adjust plai's gc2 language to use roots as the arguments
to gc:cons and gc:closure instead of passing locs This enables the important change, namely that get-root-set no longer returns roots corresponding to the arguments of the allocation function that we're in the middle of. This means that a common error students have (forgetting to chase the 'hd' and 'tl' pointers in their GC) is harder to make now, since get-root-set never contains those locations as roots. (In the past you would have had to write some pretty non-obvious mutator program to get that behavior.)
This commit is contained in:
Robby Findler
parent
44c274e6c3
commit
38f5823a59
|
|
@ -48,8 +48,8 @@
|
|||
(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:closure (closure-code? (vectorof location?) . -> . location?)))
|
||||
(provide/contract (gc:cons (root? root? . -> . location?)))
|
||||
(provide/contract (gc:closure (closure-code? (listof root?) . -> . location?)))
|
||||
|
||||
(provide/contract (gc:closure-code-ptr (location? . -> . closure-code?)))
|
||||
(provide/contract (gc:closure-env-ref (location? integer? . -> . location?)))
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
[mutator-lambda λ]
|
||||
(mutator-app #%app)
|
||||
(mutator-datum #%datum)
|
||||
(collector:cons cons)
|
||||
(mutator-cons cons)
|
||||
(collector:first first)
|
||||
(collector:rest rest)
|
||||
(mutator-quote quote)
|
||||
|
|
@ -118,6 +118,33 @@
|
|||
(yes! fe))])
|
||||
(mutator-begin e ...))]))
|
||||
|
||||
(define mutator-cons
|
||||
(let ([cons
|
||||
(λ (hd tl)
|
||||
(define roots (compute-current-roots))
|
||||
(define-values (hd-roots no-hd-roots)
|
||||
(partition (λ (x) (= hd (read-root x))) roots))
|
||||
(define-values (tl-roots no-hd-no-tl-roots)
|
||||
(partition (λ (x) (= tl (read-root x))) no-hd-roots))
|
||||
(parameterize ([active-roots no-hd-no-tl-roots])
|
||||
(collector:cons (make-root 'hd
|
||||
(λ () hd)
|
||||
(λ (v)
|
||||
(set! hd v)
|
||||
(for ([r (in-list hd-roots)])
|
||||
(set-root! r v))))
|
||||
(make-root 'tl
|
||||
(λ () tl)
|
||||
(λ (v)
|
||||
(set! tl v)
|
||||
(for ([r (in-list tl-roots)])
|
||||
(set-root! r v)))))))])
|
||||
cons))
|
||||
|
||||
(define (do-alloc-flat flat)
|
||||
(parameterize ([active-roots (compute-current-roots)])
|
||||
(collector:alloc-flat flat)))
|
||||
|
||||
; Real Macros
|
||||
(define-syntax-rule (mutator-define-values (id ...) e)
|
||||
(begin (define-values (id ...)
|
||||
|
|
@ -205,16 +232,46 @@
|
|||
closure))])
|
||||
#,(if (syntax-parameter-value #'mutator-tail-call?)
|
||||
(syntax/loc stx
|
||||
(#%app collector:closure closure (vector free-id ...)))
|
||||
(#%app do-collector:closure closure
|
||||
(list (λ () free-id) ...)
|
||||
(list (λ (v) (set! free-id v)) ...)))
|
||||
(syntax/loc stx
|
||||
(with-continuation-mark
|
||||
gc-roots-key
|
||||
(list (make-env-root env-id) ...)
|
||||
(#%app collector:closure closure (vector free-id ...)))))))))]
|
||||
(#%app do-collector:closure closure
|
||||
(list (λ () free-id) ...)
|
||||
(list (λ (v) (set! free-id v)) ...)))))))))]
|
||||
[(_ (id ...) body ...)
|
||||
(syntax/loc stx
|
||||
(mutator-lambda (id ...) (mutator-begin body ...)))]))
|
||||
|
||||
(define (do-collector:closure closure getters setters)
|
||||
(define-values (remaining-roots closure-roots)
|
||||
(let loop ([getters getters]
|
||||
[setters setters]
|
||||
[remaining-roots (compute-current-roots)]
|
||||
[closure-roots '()])
|
||||
(cond
|
||||
[(null? getters) (values remaining-roots closure-roots)]
|
||||
[else
|
||||
(define this-loc ((car getters)))
|
||||
(define this-setter (car setters))
|
||||
(define-values (this-other-roots leftovers)
|
||||
(filter (λ (x) (= (read-root x) this-loc)) remaining-roots))
|
||||
(loop (cdr getters) (cdr setters)
|
||||
leftovers
|
||||
(cons (make-root 'closure-root
|
||||
(λ () this-loc)
|
||||
(λ (v)
|
||||
(set! this-loc v)
|
||||
(this-setter v)
|
||||
(for ([root (in-list this-other-roots)])
|
||||
(set-root! v))))
|
||||
closure-roots))])))
|
||||
(parameterize ([active-roots remaining-roots])
|
||||
(collector:closure closure closure-roots)))
|
||||
|
||||
(define-syntax (mutator-app stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e ...)
|
||||
|
|
@ -247,7 +304,7 @@
|
|||
stx)))
|
||||
(with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)]
|
||||
[app-exp (if prim-app?
|
||||
(syntax/loc stx (collector:alloc-flat (fe (collector:deref ae) ...)))
|
||||
(syntax/loc stx (do-alloc-flat (fe (collector:deref ae) ...)))
|
||||
(syntax/loc stx ((deref-proc fe) ae ...)))])
|
||||
(if (syntax-parameter-value #'mutator-tail-call?)
|
||||
; If this call is in tail position, we will not need access
|
||||
|
|
@ -261,13 +318,13 @@
|
|||
(define-syntax mutator-quote
|
||||
(syntax-rules ()
|
||||
[(_ (a . d))
|
||||
(mutator-app collector:cons (mutator-quote a) (mutator-quote d))]
|
||||
(mutator-app mutator-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)))]))
|
||||
(quasisyntax/loc stx (mutator-anf-app do-alloc-flat (#%datum . e)))]))
|
||||
|
||||
(define-syntax (mutator-top-interaction stx)
|
||||
(syntax-case stx (require provide mutator-define mutator-define-values test/value=? import-primitives)
|
||||
|
|
@ -404,7 +461,7 @@
|
|||
(let ([result (apply renamed-id (map collector:deref args))])
|
||||
(cond
|
||||
[(void? result) (void)]
|
||||
[(heap-value? result) (collector:alloc-flat result)]
|
||||
[(heap-value? result) (do-alloc-flat result)]
|
||||
[else
|
||||
(error 'id (string-append "imported primitive must return <heap-value?>, "
|
||||
"received ~a" result))]))))
|
||||
|
|
@ -447,7 +504,7 @@
|
|||
(define (member? v l)
|
||||
(and (member v l) #t))
|
||||
(define (mutator-member? v l)
|
||||
(collector:alloc-flat
|
||||
(do-alloc-flat
|
||||
(member? (collector:deref v)
|
||||
(gc->scheme l))))
|
||||
|
||||
|
|
@ -480,17 +537,17 @@
|
|||
(define (mutator-empty? loc)
|
||||
(cond
|
||||
[(collector:flat? loc)
|
||||
(collector:alloc-flat (empty? (collector:deref loc)))]
|
||||
(do-alloc-flat (empty? (collector:deref loc)))]
|
||||
[else
|
||||
(collector:alloc-flat false)]))
|
||||
(do-alloc-flat false)]))
|
||||
|
||||
(provide (rename-out [mutator-cons? cons?]))
|
||||
(define (mutator-cons? loc)
|
||||
(collector:alloc-flat (collector:cons? loc)))
|
||||
(do-alloc-flat (collector:cons? loc)))
|
||||
|
||||
(provide (rename-out [mutator-eq? eq?]))
|
||||
(define (mutator-eq? l1 l2)
|
||||
(collector:alloc-flat (= l1 l2)))
|
||||
(do-alloc-flat (= l1 l2)))
|
||||
|
||||
(provide (rename-out [mutator-printf printf]))
|
||||
(define-syntax (mutator-printf stx)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang scheme
|
||||
(require (for-syntax racket/syntax))
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/syntax
|
||||
racket/base))
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-syntax (define-collector-export stx)
|
||||
|
|
@ -7,8 +8,9 @@
|
|||
[(_ i)
|
||||
(with-syntax
|
||||
([collector:i (format-id #'i "collector:~a" #'i)]
|
||||
[set-collector:i! (format-id #'i "set-collector:~a!" #'i)])
|
||||
#'(begin (define collector:i false)
|
||||
[set-collector:i! (format-id #'i "set-collector:~a!" #'i)]
|
||||
[uninit-collector:i (format-id #'i "uninit-collector:~a" #'i)])
|
||||
#'(begin (define collector:i 'uninit-collector:i)
|
||||
(define (set-collector:i! proc)
|
||||
(set! collector:i proc))))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -145,47 +145,41 @@
|
|||
(set! global-roots (cons root global-roots)))
|
||||
|
||||
(provide get-root-set)
|
||||
(define-syntax (get-root-set stx)
|
||||
(syntax-case stx ()
|
||||
[(_ root-id ...)
|
||||
(andmap identifier? (syntax->list #'(root-id ...)))
|
||||
#`(get-root-set/proc (list (λ () root-id) ...)
|
||||
(list (λ (x) (set! root-id x)) ...)
|
||||
'(root-id ...))]
|
||||
[(_ e ...)
|
||||
(let ([err (ormap (λ (x) (and (not (identifier? x)) x)) (syntax->list #'(e ...)))])
|
||||
(raise-syntax-error false
|
||||
"expected an identifier to treat as a root"
|
||||
stx
|
||||
err))]
|
||||
[_ (raise-syntax-error false
|
||||
"missing open parenthesis"
|
||||
stx)]))
|
||||
(define (get-root-set) (append (active-roots) (user-specified-roots)))
|
||||
|
||||
(define (get-root-set/proc root-getters root-setters root-ids)
|
||||
(append
|
||||
(for/list ([root-getter (in-list root-getters)]
|
||||
[root-setter (in-list root-setters)]
|
||||
[root-id (in-list root-ids)])
|
||||
(if (location? (root-getter))
|
||||
(make-root root-id root-getter root-setter)
|
||||
(error 'get-root-set "expected a location, given ~e" (root-getter))))
|
||||
(get-global-roots)
|
||||
(stack-roots)
|
||||
(user-specified-roots)))
|
||||
(provide compute-current-roots)
|
||||
(define (compute-current-roots) (append (get-global-roots) (stack-roots)))
|
||||
|
||||
(provide active-roots)
|
||||
(define active-roots (make-parameter '()))
|
||||
|
||||
(provide with-roots)
|
||||
(define-syntax-rule
|
||||
(with-roots e1 e2 e3 ...)
|
||||
(with-roots/proc e1 (λ () e2 e3 ...)))
|
||||
(define-syntax (with-roots stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (x ...) e2 e3 ...)
|
||||
(begin
|
||||
(for ([x (in-list (syntax->list #'(x ...)))])
|
||||
(unless (identifier? #'x)
|
||||
(raise-syntax-error 'with-roots "expected an identifier" stx x)))
|
||||
#'(with-roots/proc
|
||||
(list (λ () x) ...)
|
||||
(list (λ (v) (set! x v)) ...)
|
||||
(λ () e2 e3 ...)))]))
|
||||
|
||||
(define (with-roots/proc roots thunk)
|
||||
(define (with-roots/proc getters setters thunk)
|
||||
(define c (listof location?))
|
||||
(unless (c roots)
|
||||
(raise-argument-error 'with-roots
|
||||
(format "~s" (contract-name c))
|
||||
roots))
|
||||
(parameterize ([user-specified-roots (append roots (user-specified-roots))])
|
||||
(for ([getter (in-list getters)])
|
||||
(define rt (getter))
|
||||
(unless (location? rt)
|
||||
(raise-argument-error 'with-roots
|
||||
'location?
|
||||
rt)))
|
||||
(parameterize ([user-specified-roots
|
||||
(append
|
||||
(map (λ (x y) (make-root 'user-specified x y))
|
||||
getters
|
||||
setters)
|
||||
(user-specified-roots))])
|
||||
(thunk)))
|
||||
|
||||
(define user-specified-roots (make-parameter '()))
|
||||
|
|
|
|||
|
|
@ -16,14 +16,13 @@
|
|||
halt-on-errors print-only-errors
|
||||
test-inexact-epsilon plai-ignore-exn-strings
|
||||
plai-all-test-results)
|
||||
(only-in plai/collector
|
||||
(only-in plai/gc2/collector
|
||||
root?
|
||||
heap-size
|
||||
location?
|
||||
heap-value?
|
||||
heap-set! heap-ref with-heap
|
||||
get-root-set read-root set-root!
|
||||
procedure-roots)
|
||||
get-root-set read-root set-root! make-root)
|
||||
plai/scribblings/fake-collector
|
||||
plai/scribblings/fake-mutator
|
||||
plai/scribblings/fake-web
|
||||
|
|
@ -31,7 +30,7 @@
|
|||
(only-in plai/web
|
||||
no-web-browser
|
||||
static-files-path)
|
||||
(only-in plai/mutator
|
||||
(only-in plai/gc2/mutator
|
||||
set-first!
|
||||
set-rest!
|
||||
import-primitives
|
||||
|
|
@ -84,9 +83,10 @@ Determines if @racket[v] is a root.
|
|||
Returns the value at @racket[_loc].
|
||||
}
|
||||
|
||||
@defform/subs[(get-root-set id ...)()]{
|
||||
Returns the current roots as a list. Local roots are created for the
|
||||
identifiers @racket[_id] as well.
|
||||
@defform[(get-root-set)]{
|
||||
Returns the current @racket[root?]s as a list. This returns
|
||||
valid roots only when invoked via the mutator language. Otherwise
|
||||
it returns only what has been set up with @racket[with-roots].
|
||||
}
|
||||
|
||||
@defproc[(read-root (root root?)) location?]{
|
||||
|
|
@ -94,13 +94,21 @@ Determines if @racket[v] is a root.
|
|||
}
|
||||
|
||||
@defproc[(set-root! (root root?) (loc location?)) void?]{
|
||||
Updates the root to reference the given location.
|
||||
Updates @racket[root] to refer to @racket[loc].
|
||||
}
|
||||
|
||||
@defproc[(procedure-roots (proc procedure?)) (listof root?)]{
|
||||
Given a closure stored on the heap, returns a list of the roots reachable
|
||||
from the closure's environment. If @racket[_proc] is not reachable, the
|
||||
empty list is returned.
|
||||
@defproc[(make-root [name symbol?] [get (-> location?)] [set (-> location? void?)])
|
||||
root?]{
|
||||
Creates a new root. When @racket[read-root] is called, it invokes
|
||||
@racket[get] and when @racket[set-root!] is called, it invokes
|
||||
@racket[set].
|
||||
|
||||
For example, this creates a root that uses the local variable
|
||||
@racket[x] to hold its location:
|
||||
@racketblock[(let ([x 1])
|
||||
(make-root 'x
|
||||
(λ () x)
|
||||
(λ (new-x) (set! x new-x))))]
|
||||
}
|
||||
|
||||
@defform[(with-heap heap-expr body-expr ...)
|
||||
|
|
@ -115,28 +123,35 @@ Determines if @racket[v] is a root.
|
|||
2)
|
||||
]}
|
||||
|
||||
@defform[(with-roots roots-expr expr1 expr2 ...)
|
||||
@defform[(with-roots (root-var ...) expr1 expr2 ...)
|
||||
#:contracts ([roots-expr (listof location?)])]{
|
||||
Evaluates each of @racket[expr1] and the @racket[expr2]s in
|
||||
in a context with the result of @racket[roots-expr]
|
||||
as additional roots.
|
||||
in a context with additional roots, one for each of
|
||||
the @racket[root-var]s. The @racket[get-root-set] function
|
||||
returns these additional roots. Calling @racket[read-root] on
|
||||
one of the newly created roots returns the value of the
|
||||
corresponding @racket[root-var] and calling @racket[set-root!]
|
||||
mutates the corresponding variable.
|
||||
|
||||
This function is intended to be used in test suites
|
||||
This form is intended to be used in test suites
|
||||
for collectors. Since your test suites are not running
|
||||
in the @racketmod[plai/gc2/mutator] language, @racket[get-root-set]
|
||||
returns a list consisting only of the roots it created,
|
||||
not all of the other roots it normally would return.
|
||||
Use this function to note specific locations as roots
|
||||
Use @racket[with-roots] to note specific locations as roots
|
||||
and set up better tests for your GC.
|
||||
|
||||
@racketblock[
|
||||
(test (with-heap (make-vector 4)
|
||||
(define f1 (gc:alloc-flat 1))
|
||||
(define c1 (gc:cons f1 f1))
|
||||
(with-roots (list c1)
|
||||
(define r1 (make-root 'f1
|
||||
(λ () f1)
|
||||
(λ (v) (set! f1 v))))
|
||||
(define c1 (gc:cons r1 r1))
|
||||
(with-roots (c1)
|
||||
(gc:deref
|
||||
(gc:first
|
||||
(gc:cons f1 f1)))))
|
||||
(gc:cons r1 r1)))))
|
||||
1)]
|
||||
|
||||
}
|
||||
|
|
@ -178,9 +193,9 @@ language exposes the environment via the @racket[procedure-roots] function.
|
|||
|
||||
}
|
||||
|
||||
@defproc[(gc:cons (first location?) (rest location?)) location?]{
|
||||
@defproc[(gc:cons (first root?) (rest root?)) location?]{
|
||||
|
||||
Given the location of the @racket[_first] and @racket[_rest] values, this
|
||||
Given two roots, one for the @racket[first] and @racket[rest] values, this
|
||||
procedure must allocate a cons cell on the heap. If there is insufficient
|
||||
space to allocate the cons cell, it should signal an error.
|
||||
|
||||
|
|
@ -202,37 +217,37 @@ field. Otherwise, it should signal an error.
|
|||
|
||||
@defproc[(gc:set-first! (cons-cell location?) (first-value location?)) void?]{
|
||||
|
||||
If @racket[_cons-cell] refers to a cons cell, set the head of the cons cell to
|
||||
@racket[_first-value]. Otherwise, signal an error.
|
||||
If @racket[cons-cell] refers to a cons cell, set the head of the cons cell to
|
||||
@racket[first-value]. Otherwise, signal an error.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(gc:set-rest! (cons-cell location?) (rest-value location?)) void?]{
|
||||
|
||||
If @racket[_cons-cell] refers to a cons cell, set the tail of the cons cell to
|
||||
@racket[_rest-value]. Otherwise, signal an error.
|
||||
If @racket[cons-cell] refers to a cons cell, set the tail of the cons cell to
|
||||
@racket[rest-value]. Otherwise, signal an error.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(gc:cons? (loc location?)) boolean?]{
|
||||
|
||||
|
||||
Returns @racket[true] if @racket[_loc] refers to a cons cell. This function
|
||||
Returns @racket[#true] if @racket[loc] refers to a cons cell. This function
|
||||
should never signal an error.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(gc:flat? (loc location?)) boolean?]{
|
||||
|
||||
Returns @racket[true] if @racket[_loc] refers to a flat value. This function
|
||||
Returns @racket[#true] if @racket[loc] refers to a flat value. This function
|
||||
should never signal an error.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(gc:closure [code-ptr heap-value?] [free-vars (vectorof location?)])
|
||||
@defproc[(gc:closure [code-ptr heap-value?] [free-vars (listof root?)])
|
||||
location?]{
|
||||
Allocates a closure with 'code-ptr' and the free variables
|
||||
in the vector 'free-vars'.
|
||||
Allocates a closure with @racket[code-ptr] and the free variables
|
||||
in the list @racket[free-vars].
|
||||
}
|
||||
@defproc[(gc:closure-code-ptr [loc location?]) heap-value?]{
|
||||
Given a location returned from an earlier allocation
|
||||
|
|
|
|||
|
|
@ -169,21 +169,21 @@ A collector for use in testing the random mutator generator.
|
|||
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 ptr (alloc 3 (λ () (list* hd tl (get-root-set)))))
|
||||
(heap-set! ptr 'pair)
|
||||
(heap-set! (+ ptr 1) (read-root hd))
|
||||
(heap-set! (+ ptr 2) (read-root tl))
|
||||
ptr)
|
||||
|
||||
(define (gc:closure code env)
|
||||
(define len (vector-length env))
|
||||
(define ptr (alloc (+ 3 len) (λ () (append (get-root-set) (vector->roots env)))))
|
||||
(define len (length env))
|
||||
(define ptr (alloc (+ 3 len) (λ () (append (get-root-set) env))))
|
||||
(heap-set! ptr 'closure)
|
||||
(heap-set! (+ ptr 1) code)
|
||||
(heap-set! (+ ptr 2) len)
|
||||
(for ([v (in-vector env)]
|
||||
(for ([r (in-list env)]
|
||||
[i (in-naturals)])
|
||||
(heap-set! (+ ptr 3 i) v))
|
||||
(heap-set! (+ ptr 3 i) (read-root r)))
|
||||
ptr)
|
||||
|
||||
(define (alloc n get-roots)
|
||||
|
|
@ -339,12 +339,14 @@ A collector for use in testing the random mutator generator.
|
|||
(vector 'free 'free 'free 'free 'pair 4 4))
|
||||
|
||||
(test (with-heap (make-vector 50)
|
||||
(with-roots (list 1 2 3)
|
||||
(get-root-set)))
|
||||
(let ([x 1][y 2][z 3])
|
||||
(with-roots (x y z)
|
||||
(map read-root (get-root-set)))))
|
||||
(list 1 2 3))
|
||||
|
||||
(test (with-heap (make-vector 50)
|
||||
(with-roots (list 1 2 3)
|
||||
(with-roots (list 4 5 6)
|
||||
(sort (get-root-set) <))))
|
||||
(list 1 2 3 4 5 6))
|
||||
(let ([x 1][y 2][z 3][a 4][b 5][c 6])
|
||||
(with-roots (x y z)
|
||||
(with-roots (a b c)
|
||||
(sort (map read-root (get-root-set)) <)))))
|
||||
(list 1 2 3 4 5 6))
|
||||
|
|
|
|||
|
|
@ -5,15 +5,15 @@
|
|||
; calling heap-offset before init-allocator is called gives 'undefined
|
||||
(set! heap-ptr 0))
|
||||
|
||||
(define (gc:closure code vs)
|
||||
(define len (vector-length vs))
|
||||
(define (gc:closure code roots)
|
||||
(define len (length roots))
|
||||
(when (> (+ heap-ptr len) (heap-size))
|
||||
(error "out of memory"))
|
||||
(heap-set! heap-ptr 'closure)
|
||||
(heap-set! (+ 1 heap-ptr) code)
|
||||
(for ([v (in-vector vs)]
|
||||
(for ([r (in-list roots)]
|
||||
[i (in-naturals 1)])
|
||||
(heap-set! (+ 1 i heap-ptr) v))
|
||||
(heap-set! (+ 1 i heap-ptr) (read-root r)))
|
||||
(set! heap-ptr (+ len 2 heap-ptr))
|
||||
;; return the location of this flat data
|
||||
(- heap-ptr len 2))
|
||||
|
|
@ -40,8 +40,8 @@
|
|||
(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)
|
||||
(heap-set! (+ 1 heap-ptr) (read-root f))
|
||||
(heap-set! (+ 2 heap-ptr) (read-root r))
|
||||
(set! heap-ptr (+ 3 heap-ptr))
|
||||
(- heap-ptr 3)))
|
||||
|
||||
|
|
@ -74,18 +74,13 @@
|
|||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (with-heap (vector 2 3)
|
||||
(let ([x 0])
|
||||
(set-root! (car (get-root-set x)) 1)
|
||||
x))
|
||||
1)
|
||||
|
||||
(check-equal? (let ([h (make-vector 7)])
|
||||
(with-heap
|
||||
h
|
||||
(init-allocator)
|
||||
(define one (gc:alloc-flat 1))
|
||||
(define clos (gc:closure 'something (vector one)))
|
||||
(define clos (gc:closure 'something (list (make-root 'dummy (λ () one) void))))
|
||||
(gc:alloc-flat 2))
|
||||
h)
|
||||
(vector 'prim 1 'closure 'something 0 'prim 2)))
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ that prints out all of the flat values in the root set at the point
|
|||
when a cons happens.
|
||||
|
||||
Then it sets up various little expressions (in the calls to 'run-one')
|
||||
that check the root set contents.
|
||||
that check the root set contents and the arguments to cons.
|
||||
|
||||
The roots are printed only if they are flat values and the values
|
||||
themselves are printed, sorted with duplicates removed. (Also the code
|
||||
|
|
@ -64,14 +64,16 @@ that the test cases have to be set up somewhat carefully.
|
|||
(begin
|
||||
(when (> (+ heap-ptr 3) (heap-size))
|
||||
(error "out of memory"))
|
||||
(define (get-prim x) (heap-ref (+ (read-root x) 1)))
|
||||
(define prim-roots
|
||||
(for/list ([x (in-list (get-root-set))]
|
||||
#:when (eq? 'prim (heap-ref (read-root x))))
|
||||
(heap-ref (+ (read-root x) 1))))
|
||||
(printf "~s\n" (cons 'roots (remove-duplicates (sort prim-roots <))))
|
||||
(get-prim x)))
|
||||
(printf "~s\n" (append (cons 'roots (remove-duplicates (sort prim-roots <)))
|
||||
(list 'hd (get-prim f) 'tl (get-prim r))))
|
||||
(heap-set! heap-ptr 'cons)
|
||||
(heap-set! (+ 1 heap-ptr) f)
|
||||
(heap-set! (+ 2 heap-ptr) r)
|
||||
(heap-set! (+ 1 heap-ptr) (read-root f))
|
||||
(heap-set! (+ 2 heap-ptr) (read-root r))
|
||||
(set! heap-ptr (+ 3 heap-ptr))
|
||||
(- heap-ptr 3)))
|
||||
|
||||
|
|
@ -119,21 +121,21 @@ that the test cases have to be set up somewhat carefully.
|
|||
@run-one['non-tail-cons]{#lang plai/gc2/mutator
|
||||
(allocator-setup 'gc 200)
|
||||
(first (cons 1 2))}
|
||||
'((roots 1 2)))
|
||||
'((roots hd 1 tl 2)))
|
||||
|
||||
(check-equal?
|
||||
@run-one['tail-cons]{#lang plai/gc2/mutator
|
||||
(allocator-setup 'gc 200)
|
||||
(define (f x) (cons 1 2))
|
||||
(f 3)}
|
||||
'((roots 3)))
|
||||
'((roots 3 hd 1 tl 2)))
|
||||
|
||||
(check-equal?
|
||||
@run-one['tail-cons-with-unused-var]{#lang plai/gc2/mutator
|
||||
(allocator-setup 'gc 200)
|
||||
(define (f x) (let ([y 2]) (cons 3 4)))
|
||||
(f 1)}
|
||||
'((roots 1)))
|
||||
'((roots 1 hd 3 tl 4)))
|
||||
|
||||
(check-equal?
|
||||
@run-one['cons-with-used-var]{#lang plai/gc2/mutator
|
||||
|
|
@ -142,7 +144,7 @@ that the test cases have to be set up somewhat carefully.
|
|||
(let ([z (cons 3 4)])
|
||||
y)))
|
||||
(f 1)}
|
||||
'((roots 1 2 3 4)))
|
||||
'((roots 1 2 hd 3 tl 4)))
|
||||
|
||||
|
||||
(check-equal?
|
||||
|
|
@ -152,7 +154,7 @@ that the test cases have to be set up somewhat carefully.
|
|||
(let ([z (cons 3 4)])
|
||||
x)))
|
||||
(f 1)}
|
||||
'((roots 1 3 4)))
|
||||
'((roots 1 hd 3 tl 4)))
|
||||
|
||||
|
||||
(check-equal?
|
||||
|
|
@ -162,7 +164,7 @@ that the test cases have to be set up somewhat carefully.
|
|||
[(z) (cons 3 4)])
|
||||
x))
|
||||
(f 1)}
|
||||
'((roots 1 3 4)))
|
||||
'((roots 1 hd 3 tl 4)))
|
||||
|
||||
(check-equal?
|
||||
@run-one['let-values2]{#lang plai/gc2/mutator
|
||||
|
|
@ -171,7 +173,7 @@ that the test cases have to be set up somewhat carefully.
|
|||
[(z) (cons 3 4)])
|
||||
y))
|
||||
(f 1)}
|
||||
'((roots 1 2 3 4)))
|
||||
'((roots 1 2 hd 3 tl 4)))
|
||||
|
||||
(check-equal?
|
||||
@run-one['fn-args]{#lang plai/gc2/mutator
|
||||
|
|
@ -179,7 +181,7 @@ that the test cases have to be set up somewhat carefully.
|
|||
(define (f x) (let ([z (cons 1 2)]) x))
|
||||
(define (g y) (f 3))
|
||||
(g 4)}
|
||||
'((roots 1 2 3 4)))
|
||||
'((roots 3 4 hd 1 tl 2)))
|
||||
|
||||
(check-equal?
|
||||
@run-one['fn-args2]{#lang plai/gc2/mutator
|
||||
|
|
@ -187,7 +189,7 @@ that the test cases have to be set up somewhat carefully.
|
|||
(define (f x) (let ([z (cons 1 2)]) z))
|
||||
(define (g y) (f 3))
|
||||
(g 4)}
|
||||
'((roots 1 2 4)))
|
||||
'((roots 4 hd 1 tl 2)))
|
||||
|
||||
(check-equal?
|
||||
@run-one['fn-args3]{#lang plai/gc2/mutator
|
||||
|
|
@ -195,4 +197,4 @@ that the test cases have to be set up somewhat carefully.
|
|||
(define (f x) (cons 1 2))
|
||||
(define (g y) (f 3))
|
||||
(g 4)}
|
||||
'((roots 4)))
|
||||
'((roots 4 hd 1 tl 2)))
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
(directory-list pth)))))
|
||||
|
||||
(define (test-mutator m)
|
||||
(printf "Running ~a\n" m)
|
||||
(printf "Running ~a\n" (simplify-path m))
|
||||
(parameterize ([current-namespace (make-base-empty-namespace)])
|
||||
(dynamic-require m #f)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user