[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-146-g535f738

[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=535f738240ab470e045b5dfae9315520a0422c1e

The branch, wip-cps-bis has been updated
       via  535f738240ab470e045b5dfae9315520a0422c1e (commit)
      from  c5d842e88f5219abdff73d2416262606f7a3bdac (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 535f738240ab470e045b5dfae9315520a0422c1e
Author: Mark H Weaver <address@hidden>
Date:   Tue Aug 13 08:18:21 2013 -0400

    Miscellaneous fixes to the RTL compiler.
    
    * module/language/cps/arities.scm (*rtl-instruction-aliases*):
      Export.  Add more entries.
      (fix-arities): Specially handle the case of a branching primitive
      within a conditional.
    
    * module/language/cps/compile-rtl.scm (emit-rtl-sequence): Pass nargs+1
      to 'call' instruction.  Use *rtl-instruction-aliases* to convert
      primitive names.
    
    * module/language/tree-il/compile-cps.scm (convert): Specially handle
      the case of a branching primitive within a conditional.  If a
      branching primitive is found outside of a conditional, put it within a
      conditional that returns #t or #f.
    
    * module/language/tree-il/primitives.scm (branching-primitive?): New
      exported procedure.
      (*branching-primitives*, *branching-primitive-table*): New variables.

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

Summary of changes:
 module/language/cps/arities.scm         |   12 +++++++-
 module/language/cps/compile-rtl.scm     |   10 +++---
 module/language/tree-il/compile-cps.scm |   43 ++++++++++++++++++-------------
 module/language/tree-il/primitives.scm  |   12 ++++++++-
 4 files changed, 51 insertions(+), 26 deletions(-)

diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index f27814c..7696cf7 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -27,7 +27,8 @@
   #:use-module (srfi srfi-26)
   #:use-module (language cps)
   #:use-module (system vm instruction)
-  #:export (fix-arities))
+  #:use-module ((language tree-il primitives) #:select (branching-primitive?))
+  #:export (fix-arities *rtl-instruction-aliases*))
 
 (define (make-$let1k cont body)
   (make-$letk (list cont) body))
@@ -122,7 +123,11 @@
            args))))
 
 (define *rtl-instruction-aliases*
-  '((+ . add)))
+  '((+ . add) (1+ . add1)
+    (- . sub) (1- . sub1)
+    (* . mul) (/ . div)
+    (quotient . quo) (remainder . rem)
+    (modulo . mod)))
 
 (define *macro-instruction-arities*
   '((cache-current-module! . (0 . 2))
@@ -206,6 +211,9 @@
 
     (let lp ((term term))
       (match term
+        (($ $letk (($ $cont src kif ($ $kif kt kf)))
+            ($ $continue kif ($ $primcall (? branching-primitive? name) args)))
+         term)
         (($ $letk conts body)
          (make-$letk (map lp conts) (lp body)))
         (($ $cont src sym ($ $kargs names syms body))
diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 1dd0a6c..11f6164 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -178,14 +178,12 @@
                (let lp ((n (1+ proc-slot)) (args args))
                  (match args
                    (()
-                    (emit `(call ,proc-slot ,nargs))
+                    (emit `(call ,proc-slot ,(+ nargs 1)))
                     (emit `(receive ,dst ,proc-slot ,nlocals)))
                    ((arg . args)
                     (or (maybe-load-constant n arg)
                         (maybe-mov n (slot arg)))
                     (lp (1+ n) args))))))
-            (($ $primcall '+ (a b))
-             (emit `(add ,dst ,(slot a) ,(slot b))))
             (($ $primcall 'current-module)
              (emit `(current-module ,dst)))
             (($ $primcall 'cached-toplevel-box (scope name bound?))
@@ -197,7 +195,9 @@
             (($ $primcall 'resolve (name bound?))
              (emit `(resolve ,dst ,(constant bound?) ,(slot name))))
             (($ $primcall name args)
-             (emit `(,name ,dst ,@(map slot args))))
+             (let ((name (or (assq-ref *rtl-instruction-aliases* name)
+                             name)))
+               (emit `(,name ,dst ,@(map slot args)))))
             (($ $values (arg))
              (or (maybe-load-constant (slot dst) arg)
                  (maybe-mov dst (slot arg))))
@@ -268,7 +268,7 @@
              (let lp ((n (1+ proc-slot)) (args args))
                (match args
                  (()
-                  (emit `(call ,proc-slot ,nargs))
+                  (emit `(call ,proc-slot ,(+ nargs 1)))
                   (emit `(receive-values ,(1+ proc-slot) ,nreq))
                   (when rest?
                     (emit `(bind-rest ,(+ proc-slot 1 nreq))))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 11e6784..e0927bc 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -29,6 +29,7 @@
   #:use-module (language cps)
   #:use-module (language tree-il analyze)
   #:use-module (language tree-il optimize)
+  #:use-module ((language tree-il primitives) #:select (branching-primitive?))
   #:use-module ((language tree-il)
                 #:select
                 (<void>
@@ -41,6 +42,7 @@
                  <lambda> <lambda-case>
                  <let> <letrec> <fix> <let-values>
                  <prompt> <abort>
+                 make-conditional make-const
                  tree-il-src
                  tree-il-fold))
   #:export (compile-cps))
@@ -316,9 +318,13 @@
                     ((proc . args) (make-$continue k (make-$call proc 
args))))))
 
     (($ <primcall> src name args)
-     (convert-args args
-                   (lambda (args)
-                     (make-$continue k (make-$primcall name args)))))
+     (if (branching-primitive? name)
+         (convert (make-conditional src exp (make-const #f #t)
+                                    (make-const #f #f))
+                  k subst)
+         (convert-args args
+                       (lambda (args)
+                         (make-$continue k (make-$primcall name args))))))
 
     ;; Prompts with inline handlers.
     (($ <prompt> src escape-only? tag body
@@ -416,23 +422,24 @@
                      (make-$continue k (make-$primcall 'abort args*)))))
 
     (($ <conditional> src test consequent alternate)
-     (let ((kifvar (gensym "kifvar"))
-           (var (gensym "ifvar"))
-           (kif (gensym "kif"))
+     (let ((kif (gensym "kif"))
            (kt (gensym "k"))
            (kf (gensym "k")))
-       (make-$letk* (list
-                     (make-$cont (tree-il-src consequent) kt
-                              (make-$kargs '() '()
-                                           (convert consequent k subst)))
-                     (make-$cont (tree-il-src alternate) kf
-                              (make-$kargs '() '()
-                                           (convert alternate k subst)))
-                     (make-$cont src kif
-                              (make-$kif kt kf)))
-                    (convert-arg test
-                                 (lambda (test)
-                                   (make-$continue kif (list test)))))))
+       (make-$letk*
+        (list (make-$cont (tree-il-src consequent) kt
+                          (make-$kargs '() '() (convert consequent k subst)))
+              (make-$cont (tree-il-src alternate) kf
+                          (make-$kargs '() '() (convert alternate k subst))))
+        (make-$let1k
+         (make-$cont src kif (make-$kif kt kf))
+         (match test
+           (($ <primcall> src (? branching-primitive? name) args)
+            (convert-args args
+                          (lambda (args)
+                            (make-$continue kif (make-$primcall name args)))))
+           (_ (convert-arg test
+                           (lambda (test)
+                             (make-$continue kif (make-$var test))))))))))
 
     (($ <lexical-set> src name gensym exp)
      (convert-arg
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index f738b74..ce11e52 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -30,7 +30,7 @@
             effect-free-primitive? effect+exception-free-primitive?
             constructor-primitive? accessor-primitive?
             singly-valued-primitive? equality-primitive?
-            bailout-primitive?
+            bailout-primitive? branching-primitive?
             negate-primitive))
 
 ;; When adding to this, be sure to update *multiply-valued-primitives*
@@ -195,6 +195,10 @@
 (define *bailout-primitives*
   '(throw error scm-error))
 
+;; Primitives that are implemented as br-if-* instructions in RTL VM.
+(define *branching-primitives*
+  '(null? nil? pair? struct? char? eq? eqv? equal? < <= = >= >))
+
 ;; Negatable predicates.
 (define *negatable-primitives*
   '((even? . odd?)
@@ -212,6 +216,7 @@
 (define *equality-primitive-table* (make-hash-table))
 (define *multiply-valued-primitive-table* (make-hash-table))
 (define *bailout-primitive-table* (make-hash-table))
+(define *branching-primitive-table* (make-hash-table))
 (define *negatable-primitive-table* (make-hash-table))
 
 (for-each (lambda (x)
@@ -230,6 +235,9 @@
             (hashq-set! *bailout-primitive-table* x #t))
           *bailout-primitives*)
 (for-each (lambda (x)
+            (hashq-set! *branching-primitive-table* x #t))
+          *branching-primitives*)
+(for-each (lambda (x)
             (hashq-set! *negatable-primitive-table* (car x) (cdr x))
             (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
           *negatable-primitives*)
@@ -248,6 +256,8 @@
   (not (hashq-ref *multiply-valued-primitive-table* prim)))
 (define (bailout-primitive? prim)
   (hashq-ref *bailout-primitive-table* prim))
+(define (branching-primitive? prim)
+  (hashq-ref *branching-primitive-table* prim))
 (define (negate-primitive prim)
   (hashq-ref *negatable-primitive-table* prim))
 


hooks/post-receive
-- 
GNU Guile