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

Fixing error in GC1 found by Mark Engelberg, but fixed in GC2

Browse Source
This commit is contained in:
Jay McCarthy 2013-05-20 12:46:56 -06:00
parent d381eb5051
commit bd2d17e653
4 changed files with 51 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/plai/mutator.rkt
View File

@ -138,19 +138,23 @@
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)
(syntax-parameter-value #'mutator-env-roots))]
[mutator-tail-call? #f])
(syntax-parameterize
([mutator-env-roots
(append
(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])
expr)]
...)
(let-values ([(id ...) (values tmp ...)]

19
collects/plai/private/gc-transformer.rkt
View File

@ -1,6 +1,11 @@
#lang scheme
(provide/contract (find-referenced-locals ((listof identifier?) syntax? . -> . (listof identifier?))))
(provide/contract
(find-referenced-locals ((listof identifier?) syntax? . -> . (listof identifier?)))
[switch-over (-> (listof identifier?)
(listof identifier?)
(listof identifier?)
(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)))
@ -16,5 +21,13 @@
(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)))
(find stx)
(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))))

4
collects/tests/plai/gc/good-collectors/good-collector.rkt
View File

@ -152,6 +152,7 @@ A collector for use in testing the random mutator generator.
(define (collect-garbage get-roots)
(let ([roots (map read-root (get-roots))])
;; (eprintf "roots: ~a\n" roots)
(collect-garbage-help roots
(remove* roots (get-all-records 0)))))
@ -164,6 +165,7 @@ A collector for use in testing the random mutator generator.
(let ([proc (heap-ref (+ (car gray) 1))])
(if (procedure? proc)
(let ([new-locs (map read-root (procedure-roots proc))])
;; (eprintf "proc roots: ~a\n" new-locs)
(collect-garbage-help
(add-in new-locs (cdr gray) white)
(remove* new-locs white)))
@ -281,4 +283,4 @@ A collector for use in testing the random mutator generator.
(with-roots (list 1 2 3)
(with-roots (list 4 5 6)
(sort (get-root-set) <))))
(list 1 2 3 4 5 6))
(list 1 2 3 4 5 6))

19
collects/tests/plai/gc/good-mutators/me-let.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang plai/mutator
(allocator-setup "../good-collectors/good-collector.rkt" 20)
2 4 6 8 10 12 14
(define g
(let [[i 1] ;; 2
[j 2] ;; 4
[k 3] ;; 6
[m 4] ;; 8 <-- GC
[n 5] ;; 10
[o 6] ;; 12
[p 7]] ;; 14
;; 16
(lambda (x) (+ i j k m n o p))))
;; 18 for the 8
(g 8)
;; 20 for the answer