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)))])) (raise-syntax-error 'set! "allowed only inside begin expressions and at the top-level" stx)))]))
(define-syntax (mutator-let-values stx) (define-syntax (mutator-let-values stx)
(syntax-case stx () (syntax-case stx ()
[(_ ([(id ...) expr] [(_ ([(id ...) expr] ...) body-expr)
...)
body-expr)
(with-syntax ([((tmp ...) ...) (with-syntax ([((tmp ...) ...)
(map generate-temporaries (syntax->list #'((id ...) ...)))]) (map generate-temporaries (syntax->list #'((id ...) ...)))])
(let ([binding-list (syntax->list #'((tmp ...) ...))]) (let ([binding-list (syntax->list #'((id ...) ...))])
(with-syntax ([((previous-tmp ...) ...) (with-syntax ([((previous-id ...) ...)
(build-list (length binding-list) (build-list (length binding-list)
(λ (n) (append-map syntax->list (take binding-list n))))]) (λ (n) (append-map syntax->list (take binding-list n))))])
(syntax/loc stx (syntax/loc stx
(let*-values ([(tmp ...) (let*-values ([(tmp ...)
(syntax-parameterize ([mutator-env-roots (syntax-parameterize ([mutator-env-roots
(append (append
(find-referenced-locals (switch-over
(list #'previous-tmp ...) (syntax->list #'(id ... ...))
#'expr) (syntax->list #'(tmp ... ...))
(find-referenced-locals
(list #'previous-id ...)
#'body-expr))
(syntax-parameter-value #'mutator-env-roots))] (syntax-parameter-value #'mutator-env-roots))]
[mutator-tail-call? #f]) [mutator-tail-call? #f])
(no! expr))] (no! expr))]
...) ...)
(let-values ([(id ...) (values tmp ...)] (let-values ([(id ...) (values tmp ...)] ...)
...)
(syntax-parameterize ([mutator-env-roots (syntax-parameterize ([mutator-env-roots
(append (find-referenced-locals (append (find-referenced-locals
(list #'id ... ...) (list #'id ... ...)
#'body-expr) #'body-expr)
(syntax-parameter-value #'mutator-env-roots))]) (syntax-parameter-value #'mutator-env-roots))])
body-expr)))))))] body-expr)))))))]
[(_ ([(id ...) expr] [(_ ([(id ...) expr] ...) body-expr ...)
...)
body-expr ...)
(syntax/loc stx (syntax/loc stx
(mutator-let-values (mutator-let-values
([(id ...) expr] ([(id ...) expr] ...)
...)
(mutator-begin body-expr ...)))])) (mutator-begin body-expr ...)))]))
(define-syntax (mutator-lambda stx) (define-syntax (mutator-lambda stx)
(syntax-case 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) (define (find-referenced-locals env-ids stx)
(local ([define id-hash (make-custom-hash free-identifier=? (define id-hash
(λ (v) (equal-hash-code (syntax->datum v))) (make-custom-hash free-identifier=?
(λ (v) (equal-secondary-hash-code (syntax->datum v))))] (λ (v) (equal-hash-code (syntax->datum v)))
[define (find stx) (λ (v) (equal-secondary-hash-code (syntax->datum v)))))
(syntax-case stx () (let find ([stx stx])
[(head . tail) (syntax-case stx ()
(begin [(head . tail)
(find #'head) (begin
(find #'tail))] (find #'head)
[id (identifier? stx) (find #'tail))]
(begin [id (identifier? stx)
(unless (dict-ref id-hash stx false) (unless (dict-ref id-hash stx #false)
(dict-set! id-hash stx true)))] (dict-set! id-hash stx #true))]
[_ (void)])]) [_ (void)]))
(find stx) (filter (λ (env-id) (dict-ref id-hash env-id #false)) env-ids))
(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))))