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

adjust gc2's mutator language:

Browse Source 
- give names to user functions that matches the user's names
    (if the third bullet goes away, then the function
     mutator-lift needs to be adjusted so that it uses
     procedure-rename in order to preserve the improvement
     in this bullet)

  - change exn? to exn:fail? (to avoid catching break exns)

  - change lang so that primitives (the ones in the
    provide-flat-prims/lift declaration) are not allocated
    in the user's space (treat them as if they are constants)

    This change makes it easier to build up and explain the
    GC api, piece by piece. That is, you can first run a program
    that contains just a constant (and explain it) with only a
    subset of the api. Then you can do something like (+ 1 2)
    and explain it, both without getting into how procedures work.

    (This is helpful for the way I run my lectures)
This commit is contained in:
Robby Findler 2012-02-19 19:09:39 -06:00
parent a8bdb9d6ce
commit c42675f80c
1 changed files with 28 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -182,12 +182,14 @@
(let ([closure (let ([closure
(closure-code (closure-code
#,(length (syntax->list #'(free-id ...))) #,(length (syntax->list #'(free-id ...)))
(lambda (free-id ... id ...) (let ([closure
(syntax-parameterize ([mutator-env-roots (lambda (free-id ... id ...)
(list #'id ... (syntax-parameterize ([mutator-env-roots
#'free-id ...)] (list #'id ...
[mutator-tail-call? #t]) #'free-id ...)]
(->address body))))]) [mutator-tail-call? #t])
(->address body)))])
closure))])
#,(if (syntax-parameter-value #'mutator-tail-call?) #,(if (syntax-parameter-value #'mutator-tail-call?)
(syntax/loc stx (syntax/loc stx
(#%app collector:closure closure (vector free-id ...))) (#%app collector:closure closure (vector free-id ...)))
@ -279,7 +281,10 @@
result-addr] result-addr]
[(location? result-addr) [(location? result-addr)
(printf "Value at location ~a:\n" result-addr) (printf "Value at location ~a:\n" result-addr)
(gc->scheme result-addr)])])))])) (gc->scheme result-addr)]
[(prim? result-addr)
(printf "Primitive:\n")
(prim-proc result-addr)])])))]))
; Module Begin ; Module Begin
(define-for-syntax (allocator-setup-internal stx) (define-for-syntax (allocator-setup-internal stx)
@ -388,49 +393,17 @@
(raise-syntax-error #f "expected list of identifiers to import" stx)] (raise-syntax-error #f "expected list of identifiers to import" stx)]
[_ (raise-syntax-error #f "expected open parenthesis before import-primitive")])) [_ (raise-syntax-error #f "expected open parenthesis before import-primitive")]))
; User Functions (define-syntax (provide-flat-prims/lift stx)
(define (mutator-lift f)
(lambda args
(let ([result (apply f (map collector:deref args))])
(if (void? result)
(void)
(collector:alloc-flat result)))))
(define-syntax (provide/lift stx)
(syntax-case stx () (syntax-case stx ()
[(_ id ...) [(_ id ...)
(andmap identifier? (syntax->list #'(id ...))) (andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([(lifted-id ...) (generate-temporaries #'(id ...))]) (with-syntax ([(id2 ...) (generate-temporaries #'(id ...))])
#'(begin #'(begin
(define-syntax lifted-id (provide (rename-out [id2 id] ...))
(make-set!-transformer (define id2 (make-prim id)) ...))]))
(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)
;; XXX Make a macro to unify this and mutator-lambda
(with-syntax
([(env-id (... ...)) (syntax-parameter-value #'mutator-env-roots)])
(if (syntax-parameter-value #'mutator-tail-call?)
(syntax/loc stx
(#%app collector:closure
(closure-code 0 (mutator-lift id))
(vector)))
(syntax/loc stx
(with-continuation-mark
gc-roots-key
(list (make-env-root env-id) (... ...))
(#%app collector:closure
(closure-code 0 (mutator-lift id))
(vector))))))]))))
...
(provide (rename-out [lifted-id id]
...))))]))
(provide/lift (define-struct prim (proc))
(provide-flat-prims/lift
symbol? boolean? number? symbol=? symbol? boolean? number? symbol=?
add1 sub1 zero? + - * / even? odd? = < > <= >=) add1 sub1 zero? + - * / even? odd? = < > <= >=)
@ -497,16 +470,16 @@
[(_ arg) #'(#%app print-only-errors (#%datum . arg))])) [(_ arg) #'(#%app print-only-errors (#%datum . arg))]))
; Implementation Functions ; Implementation Functions
(define (deref-proc proc-or-loc) (define (deref-proc proc/loc)
(define (deref proc/loc) (define v
(cond (cond
[(procedure? proc/loc) proc/loc] [(procedure? proc/loc) proc/loc]
[(location? proc/loc) (collector:closure-code-ptr proc/loc)] [(location? proc/loc) (collector:closure-code-ptr proc/loc)]
[else (error 'deref "expected <location?> or <procedure?>; received ~a" proc/loc)])) [(prim? proc/loc)
(define v (λ args
(with-handlers ([exn? (lambda (x) (collector:alloc-flat (apply (prim-proc proc/loc) (map collector:deref args))))]
(error 'procedure-application "expected procedure, given something else"))]) [else
(deref proc-or-loc))) (error 'procedure-application "expected procedure, given something else")]))
(cond (cond
[(procedure? v) [(procedure? v)
v] v]
@ -515,7 +488,7 @@
(apply (closure-code-proc v) (apply (closure-code-proc v)
(append (append
(for/list ([i (in-range (closure-code-env-count v))]) (for/list ([i (in-range (closure-code-env-count v))])
(collector:closure-env-ref proc-or-loc i)) (collector:closure-env-ref proc/loc i))
args)))] args)))]
[else [else
(error 'procedure-application "expected procedure, given ~e" v)])) (error 'procedure-application "expected procedure, given ~e" v)]))