call-with-values can make fewer closures

* module/language/tree-il.scm: Rename let-exp and letrec-exp to let-body
  and letrec-body. Add <let-values>, a one-expression let-values that
  should avoid the needless creation of two closures in many common
  multiple-value cases. We'll need to add an optimization pass to the
  compiler to produce this form, though, as well as rewriting lambdas
  into lets, etc.

  I added this form instead of adding more special cases to the
  call-with-values compile code because it's a useful intermediate form
  -- it will allow the optimizer to perform constant folding across more
  code.

* module/language/tree-il.scm (parse-tree-il, unparse-tree-il)
  (tree-il->scheme, post-order!, pre-order!): Adapt to let/letrec body
  renaming, and let-values.

* module/language/tree-il/analyze.scm (analyze-lexicals): Adapt for
  renaming, and add cases for let-values.

* module/language/tree-il/compile-glil.scm (flatten): Add a new context,
  `vals', used by let-values code for the values producer. Code that
  produces multiple values can then jump to the let-values MV return
  address directly, instead of trampolining into a procedure. Add code to
  compile let-values.

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 3350311..9718920 100644 (file)
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -35,9 +35,10 @@
             <application> application? make-application application-src application-proc application-args
             <sequence> sequence? make-sequence sequence-src sequence-exps
             <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-exp
-            <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp
-
+            <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
+            <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
             unparse-tree-il
             tree-il->scheme
@@ -60,8 +61,9 @@
   (<application> proc args)
   (<sequence> exps)
   (<lambda> names vars meta body)
-  (<let> names vars vals exp)
-  (<letrec> names vars vals exp))
+  (<let> names vars vals body)
+  (<letrec> names vars vals body)
+  (<let-values> names vars exp body))
   
 \f
 
@@ -128,11 +130,14 @@
      ((begin . ,exps)
       (make-sequence loc (map retrans exps)))
 
-     ((let ,names ,vars ,vals ,exp)
-      (make-let loc names vars (map retrans vals) (retrans exp)))
+     ((let ,names ,vars ,vals ,body)
+      (make-let loc names vars (map retrans vals) (retrans body)))
+
+     ((letrec ,names ,vars ,vals ,body)
+      (make-letrec loc names vars (map retrans vals) (retrans body)))
 
-     ((letrec ,names ,vars ,vals ,exp)
-      (make-letrec loc names vars (map retrans vals) (retrans exp)))
+     ((let-values ,names ,vars ,exp ,body)
+      (make-let-values loc names vars (retrans exp) (retrans body)))
 
      (else
       (error "unrecognized tree-il" exp)))))
@@ -181,140 +186,120 @@
     ((<sequence> exps)
      `(begin ,@(map unparse-tree-il exps)))
 
-    ((<let> names vars vals exp)
-     `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
+    ((<let> names vars vals body)
+     `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 
-    ((<letrec> names vars vals exp)
-     `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))))
+    ((<letrec> names vars vals body)
+     `(letrec ,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)))))
 
 (define (tree-il->scheme e)
-  (cond ((list? e)
-         (map tree-il->scheme e))
-        ((pair? e)
-         (cons (tree-il->scheme (car e))
-               (tree-il->scheme (cdr e))))
-        ((record? e)
-         (record-case e
-           ((<void>)
-            '(if #f #f))
-
-           ((<application> proc args)
-            `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
-
-           ((<conditional> test then else)
-            (if (void? else)
-                `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
-                `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))))
-
-           ((<primitive-ref> name)
-            name)
-           
-           ((<lexical-ref> name gensym)
-            gensym)
-           
-           ((<lexical-set> name gensym exp)
-            `(set! ,gensym ,(tree-il->scheme exp)))
-           
-           ((<module-ref> mod name public?)
-            `(,(if public? '@ '@@) ,mod ,name))
-           
-           ((<module-set> mod name public? exp)
-            `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
-           
-           ((<toplevel-ref> name)
-            name)
-           
-           ((<toplevel-set> name exp)
-            `(set! ,name ,(tree-il->scheme exp)))
-           
-           ((<toplevel-define> name exp)
-            `(define ,name ,(tree-il->scheme exp)))
-           
-           ((<lambda> vars meta body)
-            `(lambda ,vars
-               ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
-               ,(tree-il->scheme body)))
-           
-           ((<const> exp)
-            (if (and (self-evaluating? exp) (not (vector? exp)))
-                exp
-                (list 'quote exp)))
-           
-           ((<sequence> exps)
-            `(begin ,@(map tree-il->scheme exps)))
-           
-           ((<let> vars vals exp)
-            `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))
-           
-           ((<letrec> vars vals exp)
-            `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))))
-        (else e)))
+  (record-case e
+    ((<void>)
+     '(if #f #f))
+
+    ((<application> proc args)
+     `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+
+    ((<conditional> test then else)
+     (if (void? else)
+         `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
+         `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))))
+
+    ((<primitive-ref> name)
+     name)
+    
+    ((<lexical-ref> name gensym)
+     gensym)
+    
+    ((<lexical-set> name gensym exp)
+     `(set! ,gensym ,(tree-il->scheme exp)))
+    
+    ((<module-ref> mod name public?)
+     `(,(if public? '@ '@@) ,mod ,name))
+    
+    ((<module-set> mod name public? exp)
+     `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
+    
+    ((<toplevel-ref> name)
+     name)
+    
+    ((<toplevel-set> name exp)
+     `(set! ,name ,(tree-il->scheme exp)))
+    
+    ((<toplevel-define> name exp)
+     `(define ,name ,(tree-il->scheme exp)))
+    
+    ((<lambda> vars meta body)
+     `(lambda ,vars
+        ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
+        ,(tree-il->scheme body)))
+    
+    ((<const> exp)
+     (if (and (self-evaluating? exp) (not (vector? exp)))
+         exp
+         (list 'quote exp)))
+    
+    ((<sequence> exps)
+     `(begin ,@(map tree-il->scheme exps)))
+    
+    ((<let> vars vals body)
+     `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+    
+    ((<letrec> vars vals body)
+     `(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))))))
 
 (define (post-order! f x)
   (let lp ((x x))
     (record-case x
-      ((<void>)
-       (or (f x) x))
-
       ((<application> proc args)
        (set! (application-proc x) (lp proc))
-       (set! (application-args x) (map lp args))
-       (or (f x) x))
+       (set! (application-args x) (map lp args)))
 
       ((<conditional> test then else)
        (set! (conditional-test x) (lp test))
        (set! (conditional-then x) (lp then))
-       (set! (conditional-else x) (lp else))
-       (or (f x) x))
-
-      ((<primitive-ref> name)
-       (or (f x) x))
-             
-      ((<lexical-ref> name gensym)
-       (or (f x) x))
-             
+       (set! (conditional-else x) (lp else)))
+      
       ((<lexical-set> name gensym exp)
-       (set! (lexical-set-exp x) (lp exp))
-       (or (f x) x))
-             
-      ((<module-ref> mod name public?)
-       (or (f x) x))
-             
+       (set! (lexical-set-exp x) (lp exp)))
+      
       ((<module-set> mod name public? exp)
-       (set! (module-set-exp x) (lp exp))
-       (or (f x) x))
-
-      ((<toplevel-ref> name)
-       (or (f x) x))
-
+       (set! (module-set-exp x) (lp exp)))
+      
       ((<toplevel-set> name exp)
-       (set! (toplevel-set-exp x) (lp exp))
-       (or (f x) x))
-
+       (set! (toplevel-set-exp x) (lp exp)))
+      
       ((<toplevel-define> name exp)
-       (set! (toplevel-define-exp x) (lp exp))
-       (or (f x) x))
-
+       (set! (toplevel-define-exp x) (lp exp)))
+      
       ((<lambda> vars meta body)
-       (set! (lambda-body x) (lp body))
-       (or (f x) x))
-
-      ((<const> exp)
-       (or (f x) x))
-
+       (set! (lambda-body x) (lp body)))
+      
       ((<sequence> exps)
-       (set! (sequence-exps x) (map lp exps))
-       (or (f x) x))
-
-      ((<let> vars vals exp)
+       (set! (sequence-exps x) (map lp exps)))
+      
+      ((<let> vars vals body)
        (set! (let-vals x) (map lp vals))
-       (set! (let-exp x) (lp exp))
-       (or (f x) x))
-
-      ((<letrec> vars vals exp)
+       (set! (let-body x) (lp body)))
+      
+      ((<letrec> vars vals body)
        (set! (letrec-vals x) (map lp vals))
-       (set! (letrec-exp x) (lp exp))
-       (or (f x) x)))))
+       (set! (letrec-body x) (lp body)))
+      
+      ((<let-values> vars exp body)
+       (set! (let-values-exp x) (lp exp))
+       (set! (let-values-body x) (lp body)))
+      
+      (else #f))
+    
+    (or (f x) x)))
 
 (define (pre-order! f x)
   (let lp ((x x))
@@ -347,13 +332,17 @@
         ((<sequence> exps)
          (set! (sequence-exps x) (map lp exps)))
 
-        ((<let> vars vals exp)
+        ((<let> vars vals body)
          (set! (let-vals x) (map lp vals))
-         (set! (let-exp x) (lp exp)))
+         (set! (let-body x) (lp body)))
 
-        ((<letrec> vars vals exp)
+        ((<letrec> vars vals body)
          (set! (letrec-vals x) (map lp vals))
-         (set! (letrec-exp x) (lp exp)))
+         (set! (letrec-body x) (lp body)))
+
+        ((<let-values> vars exp body)
+         (set! (let-values-exp x) (lp exp))
+         (set! (let-values-body x) (lp body)))
 
         (else #f))
       x)))

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 477f1fc..90843f7 100644 (file)
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -116,17 +116,26 @@
        (recur body x)
        (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
 
-      ((<let> vars vals exp)
+      ((<let> vars vals body)
        (for-each step vals)
        (hashq-set! bindings parent
                    (append (reverse vars) (hashq-ref bindings parent)))
-       (step exp))
+       (step body))
       
-      ((<letrec> vars vals exp)
+      ((<letrec> vars vals body)
        (hashq-set! bindings parent
                    (append (reverse vars) (hashq-ref bindings parent)))
        (for-each step vals)
-       (step exp))
+       (step body))
+
+      ((<let-values> vars exp body)
+       (hashq-set! bindings parent
+                   (let lp ((out (hashq-ref bindings parent)) (in vars))
+                     (if (pair? in)
+                         (lp (cons (car in) out) (cdr in))
+                         (if (null? in) out (cons in out)))))
+       (step exp)
+       (step body))
 
       (else #f)))
 
@@ -174,26 +183,26 @@
                  (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
          n)
 
-        ((<let> vars vals exp)
+        ((<let> vars vals body)
          (let ((nmax (apply max (map recur vals))))
            (cond
             ;; the `or' hack
-            ((and (conditional? exp)
+            ((and (conditional? body)
                   (= (length vars) 1)
                   (let ((v (car vars)))
                     (and (not (hashq-ref heaps v))
                          (= (hashq-ref refcounts v 0) 2)
-                         (lexical-ref? (conditional-test exp))
-                         (eq? (lexical-ref-gensym (conditional-test exp)) v)
-                         (lexical-ref? (conditional-then exp))
-                         (eq? (lexical-ref-gensym (conditional-then exp)) v))))
+                         (lexical-ref? (conditional-test body))
+                         (eq? (lexical-ref-gensym (conditional-test body)) v)
+                         (lexical-ref? (conditional-then body))
+                         (eq? (lexical-ref-gensym (conditional-then body)) v))))
              (hashq-set! allocation (car vars) (cons 'stack n))
              ;; the 1+ for this var
-             (max nmax (1+ n) (allocate! (conditional-else exp) level n)))
+             (max nmax (1+ n) (allocate! (conditional-else body) level n)))
             (else
              (let lp ((vars vars) (n n))
                (if (null? vars)
-                   (max nmax (allocate! exp level n))
+                   (max nmax (allocate! body level n))
                    (let ((v (car vars)))
                      (let ((binder (hashq-ref heaps v)))
                        (hashq-set!
@@ -203,14 +212,14 @@
                             (cons 'stack n)))
                        (lp (cdr vars) (if binder n (1+ n)))))))))))
         
-        ((<letrec> vars vals exp)
+        ((<letrec> vars vals body)
          (let lp ((vars vars) (n n))
            (if (null? vars)
                (let ((nmax (apply max
                                   (map (lambda (x)
                                          (allocate! x level n))
                                        vals))))
-                 (max nmax (allocate! exp level n)))
+                 (max nmax (allocate! body level n)))
                (let ((v (car vars)))
                  (let ((binder (hashq-ref heaps v)))
                    (hashq-set!
@@ -220,6 +229,21 @@
                         (cons 'stack n)))
                    (lp (cdr vars) (if binder n (1+ n))))))))
 
+        ((<let-values> vars exp body)
+         (let ((nmax (recur exp)))
+           (let lp ((vars vars) (n n))
+             (if (null? vars)
+                 (max nmax (allocate! body level n))
+                 (let ((v (if (pair? vars) (car vars) vars)))
+                   (let ((binder (hashq-ref heaps v)))
+                     (hashq-set!
+                      allocation v
+                      (if binder
+                          (cons* 'heap level (allocate-heap! binder))
+                          (cons 'stack n)))
+                     (lp (if (pair? vars) (cdr vars) '())
+                         (if binder n (1+ n)))))))))
+        
         (else n)))
 
   (define parents (make-hash-table))

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 94ace7e..78a841d 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -150,22 +150,24 @@
   (define (emit-branch src inst label)
     (emit-code src (make-glil-branch inst label)))
 
-  (let comp ((x x) (context 'tail))
-    (define (comp-tail tree) (comp tree context))
-    (define (comp-push tree) (comp tree 'push))
-    (define (comp-drop tree) (comp tree 'drop))
+  ;; 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))
 
     (record-case x
       ((<void>)
        (case context
-         ((push) (emit-code #f (make-glil-void)))
+         ((push vals) (emit-code #f (make-glil-void)))
          ((tail)
           (emit-code #f (make-glil-void))
           (emit-code #f (make-glil-call 'return 1)))))
 
       ((<const> src exp)
        (case context
-         ((push) (emit-code src (make-glil-const exp)))
+         ((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)))))
@@ -189,7 +191,7 @@
                (args (cdr args)))
            (cond
             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
-                  (not (eq? context 'push)))
+                  (not (eq? context 'push)) (not (eq? context 'vals)))
              ;; tail: (lambda () (apply values '(1 2)))
              ;; drop: (lambda () (apply values '(1 2)) 3)
              ;; push: (lambda () (list (apply values '(10 12)) 1))
@@ -209,6 +211,11 @@
                 (comp-push proc)
                 (for-each comp-push args)
                 (emit-code src (make-glil-call 'apply (1+ (length args)))))
+               ((vals)
+                (comp-vals
+                 (make-application src (make-primitive-ref #f 'apply)
+                                   (cons proc args))
+                 LMVRA))
                ((drop)
                 ;; Well, shit. The proc might return any number of
                 ;; values (including 0), since it's in a drop context,
@@ -223,11 +230,17 @@
          ;; tail: (lambda () (values '(1 2)))
          ;; drop: (lambda () (values '(1 2)) 3)
          ;; push: (lambda () (list (values '(10 12)) 1))
+         ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
          (case context
            ((drop) (for-each comp-drop args))
+           ((vals)
+            (for-each comp-push args)
+            (emit-code #f (make-glil-const (length args)))
+            (emit-branch src 'br LMVRA))
            ((tail)
             (for-each comp-push args)
             (emit-code src (make-glil-call 'return/values (length args))))))
+        
         ((and (primitive-ref? proc)
               (eq? (primitive-ref-name proc) '@call-with-values)
               (= (length args) 2))
@@ -238,22 +251,30 @@
          ;; goto POST
          ;; MV: [tail-]call/nargs
          ;; POST: (maybe-drop)
-         (let ((MV (make-label)) (POST (make-label))
-               (producer (car args)) (consumer (cadr args)))
-           (comp-push consumer)
-           (comp-push producer)
-           (emit-code src (make-glil-mv-call 0 MV))
-           (case context
-             ((tail) (emit-code src (make-glil-call 'goto/args 1)))
-             (else   (emit-code src (make-glil-call 'call 1))
-                     (emit-branch #f 'br POST)))
-           (emit-label MV)
-           (case context
-             ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
-             (else   (emit-code src (make-glil-call 'call/nargs 0))
-                     (emit-label POST)
-                     (if (eq? context 'drop)
-                         (emit-code #f (make-glil-call 'drop 1)))))))
+         (case context
+           ((vals)
+            ;; Fall back.
+            (comp-vals
+             (make-application src (make-primitive-ref #f 'call-with-values)
+                               args)
+             LMVRA))
+           (else
+            (let ((MV (make-label)) (POST (make-label))
+                  (producer (car args)) (consumer (cadr args)))
+              (comp-push consumer)
+              (comp-push producer)
+              (emit-code src (make-glil-mv-call 0 MV))
+              (case context
+                ((tail) (emit-code src (make-glil-call 'goto/args 1)))
+                (else   (emit-code src (make-glil-call 'call 1))
+                        (emit-branch #f 'br POST)))
+              (emit-label MV)
+              (case context
+                ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
+                (else   (emit-code src (make-glil-call 'call/nargs 0))
+                        (emit-label POST)
+                        (if (eq? context 'drop)
+                            (emit-code #f (make-glil-call 'drop 1)))))))))
 
         ((and (primitive-ref? proc)
               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
@@ -262,6 +283,12 @@
            ((tail)
             (comp-push (car args))
             (emit-code src (make-glil-call 'goto/cc 1)))
+           ((vals)
+            (comp-vals
+             (make-application
+              src (make-primitive-ref #f 'call-with-current-continuation)
+              args)
+             LMVRA))
            ((push)
             (comp-push (car args))
             (emit-code src (make-glil-call 'call/cc 1)))
@@ -282,6 +309,7 @@
               (case context
                 ((tail) (emit-code #f (make-glil-call 'return 1)))
                 ((drop) (emit-code #f (make-glil-call 'drop 1))))))
+
         (else
          (comp-push proc)
          (for-each comp-push args)
@@ -289,6 +317,7 @@
            (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))
@@ -322,7 +351,7 @@
         ((eq? (module-variable (fluid-ref *comp-module*) name)
               (module-variable the-root-module name))
          (case context
-           ((push)
+           ((push vals)
             (emit-code src (make-glil-toplevel 'ref name)))
            ((tail)
             (emit-code src (make-glil-toplevel 'ref name))
@@ -330,7 +359,7 @@
         (else
          (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
          (case context
-           ((push)
+           ((push vals)
             (emit-code src (make-glil-module 'ref '(guile) name #f)))
            ((tail)
             (emit-code src (make-glil-module 'ref '(guile) name #f))
@@ -338,7 +367,7 @@
 
       ((<lexical-ref> src name gensym)
        (case context
-         ((push tail)
+         ((push vals tail)
           (let ((loc (hashq-ref allocation gensym)))
             (case (car loc)
               ((stack)
@@ -361,7 +390,7 @@
                             'set (- level (cadr loc)) (cddr loc))))
            (else (error "badness" x loc))))
        (case context
-         ((push)
+         ((push vals)
           (emit-code #f (make-glil-void)))
          ((tail) 
           (emit-code #f (make-glil-void))
@@ -377,7 +406,7 @@
        (comp-push exp)
        (emit-code src (make-glil-module 'set mod name public?))
        (case context
-         ((push)
+         ((push vals)
           (emit-code #f (make-glil-void)))
          ((tail) 
           (emit-code #f (make-glil-void))
@@ -393,7 +422,7 @@
        (comp-push exp)
        (emit-code src (make-glil-toplevel 'set name))
        (case context
-         ((push)
+         ((push vals)
           (emit-code #f (make-glil-void)))
          ((tail) 
           (emit-code #f (make-glil-void))
@@ -403,7 +432,7 @@
        (comp-push exp)
        (emit-code src (make-glil-toplevel 'define name))
        (case context
-         ((push)
+         ((push vals)
           (emit-code #f (make-glil-void)))
          ((tail) 
           (emit-code #f (make-glil-void))
@@ -411,13 +440,13 @@
 
       ((<lambda>)
        (case context
-         ((push)
+         ((push vals)
           (emit-code #f (flatten-lambda x level allocation)))
          ((tail)
           (emit-code #f (flatten-lambda x level allocation))
           (emit-code #f (make-glil-call 'return 1)))))
 
-      ((<let> src names vars vals exp)
+      ((<let> src names vars vals body)
        (for-each comp-push vals)
        (emit-bindings src names vars allocation emit-code)
        (for-each (lambda (v)
@@ -429,10 +458,10 @@
                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
                        (else (error "badness" x loc)))))
                  (reverse vars))
-       (comp-tail exp)
+       (comp-tail body)
        (emit-code #f (make-glil-unbind)))
 
-      ((<letrec> src names vars vals exp)
+      ((<letrec> src names vars vals body)
        (for-each comp-push vals)
        (emit-bindings src names vars allocation emit-code)
        (for-each (lambda (v)
@@ -444,5 +473,35 @@
                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
                        (else (error "badness" x loc)))))
                  (reverse vars))
-       (comp-tail exp)
-       (emit-code #f (make-glil-unbind))))))
+       (comp-tail body)
+       (emit-code #f (make-glil-unbind)))
+
+      ((<let-values> src names vars exp body)
+       (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
+         (cond
+          ((pair? inames)
+           (lp (cons (car inames) names) (cons (car ivars) vars)
+               (cdr inames) (cdr ivars) #f))
+          ((not (null? inames))
+           (lp (cons inames names) (cons ivars vars) '() '() #t))
+          (else
+           (let ((names (reverse! names))
+                 (vars (reverse! vars))
+                 (MV (make-label)))
+             (comp-vals exp MV)
+             (emit-code #f (make-glil-const 1))
+             (emit-label MV)
+             (emit-code src (make-glil-mv-bind
+                             (vars->bind-list names vars allocation)
+                             rest?))
+             (for-each (lambda (v)
+                         (let ((loc (hashq-ref allocation v)))
+                           (case (car loc)
+                             ((stack)
+                              (emit-code src (make-glil-local 'set (cdr loc))))
+                             ((heap)
+                              (emit-code src (make-glil-external 'set 0 (cddr loc))))
+                             (else (error "badness" x loc)))))
+                       (reverse vars))
+             (comp-tail body)
+             (emit-code #f (make-glil-unbind))))))))))