guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-188-g20b2


From: Noah Lavine
Subject: [Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-188-g20b2833
Date: Wed, 20 Feb 2013 18:15:39 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=20b2833f65cd20044aea40ce547873f453eb29ea

The branch, wip-rtl-cps has been updated
       via  20b2833f65cd20044aea40ce547873f453eb29ea (commit)
       via  fb339dacf27d2da3a22d20502f14cffe9dc9431a (commit)
      from  3a03f6a66c156b712c439cfd93bc18171d7e3793 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 20b2833f65cd20044aea40ce547873f453eb29ea
Author: Noah Lavine <address@hidden>
Date:   Wed Feb 20 13:12:37 2013 -0500

    Split (language cps compile-rtl)
    
    * module/language/cps/compile-rtl.scm: move
      allocate-registers-and-labels to a new module.
    * module/language/cps/allocate.scm: new module for allocation.
    * module/language/cps/spec.scm: removed for redundancy.
    * test-suite/tests/cps.test: adjust.

commit fb339dacf27d2da3a22d20502f14cffe9dc9431a
Author: Noah Lavine <address@hidden>
Date:   Wed Feb 20 11:16:32 2013 -0500

    Compile let to CPS
    
    * module/language/tree-il/compile-cps.scm: support 'let'.
    * test-suite/tests/cps.test: test 'let'.

-----------------------------------------------------------------------

Summary of changes:
 module/language/cps/allocate.scm        |  211 +++++++++++++++++++++++++
 module/language/cps/compile-rtl.scm     |  261 ++++++++-----------------------
 module/language/cps/spec.scm            |   24 ---
 module/language/tree-il/compile-cps.scm |   60 ++++++--
 test-suite/tests/cps.test               |    6 +-
 5 files changed, 331 insertions(+), 231 deletions(-)
 create mode 100644 module/language/cps/allocate.scm
 delete mode 100644 module/language/cps/spec.scm

diff --git a/module/language/cps/allocate.scm b/module/language/cps/allocate.scm
new file mode 100644
index 0000000..22a9d8f
--- /dev/null
+++ b/module/language/cps/allocate.scm
@@ -0,0 +1,211 @@
+(define-module (language cps allocate)
+  #:use-module (language cps)
+  #:use-module (system base syntax) ; for record-case
+  #:use-module (srfi srfi-1)
+  #:export (allocate-registers-and-labels
+            with-alloc show-alloc))
+
+;; This function walks some CPS and allocates registers and labels for
+;; it. It's certainly not optimal yet.
+(define (allocate-registers-and-labels cps)
+  ;; we associate a register number with every CPS value (which will
+  ;; always be a symbol)
+  (define register (make-object-property))
+
+  ;; when we make a call, we need to know where to put the new stack
+  ;; frame. this holds that information.
+  (define call-frame-start (make-object-property))
+
+  ;; when we have a continuation that can accept any number of values,
+  ;; it needs to know where to put them on the stack. this holds that
+  ;; information. TO DO: could this be combined with the previous
+  ;; property?
+  (define rest-args-start (make-object-property))
+
+  ;; this holds the number of registers needed by every 'lambda' form, so we
+  ;; can allocate them with the reserve-locals or
+  ;; assert-nargs-ee/nlocals instructions.
+  (define nlocals (make-object-property))
+
+  ;; and every contination gets a label, so we can jump to it. this is
+  ;; indexed by the names of the continuations, not the actual lambda
+  ;; objects.
+  (define label (make-object-property))
+
+  (define next-label!
+    (let ((label-counter 0))
+      (lambda ()
+        (let ((label
+               (string->symbol
+                (string-append
+                 "l-" (number->string label-counter)))))
+          (set! label-counter (+ label-counter 1))
+          label))))
+
+  ;; visit walks the CPS
+  (define (visit cps counter)
+    ;; counter is the number of registers we've already allocated.
+    (record-case cps
+      ;; call is kind of a weird case, because although it doesn't need
+      ;; any extra registers, the new frame needs to be on top of the
+      ;; stack. so we save the end of the stack in its own property.
+      ((<call>)
+       (set! (call-frame-start cps) counter)
+       counter)
+
+      ((<lambda> names rest body)
+       ;; we can't actually handle continuations with any number of
+       ;; values (except in some special cases), because we wouldn't be
+       ;; able to allocate registers for an subsequent instructions
+       ;; without knowing how many registers this will use. so if we get
+       ;; a rest arg, we remember where the top of the stack is and then
+       ;; emit either a bind-rest or drop-values instruction.
+       (let* ((after-names
+               ;; assign register numbers to each name
+               (fold (lambda (name counter)
+                       (set! (register name) counter)
+                       (1+ counter))
+                     counter names))
+              (total
+               (visit body after-names)))
+         (when rest
+               (set! (rest-args-start rest) total)
+               (set! total (+ total 1)))
+         ;; we reserve one more than whatever number of values we have
+         ;; because we might need an extra space to move values
+         ;; around. see generate-shuffle. this doesn't really feel
+         ;; elegant, but I don't have a better solution right now.
+         (set! (nlocals cps) (+ total 1))))
+      
+      ((<letval> names vals body)
+       ;; allocate the registers
+       (let ((counter
+              (fold
+               (lambda (name counter)
+                 (set! (register name) counter)
+                 (1+ counter))
+               counter names)))
+
+         ;; and visit the body of the letval
+         (visit body counter)))
+      
+      ;; an important scoping point: none of the arguments to any of the
+      ;; <letcont>'s continuations are in scope for any of the other
+      ;; continuations, or the body. therefore, we allocate registers
+      ;; for them independently. (TO DO: if we have a bunch of
+      ;; continuations that are going to call each other recursively, we
+      ;; should try to set up our allocation to avoid unnecessary
+      ;; moves.)
+      ((<letcont> names conts body)
+       ;; allocate labels for the continuations
+       (map (lambda (n)
+              (set! (label n) (next-label!)))
+            names)
+       ;; then allocate registers for all of the continuations and the
+       ;; body. we need to return the maximum of the register numbers
+       ;; used so that whatever procedure we're part of will allocate
+       ;; the right number of registers.
+       (apply max (visit body counter)
+              (map (lambda (c) (visit c counter)) conts)))
+      
+      ;; in a letrec, unlike a letcont, we do have to allocate registers
+      ;; to hold the actual functions, because they could be used as
+      ;; values instead of just as static jump targets. but they can
+      ;; also reference each other, so we should allocate labels for
+      ;; them too.
+      ((<letrec> names funcs body)
+       ;; allocate labels for the functions
+       (map
+        (lambda (name)
+          (set! (label name) (next-label!)))
+        names)
+
+       ;; allocate registers *within* the functions
+       (map (lambda (f) (visit f 0)) funcs)
+
+       ;; and allocate registers for the functions and the body
+       (let ((total
+              (fold
+               (lambda (name counter)
+                 (set! (register name) counter)
+                 (1+ counter))
+               0 names)))
+         (visit body counter)
+         counter))
+      
+      ;; an if has no interesting content, so we don't need to do
+      ;; anything here.
+      ((<if> test consequent alternate)
+       counter)))
+
+  (visit cps 0)
+
+  (values register
+          call-frame-start
+          rest-args-start
+          nlocals
+          label
+          next-label!))
+
+;; show what registers and labels we've allocated where. use this at the
+;; REPL: ,pp (with-alloc cps)
+(define (with-alloc cps register call-frame-start rest-args-start
+                    nlocals label next-label!)
+  (define (with-register s) ;; s must be a symbol
+    (cons s (register s))) ;; (register s) will be #f if we haven't
+                           ;; allocated s.
+
+  
+  (define (do-data v) ;; v is a cps-data object
+    (cond ((var? v)
+           (list 'var (var-value v)))
+          ((toplevel-var? v)
+           (list 'toplevel-var (toplevel-var-name v)))
+          ((const? v)
+           (list 'const (const-value v)))
+          (else
+           (error "Bad cps-data object" v))))
+  
+  (define (with-label s) ;; s must be the name of a continuation
+    (if (eq? s 'return)
+        s
+        (cons s (label s))))
+
+  (define (visit cps)
+    (cond ((symbol? cps)
+           (with-register cps))
+          ((boolean? cps)
+           ;; we get a boolean when with-alloc is called on the cont of a
+           ;; call to a letcont continuation.
+           cps)
+          (else
+           (record-case cps
+                        ((<call> proc cont args)
+                         (cons* 'call
+                                (call-frame-start cps)
+                                (visit proc)
+                                (with-label cont)
+                                (map visit args)))
+                        ((<lambda> names rest body)
+                         `(lambda ,(map with-register names)
+                            ,(cons rest (rest-args-start rest))
+                            ,(visit body)))
+                        ((<letval> names vals body)
+                         `(letval ,(map with-register names)
+                                  ,(map do-data vals)
+                                  ,(visit body)))
+                        ((<letcont> names conts body)
+                         `(letcont ,(map with-label names)
+                                   ,(map visit conts)
+                                   ,(visit body)))
+                        ((<primitive> name)
+                         `(primitive ,name))
+                        ((<if> test consequent alternate)
+                         `(if ,test ,consequent ,alternate))))))
+
+  (visit cps))
+
+(define (show-alloc cps)
+  (call-with-values
+      (lambda () (allocate-registers-and-labels cps))
+    (lambda args (apply with-alloc cps args))))
diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 3a06c99..8491d26 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -1,227 +1,67 @@
 (define-module (language cps compile-rtl)
   #:use-module (language cps)
   #:use-module (language cps primitives)
+  #:use-module (language cps allocate)
   #:use-module (system base syntax) ;; for record-case
   #:use-module (ice-9 match)
   #:use-module (ice-9 q) ;; used in generate-shuffle
   #:use-module (ice-9 receive)
   #:use-module (srfi srfi-1)
-  #:export (cps->rtl allocate-registers-and-labels! with-alloc show-alloc!
-            generate-suffle))
+  #:use-module (system base compile)
+  #:use-module (language tree-il compile-cps)
+  #:use-module (system vm rtl)
+  #:export (cps->rtl generate-shuffle generate-rtl cps-compile))
 
 ;; currently, the only way we have to run RTL code is to package it up
 ;; into a program and call that program. Therefore, all code that we
 ;; compile will look like a lambda expression, maybe with no arguments.
 
-;; we associate a register number with every CPS value (which will
-;; always be a symbol)
-(define register (make-object-property))
-
-;; when we make a call, we need to know where to put the new stack
-;; frame. this holds that information.
-(define call-frame-start (make-object-property))
-
-;; when we have a continuation that can accept any number of values, it
-;; needs to know where to put them on the stack. this holds that
-;; information. TO DO: could this be combined with the previous
-;; property?
-(define rest-args-start (make-object-property))
-
-;; and every contination gets a label, so we can jump to it. this is
-;; indexed by the names of the continuations, not the actual lambda objects.
-(define label (make-object-property))
-(define label-counter 0)
-(define (next-label!)
-  (let ((label
-         (string->symbol
-          (string-append
-           "l-" (number->string label-counter)))))
-    (set! label-counter (+ label-counter 1))
-    label))
-
-;; the name-defn map lets us find the definitions of names bound in
-;; 'let...'  forms. right now it only holds things from 'letval' and
-;; 'letcont' forms, but there's no barrier to adding 'letrec' too. it
-;; might be better to get rid of this and replace names with direct
-;; links to their values, but that's a bigger project.
-
-;; bikeshedding note: what's the correct naming convention here?
-;; "name-defn"? "name->defn"? "definition"? "lookup-defn"?
-(define name-defn (make-object-property))
-
-;; this holds the number of registers needed by every 'lambda' form, so we
-;; can allocate them with the reserve-locals or assert-nargs-ee/nlocals
-;; instructions. this is set by allocate-registers-and-labels!, because
-;; it has all the register information.
-(define nlocals (make-object-property))
-
-;; This function walks some CPS and allocates registers and labels for
-;; it. It's certainly not optimal yet. It also sets the name-defn
-;; property for continuations
-(define (allocate-registers-and-labels! cps)
-  (define (visit cps counter)
-    ;; counter is the number of registers we've already allocated.
+;; This function generates the name-defn property, which lets us look up
+;; the definition of some CPS values. It might be better to get rid of
+;; this and directly link names to their definitions, but that's a
+;; bigger project.
+(define (name-defn-mapping cps)
+  (define name-defn (make-object-property))
+  
+  (define (visit cps)
     (record-case cps
-      ;; call is kind of a weird case, because although it doesn't need
-      ;; any extra registers, the new frame needs to be on top of the
-      ;; stack. so we save the end of the stack in its own property.
-      ((<call>)
-       (set! (call-frame-start cps) counter)
-       counter)
+      ((<call>))
 
       ((<lambda> names rest body)
-       ;; we can't actually handle continuations with any number of
-       ;; values (except in some special cases), because we wouldn't be
-       ;; able to allocate registers for an subsequent instructions
-       ;; without knowing how many registers this will use. so if we get
-       ;; a rest arg, we remember where the top of the stack is and then
-       ;; emit either a bind-rest or drop-values instruction.
-       (let* ((after-names
-               ;; assign register numbers to each name
-               (fold (lambda (name counter)
-                       (set! (register name) counter)
-                       (1+ counter))
-                     counter names))
-              (total
-               (visit body after-names)))
-         (when rest
-               (set! (rest-args-start rest) total)
-               (set! total (+ total 1)))
-         ;; we reserve one more than whatever number of values we have
-         ;; because we might need an extra space to move values
-         ;; around. see generate-shuffle. this doesn't really feel
-         ;; elegant, but I don't have a better solution right now.
-         (set! (nlocals cps) (+ total 1))))
+       (for-each
+        (lambda (n) (set! (name-defn n) cps))
+        names)
+
+       (visit body))
       
       ((<letval> names vals body)
-       ;; update the name-defn mapping
        (map (lambda (n c)
               (set! (name-defn n) c))
             names vals)
 
-       ;; allocate the registers
-       (let ((counter
-              (fold
-               (lambda (name counter)
-                 (set! (register name) counter)
-                 (1+ counter))
-               counter names)))
-
-         ;; and visit the body of the letval
-         (visit body counter)))
+       (visit body))
       
-      ;; an important scoping point: none of the arguments to any of the
-      ;; <letcont>'s continuations are in scope for any of the other
-      ;; continuations, or the body. therefore, we allocate registers
-      ;; for them independently. (TO DO: if we have a bunch of
-      ;; continuations that are going to call each other recursively, we
-      ;; should try to set up our allocation to avoid unnecessary
-      ;; moves.)
       ((<letcont> names conts body)
-       ;; allocate labels for the continuations
-       (map (lambda (n)
-              (set! (label n) (next-label!)))
-            names)
-       ;; update the name-defn mapping
        (map (lambda (n c)
               (set! (name-defn n) c))
             names conts)
-       ;; then allocate registers for all of the continuations and the
-       ;; body. we need to return the maximum of the register numbers
-       ;; used so that whatever procedure we're part of will allocate
-       ;; the right number of registers.
-       (apply max (visit body counter)
-              (map (lambda (c) (visit c counter)) conts)))
+
+       (for-each visit conts)
+       (visit body))
       
-      ;; in a letrec, unlike a letcont, we do have to allocate registers
-      ;; to hold the actual functions, because they could be used as
-      ;; values instead of just as static jump targets. but they can
-      ;; also reference each other, so we should allocate labels for
-      ;; them too.
       ((<letrec> names funcs body)
-       ;; allocate labels for the functions
-       (map
-        (lambda (name)
-          (set! (label name) (next-label!)))
-        names)
-
-       ;; allocate registers *within* the functions
-       (map (lambda (f) (visit f 0)) funcs)
+       (map (lambda (n f)
+              (set! (name-defn n) f))
+            names funcs)
 
-       ;; and allocate registers for the functions and the body
-       (let ((total
-              (fold
-               (lambda (name counter)
-                 (set! (register name) counter)
-                 (1+ counter))
-               0 names)))
-         (visit body counter)
-         counter))
+       (for-each visit funcs)
+       (visit body))
       
-      ;; an if has no interesting content, so we don't need to do
-      ;; anything here.
-      ((<if> test consequent alternate)
-       counter)))
+      ((<if> test consequent alternate))))
 
-  (visit cps 0))
+  (visit cps)
 
-;; show what registers and labels we've allocated where. use this at the
-;; REPL: ,pp (with-alloc cps)
-(define (with-alloc cps)
-  (define (with-register s) ;; s must be a symbol
-    (cons s (register s))) ;; (register s) will be #f if we haven't
-                           ;; allocated s.
-
-  
-  (define (do-data v) ;; v is a cps-data object
-    (cond ((var? v)
-           (list 'var (var-value v)))
-          ((toplevel-var? v)
-           (list 'toplevel-var (toplevel-var-name v)))
-          ((const? v)
-           (list 'const (const-value v)))
-          (else
-           (error "Bad cps-data object" v))))
-  
-  (define (with-label s) ;; s must be the name of a continuation
-    (if (eq? s 'return)
-        s
-        (cons s (label s))))
-
-  (cond ((symbol? cps)
-         (with-register cps))
-        ((boolean? cps)
-         ;; we get a boolean when with-alloc is called on the cont of a
-         ;; call to a letcont continuation.
-         cps)
-        (else
-         (record-case cps
-           ((<call> proc cont args)
-            (cons* 'call
-                   (call-frame-start cps)
-                   (with-alloc proc)
-                   (with-label cont)
-                   (map with-alloc args)))
-           ((<lambda> names rest body)
-            `(lambda ,(map with-register names)
-               ,(cons rest (rest-args-start rest))
-               ,(with-alloc body)))
-           ((<letval> names vals body)
-            `(letval ,(map with-register names)
-                     ,(map do-data vals)
-                     ,(with-alloc body)))
-           ((<letcont> names conts body)
-            `(letcont ,(map with-label names)
-                      ,(map with-alloc conts)
-                      ,(with-alloc body)))
-           ((<primitive> name)
-            `(primitive ,name))
-           ((<if> test consequent alternate)
-            `(if ,test ,consequent ,alternate))))))
-
-(define (show-alloc! cps)
-  (allocate-registers-and-labels! cps)
-  (with-alloc cps))
+  name-defn)
 
 ;; this function should probably be in (ice-9 q)
 (define (append-qs! q r)
@@ -311,9 +151,9 @@
     ;; swap space.
     (apply append (map (lambda (x) (moves-for-chain swap x)) chains))))
 
-;; This is the main function. cps->rtl compiles a cps form into a list
-;; of RTL code.
-(define (cps->rtl cps)
+;; generate-rtl compiles a CPS form to RTL.
+(define (generate-rtl cps name-defn register call-frame-start
+                      rest-args-start nlocals label next-label!)
   ;; generate-primitive-call: generate a call to primitive prim with the
   ;; given args, placing the result in register(s) dsts. rest is either
   ;; #f or the location of the rest arguments of the destination
@@ -494,3 +334,36 @@
           (end-program)))))
 
   (visit cps))
+
+;; this is a wrapper function for the CPS->RTL transformation. Its job
+;; is to know about all of the passes that we do.
+(define (cps->rtl cps)
+  (let ((name-defn (name-defn-mapping cps)))
+    (receive (register
+              call-frame-start
+              rest-args-start
+              nlocals
+              label
+              next-label!)
+      (allocate-registers-and-labels cps)
+      (generate-rtl cps name-defn register
+                    call-frame-start
+                    rest-args-start nlocals
+                    label next-label!))))
+
+;; since CPS isn't complete yet, we don't want to make it part of the
+;; system compiler graph, so we have our own compile function.
+(define* (cps-compile x #:key (from 'scheme) (to 'value))
+  (cond ((eq? from to) x)
+        ((not (memq to '(scheme tree-il cps rtl value)))
+         (error "Unrecognized language" to))
+        (else
+         (case from
+           ((scheme) (cps-compile (compile x #:to 'tree-il)
+                                  #:from 'tree-il #:to to))
+           ((tree-il) (cps-compile (tree-il->cps x)
+                                   #:from 'cps #:to to))
+           ((cps) (cps-compile (cps->rtl x)
+                               #:from 'rtl #:to to))
+           ((rtl) (assemble-program x))
+           (else (error "Unrecognized language" from))))))
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
deleted file mode 100644
index 806c339..0000000
--- a/module/language/cps/spec.scm
+++ /dev/null
@@ -1,24 +0,0 @@
-(define-module (language cps spec)
-  #:use-module (system base compile)
-  #:use-module (language tree-il compile-cps)
-  #:use-module (language cps compile-rtl)
-  #:use-module (system vm rtl)
-  #:export (cps-compile))
-
-;; since CPS isn't complete yet, we don't want to make it part of the
-;; system compiler graph, so we have our own compile function.
-(define* (cps-compile x #:key (from 'scheme) (to 'value))
-  (cond ((eq? from to) x)
-        ((not (memq to '(scheme tree-il cps rtl value)))
-         (error "Unrecognized language" to))
-        (else
-         (case from
-           ((scheme) (cps-compile (compile x #:to 'tree-il)
-                                  #:from 'tree-il #:to to))
-           ((tree-il) (cps-compile (tree-il->cps x)
-                                   #:from 'cps #:to to))
-           ((cps) (allocate-registers-and-labels! x)
-            (cps-compile (cps->rtl x)
-                         #:from 'rtl #:to to))
-           ((rtl) (assemble-program x))
-           (else (error "Unrecognized language" from))))))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 09fb0fc..586614c 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -52,21 +52,50 @@
            (car trees)
            env))))
 
+  ;; the next two are variants on with-value-name and with-value-names
+  ;; in which I know what names I want the values to have, and I just
+  ;; need to wrap them in the appropriate CPS construct. in that case,
+  ;; we don't even need to pass a continuation closure - we just
+  ;; pass in the code to run next.
+  (define (with-value-named next tree name env)
+    (cond ((const? tree)
+           (cps-make-letval
+            (list name)
+            (list (cps-make-const (const-exp tree)))
+            next))
+          (else
+           (let ((con (gensym "con-")))
+             (cps-make-letcont
+              (list con)
+              (list (cps-make-lambda (list name) #f next))
+              (visit con tree env))))))
+
+  (define (with-values-named next trees names env)
+    (if (null? trees)
+        next
+        (with-value-named
+         (with-values-named next (cdr trees) (cdr names) env)
+         (car trees) (car names) env)))
+
   ;; with-variable-boxes generates CPS that makes variable objects for
   ;; the given CPS values and then calls 'gen-k' with a new environment
-  ;; in which the given names are mapped to the names of their boxes.
+  ;; in which the given names are mapped to the names of their boxes. TO
+  ;; DO: let the names that will be in the environment be different than
+  ;; the current CPS names of the values?
   (define (with-variable-boxes gen-k vals env)
-    (let ((var-names (sample (lambda () (gensym "var-"))
-                             (length vals))))
-      (cps-make-letval
-       var-names
-       (map (lambda (var-name val)
-              (cps-make-var val))
-            var-names vals)
-       (gen-k
-        (fold vhash-consq
-              env
-              vals var-names)))))
+    (if (null? vals)
+        (gen-k env)
+        (let ((var-names (sample (lambda () (gensym "var-"))
+                                 (length vals))))
+          (cps-make-letval
+           var-names
+           (map (lambda (var-name val)
+                  (cps-make-var val))
+                var-names vals)
+           (gen-k
+            (fold vhash-consq
+                  env
+                  vals var-names))))))
   
   ;; visit returns a CPS version of tree which ends by calling
   ;; continuation k. 'env' is a vhash that maps Tree-IL variable gensyms
@@ -129,6 +158,13 @@
           (list (cps-make-lambda '() rest
                             (visit k tail env)))
           (visit con head env))))
+      (($ <let> src names gensyms vals exp)
+       (with-values-named
+        (with-variable-boxes
+         (lambda (env)
+           (visit k exp env))
+         gensyms env)
+        vals gensyms env))
       (($ <toplevel-ref> src name)
        (let ((var-name (gensym "var-")))
          (cps-make-letval
diff --git a/test-suite/tests/cps.test b/test-suite/tests/cps.test
index 6bfb34b..fc3d417 100644
--- a/test-suite/tests/cps.test
+++ b/test-suite/tests/cps.test
@@ -1,6 +1,6 @@
 (use-modules
  (test-suite lib)
- (language cps spec))
+ (language cps compile-rtl))
 
 (pass-if "return-three"
   (= 3
@@ -54,6 +54,10 @@
   (= 5
      ((cps-compile '(lambda (x) (set! x 5) x)) 3)))
 
+(pass-if "let"
+  (= 1
+     ((cps-compile '(lambda () (let ((x 1) (y 2)) x))))))
+
 (pass-if "addition"
   (= 7
      ((cps-compile '(lambda () (+ 3 4))))))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]