diff --git a/collects/plai/gc2/mutator.rkt b/collects/plai/gc2/mutator.rkt index 51ab50e362..b23d59431c 100644 --- a/collects/plai/gc2/mutator.rkt +++ b/collects/plai/gc2/mutator.rkt @@ -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 diff --git a/collects/tests/plai/gc2/good-mutators/app.rkt b/collects/tests/plai/gc2/good-mutators/app.rkt index 3ceda4742f..2d880241ba 100644 --- a/collects/tests/plai/gc2/good-mutators/app.rkt +++ b/collects/tests/plai/gc2/good-mutators/app.rkt @@ -5,7 +5,7 @@ (lambda (x) (f x))) -(define plus (app add1)) +(define plus (app (λ (x) (add1 x)))) (plus 23) (plus 5) diff --git a/collects/tests/plai/gc2/good-mutators/closure-1.rkt b/collects/tests/plai/gc2/good-mutators/closure-1.rkt index 3a546d31bf..d734ab4a81 100644 --- a/collects/tests/plai/gc2/good-mutators/closure-1.rkt +++ b/collects/tests/plai/gc2/good-mutators/closure-1.rkt @@ -10,4 +10,4 @@ (define x 'gc-garbage) -(test/value=? (map add1 lst) '(3 -9)) +(test/value=? (map (λ (x) (add1 x)) lst) '(3 -9)) diff --git a/collects/tests/plai/gc2/good-mutators/student-1.rkt b/collects/tests/plai/gc2/good-mutators/student-1.rkt index 9437fc9a7e..5eec435959 100644 --- a/collects/tests/plai/gc2/good-mutators/student-1.rkt +++ b/collects/tests/plai/gc2/good-mutators/student-1.rkt @@ -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))