Finalizing initial pass on GC2

It was not a problem with the particular collector. All allocation
sites need to update the gc-roots-key with their static information.

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
+           ; If this call is not in tail position, we make the
-           ; reachable.
+           ; 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]
                                 ...))))]))

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)
+      (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)))])
+          (define env-len (heap-ref (+ white 2)))
-               (heap-set! (+ white 3 i) 'free))          
+          (heap-set! (+ white 2) 'free)
-          (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)))))]
+       [(closure) (cons i (get-all-records (+ i 2 (heap-ref (+ i 2)) 1)))]
-       [(pair) (cons i (get-all-records (+ i 3)))]
+       [(pair) (cons i (get-all-records (+ i 2 1)))]
-       [(flat) (cons i (get-all-records (+ i 2)))]
+       [(flat) (cons i (get-all-records (+ i 1 1)))]
-       [(free) (get-all-records (+ i 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]))
 

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)

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?

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)

collects/tests/plai/gc2/run-test.rkt

@@ -56,7 +56,7 @@ END
   (capture-output (test-mutator (build-path here "other-mutators" "begin.rkt")))
  =>
  #<<END
-Value at location 2:
+Value at location 8:
 #t
 
 END