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

special and primtives not in an application position is a syntax error

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)))
+                    (or (free-identifier=? exp #'empty)
-             (define exps
+                        (ormap (λ (x) (free-identifier=? x exp))
-               (syntax->list #'(e ...)))
+                               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)])
+     (let ()
-       (if (syntax-parameter-value #'mutator-tail-call?)
+       (define prim-app? (ormap (λ (x) (free-identifier=? x #'fe))
-           ; If this call is in tail position, we will not need access
+                                prim-ids))
-           ; to its environment when it returns.
+       (with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)]
-           (syntax/loc stx ((deref-proc fe) ae ...))
+                     [app-exp (if prim-app?
-           ; If this call is not in tail position, we make the
+                                  (syntax/loc stx (collector:alloc-flat (fe (collector:deref ae) ...)))
-           ; environment at the call site reachable.
+                                  (syntax/loc stx ((deref-proc fe) ae ...)))])
-           #`(with-continuation-mark gc-roots-key 
+         (if (syntax-parameter-value #'mutator-tail-call?)
-               (list (make-env-root env-id) ...)
+             ; If this call is in tail position, we will not need access
-               #,(syntax/loc stx ((deref-proc fe) ae ...)))))]))
+             ; 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)]
+              (gc->scheme result-addr)])])))]))
-             [(prim? result-addr)
-              (printf "Primitive:\n")
-              (prim-proc 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

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)

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))

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))