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

add with-roots to plai's gc languages

Browse Source
This commit is contained in:
Robby Findler 2013-02-26 08:41:37 -06:00
parent 87a8e6f677
commit 478ec22d02
5 changed files with 113 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -144,18 +144,8 @@
(syntax-case stx ()
[(_ root-id ...)
(andmap identifier? (syntax->list #'(root-id ...)))
#`(begin
(append
(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)))]
#`(get-root-set/proc (list root-id ...)
'(root-id ...))]
[(_ e ...)
(let ([err (ormap (λ (x) (and (not (identifier? x)) x)) (syntax->list #'(e ...)))])
(raise-syntax-error false
@ -166,6 +156,37 @@
"missing open parenthesis"
stx)]))
(define (get-root-set/proc root-locs root-ids)
(append
(for/list ([root-loc (in-list root-locs)]
[root-id (in-list root-ids)])
(if (location? root-loc)
(make-root root-id
(λ ()
root-loc)
(λ (loc)
(set! root-loc loc)))
(error 'get-root-set "expected a location, given ~e" root-loc)))
(get-global-roots)
(stack-roots)
(user-specified-roots)))
(provide with-roots)
(define-syntax-rule
(with-roots e1 e2 e3 ...)
(with-roots/proc e1 (λ () e2 e3 ...)))
(define (with-roots/proc roots thunk)
(define c (listof location?))
(unless (c roots)
(raise-argument-error 'with-roots
(format "~s" (contract-name c))
roots))
(parameterize ([user-specified-roots (append roots (user-specified-roots))])
(thunk)))
(define user-specified-roots (make-parameter '()))
(provide/contract
[vector->roots (-> (vectorof location?) (listof root?))])
(define (vector->roots v)

38
collects/plai/private/gc-core.rkt
View File

@ -135,14 +135,7 @@
(syntax-case stx ()
[(_ root-id ...)
(andmap identifier? (syntax->list #'(root-id ...)))
#`(begin
(append
(list (make-root 'root-id (λ () root-id)
(λ (loc)
(set! root-id loc)))
...)
(get-global-roots)
(stack-roots)))]
#`(get-root-set/proc (list root-id ...) '(root-id ...))]
[(_ e ...)
(let ([err (ormap (λ (x) (and (not (identifier? x)) x)) (syntax->list #'(e ...)))])
(raise-syntax-error false
@ -153,6 +146,35 @@
"missing open parenthesis"
stx)]))
(define (get-root-set/proc root-locs root-ids)
(append
(for/list ([root-loc (in-list root-locs)]
[root-id (in-list root-ids)])
(if (location? root-loc)
(make-root root-id
(λ () root-loc)
(λ (loc) (set! root-loc loc)))
(error 'get-root-set "expected a location, given ~e" root-loc)))
(get-global-roots)
(stack-roots)
(user-specified-roots)))
(provide with-roots)
(define-syntax-rule
(with-roots e1 e2 e3 ...)
(with-roots/proc e1 (λ () e2 e3 ...)))
(define (with-roots/proc roots thunk)
(define c (listof location?))
(unless (c roots)
(raise-argument-error 'with-roots
(format "~s" (contract-name c))
roots))
(parameterize ([user-specified-roots (append roots (user-specified-roots))])
(thunk)))
(define user-specified-roots (make-parameter '()))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Environments of closures

33
collects/plai/scribblings/plai.scrbl
View File

@ -310,9 +310,10 @@ Determines if @racket[v] is a root.
empty list is returned.
}
@defform[(with-heap heap expr ...)
#:contracts ([heap (vectorof heap-value?)])]{
Evaluates @racket[(begin expr ...)] in the context of @racket[heap]. Useful in
@defform[(with-heap heap-expr body-expr ...)
#:contracts ([heap-expr (vectorof heap-value?)])]{
Evaluates each of the @racket[body-expr]s in a context where
the value of @racket[heap-expr] is used as the heap. Useful in
tests:
@racketblock[
(test (with-heap (make-vector 20)
@ -320,6 +321,32 @@ Determines if @racket[v] is a root.
(gc:deref (gc:alloc-flat 2)))
2)
]}
@defform[(with-roots roots-expr expr1 expr2 ...)
#:contracts ([roots-expr (listof location?)])]{
Evaluates each of @racket[expr1] and the @racket[expr2]s in
in a context with the result of @racket[roots-expr]
as additional roots.
This function is intended to be used in test suites
for collectors. Since your test suites are not running
in the @racketmod[plai/mutator] language, @racket[get-root-set]
returns a list consisting only of the roots it created,
not all of the other roots it normally would return.
Use this function to note specific locations as roots
and set up better tests for your GC.
@racketblock[
(test (with-heap (make-vector 4)
(define f1 (gc:alloc-flat 1))
(define c1 (gc:cons f1 f1))
(with-roots (list c1)
(gc:deref
(gc:first
(gc:cons f1 f1)))))
1)]
}
@subsection{Garbage Collector Exports}

10
collects/tests/plai/gc/good-collectors/good-collector.rkt
View File

@ -272,3 +272,13 @@ 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))
(test (with-heap (make-vector 50)
(with-roots (list 1 2 3)
(get-root-set)))
(list 1 2 3))
(test (with-heap (make-vector 50)
(with-roots (list 1 2 3)
(with-roots (list 4 5 6)
(sort (get-root-set) <))))
(list 1 2 3 4 5 6))

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

@ -338,3 +338,13 @@ A collector for use in testing the random mutator generator.
v)
(vector 'free 'free 'free 'free 'pair 4 4))
(test (with-heap (make-vector 50)
(with-roots (list 1 2 3)
(get-root-set)))
(list 1 2 3))
(test (with-heap (make-vector 50)
(with-roots (list 1 2 3)
(with-roots (list 4 5 6)
(sort (get-root-set) <))))
(list 1 2 3 4 5 6))