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.0.5-943-g3f7a


From: Noah Lavine
Subject: [Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.0.5-943-g3f7a14a
Date: Wed, 22 May 2013 03:08:50 +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=3f7a14a4c6518230774c0df14dde33db15dfb253

The branch, wip-rtl-cps has been updated
       via  3f7a14a4c6518230774c0df14dde33db15dfb253 (commit)
       via  af5463addbda9c54a89edcf71ea13608e3749e9e (commit)
       via  d371575dc32a4f7c8c1c0453c24684916791fc17 (commit)
      from  be665ec0fe9f28f13d904a96ee32e691f52b1b01 (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 3f7a14a4c6518230774c0df14dde33db15dfb253
Author: Noah Lavine <address@hidden>
Date:   Sun May 5 01:11:25 2013 -0400

    Module References in CPS
    
    * module/language/cps.scm: new CPS data type 'module-var' lets us
      describe references to module variables; replaces old 'toplevel-var'.
    * module/language/tree-il/compile-cps.scm: generate module-vars.
    * module/language/cps/compile-rtl.scm: generate code for module-vars.
    * test-suite/tests/cps.test: test module-refs.
    * module/language/cps/annotate.scm: adjust.

commit af5463addbda9c54a89edcf71ea13608e3749e9e
Author: Noah Lavine <address@hidden>
Date:   Thu Apr 4 13:00:04 2013 -0400

    More CPS Tests
    
    * test-suite/tests/cps.test: test calls better, and closure sets.

commit d371575dc32a4f7c8c1c0453c24684916791fc17
Author: Noah Lavine <address@hidden>
Date:   Wed Apr 3 18:08:05 2013 -0400

    Clean-ups in CPS compiler
    
    * module/language/cps/compile-rtl.scm: merge some if statements into the
      surrounding (match ...).

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

Summary of changes:
 module/language/cps.scm                 |   21 ++--
 module/language/cps/annotate.scm        |    4 +-
 module/language/cps/compile-rtl.scm     |  182 ++++++++++++++++--------------
 module/language/tree-il/compile-cps.scm |   25 ++++-
 test-suite/tests/cps.test               |   54 ++++++++-
 5 files changed, 183 insertions(+), 103 deletions(-)

diff --git a/module/language/cps.scm b/module/language/cps.scm
index e6e21f5..2bf1122 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -4,7 +4,8 @@
   #:export (<letval> letval? make-letval letval-names letval-vals letval-body
             <const> const? make-const const-value
             <var> var? make-var var-value
-            <toplevel-var> toplevel-var? make-toplevel-var toplevel-var-name
+            <module-var> module-var? make-module-var module-var-module
+                         module-var-name module-var-public?
             <letrec> letrec? make-letrec letrec-names letrec-funcs letrec-body
             <letcont> letcont? make-letcont letcont-names
                       letcont-conts letcont-body
@@ -167,11 +168,15 @@
   ;; in the VM. value is the value it is initialized to. it should be a
   ;; CPS value (which is a symbol).
   (<var> value)
-  ;; toplevel vars are like pseudo-vars. instead of actually creating a
+  ;; module vars are like pseudo-vars. instead of actually creating a
   ;; variable object, we'll just remember that there *is* a variable
   ;; object already in existence and look it up when we need it. we
-  ;; remember the name of the variable so that we can look it up.
-  (<toplevel-var> name))
+  ;; remember the name of the variable so that we can look it up. we
+  ;; also remember the module, which is always a constant value (not
+  ;; bound in a letval- this is an actual list). toplevel-vars are a
+  ;; subset of module vars, where module is the special value
+  ;; 'toplevel. they are always public.
+  (<module-var> module name public?))
 
 (define (parse-cps tree)
   (match tree
@@ -183,8 +188,8 @@
      (make-const value))
     (('var value)
      (make-var value))
-    (('toplevel-var name)
-     (make-toplevel-var name))
+    (('module-var mod name public?)
+     (make-module-var mod name public?))
     (('letrec names funcs body)
      (make-letrec names
                   (map parse-cps funcs)
@@ -215,8 +220,8 @@
      (list 'const value))
     (($ <var> value)
      (list 'var value))
-    (($ <toplevel-var> name)
-     (list 'toplevel-var name))
+    (($ <module-var> mod name public?)
+     (list 'module-var mod name public?))
     (($ <letrec> names funcs body)
      (list 'letrec names
            (map unparse-cps funcs)
diff --git a/module/language/cps/annotate.scm b/module/language/cps/annotate.scm
index 949bfbf..af75bf8 100644
--- a/module/language/cps/annotate.scm
+++ b/module/language/cps/annotate.scm
@@ -67,8 +67,8 @@
                         ((<var> value)
                          `(,(maybe-cons-ann 'var)
                            ,(visit value)))
-                        ((<toplevel-var> name)
-                         `(,(maybe-cons-ann 'toplevel-var)
+                        ((<module-var> mod name public?)
+                         `(,(maybe-cons-ann 'module-var)
                            ,name))))))
   
   (visit cps))
diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 50340b6..69d4f81 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -246,12 +246,11 @@
     ;; (language cps primitives). However, other primitives are
     ;; different, in different ways:
 
-    ;; ref and set need to know if they're handling a toplevel variable
-    ;; or not. I think there's some bad abstraction going on here, but
-    ;; fixing it is hard. The most elegant thing from the CPS point of
-    ;; view is to forget about the toplevel-ref and toplevel-set VM
-    ;; instructions and just use resolve for everything, but that might
-    ;; be slow until we have a tiling code generator.
+    ;; ref and set need to know if they're handling a module variable or
+    ;; not. The most elegant thing from the CPS point of view is to
+    ;; forget about the module-ref and module-set VM instructions and
+    ;; just use resolve for everything, but that might be slow until we
+    ;; have a tiling code generator.
 
     ;; closure-ref needs to know the value of its argument at compile
     ;; time, so it has to look that up in the name-defn table.
@@ -272,13 +271,19 @@
                     (dst (if (pair? dsts)
                              (car dsts)
                              rest)))
-               (if (toplevel-var? var)
+               (if (module-var? var)
                    ;; the scope is 'foo because we don't meaningfully
-                   ;; distinguish scopes yet. we should really just
-                   ;; cache the current module once per procedure.
-                   `((cache-current-module! ,dst foo)
-                     (cached-toplevel-ref ,dst foo
-                                          ,(toplevel-var-name var)))
+                   ;; distinguish scopes yet.
+                   (if (eq? (module-var-module var) 'toplevel)
+                       ;; we should really just cache the current module
+                       ;; once per procedure.
+                       `((cache-current-module! ,dst foo)
+                         (cached-toplevel-ref ,dst foo
+                                              ,(module-var-name var)))
+                       `((cached-module-ref ,dst
+                                            ,(module-var-module var)
+                                            ,(module-var-public? var)
+                                            ,(module-var-name var))))
                    `((box-ref ,dst ,(register var-value))))))
       ((set) (let* ((var-value (car args))
                     (new-value (cadr args))
@@ -286,11 +291,17 @@
                     (dst (if (pair? dsts)
                              (car dsts)
                              rest)))
-               (if (toplevel-var? var)
-                   `((cache-current-module! ,dst foo)
-                     (cached-toplevel-set! ,(register new-value) foo
-                                           ,(toplevel-var-name var))
-                     (mov ,dst ,(register new-value)))
+               (if (module-var? var)
+                   (if (eq? (module-var-module var) 'toplevel)
+                       `((cache-current-module! ,dst foo)
+                         (cached-toplevel-set! ,(register new-value) foo
+                                               ,(module-var-name var))
+                         (mov ,dst ,(register new-value)))
+                       `((cached-module-set! ,(register new-value)
+                                             ,(module-var-module var)
+                                             ,(module-var-public? var)
+                                             ,(module-var-name var))
+                         (mov ,dst ,(register new-value))))
                    `((box-set!
                       ,(register var-value)
                       ,(register new-value))
@@ -341,73 +352,73 @@
        ;; that's the only escaping continuation so far). TO DO: check
        ;; whether proc is a continuation or a real function, and do
        ;; something different if it's a continuation.
+      (($ <call> (? primitive? proc) 'return args)
+       ;; we can't really call primitive procedures in tail position,
+       ;; so we just generate them in non-tail manner and then
+       ;; return. this seems like it might have to change in the
+       ;; future. it's fine to take the maximum register and add one,
+       ;; because the allocator reserved us one extra.
+       
+       ;; note: this only handles primitives that return exactly one
+       ;; value.
+       (let ((return-reg
+              (+ 1 (apply max (map register args)))))
+         `(,@(generate-primitive-call
+              (list return-reg) #f (primitive-name proc) args)
+           (return ,return-reg))))
+
        (($ <call> proc 'return args)
-        (if (primitive? proc)
-            ;; we can't really call primitive procedures in tail
-            ;; position, so we just generate them in non-tail manner and
-            ;; then return. this seems like it might have to change in
-            ;; the future. it's fine to take the maximum register and
-            ;; add one, because the allocator reserved us one extra.
-
-            ;; note: this only handles primitives that return exactly
-            ;; one value.
-            (let ((return-reg
-                   (+ 1 (apply max (map register args)))))
+        (let ((num-args (length args)))
+          ;; the shuffle here includes the procedure that we're going to
+          ;; call, because we don't want to accidentally overwrite
+          ;; it. this is a bit ugly - maybe there should be a better
+          ;; generate-shuffle procedure that knows that some registers
+          ;; are "protected", meaning that their values have to exist
+          ;; after the shuffle, but don't have to end up in any specific
+          ;; target register.
+          (let ((shuffle
+                 (cons (cons (register proc)
+                             (+ num-args 1))
+                       (let iter ((args args)
+                                  (arg-num 0))
+                         (if (null? args)
+                             '()
+                             (cons
+                              (cons (register (car args))
+                                    arg-num)
+                              (iter (cdr args) (+ arg-num 1))))))))
+            `(,@(apply generate-shuffle (+ num-args 2) shuffle)
+              (tail-call ,num-args ,(+ num-args 1))))))
+
+       ;; we use label to check that cont is a continuation (i.e. bound
+       ;; in a letcont form). TO DO: write a real continuation-checking
+       ;; function.
+       (($ <call> proc (? label cont) args)
+        (let* ((dsts (map register (lambda-names (name-defn cont))))
+               (rest (rest-args-start (lambda-rest (name-defn cont))))
+               (return-start (call-frame-start cps))
+               ;; perm is the permutation we have to execute to put
+               ;; the results of the call in their destinations
+               (perm (map cons (int-range return-start
+                                          (+ return-start (length dsts)))
+                          dsts))
+               (perm-label (next-label!)))
+          (if (primitive? proc)
               `(,@(generate-primitive-call
-                   (list return-reg) #f (primitive-name proc) args)
-                (return ,return-reg)))
-            
-            (let ((num-args (length args)))
-              ;; the shuffle here includes the procedure that we're
-              ;; going to call, because we don't want to accidentally
-              ;; overwrite it. this is a bit ugly - maybe there should
-              ;; be a better generate-shuffle procedure that knows that
-              ;; some registers are "protected", meaning that their
-              ;; values have to exist after the shuffle, but don't have
-              ;; to end up in any specific target register.
-              (let ((shuffle
-                     (cons (cons (register proc)
-                                 (+ num-args 1))
-                           (let iter ((args args)
-                                      (arg-num 0))
-                             (if (null? args)
-                                 '()
-                                 (cons
-                                  (cons (register (car args))
-                                        arg-num)
-                                  (iter (cdr args) (+ arg-num 1))))))))
-                `(,@(apply generate-shuffle (+ num-args 2) shuffle)
-                  (tail-call ,num-args ,(+ num-args 1)))))))
-       
-       (($ <call> proc cont args)
-        (if (label cont) ;; a call whose continuation is bound in a
-                         ;; letcont form
-            (let* ((dsts (map register (lambda-names (name-defn cont))))
-                   (rest (rest-args-start (lambda-rest (name-defn cont))))
-                   (return-start (call-frame-start cps))
-                   ;; perm is the permutation we have to execute to put
-                   ;; the results of the call in their destinations
-                   (perm (map cons (int-range return-start
-                                              (+ return-start (length dsts)))
-                              dsts))
-                   (perm-label (next-label!)))
-              (if (primitive? proc)
-                  `(,@(generate-primitive-call
-                       dsts rest (primitive-name proc) args)
-                    (br ,(label cont)))
-                  `((call ,(call-frame-start cps) ,(register proc)
-                          ,(map register args))
-                    ;; shuffle the return values into their place. we
-                    ;; pass #f as our swap point because this
-                    ;; permutation should never need swap space.
-                    (br ,perm-label) ;; MVRA
-                    (br ,perm-label) ;; RA
-                    (label ,perm-label)
-                    ,@(apply generate-shuffle #f perm)
-                    ;; the RA and MVRA both branch to the continuation. we
-                    ;; don't do error checking yet.
-                    (br ,(label cont)))))
-            (error "We don't know how to compile" cps)))
+                   dsts rest (primitive-name proc) args)
+                (br ,(label cont)))
+              `((call ,(call-frame-start cps) ,(register proc)
+                      ,(map register args))
+                ;; shuffle the return values into their place. we
+                ;; pass #f as our swap point because this
+                ;; permutation should never need swap space.
+                (br ,perm-label) ;; MVRA
+                (br ,perm-label) ;; RA
+                (label ,perm-label)
+                ,@(apply generate-shuffle #f perm)
+                ;; the RA and MVRA both branch to the continuation. we
+                ;; don't do error checking yet.
+                (br ,(label cont))))))
        ;; consequent and alternate should both be continuations with no
        ;; arguments, so we call them by just jumping to them.
        (($ <if> test consequent alternate)
@@ -417,14 +428,14 @@
           (br ,(label consequent))))
        (($ <letval> names vals body)
         ;; <letval> values can be either constants, <var>s, or
-        ;; <toplevel-var>s. For constants, we intern a constant. For
-        ;; <var>s, we make a box. For <toplevel-var>s, we do nothing.
+        ;; <module-var>s. For constants, we intern a constant. For
+        ;; <var>s, we make a box. For <module-var>s, we do nothing.
         `(,@(append-map!
              (lambda (name val)
                (cond ((var? val)
                       `((box ,(register name)
                              ,(register (var-value val)))))
-                     ((toplevel-var? val)
+                     ((module-var? val)
                       `())
                      ((const? val)
                       `((load-constant ,(register name)
@@ -452,7 +463,8 @@
         `((begin-program foo)
           (assert-nargs-ee/locals ,(length names) ,(nlocals cps))
           ,@(visit body)
-          (end-program)))))
+          (end-program)))
+       (x (error "We don't know how to compile" x))))
 
   (visit cps))
 
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 5fe48a4..3f38190 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -177,7 +177,16 @@
        (let ((var-name (gensym "var-")))
          (cps-make-letval
           (list var-name)
-          (list (cps-make-toplevel-var name))
+          (list (cps-make-module-var 'toplevel name #t))
+          (cps-make-call
+           (cps-make-primitive 'ref)
+           k
+           (list var-name)))))
+      (($ <module-ref> src mod name public?)
+       (let ((var-name (gensym "var-")))
+         (cps-make-letval
+          (list var-name)
+          (list (cps-make-module-var mod name public?))
           (cps-make-call
            (cps-make-primitive 'ref)
            k
@@ -188,7 +197,19 @@
           (let ((var-name (gensym "var-")))
             (cps-make-letval
              (list var-name)
-             (list (cps-make-toplevel-var name))
+             (list (cps-make-module-var 'toplevel name #t))
+             (cps-make-call
+              (cps-make-primitive 'set)
+              k
+              (list var-name set-val)))))
+        exp env))
+      (($ <module-set> src mod name public? exp)
+       (with-value-name
+        (lambda (set-val)
+          (let ((var-name (gensym "var-")))
+            (cps-make-letval
+             (list var-name)
+             (list (cps-make-module-var mod name public?))
              (cps-make-call
               (cps-make-primitive 'set)
               k
diff --git a/test-suite/tests/cps.test b/test-suite/tests/cps.test
index 0cf1743..417b6b7 100644
--- a/test-suite/tests/cps.test
+++ b/test-suite/tests/cps.test
@@ -1,6 +1,7 @@
 (use-modules
  (test-suite lib)
- (language cps compile-rtl))
+ (language cps compile-rtl)
+ (srfi srfi-8)) ;; receive
 
 (pass-if "return-three"
   (= 3
@@ -50,6 +51,34 @@
   (= 5
      ((cps-compile '(lambda (x) (set! x 5))) 3)))
 
+(pass-if "call 0"
+  (= 0
+     ((cps-compile '(lambda () (+))))))
+
+(pass-if "call 1"
+  (= 1
+     ((cps-compile '(lambda () (+ 1))))))
+
+(pass-if "call 2"
+  (= 3
+     ((cps-compile '(lambda () (+ 1 2))))))
+
+(pass-if "call 3"
+  (= 6
+     ((cps-compile '(lambda () (+ 1 2 3))))))
+
+(pass-if "call 4"
+  (= 10
+     ((cps-compile '(lambda () (+ 1 2 3 4))))))
+
+(pass-if "call 5"
+  (= 15
+     ((cps-compile '(lambda () (+ 1 2 3 4 5))))))
+
+(pass-if "call 6"
+  (= 21
+     ((cps-compile '(lambda () (+ 1 2 3 4 5 6))))))
+
 (pass-if "sequences"
   (= 5
      ((cps-compile '(lambda (x) (set! x 5) x)) 3)))
@@ -58,10 +87,23 @@
   (= 1
      ((cps-compile '(lambda () (let ((x 1) (y 2)) x))))))
 
-(pass-if "addition"
-  (= 7
-     ((cps-compile '(lambda () (+ 3 4))))))
-
-(pass-if "closures"
+(pass-if "closure-ref"
   (= 12
      (((cps-compile '(lambda (x) (lambda () x))) 12))))
+
+(pass-if "closure-ref from let"
+  (= 12
+     (((cps-compile '(lambda () (let ((x 12)) (lambda () x))))))))
+
+(pass-if "closure-set!"
+  (= 12
+     (((cps-compile '(lambda ()
+                       (let ((x 5))
+                         (lambda ()
+                           (set! x 12)
+                           x))))))))
+
+(pass-if "module-ref"
+  (eq? ((cps-compile '(lambda ()
+                      (@ (language cps compile-rtl) cps-compile))))
+       cps-compile))


hooks/post-receive
-- 
GNU Guile



reply via email to

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