Merge commit 'origin/master'

19 files changed, 1107 insertions, 410 deletions

diff --git a/configure.in b/configure.ac
index 53049eb79..dae82954a 100644
--- a/configure.in
+++ b/configure.ac
@@ -827,22 +827,19 @@ fi
 
 
 dnl GMP tests
-AC_LIB_LINKFLAGS(gmp)
-AC_CHECK_LIB([gmp], [__gmpz_init], ,
-  [AC_MSG_ERROR([GNU MP not found, see README])])
-
-# mpz_import is a macro so we need to include <gmp.h>
-AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <gmp.h>]],
- 			        [[mpz_import (0, 0, 0, 0, 0, 0, 0); ]])],
+AC_LIB_HAVE_LINKFLAGS(gmp,
   [],
-  [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])])
+  [#include <gmp.h>],
+  [mpz_import (0, 0, 0, 0, 0, 0, 0);],
+  AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README]))
 
 dnl GNU libunistring tests.
-if test "x$LTLIBUNISTRING" != "x"; then
-   LIBS="$LTLIBUNISTRING $LIBS"
-else
-   AC_MSG_ERROR([GNU libunistring is required, please install it.])
-fi
+AC_LIB_HAVE_LINKFLAGS(unistring,
+  [],
+  [#include <unistr.h>],
+  [u8_check ("foo", 3)]
+  AC_MSG_ERROR([GNU libunistring not found, see README]))
+
 
 dnl i18n tests
 #AC_CHECK_HEADERS([libintl.h])
diff --git a/guile-readline/configure.in b/guile-readline/configure.ac
index f24fc9418..f24fc9418 100644
--- a/guile-readline/configure.in
+++ b/guile-readline/configure.ac
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 8c9c598bf..dfaa65a8f 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -220,7 +220,7 @@ noinst_HEADERS = convert.i.c					\
 noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
 
 libguile_la_DEPENDENCIES = @LIBLOBJS@
-libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
+libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING)
 libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
 
 # These are headers visible as <guile/mumble.h>
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 5f56b7a29..b4bff8142 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -2657,17 +2657,26 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len,
 	case 'l': case 'L':
 	case 's': case 'S':
 	  idx++;
+          if (idx == len)
+            return SCM_BOOL_F;
+
 	  start = idx;
 	  c = mem[idx];
 	  if (c == '-')
 	    {
 	      idx++;
+              if (idx == len)
+                return SCM_BOOL_F;
+
 	      sign = -1;
 	      c = mem[idx];
 	    }
 	  else if (c == '+')
 	    {
 	      idx++;
+              if (idx == len)
+                return SCM_BOOL_F;
+
 	      sign = 1;
 	      c = mem[idx];
 	    }
@@ -2783,8 +2792,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
 	  SCM divisor;
 
 	  idx++;
+          if (idx == len)
+            return SCM_BOOL_F;
 
-	  divisor = mem2uinteger (mem, len, &idx, radix, &x);
+          divisor = mem2uinteger (mem, len, &idx, radix, &x);
 	  if (scm_is_false (divisor))
 	    return SCM_BOOL_F;
 
@@ -2905,11 +2916,15 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
 	      if (c == '+')
 		{
 		  idx++;
+                  if (idx == len)
+                    return SCM_BOOL_F;
 		  sign = 1;
 		}
 	      else if (c == '-')
 		{
 		  idx++;
+                  if (idx == len)
+                    return SCM_BOOL_F;
 		  sign = -1;
 		}
 	      else
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index dce9b5fbc..0cace147d 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -215,11 +215,37 @@ VM_DEFINE_FUNCTION (120, add, "add", 2)
   FUNC2 (+, scm_sum);
 }
 
+VM_DEFINE_FUNCTION (167, add1, "add1", 1)
+{
+  ARGS1 (x);
+  if (SCM_I_INUMP (x))
+    {
+      scm_t_int64 n = SCM_I_INUM (x) + 1;
+      if (SCM_FIXABLE (n))
+	RETURN (SCM_I_MAKINUM (n));
+    }
+  SYNC_REGISTER ();
+  RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
+}
+
 VM_DEFINE_FUNCTION (121, sub, "sub", 2)
 {
   FUNC2 (-, scm_difference);
 }
 
+VM_DEFINE_FUNCTION (168, sub1, "sub1", 1)
+{
+  ARGS1 (x);
+  if (SCM_I_INUMP (x))
+    {
+      scm_t_int64 n = SCM_I_INUM (x) - 1;
+      if (SCM_FIXABLE (n))
+	RETURN (SCM_I_MAKINUM (n));
+    }
+  SYNC_REGISTER ();
+  RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
+}
+
 VM_DEFINE_FUNCTION (122, mul, "mul", 2)
 {
   ARGS2 (x, y);
@@ -289,7 +315,10 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
                   && i < SCM_I_VECTOR_LENGTH (vect)))
     RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
   else
-    RETURN (scm_vector_ref (vect, idx));
+    {
+      SYNC_REGISTER ();
+      RETURN (scm_vector_ref (vect, idx));
+    }
 }
 
 VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
@@ -303,7 +332,10 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
                   && i < SCM_I_VECTOR_LENGTH (vect)))
     SCM_I_VECTOR_WELTS (vect)[i] = val;
   else
-    scm_vector_set_x (vect, idx, val);
+    {
+      SYNC_REGISTER ();
+      scm_vector_set_x (vect, idx, val);
+    }
   NEXT;
 }
 
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 4536b91da..9604ce55a 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1232,6 +1232,20 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1)
+{
+  SCM x, vect;
+  unsigned int i = FETCH ();
+  i <<= 8;
+  i += FETCH ();
+  POP (vect);
+  /* FIXME CHECK_LOCAL (i) */ 
+  x = LOCAL_REF (i);
+  /* FIXME ASSERT_PROGRAM (x); */
+  SCM_SET_CELL_WORD_3 (x, vect);
+  NEXT;
+}
+
 
 /*
 (defun renumber-ops ()
diff --git a/module/Makefile.am b/module/Makefile.am
index 2971fc6b5..5eec063c2 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -37,11 +37,11 @@ SOURCES =								\
   system/base/message.scm						\
 									\
   language/tree-il.scm							\
-  language/ghil.scm language/glil.scm language/assembly.scm		\
+  language/glil.scm language/assembly.scm				\
 									\
   $(SCHEME_LANG_SOURCES) 						\
   $(TREE_IL_LANG_SOURCES)						\
-  $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES)				\
+  $(GLIL_LANG_SOURCES)							\
   $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES)			\
   $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)				\
 									\
@@ -50,9 +50,10 @@ SOURCES =								\
   $(RNRS_SOURCES)							\
   $(OOP_SOURCES)							\
   $(SYSTEM_SOURCES)                                                     \
+  $(SCRIPTS_SOURCES)                                                    \
+  $(GHIL_LANG_SOURCES)                                                  \
   $(ECMASCRIPT_LANG_SOURCES)						\
-  $(BRAINFUCK_LANG_SOURCES)						\
-  $(SCRIPTS_SOURCES)
+  $(BRAINFUCK_LANG_SOURCES)
 
 ## test.scm is not currently installed.
 EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008
@@ -77,12 +78,14 @@ SCHEME_LANG_SOURCES =						\
 TREE_IL_LANG_SOURCES =						\
   language/tree-il/primitives.scm				\
   language/tree-il/optimize.scm                                 \
+  language/tree-il/inline.scm                                   \
+  language/tree-il/fix-letrec.scm                               \
   language/tree-il/analyze.scm					\
   language/tree-il/compile-glil.scm 				\
   language/tree-il/spec.scm
 
-GHIL_LANG_SOURCES =					\
-  language/ghil/spec.scm language/ghil/compile-glil.scm
+GHIL_LANG_SOURCES =						\
+  language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
 
 GLIL_LANG_SOURCES =						\
   language/glil/spec.scm language/glil/compile-assembly.scm 	\
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index fa5805757..4bd6c4f04 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -251,35 +251,41 @@
      (emit-code
       (if local?
           (if (< index 256)
-              `((,(case op
-                    ((ref) (if boxed? 'local-boxed-ref 'local-ref))
-                    ((set) (if boxed? 'local-boxed-set 'local-set))
-                    ((box) 'box)
-                    ((empty-box) 'empty-box)
-                    (else (error "what" op)))
-                 ,index))
+              (case op
+                ((ref) (if boxed?
+                           `((local-boxed-ref ,index))
+                           `((local-ref ,index))))
+                ((set) (if boxed?
+                           `((local-boxed-set ,index))
+                           `((local-set ,index))))
+                ((box) `((box ,index)))
+                ((empty-box) `((empty-box ,index)))
+                ((fix) `((fix-closure 0 ,index)))
+                (else (error "what" op)))
               (let ((a (quotient i 256))
                     (b (modulo i 256)))
-               `((,(case op
-                     ((ref)
-                      (if boxed?
-                          `((long-local-ref ,a ,b)
-                            (variable-ref))
-                          `((long-local-ref ,a ,b))))
-                     ((set)
-                      (if boxed?
-                          `((long-local-ref ,a ,b)
-                            (variable-set))
-                          `((long-local-set ,a ,b))))
-                     ((box)
-                      `((make-variable)
-                        (variable-set)
-                        (long-local-set ,a ,b)))
-                     ((empty-box)
-                      `((make-variable)
-                        (long-local-set ,a ,b)))
-                     (else (error "what" op)))
-                  ,index))))
+                `((,(case op
+                      ((ref)
+                       (if boxed?
+                           `((long-local-ref ,a ,b)
+                             (variable-ref))
+                           `((long-local-ref ,a ,b))))
+                      ((set)
+                       (if boxed?
+                           `((long-local-ref ,a ,b)
+                             (variable-set))
+                           `((long-local-set ,a ,b))))
+                      ((box)
+                       `((make-variable)
+                         (variable-set)
+                         (long-local-set ,a ,b)))
+                      ((empty-box)
+                       `((make-variable)
+                         (long-local-set ,a ,b)))
+                      ((fix)
+                       `((fix-closure ,a ,b)))
+                      (else (error "what" op)))
+                   ,index))))
           `((,(case op
                 ((ref) (if boxed? 'free-boxed-ref 'free-ref))
                 ((set) (if boxed? 'free-boxed-set (error "what." glil)))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 21aa023a5..df618581f 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -1,6 +1,6 @@
 ;;; Guile Scheme specification
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,7 +20,6 @@
 
 (define-module (language scheme spec)
   #:use-module (system base language)
-  #:use-module (language scheme compile-ghil)
   #:use-module (language scheme compile-tree-il)
   #:use-module (language scheme decompile-tree-il)
   #:export (scheme))
@@ -39,8 +38,7 @@
   #:title	"Guile Scheme"
   #:version	"0.5"
   #:reader	read
-  #:compilers   `((tree-il . ,compile-tree-il)
-                  (ghil . ,compile-ghil))
+  #:compilers   `((tree-il . ,compile-tree-il))
   #:decompilers `((tree-il . ,decompile-tree-il))
   #:evaluator	(lambda (x module) (primitive-eval x))
   #:printer	write
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index aec4eedb9..ad8b73176 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -18,6 +18,7 @@
 
 (define-module (language tree-il)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (system base pmatch)
   #:use-module (system base syntax)
   #:export (tree-il-src
@@ -38,6 +39,7 @@
             <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
             <let> let? make-let let-src let-names let-vars let-vals let-body
             <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
+            <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
             <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
 
             parse-tree-il
@@ -45,6 +47,7 @@
             tree-il->scheme
 
             tree-il-fold
+            make-tree-il-folder
             post-order!
             pre-order!))
 
@@ -65,6 +68,7 @@
   (<lambda> names vars meta body)
   (<let> names vars vals body)
   (<letrec> names vars vals body)
+  (<fix> names vars vals body)
   (<let-values> names vars exp body))
   
 
@@ -141,6 +145,9 @@
      ((letrec ,names ,vars ,vals ,body)
       (make-letrec loc names vars (map retrans vals) (retrans body)))
 
+     ((fix ,names ,vars ,vals ,body)
+      (make-fix loc names vars (map retrans vals) (retrans body)))
+
      ((let-values ,names ,vars ,exp ,body)
       (make-let-values loc names vars (retrans exp) (retrans body)))
 
@@ -197,6 +204,9 @@
     ((<letrec> names vars vals body)
      `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 
+    ((<fix> names vars vals body)
+     `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
     ((<let-values> names vars exp body)
      `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
 
@@ -256,6 +266,10 @@
     ((<letrec> vars vals body)
      `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 
+    ((<fix> vars vals body)
+     ;; not a typo, we really do translate back to letrec
+     `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+
     ((<let-values> vars exp body)
      `(call-with-values (lambda () ,(tree-il->scheme exp))
         (lambda ,vars ,(tree-il->scheme body))))))
@@ -300,11 +314,65 @@ This is an implementation of `foldts' as described by Andy Wingo in
            (up tree (loop body
                           (loop vals
                                 (down tree result)))))
-          ((<let-values> body)
-           (up tree (loop body (down tree result))))
+          ((<fix> vals body)
+           (up tree (loop body
+                          (loop vals
+                                (down tree result)))))
+          ((<let-values> exp body)
+           (up tree (loop body (loop exp (down tree result)))))
           (else
            (leaf tree result))))))
 
+
+(define-syntax make-tree-il-folder
+  (syntax-rules ()
+    ((_ seed ...)
+     (lambda (tree down up seed ...)
+       (define (fold-values proc exps seed ...)
+         (if (null? exps)
+             (values seed ...)
+             (let-values (((seed ...) (proc (car exps) seed ...)))
+               (fold-values proc (cdr exps) seed ...))))
+       (let foldts ((tree tree) (seed seed) ...)
+         (let*-values
+             (((seed ...) (down tree seed ...))
+              ((seed ...)
+               (record-case tree
+                 ((<lexical-set> exp)
+                  (foldts exp seed ...))
+                 ((<module-set> exp)
+                  (foldts exp seed ...))
+                 ((<toplevel-set> exp)
+                  (foldts exp seed ...))
+                 ((<toplevel-define> exp)
+                  (foldts exp seed ...))
+                 ((<conditional> test then else)
+                  (let*-values (((seed ...) (foldts test seed ...))
+                                ((seed ...) (foldts then seed ...)))
+                    (foldts else seed ...)))
+                 ((<application> proc args)
+                  (let-values (((seed ...) (foldts proc seed ...)))
+                    (fold-values foldts args seed ...)))
+                 ((<sequence> exps)
+                  (fold-values foldts exps seed ...))
+                 ((<lambda> body)
+                  (foldts body seed ...))
+                 ((<let> vals body)
+                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                    (foldts body seed ...)))
+                 ((<letrec> vals body)
+                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                    (foldts body seed ...)))
+                 ((<fix> vals body)
+                  (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+                    (foldts body seed ...)))
+                 ((<let-values> exp body)
+                  (let*-values (((seed ...) (foldts exp seed ...)))
+                    (foldts body seed ...)))
+                 (else
+                  (values seed ...)))))
+           (up tree seed ...)))))))
+
 (define (post-order! f x)
   (let lp ((x x))
     (record-case x
@@ -343,6 +411,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
        (set! (letrec-vals x) (map lp vals))
        (set! (letrec-body x) (lp body)))
       
+      ((<fix> vars vals body)
+       (set! (fix-vals x) (map lp vals))
+       (set! (fix-body x) (lp body)))
+      
       ((<let-values> vars exp body)
        (set! (let-values-exp x) (lp exp))
        (set! (let-values-body x) (lp body)))
@@ -390,6 +462,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
          (set! (letrec-vals x) (map lp vals))
          (set! (letrec-body x) (lp body)))
 
+        ((<fix> vars vals body)
+         (set! (fix-vals x) (map lp vals))
+         (set! (fix-body x) (lp body)))
+
         ((<let-values> vars exp body)
          (set! (let-values-exp x) (lp exp))
          (set! (let-values-body x) (lp body)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 1b39b2dd4..b93a0bd7e 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -78,6 +78,25 @@
 ;; in a vector. Each closure variable has a unique index into that
 ;; vector.
 ;;
+;; There is one more complication. Procedures bound by <fix> may, in
+;; some cases, be rendered inline to their parent procedure. That is to
+;; say,
+;;
+;;  (letrec ((lp (lambda () (lp)))) (lp))
+;;    => (fix ((lp (lambda () (lp)))) (lp))
+;;      => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
+;;         ^ jump over the loop  ^ the fixpoint lp ^ starting off the loop
+;;
+;; The upshot is that we don't have to allocate any space for the `lp'
+;; closure at all, as it can be rendered inline as a loop. So there is
+;; another kind of allocation, "label allocation", in which the
+;; procedure is simply a label, placed at the start of the lambda body.
+;; The label is the gensym under which the lambda expression is bound.
+;;
+;; The analyzer checks to see that the label is called with the correct
+;; number of arguments. Calls to labels compile to rename + goto.
+;; Lambda, the ultimate goto!
+;;
 ;;
 ;; The return value of `analyze-lexicals' is a hash table, the
 ;; "allocation".
@@ -88,15 +107,17 @@
 ;; in many procedures, it is a two-level map.
 ;;
 ;; The allocation also stored information on how many local variables
-;; need to be allocated for each procedure, and information on what free
-;; variables to capture from its lexical parent procedure.
+;; need to be allocated for each procedure, lexicals that have been
+;; translated into labels, and information on what free variables to
+;; capture from its lexical parent procedure.
 ;;
 ;; That is:
 ;;
 ;;  sym -> {lambda -> address}
-;;  lambda -> (nlocs . free-locs)
+;;  lambda -> (nlocs labels . free-locs)
 ;;
-;; address := (local? boxed? . index)
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda-vars) ...)
 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
 ;; free variable addresses are relative to parent proc.
 
@@ -108,32 +129,52 @@
 (define (analyze-lexicals x)
   ;; bound-vars: lambda -> (sym ...)
   ;;  all identifiers bound within a lambda
+  (define bound-vars (make-hash-table))
   ;; free-vars: lambda -> (sym ...)
   ;;  all identifiers referenced in a lambda, but not bound
   ;;  NB, this includes identifiers referenced by contained lambdas
+  (define free-vars (make-hash-table))
   ;; assigned: sym -> #t
   ;;  variables that are assigned
+  (define assigned (make-hash-table))
   ;; refcounts: sym -> count
   ;;  allows us to detect the or-expansion in O(1) time
-  
+  (define refcounts (make-hash-table))
+  ;; labels: sym -> lambda-vars
+  ;;  for determining if fixed-point procedures can be rendered as
+  ;;  labels. lambda-vars may be an improper list.
+  (define labels (make-hash-table))
+
   ;; returns variables referenced in expr
-  (define (analyze! x proc)
-    (define (step y) (analyze! y proc))
-    (define (recur x new-proc) (analyze! x new-proc))
+  (define (analyze! x proc labels-in-proc tail? tail-call-args)
+    (define (step y) (analyze! y proc labels-in-proc #f #f))
+    (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
+    (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
+                                              (and tail? args)))
+    (define (recur/labels x new-proc labels)
+      (analyze! x new-proc (append labels labels-in-proc) #t #f))
+    (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
     (record-case x
       ((<application> proc args)
-       (apply lset-union eq? (step proc) (map step args)))
+       (apply lset-union eq? (step-tail-call proc args)
+              (map step args)))
 
       ((<conditional> test then else)
-       (lset-union eq? (step test) (step then) (step else)))
+       (lset-union eq? (step test) (step-tail then) (step-tail else)))
 
       ((<lexical-ref> name gensym)
        (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+       (if (not (and tail-call-args
+                     (memq gensym labels-in-proc)
+                     (let ((args (hashq-ref labels gensym)))
+                       (and (list? args)
+                            (= (length args) (length tail-call-args))))))
+           (hashq-set! labels gensym #f))
        (list gensym))
       
       ((<lexical-set> name gensym exp)
-       (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
        (hashq-set! assigned gensym #t)
+       (hashq-set! labels gensym #f)
        (lset-adjoin eq? (step exp) gensym))
       
       ((<module-set> mod name public? exp)
@@ -146,7 +187,12 @@
        (step exp))
       
       ((<sequence> exps)
-       (apply lset-union eq? (map step exps)))
+       (let lp ((exps exps) (ret '()))
+         (cond ((null? exps) '())
+               ((null? (cdr exps))
+                (lset-union eq? ret (step-tail (car exps))))
+               (else
+                (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
       
       ((<lambda> vars meta body)
        (let ((locally-bound (let rev* ((vars vars) (out '()))
@@ -166,7 +212,7 @@
        (hashq-set! bound-vars proc
                    (append (reverse vars) (hashq-ref bound-vars proc)))
        (lset-difference eq?
-                        (apply lset-union eq? (step body) (map step vals))
+                        (apply lset-union eq? (step-tail body) (map step vals))
                         vars))
       
       ((<letrec> vars vals body)
@@ -174,21 +220,103 @@
                    (append (reverse vars) (hashq-ref bound-vars proc)))
        (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
        (lset-difference eq?
-                        (apply lset-union eq? (step body) (map step vals))
+                        (apply lset-union eq? (step-tail body) (map step vals))
                         vars))
       
-      ((<let-values> vars exp body)
+      ((<fix> vars vals body)
+       ;; Try to allocate these procedures as labels.
+       (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val)))
+                 vars vals)
        (hashq-set! bound-vars proc
-                   (let lp ((out (hashq-ref bound-vars proc)) (in vars))
-                     (if (pair? in)
-                         (lp (cons (car in) out) (cdr in))
-                         (if (null? in) out (cons in out)))))
-       (lset-difference eq?
-                        (lset-union eq? (step exp) (step body))
-                        vars))
+                   (append (reverse vars) (hashq-ref bound-vars proc)))
+       ;; Step into subexpressions.
+       (let* ((var-refs
+               (map
+                ;; Since we're trying to label-allocate the lambda,
+                ;; pretend it's not a closure, and just recurse into its
+                ;; body directly. (Otherwise, recursing on a closure
+                ;; that references one of the fix's bound vars would
+                ;; prevent label allocation.)
+                (lambda (x)
+                  (record-case x
+                    ((<lambda> (lvars vars) body)
+                     (let ((locally-bound
+                            (let rev* ((lvars lvars) (out '()))
+                              (cond ((null? lvars) out)
+                                    ((pair? lvars) (rev* (cdr lvars)
+                                                         (cons (car lvars) out)))
+                                    (else (cons lvars out))))))
+                       (hashq-set! bound-vars x locally-bound)
+                       ;; recur/labels, the difference from the closure case
+                       (let* ((referenced (recur/labels body x vars))
+                              (free (lset-difference eq? referenced locally-bound))
+                              (all-bound (reverse! (hashq-ref bound-vars x))))
+                         (hashq-set! bound-vars x all-bound)
+                         (hashq-set! free-vars x free)
+                         free)))))
+                vals))
+              (vars-with-refs (map cons vars var-refs))
+              (body-refs (recur/labels body proc vars)))
+         (define (delabel-dependents! sym)
+           (let ((refs (assq-ref vars-with-refs sym)))
+             (if refs
+                 (for-each (lambda (sym)
+                             (if (hashq-ref labels sym)
+                                 (begin
+                                   (hashq-set! labels sym #f)
+                                   (delabel-dependents! sym))))
+                           refs))))
+         ;; Stepping into the lambdas and the body might have made some
+         ;; procedures not label-allocatable -- which might have
+         ;; knock-on effects. For example:
+         ;;   (fix ((a (lambda () (b)))
+         ;;         (b (lambda () a)))
+         ;;     (a))
+         ;; As far as `a' is concerned, both `a' and `b' are
+         ;; label-allocatable. But `b' references `a' not in a proc-tail
+         ;; position, which makes `a' not label-allocatable. The
+         ;; knock-on effect is that, when back-propagating this
+         ;; information to `a', `b' will also become not
+         ;; label-allocatable, as it is referenced within `a', which is
+         ;; allocated as a closure. This is a transitive relationship.
+         (for-each (lambda (sym)
+                     (if (not (hashq-ref labels sym))
+                         (delabel-dependents! sym)))
+                   vars)
+         ;; Now lift bound variables with label-allocated lambdas to the
+         ;; parent procedure.
+         (for-each
+          (lambda (sym val)
+            (if (hashq-ref labels sym)
+                ;; Remove traces of the label-bound lambda. The free
+                ;; vars will propagate up via the return val.
+                (begin
+                  (hashq-set! bound-vars proc
+                              (append (hashq-ref bound-vars val)
+                                      (hashq-ref bound-vars proc)))
+                  (hashq-remove! bound-vars val)
+                  (hashq-remove! free-vars val))))
+          vars vals)
+         (lset-difference eq?
+                          (apply lset-union eq? body-refs var-refs)
+                          vars)))
+      
+      ((<let-values> vars exp body)
+       (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
+                      (if (pair? in)
+                          (lp (cons (car in) out) (cdr in))
+                          (if (null? in) out (cons in out))))))
+         (hashq-set! bound-vars proc bound)
+         (lset-difference eq?
+                          (lset-union eq? (step exp) (step-tail body))
+                          bound)))
       
       (else '())))
   
+  ;; allocation: sym -> {lambda -> address}
+  ;;             lambda -> (nlocs labels . free-locs)
+  (define allocation (make-hash-table))
+  
   (define (allocate! x proc n)
     (define (recur y) (allocate! y proc n))
     (record-case x
@@ -237,9 +365,13 @@
              (free-addresses
               (map (lambda (v)
                      (hashq-ref (hashq-ref allocation v) proc))
-                   (hashq-ref free-vars x))))
+                   (hashq-ref free-vars x)))
+             (labels (filter cdr
+                             (map (lambda (sym)
+                                    (cons sym (hashq-ref labels sym)))
+                                  (hashq-ref bound-vars x)))))
          ;; set procedure allocations
-         (hashq-set! allocation x (cons nlocs free-addresses)))
+         (hashq-set! allocation x (cons* nlocs labels free-addresses)))
        n)
 
       ((<let> vars vals body)
@@ -285,29 +417,71 @@
                             `(#t ,(hashq-ref assigned v) . ,n)))
                (lp (cdr vars) (1+ n))))))
 
+      ((<fix> vars vals body)
+       (let lp ((in vars) (n n))
+         (if (null? in)
+             (let lp ((vars vars) (vals vals) (nmax n))
+               (cond
+                ((null? vars)
+                 (max nmax (allocate! body proc n)))
+                ((hashq-ref labels (car vars))                 
+                 ;; allocate label bindings & body inline to proc
+                 (lp (cdr vars)
+                     (cdr vals)
+                     (record-case (car vals)
+                       ((<lambda> vars body)
+                        (let lp ((vars vars) (n n))
+                          (if (not (null? vars))
+                              ;; allocate bindings
+                              (let ((v (if (pair? vars) (car vars) vars)))
+                                (hashq-set!
+                                 allocation v
+                                 (make-hashq
+                                  proc `(#t ,(hashq-ref assigned v) . ,n)))
+                                (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+                              ;; allocate body
+                              (max nmax (allocate! body proc n))))))))
+                (else
+                 ;; allocate closure
+                 (lp (cdr vars)
+                     (cdr vals)
+                     (max nmax (allocate! (car vals) proc n))))))
+             
+             (let ((v (car in)))
+               (cond
+                ((hashq-ref assigned v)
+                 (error "fixpoint procedures may not be assigned" x))
+                ((hashq-ref labels v)
+                 ;; no binding, it's a label
+                 (lp (cdr in) n))
+                (else
+                 ;; allocate closure binding
+                 (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
+                 (lp (cdr in) (1+ n))))))))
+
       ((<let-values> vars exp body)
        (let ((nmax (recur exp)))
          (let lp ((vars vars) (n n))
-           (if (null? vars)
-               (max nmax (allocate! body proc n))
-               (let ((v (if (pair? vars) (car vars) vars)))
-                 (let ((v (car vars)))
-                   (hashq-set!
-                    allocation v
-                    (make-hashq proc
-                                `(#t ,(hashq-ref assigned v) . ,n)))
-                   (lp (cdr vars) (1+ n))))))))
+           (cond
+            ((null? vars)
+             (max nmax (allocate! body proc n)))
+            ((not (pair? vars))
+             (hashq-set! allocation vars
+                         (make-hashq proc
+                                     `(#t ,(hashq-ref assigned vars) . ,n)))
+             ;; the 1+ for this var
+             (max nmax (allocate! body proc (1+ n))))
+            (else               
+             (let ((v (car vars)))
+               (hashq-set!
+                allocation v
+                (make-hashq proc
+                            `(#t ,(hashq-ref assigned v) . ,n)))
+               (lp (cdr vars) (1+ n))))))))
       
       (else n)))
 
-  (define bound-vars (make-hash-table))
-  (define free-vars (make-hash-table))
-  (define assigned (make-hash-table))
-  (define refcounts (make-hash-table))
-  
-  (define allocation (make-hash-table))
-  
-  (analyze! x #f)
+  (analyze! x #f '() #t #f)
   (allocate! x #f 0)
 
   allocation)
@@ -381,6 +555,9 @@
                       ((<letrec> vars names)
                        (make-binding-info (extend vars names) refs
                                           (cons src locs)))
+                      ((<fix> vars names)
+                       (make-binding-info (extend vars names) refs
+                                          (cons src locs)))
                       ((<let-values> vars names)
                        (make-binding-info (extend vars names) refs
                                           (cons src locs)))
@@ -428,6 +605,9 @@
                       ((<letrec> vars)
                        (make-binding-info (shrink vars refs) refs
                                           (cdr locs)))
+                      ((<fix> vars)
+                       (make-binding-info (shrink vars refs) refs
+                                          (cdr locs)))
                       ((<let-values> vars)
                        (make-binding-info (shrink vars refs) refs
                                           (cdr locs)))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index bf4699797..48db6f6c4 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -37,7 +37,7 @@
 
 ;; allocation:
 ;;  sym -> {lambda -> address}
-;;  lambda -> (nlocs . closure-vars)
+;;  lambda -> (nlocs labels . free-locs)
 ;;
 ;; address := (local? boxed? . index)
 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
@@ -66,7 +66,7 @@
 
     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
       (lambda ()
-        (values (flatten-lambda x allocation)
+        (values (flatten-lambda x #f allocation)
                 (and e (cons (car e) (cddr e)))
                 e)))))
 
@@ -85,6 +85,8 @@
    ((>= . 2) . ge?)
    ((+ . 2) . add)
    ((- . 2) . sub)
+   ((1+ . 1) . add1)
+   ((1- . 1) . sub1)
    ((* . 2) . mul)
    ((/ . 2) . div)
    ((quotient . 2) . quo)
@@ -161,10 +163,10 @@
        ids
        vars))
 
+;; FIXME: always emit? otherwise it's hard to pair bind with unbind
 (define (emit-bindings src ids vars allocation proc emit-code)
-  (if (pair? vars)
-      (emit-code src (make-glil-bind
-                      (vars->bind-list ids vars allocation proc)))))
+  (emit-code src (make-glil-bind
+                  (vars->bind-list ids vars allocation proc))))
 
 (define (with-output-to-code proc)
   (let ((out '()))
@@ -175,7 +177,7 @@
     (proc emit-code)
     (reverse out)))
 
-(define (flatten-lambda x allocation)
+(define (flatten-lambda x self-label allocation)
   (receive (ids vars nargs nrest)
       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
                (oids '()) (ovars '()) (n 0))
@@ -186,53 +188,67 @@
                 (else (values (reverse (cons ids oids))
                               (reverse (cons vars ovars))
                               (1+ n) 1))))
-    (let ((nlocs (car (hashq-ref allocation x))))
+    (let ((nlocs (car (hashq-ref allocation x)))
+          (labels (cadr (hashq-ref allocation x))))
       (make-glil-program
        nargs nrest nlocs (lambda-meta x)
        (with-output-to-code
         (lambda (emit-code)
+          ;; emit label for self tail calls
+          (if self-label
+              (emit-code #f (make-glil-label self-label)))
           ;; write bindings and source debugging info
-          (emit-bindings #f ids vars allocation x emit-code)
+          (if (not (null? ids))
+              (emit-bindings #f ids vars allocation x emit-code))
           (if (lambda-src x)
               (emit-code #f (make-glil-source (lambda-src x))))
           ;; box args if necessary
           (for-each
            (lambda (v)
              (pmatch (hashq-ref (hashq-ref allocation v) x)
-               ((#t #t . ,n)
-                (emit-code #f (make-glil-lexical #t #f 'ref n))
-                (emit-code #f (make-glil-lexical #t #t 'box n)))))
+                     ((#t #t . ,n)
+                      (emit-code #f (make-glil-lexical #t #f 'ref n))
+                      (emit-code #f (make-glil-lexical #t #t 'box n)))))
            vars)
           ;; and here, here, dear reader: we compile.
-          (flatten (lambda-body x) allocation x emit-code)))))))
+          (flatten (lambda-body x) allocation x self-label
+                   labels emit-code)))))))
 
-(define (flatten x allocation proc emit-code)
+(define (flatten x allocation self self-label fix-labels emit-code)
   (define (emit-label label)
     (emit-code #f (make-glil-label label)))
   (define (emit-branch src inst label)
     (emit-code src (make-glil-branch inst label)))
 
-  ;; LMVRA == "let-values MV return address"
-  (let comp ((x x) (context 'tail) (LMVRA #f))
-    (define (comp-tail tree) (comp tree context LMVRA))
-    (define (comp-push tree) (comp tree 'push #f))
-    (define (comp-drop tree) (comp tree 'drop #f))
-    (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
-
+  ;; RA: "return address"; #f unless we're in a non-tail fix with labels
+  ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
+  (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+    (define (comp-tail tree) (comp tree context RA MVRA))
+    (define (comp-push tree) (comp tree 'push #f #f))
+    (define (comp-drop tree) (comp tree 'drop #f #f))
+    (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
+    (define (comp-fix tree RA) (comp tree context RA MVRA))
+
+    ;; A couple of helpers. Note that if we are in tail context, we
+    ;; won't have an RA.
+    (define (maybe-emit-return)
+      (if RA
+          (emit-branch #f 'br RA)
+          (if (eq? context 'tail)
+              (emit-code #f (make-glil-call 'return 1)))))
+    
     (record-case x
       ((<void>)
        (case context
-         ((push vals) (emit-code #f (make-glil-void)))
-         ((tail)
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((push vals tail)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
 
       ((<const> src exp)
        (case context
-         ((push vals) (emit-code src (make-glil-const exp)))
-         ((tail)
-          (emit-code src (make-glil-const exp))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((push vals tail)
+          (emit-code src (make-glil-const exp))))
+       (maybe-emit-return))
 
       ;; FIXME: should represent sequence as exps tail
       ((<sequence> src exps)
@@ -258,7 +274,7 @@
              ;; drop: (lambda () (apply values '(1 2)) 3)
              ;; push: (lambda () (list (apply values '(10 12)) 1))
              (case context
-               ((drop) (for-each comp-drop args))
+               ((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))))))
@@ -272,12 +288,14 @@
                ((push)
                 (comp-push proc)
                 (for-each comp-push args)
-                (emit-code src (make-glil-call 'apply (1+ (length args)))))
+                (emit-code src (make-glil-call 'apply (1+ (length args))))
+                (maybe-emit-return))
                ((vals)
                 (comp-vals
                  (make-application src (make-primitive-ref #f 'apply)
                                    (cons proc args))
-                 LMVRA))
+                 MVRA)
+                (maybe-emit-return))
                ((drop)
                 ;; Well, shit. The proc might return any number of
                 ;; values (including 0), since it's in a drop context,
@@ -285,8 +303,9 @@
                 ;; mv-call out to our trampoline instead.
                 (comp-drop
                  (make-application src (make-primitive-ref #f 'apply)
-                                   (cons proc args)))))))))
-
+                                   (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)))
@@ -294,11 +313,11 @@
          ;; push: (lambda () (list (values '(10 12)) 1))
          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
          (case context
-           ((drop) (for-each comp-drop args))
+           ((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 LMVRA))
+            (emit-branch src 'br MVRA))
            ((tail)
             (for-each comp-push args)
             (emit-code src (make-glil-call 'return/values (length args))))))
@@ -319,7 +338,8 @@
             (comp-vals
              (make-application src (make-primitive-ref #f 'call-with-values)
                                args)
-             LMVRA))
+             MVRA)
+            (maybe-emit-return))
            (else
             (let ((MV (make-label)) (POST (make-label))
                   (producer (car args)) (consumer (cadr args)))
@@ -336,7 +356,8 @@
                 (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)))))))))
+                            (emit-code #f (make-glil-call 'drop 1)))
+                        (maybe-emit-return)))))))
 
         ((and (primitive-ref? proc)
               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
@@ -350,16 +371,19 @@
              (make-application
               src (make-primitive-ref #f 'call-with-current-continuation)
               args)
-             LMVRA))
+             MVRA)
+            (maybe-emit-return))
            ((push)
             (comp-push (car args))
-            (emit-code src (make-glil-call 'call/cc 1)))
+            (emit-code src (make-glil-call 'call/cc 1))
+            (maybe-emit-return))
            ((drop)
             ;; Crap. Just like `apply' in drop context.
             (comp-drop
              (make-application
               src (make-primitive-ref #f 'call-with-current-continuation)
-              args)))))
+              args))
+            (maybe-emit-return))))
 
         ((and (primitive-ref? proc)
               (or (hash-ref *primcall-ops*
@@ -371,34 +395,74 @@
               (case (instruction-pushes op)
                 ((0)
                  (case context
-                   ((tail) (emit-code #f (make-glil-void))
-                           (emit-code #f (make-glil-call 'return 1)))
-                   ((push vals) (emit-code #f (make-glil-void)))))
+                   ((tail push vals) (emit-code #f (make-glil-void))))
+                 (maybe-emit-return))
                 ((1)
                  (case context
-                   ((tail) (emit-code #f (make-glil-call 'return 1)))
-                   ((drop) (emit-code #f (make-glil-call 'drop 1)))))
+                   ((drop) (emit-code #f (make-glil-call 'drop 1))))
+                 (maybe-emit-return))
                 (else
                  (error "bad primitive op: too many pushes"
                         op (instruction-pushes op))))))
         
+        ;; da capo al fine
+        ((and (lexical-ref? proc)
+              self-label (eq? (lexical-ref-gensym proc) self-label)
+              ;; self-call in tail position is a goto
+              (eq? context 'tail)
+              ;; make sure the arity is right
+              (list? (lambda-vars self))
+              (= (length args) (length (lambda-vars self))))
+         ;; evaluate new values
+         (for-each comp-push args)
+         ;; rename & goto
+         (for-each (lambda (sym)
+                     (pmatch (hashq-ref (hashq-ref allocation sym) self)
+                       ((#t ,boxed? . ,index)
+                        ;; set unboxed, as the proc prelude will box if needed
+                        (emit-code #f (make-glil-lexical #t #f 'set index)))
+                       (,x (error "what" x))))
+                   (reverse (lambda-vars self)))
+         (emit-branch src 'br self-label))
+        
+        ;; lambda, the ultimate goto
+        ((and (lexical-ref? proc)
+              (assq (lexical-ref-gensym proc) fix-labels))
+         ;; evaluate new values, assuming that analyze-lexicals did its
+         ;; job, and that the arity was right
+         (for-each comp-push args)
+         ;; rename
+         (for-each (lambda (sym)
+                     (pmatch (hashq-ref (hashq-ref allocation sym) self)
+                       ((#t #f . ,index)
+                        (emit-code #f (make-glil-lexical #t #f 'set index)))
+                       ((#t #t . ,index)
+                        (emit-code #f (make-glil-lexical #t #t 'box index)))
+                       (,x (error "what" x))))
+                   (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
+         ;; goto!
+         (emit-branch src 'br (lexical-ref-gensym proc)))
+        
         (else
          (comp-push proc)
          (for-each comp-push args)
          (let ((len (length args)))
            (case context
              ((tail) (emit-code src (make-glil-call 'goto/args len)))
-             ((push) (emit-code src (make-glil-call 'call len)))
-             ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA)))
-             ((drop)
-              (let ((MV (make-label)) (POST (make-label)))
-                (emit-code src (make-glil-mv-call len MV))
-                (emit-code #f (make-glil-call 'drop 1))
-                (emit-branch #f 'br POST)
-                (emit-label MV)
-                (emit-code #f (make-glil-mv-bind '() #f))
-                (emit-code #f (make-glil-unbind))
-                (emit-label POST))))))))
+             ((push) (emit-code src (make-glil-call 'call len))
+                     (maybe-emit-return))
+             ((vals) (emit-code src (make-glil-mv-call len MVRA))
+                     (maybe-emit-return))
+             ((drop) (let ((MV (make-label)) (POST (make-label)))
+                       (emit-code src (make-glil-mv-call len MV))
+                       (emit-code #f (make-glil-call 'drop 1))
+                       (emit-branch #f 'br (or RA POST))
+                       (emit-label MV)
+                       (emit-code #f (make-glil-mv-bind '() #f))
+                       (emit-code #f (make-glil-unbind))
+                       (if RA
+                           (emit-branch #f 'br RA)
+                           (emit-label POST)))))))))
 
       ((<conditional> src test then else)
        ;;     TEST
@@ -411,104 +475,93 @@
          (comp-push test)
          (emit-branch src 'br-if-not L1)
          (comp-tail then)
-         (if (not (eq? context 'tail))
+         ;; if there is an RA, comp-tail will cause a jump to it -- just
+         ;; have to clean up here if there is no RA.
+         (if (and (not RA) (not (eq? context 'tail)))
              (emit-branch #f 'br L2))
          (emit-label L1)
          (comp-tail else)
-         (if (not (eq? context 'tail))
+         (if (and (not RA) (not (eq? context 'tail)))
              (emit-label L2))))
-
+      
       ((<primitive-ref> src name)
        (cond
         ((eq? (module-variable (fluid-ref *comp-module*) name)
               (module-variable the-root-module name))
          (case context
-           ((push vals)
-            (emit-code src (make-glil-toplevel 'ref name)))
-           ((tail)
-            (emit-code src (make-glil-toplevel 'ref name))
-            (emit-code #f (make-glil-call 'return 1)))))
+           ((tail push vals)
+            (emit-code src (make-glil-toplevel 'ref name))))
+         (maybe-emit-return))
         (else
          (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
          (case context
-           ((push vals)
-            (emit-code src (make-glil-module 'ref '(guile) name #f)))
-           ((tail)
-            (emit-code src (make-glil-module 'ref '(guile) name #f))
-            (emit-code #f (make-glil-call 'return 1)))))))
+           ((tail push vals)
+            (emit-code src (make-glil-module 'ref '(guile) name #f))))
+         (maybe-emit-return))))
 
       ((<lexical-ref> src name gensym)
        (case context
          ((push vals tail)
-          (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+          (pmatch (hashq-ref (hashq-ref allocation gensym) self)
             ((,local? ,boxed? . ,index)
              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
             (,loc
              (error "badness" x loc)))))
-       (case context
-         ((tail) (emit-code #f (make-glil-call 'return 1)))))
+       (maybe-emit-return))
       
       ((<lexical-set> src name gensym exp)
        (comp-push exp)
-       (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+       (pmatch (hashq-ref (hashq-ref allocation gensym) self)
          ((,local? ,boxed? . ,index)
           (emit-code src (make-glil-lexical local? boxed? 'set index)))
          (,loc
           (error "badness" x loc)))
        (case context
-         ((push vals)
-          (emit-code #f (make-glil-void)))
-         ((tail) 
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
       
       ((<module-ref> src mod name public?)
        (emit-code src (make-glil-module 'ref mod name public?))
        (case context
-         ((drop) (emit-code #f (make-glil-call 'drop 1)))
-         ((tail) (emit-code #f (make-glil-call 'return 1)))))
+         ((drop) (emit-code #f (make-glil-call 'drop 1))))
+       (maybe-emit-return))
       
       ((<module-set> src mod name public? exp)
        (comp-push exp)
        (emit-code src (make-glil-module 'set mod name public?))
        (case context
-         ((push vals)
-          (emit-code #f (make-glil-void)))
-         ((tail) 
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
 
       ((<toplevel-ref> src name)
        (emit-code src (make-glil-toplevel 'ref name))
        (case context
-         ((drop) (emit-code #f (make-glil-call 'drop 1)))
-         ((tail) (emit-code #f (make-glil-call 'return 1)))))
+         ((drop) (emit-code #f (make-glil-call 'drop 1))))
+       (maybe-emit-return))
       
       ((<toplevel-set> src name exp)
        (comp-push exp)
        (emit-code src (make-glil-toplevel 'set name))
        (case context
-         ((push vals)
-          (emit-code #f (make-glil-void)))
-         ((tail) 
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
       
       ((<toplevel-define> src name exp)
        (comp-push exp)
        (emit-code src (make-glil-toplevel 'define name))
        (case context
-         ((push vals)
-          (emit-code #f (make-glil-void)))
-         ((tail) 
-          (emit-code #f (make-glil-void))
-          (emit-code #f (make-glil-call 'return 1)))))
+         ((tail push vals)
+          (emit-code #f (make-glil-void))))
+       (maybe-emit-return))
 
       ((<lambda>)
-       (let ((free-locs (cdr (hashq-ref allocation x))))
+       (let ((free-locs (cddr (hashq-ref allocation x))))
          (case context
            ((push vals tail)
-            (emit-code #f (flatten-lambda x allocation))
+            (emit-code #f (flatten-lambda x #f allocation))
             (if (not (null? free-locs))
                 (begin
                   (for-each
@@ -519,15 +572,14 @@
                        (else (error "what" x loc))))
                    free-locs)
                   (emit-code #f (make-glil-call 'vector (length free-locs)))
-                  (emit-code #f (make-glil-call 'make-closure 2))))
-            (if (eq? context 'tail)
-                (emit-code #f (make-glil-call 'return 1)))))))
+                  (emit-code #f (make-glil-call 'make-closure 2)))))))
+       (maybe-emit-return))
       
       ((<let> src names vars vals body)
        (for-each comp-push vals)
-       (emit-bindings src names vars allocation proc emit-code)
+       (emit-bindings src names vars allocation self emit-code)
        (for-each (lambda (v)
-                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #f . ,n)
                       (emit-code src (make-glil-lexical #t #f 'set n)))
                      ((#t #t . ,n)
@@ -539,15 +591,15 @@
 
       ((<letrec> src names vars vals body)
        (for-each (lambda (v)
-                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #t . ,n)
                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
                      (,loc (error "badness" x loc))))
                  vars)
        (for-each comp-push vals)
-       (emit-bindings src names vars allocation proc emit-code)
+       (emit-bindings src names vars allocation self emit-code)
        (for-each (lambda (v)
-                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #t . ,n)
                       (emit-code src (make-glil-lexical #t #t 'set n)))
                      (,loc (error "badness" x loc))))
@@ -555,6 +607,87 @@
        (comp-tail body)
        (emit-code #f (make-glil-unbind)))
 
+      ((<fix> src names vars vals body)
+       ;; The ideal here is to just render the lambda bodies inline, and
+       ;; wire the code together with gotos. We can do that if
+       ;; analyze-lexicals has determined that a given var has "label"
+       ;; allocation -- which is the case if it is in `fix-labels'.
+       ;;
+       ;; But even for closures that we can't inline, we can do some
+       ;; tricks to avoid heap-allocation for the binding itself. Since
+       ;; we know the vals are lambdas, we can set them to their local
+       ;; var slots first, then capture their bindings, mutating them in
+       ;; place.
+       (let ((RA (if (eq? context 'tail) #f (make-label))))
+         (for-each
+          (lambda (x v)
+            (cond
+             ((hashq-ref allocation x)
+              ;; allocating a closure
+              (emit-code #f (flatten-lambda x v allocation))
+              (if (not (null? (cddr (hashq-ref allocation x))))
+                  ;; Need to make-closure first, but with a temporary #f
+                  ;; free-variables vector, so we are mutating fresh
+                  ;; closures on the heap.
+                  (begin
+                    (emit-code #f (make-glil-const #f))
+                    (emit-code #f (make-glil-call 'make-closure 2))))
+              (pmatch (hashq-ref (hashq-ref allocation v) self)
+                ((#t #f . ,n)
+                 (emit-code src (make-glil-lexical #t #f 'set n)))
+                (,loc (error "badness" x loc))))
+             (else
+              ;; labels allocation: emit label & body, but jump over it
+              (let ((POST (make-label)))
+                (emit-branch #f 'br POST)
+                (emit-label v)
+                ;; we know the lambda vars are a list
+                (emit-bindings #f (lambda-names x) (lambda-vars x)
+                               allocation self emit-code)
+                (if (lambda-src x)
+                    (emit-code #f (make-glil-source (lambda-src x))))
+                (comp-fix (lambda-body x) RA)
+                (emit-code #f (make-glil-unbind))
+                (emit-label POST)))))
+          vals
+          vars)
+         ;; Emit bindings metadata for closures
+         (let ((binds (let lp ((out '()) (vars vars) (names names))
+                        (cond ((null? vars) (reverse! out))
+                              ((assq (car vars) fix-labels)
+                               (lp out (cdr vars) (cdr names)))
+                              (else
+                               (lp (acons (car vars) (car names) out)
+                                   (cdr vars) (cdr names)))))))
+           (emit-bindings src (map cdr binds) (map car binds)
+                          allocation self emit-code))
+         ;; Now go back and fix up the bindings for closures.
+         (for-each
+          (lambda (x v)
+            (let ((free-locs (if (hashq-ref allocation x)
+                                 (cddr (hashq-ref allocation x))
+                                 ;; can hit this latter case for labels allocation
+                                 '())))
+              (if (not (null? free-locs))
+                  (begin
+                    (for-each
+                     (lambda (loc)
+                       (pmatch loc
+                         ((,local? ,boxed? . ,n)
+                          (emit-code #f (make-glil-lexical local? #f 'ref n)))
+                         (else (error "what" x loc))))
+                     free-locs)
+                    (emit-code #f (make-glil-call 'vector (length free-locs)))
+                    (pmatch (hashq-ref (hashq-ref allocation v) self)
+                      ((#t #f . ,n)
+                       (emit-code #f (make-glil-lexical #t #f 'fix n)))
+                      (,loc (error "badness" x loc)))))))
+          vals
+          vars)
+         (comp-tail body)
+         (emit-label RA)
+         (emit-code #f (make-glil-unbind))))
+
       ((<let-values> src names vars exp body)
        (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
          (cond
@@ -571,10 +704,10 @@
              (emit-code #f (make-glil-const 1))
              (emit-label MV)
              (emit-code src (make-glil-mv-bind
-                             (vars->bind-list names vars allocation proc)
+                             (vars->bind-list names vars allocation self)
                              rest?))
              (for-each (lambda (v)
-                         (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                         (pmatch (hashq-ref (hashq-ref allocation v) self)
                            ((#t #f . ,n)
                             (emit-code src (make-glil-lexical #t #f 'set n)))
                            ((#t #t . ,n)
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
new file mode 100644
index 000000000..0ed7b6bab
--- /dev/null
+++ b/module/language/tree-il/fix-letrec.scm
@@ -0,0 +1,180 @@
+;;; transformation of letrec into simpler forms
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il fix-letrec)
+  #:use-module (system base syntax)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (language tree-il)
+  #:use-module (language tree-il primitives)
+  #:export (fix-letrec!))
+
+;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
+;; Efficient Implementation of Scheme’s Recursive Binding Construct", by
+;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
+
+(define fix-fold
+  (make-tree-il-folder unref ref set simple lambda complex))
+
+(define (simple-expression? x bound-vars)
+  (record-case x
+    ((<void>) #t)
+    ((<const>) #t)
+    ((<lexical-ref> gensym)
+     (not (memq gensym bound-vars)))
+    ((<conditional> test then else)
+     (and (simple-expression? test bound-vars)
+          (simple-expression? then bound-vars)
+          (simple-expression? else bound-vars)))
+    ((<sequence> exps)
+     (and-map (lambda (x) (simple-expression? x bound-vars))
+              exps))
+    ((<application> proc args)
+     (and (primitive-ref? proc)
+          (effect-free-primitive? (primitive-ref-name proc))
+          (and-map (lambda (x) (simple-expression? x bound-vars))
+                   args)))
+    (else #f)))
+
+(define (partition-vars x)
+  (let-values
+      (((unref ref set simple lambda* complex)
+        (fix-fold x
+                  (lambda (x unref ref set simple lambda* complex)
+                    (record-case x
+                      ((<lexical-ref> gensym)
+                       (values (delq gensym unref)
+                               (lset-adjoin eq? ref gensym)
+                               set
+                               simple
+                               lambda*
+                               complex))
+                      ((<lexical-set> gensym)
+                       (values unref
+                               ref
+                               (lset-adjoin eq? set gensym)
+                               simple
+                               lambda*
+                               complex))
+                      ((<letrec> vars)
+                       (values (append vars unref)
+                               ref
+                               set
+                               simple
+                               lambda*
+                               complex))
+                      (else
+                       (values unref ref set simple lambda* complex))))
+                  (lambda (x unref ref set simple lambda* complex)
+                    (record-case x
+                      ((<letrec> (orig-vars vars) vals)
+                       (let lp ((vars orig-vars) (vals vals)
+                                (s '()) (l '()) (c '()))
+                         (cond
+                          ((null? vars)
+                           (values unref
+                                   ref
+                                   set
+                                   (append s simple)
+                                   (append l lambda*)
+                                   (append c complex)))
+                          ((memq (car vars) unref)
+                           (lp (cdr vars) (cdr vals)
+                               s l c))
+                          ((memq (car vars) set)
+                           (lp (cdr vars) (cdr vals)
+                               s l (cons (car vars) c)))
+                          ((lambda? (car vals))
+                           (lp (cdr vars) (cdr vals)
+                               s (cons (car vars) l) c))
+                          ((simple-expression? (car vals) orig-vars)
+                           (lp (cdr vars) (cdr vals)
+                               (cons (car vars) s) l c))
+                          (else
+                           (lp (cdr vars) (cdr vals)
+                               s l (cons (car vars) c))))))
+                      (else
+                       (values unref ref set simple lambda* complex))))
+                  '()
+                  '()
+                  '()
+                  '()
+                  '()
+                  '())))
+    (values unref simple lambda* complex)))
+
+(define (fix-letrec! x)
+  (let-values (((unref simple lambda* complex) (partition-vars x)))
+    (post-order!
+     (lambda (x)
+       (record-case x
+
+         ;; Sets to unreferenced variables may be replaced by their
+         ;; expression, called for effect.
+         ((<lexical-set> gensym exp)
+          (if (memq gensym unref)
+              (make-sequence #f (list (make-void #f) exp))
+              x))
+
+         ((<letrec> src names vars vals body)
+          (let ((binds (map list vars names vals)))
+            (define (lookup set)
+              (map (lambda (v) (assq v binds))
+                   (lset-intersection eq? vars set)))
+            (let ((u (lookup unref))
+                  (s (lookup simple))
+                  (l (lookup lambda*))
+                  (c (lookup complex)))
+              ;; Bind "simple" bindings, and locations for complex
+              ;; bindings.
+              (make-let
+               src
+               (append (map cadr s) (map cadr c))
+               (append (map car s) (map car c))
+               (append (map caddr s) (map (lambda (x) (make-void #f)) c))
+               ;; Bind lambdas using the fixpoint operator.
+               (make-fix
+                src (map cadr l) (map car l) (map caddr l)
+                (make-sequence
+                 src
+                 (append
+                  ;; The right-hand-sides of the unreferenced
+                  ;; bindings, for effect.
+                  (map caddr u)
+                  (if (null? c)
+                      ;; No complex bindings, just emit the body.
+                      (list body)
+                      (list
+                       ;; Evaluate the the "complex" bindings, in a `let' to
+                       ;; indicate that order doesn't matter, and bind to
+                       ;; their variables.
+                       (let ((tmps (map (lambda (x) (gensym)) c)))
+                         (make-let
+                          #f (map cadr c) tmps (map caddr c)
+                          (make-sequence
+                           #f
+                           (map (lambda (x tmp)
+                                  (make-lexical-set
+                                   #f (cadr x) (car x)
+                                   (make-lexical-ref #f (cadr x) tmp)))
+                                c tmps))))
+                       ;; Finally, the body.
+                       body)))))))))
+
+         (else x)))
+     x)))
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
new file mode 100644
index 000000000..adc3f18bd
--- /dev/null
+++ b/module/language/tree-il/inline.scm
@@ -0,0 +1,81 @@
+;;; a simple inliner
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il inline)
+  #:use-module (system base syntax)
+  #:use-module (language tree-il)
+  #:export (inline!))
+
+;; Possible optimizations:
+;; * constant folding, propagation
+;; * procedure inlining
+;;   * always when single call site
+;;   * always for "trivial" procs
+;;   * otherwise who knows
+;; * dead code elimination
+;; * degenerate case optimizations
+;; * "fixing letrec"
+
+;; This is a completely brain-dead optimization pass whose sole claim to
+;; fame is ((lambda () x)) => x.
+(define (inline! x)
+  (post-order!
+   (lambda (x)
+     (record-case x
+       ((<application> src proc args)
+        (cond
+
+         ;; ((lambda () x)) => x
+         ((and (lambda? proc) (null? (lambda-vars proc))
+               (null? args))
+          (lambda-body proc))
+
+         ;; (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. Also
+         ;; note that Scheme's let-values expands into call-with-values,
+         ;; then here we reduce it to tree-il's let-values.
+         ((and (primitive-ref? proc)
+               (eq? (primitive-ref-name proc) '@call-with-values)
+               (= (length args) 2)
+               (lambda? (cadr args)))
+          (let ((producer (car args))
+                (consumer (cadr args)))
+            (make-let-values src
+                             (lambda-names consumer)
+                             (lambda-vars consumer)
+                             (if (and (lambda? producer)
+                                      (null? (lambda-names producer)))
+                                 (lambda-body producer)
+                                 (make-application src producer '()))
+                             (lambda-body consumer))))
+
+         (else #f)))
+       
+       ((<let> vars body)
+        (if (null? vars) body x))
+       
+       ((<letrec> vars body)
+        (if (null? vars) body x))
+       
+       ((<fix> vars body)
+        (if (null? vars) body x))
+       
+       (else #f)))
+   x))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index ac16a9e39..0e490a636 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -21,21 +21,15 @@
 (define-module (language tree-il optimize)
   #:use-module (language tree-il)
   #:use-module (language tree-il primitives)
+  #:use-module (language tree-il inline)
+  #:use-module (language tree-il fix-letrec)
   #:export (optimize!))
 
 (define (env-module e)
   (if e (car e) (current-module)))
 
 (define (optimize! x env opts)
-  (expand-primitives! (resolve-primitives! x (env-module env))))
-
-;; Possible optimizations:
-;; * constant folding, propagation
-;; * procedure inlining
-;;   * always when single call site
-;;   * always for "trivial" procs
-;;   * otherwise who knows
-;; * dead code elimination
-;; * degenerate case optimizations
-;; * "fixing letrec"
-
+  (inline!
+   (fix-letrec!
+    (expand-primitives! 
+     (resolve-primitives! x (env-module env))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 9ccd2720d..955c7bf25 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -19,12 +19,13 @@
 ;;; Code:
 
 (define-module (language tree-il primitives)
+  #:use-module (system base pmatch)
   #:use-module (rnrs bytevector)
   #:use-module (system base syntax)
   #:use-module (language tree-il)
   #:use-module (srfi srfi-16)
   #:export (resolve-primitives! add-interesting-primitive!
-            expand-primitives!))
+            expand-primitives! effect-free-primitive?))
 
 (define *interesting-primitive-names* 
   '(apply @apply
@@ -84,6 +85,39 @@
 
 (for-each add-interesting-primitive! *interesting-primitive-names*)
 
+(define *effect-free-primitives*
+  '(values
+    eq? eqv? equal?
+    = < > <= >= zero?
+    + * - / 1- 1+ quotient remainder modulo
+    not
+    pair? null? list? acons cons cons*
+    list vector
+    car cdr
+    caar cadr cdar cddr
+    caaar caadr cadar caddr cdaar cdadr cddar cdddr
+    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+    vector-ref
+    bytevector-u8-ref bytevector-s8-ref
+    bytevector-u16-ref bytevector-u16-native-ref
+    bytevector-s16-ref bytevector-s16-native-ref
+    bytevector-u32-ref bytevector-u32-native-ref
+    bytevector-s32-ref bytevector-s32-native-ref
+    bytevector-u64-ref bytevector-u64-native-ref
+    bytevector-s64-ref bytevector-s64-native-ref
+    bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+    bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+
+
+(define *effect-free-primitive-table* (make-hash-table))
+
+(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
+          *effect-free-primitives*)
+
+(define (effect-free-primitive? prim)
+  (hashq-ref *effect-free-primitive-table* prim))
+
 (define (resolve-primitives! x mod)
   (post-order!
    (lambda (x)
@@ -142,8 +176,14 @@
   (define (consequent exp)
     (cond
      ((pair? exp)
-      `(make-application src (make-primitive-ref src ',(car exp))
-                         ,(inline-args (cdr exp))))
+      (pmatch exp
+        ((if ,test ,then ,else)
+         `(if ,test
+              ,(consequent then)
+              ,(consequent else)))
+        (else
+         `(make-application src (make-primitive-ref src ',(car exp))
+                            ,(inline-args (cdr exp))))))
      ((symbol? exp)
       ;; assume locally bound
       exp)
@@ -160,9 +200,21 @@
                             (cons `((src . ,(car in))
                                     ,(consequent (cadr in))) out)))))))
 
+(define-primitive-expander zero? (x)
+  (= x 0))
+
 (define-primitive-expander +
   () 0
   (x) x
+  (x y) (if (and (const? y)
+                 (let ((y (const-exp y)))
+                   (and (exact? y) (= y 1))))
+            (1+ x)
+            (if (and (const? x)
+                     (let ((x (const-exp x)))
+                       (and (exact? x) (= x 1))))
+                (1+ y)
+                (+ x y)))
   (x y z . rest) (+ x (+ y z . rest)))
   
 (define-primitive-expander *
@@ -172,11 +224,13 @@
   
 (define-primitive-expander -
   (x) (- 0 x)
+  (x y) (if (and (const? y)
+                 (let ((y (const-exp y)))
+                   (and (exact? y) (= y 1))))
+            (1- x)
+            (- x y))
   (x y z . rest) (- x (+ y z . rest)))
   
-(define-primitive-expander 1-
-  (x) (- x 1))
-
 (define-primitive-expander /
   (x) (/ 1 x)
   (x y z . rest) (/ x (* y z . rest)))
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
index c8422eeaf..22bda21a2 100644
--- a/module/srfi/srfi-11.scm
+++ b/module/srfi/srfi-11.scm
@@ -1,6 +1,6 @@
 ;;; srfi-11.scm --- let-values and let*-values
 
-;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -63,148 +63,58 @@
 ;;                 (q <tmp-q>))
 ;;             (baz x y z p q))))))
 
-;; I originally wrote this as a define-macro, but then I found out
-;; that guile's gensym/gentemp was broken, so I tried rewriting it as
-;; a syntax-rules statement.
-;;     [make-symbol now fixes gensym/gentemp problems.]
-;;
-;; Since syntax-rules didn't seem powerful enough to implement
-;; let-values in one definition without exposing illegal syntax (or
-;; perhaps my brain's just not powerful enough :>).  I tried writing
-;; it using a private helper, but that didn't work because the
-;; let-values expands outside the scope of this module.  I wonder why
-;; syntax-rules wasn't designed to allow "private" patterns or
-;; similar...
-;;
-;; So in the end, I dumped the syntax-rules implementation, reproduced
-;; here for posterity, and went with the define-macro one below --
-;; gensym/gentemp's got to be fixed anyhow...
-;
-; (define-syntax let-values-helper
-;   (syntax-rules ()
-;     ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
-;     ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
-;     ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
-;     ;; temps you create so you can use them later...
-;     ;;
-;     ;; I really don't fully understand why the (var-1 var-1) trick
-;     ;; works below, but basically, when all those (x x) bindings show
-;     ;; up in the final "let", syntax-rules forces a renaming.
-
-;     ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
-;         body ...)
-;      (lambda lambda-tmps
-;        (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
-
-;     ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
-;         body ...)
-;      (let-values-helper "consumer"
-;                         (var-2 ...)
-;                         (lambda-tmp ... var-1)
-;                         ((var-1 var-1) . final-let-bindings)
-;                         lv-bindings
-;                         body ...))
-
-;     ((_ "cwv" () final-let-bindings body ...)
-;      (let final-let-bindings
-;          body ...))
-
-;     ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
-;         body ...)
-;      (call-with-values (lambda () binding-1)
-;        (let-values-helper "consumer"
-;                           vars-1
-;                           ()
-;                           final-let-bindings
-;                           (other-bindings ...)
-;                           body ...)))))
-;
-; (define-syntax let-values
-;   (syntax-rules ()
-;     ((let-values () body ...)
-;      (begin body ...))
-;     ((let-values (binding ...) body ...)
-;      (let-values-helper "cwv" (binding ...) () body ...))))
-;
-;
-; (define-syntax let-values
-;   (letrec-syntax ((build-consumer
-;                    ;; Take the vars from one let binding (i.e. the (x
-;                    ;; y z) from ((x y z) (values 1 2 3)) and turn it
-;                    ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
-;                    ;; <tmp-z>) ...) from above.
-;                    (syntax-rules ()
-;                      ((_ () new-tmps tmp-vars () body ...)
-;                       (lambda new-tmps
-;                         body ...))
-;                      ((_ () new-tmps tmp-vars vars body ...)
-;                       (lambda new-tmps
-;                         (lv-builder vars tmp-vars body ...)))
-;                      ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
-;                       (build-consumer (var-2 ...)
-;                                       (tmp-1 . new-tmps)
-;                                       ((var-1 tmp-1) . tmp-vars)
-;                                       bindings
-;                                       body ...))))
-;                   (lv-builder
-;                    (syntax-rules ()
-;                      ((_ () tmp-vars body ...)
-;                       (let tmp-vars
-;                           body ...))
-;                      ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
-;                          tmp-vars
-;                          body ...)
-;                       (call-with-values (lambda () binding-1)
-;                         (build-consumer vars-1
-;                                         ()
-;                                         tmp-vars
-;                                         ((vars-2 binding-2) ...)
-;                                         body ...))))))
-;
-;     (syntax-rules ()
-;       ((_ () body ...)
-;        (begin body ...))
-;       ((_ ((vars binding) ...) body ...)
-;        (lv-builder ((vars binding) ...) () body ...)))))
-
-(define-macro (let-values vars . body)
-
-  (define (map-1-dot proc elts)
-    ;; map over one optionally dotted (a b c . d) list, producing an
-    ;; optionally dotted result.
-    (cond
-     ((null? elts) '())
-     ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
-     (else (proc elts))))
-
-  (define (undot-list lst)
-    ;; produce a non-dotted list from a possibly dotted list.
-    (cond
-     ((null? lst) '())
-     ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
-     (else (list lst))))
-
-  (define (let-values-helper vars body prev-let-vars)
-    (let* ((var-binding (car vars))
-           (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
-                                (car var-binding)))
-           (let-vars (map (lambda (sym tmp) (list sym tmp))
-                          (undot-list (car var-binding))
-                          (undot-list new-tmps))))
-
-      (if (null? (cdr vars))
-          `(call-with-values (lambda () ,(cadr var-binding))
-             (lambda ,new-tmps
-               (let ,(apply append let-vars prev-let-vars)
-                 ,@body)))
-          `(call-with-values (lambda () ,(cadr var-binding))
-             (lambda ,new-tmps
-               ,(let-values-helper (cdr vars) body
-                                   (cons let-vars prev-let-vars)))))))
-
-  (if (null? vars)
-      `(begin ,@body)
-      (let-values-helper vars body '())))
+;; We could really use quasisyntax here...
+(define-syntax let-values
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((binds exp)) b0 b1 ...)
+       (syntax (call-with-values (lambda () exp)
+                 (lambda binds b0 b1 ...))))
+      ((_ (clause ...) b0 b1 ...)
+       (let lp ((clauses (syntax (clause ...)))
+                (ids '())
+                (tmps '()))
+         (if (null? clauses)
+             (with-syntax (((id ...) ids)
+                           ((tmp ...) tmps))
+               (syntax (let ((id tmp) ...)
+                         b0 b1 ...)))
+             (syntax-case (car clauses) ()
+               (((var ...) exp)
+                (with-syntax (((new-tmp ...) (generate-temporaries 
+                                              (syntax (var ...))))
+                              ((id ...) ids)
+                              ((tmp ...) tmps))
+                  (with-syntax ((inner (lp (cdr clauses)
+                                           (syntax (var ... id ...))
+                                           (syntax (new-tmp ... tmp ...)))))
+                    (syntax (call-with-values (lambda () exp)
+                              (lambda (new-tmp ...) inner))))))
+               ((vars exp)
+                (with-syntax ((((new-tmp . new-var) ...)
+                               (let lp ((vars (syntax vars)))
+                                 (syntax-case vars ()
+                                   ((id . rest)
+                                    (acons (syntax id)
+                                           (car
+                                            (generate-temporaries (syntax (id))))
+                                           (lp (syntax rest))))
+                                   (id (acons (syntax id)
+                                              (car
+                                               (generate-temporaries (syntax (id))))
+                                              '())))))
+                              ((id ...) ids)
+                              ((tmp ...) tmps))
+                  (with-syntax ((inner (lp (cdr clauses)
+                                           (syntax (new-var ... id ...))
+                                           (syntax (new-tmp ... tmp ...))))
+                                (args (let lp ((tmps (syntax (new-tmp ...))))
+                                        (syntax-case tmps ()
+                                          ((id) (syntax id))
+                                          ((id . rest) (cons (syntax id)
+                                                             (lp (syntax rest))))))))
+                    (syntax (call-with-values (lambda () exp)
+                              (lambda args inner)))))))))))))
 
 ;;;;;;;;;;;;;;
 ;; let*-values
@@ -226,28 +136,11 @@
 (define-syntax let*-values
   (syntax-rules ()
     ((let*-values () body ...)
-     (begin body ...))
+     (let () body ...))
     ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
      (call-with-values (lambda () binding-1)
        (lambda vars-1
          (let*-values ((vars-2 binding-2) ...)
            body ...))))))
 
-; Alternate define-macro implementation...
-;
-; (define-macro (let*-values vars . body)
-;   (define (let-values-helper vars body)
-;     (let ((var-binding (car vars)))
-;       (if (null? (cdr vars))
-;           `(call-with-values (lambda () ,(cadr var-binding))
-;              (lambda ,(car var-binding)
-;                ,@body))
-;           `(call-with-values (lambda () ,(cadr var-binding))
-;              (lambda ,(car var-binding)
-;                ,(let-values-helper (cdr vars) body))))))
-
-;   (if (null? vars)
-;       `(begin ,@body)
-;       (let-values-helper vars body)))
-
 ;;; srfi-11.scm ends here
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index cc73f38d1..249961d79 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM specific syntaxes and utilities
 
-;; Copyright (C) 2001 Free Software Foundation, Inc
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -174,29 +174,70 @@
 ;;   5.88      0.01      0.01  list-index
 
 
-(define-macro (record-case record . clauses)
-  (let ((r (gensym))
-        (rtd (gensym)))
-    (define (process-clause clause)
-      (if (eq? (car clause) 'else)
-          clause
-          (let ((record-type (caar clause))
-                (slots (cdar clause))
-                (body (cdr clause)))
-            (let ((stem (trim-brackets record-type)))
-              `((eq? ,rtd ,record-type)
-                (let ,(map (lambda (slot)
-                             (if (pair? slot)
-                                 `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
-                                 `(,slot (,(symbol-append stem '- slot) ,r))))
-                           slots)
-                  ,@(if (pair? body) body '((if #f #f)))))))))
-    `(let* ((,r ,record)
-            (,rtd (struct-vtable ,r)))
-       (cond ,@(let ((clauses (map process-clause clauses)))
-                 (if (assq 'else clauses)
-                     clauses
-                     (append clauses `((else (error "unhandled record" ,r))))))))))
+;;; So ugly... but I am too ignorant to know how to make it better.
+(define-syntax record-case
+  (lambda (x)
+    (syntax-case x ()
+      ((_ record clause ...)
+       (let ((r (syntax r))
+             (rtd (syntax rtd)))
+         (define (process-clause tag fields exprs)
+           (let ((infix (trim-brackets (syntax->datum tag))))
+             (with-syntax ((tag tag)
+                           (((f . accessor) ...)
+                            (let lp ((fields fields))
+                              (syntax-case fields ()
+                                (() (syntax ()))
+                                (((v0 f0) f1 ...)
+                                 (acons (syntax v0)
+                                        (datum->syntax x 
+                                                       (symbol-append infix '- (syntax->datum
+                                                                                (syntax f0))))
+                                        (lp (syntax (f1 ...)))))
+                                ((f0 f1 ...)
+                                 (acons (syntax f0)
+                                        (datum->syntax x 
+                                                       (symbol-append infix '- (syntax->datum
+                                                                                (syntax f0))))
+                                        (lp (syntax (f1 ...))))))))
+                           ((e0 e1 ...)
+                            (syntax-case exprs ()
+                              (() (syntax (#t)))
+                              ((e0 e1 ...) (syntax (e0 e1 ...))))))
+               (syntax
+                ((eq? rtd tag)
+                 (let ((f (accessor r))
+                       ...)
+                   e0 e1 ...))))))
+         (with-syntax
+             ((r r)
+              (rtd rtd)
+              ((processed ...)
+               (let lp ((clauses (syntax (clause ...)))
+                        (out '()))
+                 (syntax-case clauses (else)
+                   (()
+                    (reverse! (cons (syntax
+                                     (else (error "unhandled record" r)))
+                                    out)))
+                   (((else e0 e1 ...))
+                    (reverse! (cons (syntax (else e0 e1 ...)) out)))
+                   (((else e0 e1 ...) . rest)
+                    (syntax-violation 'record-case
+                                      "bad else clause placement"
+                                      (syntax x)
+                                      (syntax (else e0 e1 ...))))
+                   ((((<foo> f0 ...) e0 ...) . rest)
+                    (lp (syntax rest)
+                        (cons (process-clause (syntax <foo>)
+                                              (syntax (f0 ...))
+                                              (syntax (e0 ...)))
+                              out)))))))
+           (syntax
+            (let* ((r record)
+                   (rtd (struct-vtable r)))
+              (cond processed ...)))))))))
+
 
 ;; Here we take the terrorism to another level. Nasty, but the client
 ;; code looks good.
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 896206b1f..d993e4ff2 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -72,7 +72,7 @@
    (program 0 0 0 () (const 1) (call return 1)))
   (assert-tree-il->glil
    (apply (primitive +) (void) (const 1))
-   (program 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
+   (program 0 0 0 () (void) (call add1 1) (call return 1))))
 
 (with-test-prefix "application"
   (assert-tree-il->glil