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

See last commit

Browse Source
This commit is contained in:
Jay McCarthy 2012-01-04 16:17:49 -07:00
parent caf83b911b
commit 55e1df1445
14 changed files with 227 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/plai/gc2/collector.rkt
View File

@ -33,9 +33,11 @@
(syntax-case stx () (syntax-case stx ()
[(_ body ...) [(_ body ...)
(with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons gc:first gc:rest gc:flat? (with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons gc:first gc:rest gc:flat?
gc:closure gc:closure? gc:closure-code-ptr gc:closure-env-ref
gc:cons? gc:set-first! gc:set-rest!) gc:cons? gc:set-first! gc:set-rest!)
(map (λ (s) (datum->syntax stx s)) (map (λ (s) (datum->syntax stx s))
'(init-allocator gc:deref gc:alloc-flat gc:cons gc:first gc:rest gc:flat? '(init-allocator gc:deref gc:alloc-flat gc:cons gc:first gc:rest gc:flat?
gc:closure gc:closure? gc:closure-code-ptr gc:closure-env-ref
gc:cons? gc:set-first! gc:set-rest!))]) gc:cons? gc:set-first! gc:set-rest!))])
#`(#%module-begin #`(#%module-begin
@ -47,12 +49,17 @@
(provide/contract (gc:alloc-flat (heap-value? . -> . location?))) (provide/contract (gc:alloc-flat (heap-value? . -> . location?)))
(provide/contract (gc:cons (location? location? . -> . location?))) (provide/contract (gc:cons (location? location? . -> . location?)))
(provide/contract (gc:closure (closure-code? (vectorof location?) . -> . location?)))
(provide/contract (gc:closure-code-ptr (location? . -> . closure-code?)))
(provide/contract (gc:closure-env-ref (location? integer? . -> . location?)))
(provide/contract (gc:first (location? . -> . location?))) (provide/contract (gc:first (location? . -> . location?)))
(provide/contract (gc:rest (location? . -> . location?))) (provide/contract (gc:rest (location? . -> . location?)))
(provide/contract (gc:flat? (location? . -> . boolean?))) (provide/contract (gc:flat? (location? . -> . boolean?)))
(provide/contract (gc:cons? (location? . -> . boolean?))) (provide/contract (gc:cons? (location? . -> . boolean?)))
(provide/contract (gc:closure? (location? . -> . boolean?)))
(provide/contract (gc:set-first! (location? location? . -> . void?))) (provide/contract (gc:set-first! (location? location? . -> . void?)))
(provide/contract (gc:set-rest! (location? location? . -> . void?))) (provide/contract (gc:set-rest! (location? location? . -> . void?)))

2
collects/plai/gc2/collector/lang/reader.rkt
View File

@ -1,2 +1,2 @@
(module reader syntax/module-reader (module reader syntax/module-reader
#:language `plai/collector) #:language `plai/gc2/collector)

66
collects/plai/gc2/mutator.rkt
View File

@ -179,20 +179,23 @@
#f)) #f))
(string->symbol "#<proc>"))]) (string->symbol "#<proc>"))])
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([closure (lambda (id ...) (let ([closure
(closure-code
#,(length (syntax->list #'(free-id ...)))
(lambda (free-id ... id ...)
(syntax-parameterize ([mutator-env-roots (syntax-parameterize ([mutator-env-roots
(list #'id ... (list #'id ...
#'free-id ...)] #'free-id ...)]
[mutator-tail-call? #t]) [mutator-tail-call? #t])
(->address body)))]) (->address body))))])
(add-closure-env! closure (list (make-env-root free-id) ...))
#,(if (syntax-parameter-value #'mutator-tail-call?) #,(if (syntax-parameter-value #'mutator-tail-call?)
(syntax/loc stx (syntax/loc stx
(#%app collector:alloc-flat closure)) (#%app collector:closure closure (vector free-id ...)))
(syntax/loc stx (syntax/loc stx
(with-continuation-mark gc-roots-key (with-continuation-mark
gc-roots-key
(list (make-env-root env-id) ...) (list (make-env-root env-id) ...)
(#%app collector:alloc-flat closure))))))))] (#%app collector:closure closure (vector free-id ...)))))))))]
[(_ (id ...) body ...) [(_ (id ...) body ...)
(syntax/loc stx (syntax/loc stx
(mutator-lambda (id ...) (mutator-begin body ...)))])) (mutator-lambda (id ...) (mutator-begin body ...)))]))
@ -282,11 +285,13 @@
(syntax-case stx () (syntax-case stx ()
[(collector-module heap-size) [(collector-module heap-size)
(with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons (with-syntax ([(init-allocator gc:deref gc:alloc-flat gc:cons
gc:closure gc:closure? gc:closure-code-ptr gc:closure-env-ref
gc:first gc:rest gc:first gc:rest
gc:flat? gc:cons? gc:flat? gc:cons?
gc:set-first! gc:set-rest!) gc:set-first! gc:set-rest!)
(map (λ (s) (datum->syntax stx s)) (map (λ (s) (datum->syntax stx s))
'(init-allocator gc:deref gc:alloc-flat gc:cons '(init-allocator gc:deref gc:alloc-flat gc:cons
gc:closure gc:closure? gc:closure-code-ptr gc:closure-env-ref
gc:first gc:rest gc:first gc:rest
gc:flat? gc:cons? gc:flat? gc:cons?
gc:set-first! gc:set-rest!))]) gc:set-first! gc:set-rest!))])
@ -305,11 +310,15 @@
(set-collector:cons?! gc:cons?) (set-collector:cons?! gc:cons?)
(set-collector:set-first!! gc:set-first!) (set-collector:set-first!! gc:set-first!)
(set-collector:set-rest!! gc:set-rest!) (set-collector:set-rest!! gc:set-rest!)
(set-collector:closure! gc:closure)
(set-collector:closure?! gc:closure?)
(set-collector:closure-code-ptr! gc:closure-code-ptr)
(set-collector:closure-env-ref! gc:closure-env-ref)
(init-heap! (#%datum . heap-size)) (init-heap! (#%datum . heap-size))
(when (gui-available?) (when (gui-available?)
(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/gc2/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
@ -390,8 +399,20 @@
(andmap identifier? (syntax->list #'(id ...))) (andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([(lifted-id ...) (generate-temporaries #'(id ...))]) (with-syntax ([(lifted-id ...) (generate-temporaries #'(id ...))])
#'(begin #'(begin
(define lifted-id (mutator-lift id)) ... (define-syntax lifted-id
(provide (rename-out [lifted-id id] ...))))])) (make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
;; Redirect mutation of x to y
[(set! x v)
(raise-syntax-error 'id "Cannot mutate primitive functions")]
[(x (... ...))
#'(mutator-app x (... ...))]
[x (identifier? #'x)
#'(collector:closure (closure-code 0 (mutator-lift id)) (vector))]))))
...
(provide (rename-out [lifted-id id]
...))))]))
(provide/lift (provide/lift
symbol? boolean? number? symbol=? symbol? boolean? number? symbol=?
@ -460,20 +481,28 @@
[(_ arg) #'(#%app print-only-errors (#%datum . arg))])) [(_ arg) #'(#%app print-only-errors (#%datum . arg))]))
; Implementation Functions ; Implementation Functions
(define (deref proc/loc) (define (deref-proc proc-or-loc)
(define (deref proc/loc)
(cond (cond
[(procedure? proc/loc) proc/loc] [(procedure? proc/loc) proc/loc]
[(location? proc/loc) (collector:deref proc/loc)] [(location? proc/loc) (collector:closure-code-ptr proc/loc)]
[else (error 'deref "expected <location?> or <procedure?>; received ~a" proc/loc)])) [else (error 'deref "expected <location?> or <procedure?>; received ~a" proc/loc)]))
(define (deref-proc proc-or-loc)
(define v (define v
(with-handlers ([exn? (lambda (x) (with-handlers ([exn? (lambda (x)
(error 'procedure-application "expected procedure, given something else"))]) (error 'procedure-application "expected procedure, given something else"))])
(deref proc-or-loc))) (deref proc-or-loc)))
(if (procedure? v) (cond
v [(procedure? v)
(error 'procedure-application "expected procedure, given ~e" v))) v]
[(closure-code? v)
(lambda args
(apply (closure-code-proc v)
(append
(for/list ([i (in-range (closure-code-env-count v))])
(collector:closure-env-ref proc-or-loc i))
args)))]
[else
(error 'procedure-application "expected procedure, given ~e" v)]))
(define (gc->scheme loc) (define (gc->scheme loc)
(define-struct an-unset ()) (define-struct an-unset ())
@ -494,8 +523,11 @@
(placeholder-set! ph (cons car-ph cdr-ph)) (placeholder-set! ph (cons car-ph cdr-ph))
(placeholder-set! car-ph (unwrap (collector:first loc))) (placeholder-set! car-ph (unwrap (collector:first loc)))
(placeholder-set! cdr-ph (unwrap (collector:rest loc))))] (placeholder-set! cdr-ph (unwrap (collector:rest loc))))]
[(collector:closure? loc)
;; XXX get env?
(placeholder-set! ph (closure-code-proc (collector:closure-code-ptr loc)))]
[else [else
(error (format "gc:flat? and gc:cons? both returned false for ~a" loc))]) (error (format "gc:flat?, gc:cons?, gc:closure? all returned false for ~a" loc))])
(placeholder-get ph))))) (placeholder-get ph)))))
(make-reader-graph (unwrap loc))) (make-reader-graph (unwrap loc)))

2
collects/plai/gc2/mutator/lang/reader.rkt
View File

@ -1,2 +1,2 @@
(module reader syntax/module-reader (module reader syntax/module-reader
#:language `plai/mutator) #:language `plai/gc2/mutator)

61
collects/plai/gc2/private/collector-exports.rkt
View File

@ -1,39 +1,32 @@
#lang scheme #lang scheme
(require (for-syntax racket/syntax))
(provide (all-defined-out)) (provide (all-defined-out))
(define collector:deref false) (define-syntax (define-collector-export stx)
(define collector:alloc-flat false) (syntax-case stx ()
(define collector:cons false) [(_ i)
(define collector:first false) (with-syntax
(define collector:rest false) ([collector:i (format-id #'i "collector:~a" #'i)]
(define collector:flat? false) [set-collector:i! (format-id #'i "set-collector:~a!" #'i)])
(define collector:cons? false) #'(begin (define collector:i false)
(define collector:set-first! false) (define (set-collector:i! proc)
(define collector:set-rest! false) (set! collector:i proc))))]))
(define (set-collector:deref! proc) (define-syntax-rule (define-collector-exports i ...)
(set! collector:deref proc)) (begin (define-collector-export i)
...))
(define (set-collector:alloc-flat! proc) (define-collector-exports
(set! collector:alloc-flat proc)) deref
alloc-flat
(define (set-collector:cons! proc) cons
(set! collector:cons proc)) first
rest
(define (set-collector:first! proc) flat?
(set! collector:first proc)) cons?
set-first!
(define (set-collector:rest! proc) set-rest!
(set! collector:rest proc)) closure
closure?
(define (set-collector:flat?! proc) closure-code-ptr
(set! collector:flat? proc)) closure-env-ref)
(define (set-collector:cons?! proc)
(set! collector:cons? proc))
(define (set-collector:set-first!! proc)
(set! collector:set-first! proc))
(define (set-collector:set-rest!! proc)
(set! collector:set-rest! proc))

54
collects/plai/gc2/private/gc-core.rkt
View File

@ -50,10 +50,10 @@
(string-append " " (format-cell elt)))]))))) (string-append " " (format-cell elt)))])))))
;;; Predicate determines values that may be stored on the heap. Limit this to "small" values that ;;; Predicate determines values that may be stored on the heap. Limit this to "small" values that
;;; conceptually occupy a small, fixed amount of space. Closures are an exception. ;;; conceptually occupy a small, fixed amount of space.
(provide/contract [heap-value? (any/c . -> . boolean?)]) (provide/contract [heap-value? (any/c . -> . boolean?)])
(define (heap-value? v) (define (heap-value? v)
(or (number? v) (symbol? v) (boolean? v) (empty? v) (procedure? v))) (or (number? v) (symbol? v) (boolean? v) (empty? v) (closure-code? v)))
(provide location?) (provide location?)
(define (location? v) (define (location? v)
@ -87,16 +87,22 @@
(define gc-roots-key (gensym 'gc-roots-key)) (define gc-roots-key (gensym 'gc-roots-key))
;;; Roots are defined with custom getters and setters as they can be created in various ways. ;;; Roots are defined with custom getters and setters as they can be created in various ways.
(provide root? root-name make-root)
(define-struct root (name get set!) (define-struct root (name get set!)
#:property prop:custom-write (λ (v port write?) #:property prop:custom-write (λ (v port write?)
(display (format "#<root:~a>" (root-name v)) port))) (display (format "#<root:~a>" (root-name v)) port)))
(provide/contract
[root? (-> any/c boolean?)]
[root-name (-> root? any/c)]
[make-root (-> any/c (-> location?) (-> location? void) root?)])
(provide make-env-root) (provide make-env-root)
(define-syntax (make-env-root stx) (define-syntax (make-env-root stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) (identifier? #'id) [(_ id) (identifier? #'id)
#`(make-root 'id (λ () id) (λ (loc) (set! id loc)))])) #`(make-root 'id
(λ ()
id)
(λ (loc) (set! id loc)))]))
;;; Roots on the stack. ;;; Roots on the stack.
(provide/contract (stack-roots (-> (listof root?)))) (provide/contract (stack-roots (-> (listof root?))))
@ -110,7 +116,10 @@
(provide/contract (make-stack-root (symbol? location? . -> . root?))) (provide/contract (make-stack-root (symbol? location? . -> . root?)))
(define (make-stack-root id location) (define (make-stack-root id location)
(make-root id (λ () location) (λ (new-location) (set! location new-location)))) (make-root id
(λ ()
location)
(λ (new-location) (set! location new-location))))
(provide/contract (read-root (root? . -> . location?))) (provide/contract (read-root (root? . -> . location?)))
(define (read-root root) (define (read-root root)
@ -137,9 +146,13 @@
(andmap identifier? (syntax->list #'(root-id ...))) (andmap identifier? (syntax->list #'(root-id ...)))
#`(begin #`(begin
(append (append
(list (make-root 'root-id (λ () root-id) (list (if (location? root-id)
(make-root 'root-id
(λ ()
root-id)
(λ (loc) (λ (loc)
(set! root-id loc))) (set! root-id loc)))
(error 'get-root-set "expected a location, given ~e" root-id))
...) ...)
(get-global-roots) (get-global-roots)
(stack-roots)))] (stack-roots)))]
@ -153,24 +166,23 @@
"missing open parenthesis" "missing open parenthesis"
stx)])) stx)]))
(provide/contract
[vector->roots (-> (vectorof location?) (listof root?))])
(define (vector->roots v)
(for/list ([e (in-vector v)]
[i (in-naturals)])
(make-root 'vector
(λ ()
(vector-ref v i))
(λ (ne) (vector-set! v ne)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Environments of closures ;;; Environments of closures
; Once the closure is garbage collected, its environment is only reachable by a weak reference to (define-struct closure-code (env-count proc) #:transparent)
; the closure. (provide/contract
(define closure-envs (make-weak-hash)) [struct closure-code ([env-count exact-nonnegative-integer?]
[proc procedure?])])
(provide/contract (add-closure-env! (procedure? (listof root?) . -> . any)))
(define (add-closure-env! proc roots)
(hash-set! closure-envs proc roots))
(provide/contract (get-closure-env (procedure? . -> . (or/c false/c (listof root?)))))
(define (get-closure-env proc)
(hash-ref closure-envs proc false))
(provide/contract (procedure-roots (procedure? . -> . (listof root?))))
(define (procedure-roots proc)
(filter is-mutable-root? (hash-ref closure-envs proc empty)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Optional UI ;;; Optional UI

10
collects/plai/gc2/private/gc-gui.rkt
View File

@ -103,10 +103,8 @@
(cond (cond
[(boolean? obj) (if obj "#t" "#f")] [(boolean? obj) (if obj "#t" "#f")]
[(number? obj) (format "~a" obj)] [(number? obj) (format "~a" obj)]
[(procedure? obj) [(closure-code? obj)
(if (object-name obj) (format "~a" (or (object-name (closure-code-proc obj)) "#<closure>"))]
(format "~a" (object-name obj))
"#<proc>")]
[(symbol? obj) (format "'~s" obj)] [(symbol? obj) (format "'~s" obj)]
[(null? obj) "empty"] [(null? obj) "empty"]
[else (error 'val->string "unknown object, expected a heap-value.")])) [else (error 'val->string "unknown object, expected a heap-value.")]))
@ -324,8 +322,8 @@
(<= 0 n) (<= 0 n)
(< n (vector-length heap-vec))) (< n (vector-length heap-vec)))
(list n)] (list n)]
[(procedure? n) [(closure-code? n)
(map read-root (procedure-roots n))] '()]
[else [else
'()])) '()]))
'())) '()))

2
collects/tests/plai/gc2/bad-collectors/no-collection-collector.rkt
View File

@ -1,4 +1,4 @@
#lang plai/gc2collector #lang plai/gc2/collector
(define ptr 0) (define ptr 0)

79
collects/tests/plai/gc2/good-collectors/good-collector.rkt
View File

@ -1,4 +1,4 @@
#lang plai/gc2collector #lang plai/gc2/collector
#| #|
@ -68,7 +68,7 @@ A collector for use in testing the random mutator generator.
[(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, tag ~s" loc (heap-ref loc))]))
(test (with-heap (vector 'free 'free 'free 'flat 14 'free 'free) (test (with-heap (vector 'free 'free 'free 'flat 14 'free 'free)
(gc:deref 3)) (gc:deref 3))
@ -92,6 +92,18 @@ A collector for use in testing the random mutator generator.
(gc:rest 3)) (gc:rest 3))
1) 1)
(define (gc:closure-code-ptr a)
(if (gc:closure? a)
(heap-ref (+ a 1))
(error 'closure-code "non closure")))
;; XXX test
(define (gc:closure-env-ref a i)
(if (gc:closure? a)
(heap-ref (+ a 3 i))
(error 'closure-env-ref "non closure")))
(define (gc:flat? loc) (equal? (heap-ref loc) 'flat)) (define (gc:flat? loc) (equal? (heap-ref loc) 'flat))
(test (with-heap (vector 'free 'free 'pair 0 1 'flat 14) (test (with-heap (vector 'free 'free 'pair 0 1 'flat 14)
@ -110,6 +122,15 @@ A collector for use in testing the random mutator generator.
(gc:cons? 5)) (gc:cons? 5))
#f) #f)
(define (gc:closure? loc) (equal? (heap-ref loc) 'closure))
(test (with-heap (vector 'free 'free 'closure #f 0 'flat 14)
(gc:closure? 2))
#t)
(test (with-heap (vector 'free 'free 'closure #f 0 'flat 14)
(gc:closure? 5))
#f)
(define (gc:set-first! pr-ptr new) (define (gc:set-first! pr-ptr new)
(if (equal? (heap-ref pr-ptr) 'pair) (if (equal? (heap-ref pr-ptr) 'pair)
(heap-set! (+ pr-ptr 1) new) (heap-set! (+ pr-ptr 1) new)
@ -122,11 +143,7 @@ A collector for use in testing the random mutator generator.
(define (gc:alloc-flat fv) (define (gc:alloc-flat fv)
(let ([ptr (alloc 2 (λ () (let ([ptr (alloc 2 (λ () (get-root-set)))])
(if (procedure? fv)
(append (procedure-roots fv)
(get-root-set))
(get-root-set))))])
(heap-set! ptr 'flat) (heap-set! ptr 'flat)
(heap-set! (+ ptr 1) fv) (heap-set! (+ ptr 1) fv)
ptr)) ptr))
@ -138,6 +155,17 @@ A collector for use in testing the random mutator generator.
(heap-set! (+ ptr 2) tl) (heap-set! (+ ptr 2) tl)
ptr)) ptr))
(define (gc:closure code env)
(define len (vector-length env))
(define ptr (alloc (+ 3 len) (λ () (append (get-root-set) (vector->roots env)))))
(heap-set! ptr 'closure)
(heap-set! (+ ptr 1) code)
(heap-set! (+ ptr 2) len)
(for ([v (in-vector env)]
[i (in-naturals)])
(heap-set! (+ ptr 3 i) v))
ptr)
(define (alloc n get-roots) (define (alloc n get-roots)
(let ([next (find-free-space 0 n)]) (let ([next (find-free-space 0 n)])
(cond (cond
@ -162,18 +190,27 @@ A collector for use in testing the random mutator generator.
(case (heap-ref (car gray)) (case (heap-ref (car gray))
[(flat) [(flat)
(let ([proc (heap-ref (+ (car gray) 1))]) (let ([proc (heap-ref (+ (car gray) 1))])
(if (procedure? proc) (collect-garbage-help (cdr gray) white))]
(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) [(pair)
(let ([hd (heap-ref (+ (car gray) 1))] (let ([hd (heap-ref (+ (car gray) 1))]
[tl (heap-ref (+ (car gray) 2))]) [tl (heap-ref (+ (car gray) 2))])
(collect-garbage-help (collect-garbage-help
(add-in (list hd tl) (cdr gray) white) (add-in (list hd tl) (cdr gray) white)
(remove tl (remove hd white))))] (remove tl (remove hd white))))]
[(closure)
(define env-count
(heap-ref (+ (car gray) 2)))
(define-values
(gray* white*)
(for/fold ([gray* (cdr gray)]
[white* white])
([i (in-range env-count)])
(define env (gc:closure-env-ref (car gray) i))
(values (add-in (list env) gray* white)
(remove env white*))))
(collect-garbage-help
gray*
white*)]
[else [else
(error 'collect-garbage "unknown tag ~s, loc ~s" (heap-ref (car gray)) (car gray))])])) (error 'collect-garbage "unknown tag ~s, loc ~s" (heap-ref (car gray)) (car gray))])]))
@ -190,6 +227,12 @@ A collector for use in testing the random mutator generator.
[(flat) [(flat)
(heap-set! white 'free) (heap-set! white 'free)
(heap-set! (+ white 1) 'free)] (heap-set! (+ white 1) 'free)]
[(closure)
(heap-set! white 'free)
(heap-set! (+ white 1) 'free)
(for ([i (in-range (heap-ref (+ white 2)))])
(heap-set! (+ white 3 i) 'free))
(heap-set! (+ white 2) 'free)]
[else [else
(error 'free! "unknown tag ~s\n" (heap-ref white))]) (error 'free! "unknown tag ~s\n" (heap-ref white))])
(free! (cdr whites)))])) (free! (cdr whites)))]))
@ -221,15 +264,16 @@ A collector for use in testing the random mutator generator.
(cond (cond
[(< i (heap-size)) [(< i (heap-size))
(case (heap-ref i) (case (heap-ref i)
[(closure) (cons i (get-all-records (+ i 3 (heap-ref (+ i 2)))))]
[(pair) (cons i (get-all-records (+ i 3)))] [(pair) (cons i (get-all-records (+ i 3)))]
[(flat) (cons i (get-all-records (+ i 2)))] [(flat) (cons i (get-all-records (+ i 2)))]
[(free) (get-all-records (+ i 1))] [(free) (get-all-records (+ i 1))]
[else (get-all-records (+ i 1))])] [else (error 'get-all-records "Unknown tag ~e in cell ~e" (heap-ref i) i)])]
[else null])) [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) (test (with-heap (vector #f #t '() 0 1 2 3 4 5 6 'pair 0 1 'flat 14 'pair 0 1 'flat 12 'closure #f 1 10 'flat 16)
(get-all-records 0)) (get-all-records 10))
(list 10 13 15 18)) (list 10 13 15 18 20 24))
(test (with-heap (make-vector 10 'free) (gc:alloc-flat #f)) (test (with-heap (make-vector 10 'free) (gc:alloc-flat #f))
0) 0)
@ -272,3 +316,4 @@ A collector for use in testing the random mutator generator.
(remove 4 (get-all-records 0)))) (remove 4 (get-all-records 0))))
v) v)
(vector 'free 'free 'free 'free 'pair 4 4)) (vector 'free 'free 'free 'free 'pair 4 4))

22
collects/tests/plai/gc2/good-collectors/trivial-collector.rkt
View File

@ -1,10 +1,30 @@
#lang plai/gc2collector #lang plai/gc2/collector
(define heap-ptr 'uninitialized-heap-ptr) (define heap-ptr 'uninitialized-heap-ptr)
(define (init-allocator) (define (init-allocator)
; calling heap-offset before init-allocator is called gives 'undefined ; calling heap-offset before init-allocator is called gives 'undefined
(set! heap-ptr 0)) (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 heap-ptr))
;; return the location of this flat data
(- heap-ptr len))
(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) (define (gc:alloc-flat p)
(begin (begin
(when (> (+ heap-ptr 2) (heap-size)) (when (> (+ heap-ptr 2) (heap-size))

4
collects/tests/plai/gc2/good-mutators/danny-bug.rkt
View File

@ -1,11 +1,11 @@
#lang plai/gc2/mutator #lang plai/gc2/mutator
(allocator-setup "../good-collectors/good-collector.rkt" 6) (allocator-setup "../good-collectors/good-collector.rkt" 8)
(define (define
proc proc
(let* ([not-root 1] ; 2 (let* ([not-root 1] ; 2
[root 2]) ; 4 [root 2]) ; 4
(lambda () ; 6 (lambda () ; 8
3 3
root))) root)))

6
collects/tests/plai/gc2/good-mutators/thunks.rkt
View File

@ -1,7 +1,7 @@
#lang plai/gc2/mutator #lang plai/gc2/mutator
(allocator-setup "../good-collectors/good-collector.rkt" 4) (allocator-setup "../good-collectors/good-collector.rkt" 5)
; 2 ; 3
(define thunker (define thunker
(lambda () (lambda ()
; 2 ; 2
@ -10,6 +10,6 @@
'bananna 'bananna
; 2 ; 2
'frog)) 'frog))
; 4 total ; 5 total
(thunker) (thunker)

2
collects/tests/plai/gc2/other-mutators/begin.rkt
View File

@ -1,5 +1,5 @@
#lang plai/gc2/mutator #lang plai/gc2/mutator
(allocator-setup "../good-collectors/good-collector.rkt" 6) (allocator-setup "../good-collectors/good-collector.rkt" 7)
(define (go) (define (go)
(let ([obj 'z]) (let ([obj 'z])

8
collects/tests/plai/gc2/run-test.rkt
View File

@ -28,7 +28,7 @@
(test (test
(if (run-good?) (if (run-good?)
(for ([m (in-directory (build-path here "good-mutators") #rx"rkt$")]) (for ([m (in-directory (build-path here "good-mutators") #rx"rkt$")])
(test (test #:failure-prefix (format "~a" m)
(test-mutator m))) (test-mutator m)))
(void)) (void))
(for ([m (in-directory (build-path here "bad-mutators") #rx"rkt$")]) (for ([m (in-directory (build-path here "bad-mutators") #rx"rkt$")])
@ -37,7 +37,7 @@
(test-mutator (build-path here "other-mutators" "error.rkt")) (test-mutator (build-path here "other-mutators" "error.rkt"))
=error> =error>
#rx"plai/gc2mutator has error" #rx"plai/gc2/mutator has error"
(test-mutator (build-path here "other-mutators" "top.rkt")) (test-mutator (build-path here "other-mutators" "top.rkt"))
=error> =error>
@ -48,8 +48,8 @@
#<<END #<<END
(good lst '(1 2 3) '(1 2 3) "at line 6") (good lst '(1 2 3) '(1 2 3) "at line 6")
(good (length (quote (hello goodbye))) 2 2 "at line 13") (good (length (quote (hello goodbye))) 2 2 "at line 13")
(good (heap-loc head) 62 62 "at line 18") (good (heap-loc head) 69 69 "at line 18")
(bad (heap-loc head) 62 47 "at line 19") (bad (heap-loc head) 69 54 "at line 19")
END END