From 478ec22d02ed707555fc7cef73b42103f0baf3d8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 26 Feb 2013 08:41:37 -0600 Subject: [PATCH] add with-roots to plai's gc languages --- collects/plai/gc2/private/gc-core.rkt | 45 ++++++++++++++----- collects/plai/private/gc-core.rkt | 38 ++++++++++++---- collects/plai/scribblings/plai.scrbl | 33 ++++++++++++-- .../gc/good-collectors/good-collector.rkt | 10 +++++ .../gc2/good-collectors/good-collector.rkt | 10 +++++ 5 files changed, 113 insertions(+), 23 deletions(-) diff --git a/collects/plai/gc2/private/gc-core.rkt b/collects/plai/gc2/private/gc-core.rkt index 792d5cbf13..d5b9190072 100644 --- a/collects/plai/gc2/private/gc-core.rkt +++ b/collects/plai/gc2/private/gc-core.rkt @@ -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) diff --git a/collects/plai/private/gc-core.rkt b/collects/plai/private/gc-core.rkt index 7247a33663..afe18b756c 100644 --- a/collects/plai/private/gc-core.rkt +++ b/collects/plai/private/gc-core.rkt @@ -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 diff --git a/collects/plai/scribblings/plai.scrbl b/collects/plai/scribblings/plai.scrbl index 50de99885d..7606d65053 100644 --- a/collects/plai/scribblings/plai.scrbl +++ b/collects/plai/scribblings/plai.scrbl @@ -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} diff --git a/collects/tests/plai/gc/good-collectors/good-collector.rkt b/collects/tests/plai/gc/good-collectors/good-collector.rkt index ab2c20ff96..5362a45afc 100644 --- a/collects/tests/plai/gc/good-collectors/good-collector.rkt +++ b/collects/tests/plai/gc/good-collectors/good-collector.rkt @@ -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)) \ No newline at end of file diff --git a/collects/tests/plai/gc2/good-collectors/good-collector.rkt b/collects/tests/plai/gc2/good-collectors/good-collector.rkt index c65713746e..72d814c5f1 100644 --- a/collects/tests/plai/gc2/good-collectors/good-collector.rkt +++ b/collects/tests/plai/gc2/good-collectors/good-collector.rkt @@ -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)) \ No newline at end of file