From 6565005468327aed53d3530e7be4c26401bce2e7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 17 Feb 2010 15:14:49 +0000 Subject: [PATCH] checking this in to be able to show it to Jay svn: r18111 --- collects/tests/plai/no-compact-cheat.ss | 270 ++++++++++++++++++++++++ 1 file changed, 270 insertions(+) create mode 100644 collects/tests/plai/no-compact-cheat.ss diff --git a/collects/tests/plai/no-compact-cheat.ss b/collects/tests/plai/no-compact-cheat.ss new file mode 100644 index 0000000000..8bcf2aeeae --- /dev/null +++ b/collects/tests/plai/no-compact-cheat.ss @@ -0,0 +1,270 @@ +#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 (λ () (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))