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

Test cleanup

Browse Source 
svn: r18150
This commit is contained in:
Jay McCarthy 2010-02-18 16:14:41 +00:00
parent b51f3e0940
commit 25dbc6a418
10 changed files with 218 additions and 770 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/plai/mutator.ss
View File

@ -84,11 +84,11 @@
[(_ (f a ...) e ...) [(_ (f a ...) e ...)
(mutator-define-values (f) (mutator-define-values (f)
(syntax-parameterize ([mutator-name #'f]) (syntax-parameterize ([mutator-name #'f])
(mutator-lambda (a ...) e ...)))] (mutator-lambda (a ...) e ...)))]
[(_ id e) [(_ id e)
(mutator-define-values (id) (mutator-define-values (id)
(syntax-parameterize ([mutator-name #'id]) (syntax-parameterize ([mutator-name #'id])
e))])) e))]))
(define-syntax-rule (mutator-let ([id e] ...) be ...) (define-syntax-rule (mutator-let ([id e] ...) be ...)
(mutator-let-values ([(id) (syntax-parameterize ([mutator-name #'id]) (mutator-let-values ([(id) (syntax-parameterize ([mutator-name #'id])
e)] e)]
@ -272,25 +272,19 @@
(gc->scheme result-addr)])])))])) (gc->scheme result-addr)])])))]))
; Module Begin ; Module Begin
(define-for-syntax required-allocator-stx false)
(define-for-syntax (allocator-setup-internal stx) (define-for-syntax (allocator-setup-internal stx)
(with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons (syntax-case stx ()
gc:first gc:rest [(collector-module heap-size)
gc:flat? gc:cons? (with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons
gc:set-first! gc:set-rest!) gc:first gc:rest
(map (λ (s) (datum->syntax stx s)) gc:flat? gc:cons?
'(init-allocator gc:deref gc:alloc-flat gc:cons gc:set-first! gc:set-rest!)
gc:first gc:rest (map (λ (s) (datum->syntax stx s))
gc:flat? gc:cons? '(init-allocator gc:deref gc:alloc-flat gc:cons
gc:set-first! gc:set-rest!))]) gc:first gc:rest
(syntax-case stx () gc:flat? gc:cons?
[(collector-module heap-size) gc:set-first! gc:set-rest!))])
(begin (begin
(set! required-allocator-stx
(if (alternate-collector)
(datum->syntax stx (alternate-collector))
#'collector-module))
#`(begin #`(begin
#,(if (alternate-collector) #,(if (alternate-collector)
#`(require #,(datum->syntax #'collector-module (alternate-collector))) #`(require #,(datum->syntax #'collector-module (alternate-collector)))
@ -311,10 +305,10 @@
(if (<= (#%datum . heap-size) 500) (if (<= (#%datum . heap-size) 500)
(set-ui! (dynamic-require `plai/private/gc-gui 'heap-viz%)) (set-ui! (dynamic-require `plai/private/gc-gui 'heap-viz%))
(printf "Large heap; the heap visualizer will not be displayed.~n"))) (printf "Large heap; the heap visualizer will not be displayed.~n")))
(init-allocator)))] (init-allocator))))]
[_ (raise-syntax-error 'mutator [_ (raise-syntax-error 'mutator
"Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)" "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)"
stx)]))) stx)]))
(define-for-syntax allocator-setup-error-msg (define-for-syntax allocator-setup-error-msg
"Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)") "Mutator must start with an 'allocator-setup' expression, such as: (allocator-setup <literal-string> <literal-number>)")

2
collects/tests/plai/gc/bad-mutators/void-app.ss
View File

@ -1,4 +1,4 @@
#lang plai/mutator #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)) (define x (cons 1 2))
((set-first! x 2) 1) ((set-first! x 2) 1)

650
collects/tests/plai/gc/good-collectors/good-collector.ss
View File

@ -1,129 +1,86 @@
#lang plai/collector #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: A collector for use in testing the random mutator generator.
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.
|# |#
;; the bounds on the initial half of a heap. (print-only-errors #t)
(define (first-start) 10)
(define (second-start) (define (find-free-space start size)
(unless (even? (- (heap-size) (first-start))) (cond
(error 'second-start "bad heap size ~s" (heap-size))) [(= start (heap-size))
(+ (first-start) (/ (- (heap-size) (first-start)) 2))) #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) (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))]) (for ([i (in-range 0 (heap-size))])
(heap-set! (heap-set! i 'free)))
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)))
(test (let ([v (make-vector 12 'x)]) (test (let ([v (make-vector 12 'x)])
(with-heap v (init-allocator)) (with-heap v (init-allocator))
v) v)
(mkheap 10 11 'free 'bad)) (make-vector 12 'free))
(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))
(define (gc:deref loc) (define (gc:deref loc)
(cond (cond
[(immediate-loc? loc)
(immediate-loc->val loc)]
[(equal? (heap-ref loc) 'flat) [(equal? (heap-ref loc) 'flat)
(heap-ref (+ loc 1))] (heap-ref (+ loc 1))]
[else [else
(error 'gc:deref "attempted to deref a non flat value, loc ~s" loc)])) (error 'gc:deref "attempted to deref a non flat value, loc ~s" loc)]))
(test (with-heap (mkheap 10 20 'flat 14) (test (with-heap (vector 'free 'free 'free 'flat 14 'free 'free)
(gc:deref 10)) (gc:deref 3))
14) 14)
(test (gc:deref 2) #f)
(test (gc:deref 3) #t)
(define (gc:first pr-ptr) (define (gc:first pr-ptr)
(if (equal? (heap-ref pr-ptr) 'pair) (if (equal? (heap-ref pr-ptr) 'pair)
(heap-ref (+ pr-ptr 1)) (heap-ref (+ pr-ptr 1))
(error 'first "non pair"))) (error 'first "non pair")))
(test (with-heap (mkheap 10 20 'pair 0 1) (test (with-heap (vector 'free 'flat 3 'pair 0 1)
(gc:first 10)) (gc:first 3))
0) 0)
(define (gc:rest pr-ptr) (define (gc:rest pr-ptr)
@ -131,39 +88,25 @@ heap-layout:
(heap-ref (+ pr-ptr 2)) (heap-ref (+ pr-ptr 2))
(error 'first "non pair"))) (error 'first "non pair")))
(test (with-heap (mkheap 10 20 'pair 0 1) (test (with-heap (vector 'free 'flat 3 'pair 0 1)
(gc:rest 10)) (gc:rest 3))
1) 1)
(define (gc:flat? loc) (define (gc:flat? loc) (equal? (heap-ref loc) 'flat))
(cond
[(< loc (first-start)) #t]
[(equal? (heap-ref loc) 'flat) #t]
[else #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:flat? 12)) (gc:flat? 2))
#f) #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:flat? 15))
#t)
(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
(gc:flat? 5)) (gc:flat? 5))
#t) #t)
(define (gc:cons? loc) (define (gc:cons? loc) (equal? (heap-ref loc) 'pair))
(cond
[(< loc (first-start)) #f]
[else
(equal? (heap-ref loc) 'pair)]))
(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? 12)) (gc:cons? 2))
#t) #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:cons? 15))
#f)
(test (with-heap (mkheap 10 20 'free 'free 'pair 0 1 'flat 14)
(gc:cons? 5)) (gc:cons? 5))
#f) #f)
@ -172,375 +115,160 @@ heap-layout:
(heap-set! (+ pr-ptr 1) new) (heap-set! (+ pr-ptr 1) new)
(error 'set-first! "non pair"))) (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) (define (gc:set-rest! pr-ptr new)
(if (equal? (heap-ref pr-ptr) 'pair) (if (equal? (heap-ref pr-ptr) 'pair)
(heap-set! (+ pr-ptr 2) new) (heap-set! (+ pr-ptr 2) new)
(error 'set-first! "non pair"))) (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) (define (gc:alloc-flat fv)
(cond (let ([ptr (alloc 2 (λ ()
[(immediate-val? fv) (if (procedure? fv)
(immediate-val->loc fv)] (append (procedure-roots fv)
[else (get-root-set))
(let ([ptr (alloc 2)]) (get-root-set))))])
(cond (heap-set! ptr 'flat)
[ptr (heap-set! (+ ptr 1) fv)
(fill-in-flat ptr fv)] ptr))
[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 (fill-in-flat ptr fv)
(heap-set! ptr 'flat)
(heap-set! (+ ptr 1) fv)
ptr)
(define (gc:cons hd tl) (define (gc:cons hd tl)
(let ([ptr (alloc 3)]) (let ([ptr (alloc 3 (λ () (get-root-set hd tl)))])
(cond (heap-set! ptr 'pair)
[ptr (heap-set! (+ ptr 1) hd)
(fill-in-cons ptr hd tl)] (heap-set! (+ ptr 2) tl)
[else ptr))
(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)))])))
(define (fill-in-cons ptr hd tl) (define (alloc n get-roots)
(heap-set! ptr 'pair) (let ([next (find-free-space 0 n)])
(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)])
(cond (cond
[(<= (+ next n) (heap-ref 1)) [next
(heap-set! 0 (+ next n))
next] next]
[else [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 (define (collect-garbage get-roots)
'fwd 17 'flat 112 'pair 10 10 (let ([roots (map read-root (get-roots))])
'free 'free 'free 'free 'free 'free 'free)]) (collect-garbage-help roots
(with-heap h (alloc 3))) (remove* roots (get-all-records 0)))))
#f)
(test (let ([h (mkheap 10 16 (define (collect-garbage-help gray white)
'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)
(cond (cond
[(< (heap-ref 0) (second-start)) [(null? gray) (free! white)]
(heap-set! 0 (second-start))]
[else [else
(heap-set! 0 (first-start))]) (case (heap-ref (car gray))
(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)]
[(flat) [(flat)
(let ([dest (heap-ref 1)]) (let ([proc (heap-ref (+ (car gray) 1))])
(heap-set! dest 'flat) (if (procedure? proc)
(heap-set! (+ dest 1) (heap-ref (+ loc 1))) (let ([new-locs (map read-root (procedure-roots proc))])
(heap-set! 1 (+ dest 2)) (collect-garbage-help
(heap-set! loc 'fwd) (add-in new-locs (cdr gray) white)
(heap-set! (+ loc 1) dest) (remove* new-locs white)))
dest)] (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 [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) (define (free! whites)
(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)
(cond (cond
[(null? roots) (void)] [(null? whites) (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]
[else [else
(not (equal? (< n (second-start)) (let ([white (car whites)])
(< m (second-start))))])) (case (heap-ref white)
[(pair)
(test (different-halves? 2 3) #f) (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 (test (let ([v (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)])
'free 'free 'free 'free 'free (with-heap v (free! (list 10 18)))
'free 'free 'free 'free 'free) v)
(different-halves? 12 13)) (vector #f #t '() 0 1 2 3 4 5 6 'free 'free 'free 'flat 14 'pair 0 1 'free 'free))
#f)
(test (with-heap (mkheap 10 15 ;; add-in : (listof location) (listof location) (listof location) -> (listof location)
'free 'free 'free 'free 'free ;; computes a new set of gray addresses by addding all white elements of locs to gray
'free 'free 'free 'free 'free) (define (add-in locs gray white)
(different-halves? 12 17)) (cond
#t) [(null? locs) gray]
(test (with-heap (mkheap 10 15 [else
'free 'free 'free 'free 'free (let* ([loc (car locs)]
'free 'free 'free 'free 'free) [white? (member loc white)])
(different-halves? 16 17)) (add-in (cdr locs)
#f) (if white? (cons loc gray) gray)
(test (with-heap (mkheap 10 15 white))]))
'free 'free 'free 'free 'free
'free 'free 'free 'free 'free)
(different-halves? 17 12))
#t)
(test (with-heap (mkheap 17 20 (test (add-in '(13 14) '(100 102) '(13 14 104 105))
'fwd 17 'junk 'free 'free 'free 'free '(14 13 100 102))
'pair 11 11 'free 'free 'free 'free)
(different-halves? 17 11))
#t)
(test (let ([h (mkheap 17 22 (test (add-in '(13 14) '(100 102) '(13 104 105))
'fwd 17 'free 'free 'free 'free 'free '(13 100 102))
'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 (let ([h (mkheap 17 22 (define (get-all-records i)
'flat 12 'free 'free 'free 'free 'free (cond
'flat 11 'pair 17 10 'free 'free)]) [(< i (heap-size))
(with-heap h (maybe-move/loc 19 2)) (case (heap-ref i)
h) [(pair) (cons i (get-all-records (+ i 3)))]
(mkheap 17 24 [(flat) (cons i (get-all-records (+ i 2)))]
'fwd 22 'free 'free 'free 'free 'free [(free) (get-all-records (+ i 1))]
'flat 11 'pair 17 22 'flat '12)) [else (get-all-records (+ i 1))])]
[else null]))
(test (let ([h (mkheap 17 19 (test (with-heap (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12)
'free 'free 'free 'free 'free 'free 'free (get-all-records 0))
'flat 11 'free 'free 'free 'free 'free)]) (list 10 13 15 18))
(with-heap h (copy-data))
h)
(mkheap 19 19
'free 'free 'free 'free 'free 'free 'free
'flat 11 'free 'free 'free 'free 'free))
(test (let ([h (mkheap 17 20 (test (with-heap (make-vector 10 'free) (gc:alloc-flat #f))
'fwd 17 'junk 'free 'free 'free 'free 0)
'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 (let ([h (mkheap 17 20 (test (with-heap (make-vector 10 'free) (gc:alloc-flat #t) (gc:alloc-flat #f))
'fwd 17 'flat 112 'free 'free 'free 2)
'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 (gc:alloc-flat 1) (test (let ([v (vector 'flat 0 'flat 1)])
6) (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 (test (let ([v (vector 'flat 0 'flat 1)])
'flat 17 'pair 10 10 'free 'free (with-heap v (collect-garbage-help (list 2)
'pair 12 10 'free 'free 'free 'free)]) (remove 2 (get-all-records 0))))
(list (with-heap h (gc:alloc-flat 111)) v)
h)) (vector 'free 'free 'flat 1))
(list 15
(mkheap 17 17
'flat 17 'pair 10 10 'flat 111
'pair 12 10 'free 'free 'free 'free)))
(test (let ([h (mkheap 14 17 (test (let ([v (vector 'flat 0 'flat 1 'pair 0 2)])
'flat 17 'flat 12 'free 'free 'free (with-heap v (collect-garbage-help (list 4)
'pair 12 10 'free 'free 'free 'free)]) (remove 4 (get-all-records 0))))
(list (with-heap h (gc:cons 10 10)) v)
h)) (vector 'flat 0 'flat 1 'pair 0 2))
(list 14
(mkheap 17 17 (test (let ([v (vector 'flat 0 'flat 1 'pair 0 0)])
'flat 17 'flat 12 'pair 10 10 (with-heap v (collect-garbage-help (list 4)
'pair 12 10 'free 'free 'free 'free))) (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))

274
collects/tests/plai/gc/good-collectors/no-compact-cheat.ss
View File

@ -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))

4
collects/tests/plai/gc/good-mutators/classic-error.ss
View File

@ -1,6 +1,6 @@
#lang plai/mutator #lang plai/mutator
; This is `classic' in that caught many bugs in copying collectors that students wrote for CS173, Fall 2007. ; 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" 38) (allocator-setup "../good-collectors/good-collector.ss" 28)
'trash 'trash
'junk 'junk

2
collects/tests/plai/gc/good-mutators/closure-2.ss
View File

@ -1,5 +1,5 @@
#lang plai/mutator #lang plai/mutator
(allocator-setup "../good-collectors/good-collector.ss" 58) (allocator-setup "../good-collectors/good-collector.ss" 40)
(define make-conser (define make-conser

2
collects/tests/plai/gc/good-mutators/names.ss
View File

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

2
collects/tests/plai/gc/good-mutators/proc-list.ss
View File

@ -2,7 +2,7 @@
; Demonstrates garbage collection while a closure is on the stack. A correct collector must ensure that the roots ; 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 ; 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. ; not get discarded.
(allocator-setup "../good-collectors/good-collector.ss" 68) (allocator-setup "../good-collectors/good-collector.ss" 58)
(define (make-adder k) (define (make-adder k)
(lambda (n) (+ n k))) (lambda (n) (+ n k)))

2
collects/tests/plai/gc/good-mutators/student-1.ss
View File

@ -15,7 +15,7 @@
; Finally it runs the sample tests distributed with the assignment ; 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 ; Helper to generate long lists
(define (gen-list x) (define (gen-list x)

10
collects/tests/plai/test-random-mutator.ss
View File

@ -11,7 +11,7 @@
;; random mutator generation tests ;; 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 ".") (define-runtime-path here ".")
@ -27,7 +27,7 @@
(find-relative-path (find-relative-path
(normalize-path (simple-form-path tmpfile)) (normalize-path (simple-form-path tmpfile))
(normalize-path (normalize-path
(simple-form-path no-compact-cheat-path)))) (simple-form-path collector-path))))
100)) 100))
(for-each (λ (exp) (pretty-print exp port)) exps)) (for-each (λ (exp) (pretty-print exp port)) exps))
#:exists 'truncate) #:exists 'truncate)
@ -36,9 +36,9 @@
(printf "simple-form tmpfile ~s\n" (simple-form-path tmpfile)) (printf "simple-form tmpfile ~s\n" (simple-form-path tmpfile))
(printf "normalized tmpfile ~s\n" (normalize-path (simple-form-path tmpfile))) (printf "normalized tmpfile ~s\n" (normalize-path (simple-form-path tmpfile)))
(newline) (newline)
(printf "collector ~s\n" no-compact-cheat-path) (printf "collector ~s\n" collector-path)
(printf "simple-form collector: ~s\n" (simple-form-path no-compact-cheat-path)) (printf "simple-form collector: ~s\n" (simple-form-path collector-path))
(printf "normalized simple-form collector: ~s\n" (normalize-path (simple-form-path no-compact-cheat-path))) (printf "normalized simple-form collector: ~s\n" (normalize-path (simple-form-path collector-path)))
(newline) (newline)
(printf "here ~s\n" here) (printf "here ~s\n" here)
(printf "simple-form here: ~s\n" (simple-form-path here)) (printf "simple-form here: ~s\n" (simple-form-path here))