suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix a bug in the way let-values decided which variables are roots

Browse Source 
also, Rackety
This commit is contained in:
Robby Findler 2013-03-08 16:23:09 -06:00
parent eb41882843
commit 46eb91b578
2 changed files with 43 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/plai/gc2/mutator.rkt
View File

@ -141,41 +141,38 @@
(raise-syntax-error 'set! "allowed only inside begin expressions and at the top-level" stx)))]))
(define-syntax (mutator-let-values stx)
(syntax-case stx ()
[(_ ([(id ...) expr]
...)
body-expr)
[(_ ([(id ...) expr] ...) body-expr)
(with-syntax ([((tmp ...) ...)
(map generate-temporaries (syntax->list #'((id ...) ...)))])
(let ([binding-list (syntax->list #'((tmp ...) ...))])
(with-syntax ([((previous-tmp ...) ...)
(let ([binding-list (syntax->list #'((id ...) ...))])
(with-syntax ([((previous-id ...) ...)
(build-list (length binding-list)
(λ (n) (append-map syntax->list (take binding-list n))))])
(syntax/loc stx
(let*-values ([(tmp ...)
(syntax-parameterize ([mutator-env-roots
(append
(find-referenced-locals
(list #'previous-tmp ...)
#'expr)
(switch-over
(syntax->list #'(id ... ...))
(syntax->list #'(tmp ... ...))
(find-referenced-locals
(list #'previous-id ...)
#'body-expr))
(syntax-parameter-value #'mutator-env-roots))]
[mutator-tail-call? #f])
(no! expr))]
...)
(let-values ([(id ...) (values tmp ...)]
...)
(let-values ([(id ...) (values tmp ...)] ...)
(syntax-parameterize ([mutator-env-roots
(append (find-referenced-locals
(list #'id ... ...)
#'body-expr)
(syntax-parameter-value #'mutator-env-roots))])
body-expr)))))))]
[(_ ([(id ...) expr]
...)
body-expr ...)
[(_ ([(id ...) expr] ...) body-expr ...)
(syntax/loc stx
(mutator-let-values
([(id ...) expr]
...)
([(id ...) expr] ...)
(mutator-begin body-expr ...)))]))
(define-syntax (mutator-lambda stx)
(syntax-case stx ()

49
collects/plai/gc2/private/gc-transformer.rkt
View File

@ -1,20 +1,33 @@
#lang scheme
#lang racket/base
(require racket/contract
racket/dict)
(provide
(contract-out
[find-referenced-locals (-> (listof identifier?) syntax? (listof identifier?))]
[switch-over (-> (listof identifier?) (listof identifier?) (listof identifier?) (listof identifier?))]))
(provide/contract (find-referenced-locals ((listof identifier?) syntax? . -> . (listof identifier?))))
(define (find-referenced-locals env-ids stx)
(local ([define id-hash (make-custom-hash free-identifier=?
(λ (v) (equal-hash-code (syntax->datum v)))
(λ (v) (equal-secondary-hash-code (syntax->datum v))))]
[define (find stx)
(syntax-case stx ()
[(head . tail)
(begin
(find #'head)
(find #'tail))]
[id (identifier? stx)
(begin
(unless (dict-ref id-hash stx false)
(dict-set! id-hash stx true)))]
[_ (void)])])
(find stx)
(filter (λ (env-id) (dict-ref id-hash env-id false)) env-ids)))
(define id-hash
(make-custom-hash free-identifier=?
(λ (v) (equal-hash-code (syntax->datum v)))
(λ (v) (equal-secondary-hash-code (syntax->datum v)))))
(let find ([stx stx])
(syntax-case stx ()
[(head . tail)
(begin
(find #'head)
(find #'tail))]
[id (identifier? stx)
(unless (dict-ref id-hash stx #false)
(dict-set! id-hash stx #true))]
[_ (void)]))
(filter (λ (env-id) (dict-ref id-hash env-id #false)) env-ids))
(define (switch-over src-ids dest-ids to-switch)
(for/list ([id (in-list to-switch)])
(or (for/or ([src-id (in-list src-ids)]
[dest-id (in-list dest-ids)])
(and (free-identifier=? src-id id)
dest-id))
(error 'switch-over "didn't find src-id for ~s" id))))