diff --git a/collects/plai/gc2/mutator.rkt b/collects/plai/gc2/mutator.rkt index 824adf9b3b..5ff75e02a9 100644 --- a/collects/plai/gc2/mutator.rkt +++ b/collects/plai/gc2/mutator.rkt @@ -225,10 +225,11 @@ [(_ fe ae ...) (with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)]) (if (syntax-parameter-value #'mutator-tail-call?) - ; If this call is in tail position, we will not need access to its environment when it returns. + ; If this call is in tail position, we will not need access + ; to its environment when it returns. (syntax/loc stx ((deref-proc fe) ae ...)) - ; If this call is not in tail position, we make the environment at the call site - ; reachable. + ; If this call is not in tail position, we make the + ; environment at the call site reachable. #`(with-continuation-mark gc-roots-key (list (make-env-root env-id) ...) #,(syntax/loc stx ((deref-proc fe) ae ...)))))])) @@ -363,6 +364,7 @@ (syntax-local-introduce #'scheme))]) #`(begin (require (only-in source [id renamed-id] ...)) + ;; XXX make a macro to unify this and provide/lift (define id (lambda args (unless (andmap (lambda (v) (and (location? v) (collector:flat? v))) args) @@ -409,7 +411,21 @@ [(x (... ...)) #'(mutator-app x (... ...))] [x (identifier? #'x) - #'(collector:closure (closure-code 0 (mutator-lift id)) (vector))])))) + ;; XXX Make a macro to unify this and mutator-lambda + (with-syntax + ([(env-id (... ...)) (syntax-parameter-value #'mutator-env-roots)]) + (if (syntax-parameter-value #'mutator-tail-call?) + (syntax/loc stx + (#%app collector:closure + (closure-code 0 (mutator-lift id)) + (vector))) + (syntax/loc stx + (with-continuation-mark + gc-roots-key + (list (make-env-root env-id) (... ...)) + (#%app collector:closure + (closure-code 0 (mutator-lift id)) + (vector))))))])))) ... (provide (rename-out [lifted-id id] ...))))])) diff --git a/collects/tests/plai/gc2/good-collectors/good-collector.rkt b/collects/tests/plai/gc2/good-collectors/good-collector.rkt index c1339bd16b..cb71b50772 100644 --- a/collects/tests/plai/gc2/good-collectors/good-collector.rkt +++ b/collects/tests/plai/gc2/good-collectors/good-collector.rkt @@ -31,6 +31,9 @@ A collector for use in testing the random mutator generator. (test (with-heap #(free free free) (n-free-blocks? 0 3)) #t) +(test (with-heap #(free free free free) + (n-free-blocks? 0 4)) + #t) (test (with-heap #(free free free) (n-free-blocks? 0 4)) #f) @@ -101,9 +104,13 @@ A collector for use in testing the random mutator generator. (define (gc:closure-env-ref a i) (if (gc:closure? a) - (heap-ref (+ a 3 i)) + (if (< i (heap-ref (+ a 2))) + (heap-ref (+ a 3 i)) + (error 'closure-env-ref "closure-env-ref out of bounds")) (error 'closure-env-ref "non closure"))) +;; XXX test + (define (gc:flat? loc) (equal? (heap-ref loc) 'flat)) (test (with-heap (vector 'free 'free 'pair 0 1 'flat 14) @@ -230,9 +237,10 @@ A collector for use in testing the random mutator generator. [(closure) (heap-set! white 'free) (heap-set! (+ white 1) 'free) - (for ([i (in-range (heap-ref (+ white 2)))]) - (heap-set! (+ white 3 i) 'free)) - (heap-set! (+ white 2) 'free)] + (define env-len (heap-ref (+ white 2))) + (heap-set! (+ white 2) 'free) + (for ([i (in-range env-len)]) + (heap-set! (+ white 3 i) 'free))] [else (error 'free! "unknown tag ~s\n" (heap-ref white))]) (free! (cdr whites)))])) @@ -264,10 +272,10 @@ A collector for use in testing the random mutator generator. (cond [(< i (heap-size)) (case (heap-ref i) - [(closure) (cons i (get-all-records (+ i 3 (heap-ref (+ i 2)))))] - [(pair) (cons i (get-all-records (+ i 3)))] - [(flat) (cons i (get-all-records (+ i 2)))] - [(free) (get-all-records (+ i 1))] + [(closure) (cons i (get-all-records (+ i 2 (heap-ref (+ i 2)) 1)))] + [(pair) (cons i (get-all-records (+ i 2 1)))] + [(flat) (cons i (get-all-records (+ i 1 1)))] + [(free) (get-all-records (+ i 0 1))] [else (error 'get-all-records "Unknown tag ~e in cell ~e" (heap-ref i) i)])] [else null])) diff --git a/collects/tests/plai/gc2/good-mutators/student-1.rkt b/collects/tests/plai/gc2/good-mutators/student-1.rkt index 431c9a9505..9437fc9a7e 100644 --- a/collects/tests/plai/gc2/good-mutators/student-1.rkt +++ b/collects/tests/plai/gc2/good-mutators/student-1.rkt @@ -15,7 +15,7 @@ ; Finally it runs the sample tests distributed with the assignment -(allocator-setup "../good-collectors/good-collector.rkt" 80) +(allocator-setup "../good-collectors/good-collector.rkt" 110) ; Helper to generate long lists (define (gen-list x) diff --git a/collects/tests/plai/gc2/good-mutators/student20111116.rkt b/collects/tests/plai/gc2/good-mutators/student20111116.rkt index 64a70d4404..4173601a99 100644 --- a/collects/tests/plai/gc2/good-mutators/student20111116.rkt +++ b/collects/tests/plai/gc2/good-mutators/student20111116.rkt @@ -1,5 +1,5 @@ #lang plai/gc2/mutator -(allocator-setup "../good-collectors/good-collector.rkt" 84) +(allocator-setup "../good-collectors/good-collector.rkt" 104) (halt-on-errors) ;(check-temps1 temps) -> boolean? diff --git a/collects/tests/plai/gc2/other-mutators/begin.rkt b/collects/tests/plai/gc2/other-mutators/begin.rkt index 8afd7d04dd..7d3c760c71 100644 --- a/collects/tests/plai/gc2/other-mutators/begin.rkt +++ b/collects/tests/plai/gc2/other-mutators/begin.rkt @@ -1,9 +1,13 @@ #lang plai/gc2/mutator -(allocator-setup "../good-collectors/good-collector.rkt" 7) +(allocator-setup "../good-collectors/good-collector.rkt" 10) +; 3 (define (go) + ; 2 (let ([obj 'z]) - 2 3 + 9 10 + ; 3 (symbol? obj))) +; 2 (go) diff --git a/collects/tests/plai/gc2/run-test.rkt b/collects/tests/plai/gc2/run-test.rkt index d5390cfaaf..3c7805f12e 100644 --- a/collects/tests/plai/gc2/run-test.rkt +++ b/collects/tests/plai/gc2/run-test.rkt @@ -56,7 +56,7 @@ END (capture-output (test-mutator (build-path here "other-mutators" "begin.rkt"))) => #<