add <primcall> to tree-il

* libguile/expand.c:
* libguile/expand.h (SCM_EXPANDED_PRIMCALL_TYPE_NAME):
  (SCM_EXPANDED_PRIMCALL_FIELD_NAMES):
  (SCM_EXPANDED_PRIMCALL_SRC):
  (SCM_EXPANDED_PRIMCALL_NAME):
  (SCM_EXPANDED_PRIMCALL_ARGS):
  (SCM_MAKE_EXPANDED_PRIMCALL): Add "primcall" Tree-IL type.

* doc/ref/compiler.texi (Tree-IL): Update docs.

* libguile/memoize.c (memoize): Memoizer for primcalls.

* module/ice-9/psyntax.scm: Build primcalls, sometimes.  Also change
  build-primref to just make a primitive-ref.

* module/language/tree-il.scm: Add primcall to the exports, parsers,
  serializers, etc.

* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/fix-letrec.scm:
* module/language/tree-il/inline.scm:
* module/language/tree-il/primitives.scm:
* module/language/elisp/compile-tree-il.scm: Add primcall support.

* test-suite/tests/tree-il.test: Use primcalls sometimes.

doc/ref/compiler.texi

@@ -388,6 +388,15 @@ A conditional. Note that @var{else} is not optional.
 @deftpx {External Representation} (call @var{proc} . @var{args})
 A procedure call.
 @end deftp
+@deftp {Scheme Variable} <primcall> src name args
+@deftpx {External Representation} (primcall @var{name} . @var{args})
+A call to a primitive.  Equivalent to @code{(call (primitive @var{name})
+. @var{args})}.  This construct is often more convenient to generate and
+analyze than @code{<call>}.
+
+As part of the compilation process, instances of @code{(call (primitive
+@var{name}) . @var{args})} are transformed into primcalls.
+@end deftp
 @deftp {Scheme Variable} <sequence> src exps
 @deftpx {External Representation} (begin . @var{exps})
 Like Scheme's @code{begin}.

libguile/expand.c

@@ -1244,6 +1244,7 @@ scm_init_expand ()
   DEFINE_NAMES (TOPLEVEL_DEFINE);
   DEFINE_NAMES (CONDITIONAL);
   DEFINE_NAMES (CALL);
+  DEFINE_NAMES (PRIMCALL);
   DEFINE_NAMES (SEQUENCE);
   DEFINE_NAMES (LAMBDA);
   DEFINE_NAMES (LAMBDA_CASE);

libguile/expand.h

@@ -48,6 +48,7 @@ typedef enum
     SCM_EXPANDED_TOPLEVEL_DEFINE,
     SCM_EXPANDED_CONDITIONAL,
     SCM_EXPANDED_CALL,
+    SCM_EXPANDED_PRIMCALL,
     SCM_EXPANDED_SEQUENCE,
     SCM_EXPANDED_LAMBDA,
     SCM_EXPANDED_LAMBDA_CASE,
@@ -241,6 +242,19 @@ enum
 #define SCM_MAKE_EXPANDED_CALL(src, proc, args) \
   scm_c_make_struct (exp_vtables[SCM_EXPANDED_CALL], 0, SCM_NUM_EXPANDED_CALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (args))
 
+#define SCM_EXPANDED_PRIMCALL_TYPE_NAME "primcall"
+#define SCM_EXPANDED_PRIMCALL_FIELD_NAMES    \
+  { "src", "name", "args", }
+enum
+  {
+    SCM_EXPANDED_PRIMCALL_SRC,
+    SCM_EXPANDED_PRIMCALL_NAME,
+    SCM_EXPANDED_PRIMCALL_ARGS,
+    SCM_NUM_EXPANDED_PRIMCALL_FIELDS,
+  };
+#define SCM_MAKE_EXPANDED_PRIMCALL(src, name, args) \
+  scm_c_make_struct (exp_vtables[SCM_EXPANDED_PRIMCALL], 0, SCM_NUM_EXPANDED_PRIMCALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (args))
+
 #define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence"
 #define SCM_EXPANDED_SEQUENCE_FIELD_NAMES       \
   {  "src", "exps", }

libguile/memoize.c

@@ -263,6 +263,20 @@ memoize (SCM exp, SCM env)
         return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
       }
 
+    case SCM_EXPANDED_PRIMCALL:
+      {
+        SCM proc, args;
+
+        if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+          proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
+        else
+          proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
+                                  SCM_BOOL_F);
+        args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
+
+        return MAKMEMO_CALL (proc, scm_ilength (args), args);
+      }
+
     case SCM_EXPANDED_SEQUENCE:
       return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env));
 

module/ice-9/psyntax.scm

@@ -402,11 +402,13 @@
       (lambda (src req opt rest kw inits vars body else-case)
         (make-lambda-case src req opt rest kw inits vars body else-case)))
 
+    (define build-primcall
+      (lambda (src name args)
+        (make-primcall src name args)))
+    
     (define build-primref
       (lambda (src name)
-        (if (equal? (module-name (current-module)) '(guile))
+        (make-primitive-ref src name)))
-            (make-toplevel-ref src name)
-            (make-module-ref src '(guile) name #f))))
     
     (define (build-data src exp)
       (make-const src exp))
@@ -1038,9 +1040,9 @@
         (build-global-definition
          no-source
          name
-         (build-call
+         (build-primcall
           no-source
-          (build-primref no-source 'make-syntax-transformer)
+          'make-syntax-transformer
           (list (build-data no-source name)
                 (build-data no-source 'macro)
                 e)))))
@@ -1954,9 +1956,7 @@
                             (if (list? (cadr x))
                                 (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
                                 (error "how did we get here" x)))
-                           (else (build-call no-source
+                           (else (build-primcall no-source (car x) (map regen (cdr x)))))))
-                                             (build-primref no-source (car x))
-                                             (map regen (cdr x)))))))
 
                      (lambda (e r w s mod)
                        (let ((e (source-wrap e w s mod)))
@@ -2288,8 +2288,9 @@
                        (lambda (pvars exp y r mod)
                          (let ((ids (map car pvars)) (levels (map cdr pvars)))
                            (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
-                             (build-call no-source
+                             (build-primcall
-                                         (build-primref no-source 'apply)
+                              no-source
+                              'apply
                               (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
                                                          (chi exp
                                                               (extend-env
@@ -2330,18 +2331,14 @@
                                                                                        (build-dispatch-call pvars exp y r mod)
                                                                                        (gen-syntax-case x keys clauses r mod))))
                                              (list (if (eq? p 'any)
-                                                       (build-call no-source
+                                                       (build-primcall no-source 'list (list x))
-                                                                   (build-primref no-source 'list)
+                                                       (build-primcall no-source '$sc-dispatch
-                                                                   (list x))
-                                                       (build-call no-source
-                                                                   (build-primref no-source '$sc-dispatch)
                                                                        (list x (build-data no-source p)))))))))))))
 
                      (define gen-syntax-case
                        (lambda (x keys clauses r mod)
                          (if (null? clauses)
-                             (build-call no-source
+                             (build-primcall no-source 'syntax-violation
-                                         (build-primref no-source 'syntax-violation)
                                              (list (build-data no-source #f)
                                                    (build-data no-source
                                                                "source expression failed to match any pattern")

module/language/elisp/compile-tree-il.scm

@@ -109,7 +109,7 @@
 ;;; Build a call to a primitive procedure nicely.
 
 (define (call-primitive loc sym . args)
-  (make-call loc (make-primitive-ref loc sym) args))
+  (make-primcall loc sym args))
 
 ;;; Error reporting routine for syntax/compilation problems or build
 ;;; code for a runtime-error output.
@@ -118,8 +118,7 @@
   (apply error args))
 
 (define (runtime-error loc msg . args)
-  (make-call loc
+  (make-primcall loc 'error
-             (make-primitive-ref loc 'error)
                  (cons (make-const loc msg) args)))
 
 ;;; Generate code to ensure a global symbol is there for further use of
@@ -151,12 +150,11 @@
   (call-primitive
    loc
    'with-fluids*
-   (make-call loc
+   (make-primcall loc 'list
-              (make-primitive-ref loc 'list)
                   (map (lambda (sym)
                          (make-module-ref loc module sym #t))
                        syms))
-   (make-call loc (make-primitive-ref loc 'list) vals)
+   (make-primcall loc 'list vals)
    (make-lambda loc
                 '()
                 (make-lambda-case #f '() #f #f #f '() '() body #f))))
@@ -828,9 +826,7 @@
                     loc
                     name
                     function-slot
-                    (make-call
+                    (make-primcall loc 'cons
-                     loc
-                     (make-module-ref loc '(guile) 'cons #t)
                                    (list (make-const loc 'macro)
                                          (compile-lambda loc args body))))
                    (make-const loc name)))))

module/language/tree-il.scm

@@ -35,6 +35,7 @@
             <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
             <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
             <call> call? make-call call-src call-proc call-args
+            <primcall> primcall? make-primcall primcall-src primcall-name primcall-args
             <sequence> sequence? make-sequence sequence-src sequence-exps
             <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
             <lambda-case> lambda-case? make-lambda-case lambda-case-src
@@ -119,6 +120,7 @@
   ;; (<toplevel-define> name exp)
   ;; (<conditional> test consequent alternate)
   ;; (<call> proc args)
+  ;; (<primcall> name args)
   ;; (<sequence> exps)
   ;; (<lambda> meta body)
   ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
@@ -152,6 +154,9 @@
      ((call ,proc . ,args)
       (make-call loc (retrans proc) (map retrans args)))
 
+     ((primcall ,name . ,args)
+      (make-primcall loc name (map retrans args)))
+
      ((if ,test ,consequent ,alternate)
       (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
 
@@ -256,6 +261,9 @@
     ((<call> proc args)
      `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 
+    ((<primcall> name args)
+     `(primcall ,name ,@(map unparse-tree-il args)))
+
     ((<conditional> test consequent alternate)
      `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
 
@@ -339,6 +347,9 @@
     ((<call> proc args)
      `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
 
+    ((<primcall> name args)
+     `(,name ,@(map tree-il->scheme args)))
+
     ((<conditional> test consequent alternate)
      (if (void? alternate)
          `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent))
@@ -510,6 +521,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
                                 (loop test (down tree result))))))
           ((<call> proc args)
            (up tree (loop (cons proc args) (down tree result))))
+          ((<primcall> name args)
+           (up tree (loop args (down tree result))))
           ((<sequence> exps)
            (up tree (loop exps (down tree result))))
           ((<lambda> body)
@@ -584,6 +597,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
                  ((<call> proc args)
                   (let-values (((seed ...) (foldts proc seed ...)))
                     (fold-values foldts args seed ...)))
+                 ((<primcall> name args)
+                  (fold-values foldts args seed ...))
                  ((<sequence> exps)
                   (fold-values foldts exps seed ...))
                  ((<lambda> body)
@@ -638,6 +653,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
        (set! (call-proc x) (lp proc))
        (set! (call-args x) (map lp args)))
 
+      ((<primcall> name args)
+       (set! (primcall-args x) (map lp args)))
+
       ((<conditional> test consequent alternate)
        (set! (conditional-test x) (lp test))
        (set! (conditional-consequent x) (lp consequent))
@@ -722,6 +740,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
          (set! (call-proc x) (lp proc))
          (set! (call-args x) (map lp args)))
 
+        ((<primcall> name args)
+         (set! (primcall-args x) (map lp args)))
+
         ((<conditional> test consequent alternate)
          (set! (conditional-test x) (lp test))
          (set! (conditional-consequent x) (lp consequent))

module/language/tree-il/analyze.scm

@@ -182,6 +182,9 @@
        (apply lset-union eq? (step-tail-call proc args)
               (map step args)))
 
+      ((<primcall> args)
+       (apply lset-union eq? (map step args)))
+
       ((<conditional> test consequent alternate)
        (lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
 
@@ -367,6 +370,9 @@
       ((<call> proc args)
        (apply max (recur proc) (map recur args)))
 
+      ((<primcall> args)
+       (apply max n (map recur args)))
+
       ((<conditional> test consequent alternate)
        (max (recur test) (recur consequent) (recur alternate)))
 

module/language/tree-il/compile-glil.scm

@@ -256,172 +256,7 @@
                (lp (cdr exps))))))
 
       ((<call> src proc args)
-       ;; FIXME: need a better pattern-matcher here
        (cond
-        ((and (primitive-ref? proc)
-              (eq? (primitive-ref-name proc) '@apply)
-              (>= (length args) 1))
-         (let ((proc (car args))
-               (args (cdr args)))
-           (cond
-            ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
-                  (not (eq? context 'push)) (not (eq? context 'vals)))
-             ;; tail: (lambda () (apply values '(1 2)))
-             ;; drop: (lambda () (apply values '(1 2)) 3)
-             ;; push: (lambda () (list (apply values '(10 12)) 1))
-             (case context
-               ((drop) (for-each comp-drop args) (maybe-emit-return))
-               ((tail)
-                (for-each comp-push args)
-                (emit-code src (make-glil-call 'return/values* (length args))))))
-
-            (else
-             (case context
-               ((tail)
-                (comp-push proc)
-                (for-each comp-push args)
-                (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
-               ((push)
-                (emit-code src (make-glil-call 'new-frame 0))
-                (comp-push proc)
-                (for-each comp-push args)
-                (emit-code src (make-glil-call 'apply (1+ (length args))))
-                (maybe-emit-return))
-               ((vals)
-                (comp-vals
-                 (make-call src (make-primitive-ref #f 'apply)
-                            (cons proc args))
-                 MVRA)
-                (maybe-emit-return))
-               ((drop)
-                ;; Well, shit. The proc might return any number of
-                ;; values (including 0), since it's in a drop context,
-                ;; yet apply does not create a MV continuation. So we
-                ;; mv-call out to our trampoline instead.
-                (comp-drop
-                 (make-call src (make-primitive-ref #f 'apply)
-                            (cons proc args)))
-                (maybe-emit-return)))))))
-        
-        ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
-              (not (eq? context 'push)))
-         ;; tail: (lambda () (values '(1 2)))
-         ;; drop: (lambda () (values '(1 2)) 3)
-         ;; push: (lambda () (list (values '(10 12)) 1))
-         ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
-         (case context
-           ((drop) (for-each comp-drop args) (maybe-emit-return))
-           ((vals)
-            (for-each comp-push args)
-            (emit-code #f (make-glil-const (length args)))
-            (emit-branch src 'br MVRA))
-           ((tail)
-            (for-each comp-push args)
-            (emit-code src (make-glil-call 'return/values (length args))))))
-        
-        ((and (primitive-ref? proc)
-              (eq? (primitive-ref-name proc) '@call-with-values)
-              (= (length args) 2))
-	 ;; CONSUMER
-         ;; PRODUCER
-         ;; (mv-call MV)
-         ;; ([tail]-call 1)
-         ;; goto POST
-         ;; MV: [tail-]call/nargs
-         ;; POST: (maybe-drop)
-         (case context
-           ((vals)
-            ;; Fall back.
-            (comp-vals
-             (make-call src (make-primitive-ref #f 'call-with-values)
-                        args)
-             MVRA)
-            (maybe-emit-return))
-           (else
-            (let ((MV (make-label)) (POST (make-label))
-                  (producer (car args)) (consumer (cadr args)))
-              (if (not (eq? context 'tail))
-                  (emit-code src (make-glil-call 'new-frame 0)))
-              (comp-push consumer)
-              (emit-code src (make-glil-call 'new-frame 0))
-              (comp-push producer)
-              (emit-code src (make-glil-mv-call 0 MV))
-              (case context
-                ((tail) (emit-code src (make-glil-call 'tail-call 1)))
-                (else   (emit-code src (make-glil-call 'call 1))
-                        (emit-branch #f 'br POST)))
-              (emit-label MV)
-              (case context
-                ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
-                (else   (emit-code src (make-glil-call 'call/nargs 0))
-                        (emit-label POST)
-                        (if (eq? context 'drop)
-                            (emit-code #f (make-glil-call 'drop 1)))
-                        (maybe-emit-return)))))))
-
-        ((and (primitive-ref? proc)
-              (eq? (primitive-ref-name proc) '@call-with-current-continuation)
-              (= (length args) 1))
-         (case context
-           ((tail)
-            (comp-push (car args))
-            (emit-code src (make-glil-call 'tail-call/cc 1)))
-           ((vals)
-            (comp-vals
-             (make-call
-              src (make-primitive-ref #f 'call-with-current-continuation)
-              args)
-             MVRA)
-            (maybe-emit-return))
-           ((push)
-            (comp-push (car args))
-            (emit-code src (make-glil-call 'call/cc 1))
-            (maybe-emit-return))
-           ((drop)
-            ;; Crap. Just like `apply' in drop context.
-            (comp-drop
-             (make-call
-              src (make-primitive-ref #f 'call-with-current-continuation)
-              args))
-            (maybe-emit-return))))
-
-        ;; A hack for variable-set, the opcode for which takes its args
-        ;; reversed, relative to the variable-set! function
-        ((and (primitive-ref? proc)
-              (eq? (primitive-ref-name proc) 'variable-set!)
-              (= (length args) 2))
-         (comp-push (cadr args))
-         (comp-push (car args))
-         (emit-code src (make-glil-call 'variable-set 2))
-         (case context
-           ((tail push vals) (emit-code #f (make-glil-void))))
-         (maybe-emit-return))
-        
-        ((and (primitive-ref? proc)
-              (or (hash-ref *primcall-ops*
-                            (cons (primitive-ref-name proc) (length args)))
-                  (hash-ref *primcall-ops* (primitive-ref-name proc))))
-         => (lambda (op)
-              (for-each comp-push args)
-              (emit-code src (make-glil-call op (length args)))
-              (case (instruction-pushes op)
-                ((0)
-                 (case context
-                   ((tail push vals) (emit-code #f (make-glil-void))))
-                 (maybe-emit-return))
-                ((1)
-                 (case context
-                   ((drop) (emit-code #f (make-glil-call 'drop 1))))
-                 (maybe-emit-return))
-                ((-1)
-                 ;; A control instruction, like return/values.  Here we
-                 ;; just have to hope that the author of the tree-il
-                 ;; knew what they were doing.
-                 *unspecified*)
-                (else
-                 (error "bad primitive op: too many pushes"
-                        op (instruction-pushes op))))))
-        
         ;; self-call in tail position
         ((and (lexical-ref? proc)
               self-label (eq? (lexical-ref-gensym proc) self-label)
@@ -518,6 +353,141 @@
                            (emit-branch #f 'br RA)
                            (emit-label POST)))))))))
 
+      ((<primcall> src name args)
+       (pmatch (cons name args)
+         ((@apply ,proc . ,args)
+          (cond
+           ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+                 (not (eq? context 'push)) (not (eq? context 'vals)))
+            ;; tail: (lambda () (apply values '(1 2)))
+            ;; drop: (lambda () (apply values '(1 2)) 3)
+            ;; push: (lambda () (list (apply values '(10 12)) 1))
+            (case context
+              ((drop) (for-each comp-drop args) (maybe-emit-return))
+              ((tail)
+               (for-each comp-push args)
+               (emit-code src (make-glil-call 'return/values* (length args))))))
+
+           (else
+            (case context
+              ((tail)
+               (comp-push proc)
+               (for-each comp-push args)
+               (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+              ((push)
+               (emit-code src (make-glil-call 'new-frame 0))
+               (comp-push proc)
+               (for-each comp-push args)
+               (emit-code src (make-glil-call 'apply (1+ (length args))))
+               (maybe-emit-return))
+              (else
+               (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+         ((values . _) (guard (not (eq? context 'push)))
+          ;; tail: (lambda () (values '(1 2)))
+          ;; drop: (lambda () (values '(1 2)) 3)
+          ;; push: (lambda () (list (values '(10 12)) 1))
+          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+          (case context
+            ((drop) (for-each comp-drop args) (maybe-emit-return))
+            ((vals)
+             (for-each comp-push args)
+             (emit-code #f (make-glil-const (length args)))
+             (emit-branch src 'br MVRA))
+            ((tail)
+             (for-each comp-push args)
+             (emit-code src (make-glil-call 'return/values (length args))))))
+        
+         ((@call-with-values ,producer ,consumer)
+          ;; CONSUMER
+          ;; PRODUCER
+          ;; (mv-call MV)
+          ;; ([tail]-call 1)
+          ;; goto POST
+          ;; MV: [tail-]call/nargs
+          ;; POST: (maybe-drop)
+          (case context
+            ((vals)
+             ;; Fall back.
+             (comp-tail (make-primcall src 'call-with-values args)))
+            (else
+             (let ((MV (make-label)) (POST (make-label)))
+               (if (not (eq? context 'tail))
+                   (emit-code src (make-glil-call 'new-frame 0)))
+               (comp-push consumer)
+               (emit-code src (make-glil-call 'new-frame 0))
+               (comp-push producer)
+               (emit-code src (make-glil-mv-call 0 MV))
+               (case context
+                 ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+                 (else   (emit-code src (make-glil-call 'call 1))
+                         (emit-branch #f 'br POST)))
+               (emit-label MV)
+               (case context
+                 ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+                 (else   (emit-code src (make-glil-call 'call/nargs 0))
+                         (emit-label POST)
+                         (if (eq? context 'drop)
+                             (emit-code #f (make-glil-call 'drop 1)))
+                         (maybe-emit-return)))))))
+
+         ((@call-with-current-continuation ,proc)
+          (case context
+            ((tail)
+             (comp-push proc)
+             (emit-code src (make-glil-call 'tail-call/cc 1)))
+            ((vals)
+             (comp-vals
+              (make-primcall src 'call-with-current-continuation args)
+              MVRA)
+             (maybe-emit-return))
+            ((push)
+             (comp-push proc)
+             (emit-code src (make-glil-call 'call/cc 1))
+             (maybe-emit-return))
+            ((drop)
+             ;; Fall back.
+             (comp-tail
+              (make-primcall src 'call-with-current-continuation args)))))
+         
+        ;; A hack for variable-set, the opcode for which takes its args
+        ;; reversed, relative to the variable-set! function
+        ((variable-set! ,var ,val)
+         (comp-push val)
+         (comp-push var)
+         (emit-code src (make-glil-call 'variable-set 2))
+         (case context
+           ((tail push vals) (emit-code #f (make-glil-void))))
+         (maybe-emit-return))
+        
+        (else
+         (cond
+          ((or (hash-ref *primcall-ops* (cons name (length args)))
+               (hash-ref *primcall-ops* name))
+           => (lambda (op)
+                (for-each comp-push args)
+                (emit-code src (make-glil-call op (length args)))
+                (case (instruction-pushes op)
+                  ((0)
+                   (case context
+                     ((tail push vals) (emit-code #f (make-glil-void))))
+                   (maybe-emit-return))
+                  ((1)
+                   (case context
+                     ((drop) (emit-code #f (make-glil-call 'drop 1))))
+                   (maybe-emit-return))
+                  ((-1)
+                   ;; A control instruction, like return/values.  Here we
+                   ;; just have to hope that the author of the tree-il
+                   ;; knew what they were doing.
+                   *unspecified*)
+                  (else
+                   (error "bad primitive op: too many pushes"
+                          op (instruction-pushes op))))))
+          (else
+           ;; Fall back to the normal compilation strategy.
+           (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
       ((<conditional> src test consequent alternate)
        ;;     TEST
        ;;     (br-if-not L1)
@@ -526,54 +496,33 @@
        ;; L1: alternate
        ;; L2:
        (let ((L1 (make-label)) (L2 (make-label)))
-         ;; need a pattern matcher
          (record-case test
-           ((<call> proc args)
+           ((<primcall> name args)
-            (record-case proc
+            (pmatch (cons name args)
-              ((<primitive-ref> name)
+              ((eq? ,a ,b)
-               (let ((len (length args)))
+               (comp-push a)
-                 (cond
+               (comp-push b)
-
-                  ((and (eq? name 'eq?) (= len 2))
-                   (comp-push (car args))
-                   (comp-push (cadr args))
                (emit-branch src 'br-if-not-eq L1))
-
+              ((null? ,x)
-                  ((and (eq? name 'null?) (= len 1))
+               (comp-push x)
-                   (comp-push (car args))
                (emit-branch src 'br-if-not-null L1))
-
+              ((not ,x)
-                  ((and (eq? name 'not) (= len 1))
+               (record-case x
-                   (let ((app (car args)))
+                 ((<primcall> name args)
-                     (record-case app
+                  (pmatch (cons name args)
-                       ((<call> proc args)
+                    ((eq? ,a ,b)
-                        (let ((len (length args)))
+                     (comp-push a)
-                          (record-case proc
+                     (comp-push b)
-                            ((<primitive-ref> name)
-                             (cond
-
-                              ((and (eq? name 'eq?) (= len 2))
-                               (comp-push (car args))
-                               (comp-push (cadr args))
                      (emit-branch src 'br-if-eq L1))
-                            
+                    ((null? ,x)
-                              ((and (eq? name 'null?) (= len 1))
+                     (comp-push x)
-                               (comp-push (car args))
                      (emit-branch src 'br-if-null L1))
-
                     (else
-                               (comp-push app)
+                     (comp-push x)
                      (emit-branch src 'br-if L1))))
                  (else
-                             (comp-push app)
+                  (comp-push x)
-                             (emit-branch src 'br-if L1)))))
+                  (emit-branch src 'br-if L1))))
-                       (else
-                        (comp-push app)
-                        (emit-branch src 'br-if L1)))))
-                  
-                  (else
-                   (comp-push test)
-                   (emit-branch src 'br-if-not L1)))))
               (else
                (comp-push test)
                (emit-branch src 'br-if-not L1))))

module/language/tree-il/fix-letrec.scm

@@ -44,9 +44,8 @@
     ((<sequence> exps)
      (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
               exps))
-    ((<call> proc args)
+    ((<primcall> name args)
-     (and (primitive-ref? proc)
+     (and (simple-primitive? name)
-          (simple-primitive? (primitive-ref-name proc))
           ;; FIXME: check arity?
           (and-map (lambda (x)
                      (simple-expression? x bound-vars simple-primitive?))

module/language/tree-il/inline.scm

@@ -47,31 +47,28 @@
             (else x)))
          (else x)))
       
-      ((<call> src proc args)
+      ((<primcall> src name args)
-       (record-case proc
+       (pmatch (cons name args)
-         ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
+         ((,member ,k ,l) (guard (and (memq member '(memq memv))
-         ((<primitive-ref> name)
+                                      (const? k)
-          (case name
+                                      (list? (const-exp l))))
-            ((memq memv)
-             (pmatch args
-               ((,k ,l) (guard (const? l) (list? (const-exp l)))
           (cond
            ((null? (const-exp l))
             (make-const #f #f))
            ((const? k)
-                  (make-const #f (->bool ((case name
+            (make-const #f (->bool ((case member
                                       ((memq) memq)
                                       ((memv) memv)
-                                            (else (error "unexpected member func" name)))
+                                      (else (error "what" member)))
                                     (const-exp k) (const-exp l)))))
            (else
             (let lp ((elts (const-exp l)))
-                    (let ((test (make-call
+              (let ((test (make-primcall
                            #f
-                                 (make-primitive-ref #f (case name
+                           (case member
                              ((memq) 'eq?)
                              ((memv) 'eqv?)
-                                                          (else (error "what"))))
+                             (else (error "what" member)))
                            (list k (make-const #f (car elts))))))
                 (if (null? (cdr elts))
                     test
@@ -80,11 +77,6 @@
                      test
                      (make-const #f #t)
                      (lp (cdr elts)))))))))
-
-               (else x)))
-
-            (else x)))
-
          (else x)))
        
       ((<lambda> meta body)
@@ -114,18 +106,17 @@
                           (or (inline1 x) x))
                         (lp alternate)))))))
 
-         ((<primitive-ref> name)
+         (else #f)))
-          (case name
+       
-            ((@call-with-values)
+      ((<primcall> src name args)
-             (pmatch args
+       (pmatch (cons name args)
          ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
          ;; => (let-values (((a b . c) foo)) bar)
          ;;
-               ;; Note that this is a singly-binding form of let-values.
+         ;; Note that this is a singly-binding form of let-values.  Also
-               ;; Also note that Scheme's let-values expands into
+         ;; note that Scheme's let-values expands into call-with-values,
-               ;; call-with-values, then here we reduce it to tree-il's
+         ;; then here we reduce it to tree-il's let-values.
-               ;; let-values.
+         ((@call-with-values ,producer ,consumer)
-               ((,producer ,consumer)
           (guard (lambda? consumer)
                  (lambda-case? (lambda-body consumer))
                  (not (lambda-case-opt (lambda-body consumer)))
@@ -138,10 +129,6 @@
            (lambda-body consumer)))
          (else #f)))
 
-            (else #f)))
-
-         (else #f)))
-       
       ((<conditional> test consequent alternate)
        (let ((btest (boolean-value test)))
          (or (record-case btest
@@ -178,10 +165,9 @@
          
        (and (not opt) (not kw) rest (not alternate)
             (record-case body
-              ((<call> proc args)
+              ((<primcall> name args)
                ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
-               (and (primitive-ref? proc)
+               (and (eq? name '@apply)
-                    (eq? (primitive-ref-name proc) '@apply)
                     (pair? args)
                     (lambda? (car args))
                     (args-compatible? (cdr args) gensyms)

module/language/tree-il/primitives.scm

@@ -172,6 +172,9 @@
                (and=> (hashq-ref *interesting-primitive-vars*
                                  (module-variable m name))
                       (lambda (name) (make-primitive-ref src name))))))
+       ((<call> src proc args)
+        (and (primitive-ref? proc)
+             (make-primcall src (primitive-ref-name proc) args)))
        (else #f)))
    x))
 
@@ -183,11 +186,9 @@
   (pre-order!
    (lambda (x)
      (record-case x
-       ((<call> src proc args)
+       ((<primcall> src name args)
-        (and (primitive-ref? proc)
+        (let ((expand (hashq-ref *primitive-expand-table* name)))
-             (let ((expand (hashq-ref *primitive-expand-table*
+          (and expand (apply expand src args))))
-                                      (primitive-ref-name proc))))
-               (and expand (apply expand src args)))))
        (else #f)))
    x))
 
@@ -203,7 +204,7 @@
              (lp (cdr in)
                  (cons (if (eq? (caar in) 'quote)
                            `(make-const src ,@(cdar in))
-                           `(make-call src (make-primitive-ref src ',(caar in))
+                           `(make-primcall src ',(caar in)
                                            ,(inline-args (cdar in))))
                        out)))
             ((symbol? (car in))
@@ -222,7 +223,7 @@
               ,(consequent then)
               ,(consequent else)))
         (else
-         `(make-call src (make-primitive-ref src ',(car exp))
+         `(make-primcall src ',(car exp)
                          ,(inline-args (cdr exp))))))
      ((symbol? exp)
       ;; assume locally bound
@@ -470,7 +471,7 @@
                   ;; trickery here.
                   (make-lambda-case
                    (tree-il-src handler) '() #f 'args #f '() (list args-sym)
-                   (make-call #f (make-primitive-ref #f 'apply)
+                   (make-primcall #f 'apply
                                   (list handler
                                         (make-lexical-ref #f 'args args-sym)))
                    #f))))
@@ -491,7 +492,7 @@
                     ;; trickery here.
                     (make-lambda-case
                      (tree-il-src handler) '() #f 'args #f '() (list args-sym)
-                     (make-call #f (make-primitive-ref #f 'apply)
+                     (make-primcall #f 'apply
                                     (list handler
                                           (make-lexical-ref #f 'args args-sym)))
                      #f))))

test-suite/tests/tree-il.test

@@ -63,7 +63,7 @@
    (begin (void) (const 1))
    (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
   (assert-tree-il->glil
-   (call (primitive +) (void) (const 1))
+   (primcall + (void) (const 1))
    (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
 
 (with-test-prefix "application"
@@ -98,7 +98,7 @@
    (eq? l1 l3) (eq? l2 l4))
 
   (assert-tree-il->glil
-   (call (primitive null?) (if (toplevel foo) (const 1) (const 2)))
+   (primcall null? (if (toplevel foo) (const 1) (const 2)))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
             (const 1) (branch br ,l2)
                     (label ,l3) (const 2) (label ,l4)
@@ -115,7 +115,7 @@
    (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (primitive +))
+   (primcall null? (primitive +))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
             (call return 1))))
 
@@ -135,7 +135,7 @@
             (unbind)))
 
   (assert-tree-il->glil
-   (let (x) (y) ((const 1)) (call (primitive null?) (lexical x y)))
+   (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (lexical #t #f ref 0) (call null? 1) (call return 1)
@@ -145,7 +145,7 @@
   (assert-tree-il->glil
    ;; unreferenced sets may be optimized away -- make sure they are ref'd
    (let (x) (y) ((const 1))
-        (set! (lexical x y) (call (primitive 1+) (lexical x y))))
+        (set! (lexical x y) (primcall 1+ (lexical x y))))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
@@ -154,7 +154,7 @@
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
-        (begin (set! (lexical x y) (call (primitive 1+) (lexical x y)))
+        (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
                (lexical x y)))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
@@ -164,8 +164,8 @@
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
-     (call (primitive null?)
+     (primcall null?
-            (set! (lexical x y) (call (primitive 1+) (lexical x y)))))
+           (set! (lexical x y) (primcall 1+ (lexical x y)))))
    (program () (std-prelude 0 1 #f) (label _)
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
             (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
@@ -186,7 +186,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (@ (foo) bar))
+   (primcall null? (@ (foo) bar))
    (program () (std-prelude 0 0 #f) (label _)
             (module public ref (foo) bar)
             (call null? 1) (call return 1)))
@@ -204,7 +204,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (@@ (foo) bar))
+   (primcall null? (@@ (foo) bar))
    (program () (std-prelude 0 0 #f) (label _)
             (module private ref (foo) bar)
             (call null? 1) (call return 1))))
@@ -223,7 +223,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (set! (@ (foo) bar) (const 2)))
+   (primcall null? (set! (@ (foo) bar) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (module public set (foo) bar)
             (void) (call null? 1) (call return 1)))
@@ -241,7 +241,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (set! (@@ (foo) bar) (const 2)))
+   (primcall null? (set! (@@ (foo) bar) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (module private set (foo) bar)
             (void) (call null? 1) (call return 1))))
@@ -260,7 +260,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (toplevel bar))
+   (primcall null? (toplevel bar))
    (program () (std-prelude 0 0 #f) (label _)
             (toplevel ref bar)
             (call null? 1) (call return 1))))
@@ -279,7 +279,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (set! (toplevel bar) (const 2)))
+   (primcall null? (set! (toplevel bar) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (toplevel set bar)
             (void) (call null? 1) (call return 1))))
@@ -298,7 +298,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (define bar (const 2)))
+   (primcall null? (define bar (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (toplevel define bar)
             (void) (call null? 1) (call return 1))))
@@ -315,7 +315,7 @@
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (const 2))
+   (primcall null? (const 2))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (call null? 1) (call return 1))))
 
@@ -336,7 +336,7 @@
   ;; complex bindings -> box and set! within let
   (assert-tree-il->glil
    (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
-           (call (primitive +) (lexical x x1) (lexical y y1)))
+           (primcall + (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 4 #f) (label _)
             (void) (void) ;; what are these?
             (bind (x #t 0) (y #t 1))
@@ -352,7 +352,7 @@
   ;; complex bindings in letrec* -> box and set! in order
   (assert-tree-il->glil
    (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
-            (call (primitive +) (lexical x x1) (lexical y y1)))
+            (primcall + (lexical x x1) (lexical y y1)))
    (program () (std-prelude 0 2 #f) (label _)
             (void) (void) ;; what are these?
             (bind (x #t 0) (y #t 1))
@@ -470,7 +470,7 @@
             (const #t) (call return 1)))
 
   (assert-tree-il->glil
-   (call (primitive null?) (begin (const #f) (const 2)))
+   (primcall null? (begin (const #f) (const 2)))
    (program () (std-prelude 0 0 #f) (label _)
             (const 2) (call null? 1) (call return 1))))
 
@@ -512,10 +512,10 @@
 
 (with-test-prefix "apply"
   (assert-tree-il->glil
-   (call (primitive @apply) (toplevel foo) (toplevel bar))
+   (primcall @apply (toplevel foo) (toplevel bar))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
   (assert-tree-il->glil
-   (begin (call (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+   (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -531,10 +531,10 @@
 
 (with-test-prefix "call/cc"
   (assert-tree-il->glil
-   (call (primitive @call-with-current-continuation) (toplevel foo))
+   (primcall @call-with-current-continuation (toplevel foo))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
   (assert-tree-il->glil
-   (begin (call (primitive @call-with-current-continuation) (toplevel foo)) (void))
+   (begin (primcall @call-with-current-continuation (toplevel foo)) (void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)