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 ()
[(_ body ...)
(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!)
(map (λ (s) (datum->syntax stx s))
'(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!))])
#`(#%module-begin
@ -47,12 +49,17 @@
(provide/contract (gc:alloc-flat (heap-value? . -> . 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:rest (location? . -> . location?)))
(provide/contract (gc:flat? (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-rest! (location? location? . -> . void?)))

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

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

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

@ -179,20 +179,23 @@
#f))
(string->symbol "#<proc>"))])
(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
(list #'id ...
#'free-id ...)]
[mutator-tail-call? #t])
(->address body)))])
(add-closure-env! closure (list (make-env-root free-id) ...))
(->address body))))])
#,(if (syntax-parameter-value #'mutator-tail-call?)
(syntax/loc stx
(#%app collector:alloc-flat closure))
(#%app collector:closure closure (vector free-id ...)))
(syntax/loc stx
(with-continuation-mark gc-roots-key
(with-continuation-mark
gc-roots-key
(list (make-env-root env-id) ...)
(#%app collector:alloc-flat closure))))))))]
(#%app collector:closure closure (vector free-id ...)))))))))]
[(_ (id ...) body ...)
(syntax/loc stx
(mutator-lambda (id ...) (mutator-begin body ...)))]))
@ -282,11 +285,13 @@
(syntax-case stx ()
[(collector-module heap-size)
(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:flat? gc:cons?
gc:set-first! gc:set-rest!)
(map (λ (s) (datum->syntax stx s))
'(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:flat? gc:cons?
gc:set-first! gc:set-rest!))])
@ -305,11 +310,15 @@
(set-collector:cons?! gc:cons?)
(set-collector:set-first!! gc:set-first!)
(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))
(when (gui-available?)
(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")))
(init-allocator))))]
[_ (raise-syntax-error 'mutator
@ -390,8 +399,20 @@
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([(lifted-id ...) (generate-temporaries #'(id ...))])
#'(begin
(define lifted-id (mutator-lift id)) ...
(provide (rename-out [lifted-id id] ...))))]))
(define-syntax lifted-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
symbol? boolean? number? symbol=?
@ -460,20 +481,28 @@
[(_ arg) #'(#%app print-only-errors (#%datum . arg))]))
; Implementation Functions
(define (deref-proc proc-or-loc)
(define (deref proc/loc)
(cond
[(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)]))
(define (deref-proc proc-or-loc)
(define v
(with-handlers ([exn? (lambda (x)
(error 'procedure-application "expected procedure, given something else"))])
(deref proc-or-loc)))
(if (procedure? v)
v
(error 'procedure-application "expected procedure, given ~e" v)))
(cond
[(procedure? 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-struct an-unset ())
@ -494,8 +523,11 @@
(placeholder-set! ph (cons car-ph cdr-ph))
(placeholder-set! car-ph (unwrap (collector:first 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
(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)))))
(make-reader-graph (unwrap loc)))

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

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

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

@ -50,10 +50,10 @@
(string-append " " (format-cell elt)))])))))
;;; 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?)])
(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?)
(define (location? v)
@ -87,16 +87,22 @@
(define gc-roots-key (gensym 'gc-roots-key))
;;; 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!)
#:property prop:custom-write (λ (v port write?)
(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)
(define-syntax (make-env-root stx)
(syntax-case stx ()
[(_ id) (identifier? #'id)
#`(make-root 'id (λ () id) (λ (loc) (set! id loc)))]))
#`(make-root 'id
(λ ()
id)
(λ (loc) (set! id loc)))]))
;;; Roots on the stack.
(provide/contract (stack-roots (-> (listof root?))))
@ -110,7 +116,10 @@
(provide/contract (make-stack-root (symbol? location? . -> . root?)))
(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?)))
(define (read-root root)
@ -137,9 +146,13 @@
(andmap identifier? (syntax->list #'(root-id ...)))
#`(begin
(append
(list (make-root 'root-id (λ () root-id)
(list (if (location? root-id)
(make-root 'root-id
(λ ()
root-id)
(λ (loc)
(set! root-id loc)))
(error 'get-root-set "expected a location, given ~e" root-id))
...)
(get-global-roots)
(stack-roots)))]
@ -153,24 +166,23 @@
"missing open parenthesis"
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
; Once the closure is garbage collected, its environment is only reachable by a weak reference to
; the closure.
(define closure-envs (make-weak-hash))
(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)))
(define-struct closure-code (env-count proc) #:transparent)
(provide/contract
[struct closure-code ([env-count exact-nonnegative-integer?]
[proc procedure?])])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Optional UI

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

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

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)
(heap-ref (+ loc 1))]
[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)
(gc:deref 3))
@ -92,6 +92,18 @@ A collector for use in testing the random mutator generator.
(gc:rest 3))
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))
(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))
#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)
(if (equal? (heap-ref pr-ptr) 'pair)
(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)
(let ([ptr (alloc 2 (λ ()
(if (procedure? fv)
(append (procedure-roots fv)
(get-root-set))
(get-root-set))))])
(let ([ptr (alloc 2 (λ () (get-root-set)))])
(heap-set! ptr 'flat)
(heap-set! (+ ptr 1) fv)
ptr))
@ -138,6 +155,17 @@ A collector for use in testing the random mutator generator.
(heap-set! (+ ptr 2) tl)
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)
(let ([next (find-free-space 0 n)])
(cond
@ -162,18 +190,27 @@ A collector for use in testing the random mutator generator.
(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)))]
(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))))]
[(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
(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)
(heap-set! white '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
(error 'free! "unknown tag ~s\n" (heap-ref white))])
(free! (cdr whites)))]))
@ -221,15 +264,16 @@ A collector for use in testing the random mutator generator.
(cond
[(< i (heap-size))
(case (heap-ref i)
[(closure) (cons i (get-all-records (+ i 3 (heap-ref (+ i 2)))))]
[(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 (error 'get-all-records "Unknown tag ~e in cell ~e" (heap-ref i) i)])]
[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 (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 10))
(list 10 13 15 18 20 24))
(test (with-heap (make-vector 10 'free) (gc:alloc-flat #f))
0)
@ -272,3 +316,4 @@ A collector for use in testing the random mutator generator.
(remove 4 (get-all-records 0))))
v)
(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 (init-allocator)
; calling heap-offset before init-allocator is called gives 'undefined
(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)
(begin
(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
(allocator-setup "../good-collectors/good-collector.rkt" 6)
(allocator-setup "../good-collectors/good-collector.rkt" 8)
(define
proc
(let* ([not-root 1] ; 2
[root 2]) ; 4
(lambda () ; 6
(lambda () ; 8
3
root)))

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

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

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

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

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

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