[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-184-gfa79854

[Mark H Weaver]

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=fa798547e4bc6c687581f937ef6756f1c74f5bf3

The branch, wip-cps-bis has been updated
       via  fa798547e4bc6c687581f937ef6756f1c74f5bf3 (commit)
       via  5c5fdba4b7f3c98002d3c216b02d3dc89e97bbb7 (commit)
      from  b1c738acc774d5125a8f63dcf5bf331eb14a1fcc (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 fa798547e4bc6c687581f937ef6756f1c74f5bf3
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 15 16:25:03 2013 -0400

    RTL Compiler: Fix compilation of basic sequences.
    
    * module/language/cps/slot-allocation.scm: Move the parallel moves into
      a separate hash table.
      (lookup-parallel-moves): Rename table argument to 'moves-table'.
      Use 'hashq-ref' directly instead of 'lookup-allocation'.
      (allocate-slots): Allocate new hash table 'moves-table', use it in
      'parallel-move!', and add it to the list of return values.
    
    * module/language/cps/compile-rtl.scm (emit-rtl-sequence): Accept new
      argument 'moves'.  Pass it to all calls to 'lookup-parallel-moves'.
      (compile-fun): Receive 'moves' from 'allocate-slots', and pass it
      to 'emit-rtl-sequence'.
    
    * test-suite/tests/rtl-compilation.test: Add test.

commit 5c5fdba4b7f3c98002d3c216b02d3dc89e97bbb7
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 15 16:13:04 2013 -0400

    RTL Compiler: add support for 'set-car!' and 'set-cdr!'.
    
    * module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add cases for
      'set-car!' and 'set-cdr!' to 'emit-seq'.

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

Summary of changes:
 module/language/cps/compile-rtl.scm     |   18 +++++++++++-------
 module/language/cps/slot-allocation.scm |   11 ++++++-----
 test-suite/tests/rtl-compilation.test   |   12 ++++++++++++
 3 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 8f2c7ab..bdc1e37 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -103,7 +103,7 @@
 
     (_ seed)))
 
-(define (emit-rtl-sequence exp slots nlocals)
+(define (emit-rtl-sequence exp moves slots nlocals)
   (define (intern-cont! k src cont table)
     (hashq-set! table k cont)
     table)
@@ -144,7 +144,7 @@
           (($ $call proc args)
            (for-each (match-lambda
                       ((src . dst) (emit `(mov ,dst ,src))))
-                     (lookup-parallel-moves label slots))
+                     (lookup-parallel-moves label moves))
            (let ((tail-slots (cdr (iota (1+ (length args))))))
              (for-each maybe-load-constant tail-slots args))
            (emit `(tail-call ,(1+ (length args)))))
@@ -152,7 +152,7 @@
            (let ((tail-slots (cdr (iota (1+ (length args))))))
              (for-each (match-lambda
                         ((src . dst) (emit `(mov ,dst ,src))))
-                       (lookup-parallel-moves label slots))
+                       (lookup-parallel-moves label moves))
              (for-each maybe-load-constant tail-slots args))
            (emit `(return-values ,(length args))))
           (($ $primcall 'return (arg))
@@ -215,7 +215,7 @@
           (($ $values args)
            (for-each (match-lambda
                       ((src . dst) (emit `(mov ,dst ,src))))
-                     (lookup-parallel-moves label slots))
+                     (lookup-parallel-moves label moves))
            (for-each maybe-load-constant (map slot syms) args)))
         (maybe-jump k))
 
@@ -229,6 +229,10 @@
            (emit `(box-set! ,(slot box) ,(slot value))))
           (($ $primcall 'vector-set! (vector index value))
            (emit `(vector-set ,(slot vector) ,(slot index) ,(slot value))))
+          (($ $primcall 'set-car! (pair value))
+           (emit `(set-car! ,(slot pair) ,(slot value))))
+          (($ $primcall 'set-cdr! (pair value))
+           (emit `(set-cdr! ,(slot pair) ,(slot value))))
           (($ $primcall 'define! (sym value))
            (emit `(define ,(slot sym) ,(slot value))))
           (($ $primcall name args)
@@ -285,7 +289,7 @@
                     (emit `(bind-rest ,(+ proc-slot 1 nreq))))
                   (for-each (match-lambda
                              ((src . dst) (emit `(mov ,dst ,src))))
-                            (lookup-parallel-moves label slots))
+                            (lookup-parallel-moves label moves))
                   (emit `(reset-frame ,nlocals)))
                  ((arg . args)
                   (or (maybe-load-constant n arg)
@@ -333,7 +337,7 @@
 
     (define (emit-fun-entry self body alternate)
       (call-with-values (lambda () (allocate-slots self body))
-        (lambda (slots nlocals)
+        (lambda (moves slots nlocals)
           (match body
             (($ $cont src k
                 ($ $kentry ($ $arity req opt rest kw allow-other-keys?) body))
@@ -346,7 +350,7 @@
                                       ,kw-indices ,allow-other-keys?
                                       ,nlocals
                                       ,alternate))
-               (for-each emit (emit-rtl-sequence body slots nlocals))
+               (for-each emit (emit-rtl-sequence body moves slots nlocals))
                (emit `(end-arity))))))))
 
     (define (emit-fun-entries self entries)
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 7aa1122..c66df53 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -119,8 +119,8 @@
     (else
      (error "Continuation not a call" sym))))
 
-(define (lookup-parallel-moves sym allocation)
-  (match (lookup-allocation sym allocation)
+(define (lookup-parallel-moves sym moves-table)
+  (match (hashq-ref moves-table sym)
     (($ $parallel-move moves) moves)
     (else
      (error "Continuation has no parallel moves" sym))))
@@ -215,7 +215,8 @@ are comparable with eqv?.  A tmp slot may be used."
                      ($ $kentry _ ($ $cont _ _ ($ $kargs names syms))))
                   (length syms))))
         (visited (make-hash-table))
-        (allocation (make-hash-table)))
+        (allocation (make-hash-table))
+        (moves-table (make-hash-table)))
     (define (allocate! sym k hint live-set)
       (match (hashq-ref allocation sym)
         (($ $allocation def slot dead has-const)
@@ -257,7 +258,7 @@ are comparable with eqv?.  A tmp slot may be used."
              (moves (solve-parallel-move src-slots dst-slots tmp-slot)))
         (when (and (>= tmp-slot nlocals) (assv tmp-slot moves))
           (set! nlocals (+ tmp-slot 1)))
-        (hashq-set! allocation src-k (make-parallel-move moves))
+        (hashq-set! moves-table src-k (make-parallel-move moves))
         post-live-set))
 
     (let visit ((exp exp)
@@ -368,4 +369,4 @@ are comparable with eqv?.  A tmp slot may be used."
 
         (_ live-set)))
 
-    (values allocation nlocals)))
+    (values moves-table allocation nlocals)))
diff --git a/test-suite/tests/rtl-compilation.test 
b/test-suite/tests/rtl-compilation.test
index ebc6673..778edbd 100644
--- a/test-suite/tests/rtl-compilation.test
+++ b/test-suite/tests/rtl-compilation.test
@@ -79,3 +79,15 @@
 (with-test-prefix "values context"
   1
   )
+
+(with-test-prefix "mixed contexts"
+  (pass-if-equal "sequences" '(3 4 5)
+    (let* ((pair (cons 1 2))
+           (result ((run-rtl '(lambda (pair)
+                                (set-car! pair 3)
+                                (set-cdr! pair 4)
+                                5))
+                    pair)))
+      (list (car pair)
+            (cdr pair)
+            result))))


hooks/post-receive
-- 
GNU Guile