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

adjust plai's gc2/mutator so that primitive applications are

Browse Source 
special and primtives not in an application position is a syntax error
This commit is contained in:
Robby Findler 2012-02-23 07:06:30 -06:00
parent f092a96333
commit 9ffc18a000
4 changed files with 43 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -201,14 +201,16 @@
[(_ (id ...) body ...)
(syntax/loc stx
(mutator-lambda (id ...) (mutator-begin body ...)))]))
(define-syntax (mutator-app stx)
(syntax-case stx ()
[(_ e ...)
(local [(define (do-not-expand? exp)
(and (identifier? exp)
(free-identifier=? exp #'empty)))
(define exps
(syntax->list #'(e ...)))
(or (free-identifier=? exp #'empty)
(ormap (λ (x) (free-identifier=? x exp))
prim-ids))))
(define exps (syntax->list #'(e ...)))
(define tmps
(generate-temporaries #'(e ...)))]
(with-syntax ([(ne ...)
@ -225,16 +227,22 @@
(define-syntax (mutator-anf-app stx)
(syntax-case stx ()
[(_ fe ae ...)
(with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)])
(if (syntax-parameter-value #'mutator-tail-call?)
; If this call is in tail position, we will not need access
; to its environment when it returns.
(syntax/loc stx ((deref-proc fe) ae ...))
; If this call is not in tail position, we make the
; environment at the call site reachable.
#`(with-continuation-mark gc-roots-key
(list (make-env-root env-id) ...)
#,(syntax/loc stx ((deref-proc fe) ae ...)))))]))
(let ()
(define prim-app? (ormap (λ (x) (free-identifier=? x #'fe))
prim-ids))
(with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)]
[app-exp (if prim-app?
(syntax/loc stx (collector:alloc-flat (fe (collector:deref ae) ...)))
(syntax/loc stx ((deref-proc fe) ae ...)))])
(if (syntax-parameter-value #'mutator-tail-call?)
; If this call is in tail position, we will not need access
; to its environment when it returns.
#'app-exp
; If this call is not in tail position, we make the
; environment at the call site reachable.
#`(with-continuation-mark gc-roots-key
(list (make-env-root env-id) ...)
app-exp))))]))
(define-syntax mutator-quote
(syntax-rules ()
[(_ (a . d))
@ -277,14 +285,11 @@
[(result-addr)
(cond
[(procedure? result-addr)
(printf "Imported procedure\n")
(printf "Imported procedure:\n")
result-addr]
[(location? result-addr)
(printf "Value at location ~a:\n" result-addr)
(gc->scheme result-addr)]
[(prim? result-addr)
(printf "Primitive:\n")
(prim-proc result-addr)])])))]))
(gc->scheme result-addr)])])))]))
; Module Begin
(define-for-syntax (allocator-setup-internal stx)
@ -393,17 +398,29 @@
(raise-syntax-error #f "expected list of identifiers to import" stx)]
[_ (raise-syntax-error #f "expected open parenthesis before import-primitive")]))
(define-for-syntax ((mk-id-macro p-id) stx)
(syntax-case stx ()
[id
(identifier? #'id)
(raise-syntax-error (syntax-e stx)
"primitive must appear in the function position of an application"
stx)]
[(id exp ...)
#`(mutator-app #,p-id exp ...)]))
(define-syntax (provide-flat-prims/lift stx)
(syntax-case stx ()
[(_ id ...)
[(_ prim-ids id ...)
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([(id2 ...) (generate-temporaries #'(id ...))])
(with-syntax ([(id2 ...) (generate-temporaries #'(id ...))]
[(p ...) (generate-temporaries #'(id ...))])
#'(begin
(define-for-syntax prim-ids (syntax->list #'(id ...)))
(provide (rename-out [id2 id] ...))
(define id2 (make-prim id)) ...))]))
(define-syntax id2 (mk-id-macro #'id)) ...))]))
(define-struct prim (proc))
(provide-flat-prims/lift
prim-ids
symbol? boolean? number? symbol=?
add1 sub1 zero? + - * / even? odd? = < > <= >=)
@ -475,9 +492,6 @@
(cond
[(procedure? proc/loc) proc/loc]
[(location? proc/loc) (collector:closure-code-ptr proc/loc)]
[(prim? proc/loc)
(λ args
(collector:alloc-flat (apply (prim-proc proc/loc) (map collector:deref args))))]
[else
(error 'procedure-application "expected procedure, given something else")]))
(cond

2
collects/tests/plai/gc2/good-mutators/app.rkt
View File

@ -5,7 +5,7 @@
(lambda (x)
(f x)))
(define plus (app add1))
(define plus (app (λ (x) (add1 x))))
(plus 23)
(plus 5)

2
collects/tests/plai/gc2/good-mutators/closure-1.rkt
View File

@ -10,4 +10,4 @@
(define x 'gc-garbage)
(test/value=? (map add1 lst) '(3 -9))
(test/value=? (map (λ (x) (add1 x)) lst) '(3 -9))

4
collects/tests/plai/gc2/good-mutators/student-1.rkt
View File

@ -119,7 +119,7 @@
(set! tail head)
(printf "res ~a\n" lst)
(printf "res ~a\n" (length '(hello goodbye)))
(printf "res ~a\n" (map sub1 lst))
(printf "res ~a\n" (map (λ (x) (sub1 x)) lst))
(printf "(fact-help 15 1): ~a\n" (fact-help 15 1))
(printf "(fact 9): ~a\n" (fact 9))
@ -127,5 +127,5 @@
(printf "(append lst lst): ~a\n" (append lst lst))
(printf "(map-add 5 lst): ~a\n" (map-add 5 lst))
(printf "(filter even? (map sub1 lst)): ~a\n" (filter even? (map sub1 lst)))
(printf "(filter even? (map sub1 lst)): ~a\n" (filter (λ (x) (even? x)) (map (λ (x) (sub1 x)) lst)))
(printf "(length lst): ~a\n" (length lst))