[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-170-g6d05bf6

[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=6d05bf6c8fb473028a13c4a2a1513c442d69cb68

The branch, wip-cps-bis has been updated
       via  6d05bf6c8fb473028a13c4a2a1513c442d69cb68 (commit)
       via  d9de782a268a34bce53360d720c2c2b3b598c260 (commit)
       via  f14b054a8939a67485e53a2a30e225563366efe7 (commit)
       via  ad6ee824f36c968954854c7398c2bfc0ab1f90ff (commit)
       via  dfbb61d8837fe2cea93236a7b5f052e28514c233 (commit)
      from  cd1ca75ea0f38e2eb007da7fb5c45407a1b5cb91 (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 6d05bf6c8fb473028a13c4a2a1513c442d69cb68
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 15 02:17:30 2013 -0400

    RTL Compiler: Fix handling of 'define!' and 'box-set!' primitives.
    
    * module/language/cps/arities.scm (*rtl-instruction-aliases*):
      Add entry for 'define!' --> 'define'.
      (fix-arities): If a primcall that returns zero values is found
      in tail position, adapt it to return *unspecified*.
    
    * module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add rules for
      'box-set!' and 'define!' to 'emit-seq'.

commit d9de782a268a34bce53360d720c2c2b3b598c260
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 15 02:09:13 2013 -0400

    RTL Compiler: rework how branching primitives are handled.
    
    * module/language/cps/arities.scm (*other-primcall-arities*):
      Add entries for branching primitives.
      (fix-arities): Remove special handling of branching primitives.
    
    * module/language/tree-il/compile-cps.scm (*branching-primitives*):
      New variable, moved from primitives.scm.
      (branching-primitive?): New procedure, moved from primitives.scm.
    
    * module/language/tree-il/primitives.scm (*branching-primitives*,
      *branching-primitive-table*, branching-primitive?): Remove.

commit f14b054a8939a67485e53a2a30e225563366efe7
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 15 01:58:37 2013 -0400

    RTL Compiler: emit 'return-values', not 'return/values'.
    
    * module/language/cps/compile-rtl.scm (emit-rtl-sequence): Emit
      'return-values', not 'return/values' which does not exist.

commit ad6ee824f36c968954854c7398c2bfc0ab1f90ff
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 15 01:50:41 2013 -0400

    RTL Compiler: Remove FIXME comments that no longer apply.
    
    * module/language/cps/compile-rtl.scm (emit-rtl-sequence):
      Remove FIXME comments about a problem that has been fixed.

commit dfbb61d8837fe2cea93236a7b5f052e28514c233
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 15 01:47:18 2013 -0400

    RTL VM: Remove OP_DST flag from 'box-set!' instruction.
    
    * libguile/vm-engine.c (box-set!): Remove OP_DST flag.

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

Summary of changes:
 libguile/vm-engine.c                    |    2 +-
 module/language/cps/arities.scm         |   37 +++++++++++++++++++++++++------
 module/language/cps/compile-rtl.scm     |    8 ++++--
 module/language/tree-il/compile-cps.scm |    7 +++++-
 module/language/tree-il/primitives.scm  |   12 +---------
 5 files changed, 43 insertions(+), 23 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 369bb79..44a9e45 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1826,7 +1826,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
    *
    * Set the contents of the variable at DST to SET.
    */
-  VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
+  VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12))
     {
       scm_t_uint16 dst, src;
       SCM var;
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 7696cf7..b6a8c0b 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -27,7 +27,6 @@
   #:use-module (srfi srfi-26)
   #:use-module (language cps)
   #:use-module (system vm instruction)
-  #:use-module ((language tree-il primitives) #:select (branching-primitive?))
   #:export (fix-arities *rtl-instruction-aliases*))
 
 (define (make-$let1k cont body)
@@ -127,7 +126,8 @@
     (- . sub) (1- . sub1)
     (* . mul) (/ . div)
     (quotient . quo) (remainder . rem)
-    (modulo . mod)))
+    (modulo . mod)
+    (define! . define)))
 
 (define *macro-instruction-arities*
   '((cache-current-module! . (0 . 2))
@@ -135,7 +135,19 @@
     (cached-module-box . (1 . 4))))
 
 (define *other-primcall-arities*
-  '((eq? . (1 . 2))))
+  '((null? . (1 . 1))
+    (nil? . (1 . 1))
+    (pair? . (1 . 1))
+    (struct? . (1 . 1))
+    (char? . (1 . 1))
+    (eq? . (1 . 2))
+    (eqv? . (1 . 2))
+    (equal? . (1 . 2))
+    (= . (1 . 2))
+    (< . (1 . 2))
+    (> . (1 . 2))
+    (<= . (1 . 2))
+    (>= . (1 . 2))))
 
 (define (compute-primcall-arities)
   (let ((table (make-hash-table)))
@@ -176,7 +188,21 @@
         (match nvals
           (0
            (match cont
-             (#f (proc k))
+             (#f      ;(proc k)
+              ;; XXX I'm not sure if this is desirable, but it's
+              ;; needed to handle things like 'define!' and 'box-set!'
+              ;; in tail position.
+              (let ((kvoid (gensym "kvoid"))
+                    (kunspec (gensym "kunspec"))
+                    (unspec (gensym "unspec")))
+                (make-$let1v
+                 #f kunspec unspec unspec
+                 (make-$continue k (make-$primcall 'return (list unspec)))
+                 (make-$let1k
+                  (make-$cont #f kvoid
+                              (make-$kargs '() '()
+                                           (make-$continue kunspec 
(make-$void))))
+                  (proc kvoid)))))
              (($ $cont _ _ ($ $ktrunc ($ $arity () () #f () #f) kseq))
               (proc kseq))
              (($ $cont _ _ ($ $kargs () () _))
@@ -211,9 +237,6 @@
 
     (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 1feb801..96eac4e 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -154,7 +154,7 @@
                         ((src . dst) (emit `(mov ,dst ,src))))
                        (lookup-parallel-moves label slots))
              (for-each maybe-load-constant tail-slots args))
-           (emit `(return/values ,(length args))))
+           (emit `(return-values ,(length args))))
           (($ $primcall 'return (arg))
            (emit `(return ,(slot arg))))))
 
@@ -197,7 +197,6 @@
             (($ $primcall 'resolve (name bound?))
              (emit `(resolve ,dst ,(constant bound?) ,(slot name))))
             (($ $primcall 'free-ref (closure idx))
-             ;; XXX FIXME prevent IDX from being needlessly loaded into a 
register!
              (emit `(free-ref ,dst ,(slot closure) ,(constant idx))))
             (($ $primcall name args)
              (let ((name (or (assq-ref *rtl-instruction-aliases* name)
@@ -226,8 +225,11 @@
           (($ $primcall 'cache-current-module! (sym scope))
            (emit `(cache-current-module! ,(slot sym) ,(constant scope))))
           (($ $primcall 'free-set! (closure idx value))
-           ;; XXX FIXME prevent IDX from being needlessly loaded into a 
register!
            (emit `(free-set! ,(slot closure) ,(slot value) ,(constant idx))))
+          (($ $primcall 'box-set! (box value))
+           (emit `(box-set! ,(slot box) ,(slot value))))
+          (($ $primcall 'define! (sym value))
+           (emit `(define ,(slot sym) ,(slot value))))
           (($ $primcall name args)
            (emit `(primcall/seq ,name ,@args)))
           (($ $values ()) #f))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index e0927bc..ae6a23f 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -29,7 +29,6 @@
   #: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>
@@ -65,6 +64,12 @@
   (let ((k (gensym "k")) (sym (gensym "v")))
     (make-$let1v src k 'tmp sym (body-proc sym) (val-proc k))))
 
+(define *branching-primitives*
+  '(null? nil? pair? struct? char? eq? eqv? equal? < <= = >= >))
+
+(define (branching-primitive? name)
+  (memq name *branching-primitives*))
+
 ;; Guile's semantics are that a toplevel lambda captures a reference on
 ;; the current module, and that all contained lambdas use that module to
 ;; resolve toplevel variables.  This parameter tracks whether or not we
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index e62d137..0fe4445 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -31,7 +31,7 @@
             effect-free-primitive? effect+exception-free-primitive?
             constructor-primitive? accessor-primitive?
             singly-valued-primitive? equality-primitive?
-            bailout-primitive? branching-primitive?
+            bailout-primitive?
             negate-primitive))
 
 ;; When adding to this, be sure to update *multiply-valued-primitives*
@@ -196,10 +196,6 @@
 (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?)
@@ -216,7 +212,6 @@
 (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)
@@ -235,9 +230,6 @@
             (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*)
@@ -256,8 +248,6 @@
   (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