primitive-eval passes first N args on stack directly, not via apply

* libguile/memoize.c (MAKMEMO_CALL): Memoize in the number of arguments
  at the call site.
  (memoize, scm_m_cond, memoize_named_let, unmemoize):
* libguile/eval.c (eval): Adapt to changes in call memoization.

* module/ice-9/eval.scm (primitive-eval): For calls, pass the first N
  arguments directly on the stack, and only the rest as a consed
  argument list to apply. Currently N is 4.

libguile/eval.c

@@ -254,8 +254,8 @@ eval (SCM x, SCM env)
     case SCM_M_CALL:
       /* Evaluate the procedure to be applied.  */
       proc = eval (CAR (mx), env);
-          
+      /* int nargs = CADR (mx); */
-      mx = CDR (mx);
+      mx = CDDR (mx);
 
       if (BOOT_CLOSURE_P (proc))
         {
@@ -289,6 +289,7 @@ eval (SCM x, SCM env)
       else
         {
           SCM rest = SCM_EOL;
+          /* FIXME: use alloca */
           for (; scm_is_pair (mx); mx = CDR (mx))
             rest = scm_cons (eval (CAR (mx), env), rest);
           return scm_vm_apply (scm_the_vm (), proc, scm_reverse (rest));

libguile/memoize.c

@@ -207,8 +207,8 @@ scm_t_bits scm_tc16_memoized;
   MAKMEMO (SCM_M_CONT, proc)
 #define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
   MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
-#define MAKMEMO_CALL(proc, args) \
+#define MAKMEMO_CALL(proc, nargs, args) \
-  MAKMEMO (SCM_M_CALL, scm_cons (proc, args))
+  MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
 #define MAKMEMO_LEX_REF(n) \
   MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
 #define MAKMEMO_LEX_SET(n, val) \
@@ -345,11 +345,15 @@ memoize (SCM exp, SCM env)
         return trans (exp, env);
       else
         {
+          SCM proc;
           SCM args = SCM_EOL;
-          for (; scm_is_pair (exp); exp = CDR (exp))
+          int nargs = 0;
+          proc = memoize (CAR (exp), env);
+          for (exp = CDR (exp); scm_is_pair (exp); exp = CDR (exp), nargs++)
             args = scm_cons (memoize (CAR (exp), env), args);
           if (scm_is_null (exp))
-            return MAKMEMO (SCM_M_CALL, scm_reverse_x (args, SCM_UNDEFINED));
+            return MAKMEMO_CALL (proc, nargs,
+                                 scm_reverse_x (args, SCM_UNDEFINED));
           else
             syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
         }
@@ -566,6 +570,7 @@ scm_m_cond (SCM expr, SCM env)
           i = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
                           MAKMEMO_CALL (memoize (CADDR (clause),
                                                  scm_cons (tmp, new_env)),
+                                        1,
                                         scm_list_1 (MAKMEMO_LEX_REF (0))),
                           MAKMEMO_QUOTE (SCM_UNSPECIFIED));
           SCM_SETCDR (loc, 
@@ -793,6 +798,7 @@ memoize_named_let (const SCM expr, SCM env)
                     memoize_sequence (CDDDR (expr),
                                       memoize_env_extend (env, rvariables)))),
                   MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
+                                nreq,
                                 memoize_exprs (inits, env)))));
 }
 
@@ -1054,7 +1060,7 @@ unmemoize (const SCM expr)
     case SCM_M_BEGIN:
       return scm_cons (scm_sym_begin, unmemoize_exprs (args));
     case SCM_M_CALL:
-      return unmemoize_exprs (args);
+      return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
     case SCM_M_CONT:
       return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
     case SCM_M_CALL_WITH_VALUES:

module/ice-9/eval.scm

@@ -55,10 +55,9 @@
                (and (current-module) the-root-module)
                env)))))
 
-  (define *max-static-argument-count* 8)
-
   (define-syntax make-closure
     (lambda (x)
+      (define *max-static-argument-count* 8)
       (define (make-formals n)
         (map (lambda (i)
                (datum->syntax
@@ -107,6 +106,43 @@
                                     (1- nreq)
                                     (cdr args)))))))))))))
 
+  (define-syntax call
+    (lambda (x)
+      (define *max-static-call-count* 4)
+      (syntax-case x ()
+        ((_ eval proc nargs args env) (identifier? #'env)
+         #`(case nargs
+             #,@(map (lambda (nargs)
+                       #`((#,nargs)
+                          (proc
+                           #,@(map
+                               (lambda (n)
+                                 (let lp ((n n) (args #'args))
+                                   (if (zero? n)
+                                       #`(eval (car #,args) env)
+                                       (lp (1- n) #`(cdr #,args)))))
+                               (iota nargs)))))
+                     (iota *max-static-call-count*))
+             (else
+              (apply proc
+                     #,@(map
+                         (lambda (n)
+                           (let lp ((n n) (args #'args))
+                             (if (zero? n)
+                                 #`(eval (car #,args) env)
+                                 (lp (1- n) #`(cdr #,args)))))
+                         (iota *max-static-call-count*))
+                     (let lp ((exps #,(let lp ((n *max-static-call-count*)
+                                               (args #'args))
+                                        (if (zero? n)
+                                            args
+                                            (lp (1- n) #`(cdr #,args)))))
+                              (args '()))
+                       (if (null? exps)
+                           (reverse args)
+                           (lp (cdr exps)
+                               (cons (eval (car exps) env) args)))))))))))
+
   ;; This macro could be more straightforward if the compiler had better
   ;; copy propagation. As it is we do some copy propagation by hand.
   (define-syntax mx-bind
@@ -189,14 +225,10 @@
         (('apply (f args))
          (apply (eval f env) (eval args env)))
 
-        (('call (f . args))
+        (('call (f nargs . args))
          (let ((proc (eval f env)))
-           (let eval-args ((in args) (out '()))
+           (call eval proc nargs args env)))
-             (if (null? in)
+        
-                 (apply proc (reverse out))
-                 (eval-args (cdr in)
-                            (cons (eval (car in) env) out))))))
-      
         (('call/cc proc)
          (call/cc (eval proc env)))