diff --git a/collects/plai/mutator.ss b/collects/plai/mutator.ss
index acecb1adb7..1e8f204ab1 100644
--- a/collects/plai/mutator.ss
+++ b/collects/plai/mutator.ss
@@ -84,11 +84,11 @@
     [(_ (f a ...) e ...)
      (mutator-define-values (f) 
                             (syntax-parameterize ([mutator-name #'f])
-                                                  (mutator-lambda (a ...) e ...)))]
+                                                 (mutator-lambda (a ...) e ...)))]
     [(_ id e)
      (mutator-define-values (id) 
                             (syntax-parameterize ([mutator-name #'id])
-                                                  e))]))
+                                                 e))]))
 (define-syntax-rule (mutator-let ([id e] ...) be ...)
   (mutator-let-values ([(id) (syntax-parameterize ([mutator-name #'id])
                                                   e)]
@@ -272,25 +272,19 @@
               (gc->scheme result-addr)])])))]))
 
 ; Module Begin
-(define-for-syntax required-allocator-stx false)
-
 (define-for-syntax (allocator-setup-internal stx)
-  (with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons 
-                                 gc:first gc:rest 
-                                 gc:flat? gc:cons?
-                                 gc:set-first! gc:set-rest!)
-                 (map (λ (s) (datum->syntax stx s))
-                      '(init-allocator gc:deref gc:alloc-flat gc:cons 
-                                       gc:first gc:rest 
-                                       gc:flat? gc:cons?
-                                       gc:set-first! gc:set-rest!))])
-    (syntax-case stx ()
-      [(collector-module heap-size)
+  (syntax-case stx ()
+    [(collector-module heap-size)
+     (with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons 
+                                    gc:first gc:rest 
+                                    gc:flat? gc:cons?
+                                    gc:set-first! gc:set-rest!)
+                    (map (λ (s) (datum->syntax stx s))
+                         '(init-allocator gc:deref gc:alloc-flat gc:cons 
+                                          gc:first gc:rest 
+                                          gc:flat? gc:cons?
+                                          gc:set-first! gc:set-rest!))]) 
        (begin
-         (set! required-allocator-stx 
-               (if (alternate-collector)
-                   (datum->syntax stx (alternate-collector))
-                   #'collector-module))
          #`(begin
              #,(if (alternate-collector)
                    #`(require #,(datum->syntax #'collector-module (alternate-collector)))
@@ -311,10 +305,10 @@
                (if (<= (#%datum . heap-size) 500)
                    (set-ui! (dynamic-require `plai/private/gc-gui 'heap-viz%))
                    (printf "Large heap; the heap visualizer will not be displayed.~n")))
-             (init-allocator)))]
-      [_ (raise-syntax-error 'mutator 
-                             "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)"
-                             stx)])))
+             (init-allocator))))]
+    [_ (raise-syntax-error 'mutator 
+                           "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)"
+                           stx)]))
 
 (define-for-syntax allocator-setup-error-msg
   "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)")
diff --git a/collects/tests/plai/gc/bad-mutators/void-app.ss b/collects/tests/plai/gc/bad-mutators/void-app.ss
index 2e2e9e8a6f..4b3ebdf11c 100644
--- a/collects/tests/plai/gc/bad-mutators/void-app.ss
+++ b/collects/tests/plai/gc/bad-mutators/void-app.ss
@@ -1,4 +1,4 @@
 #lang plai/mutator
-(allocator-setup "../good-collectors/no-compact-cheat.ss" 100)
+(allocator-setup "../good-collectors/good-collector.ss" 100)
 (define x (cons 1 2))
 ((set-first! x 2) 1)
\ No newline at end of file
diff --git a/collects/tests/plai/gc/good-collectors/good-collector.ss b/collects/tests/plai/gc/good-collectors/good-collector.ss
index 864d3811ac..ab2c20ff96 100644
--- a/collects/tests/plai/gc/good-collectors/good-collector.ss
+++ b/collects/tests/plai/gc/good-collectors/good-collector.ss
@@ -1,129 +1,86 @@
 #lang plai/collector
-; This collector was written by Robby.
-; It is advanced and particular enough, that I do not expect a student would be brazen enough to copy or plagiarize it, so it is public.
-
-(print-only-errors #t)
 
 #|
 
-heap-layout:
-
- 0 during gc   : left-side of queue
-   non-gc time : free pointer
- 1 during-gc   : right-side-of-queue
-   non-gc time : out of memory pointer
- 2 '()
- 3 #f
- 4 #t
- 5 0
- 6 1
- 7 2
- 8 3
- 9 4
- 10 .... (n-10/2): space 1.
- (n-10/2)+1 ... n: space 2.
+A collector for use in testing the random mutator generator.
 
 |#
 
-;; the bounds on the initial half of a heap.
-(define (first-start) 10)
-(define (second-start) 
-  (unless (even? (- (heap-size) (first-start)))
-    (error 'second-start "bad heap size ~s" (heap-size)))
-  (+ (first-start) (/ (- (heap-size) (first-start)) 2)))
+(print-only-errors #t)
+
+(define (find-free-space start size)
+  (cond
+    [(= start (heap-size))
+     #f]
+    [(n-free-blocks? start size)
+     start]
+    [else
+     (find-free-space (+ start 1) size)]))
+
+(define (n-free-blocks? start size)
+  (cond
+    [(= size 0) #t]
+    [(= start (heap-size)) #f]
+    [else 
+     (and (eq? 'free (heap-ref start))
+          (n-free-blocks? (+ start 1) (- size 1)))]))
+
+(test (with-heap #(free free free)
+                 (n-free-blocks? 0 2))
+      #t)
+(test (with-heap #(free free free)
+                 (n-free-blocks? 0 3))
+      #t)
+(test (with-heap #(free free free)
+                 (n-free-blocks? 0 4))
+      #f)
+(test (with-heap #(free free free)
+                 (n-free-blocks? 2 1))
+      #t)
+(test (with-heap #(free free free)
+                 (n-free-blocks? 2 2))
+      #f)
+
+(test (with-heap #(free free free)
+                 (find-free-space 0 1))
+      0)
+(test (with-heap #(pair free free)
+                 (find-free-space 0 1))
+      1)
+(test (with-heap #(pair free free)
+                 (find-free-space 0 2))
+      1)
+(test (with-heap #(pair free free)
+                 (find-free-space 0 3))
+      #f)
 
 (define (init-allocator) 
-  (unless (even? (heap-size))
-    (error 'two-space.ss "must have an even sized heap"))
-  (when (<= (heap-size) 10)
-    (error 'two-space.ss "heap too small"))
   (for ([i (in-range 0 (heap-size))])
-    (heap-set!
-     i
-     (cond
-       [(= i 0) (first-start)]
-       [(= i 1) (second-start)]
-       [(immediate-loc? i) (immediate-loc->val i)]
-       [(< i (second-start)) 'free]
-       [else 'bad]))))
-
-(define (immediate-loc? i) (< 1 i (first-start)))
-
-(define (immediate-loc->val i)
-  (case i
-    [(2) #f]
-    [(3) #t]
-    [(4) '()]
-    [else (- i 5)]))
-
-(define (immediate-val? v)
-  (or (and (exact-integer? v)
-           (<= 0 v 4))
-      (eq? v #t)
-      (eq? v #f)
-      (eq? v null)))
-
-(define (immediate-val->loc v)
-  (case v
-    [(#f) 2]
-    [(#t) 3]
-    [(()) 4]
-    [else (+ v 5)]))
-
-(test (immediate-loc? 1) #f)
-(test (immediate-loc? 2) #t)
-(test (immediate-loc? 4) #t)
-(test (immediate-loc? 10) #f)
-(test (immediate-loc->val 5) 0)
-(test (immediate-loc->val 4) '())
-(test (immediate-val->loc (immediate-loc->val 2)) 2)
-(test (immediate-val->loc (immediate-loc->val 3)) 3)
-(test (immediate-val->loc (immediate-loc->val 4)) 4)
-(test (immediate-val->loc (immediate-loc->val 5)) 5)
-(test (immediate-val->loc (immediate-loc->val 6)) 6)
-(test (immediate-val->loc (immediate-loc->val 7)) 7)
-(test (immediate-val->loc (immediate-loc->val 8)) 8)
-(test (immediate-val->loc (immediate-loc->val 9)) 9)
-
-(define (mkheap alloc-ptr alloc-stop . args)
-  (unless (and (number? alloc-ptr) (number? alloc-stop))
-    (error 'mkheap "expected numbers for first two args, got ~e and ~e" alloc-ptr alloc-stop))
-  (apply vector (append (list alloc-ptr alloc-stop  #f #t '() 0 1 2 3 4) args)))
+    (heap-set! i 'free)))
 
 (test (let ([v (make-vector 12 'x)])
         (with-heap v (init-allocator))
         v)
-      (mkheap 10 11 'free 'bad))
-
-(test (let ([v (make-vector 20 'x)])
-        (with-heap v (init-allocator))
-        v)
-      (mkheap 10 15
-              'free 'free 'free 'free 'free
-              'bad  'bad  'bad  'bad  'bad))
+      (make-vector 12 'free))
 
 (define (gc:deref loc) 
   (cond
-    [(immediate-loc? loc)
-     (immediate-loc->val loc)]
     [(equal? (heap-ref loc) 'flat)
      (heap-ref (+ loc 1))]
     [else
      (error 'gc:deref "attempted to deref a non flat value, loc ~s" loc)]))
 
-(test (with-heap (mkheap 10 20 'flat 14)
-                 (gc:deref 10))
+(test (with-heap (vector 'free 'free 'free 'flat 14 'free 'free)
+                 (gc:deref 3))
       14)
-(test (gc:deref 2) #f)
-(test (gc:deref 3) #t)
 
 (define (gc:first pr-ptr) 
   (if (equal? (heap-ref pr-ptr) 'pair)
       (heap-ref (+ pr-ptr 1))
       (error 'first "non pair")))
 
-(test (with-heap (mkheap 10 20 'pair 0 1)
-                 (gc:first 10))
+(test (with-heap (vector 'free 'flat 3 'pair 0 1)
+                 (gc:first 3))
       0)
 
 (define (gc:rest pr-ptr) 
@@ -131,39 +88,25 @@ heap-layout:
       (heap-ref (+ pr-ptr 2))
       (error 'first "non pair")))
 
-(test (with-heap (mkheap 10 20 'pair 0 1)
-                 (gc:rest 10))
+(test (with-heap (vector 'free 'flat 3 'pair 0 1)
+                 (gc:rest 3))
       1)
 
-(define (gc:flat? loc) 
-  (cond
-    [(< loc (first-start)) #t]
-    [(equal? (heap-ref loc) 'flat) #t]
-    [else #f]))
+(define (gc:flat? loc) (equal? (heap-ref loc) 'flat))
 
-(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
-                 (gc:flat? 12))
+(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
+                 (gc:flat? 2))
       #f)
-(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
-                 (gc:flat? 15))
-      #t)
-(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
+(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
                  (gc:flat? 5))
       #t)
 
-(define (gc:cons? loc) 
-  (cond
-    [(< loc (first-start)) #f]
-    [else
-     (equal? (heap-ref loc) 'pair)]))
+(define (gc:cons? loc) (equal? (heap-ref loc) 'pair))
 
-(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
-                 (gc:cons? 12))
+(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
+                 (gc:cons? 2))
       #t)
-(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
-                 (gc:cons? 15))
-      #f)
-(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
+(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
                  (gc:cons? 5))
       #f)
 
@@ -172,375 +115,160 @@ heap-layout:
       (heap-set! (+ pr-ptr 1) new)
       (error 'set-first! "non pair")))
 
-(test (let ([h (mkheap 10 20 'pair 2 2)])
-        (with-heap h (gc:set-first! 10 3))
-        h)
-      (mkheap 10 20 'pair 3 2))
-
 (define (gc:set-rest! pr-ptr new) 
   (if (equal? (heap-ref pr-ptr) 'pair)
       (heap-set! (+ pr-ptr 2) new)
       (error 'set-first! "non pair")))
 
-(test (let ([h (mkheap 10 20 'pair 2 2)])
-        (with-heap h (gc:set-rest! 10 3))
-        h)
-      (mkheap 10 20 'pair 2 3))
 
-(define (gc:alloc-flat fv)
-  (cond
-    [(immediate-val? fv)
-     (immediate-val->loc fv)]
-    [else
-     (let ([ptr (alloc 2)])
-       (cond
-         [ptr
-          (fill-in-flat ptr fv)]
-         [else
-          (init-gc)
-          (when (procedure? fv)
-            (move-roots (procedure-roots fv)))
-          (collect-garbage)
-          (let ([ptr (alloc 2)])
-            (unless ptr
-              (error 'two-space.ss "out of memory"))
-            (fill-in-flat ptr fv))]))]))
+(define (gc:alloc-flat fv) 
+  (let ([ptr (alloc 2 (λ () 
+                        (if (procedure? fv)
+                            (append (procedure-roots fv)
+                                    (get-root-set))
+                            (get-root-set))))])
+    (heap-set! ptr 'flat)
+    (heap-set! (+ ptr 1) fv)
+    ptr))
 
-(define (fill-in-flat ptr fv)
-  (heap-set! ptr 'flat)
-  (heap-set! (+ ptr 1) fv)
-  ptr)
-  
 (define (gc:cons hd tl)
-  (let ([ptr (alloc 3)])
-    (cond
-      [ptr
-       (fill-in-cons ptr hd tl)]
-      [else
-       (init-gc)
-       (let ([new-hd (move-loc hd)]
-             [new-tl (move-loc tl)])
-         (collect-garbage)
-         (let ([ptr (alloc 3)])
-           (unless ptr
-             (error 'two-space.ss "out of memory"))
-           (fill-in-cons ptr new-hd new-tl)))])))
+  (let ([ptr (alloc 3 (λ () (get-root-set hd tl)))])
+    (heap-set! ptr 'pair)
+    (heap-set! (+ ptr 1) hd)
+    (heap-set! (+ ptr 2) tl)
+    ptr))
 
-(define (fill-in-cons ptr hd tl)
-  (heap-set! ptr 'pair)
-  (heap-set! (+ ptr 1) hd)
-  (heap-set! (+ ptr 2) tl)
-  ptr)
-
-;; alloc : number -> boolean
-;; returns #f if nothing can be allocated
-(define (alloc n)
-  (let ([next (heap-ref 0)])
+(define (alloc n get-roots)
+  (let ([next (find-free-space 0 n)])
     (cond
-      [(<= (+ next n) (heap-ref 1))
-       (heap-set! 0 (+ next n))
+      [next
        next]
       [else
-       #f])))
+       (collect-garbage get-roots)
+       (let ([next (find-free-space 0 n)])
+         (unless next
+           (error 'alloc "out of space"))
+         next)])))
 
-(test (let ([h (mkheap 16 16
-                       'fwd  17    'flat 112   'pair 10    10
-                       'free 'free 'free 'free 'free 'free 'free)])
-        (with-heap h (alloc 3)))
-      #f)
+(define (collect-garbage get-roots)
+  (let ([roots (map read-root (get-roots))])
+    (collect-garbage-help roots
+                          (remove* roots (get-all-records 0)))))
 
-(test (let ([h (mkheap 10 16
-                       'free 'free 'free 'free 'free 'free 'free
-                       'free 'free 'free 'free 'free 'free 'free)])
-        (with-heap h (alloc 3))
-        h)
-      (mkheap 13 16
-              'free 'free 'free 'free 'free 'free 'free
-              'free 'free 'free 'free 'free 'free 'free))
-
-(define (init-gc)
+(define (collect-garbage-help gray white)
   (cond
-    [(< (heap-ref 0) (second-start))
-     (heap-set! 0 (second-start))]
+    [(null? gray) (free! white)]
     [else
-     (heap-set! 0 (first-start))])
-  (heap-set! 1 (heap-ref 0)))
-
-(test (let ([h (mkheap 16 16
-                       'fwd  17    'flat 112   'pair 10    10
-                       'free 'free 'free 'free 'free 'free 'free)])
-        (with-heap h (init-gc))
-        h)
-      (mkheap 17 17
-              'fwd  17    'flat 112   'pair 10    10
-              'free 'free 'free 'free 'free 'free 'free))
-
-(test (let ([h (mkheap 15 16
-                       'fwd  17    'flat 112   'pair 10    10
-                       'free 'free 'free 'free 'free 'free 'free)])
-        (with-heap h (init-gc))
-        h)
-      (mkheap 17 17
-              'fwd  17    'flat 112   'pair 10    10
-              'free 'free 'free 'free 'free 'free 'free))
-
-(define (finalize-gc)
-  (heap-set! 0 (heap-ref 1))
-  (cond
-    [(< (heap-ref 0) (second-start))
-     (heap-set! 1 (second-start))
-     (for ([i (in-range (second-start) (heap-size))])
-       (heap-set! i 'bad))]
-    [else
-     (heap-set! 1 (heap-size))
-     (for ([i (in-range (first-start) (second-start))])
-       (heap-set! i 'bad))])
-  (for ([i (in-range (heap-ref 0) (heap-ref 1))])
-    (heap-set! i 'free)))
-
-(test (let ([h (mkheap 20 20
-                       'flat 17 'flat 12    'free 'free 'free
-                       'pair 12  10   'free 'free 'free 'free)])
-        (with-heap h (finalize-gc))
-        h)
-      (mkheap 20 24
-              'bad  'bad 'bad 'bad  'bad  'bad  'bad
-              'pair 12   10   'free 'free 'free 'free))
-
-(test (let ([h (mkheap 14 14
-                       'flat 17 'flat 12    'free 'free 'free
-                       'pair 12  10   'free 'free 'free 'free)])
-        (with-heap h (finalize-gc))
-        h)
-      (mkheap 14 17
-              'flat 17 'flat 12    'free 'free 'free
-              'bad  'bad 'bad 'bad  'bad  'bad  'bad))
-
-(define (collect-garbage)
-  (move-roots (get-root-set))
-  (copy-data)
-  (finalize-gc))
-  
-;; move-roots : (listof roots) -> void
-(define (move-roots roots)
-  (cond
-    [(null? roots) (void)]
-    [else 
-     (set-root! (car roots) (move-loc (read-root (car roots))))
-     (move-roots (cdr roots))]))
-
-;; move-loc : loc[from-space] -> loc[to-space]
-(define (move-loc loc)
-  (cond
-    [(immediate-loc? loc)
-     loc]
-    [else
-     (case (heap-ref loc)
-       [(fwd) (heap-ref (+ loc 1))]
-       [(pair) 
-        (let ([dest (heap-ref 1)])
-          (heap-set! dest 'pair)
-          (heap-set! (+ dest 1) (heap-ref (+ loc 1)))
-          (heap-set! (+ dest 2) (heap-ref (+ loc 2)))
-          (heap-set! 1 (+ dest 3))
-          (heap-set! loc 'fwd)
-          (heap-set! (+ loc 1) dest)
-          (heap-set! (+ loc 2) 'junk)
-          dest)]
+     (case (heap-ref (car gray))
        [(flat) 
-        (let ([dest (heap-ref 1)])
-          (heap-set! dest 'flat)
-          (heap-set! (+ dest 1) (heap-ref (+ loc 1)))
-          (heap-set! 1 (+ dest 2))
-          (heap-set! loc 'fwd)
-          (heap-set! (+ loc 1) dest)
-          dest)]
+        (let ([proc (heap-ref (+ (car gray) 1))])
+          (if (procedure? proc)
+              (let ([new-locs (map read-root (procedure-roots proc))])
+                (collect-garbage-help 
+                 (add-in new-locs (cdr gray) white)
+                 (remove* new-locs white)))
+              (collect-garbage-help (cdr gray) white)))]
+       [(pair) 
+        (let ([hd (heap-ref (+ (car gray) 1))]
+              [tl (heap-ref (+ (car gray) 2))])
+          (collect-garbage-help 
+           (add-in (list hd tl) (cdr gray) white)
+           (remove tl (remove hd white))))]
        [else
-        (error 'move-loc "found a non-tag at location ~a" loc)])]))
+        (error 'collect-garbage "unknown tag ~s, loc ~s" (heap-ref (car gray)) (car gray))])]))
 
-(test (move-loc 4) 4)
-
-(test (let ([v (mkheap 15 15 
-                       'fwd   17 'free 'free 'free 
-                       'free 'free 'free 'free 'free)])
-        (list (with-heap v (move-loc 10))
-              v))
-      (list 17
-            (mkheap 15 15 
-                    'fwd   17   'free 'free 'free 
-                    'free 'free 'free 'free 'free)))
-
-(test (let ([v (mkheap 15 15 
-                       'flat 13 'free 'free 'free 
-                       'free 'free 'free 'free 'free)])
-        (list (with-heap v (move-loc 10))
-              v))
-      (list 15
-            (mkheap 15 17
-                    'fwd  15 'free 'free 'free
-                    'flat 13 'free 'free 'free)))
-
-(test (let ([v (mkheap 15 15 
-                       'pair 10 10 'free 'free 
-                       'free 'free 'free 'free 'free)])
-        (list (with-heap v (move-loc 10))
-              v))
-      (list 15
-            (mkheap 15 18
-                    'fwd  15 'junk 'free 'free
-                    'pair 10 10 'free 'free)))
-
-(define (copy-data)
-  (let ([left (heap-ref 0)]
-        [right (heap-ref 1)])
-  (when (< left right)
-    (case (heap-ref left)
-      [(pair)
-       (maybe-move/loc left 1)
-       (maybe-move/loc left 2)
-       (heap-set! 0 (+ left 3))]
-      [(flat)
-       (heap-set! 0 (+ left 2))]
-      [(proc)
-       (maybe-move/roots left (procedure-roots (heap-ref (+ left 1))))
-       (heap-set! 0 (+ left 2))]
-      [else
-       (error 'copy-data "unknown tag ~s" (heap-ref left))])
-    (copy-data))))
-
-;; maybe-move/loc : loc[to-space] offset -> void
-;; moves the pointer at record+offset if it is in a different
-;; semispace from record.
-(define (maybe-move/loc record delta)
-  (let ([pointer (heap-ref (+ record delta))])
-    (unless (different-halves? record pointer)
-      (error 'maybe-move/loc "tried to move a pointer that was in the from space already ~s ~s" record pointer))
-    ;; now we know pointer is in the from-space
-    (heap-set! (+ record delta) (move-loc pointer))))
-
-;; maybe-move/roots : loc[to-space] (listof root) -> void
-(define (maybe-move/roots record roots)
+(define (free! whites)
   (cond
-    [(null? roots) (void)]
-    [else 
-     (maybe-move/root record (car roots))
-     (maybe-move/roots record (cdr roots))]))
-
-;; maybe-move/root : loc[to-space] root -> void
-;; moves the pointer in the root if it is in a different
-;; semispace from record.
-(define (maybe-move/root record root)
-  (let ([pointer (read-root root)])
-    (unless (different-halves? record pointer)
-      (error 'maybe-move/root "tried to move a pointer that was in the from space already"))
-    ;; now we know pointer is in the from-space
-    (set-root! root (move-loc pointer))))
-  
-;; different-halves? : loc loc -> boolean
-;; returns #t if n and m are in different halves of the heap.
-(define (different-halves? n m)
-  (cond
-    [(or (immediate-loc? n) 
-         (immediate-loc? m))
-     #f]
+    [(null? whites) (void)]
     [else
-     (not (equal? (< n (second-start))
-                  (< m (second-start))))]))
-     
-(test (different-halves? 2 3) #f)
+     (let ([white (car whites)])
+       (case (heap-ref white)
+         [(pair) 
+          (heap-set! white 'free)
+          (heap-set! (+ white 1) 'free)
+          (heap-set! (+ white 2) 'free)]
+         [(flat)
+          (heap-set! white 'free)
+          (heap-set! (+ white 1) 'free)]
+         [else 
+          (error 'free! "unknown tag ~s\n" (heap-ref white))])
+       (free! (cdr whites)))]))
 
-(test (with-heap (mkheap 10 15 
-                         'free 'free 'free 'free 'free
-                         'free 'free 'free 'free 'free)
-                 (different-halves? 12 13))
-      #f)
-(test (with-heap (mkheap 10 15 
-                         'free 'free 'free 'free 'free
-                         'free 'free 'free 'free 'free)
-                 (different-halves? 12 17))
-      #t)
-(test (with-heap (mkheap 10 15 
-                         'free 'free 'free 'free 'free
-                         'free 'free 'free 'free 'free)
-                 (different-halves? 16 17))
-      #f)
-(test (with-heap (mkheap 10 15 
-                         'free 'free 'free 'free 'free
-                         'free 'free 'free 'free 'free)
-                 (different-halves? 17 12))
-      #t)
+(test (let ([v (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)])
+        (with-heap v (free! (list 10 18)))
+        v)
+      (vector #f #t '() 0 1 2 3 4 5 6 'free 'free 'free 'flat 14 'pair 0 1  'free 'free))
+      
+;; add-in : (listof location) (listof location) (listof location) -> (listof location)
+;; computes a new set of gray addresses by addding all white elements of locs to gray
+(define (add-in locs gray white)
+  (cond
+    [(null? locs) gray]
+    [else
+     (let* ([loc (car locs)]
+            [white? (member loc white)])
+       (add-in (cdr locs)
+               (if white? (cons loc gray) gray)
+               white))]))
 
-(test (with-heap (mkheap 17 20
-                         'fwd  17 'junk 'free 'free 'free 'free
-                         'pair 11  11   'free 'free 'free 'free)
-                 (different-halves? 17 11))
-      #t)
+(test (add-in '(13 14) '(100 102) '(13 14 104 105))
+      '(14 13 100 102))
 
-(test (let ([h (mkheap 17 22
-                       'fwd  17    'free 'free 'free 'free 'free
-                       'flat 11    'pair  17   10    'free 'free)])
-        (with-heap h (maybe-move/loc 19 2))
-        h)
-      (mkheap 17 22
-              'fwd  17    'free 'free 'free 'free 'free
-              'flat 11    'pair  17   17    'free 'free))
+(test (add-in '(13 14) '(100 102) '(13 104 105))
+      '(13 100 102))
 
-(test (let ([h (mkheap 17 22
-                       'flat 12    'free 'free 'free 'free 'free
-                       'flat 11    'pair  17   10    'free 'free)])
-        (with-heap h (maybe-move/loc 19 2))
-        h)
-      (mkheap 17 24
-              'fwd  22    'free 'free 'free 'free 'free
-              'flat 11    'pair  17    22    'flat '12))
+(define (get-all-records i)
+  (cond
+    [(< i (heap-size))
+     (case (heap-ref i)
+       [(pair) (cons i (get-all-records (+ i 3)))]
+       [(flat) (cons i (get-all-records (+ i 2)))]
+       [(free) (get-all-records (+ i 1))]
+       [else (get-all-records (+ i 1))])]
+    [else null]))
 
-(test (let ([h (mkheap 17 19
-                       'free 'free 'free 'free 'free 'free 'free
-                       'flat 11    'free 'free 'free 'free 'free)])
-        (with-heap h (copy-data))
-        h)
-      (mkheap 19 19
-              'free 'free 'free 'free 'free 'free 'free
-              'flat 11    'free 'free 'free 'free 'free))
+(test (with-heap (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)
+                 (get-all-records 0))
+      (list 10 13 15 18))
 
-(test (let ([h (mkheap 17 20
-                       'fwd  17 'junk 'free 'free 'free 'free
-                       'pair 10  10   'free 'free 'free 'free)])
-        (with-heap h (copy-data))
-        h)
-      (mkheap 20 20
-              'fwd  17 'junk 'free 'free 'free 'free
-              'pair 17  17   'free 'free 'free 'free))
+(test (with-heap (make-vector 10 'free) (gc:alloc-flat #f))
+      0)
 
-(test (let ([h (mkheap 17 20
-                       'fwd  17 'flat 112   'free 'free 'free
-                       'pair 12  10   'free 'free 'free 'free)])
-        (with-heap h (copy-data))
-        h)
-      (mkheap 22 22
-              'fwd  17 'fwd  20    'free 'free 'free
-              'pair 20  17   'flat 112 'free 'free))
+(test (with-heap (make-vector 10 'free) (gc:alloc-flat #t) (gc:alloc-flat #f))
+      2)
 
-(test (gc:alloc-flat 1)
-      6)
+(test (let ([v (vector 'flat 0 'flat 1)])
+        (with-heap v (collect-garbage-help (list) 
+                                           (get-all-records 0)))
+        v)
+      (vector 'free 'free 'free 'free))
 
+(test (let ([v (vector 'flat 0 'flat 1)])
+        (with-heap v (collect-garbage-help (list 0) 
+                                           (remove 0 (get-all-records 0))))
+        v)
+      (vector 'flat 0 'free 'free))
 
-(test (let ([h (mkheap 15 17
-                       'flat 17 'pair 10    10    'free 'free
-                       'pair 12  10   'free 'free 'free 'free)])
-        (list (with-heap h (gc:alloc-flat 111))
-              h))
-      (list 15
-            (mkheap 17 17
-                    'flat  17 'pair 10    10   'flat 111
-                    'pair 12  10   'free 'free 'free 'free)))
+(test (let ([v (vector 'flat 0 'flat 1)])
+        (with-heap v (collect-garbage-help (list 2) 
+                                           (remove 2 (get-all-records 0))))
+        v)
+      (vector  'free 'free 'flat 1))
 
-(test (let ([h (mkheap 14 17
-                       'flat 17 'flat 12    'free 'free 'free
-                       'pair 12  10   'free 'free 'free 'free)])
-        (list (with-heap h (gc:cons 10 10))
-              h))
-      (list 14
-            (mkheap 17 17
-                    'flat 17 'flat 12    'pair 10    10
-                    'pair 12  10   'free 'free 'free 'free)))
+(test (let ([v (vector 'flat 0 'flat 1 'pair 0 2)])
+        (with-heap v (collect-garbage-help (list 4) 
+                                           (remove 4 (get-all-records 0))))
+        v)
+      (vector 'flat 0 'flat 1 'pair 0 2))
+
+(test (let ([v (vector 'flat 0 'flat 1 'pair 0 0)])
+        (with-heap v (collect-garbage-help (list 4) 
+                                           (remove 4 (get-all-records 0))))
+        v)
+      (vector 'flat 0 'free 'free 'pair 0 0))
+
+(test (let ([v (vector 'flat 0 'flat 1 'pair 4 4)])
+        (with-heap v (collect-garbage-help (list 4) 
+                                           (remove 4 (get-all-records 0))))
+        v)
+      (vector 'free 'free 'free 'free 'pair 4 4))
diff --git a/collects/tests/plai/gc/good-collectors/no-compact-cheat.ss b/collects/tests/plai/gc/good-collectors/no-compact-cheat.ss
deleted file mode 100644
index ab2c20ff96..0000000000
--- a/collects/tests/plai/gc/good-collectors/no-compact-cheat.ss
+++ /dev/null
@@ -1,274 +0,0 @@
-#lang plai/collector
-
-#|
-
-A collector for use in testing the random mutator generator.
-
-|#
-
-(print-only-errors #t)
-
-(define (find-free-space start size)
-  (cond
-    [(= start (heap-size))
-     #f]
-    [(n-free-blocks? start size)
-     start]
-    [else
-     (find-free-space (+ start 1) size)]))
-
-(define (n-free-blocks? start size)
-  (cond
-    [(= size 0) #t]
-    [(= start (heap-size)) #f]
-    [else 
-     (and (eq? 'free (heap-ref start))
-          (n-free-blocks? (+ start 1) (- size 1)))]))
-
-(test (with-heap #(free free free)
-                 (n-free-blocks? 0 2))
-      #t)
-(test (with-heap #(free free free)
-                 (n-free-blocks? 0 3))
-      #t)
-(test (with-heap #(free free free)
-                 (n-free-blocks? 0 4))
-      #f)
-(test (with-heap #(free free free)
-                 (n-free-blocks? 2 1))
-      #t)
-(test (with-heap #(free free free)
-                 (n-free-blocks? 2 2))
-      #f)
-
-(test (with-heap #(free free free)
-                 (find-free-space 0 1))
-      0)
-(test (with-heap #(pair free free)
-                 (find-free-space 0 1))
-      1)
-(test (with-heap #(pair free free)
-                 (find-free-space 0 2))
-      1)
-(test (with-heap #(pair free free)
-                 (find-free-space 0 3))
-      #f)
-
-(define (init-allocator) 
-  (for ([i (in-range 0 (heap-size))])
-    (heap-set! i 'free)))
-
-(test (let ([v (make-vector 12 'x)])
-        (with-heap v (init-allocator))
-        v)
-      (make-vector 12 'free))
-
-(define (gc:deref loc) 
-  (cond
-    [(equal? (heap-ref loc) 'flat)
-     (heap-ref (+ loc 1))]
-    [else
-     (error 'gc:deref "attempted to deref a non flat value, loc ~s" loc)]))
-
-(test (with-heap (vector 'free 'free 'free 'flat 14 'free 'free)
-                 (gc:deref 3))
-      14)
-
-(define (gc:first pr-ptr) 
-  (if (equal? (heap-ref pr-ptr) 'pair)
-      (heap-ref (+ pr-ptr 1))
-      (error 'first "non pair")))
-
-(test (with-heap (vector 'free 'flat 3 'pair 0 1)
-                 (gc:first 3))
-      0)
-
-(define (gc:rest pr-ptr) 
-  (if (equal? (heap-ref pr-ptr) 'pair)
-      (heap-ref (+ pr-ptr 2))
-      (error 'first "non pair")))
-
-(test (with-heap (vector 'free 'flat 3 'pair 0 1)
-                 (gc:rest 3))
-      1)
-
-(define (gc:flat? loc) (equal? (heap-ref loc) 'flat))
-
-(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
-                 (gc:flat? 2))
-      #f)
-(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
-                 (gc:flat? 5))
-      #t)
-
-(define (gc:cons? loc) (equal? (heap-ref loc) 'pair))
-
-(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
-                 (gc:cons? 2))
-      #t)
-(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
-                 (gc:cons? 5))
-      #f)
-
-(define (gc:set-first! pr-ptr new) 
-  (if (equal? (heap-ref pr-ptr) 'pair)
-      (heap-set! (+ pr-ptr 1) new)
-      (error 'set-first! "non pair")))
-
-(define (gc:set-rest! pr-ptr new) 
-  (if (equal? (heap-ref pr-ptr) 'pair)
-      (heap-set! (+ pr-ptr 2) new)
-      (error 'set-first! "non pair")))
-
-
-(define (gc:alloc-flat fv) 
-  (let ([ptr (alloc 2 (λ () 
-                        (if (procedure? fv)
-                            (append (procedure-roots fv)
-                                    (get-root-set))
-                            (get-root-set))))])
-    (heap-set! ptr 'flat)
-    (heap-set! (+ ptr 1) fv)
-    ptr))
-
-(define (gc:cons hd tl)
-  (let ([ptr (alloc 3 (λ () (get-root-set hd tl)))])
-    (heap-set! ptr 'pair)
-    (heap-set! (+ ptr 1) hd)
-    (heap-set! (+ ptr 2) tl)
-    ptr))
-
-(define (alloc n get-roots)
-  (let ([next (find-free-space 0 n)])
-    (cond
-      [next
-       next]
-      [else
-       (collect-garbage get-roots)
-       (let ([next (find-free-space 0 n)])
-         (unless next
-           (error 'alloc "out of space"))
-         next)])))
-
-(define (collect-garbage get-roots)
-  (let ([roots (map read-root (get-roots))])
-    (collect-garbage-help roots
-                          (remove* roots (get-all-records 0)))))
-
-(define (collect-garbage-help gray white)
-  (cond
-    [(null? gray) (free! white)]
-    [else
-     (case (heap-ref (car gray))
-       [(flat) 
-        (let ([proc (heap-ref (+ (car gray) 1))])
-          (if (procedure? proc)
-              (let ([new-locs (map read-root (procedure-roots proc))])
-                (collect-garbage-help 
-                 (add-in new-locs (cdr gray) white)
-                 (remove* new-locs white)))
-              (collect-garbage-help (cdr gray) white)))]
-       [(pair) 
-        (let ([hd (heap-ref (+ (car gray) 1))]
-              [tl (heap-ref (+ (car gray) 2))])
-          (collect-garbage-help 
-           (add-in (list hd tl) (cdr gray) white)
-           (remove tl (remove hd white))))]
-       [else
-        (error 'collect-garbage "unknown tag ~s, loc ~s" (heap-ref (car gray)) (car gray))])]))
-
-(define (free! whites)
-  (cond
-    [(null? whites) (void)]
-    [else
-     (let ([white (car whites)])
-       (case (heap-ref white)
-         [(pair) 
-          (heap-set! white 'free)
-          (heap-set! (+ white 1) 'free)
-          (heap-set! (+ white 2) 'free)]
-         [(flat)
-          (heap-set! white 'free)
-          (heap-set! (+ white 1) 'free)]
-         [else 
-          (error 'free! "unknown tag ~s\n" (heap-ref white))])
-       (free! (cdr whites)))]))
-
-(test (let ([v (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)])
-        (with-heap v (free! (list 10 18)))
-        v)
-      (vector #f #t '() 0 1 2 3 4 5 6 'free 'free 'free 'flat 14 'pair 0 1  'free 'free))
-      
-;; add-in : (listof location) (listof location) (listof location) -> (listof location)
-;; computes a new set of gray addresses by addding all white elements of locs to gray
-(define (add-in locs gray white)
-  (cond
-    [(null? locs) gray]
-    [else
-     (let* ([loc (car locs)]
-            [white? (member loc white)])
-       (add-in (cdr locs)
-               (if white? (cons loc gray) gray)
-               white))]))
-
-(test (add-in '(13 14) '(100 102) '(13 14 104 105))
-      '(14 13 100 102))
-
-(test (add-in '(13 14) '(100 102) '(13 104 105))
-      '(13 100 102))
-
-(define (get-all-records i)
-  (cond
-    [(< i (heap-size))
-     (case (heap-ref i)
-       [(pair) (cons i (get-all-records (+ i 3)))]
-       [(flat) (cons i (get-all-records (+ i 2)))]
-       [(free) (get-all-records (+ i 1))]
-       [else (get-all-records (+ i 1))])]
-    [else null]))
-
-(test (with-heap (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)
-                 (get-all-records 0))
-      (list 10 13 15 18))
-
-(test (with-heap (make-vector 10 'free) (gc:alloc-flat #f))
-      0)
-
-(test (with-heap (make-vector 10 'free) (gc:alloc-flat #t) (gc:alloc-flat #f))
-      2)
-
-(test (let ([v (vector 'flat 0 'flat 1)])
-        (with-heap v (collect-garbage-help (list) 
-                                           (get-all-records 0)))
-        v)
-      (vector 'free 'free 'free 'free))
-
-(test (let ([v (vector 'flat 0 'flat 1)])
-        (with-heap v (collect-garbage-help (list 0) 
-                                           (remove 0 (get-all-records 0))))
-        v)
-      (vector 'flat 0 'free 'free))
-
-(test (let ([v (vector 'flat 0 'flat 1)])
-        (with-heap v (collect-garbage-help (list 2) 
-                                           (remove 2 (get-all-records 0))))
-        v)
-      (vector  'free 'free 'flat 1))
-
-(test (let ([v (vector 'flat 0 'flat 1 'pair 0 2)])
-        (with-heap v (collect-garbage-help (list 4) 
-                                           (remove 4 (get-all-records 0))))
-        v)
-      (vector 'flat 0 'flat 1 'pair 0 2))
-
-(test (let ([v (vector 'flat 0 'flat 1 'pair 0 0)])
-        (with-heap v (collect-garbage-help (list 4) 
-                                           (remove 4 (get-all-records 0))))
-        v)
-      (vector 'flat 0 'free 'free 'pair 0 0))
-
-(test (let ([v (vector 'flat 0 'flat 1 'pair 4 4)])
-        (with-heap v (collect-garbage-help (list 4) 
-                                           (remove 4 (get-all-records 0))))
-        v)
-      (vector 'free 'free 'free 'free 'pair 4 4))
diff --git a/collects/tests/plai/gc/good-mutators/classic-error.ss b/collects/tests/plai/gc/good-mutators/classic-error.ss
index 2917d76382..468d697e4b 100755
--- a/collects/tests/plai/gc/good-mutators/classic-error.ss
+++ b/collects/tests/plai/gc/good-mutators/classic-error.ss
@@ -1,6 +1,6 @@
 #lang plai/mutator
-; This is `classic' in that caught many bugs in copying collectors that students wrote for CS173, Fall 2007.
-(allocator-setup "../good-collectors/good-collector.ss" 38)
+; This is `classic' in that it caught many bugs in copying collectors that students wrote for CS173, Fall 2007.
+(allocator-setup "../good-collectors/good-collector.ss" 28)
 
 'trash
 'junk
diff --git a/collects/tests/plai/gc/good-mutators/closure-2.ss b/collects/tests/plai/gc/good-mutators/closure-2.ss
index a28527827e..a528e9026a 100755
--- a/collects/tests/plai/gc/good-mutators/closure-2.ss
+++ b/collects/tests/plai/gc/good-mutators/closure-2.ss
@@ -1,5 +1,5 @@
 #lang plai/mutator
-(allocator-setup "../good-collectors/good-collector.ss" 58)
+(allocator-setup "../good-collectors/good-collector.ss" 40)
 
 
 (define make-conser
diff --git a/collects/tests/plai/gc/good-mutators/names.ss b/collects/tests/plai/gc/good-mutators/names.ss
index e2aa03b838..ed52035727 100644
--- a/collects/tests/plai/gc/good-mutators/names.ss
+++ b/collects/tests/plai/gc/good-mutators/names.ss
@@ -1,3 +1,3 @@
 #lang plai/mutator
-(allocator-setup "../good-collectors/good-collector.ss" 400)
+(allocator-setup "../good-collectors/good-collector.ss" 10)
 (let ([f (λ (x) x)]) f)
\ No newline at end of file
diff --git a/collects/tests/plai/gc/good-mutators/proc-list.ss b/collects/tests/plai/gc/good-mutators/proc-list.ss
index f24367568f..72105c56b7 100755
--- a/collects/tests/plai/gc/good-mutators/proc-list.ss
+++ b/collects/tests/plai/gc/good-mutators/proc-list.ss
@@ -2,7 +2,7 @@
 ; Demonstrates garbage collection while a closure is on the stack.  A correct collector must ensure that the roots
 ; reachable from (make-adder 90) and (make-adder 200) -- that is, the values 90 and 200 that k is bound to -- do
 ; not get discarded.
-(allocator-setup "../good-collectors/good-collector.ss" 68)
+(allocator-setup "../good-collectors/good-collector.ss" 58)
 
 (define (make-adder k)
   (lambda (n) (+ n k)))
diff --git a/collects/tests/plai/gc/good-mutators/student-1.ss b/collects/tests/plai/gc/good-mutators/student-1.ss
index db02017fd7..0a46555e39 100755
--- a/collects/tests/plai/gc/good-mutators/student-1.ss
+++ b/collects/tests/plai/gc/good-mutators/student-1.ss
@@ -15,7 +15,7 @@
 ; Finally it runs the sample tests distributed with the assignment
 
 
-(allocator-setup "../good-collectors/good-collector.ss" 1000)
+(allocator-setup "../good-collectors/good-collector.ss" 80)
 
 ; Helper to generate long lists
 (define (gen-list x)
diff --git a/collects/tests/plai/test-random-mutator.ss b/collects/tests/plai/test-random-mutator.ss
index c15c00c111..a827604e75 100644
--- a/collects/tests/plai/test-random-mutator.ss
+++ b/collects/tests/plai/test-random-mutator.ss
@@ -11,7 +11,7 @@
 ;;  random mutator generation tests
 ;;
 
-(define-runtime-path no-compact-cheat-path "gc/good-collectors/no-compact-cheat.ss")
+(define-runtime-path collector-path "gc/good-collectors/good-collector.ss")
 
 (define-runtime-path here ".")
 
@@ -27,7 +27,7 @@
                                                  (find-relative-path 
                                                   (normalize-path (simple-form-path tmpfile))
                                                   (normalize-path
-                                                   (simple-form-path no-compact-cheat-path))))
+                                                   (simple-form-path collector-path))))
                                                100))
         (for-each (λ (exp) (pretty-print exp port)) exps))
       #:exists 'truncate)
@@ -36,9 +36,9 @@
     (printf "simple-form tmpfile ~s\n" (simple-form-path tmpfile))
     (printf "normalized tmpfile ~s\n" (normalize-path (simple-form-path tmpfile)))
     (newline)
-    (printf "collector ~s\n" no-compact-cheat-path)
-    (printf "simple-form collector: ~s\n" (simple-form-path no-compact-cheat-path))
-    (printf "normalized simple-form collector: ~s\n" (normalize-path (simple-form-path no-compact-cheat-path)))
+    (printf "collector ~s\n" collector-path)
+    (printf "simple-form collector: ~s\n" (simple-form-path collector-path))
+    (printf "normalized simple-form collector: ~s\n" (normalize-path (simple-form-path collector-path)))
     (newline)
     (printf "here ~s\n" here)
     (printf "simple-form here: ~s\n" (simple-form-path here))