suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add tests for plai's get-root-set (in gc2)

Browse Source
This commit is contained in:
Robby Findler 2013-03-08 13:06:31 -06:00
parent 3311387201
commit eb41882843
1 changed files with 198 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

198
collects/tests/plai/gc2/roots-test.rkt Normal file
View File

@ -0,0 +1,198 @@
#lang at-exp racket
(require rackunit)
#|
This file has tests for the mutator transformation to make
sure that the right things are in the result of get-root-set.
It works by setting up a collector (one that doesn't actually collect)
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.
The roots are printed only if they are flat values and the values
themselves are printed, sorted with duplicates removed. (Also the code
crashes if there are non-real-number flat values
because the root values are sorted before printing.) So this means
that the test cases have to be set up somewhat carefully.
|#
(define ns (make-base-namespace))
(parameterize ([current-namespace ns]
[current-module-declare-name (make-resolved-module-path 'gc)])
(eval
(parameterize ([read-accept-reader #t])
(read-syntax
'stuff
(open-input-string
@string-append{#lang plai/gc2/collector
(define heap-ptr 'uninitialized-heap-ptr)
(define (init-allocator) (set! heap-ptr 0))
(define (gc:closure code vs)
(define len (vector-length vs))
(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)]
[i (in-naturals 1)])
(heap-set! (+ 1 i heap-ptr) v))
(set! heap-ptr (+ len 2 heap-ptr))
;; return the location of this flat data
(- heap-ptr len 2))
(define (gc:closure-code-ptr a) (heap-ref (+ a 1)))
(define (gc:closure-env-ref a i) (heap-ref (+ a 1 1 i)))
(define (gc:closure? a) (eq? (heap-ref a) 'closure))
(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"))
(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 <))))
(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)))
(define (gc:cons? a) (eq? (heap-ref a) 'cons))
(define (gc:first a) (heap-ref (+ 1 a)))
(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))
(define (gc:flat? a) (eq? 'prim (heap-ref a)))})))))
;; each call to 'run-one' must have a unique name;
;; these names are used as module names.
;; the result is a list with one element for each
;; call to cons, listing the roots (as discussed above)
(define (run-one name . strings)
(parameterize ([current-namespace ns]
[current-module-declare-name
(make-resolved-module-path name)])
(eval
(parameterize ([read-accept-reader #t])
(read-syntax
'stuff
(open-input-string (apply string-append strings)))))
(define sp (open-output-string))
(parameterize ([current-output-port sp])
(namespace-require `',name))
(define ip (open-input-string (get-output-string sp)))
(let loop ()
(define l (read-line (peeking-input-port ip)))
(cond
[(eof-object? l) '()]
[(regexp-match #rx"^[(]roots" l)
(cons (read ip) (loop))]
[else
;; skip over lines that don't look like the roots printouts
(read-line ip)
(loop)]))))
(check-equal?
@run-one['non-tail-cons]{#lang plai/gc2/mutator
(allocator-setup 'gc 200)
(first (cons 1 2))}
'((roots 1 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)))
(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)))
(check-equal?
@run-one['cons-with-used-var]{#lang plai/gc2/mutator
(allocator-setup 'gc 200)
(define (f x) (let ([y 2])
(let ([z (cons 3 4)])
y)))
(f 1)}
'((roots 1 2 3 4)))
(check-equal?
@run-one['cons-with-unused-var]{#lang plai/gc2/mutator
(allocator-setup 'gc 200)
(define (f x) (let ([y 2])
(let ([z (cons 3 4)])
x)))
(f 1)}
'((roots 1 3 4)))
(check-equal?
@run-one['let-values]{#lang plai/gc2/mutator
(allocator-setup 'gc 200)
(define (f x) (let-values ([(y) 2]
[(z) (cons 3 4)])
x))
(f 1)}
'((roots 1 3 4)))
(check-equal?
@run-one['let-values2]{#lang plai/gc2/mutator
(allocator-setup 'gc 200)
(define (f x) (let-values ([(y) 2]
[(z) (cons 3 4)])
y))
(f 1)}
'((roots 1 2 3 4)))
(check-equal?
@run-one['fn-args]{#lang plai/gc2/mutator
(allocator-setup 'gc 200)
(define (f x) (let ([z (cons 1 2)]) x))
(define (g y) (f 3))
(g 4)}
'((roots 1 2 3 4)))
(check-equal?
@run-one['fn-args2]{#lang plai/gc2/mutator
(allocator-setup 'gc 200)
(define (f x) (let ([z (cons 1 2)]) z))
(define (g y) (f 3))
(g 4)}
'((roots 1 2 4)))
(check-equal?
@run-one['fn-args3]{#lang plai/gc2/mutator
(allocator-setup 'gc 200)
(define (f x) (cons 1 2))
(define (g y) (f 3))
(g 4)}
'((roots 4)))