Simplify the interpreter for trivial inits and no letrec

* libguile/memoize.c (FULL_ARITY): Serialize "ninits" and the unbound
  value instead of the init list.
  (memoize): Adapt to FULL_ARITY changes.  Remove LETREC case.
  (unmemoize): Adapt to memoized code change.

* libguile/eval.c (BOOT_CLOSURE_PARSE_FULL): Adapt to parse ninits and
  unbound instead of inits.
  (eval): Lexical-ref can no longer raise an error.
  (prepare_boot_closure_env_for_apply): Adapt to inits change.

* module/ice-9/eval.scm (primitive-eval): Adapt to ninits/unbound
  change.

* libguile/expand.c (expand_named_let): Fix lambda-case creation to make
  lists for opt and inits.

4 files changed, 70 insertions, 187 deletions

diff --git a/libguile/eval.c b/libguile/eval.c
index 2488ee272..d76fbd30d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -116,13 +116,13 @@ static scm_t_bits scm_tc16_boot_closure;
 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
 /* NB: One may only call the following accessors if the closure is not REST. */
 #define BOOT_CLOSURE_IS_FULL(x) (1)
-#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt)    \
+#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \
   do { SCM fu = fu_;                                            \
     body = CAR (fu); fu = CDDR (fu);                            \
                                                                 \
     rest = kw = alt = SCM_BOOL_F;                               \
-    inits = SCM_EOL;                                            \
-    nopt = 0;                                                   \
+    unbound = SCM_BOOL_F;                                       \
+    nopt = ninits = 0;                                          \
                                                                 \
     nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu);                \
     if (scm_is_pair (fu))                                       \
@@ -132,7 +132,8 @@ static scm_t_bits scm_tc16_boot_closure;
           {                                                     \
             nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu);        \
             kw = CAR (fu); fu = CDR (fu);                       \
-            inits = CAR (fu); fu = CDR (fu);                    \
+            ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu);      \
+            unbound = CAR (fu); fu = CDR (fu);                  \
             alt = CAR (fu);                                     \
           }                                                     \
       }                                                         \
@@ -196,14 +197,6 @@ env_set (SCM env, int depth, int width, SCM val)
 }
 
 
-SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-
-static void error_used_before_defined (void)
-{
-  scm_error (scm_unbound_variable_key, NULL,
-             "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
-}
-
 static void error_invalid_keyword (SCM proc, SCM obj)
 {
   scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
@@ -358,20 +351,14 @@ eval (SCM x, SCM env)
 
     case SCM_M_LEXICAL_REF:
       {
-        SCM pos, ret;
+        SCM pos;
         int depth, width;
 
         pos = mx;
         depth = SCM_I_INUM (CAR (pos));
         width = SCM_I_INUM (CDR (pos));
 
-        ret = env_ref (env, depth, width);
-
-        if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
-          /* we don't know what variable, though, because we don't have its
-             name */
-          error_used_before_defined ();
-        return ret;
+        return env_ref (env, depth, width);
       }
 
     case SCM_M_LEXICAL_SET:
@@ -764,12 +751,13 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
     }
   else
     {
-      int i, argc, nreq, nopt, nenv;
-      SCM body, rest, kw, inits, alt;
+      int i, argc, nreq, nopt, ninits, nenv;
+      SCM body, rest, kw, unbound, alt;
       SCM mx = BOOT_CLOSURE_CODE (proc);
       
     loop:
-      BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
+      BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw,
+                               ninits, unbound, alt);
 
       argc = scm_ilength (args);
       if (argc < nreq)
@@ -814,8 +802,8 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
         }
 
       /* At this point we are committed to the chosen clause.  */
-      nenv = nreq + (scm_is_true (rest) ? 1 : 0) + scm_ilength (inits);
-      env = make_env (nenv, SCM_UNDEFINED, env);
+      nenv = nreq + (scm_is_true (rest) ? 1 : 0) + ninits;
+      env = make_env (nenv, unbound, env);
 
       for (i = 0; i < nreq; i++, args = CDR (args))
         env_set (env, 0, i, CAR (args));
@@ -823,15 +811,10 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
       if (scm_is_false (kw))
         {
           /* Optional args (possibly), but no keyword args. */
-          for (; i < argc && i < nreq + nopt;
-               i++, args = CDR (args), inits = CDR (inits))
+          for (; i < argc && i < nreq + nopt; i++, args = CDR (args))
             env_set (env, 0, i, CAR (args));
-              
-          for (; i < nreq + nopt; i++, inits = CDR (inits))
-            env_set (env, 0, i, EVAL1 (CAR (inits), env));
-
           if (scm_is_true (rest))
-            env_set (env, 0, i++, args);
+            env_set (env, 0, nreq + nopt, args);
         }
       else
         {
@@ -842,18 +825,13 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
 
           /* Optional args. As before, but stop at the first keyword. */
           for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
-               i++, args = CDR (args), inits = CDR (inits))
+               i++, args = CDR (args))
             env_set (env, 0, i, CAR (args));
-              
-          for (; i < nreq + nopt; i++, inits = CDR (inits))
-            env_set (env, 0, i, EVAL1 (CAR (inits), env));
-
           if (scm_is_true (rest))
-            env_set (env, 0, i++, args);
+            env_set (env, 0, nreq + nopt, args);
 
           /* Parse keyword args. */
           {
-            int kw_start_idx = i;
             SCM walk;
 
             if (scm_is_pair (args) && scm_is_pair (CDR (args)))
@@ -880,20 +858,9 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
                 }
             if (scm_is_pair (args) && scm_is_false (rest))
               error_invalid_keyword (proc, CAR (args));
-
-            /* Now fill in unbound values, evaluating init expressions in their
-               appropriate environment. */
-            for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits))
-              if (SCM_UNBNDP (env_ref (env, 0, i)))
-                env_set (env, 0, i, EVAL1 (CAR (inits), env));
           }
         }
 
-      if (!scm_is_null (inits))
-        abort ();
-      if (i != nenv)
-        abort ();
-
       *out_body = body;
       *out_env = env;
     }
diff --git a/libguile/expand.c b/libguile/expand.c
index 1d511e62d..e1c6c18a5 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -977,8 +977,8 @@ expand_named_let (const SCM expr, SCM env)
      scm_list_1 (name), scm_list_1 (name_sym),
      scm_list_1 (LAMBDA (SCM_BOOL_F,
                          SCM_EOL,
-                         LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F,
-                                      SCM_BOOL_F, SCM_BOOL_F, var_syms,
+                         LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
+                                      SCM_BOOL_F, SCM_EOL, var_syms,
                                       expand_sequence (CDDDR (expr), inner_env),
                                       SCM_BOOL_F))),
      CALL (SCM_BOOL_F,
@@ -1434,7 +1434,7 @@ convert_assignment (SCM exp, SCM assigned)
         alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
 
         new_inits = scm_make_list (scm_length (inits), const_unbound);
-                                             
+
         seq = SCM_EOL, symwalk = syms;
 
         /* Required arguments may need boxing.  */
@@ -1511,7 +1511,7 @@ convert_assignment (SCM exp, SCM assigned)
 
     case SCM_EXPANDED_LETREC:
       {
-        SCM src, names, syms, vals, unbound, boxes, body;
+        SCM src, names, syms, vals, empty_box, boxes, body;
 
         src = REF (exp, LETREC, SRC);
         names = REF (exp, LETREC, NAMES);
@@ -1519,10 +1519,11 @@ convert_assignment (SCM exp, SCM assigned)
         vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
         body = convert_assignment (REF (exp, LETREC, BODY), assigned);
 
-        unbound = PRIMCALL (SCM_BOOL_F,
-                            scm_from_latin1_symbol ("make-undefined-variable"),
-                            SCM_EOL);
-        boxes = scm_make_list (scm_length (names), unbound);
+        empty_box =
+          PRIMCALL (SCM_BOOL_F,
+                    scm_from_latin1_symbol ("make-undefined-variable"),
+                    SCM_EOL);
+        boxes = scm_make_list (scm_length (names), empty_box);
 
         if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
           return LET
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 36766e83e..9651cadc6 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -119,9 +119,9 @@ scm_t_bits scm_tc16_memoized;
   scm_list_1 (SCM_I_MAKINUM (nreq))
 #define REST_ARITY(nreq, rest) \
   scm_list_2 (SCM_I_MAKINUM (nreq), rest)
-#define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
-  scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
-              alt, SCM_UNDEFINED)
+#define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
+  scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
+              SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
 #define MAKMEMO_LAMBDA(body, arity, meta)			\
   MAKMEMO (SCM_M_LAMBDA,					\
 	   scm_cons (body, scm_cons (meta, arity)))
@@ -418,8 +418,8 @@ memoize (SCM exp, SCM env)
     case SCM_EXPANDED_LAMBDA_CASE:
       {
         SCM req, rest, opt, kw, inits, vars, body, alt;
-        SCM walk, minits, arity, rib, new_env;
-        int nreq, nopt;
+        SCM unbound, arity, rib;
+        int nreq, nopt, ninits;
 
         req = REF (exp, LAMBDA_CASE, REQ);
         rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
@@ -432,17 +432,12 @@ memoize (SCM exp, SCM env)
 
         nreq = scm_ilength (req);
         nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
-
-        /* The vars are the gensyms, according to the divine plan. But we need
-           to memoize the inits within their appropriate environment,
-           complicating things. */
+        ninits = scm_ilength (inits);
+        /* This relies on assignment conversion turning inits into a
+           sequence of CONST expressions whose values are a unique
+           "unbound" token.  */
+        unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
         rib = scm_vector (vars);
-        new_env = scm_cons (rib, env);
-
-        minits = SCM_EOL;
-        for (walk = inits; scm_is_pair (walk); walk = CDR (walk))
-          minits = scm_cons (memoize (CAR (walk), new_env), minits);
-        minits = scm_reverse_x (minits, SCM_UNDEFINED);
 
         if (scm_is_true (kw))
           {
@@ -468,12 +463,13 @@ memoize (SCM exp, SCM env)
               arity = REST_ARITY (nreq, SCM_BOOL_T);
           }
         else if (scm_is_true (alt))
-          arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
+          arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
                               SCM_MEMOIZED_ARGS (memoize (alt, env)));
         else
-          arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
+          arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
+                              SCM_BOOL_F);
 
-        return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
+        return MAKMEMO_LAMBDA (memoize (body, scm_cons (rib, env)), arity,
 			       SCM_BOOL_F /* meta, filled in later */);
       }
 
@@ -497,64 +493,6 @@ memoize (SCM exp, SCM env)
           (MAKMEMO_LET (inits, memoize (body, new_env)), env);
       }
 
-    case SCM_EXPANDED_LETREC:
-      {
-        SCM vars, varsv, exps, expsv, body, undefs, new_env;
-        int i, nvars, in_order_p;
-        
-        vars = REF (exp, LETREC, GENSYMS);
-        exps = REF (exp, LETREC, VALS);
-        body = REF (exp, LETREC, BODY);
-        in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
-
-        varsv = scm_vector (vars);
-        nvars = VECTOR_LENGTH (varsv);
-        expsv = scm_vector (exps);
-
-        undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
-        new_env = scm_cons (varsv, capture_env (env));
-
-        if (in_order_p)
-          {
-            SCM body_exps = memoize (body, new_env);
-            for (i = nvars - 1; i >= 0; i--)
-              {
-                SCM init = memoize (VECTOR_REF (expsv, i), new_env);
-                body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init),
-                                         body_exps);
-              }
-            return maybe_makmemo_capture_module
-              (MAKMEMO_LET (undefs, body_exps), env);
-          }
-        else
-          {
-            SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F);
-            for (i = nvars - 1; i >= 0; i--)
-              {
-                SCM init, set;
-
-                init = memoize (VECTOR_REF (expsv, i), new_env);
-                VECTOR_SET (inits, i, init);
-
-                set = MAKMEMO_LEX_SET (make_pos (1, i),
-                                       MAKMEMO_LEX_REF (make_pos (0, i)));
-                if (scm_is_false (sets))
-                  sets = set;
-                else
-                  sets = MAKMEMO_SEQ (set, sets);
-              }
-
-            if (scm_is_false (sets))
-              return memoize (body, env);
-
-            return maybe_makmemo_capture_module
-              (MAKMEMO_LET (undefs,
-                            MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
-                                         memoize (body, new_env))),
-               env);
-          }
-      }
-
     default:
       abort ();
     }
@@ -670,7 +608,7 @@ unmemoize (const SCM expr)
 	  {
 	    SCM alt, tail;
 
-	    alt = CADDR (CDDDR (spec));
+	    alt = CADDDR (CDDDR (spec));
 	    if (scm_is_true (alt))
 	      tail = CDR (unmemoize (alt));
 	    else
@@ -682,7 +620,7 @@ unmemoize (const SCM expr)
 						 CADR (spec),
 						 CADDR (spec),
 						 CADDDR (spec),
-						 unmemoize_exprs (CADR (CDDDR (spec)))),
+                                                 CADR (CDDDR (spec))),
 				     unmemoize (body)),
 			 tail));
 	  }
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 89d17cd91..98db033ea 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -329,16 +329,10 @@
     ;; of arguments, and some rest arities; see make-fixed-closure and
     ;; make-rest-closure above.
 
-    ;; A unique marker for unbound keywords.  NB: There should be no
-    ;; other instance of '(unbound-arg) in this compilation unit, so
-    ;; that this marker is indeed unique.  It's a hack, but it allows
-    ;; the constant to propagate to inner closures, reducing free
-    ;; variable counts all around, so it is important for perf.
-    (define unbound-arg '(unbound-arg))
-
     ;; Procedures with rest, optional, or keyword arguments, potentially with
     ;; multiple arities, as with case-lambda.
-    (define (make-general-closure env body nreq rest? nopt kw inits alt)
+    (define (make-general-closure env body nreq rest? nopt kw ninits unbound
+                                  alt)
       (define alt-proc
         (and alt                        ; (body meta nreq ...)
              (let* ((body (car alt))
@@ -348,9 +342,11 @@
                     (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
                     (nopt (if tail (car tail) 0))
                     (kw (and tail (cadr tail)))
-                    (inits (if tail (caddr tail) '()))
-                    (alt (and tail (cadddr tail))))
-               (make-general-closure env body nreq rest nopt kw inits alt))))
+                    (ninits (if tail (caddr tail) 0))
+                    (unbound (and tail (cadddr tail)))
+                    (alt (and tail (car (cddddr tail)))))
+               (make-general-closure env body nreq rest nopt kw ninits unbound
+                                     alt))))
       (define (set-procedure-arity! proc)
         (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
           (if (not alt)
@@ -367,7 +363,7 @@
                      (rest?* (if (null? (cdr spec)) #f (cadr spec)))
                      (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
                      (nopt* (if tail (car tail) 0))
-                     (alt* (and tail (cadddr tail))))
+                     (alt* (and tail (car (cddddr tail)))))
                 (if (or (< nreq* nreq)
                         (and (= nreq* nreq)
                              (if rest?
@@ -395,8 +391,8 @@
                              "eval" "Wrong number of arguments"
                              '() #f))))
             (else
-             (let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
-                    (env (make-env nvals unbound-arg env)))
+             (let* ((nvals (+ nreq (if rest? 1 0) ninits))
+                    (env (make-env nvals unbound env)))
                (let lp ((i 0) (args %args))
                  (cond
                   ((< i nreq)
@@ -405,39 +401,30 @@
                    (lp (1+ i) (cdr args)))
                   ((not kw)
                    ;; Optional args (possibly), but no keyword args.
-                   (let lp ((i i) (args args) (inits inits))
+                   (let lp ((i i) (args args))
                      (cond
-                      ((< i (+ nreq nopt))
-                       (cond
-                        ((< i nargs)
-                         (env-set! env 0 i (car args))
-                         (lp (1+ i) (cdr args) (cdr inits)))
-                        (else
-                         (env-set! env 0 i (eval (car inits) env))
-                         (lp (1+ i) args (cdr inits)))))
+                      ((and (< i (+ nreq nopt)) (< i nargs))
+                       (env-set! env 0 i (car args))
+                       (lp (1+ i) (cdr args)))
                       (else
                        (when rest?
-                         (env-set! env 0 i args))
+                         (env-set! env 0 (+ nreq nopt) args))
                        (eval body env)))))
                   (else
                    ;; Optional args.  As before, but stop at the first
                    ;; keyword.
-                   (let lp ((i i) (args args) (inits inits))
+                   (let lp ((i i) (args args))
                      (cond
-                      ((< i (+ nreq nopt))
-                       (cond
-                        ((and (< i nargs) (not (keyword? (car args))))
-                         (env-set! env 0 i (car args))
-                         (lp (1+ i) (cdr args) (cdr inits)))
-                        (else
-                         (env-set! env 0 i (eval (car inits) env))
-                         (lp (1+ i) args (cdr inits)))))
+                      ((and (< i (+ nreq nopt))
+                            (< i nargs)
+                            (not (keyword? (car args))))
+                       (env-set! env 0 i (car args))
+                       (lp (1+ i) (cdr args)))
                       (else
                        (when rest?
-                         (env-set! env 0 i args))
+                         (env-set! env 0 (+ nreq nopt) args))
                        (let ((aok (car kw))
-                             (kw (cdr kw))
-                             (kw-base (if rest? (1+ i) i)))
+                             (kw (cdr kw)))
                          ;; Now scan args for keywords.
                          (let lp ((args args))
                            (cond
@@ -463,19 +450,8 @@
                                              "eval" "Invalid keyword"
                                              '() (list (car args))))))
                             (else
-                             ;; Finished parsing keywords. Fill in
-                             ;; uninitialized kwargs by evalling init
-                             ;; expressions in their appropriate
-                             ;; environment.
-                             (let lp ((i kw-base) (inits inits))
-                               (cond
-                                ((pair? inits)
-                                 (when (eq? (env-ref env 0 i) unbound-arg)
-                                   (env-set! env 0 i (eval (car inits) env)))
-                                 (lp (1+ i) (cdr inits)))
-                                (else
-                                 ;; Finally, eval the body.
-                                 (eval body env)))))))))))))))))))))
+                             ;; Finally, eval the body.
+                             (eval body env))))))))))))))))))
 
     ;; The "engine". EXP is a memoized expression.
     (define (eval exp env)
@@ -513,9 +489,10 @@
                      (if (null? tail)
                          (make-rest-closure eval nreq body env)
                          (mx-bind
-                          tail (nopt kw inits alt)
+                          tail (nopt kw ninits unbound alt)
                           (make-general-closure env body nreq rest?
-                                                nopt kw inits alt)))))))
+                                                nopt kw ninits unbound
+                                                alt)))))))
            (let lp ((meta meta))
              (unless (null? meta)
                (set-procedure-property! proc (caar meta) (cdar meta))