[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-219-ge413790

[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=e41379034b93678f2f051685a5f4dfba2ddcf997

The branch, wip-cps-bis has been updated
       via  e41379034b93678f2f051685a5f4dfba2ddcf997 (commit)
       via  49b2835a1784cde0ac49f43b2273e7a499127e0f (commit)
       via  d00630bb2164b4df272503d3a018395f03b9d2eb (commit)
       via  f55ae2be6051822d6b99e9f4fe348539f45fa9d9 (commit)
      from  63026c58cb99c32b29fd86cdb0924608a37b1f9f (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 e41379034b93678f2f051685a5f4dfba2ddcf997
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 22 07:26:50 2013 -0400

    RTL Compiler: Fix 'case-lambda'.
    
    * module/language/tree-il/compile-cps.scm (compile-cps): Canonicalize
      the tree-il before conversion.
    
    * module/language/cps/compile-rtl.scm (emit-fun-entries): Properly adapt
      to recent change in 'case-lambda' representation (alternate -> list of
      entries).
    
    * test-suite/tests/rtl-compilation.test: Add tests.

commit 49b2835a1784cde0ac49f43b2273e7a499127e0f
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 22 07:24:19 2013 -0400

    RTL Compiler: Rewrite 'solve-parallel-move'.
    
    * module/language/cps/slot-allocation.scm (solve-parallel-move):
      Rewrite.
    
    * test-suite/tests/rtl-compilation.test: Add test.

commit d00630bb2164b4df272503d3a018395f03b9d2eb
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 22 07:18:03 2013 -0400

    Adapt rtl.test to 'return-values' instruction changes.
    
    * test-suite/tests/rtl.test ("cached-toplevel-set!"): Adapt to the fact
      that 'return-values' has no operand now, and that 'reset-frame' must
      be done first.

commit f55ae2be6051822d6b99e9f4fe348539f45fa9d9
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 22 07:15:02 2013 -0400

    elisp: accept and ignore the #:to-file? compiler option.
    
    * module/language/elisp/compile-tree-il.scm (process-options!): Accept
      and ignore the #:to-file compiler option.

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

Summary of changes:
 module/language/cps/compile-rtl.scm       |   10 ++--
 module/language/cps/slot-allocation.scm   |   90 ++++++++++++++--------------
 module/language/elisp/compile-tree-il.scm |    2 +-
 module/language/tree-il/compile-cps.scm   |    3 +-
 test-suite/tests/rtl-compilation.test     |   27 +++++++++
 test-suite/tests/rtl.test                 |    3 +-
 6 files changed, 82 insertions(+), 53 deletions(-)

diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 00d6bb1..d3db3ba 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -337,11 +337,11 @@
   (define (emit-fun-entries self entries)
     (match entries
       ((entry . entries)
-       (let ((alternate (match entries
-                          (($cont _ k) k)
-                          (() #f))))
-         (emit-fun-entry self entry alternate)
-         (when alternate
+       (let ((kalternate (and (not (null? entries))
+                              (gensym "kalternate"))))
+         (emit-fun-entry self entry kalternate)
+         (when kalternate
+           (emit-label asm kalternate)
            (emit-fun-entries self entries))))))
 
   (match f
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 535fef8..4e8ebcc 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -128,51 +128,51 @@
 (define (solve-parallel-move src dst tmp)
   "Solve the parallel move problem between src and dst slot lists, which
 are comparable with eqv?.  A tmp slot may be used."
-  ;; A trivial move is a move to a dst that doesn't appear in any src,
-  ;; or an idempotent move.
-  (define (trivial-moves in moves)
-    (let ((orig-moves moves))
-      (let lp ((in in) (in* '()) (moves moves))
-        (match in
-          (() (if (eq? moves orig-moves)
-                  (non-trivial-moves in* moves)
-                  (trivial-moves in* moves)))
-          (((and move (src . dst)) . in)
-           (cond
-            ((eqv? src dst)
-             ;; Idempotent moves.
-             (lp in in* moves))
-            ((not src)
-             ;; The source is a constant and can be loaded directly in
-             ;; place.
-             (lp in in* moves))
-            ((or (assv dst in) (assv dst in*))
-             ;; Non-trivial move.
-             (lp in (cons move in*) moves))
-            (else
-             ;; Trivial move.
-             (lp in in* (cons move moves)))))))))
-  ;; By now, IN contains only strongly connected components.  If it is
-  ;; non-empty, break the cycle using temporary storage for the first
-  ;; item.  Then process all moves to or from that slot, and then solve
-  ;; the remaining parallel move problem.
-  (define (non-trivial-moves in moves)
-    (match in
-      (() (reverse moves))
-      (((and move (dst . cut)) . in)
-       (let lp ((in in) (in* '())
-                (moves (cons* move (cons cut tmp) moves)))
-         (match in
-           (() (trivial-moves in* moves))
-           (((and move (src . dst)) . in)
-            (cond
-             ((eqv? src cut)
-              (lp in in* (acons tmp dst moves)))
-             ((eqv? dst cut)
-              (lp in in* (cons move moves)))
-             (else
-              (lp in (cons move in*) moves)))))))))
-  (trivial-moves (map cons src dst) '()))
+
+  ;; This algorithm is taken from: "Tilting at windmills with Coq:
+  ;; formal verification of a compilation algorithm for parallel moves"
+  ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
+  ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
+
+  (define (split-move moves reg)
+    (let loop ((revhead '()) (tail moves))
+      (match tail
+        (((and s+d (s . d)) . rest)
+         (if (eqv? s reg)
+             (cons d (append-reverse revhead rest))
+             (loop (cons s+d revhead) rest)))
+        (_ #f))))
+
+  (define (replace-last-source reg moves)
+    (match moves
+      ((moves ... (s . d))
+       (append moves (list (cons reg d))))))
+
+  (let loop ((to-move (map cons src dst))
+             (being-moved '())
+             (moved '())
+             (last-source #f))
+    ;; 'last-source' should always be equivalent to:
+    ;; (and (pair? being-moved) (car (last being-moved)))
+    (match being-moved
+      (() (match to-move
+            (() (reverse moved))
+            (((and s+d (s . d)) . t1)
+             (if (or (eqv? s d) ; idempotent
+                     (not s))   ; src is a constant and can be loaded directly
+                 (loop t1 '() moved #f)
+                 (loop t1 (list s+d) moved s)))))
+      (((and s+d (s . d)) . b)
+       (match (split-move to-move d)
+         ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
+         (#f (match b
+               (() (loop to-move '() (cons s+d moved) #f))
+               (_ (if (eqv? d last-source)
+                      (loop to-move
+                            (replace-last-source tmp b)
+                            (cons s+d (acons d tmp moved))
+                            tmp)
+                      (loop to-move b (cons s+d moved) last-source))))))))))
 
 ;; allocation := $allocation | $call-allocation | $parallel-move
 ;; sym, term -> (hash-table of sym -> allocation)
diff --git a/module/language/elisp/compile-tree-il.scm 
b/module/language/elisp/compile-tree-il.scm
index c0b5f88..baa6b2a 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -792,7 +792,7 @@
           (let ((key (car opt))
                 (value (cadr opt)))
             (case key
-              ((#:warnings)             ; ignore
+              ((#:warnings #:to-file?)  ; ignore
                #f)
               (else (report-error #f
                                   "Invalid compiler option"
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 304b211..9a8aa03 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -30,6 +30,7 @@
   #:use-module (language cps primitives)
   #:use-module (language tree-il analyze)
   #:use-module (language tree-il optimize)
+  #:use-module (language tree-il canonicalize)
   #:use-module ((language tree-il)
                 #:select
                 (<void>
@@ -551,7 +552,7 @@ indicates that the replacement variable is in a box."
   (optimize x e opts))
 
 (define (compile-cps exp env opts)
-  (values (cps-convert/thunk (optimize-tree-il exp env opts))
+  (values (cps-convert/thunk (canonicalize (optimize-tree-il exp env opts)))
           env
           env))
 
diff --git a/test-suite/tests/rtl-compilation.test 
b/test-suite/tests/rtl-compilation.test
index 0b1e283..cf00a4f 100644
--- a/test-suite/tests/rtl-compilation.test
+++ b/test-suite/tests/rtl-compilation.test
@@ -114,6 +114,10 @@
   (pass-if-equal '(1 2)
       (call-with-values (lambda () (run-rtl '(values 1 2))) list))
 
+  (pass-if-equal 28
+      ((run-rtl '(lambda (x y z rest) (apply + x y z rest)))
+       2 3 5 '(7 11)))
+
   ;; prompts
   )
 
@@ -156,6 +160,29 @@
                              (even? x)))
                  '(1 2 3)))))
 
+(with-test-prefix "case-lambda"
+  (pass-if-equal "simple"
+      '(0 3 9 28)
+    (let ((proc (run-rtl '(case-lambda
+                            (() 0)
+                            ((x) x)
+                            ((x y) (+ x y))
+                            ((x y z . rest) (apply + x y z rest))))))
+      (map (lambda (args) (apply proc args))
+           '(() (3) (2 7) (2 3 5 7 11)))))
+
+  (pass-if-exception "no match"
+      exception:wrong-num-args
+    ((run-rtl '(case-lambda ((x) x) ((x y) (+ x y))))
+     1 2 3))
+
+  (pass-if-exception "zero clauses called with no args"
+      exception:wrong-num-args
+    ((run-rtl '(case-lambda))))
+
+  (pass-if-exception "zero clauses called with args"
+      exception:wrong-num-args
+    ((run-rtl '(case-lambda)) 1)))
 
 (with-test-prefix "mixed contexts"
   (pass-if-equal "sequences" '(3 4 5)
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 6f61f37..a6467ea 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -242,7 +242,8 @@
                             (box-ref 2 1)
                             (add1 2 2)
                             (box-set! 1 2)
-                            (return-values 0)
+                            (reset-frame 1)
+                            (return-values)
                             (end-arity)
                             (end-program)))))
                     ((make-top-incrementor))


hooks/post-receive
-- 
GNU Guile