[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-189-g847c835

[Noah Lavine]

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=847c835017954da66375909d15c9266e0d927abf

The branch, wip-rtl-cps has been updated
       via  847c835017954da66375909d15c9266e0d927abf (commit)
      from  20b2833f65cd20044aea40ce547873f453eb29ea (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 847c835017954da66375909d15c9266e0d927abf
Author: Noah Lavine <address@hidden>
Date:   Wed Feb 20 22:03:27 2013 -0500

    CPS Annotator Infrastructure
    
    * module/language/cps/annotate.scm: new function for annotating CPS for
      easy viewing.
    * module/language/cps/allocate.scm: use annotation infrastructure.

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

Summary of changes:
 module/language/cps/allocate.scm |   77 +++++++-------------------------------
 module/language/cps/annotate.scm |   64 +++++++++++++++++++++++++++++++
 2 files changed, 78 insertions(+), 63 deletions(-)
 create mode 100644 module/language/cps/annotate.scm

diff --git a/module/language/cps/allocate.scm b/module/language/cps/allocate.scm
index 22a9d8f..2d09a97 100644
--- a/module/language/cps/allocate.scm
+++ b/module/language/cps/allocate.scm
@@ -2,8 +2,10 @@
   #:use-module (language cps)
   #:use-module (system base syntax) ; for record-case
   #:use-module (srfi srfi-1)
+  #:use-module (ice-9 receive)
+  #:use-module (language cps annotate)
   #:export (allocate-registers-and-labels
-            with-alloc show-alloc))
+            show-regs show-labels))
 
 ;; This function walks some CPS and allocates registers and labels for
 ;; it. It's certainly not optimal yet.
@@ -147,65 +149,14 @@
           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))))
+(define (show-regs cps)
+  (receive (register call-frame-start rest-args-start
+            nlocals label next-label!)
+    (allocate-registers-and-labels cps)
+    (annotate-cps cps register)))
+
+(define (show-labels cps)
+  (receive (register call-frame-start rest-args-start
+            nlocals label next-label!)
+    (allocate-registers-and-labels cps)
+    (annotate-cps cps label)))
diff --git a/module/language/cps/annotate.scm b/module/language/cps/annotate.scm
new file mode 100644
index 0000000..3b83aa4
--- /dev/null
+++ b/module/language/cps/annotate.scm
@@ -0,0 +1,64 @@
+(define-module (language cps annotate)
+  #:use-module (language cps)
+  #:use-module (system base syntax)
+  #:export (annotate-cps))
+
+;; return CPS annotated with the given function. a name n will be
+;; replaced with (cons n (annotator n)). if the annotation is #f, it
+;; won't be shown. use like this at the REPL: ,pp (annotate-cps cps
+;; cool-annotator-function)
+(define (annotate-cps cps annotator)  
+  (define (visit cps)
+    (define (maybe-cons-ann n)
+      (let ((ann (annotator cps)))
+        (if ann
+            (cons n ann)
+            n)))
+    
+    (cond ((symbol? cps)
+           (maybe-cons-ann cps))
+          ((boolean? cps)
+           ;; we get a boolean when we're called on the cont of a call
+           ;; to a letcont continuation, or the rest argument of a lambda.
+           cps)
+          (else
+           (record-case cps
+                        ((<call> proc cont args)
+                         `(,(maybe-cons-ann 'call)
+                           ,(visit proc)
+                           ,(visit cont)
+                           ,(map visit args)))
+                        ((<lambda> names rest body)
+                         `(,(maybe-cons-ann 'lambda)
+                           ,(map visit names)
+                           ,(visit rest)
+                           ,(visit body)))
+                        ((<letval> names vals body)
+                         `(,(maybe-cons-ann 'letval)
+                           ,(map visit names)
+                           ,(map visit vals)
+                           ,(visit body)))
+                        ((<letcont> names conts body)
+                         `(,(maybe-cons-ann 'letcont)
+                           ,(map visit names)
+                           ,(map visit conts)
+                           ,(visit body)))
+                        ((<primitive> name)
+                         `(,(maybe-cons-ann 'primitive)
+                           ,name))
+                        ((<if> test consequent alternate)
+                         `(,(maybe-cons-ann 'if)
+                           ,(visit test)
+                           ,(visit consequent)
+                           ,(visit alternate)))
+                        ((<const> value)
+                         `(,(maybe-cons-ann 'const)
+                           ,value))
+                        ((<var> value)
+                         `(,(maybe-cons-ann 'var)
+                           ,(visit value)))
+                        ((<toplevel-var> name)
+                         `(,(maybe-cons-ann 'toplevel-var)
+                           ,name))))))
+  
+  (visit cps))


hooks/post-receive
-- 
GNU Guile