New GC code

collects/plai/gc2/collector.rkt

@@ -0,0 +1,62 @@
+#lang scheme
+
+(require (for-syntax scheme)
+         plai/datatype
+         plai/test-harness
+         plai/gc2/private/gc-core)
+
+(provide (except-out (all-from-out scheme) #%module-begin error)
+         (all-from-out plai/gc2/private/gc-core)
+         (all-from-out plai/datatype)
+         (rename-out
+          [plai-error error])
+         (except-out (all-from-out plai/test-harness))
+         (rename-out 
+          [collector-module-begin #%module-begin]))
+
+(provide with-heap)
+(define-syntax-rule (with-heap heap exp ...) (with-heap/proc heap (λ () exp ...)))
+(define (with-heap/proc vec h)
+  (unless (vector? vec)
+    (error 'with-heap "expected a vector as first argument, got ~e" vec))
+  (for ([v (in-vector vec)]
+        [i (in-naturals)])
+    (unless (heap-value? v)
+      (error 'with-heap "expected the heap to contain only heap values, but found ~e at position ~a"
+             v i)))
+  (parameterize ([current-heap vec])
+    (h)))
+
+;;; Since we explicitly identify the procedures to be exported here, an error is raised in the
+;;; collector if a procedure is not defined.
+(define-syntax (collector-module-begin stx)
+  (syntax-case stx ()
+    [(_ body ...) 
+     (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!))])
+       #`(#%module-begin 
+          
+          (require (for-syntax scheme))
+          
+          (provide/contract (init-allocator (-> any)))
+          
+          (provide/contract (gc:deref (location? . -> . heap-value?)))
+          
+          (provide/contract (gc:alloc-flat (heap-value? . -> . location?)))
+          (provide/contract (gc:cons (location? location? . -> . location?)))
+          
+          (provide/contract (gc:first (location? . -> . location?)))
+          (provide/contract (gc:rest (location? . -> . location?)))
+          
+          (provide/contract (gc:flat? (location? . -> . boolean?)))
+          (provide/contract (gc:cons? (location? . -> . boolean?)))
+          
+          (provide/contract (gc:set-first! (location? location? . -> . void?)))
+          (provide/contract (gc:set-rest! (location? location? . -> . void?)))
+          
+          body ...
+          
+          ))]))

collects/plai/gc2/collector/lang/reader.rkt

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  #:language `plai/collector)

collects/plai/gc2/mutator.rkt

@@ -0,0 +1,552 @@
+#lang scheme
+(require (prefix-in scheme: scheme)
+         plai/private/command-line
+         (for-syntax plai/private/command-line)
+         plai/gc2/private/collector-exports
+         plai/gc2/private/gc-core
+         scheme/gui/dynamic
+         (only-in plai/test-harness
+                  exn:plai? equal~?
+                  plai-error generic-test test halt-on-errors print-only-errors)
+         (for-syntax scheme)
+         (for-syntax plai/gc2/private/gc-transformer)
+         scheme/stxparam
+         (for-syntax scheme/stxparam-exptime))
+
+(provide else require provide #%top
+         test/location=? 
+         test/value=?
+         (rename-out
+          [plai-error error]
+          
+          [mutator-and and]
+          [mutator-or or]
+          [mutator-cond cond]
+          [mutator-case case]
+          [mutator-define define]
+          [mutator-define-values define-values]
+          (mutator-let let)
+          [mutator-let* let*]
+          [mutator-begin begin]
+          
+          [mutator-if if]
+          [mutator-let-values let-values]
+          [mutator-set! set!]
+          [mutator-lambda lambda]
+          [mutator-lambda λ]
+          (mutator-app #%app)
+          (mutator-datum #%datum)
+          (collector:cons cons)
+          (collector:first first)
+          (collector:rest rest)
+          (mutator-quote quote)
+          (mutator-top-interaction #%top-interaction)
+          (mutator-module-begin #%module-begin)))
+
+(define-syntax-parameter mutator-name #f)
+(define-syntax-parameter mutator-tail-call? #t)
+(define-syntax-parameter mutator-env-roots empty)
+
+; Sugar Macros
+(define-syntax-rule (->address e) e)
+(define-syntax mutator-and
+  (syntax-rules ()
+    [(_) (mutator-quote #t)]
+    [(_ fe) fe]
+    [(_ fe e ...) (mutator-if fe (mutator-and e ...) (mutator-quote #f))]))
+(define-syntax mutator-or
+  (syntax-rules ()
+    [(_) (mutator-quote #f)]
+    [(_ fe) fe]
+    [(_ fe e ...) (mutator-let ([tmp fe]) (mutator-if tmp tmp (mutator-or e ...)))]))
+(define-syntax mutator-cond
+  (syntax-rules (else)
+    [(_) (mutator-begin)]
+    [(_ [else e ...]) (mutator-begin e ...)]
+    [(_ [q ans] e ...) (mutator-if q ans (mutator-cond e ...))]))
+(define-syntax mutator-case
+  (syntax-rules (else)
+    [(_ value
+        [(v ...) e ...]
+        ...
+        [else ee ...])
+     (mutator-let ([tmp value])
+                  (mutator-cond [(mutator-app mutator-member? tmp (mutator-quote (v ...)))
+                                 e ...]
+                                ...
+                                [else ee ...]))]
+    [(_ value
+        [(v ...) e ...]
+        ...)
+     (mutator-case value
+                   [(v ...) e ...]
+                   ...
+                   [else (mutator-begin)])]))
+(define-syntax mutator-define
+  (syntax-rules ()
+    [(_ (f a ...) e ...)
+     (mutator-define-values (f) 
+                            (syntax-parameterize ([mutator-name #'f])
+                                                 (mutator-lambda (a ...) e ...)))]
+    [(_ id e)
+     (mutator-define-values (id) 
+                            (syntax-parameterize ([mutator-name #'id])
+                                                 e))]))
+(define-syntax-rule (mutator-let ([id e] ...) be ...)
+  (mutator-let-values ([(id) (syntax-parameterize ([mutator-name #'id])
+                                                  e)]
+                       ...)
+                      be ...))
+(define-syntax mutator-let*
+  (syntax-rules ()
+    [(_ () be ...)
+     (mutator-begin be ...)]
+    [(_ ([fid fe] [rid re] ...) be ...)
+     (mutator-let ([fid fe])
+                  (mutator-let* ([rid re] ...)
+                                be ...))]))
+(define-syntax mutator-begin
+  (syntax-rules ()
+    [(_) (mutator-app void)]
+    [(_ e) e]
+    [(_ fe e ...)
+     (let ([tmp 
+            (syntax-parameterize ([mutator-tail-call? #f])
+                                 fe)])
+       (mutator-begin e ...))]))
+
+; Real Macros
+(define-syntax-rule (mutator-define-values (id ...) e)
+  (begin (define-values (id ...) 
+           (syntax-parameterize ([mutator-tail-call? #f])
+                                (->address e)))
+         (add-global-root! (make-env-root id))
+         ...))
+(define-syntax-rule (mutator-if test true false)
+  (if (syntax-parameterize ([mutator-tail-call? #f])
+                           (collector:deref (->address test)))
+      (->address true)
+      (->address false)))
+(define-syntax-rule (mutator-set! id e)
+  (begin
+    (set! id (->address e))
+    (mutator-app void)))
+(define-syntax (mutator-let-values stx)
+  (syntax-case stx ()
+    [(_ ([(id ...) expr]
+         ...)
+        body-expr)
+     (with-syntax ([((tmp ...) ...)
+                    (map generate-temporaries (syntax->list #'((id ...) ...)))])
+       (let ([binding-list (syntax->list #'((tmp ...) ...))])
+         (with-syntax ([((previous-tmp ...) ...)
+                        (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 
+                                                   (list* #'previous-tmp ...
+                                                          (syntax-parameter-value #'mutator-env-roots))]
+                                                  [mutator-tail-call? #f])
+                                                 expr)]
+                           ...)
+               (let-values ([(id ...) (values tmp ...)]
+                            ...)
+                 (syntax-parameterize ([mutator-env-roots 
+                                        (list* #'id ... ...
+                                               (syntax-parameter-value #'mutator-env-roots))])
+                                      (->address body-expr))))))))]
+    [(_ ([(id ...) expr]
+         ...)
+        body-expr ...)
+     (syntax/loc stx
+       (mutator-let-values
+        ([(id ...) expr]
+         ...)
+        (mutator-begin body-expr ...)))]))
+(define-syntax (mutator-lambda stx)
+  (syntax-case stx ()
+    [(_ (id ...) body)
+     (let ([env-roots (syntax-parameter-value #'mutator-env-roots)])
+       (with-syntax ([(free-id ...) (find-referenced-locals env-roots stx)]
+                     [(env-id ...) env-roots]
+                     [closure (or (syntax-parameter-value #'mutator-name)
+                                  (syntax-local-name)
+                                  (let ([prop (syntax-property stx 'inferred-name)])
+                                    (if (or (identifier? prop)
+                                            (symbol? prop))
+                                        prop
+                                        #f))
+                                  (string->symbol "#<proc>"))])
+         (quasisyntax/loc stx
+           (let ([closure (lambda (id ...) 
+                            (syntax-parameterize ([mutator-env-roots 
+                                                   (list #'id ...
+                                                         #'free-id ...)]
+                                                  [mutator-tail-call? #t])
+                                                 (->address body)))])
+             (add-closure-env! closure (list (make-env-root free-id) ...))
+             #,(if (syntax-parameter-value #'mutator-tail-call?)
+                   (syntax/loc stx
+                     (#%app collector:alloc-flat closure))
+                   (syntax/loc stx
+                     (with-continuation-mark gc-roots-key 
+                       (list (make-env-root env-id) ...)
+                       (#%app collector:alloc-flat closure))))))))]
+    [(_ (id ...) body ...)
+     (syntax/loc stx
+       (mutator-lambda (id ...) (mutator-begin body ...)))]))
+(define-syntax (mutator-app stx)
+  (syntax-case stx ()
+    [(_ e ...)
+     (local [(define (do-not-expand? exp)
+               (and (identifier? exp)
+                    (free-identifier=? exp #'empty)))
+             (define exps
+               (syntax->list #'(e ...)))
+             (define tmps
+               (generate-temporaries #'(e ...)))]
+       (with-syntax ([(ne ...)
+                      (map (lambda (exp tmp) (if (do-not-expand? exp) exp tmp))
+                           exps tmps)])
+         (for/fold ([acc (syntax/loc stx (mutator-anf-app ne ...))])
+           ([exp (in-list (reverse exps))]
+            [tmp (in-list (reverse tmps))])
+           (if (do-not-expand? exp)
+               acc
+               (quasisyntax/loc stx
+                 (mutator-let ([#,tmp #,exp])
+                              #,acc))))))]))
+(define-syntax (mutator-anf-app stx)
+  (syntax-case stx ()
+    [(_ 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.
+           (syntax/loc stx ((deref-proc fe) ae ...))
+           ; 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 ...)))))]))
+(define-syntax mutator-quote
+  (syntax-rules ()
+    [(_ (a . d))
+     (mutator-app collector:cons (mutator-quote a) (mutator-quote d))]
+    [(_ s) 
+     (mutator-datum . s)]))
+(define-syntax (mutator-datum stx)
+  (syntax-case stx ()
+    [(_ . e) 
+     (quasisyntax/loc stx (mutator-anf-app collector:alloc-flat (#%datum . e)))]))
+
+(define-syntax (mutator-top-interaction stx)
+  (syntax-case stx (require provide mutator-define mutator-define-values test/value=? import-primitives)
+    [(_ . (require . e))
+     (syntax/loc stx
+       (require . e))]
+    [(_ . (provide . e))
+     (syntax/loc stx
+       (provide . e))]
+    [(_ . (mutator-define . e))
+     (syntax/loc stx
+       (mutator-define . e))]
+    [(_ . (mutator-define-values . e))
+     (syntax/loc stx
+       (mutator-define-values . e))]
+    [(_ . (test/value=? . e))
+     (syntax/loc stx
+       (test/value=? . e))]
+    [(_ . (import-primitives . e))
+     (syntax/loc stx
+       (import-primitives . e))]
+    [(_ . expr)
+     (syntax/loc stx
+       (call-with-values
+        (lambda ()
+          (syntax-parameterize ([mutator-tail-call? #f])
+                               (->address expr)))
+        (case-lambda
+          [() (void)]
+          [(result-addr)
+           (cond
+             [(procedure? result-addr)
+              (printf "Imported procedure\n")
+              result-addr]
+             [(location? result-addr)
+              (printf "Value at location ~a:\n" result-addr)
+              (gc->scheme result-addr)])])))]))
+
+; Module Begin
+(define-for-syntax (allocator-setup-internal stx)
+  (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
+         #`(begin
+             #,(if (alternate-collector)
+                   #`(require #,(datum->syntax #'collector-module (alternate-collector)))
+                   #`(require collector-module))
+             
+             (set-collector:deref! gc:deref)
+             (set-collector:alloc-flat! gc:alloc-flat)
+             (set-collector:cons! gc:cons)
+             (set-collector:first! gc:first)
+             (set-collector:rest! gc:rest)
+             (set-collector:flat?! gc:flat?)
+             (set-collector:cons?! gc:cons?)
+             (set-collector:set-first!! gc:set-first!)
+             (set-collector:set-rest!! gc:set-rest!)
+             
+             (init-heap! (#%datum . heap-size))
+             (when (gui-available?) 
+               (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 <module-path> <literal-number>)"
+                           stx)]))
+
+(define-for-syntax allocator-setup-error-msg
+  "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <module-path> <literal-number>)")
+
+(define-syntax (mutator-module-begin stx)
+  (syntax-case stx (allocator-setup)
+    [(_ (allocator-setup . setup) module-expr ...)
+     (begin
+       (syntax-case #'setup ()
+         [(collector heap-size)
+          (begin
+            (unless (module-path? (syntax->datum #'collector))
+              (raise-syntax-error 'allocator-setup "expected a module path" #'collector))
+            (unless (number? (syntax->datum #'heap-size))
+              (raise-syntax-error 'allocator-setup "expected a literal number" #'heap-size)))]
+         [_
+          (raise-syntax-error 'mutator allocator-setup-error-msg (syntax/loc #'setup (allocator-setup . setup)))])
+       (quasisyntax/loc stx
+         (#%module-begin
+          #,(allocator-setup-internal #'setup)
+          #,@(for/list ([me (in-list (syntax->list #'(module-expr ...)))])
+               (quasisyntax/loc me
+                 (mutator-top-interaction . #,me))))))]
+    [(_ first-expr module-expr ...)
+     (raise-syntax-error 'mutator allocator-setup-error-msg #'first-expr)]
+    [(_)
+     (raise-syntax-error 'mutator allocator-setup-error-msg)]))
+
+; User Macros
+(provide import-primitives)
+(define-syntax (import-primitives stx)
+  (syntax-case stx ()
+    [(_ id ...) 
+     (andmap identifier? (syntax->list #'(id ...)))
+     (with-syntax ([(renamed-id ...) (generate-temporaries #'(id ...))]
+                   [source (syntax-local-get-shadower
+                            (syntax-local-introduce #'scheme))])
+       #`(begin
+           (require (only-in source [id renamed-id] ...))
+           (define id
+             (lambda args
+               (unless (andmap (lambda (v) (and (location? v) (collector:flat? v))) args)
+                 (error 'id (string-append "all arguments must be <heap-value?>s, "
+                                           "even if the imported procedure accepts structured "
+                                           "data")))
+               (let ([result (apply renamed-id (map collector:deref args))])
+                 (cond
+                   [(void? result) (void)]
+                   [(heap-value? result) (collector:alloc-flat result)]
+                   [else 
+                    (error 'id (string-append "imported primitive must return <heap-value?>, "
+                                              "received ~a" result))]))))
+           ...))]
+    [(_ maybe-id ...) 
+     (ormap (λ (v) (and (not (identifier? v)) v)) (syntax->list #'(maybe-id ...)))
+     (let ([offending-stx (findf (λ (v) (not (identifier? v))) (syntax->list #'(maybe-id ...)))])
+       (raise-syntax-error 
+        #f "expected identifier to import" offending-stx))]
+    [(_ . __)
+     (raise-syntax-error #f "expected list of identifiers to import" stx)]
+    [_ (raise-syntax-error #f "expected open parenthesis before import-primitive")]))
+
+; User Functions
+(define (mutator-lift f) 
+  (lambda args
+    (let ([result (apply f (map collector:deref args))])
+      (if (void? result)
+          (void)
+          (collector:alloc-flat result)))))
+(define-syntax (provide/lift stx)
+  (syntax-case stx ()
+    [(_ id ...)
+     (andmap identifier? (syntax->list #'(id ...)))
+     (with-syntax ([(lifted-id ...) (generate-temporaries #'(id ...))])
+       #'(begin
+           (define lifted-id (mutator-lift id)) ...
+           (provide (rename-out [lifted-id id] ...))))]))
+
+(provide/lift 
+ symbol? boolean? number? symbol=?
+ add1 sub1 zero? + - * / even? odd? = < > <= >=)
+
+(define (member? v l)
+  (and (member v l) #t))
+(define (mutator-member? v l)
+  (collector:alloc-flat
+   (member? (collector:deref v)
+            (gc->scheme l))))
+
+(provide (rename-out (mutator-set-first! set-first!)))
+(define (mutator-set-first! x y)
+  (collector:set-first! x y)
+  (void))
+
+(provide (rename-out (mutator-set-rest! set-rest!)))
+(define (mutator-set-rest! x y)
+  (collector:set-rest! x y)
+  (void))
+
+(provide (rename-out [mutator-empty empty]))
+(define-syntax mutator-empty
+  (syntax-id-rules (mutator-empty)
+    [_ (mutator-quote ())]))
+
+(provide (rename-out (mutator-empty? empty?)))
+(define (mutator-empty? loc)
+  (cond
+    [(collector:flat? loc) 
+     (collector:alloc-flat (empty? (collector:deref loc)))]
+    [else 
+     (collector:alloc-flat false)]))
+
+(provide (rename-out [mutator-cons? cons?]))
+(define (mutator-cons? loc)
+  (collector:alloc-flat (collector:cons? loc)))
+
+(provide (rename-out [mutator-eq? eq?]))
+(define (mutator-eq? l1 l2)
+  (collector:alloc-flat (= l1 l2)))
+
+(provide (rename-out [mutator-printf printf]))
+(define-syntax (mutator-printf stx)
+  (syntax-case stx ()
+    [(_ fmt arg ...)
+     ; We must invoke mutator-app to A-normalize the arguments.
+     (syntax/loc stx 
+       (begin
+         (mutator-app printf (#%datum . fmt)
+                      (mutator-app gc->scheme arg) ...)
+         (void)))]))
+
+(provide (rename-out
+          (mutator-halt-on-errors halt-on-errors)
+          (mutator-print-only-errors print-only-errors)))
+(define-syntax (mutator-halt-on-errors stx)
+  (syntax-case stx ()
+    [(_) #'(halt-on-errors)]
+    [(_ arg) #'(#%app halt-on-errors (#%datum . arg))]))
+
+(define-syntax (mutator-print-only-errors stx)
+  (syntax-case stx ()
+    [(_) #'(print-only-errors)]
+    [(_ arg) #'(#%app print-only-errors (#%datum . arg))]))
+
+; Implementation Functions
+(define (deref proc/loc)
+  (cond
+    [(procedure? proc/loc) proc/loc]
+    [(location? proc/loc) (collector:deref proc/loc)]
+    [else (error 'deref "expected <location?> or <procedure?>; received ~a" proc/loc)]))
+
+(define (deref-proc proc-or-loc)
+  (define v 
+    (with-handlers ([exn? (lambda (x) 
+                            (error 'procedure-application "expected procedure, given something else"))])
+      (deref proc-or-loc)))
+  (if (procedure? v)
+      v
+      (error 'procedure-application "expected procedure, given ~e" v)))
+
+(define (gc->scheme loc)
+  (define-struct an-unset ())
+  (define unset (make-an-unset))
+  (define phs (make-hash))
+  (define (unwrap loc)
+    (if (hash-has-key? phs loc)
+        (hash-ref phs loc)
+        (begin
+          (local [(define ph (make-placeholder unset))]
+            (hash-set! phs loc ph)
+            (cond
+              [(collector:flat? loc)
+               (placeholder-set! ph (collector:deref loc))]
+              [(collector:cons? loc)
+               (local [(define car-ph (make-placeholder unset))
+                       (define cdr-ph (make-placeholder unset))]
+                 (placeholder-set! ph (cons car-ph cdr-ph))
+                 (placeholder-set! car-ph (unwrap (collector:first loc)))
+                 (placeholder-set! cdr-ph (unwrap (collector:rest loc))))]
+              [else 
+               (error (format "gc:flat? and gc:cons? both returned false for ~a" loc))])
+            (placeholder-get ph)))))
+  (make-reader-graph (unwrap loc)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Testing support
+
+(define-syntax (test/location=? stx)
+  (syntax-case stx ()
+    [(_ e1 e2)
+     (quasisyntax/loc stx
+       (generic-test 
+        (λ () e1) 
+        (λ (result-value)
+          (define expected-val e2)
+          (values
+           (cond
+             [(exn:plai? result-value) result-value]
+             [(equal~? result-value expected-val) true]
+             [else false])
+           expected-val))
+        (quote (heap-loc #,(syntax->datum #'e1)))
+        (format "at line ~a" #,(syntax-line stx))))]))
+
+(define-for-syntax (flat-heap-value? v)
+  (or (number? v) (boolean? v)))
+
+(define-syntax (expand-scheme stx)
+  (syntax-case stx (mutator-quote mutator-datum)
+    [(_ val) (flat-heap-value? (syntax->datum #'val)) #'(#%datum . val)]
+    [(_ (mutator-datum . val))
+     #'(#%datum . val)]
+    [(_ (mutator-quote e))
+     #'(quote e)]
+    [_ 
+     (raise-syntax-error 'test/value=? "must be a number, boolean or a quoted value" stx)]))
+
+(define-syntax (test/value=? stx)
+  (syntax-case stx (mutator-quote)
+    [(_ mutator-expr scheme-datum)
+     (quasisyntax/loc stx
+       (generic-test 
+        (λ () 
+          (mutator-let ([v1 mutator-expr])
+                       (gc->scheme v1))) 
+        (λ (result-value)
+          (define expected-val (expand-scheme scheme-datum))
+          (values
+           (cond
+             [(exn:plai? result-value) result-value]
+             [(equal~? result-value expected-val) true]
+             [else false])
+           expected-val))
+        (quote #,(syntax->datum #'mutator-expr))
+        (format "at line ~a" #,(syntax-line stx))))]))

collects/plai/gc2/mutator/lang/reader.rkt

@@ -0,0 +1,2 @@
+(module reader syntax/module-reader
+  #:language `plai/mutator)

collects/plai/gc2/random-mutator.rkt

@@ -0,0 +1,18 @@
+#lang scheme/base
+(require "private/random-mutator.rkt"
+         scheme/contract
+         "private/gc-core.rkt")
+
+(provide/contract
+ [save-random-mutator 
+  (->* (path-string?
+        string?)
+       (#:iterations 
+        exact-positive-integer?
+        #:heap-values (cons/c heap-value? (listof heap-value?))
+        #:program-size exact-positive-integer?
+        #:heap-size exact-positive-integer?)
+       void?)]
+ [find-heap-values
+  (-> (or/c path-string? input-port?)
+      (listof heap-value?))])

collects/tests/plai/gc2/bad-collectors/no-collection-collector.rkt

@@ -0,0 +1,18 @@
+#lang plai/gc2collector
+
+(define ptr 0)
+
+(define (init-allocator) (void))
+
+(define (gc:deref loc) #f)
+(define (gc:alloc-flat hv) 0)
+(define (gc:cons hd tl) 0)
+(define (gc:first pr) 0)
+(define (gc:rest pr) 0)
+(define (gc:flat? loc) #t)
+(define (gc:cons? loc) #f)
+(define (gc:set-first! pr new) (void))
+(define (gc:set-rest! pr new) (void))
+
+(with-heap (vector 1 2 3)
+  (test (gc:deref 0) #f))

collects/tests/plai/gc2/bad-mutators/mut-1.rkt

@@ -0,0 +1,10 @@
+#lang plai/gc2mutator
+(allocator-setup "../bad-collectors/broken-collector.rkt" 12)
+
+50
+60
+70
+80
+(define x (cons 1 2))
+
+(set-first! x x)

collects/tests/plai/gc2/bad-mutators/mutator0.rkt

@@ -0,0 +1 @@
+#lang plai/gc2mutator

collects/tests/plai/gc2/bad-mutators/mutator1.rkt

@@ -0,0 +1,2 @@
+#lang plai/gc2mutator
+1

collects/tests/plai/gc2/bad-mutators/mutator2.rkt

@@ -0,0 +1,2 @@
+#lang plai/gc2mutator
+(allocator-setup "../collectors/trivial-collector.rkt" "y")

collects/tests/plai/gc2/bad-mutators/mutator3.rkt

@@ -0,0 +1,2 @@
+#lang plai/gc2mutator
+(allocator-setup a 100)

collects/tests/plai/gc2/bad-mutators/mutator5.rkt

@@ -0,0 +1,2 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/trivial-collector.rkt")

collects/tests/plai/gc2/bad-mutators/void-app.rkt

@@ -0,0 +1,4 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 100)
+(define x (cons 1 2))
+((set-first! x 2) 1)

collects/tests/plai/gc2/good-collectors/good-collector.rkt

@@ -0,0 +1,274 @@
+#lang plai/gc2collector
+
+#|
+
+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))

collects/tests/plai/gc2/good-collectors/trivial-collector.rkt

@@ -0,0 +1,54 @@
+#lang plai/gc2collector
+(define heap-ptr 'uninitialized-heap-ptr)
+
+(define (init-allocator)
+  ; calling heap-offset before init-allocator is called gives 'undefined
+ (set! heap-ptr 0))
+
+(define (gc:alloc-flat p)
+  (begin 
+    (when (> (+ heap-ptr 2) (heap-size))
+      (error "out of memory"))
+    (heap-set! heap-ptr 'prim)
+    (heap-set! (+ 1 heap-ptr) p)
+    (set! heap-ptr (+ 2 heap-ptr))
+    ; return the location of this flat data
+    (- heap-ptr 2)))
+
+(define (gc:cons f r)
+  (begin
+    (when (> (+ heap-ptr 3) (heap-size))
+      (error "out of memory"))
+    (heap-set! heap-ptr 'cons)
+    (heap-set! (+ 1 heap-ptr) f)
+    (heap-set! (+ 2 heap-ptr) r)
+    (set! heap-ptr (+ 3 heap-ptr))
+    (- heap-ptr 3)))
+
+(define (gc:deref a)
+  (heap-ref (+ 1 a)))
+
+; number -> boolean
+(define (gc:cons? a)
+  (eq? (heap-ref a) 'cons))
+
+; number -> any
+(define (gc:first a)
+  (heap-ref (+ 1 a)))
+
+; number -> number
+(define (gc:rest a)
+  (heap-ref (+ 2 a)))
+
+(define (gc:set-first! a f)
+  (if (gc:cons? a)
+      (heap-set! (+ 1 a) f)
+      (error 'set-first! "expects address of cons")))
+
+(define (gc:set-rest! a r)
+  (heap-set! (+ 2 a) r))
+
+; function number -> boolean
+(define (gc:flat? a)
+  (eq? 'prim (heap-ref a)))
+

collects/tests/plai/gc2/good-mutators/andor.rkt

@@ -0,0 +1,8 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 400)
+(define (do-one i) (/ (- i 1)))
+(define (loop i)
+  (or (= 1 i)
+      (and (do-one i)
+           (loop (- i 1)))))
+(loop 50)

collects/tests/plai/gc2/good-mutators/app.rkt

@@ -0,0 +1,11 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 28)
+
+(define (app f)
+  (lambda (x)
+    (f x)))
+
+(define plus (app add1))
+
+(plus 23)
+(plus 5)

collects/tests/plai/gc2/good-mutators/bindings.rkt

@@ -0,0 +1,26 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 58)
+
+(define x 'intial)
+(set! x 'final)
+(test/value=? x 'final)
+
+
+(define y
+  (let ([outer-local
+       (let ([inner-local 'value-expected])
+         inner-local)])
+  outer-local))
+
+(test/value=? y 'value-expected)
+
+(define (local-vars)
+  (let ([x 23] [y 23])
+    x))
+
+(test/value=? (local-vars) 23)
+
+(define (locals-2 x)
+  (+ x 5))
+
+(test/value=? (locals-2 23) 28)

collects/tests/plai/gc2/good-mutators/by-val.rkt

@@ -0,0 +1,13 @@
+; Ensure that call by value is correctly implemented.
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 40)
+
+(define global-val 'global)
+
+(define (mut-arg arg)
+  (set! arg 'mutated))
+
+(mut-arg global-val)
+
+
+(test/value=? global-val 'global)

collects/tests/plai/gc2/good-mutators/case.rkt

@@ -0,0 +1,8 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 40)
+(test/value=? (case 1 [(1) 2])
+              2)
+(test/value=? (case 1 [(1) 2] [else 3])
+              2)
+(test/value=? (case 2 [(1) 2] [else 3])
+              3)

collects/tests/plai/gc2/good-mutators/circular.rkt

@@ -0,0 +1,11 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 68)
+
+(define (gen-circular)
+  (let ([x (cons 3 4)])
+    (let ([y (cons 2 x)])
+      (set-rest! x y)
+      x)))
+
+(define x (gen-circular))
+(test/location=? x (rest (rest x)))

collects/tests/plai/gc2/good-mutators/classic-error.rkt

@@ -0,0 +1,14 @@
+#lang plai/gc2mutator
+; 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.rkt" 28)
+
+'trash
+'junk
+; after GC, alpha beta are copied but the cons references them in the old semispace
+(define my-pair (cons 'alpha 'beta))
+; we have room for our-pair, but 'refuse forces a semi-space swap that exposes
+; the memory corruption (if one exists)
+'refuse
+(define our-pair (cons my-pair my-pair))
+(test/value=? our-pair '((alpha . beta) . (alpha . beta)))
+(test/location=? (first our-pair) (rest our-pair))

collects/tests/plai/gc2/good-mutators/closure-1.rkt

@@ -0,0 +1,13 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 60)
+
+(define lst '(2 -10)) ; (cons 2 (cons -10 empty)))
+
+(define (map f lst)
+  (if (cons? lst)
+      (cons (f (first lst)) (map f (rest lst)))
+      empty))
+
+(define x 'gc-garbage)
+
+(test/value=? (map add1 lst) '(3 -9))

collects/tests/plai/gc2/good-mutators/closure-2.rkt

@@ -0,0 +1,16 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 40)
+
+
+(define make-conser
+  (lambda (n)
+    (lambda (x) 
+      (cons n x))))
+
+
+(define kons (make-conser 'catamaran))
+;1 2 3 5 6 7 
+(kons 'people)
+(kons 'maroon)
+(kons 'srfi)
+(test/value=? (kons 'peace) '(catamaran . peace))

collects/tests/plai/gc2/good-mutators/cond.rkt

@@ -0,0 +1,7 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 40)
+
+(cond
+ [(zero? 3) 1111]
+ [#f 2222]
+ [#t 3333])

collects/tests/plai/gc2/good-mutators/danny-bug.rkt

@@ -0,0 +1,12 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 6)
+
+(define
+  proc
+  (let* ([not-root 1] ; 2
+         [root 2]) ; 4
+    (lambda () ; 6
+      3
+      root)))
+
+(proc)

collects/tests/plai/gc2/good-mutators/else.rkt

@@ -0,0 +1,5 @@
+#lang plai/gc2mutator
+; Is else defined?
+(allocator-setup "../good-collectors/good-collector.rkt" 40)
+
+(test/value=? (cond [else 28935723]) 28935723)

collects/tests/plai/gc2/good-mutators/empty-mutator.rkt

@@ -0,0 +1,3 @@
+#lang plai/gc2mutator
+
+(allocator-setup "../good-collectors/good-collector.rkt" 80)

collects/tests/plai/gc2/good-mutators/gc-order.rkt

@@ -0,0 +1,9 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 58)
+
+(define x 3)
+(cons (begin (set! x 2)
+             1)
+      (begin (set! x 3)
+             1))
+(test/value=? x 3)

collects/tests/plai/gc2/good-mutators/global-roots.rkt

@@ -0,0 +1,11 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 20)
+
+
+(define car first)
+
+
+'junk
+'junk
+'junk
+(test/value=? (car (cons 'this-car 2)) 'this-car)

collects/tests/plai/gc2/good-mutators/imports.rkt

@@ -0,0 +1,6 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 20)
+
+(import-primitives modulo)
+
+(test/value=? (modulo 5 3) 2)

collects/tests/plai/gc2/good-mutators/kathi-bug-1.rkt

@@ -0,0 +1,4 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 84)
+(define L (cons 3 empty))
+(test/value=? L '(3))

collects/tests/plai/gc2/good-mutators/modpath.rkt

@@ -0,0 +1,4 @@
+#lang plai/gc2mutator
+(allocator-setup tests/plai/gc2gc/good-collectors/good-collector 10)
+1
+2

collects/tests/plai/gc2/good-mutators/mutator4.rkt

@@ -0,0 +1,3 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 100)
+(cons 4 #t)

collects/tests/plai/gc2/good-mutators/mutator6.rkt

@@ -0,0 +1,5 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 58)
+
+(define x 'intial)
+(test/value=? x 'intial)

collects/tests/plai/gc2/good-mutators/mutator7.rkt

@@ -0,0 +1,8 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 58)
+
+(define x 'initial)
+
+(eq? x x)
+(eq? x 'initial)
+(eq? 5 4)

collects/tests/plai/gc2/good-mutators/names.rkt

@@ -0,0 +1,3 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 10)
+(let ([f (λ (x) x)]) f)

collects/tests/plai/gc2/good-mutators/proc-list.rkt

@@ -0,0 +1,17 @@
+#lang plai/gc2mutator
+; 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.rkt" 58)
+
+(define (make-adder k)
+  (lambda (n) (+ n k)))
+
+(define proc-list
+  (cons (make-adder 90)
+        (cons (make-adder 200)
+              empty)))
+
+(test/value=? ((first proc-list) 7) 97)
+(test/value=? ((first proc-list) 300) 390)
+(test/value=? ((first (rest proc-list)) 73) 273)

collects/tests/plai/gc2/good-mutators/repeat-test.rkt

@@ -0,0 +1,14 @@
+#lang plai/gc2mutator
+
+(allocator-setup "../good-collectors/good-collector.rkt" 30)
+
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))
+(test/value=? (cons 1 empty) '(1))

collects/tests/plai/gc2/good-mutators/student-1.rkt

@@ -0,0 +1,131 @@
+#lang plai/gc2mutator
+
+; mark-and-sweep-test.rkt - Ben Childs
+; Designed to test the mark and sweep collector
+; Runs three tests:
+;
+; Allocation of subsequently larger lists
+;
+; Use of Local variables in a loop (garbage after each iteration)
+; Followed by allocation of large list (verifies that they are correctly collected)
+;
+; Generation of a number of circularly referenced lists
+; Followed by allocation of several large lists
+;
+; Finally it runs the sample tests distributed with the assignment
+
+
+(allocator-setup "../good-collectors/good-collector.rkt" 80)
+
+; Helper to generate long lists
+(define (gen-list x)
+  (if (zero? x) '() (cons x (gen-list (- x 1)))))
+
+; Function that defines local vars
+(define (local-vars)
+  (let ((x 3) (y 5) (z 10) (a 5))
+    (+ x (- 10 y))))
+
+(define (loop x)
+  
+  (printf "Iteration: ~a\n" x)
+  
+  (if (zero? x) 0
+        (loop (- (+ (local-vars) (- x 1)) 8))))
+; Generate gradually increasing sizes of lists
+; To trigger garbage collection at different points
+(printf "~a\n" (gen-list 1))
+(printf "~a\n" (gen-list 2))
+(printf "~a\n" (gen-list 4))
+(printf "~a\n" (gen-list 8))
+
+; Run a loop that uses local vars a few times
+(printf "Generating Primitives in loops\n")
+(loop 20)
+
+(printf "Try Allocating large list again\n")
+(printf "~a\n" (gen-list 8))
+
+
+; Create some circular references
+(define (gen-circular)
+  (let ([x (cons 3 4)])
+    (let ([y (cons 2 x)])
+      (set-rest! x y)
+      x)))
+
+(printf "Testing Circular References\n")
+(printf "~a\n" (gen-circular))
+(printf "~a\n" (gen-circular))
+(printf "~a\n" (gen-circular))
+(printf "~a\n" (gen-circular))
+(printf "~a\n" (gen-circular))
+(printf "~a\n" (gen-circular))
+(printf "~a\n" (gen-circular))
+(printf "~a\n" (gen-circular))
+(printf "~a\n" (gen-circular))
+
+(printf "Try allocating large list again\n")
+(printf "~a\n" (gen-list 8))
+(printf "~a\n" (gen-list 8))
+(printf "~a\n" (gen-list 8))
+(printf "~a\n" (gen-list 8))
+(printf "~a\n" (gen-list 8))
+
+(printf "Running sample tests\n")
+(define (fact x)
+  (if (zero? x)
+      1
+      (* x (fact (sub1 x)))))
+
+(define (fact-help x a)
+  (if (zero? x)
+      a
+      (fact-help (sub1 x) (* x a))))
+
+(define lst (cons 1 (cons 2 (cons 3 empty))))
+
+(define (map-add n lst)
+  (map (lambda (x) (+ n x)) lst))
+
+(define (map f lst)
+  (if (cons? lst)
+      (cons (f (first lst)) (map f (rest lst)))
+      empty))
+
+(define (filter p lst)
+  (if (cons? lst)
+      (if (p (first lst))
+          (cons (first lst) (filter p (rest lst)))
+          (filter p (rest lst)))
+      lst))
+
+(define (append l1 l2)
+  (if (cons? l1)
+      (cons (first l1) (append (rest l1) l2))
+      l2))
+
+(define (length lst)
+  (if (empty? lst)
+      0
+      (add1 (length (rest lst)))))
+
+(define tail (cons 1 empty))
+(define head (cons 4 (cons 3 (cons 2 tail))))
+(set-rest! tail head)
+
+(printf "res ~a\n" head)
+(set! head empty)
+(set! tail head)
+(printf "res ~a\n" lst)
+(printf "res ~a\n" (length '(hello goodbye)))
+(printf "res ~a\n" (map sub1 lst))
+
+(printf "(fact-help 15 1): ~a\n" (fact-help 15 1))
+(printf "(fact 9): ~a\n" (fact 9))
+
+(printf "(append lst lst): ~a\n" (append lst lst))
+
+(printf "(map-add 5 lst): ~a\n" (map-add 5 lst))
+(printf "(filter even? (map sub1 lst)): ~a\n" (filter even? (map sub1 lst)))
+(printf "(length lst): ~a\n" (length lst))

collects/tests/plai/gc2/good-mutators/student20111116.rkt

@@ -0,0 +1,98 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 84)
+(halt-on-errors)
+
+;(check-temps1 temps) -> boolean?
+; temps : (listof number?)
+;Consumes a list of temperature measures and checks whether all measurements are between 5 and 95 degrees celsius (inclusively.)
+
+(define (check-temps1 temps)
+  (if (empty? temps) #t ;divide end of the list / empty list from not-the-end
+    (and ; ? this temp is between 5 & 95
+     (>= (first temps) 5)
+     (<= (first temps) 95)
+     (check-temps1 (rest temps)) ; ? and so are all the rest
+    )
+  )
+)
+
+(check-temps1 '(7 10 32 87))
+(check-temps1 '(7 4 32 87))
+(check-temps1 '(7 98 32 87))
+
+;(check-temps temps low high) -> boolean?
+;  temps : (listof number?)
+;  low : number?
+;  high : number?
+;Consumes a list of temperature measures and checks whether all measurements are between low and high degrees celsius (inclusively.)
+
+(define (check-temps temps low high)
+  (if (empty? temps) #t ;divide end of the list / empty list from not-the-end
+    (and ; ? this temp is between low & high
+     (>= (first temps) low)
+     (<= (first temps) high)
+     (check-temps (rest temps) low high) ; ? and so are all the rest
+    )
+  )
+)
+
+(check-temps '(7 10 32 87) 5 90)
+(check-temps '(7 10 32 87) 8 90)
+(check-temps '(7 10 32 87) 5 80)
+
+;(convert digits) -> number?
+;  digits : (listof number?)
+;Consumes a list of digits (numbers between 0 and 9) and produces the corresponding number. The first digit is the least significant, and so on.
+
+(define (convert digits)
+  (if (empty? digits) 0 ;at the end, don't add anything!
+    (+ (first digits) (* 10 (convert (rest digits))))
+  )
+)
+
+(convert '(1 2 3))
+
+;(average-price prices) -> number?
+;  prices : (listof number?)
+;Consumes a list of toy prices and computes the average price of a toy. The average is total of all prices divided by the number of toys.
+
+(define (count-prices prices sum count) ;need to introduce some extra parameters to hold the count & sum for averaging
+  (if (empty? prices) (/ sum count) ;end of the list- calculate the average
+    (count-prices (rest prices) (+ sum (first prices)) (+ count 1)) ;increment the count & update the total sum
+  )
+)
+(define (average-price prices)
+  (if (empty? prices) 0 ;divide special case empty list from everything else
+    (count-prices prices 0 0)
+  )
+)
+
+(average-price '())
+(average-price '(5 15 32 6))
+
+;(convertFC fahrenheit) -> (listof number?)
+;  fahrenheit : (listof number?)
+;Converts a list of of Fahrenheit measurements to a list of Celsius measurements.
+
+(define (convertFC fahrenheit)
+  (if (empty? fahrenheit) empty
+    (cons (* (- (first fahrenheit) 32) 5/9) (convertFC (rest fahrenheit)))
+  )
+)
+
+(convertFC '(-40 15 32 50 60 85))
+
+;(eliminate-exp ua lotp) -> (listof number?)
+;  ua : number?
+;  lotp : (listof number?)
+;Eliminates from lotp all toys whose price is greater than ua.
+
+(define (eliminate-exp ua lotp)
+  (cond
+    [(empty? lotp) empty] ; end of the list
+    [(> (first lotp) ua) (eliminate-exp ua (rest lotp))] ;skip this element
+    [else (cons (first lotp) (eliminate-exp ua (rest lotp)))] ;keep this element
+  )
+)
+
+(eliminate-exp 15 '(1 16 3 5 22 8))

collects/tests/plai/gc2/good-mutators/tail-calls.rkt

@@ -0,0 +1,18 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 68)
+
+(define (length-accum lst len)
+  (if (empty? lst)
+      len
+      (length-accum (rest lst) (+ 1 len))))
+
+(define (length lst)
+  (length-accum lst 0))
+
+(define (fact/acc n a)
+  (if (zero? n)
+      a
+      (fact/acc (- n 1) (* n a))))
+
+(test/value=? (length '(1 2 3 4)) 4)
+(test/value=? (fact/acc 40 1) 815915283247897734345611269596115894272000000000)

collects/tests/plai/gc2/good-mutators/test-framework.rkt

@@ -0,0 +1,5 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 28)
+
+(halt-on-errors #t)
+(test/value=? 12 12)

collects/tests/plai/gc2/good-mutators/thunks.rkt

@@ -0,0 +1,15 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 4)
+
+; 2
+(define thunker
+  (lambda ()
+    ; 2
+    'alligator
+    ; 2
+    'bananna
+    ; 2
+    'frog))
+; 4 total
+
+(thunker)

collects/tests/plai/gc2/other-mutators/begin.rkt

@@ -0,0 +1,9 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 6)
+
+(define (go)
+  (let ([obj 'z])
+    2 3
+    (symbol? obj)))
+
+(go)

collects/tests/plai/gc2/other-mutators/error.rkt

@@ -0,0 +1,3 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 400)
+(error 'error "plai/gc2mutator has error")

collects/tests/plai/gc2/other-mutators/morse.rkt

@@ -0,0 +1,5 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 24)
+
+(define a '(1 2 3 4 5))
+

collects/tests/plai/gc2/other-mutators/printing.rkt

@@ -0,0 +1,19 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 400)
+(print-only-errors #f)
+
+(define lst (cons 1 (cons 2 (cons 3 empty))))
+(test/value=? lst '(1 2 3))
+
+(define (length lst)
+  (if (empty? lst)
+      0
+      (add1 (length (rest lst)))))
+
+(test/value=? (length '(hello goodbye)) 2)
+
+(define tail (cons 1 empty))
+(define head (cons 4 (cons 3 (cons 2 tail))))
+(set-rest! tail head)
+(test/location=? head (rest tail))
+(test/location=? head tail)

collects/tests/plai/gc2/other-mutators/quote.rkt

@@ -0,0 +1,29 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 28)
+
+1 2
+(define x
+  (cons 'apple-pie ; 2 + 3
+        (cons 'pumpkin-pie ; 2 + 3
+              empty))) ; 2
+; Need 12 cells
+1 2
+(define y
+  '(apple-pie pumpkin-pie))
+; Need 24 cells
+
+(define (equal? l r)
+  (cond
+    [(and (empty? l) (empty? r))
+     #t]
+    [(and (cons? l) (cons? r))
+     (and (equal? (first l) (first r))
+          (equal? (rest l) (rest r)))]
+    [(and (symbol? l) (symbol? r))
+     (symbol=? l r)]
+    [else
+     #f]))
+; Need 2 more for the proc
+
+; Need 2 more for the ans
+(equal? x y)

collects/tests/plai/gc2/other-mutators/top.rkt

@@ -0,0 +1,3 @@
+#lang plai/gc2mutator
+(allocator-setup "../good-collectors/good-collector.rkt" 400)
+frozzle

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

@@ -0,0 +1,66 @@
+#lang racket
+(require tests/eli-tester
+         racket/runtime-path)
+
+(define-runtime-path here ".")
+
+(define (in-directory pth rx)
+  (in-list
+   (map (curry build-path pth)
+        (filter (compose (curry regexp-match rx) path->bytes)
+                (directory-list pth)))))
+
+(define (test-mutator m)
+  (printf "Running ~a\n" m)
+  (parameterize ([current-namespace (make-base-empty-namespace)])
+    (dynamic-require m #f)))
+
+(define run-good? (make-parameter #f))
+
+(command-line #:program "run-test"
+              #:once-each ["-g" "Enable running good mutators" (run-good? #t)])
+
+(define (drop-first-line e)
+  (regexp-replace "^[^\n]+\n" e ""))
+(define-syntax-rule (capture-output e)
+  (drop-first-line (with-output-to-string (λ () e))))
+
+(test
+ (if (run-good?)
+     (for ([m (in-directory (build-path here "good-mutators") #rx"rkt$")])
+       (test
+        (test-mutator m)))
+     (void))
+ (for ([m (in-directory (build-path here "bad-mutators") #rx"rkt$")])
+   (test
+    (test-mutator m) =error> #rx""))
+ 
+ (test-mutator (build-path here "other-mutators" "error.rkt"))
+ =error>
+ #rx"plai/gc2mutator has error"
+ 
+ (test-mutator (build-path here "other-mutators" "top.rkt"))
+ =error>
+ #rx"unbound identifier in module in: frozzle"
+ 
+ (capture-output (test-mutator (build-path here "other-mutators" "printing.rkt")))
+ =>
+ #<<END
+(good lst '(1 2 3) '(1 2 3) "at line 6")
+(good (length (quote (hello goodbye))) 2 2 "at line 13")
+(good (heap-loc head) 62 62 "at line 18")
+(bad (heap-loc head) 62 47 "at line 19")
+
+END
+ 
+  (capture-output (test-mutator (build-path here "other-mutators" "begin.rkt")))
+ =>
+ #<<END
+Value at location 2:
+#t
+
+END
+ 
+ (test-mutator (build-path here "other-mutators" "quote.rkt"))
+ =error> "alloc: out of space"
+ )