#lang planet plai/plai:1:17/collector #| Changes from the class version: - changes allocation of pairs to garbage collect - sweeps the pair portion of the heap - traverses procedures (in two places, search for "procedure-roots") - arguments to gc:cons are marked as live (ie, traversed) |# (print-only-errors #t) ;; init-allocator : -> void (define (init-allocator) (when (< (heap-size) 5) (error 'too-small)) (let ([m (midpoint)]) (heap-set! 0 2) (heap-set! 1 m) (for ([i (in-range 2 (- m 1))]) (heap-set! i (+ i 1))) (heap-set! (- m 1) 'eofl) (for ([i (in-range m (heap-size))]) (if (even? (- i m)) (heap-set! i (+ i 2)) (heap-set! i 'free))) (if (even? (- (heap-size) m)) (heap-set! (- (heap-size) 2) 'eopl) (begin (heap-set! (- (heap-size) 3) 'eopl) (heap-set! (- (heap-size) 1) 'wasted))))) ;; midpoint : -> number ;; the address of the first pair. (define (midpoint) (ceiling (/ (heap-size) 2))) (test (with-heap (make-vector 5 #f) (midpoint)) 3) (test (with-heap (make-vector 8 #f) (midpoint)) 4) (test (let ([h (make-vector 5 #f)]) (with-heap h (init-allocator)) h) (vector 2 3 'eofl 'eopl 'free)) (test (let ([h (make-vector 8 #f)]) (with-heap h (init-allocator)) h) (vector 2 4 3 'eofl 6 'free 'eopl 'free)) ;; gc:flat? : loc -> boolean ;; loc is guaranteed to have been an earlier ;; result from either gc:alloc-flat or gc:cons (define (gc:flat? loc) (case loc [(0 1) (error "bad")] [else (cond [(< loc (midpoint)) #t] [else (when (odd? (- loc (midpoint))) (error "bad.2")) #f])])) (test (with-heap (make-vector 8 #f) (gc:flat? 2)) #t) (test (with-heap (make-vector 8 #f) (gc:flat? 3)) #t) (test (with-heap (make-vector 8 #f) (gc:flat? 4)) #f) (test (with-heap (make-vector 8 #f) (gc:flat? 6)) #f) (test/exn (with-heap (make-vector 8 #f) (gc:flat? 5)) "bad") (test/exn (with-heap (make-vector 8 #f) (gc:flat? 7)) "bad") (test/exn (with-heap (make-vector 8 #f) (gc:flat? 0)) "bad") (test/exn (with-heap (make-vector 8 #f) (gc:flat? 1)) "bad") ;; gc:cons? : loc -> boolean ;; loc is guaranteed to have been an earlier ;; result from either gc:alloc-flat or gc:cons (define (gc:cons? loc) (not (gc:flat? loc))) (test (with-heap (make-vector 8 #f) (gc:cons? 2)) #f) (test (with-heap (make-vector 8 #f) (gc:cons? 3)) #f) (test (with-heap (make-vector 8 #f) (gc:cons? 4)) #t) (test (with-heap (make-vector 8 #f) (gc:cons? 6)) #t) (test/exn (with-heap (make-vector 8 #f) (gc:cons? 5)) "bad") (test/exn (with-heap (make-vector 8 #f) (gc:cons? 7)) "bad") (test/exn (with-heap (make-vector 8 #f) (gc:cons? 0)) "bad") (test/exn (with-heap (make-vector 8 #f) (gc:cons? 1)) "bad") ;; gc:deref : loc -> heap-value ;; must signal an error if fl-loc doesn't point to a flat value (define (gc:deref fl-loc) (unless (gc:flat? fl-loc) (error 'gc:deref "not flat")) (heap-ref fl-loc)) (define (collect-garbage extra-roots) (sweep (mark extra-roots))) (define (sweep marked) (for ([i (in-range 2 (midpoint))]) (cond [(hash-ref marked i #f) (void)] [else (heap-set! i (heap-ref 0)) (heap-set! 0 i)])) (for ([i (in-range (midpoint) (heap-size))]) (cond [(odd? (- i (midpoint))) (void)] [(hash-ref marked i #f) (void)] [else (heap-set! i (heap-ref 1)) (heap-set! (+ i 1) 'free) (heap-set! 1 i)]))) ;; mark : (listof loc) -> hash[loc -o> #t] (define (mark extra-roots) (let ([ht (make-hash)]) (for-each (λ (root) (dfs ht root)) extra-roots) (for-each (λ (root) (dfs ht (read-root root))) (get-root-set)) ht)) (define (dfs ht loc) (unless (hash-ref ht loc #f) (hash-set! ht loc #t) (for-each (λ (loc) (dfs ht loc)) (get-pointers loc)))) ;; get-pointers : loc -> (listof loc) (define (get-pointers loc) (cond [(gc:flat? loc) (let ([v (heap-ref loc)]) (if (procedure? v) (map read-root (procedure-roots v)) '()))] [(gc:cons? loc) (list (heap-ref loc) (heap-ref (+ loc 1)))])) (define (mkhash . args) (let ([ht (make-hash)]) (for-each (λ (x) (hash-set! ht x #t)) args) ht)) (test (with-heap (vector 'eofl 'eopl 111 2 2) (get-pointers 2)) '()) (test (with-heap (vector 'eofl 'eopl 111 2 3) (get-pointers 3)) '(2 3)) (test (let ([ht (make-hash)]) (with-heap (vector 'eofl 'eopl 111 2 3) (dfs ht 3)) ht) (mkhash 2 3)) (test (let ([ht (make-hash)]) (with-heap (vector 'eofl 'eopl 111 2 3) (dfs ht 2)) ht) (mkhash 2)) (test (let ([ht (make-hash)]) (with-heap (vector 'eofl 'eopl 111 3 3) (dfs ht 3)) ht) (mkhash 3)) (test (let ([heap (vector 'eofl 'eopl 111 3 3)]) (with-heap heap (sweep (mkhash 3))) heap) (vector 2 'eopl 'eofl 3 3)) (test (let ([heap (vector 'eofl 'eopl 111 3 3)]) (with-heap heap (sweep (mkhash 2))) heap) (vector 'eofl 3 111 'eopl 'free)) ;; get-next-loc : loc symbol -> number (define (get-next-loc list-start eol extra-roots) (let ([res (heap-ref list-start)]) (cond [(eq? res eol) (collect-garbage extra-roots) (let ([res (heap-ref list-start)]) (when (eq? res eol) (error 'alloc "out of memory")) res)] [else res]))) (test/exn (with-heap (vector 'eofl 'eopl 111 3 3) (get-next-loc 0 'eofl '(2 3))) "out of memory") (test/exn (with-heap (vector 'eofl 'eopl 111 3 3) (get-next-loc 1 'eopl '(2 3))) "out of memory") (test (with-heap (vector 2 'eopl 'eofl 3 3) (get-next-loc 0 'eofl '())) 2) (test (with-heap (vector 2 3 'eofl 'eopl 'free) (get-next-loc 1 'eopl '())) 3) ;; gc:alloc-flat : heap-value -> loc (define (gc:alloc-flat fv) (let ([res (get-next-loc 0 'eofl (if (procedure? fv) (map read-root (procedure-roots fv)) '()))]) (heap-set! 0 (heap-ref res)) (heap-set! res fv) res)) (test (let ([h (make-vector 5 #f)]) (list (with-heap h (init-allocator) (gc:alloc-flat 111)) h)) (list 2 (vector 'eofl 3 111 'eopl 'free))) (test (with-heap (make-vector 5 #f) (init-allocator) (gc:alloc-flat 111) (gc:deref 2)) 111) ;; gc:cons : loc loc -> loc ;; hd and tl are guaranteed to have been earlier ;; results from either gc:alloc-flat or gc:cons (define (gc:cons hd tl) (let ([res (get-next-loc 1 'eopl (list hd tl))]) (heap-set! 1 (heap-ref res)) (heap-set! res hd) (heap-set! (+ res 1) tl) res)) (test (let ([h (make-vector 8 #f)]) (list (with-heap h (init-allocator) (gc:cons (gc:alloc-flat 111) (gc:alloc-flat 222))) h)) (list 4 (vector 'eofl 6 111 222 2 3 'eopl 'free))) ;; gc:first : loc -> loc ;; must signal an error of pr-loc does not point to a pair (define (gc:first pr-loc) (unless (gc:cons? pr-loc) (error 'gc:first "not a pair")) (heap-ref pr-loc)) (test (with-heap (make-vector 8 #f) (init-allocator) (gc:deref (gc:first (gc:cons (gc:alloc-flat 111) (gc:alloc-flat 222))))) 111) ;; gc:rest : loc -> loc ;; must signal an error of pr-loc does not point to a pair (define (gc:rest pr-loc) (unless (gc:cons? pr-loc) (error 'gc:first "not a pair")) (heap-ref (+ pr-loc 1))) (test (with-heap (make-vector 8 #f) (init-allocator) (gc:deref (gc:rest (gc:cons (gc:alloc-flat 111) (gc:alloc-flat 222))))) 222) ;; gc:set-first! : loc loc -> void ;; must signal an error of pr-loc does not point to a pair (define (gc:set-first! pr-loc new) (unless (gc:cons? pr-loc) (error 'gc:set-first! "not a pair")) (heap-set! pr-loc new)) (test (with-heap (make-vector 8 #f) (init-allocator) (let* ([a-flat (gc:alloc-flat 111)] [another-flat (gc:alloc-flat 222)] [cons-addr (gc:cons a-flat a-flat)]) (gc:set-first! cons-addr another-flat) (gc:deref (gc:first cons-addr)))) 222) ;; gc:set-rest! : loc loc -> void ;; must signal an error of pr-loc does not point to a pair (define (gc:set-rest! pr-loc new) (unless (gc:cons? pr-loc) (error 'gc:set-first! "not a pair")) (heap-set! (+ pr-loc 1) new)) (test (with-heap (make-vector 8 #f) (init-allocator) (let* ([a-flat (gc:alloc-flat 111)] [another-flat (gc:alloc-flat 222)] [cons-addr (gc:cons a-flat a-flat)]) (gc:set-rest! cons-addr another-flat) (gc:deref (gc:rest cons-addr)))) 222)