[Guile-commits] 24/41: Unbox u64 phi values

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 2906d963ea5472c09fbec60f70e3aa6393fe3bae
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 20 10:41:31 2015 +0100

    Unbox u64 phi values
    
    * module/language/cps/specialize-numbers.scm
      (compute-specializable-vars): Refactor to work on any kind of
      unboxable value, not just f64 values.
      (compute-specializable-f64-vars, compute-specializable-u64-vars): New
      helpers.
      (apply-specialization): Support for u64 values.
---
 module/language/cps/specialize-numbers.scm |  137 +++++++++++++++++-----------
 1 files changed, 83 insertions(+), 54 deletions(-)

diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index 7ab5186..61c2b74 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -151,88 +151,112 @@
        (_ defs)))
    labels empty-intmap))
 
-;; Placeholder until we add the real implementation.
-(define (compute-specializable-u64-vars cps body preds defs)
-  empty-intset)
-
-;; Compute vars whose definitions are all inexact reals and whose uses
+;; Compute vars whose definitions are all unboxable and whose uses
 ;; include an unbox operation.
-(define (compute-specializable-f64-vars cps body preds defs)
+(define (compute-specializable-vars cps body preds defs
+                                    exp-result-unboxable?
+                                    unbox-op)
   ;; Compute a map of VAR->LABEL... indicating the set of labels that
-  ;; define VAR with f64 values, given the set of vars F64-VARS which is
-  ;; known already to be f64-valued.
-  (define (collect-f64-def-labels f64-vars)
-    (define (add-f64-def f64-defs var label)
-      (intmap-add f64-defs var (intset label) intset-union))
-    (intset-fold (lambda (label f64-defs)
+  ;; define VAR with unboxable values, given the set of vars
+  ;; UNBOXABLE-VARS which is known already to be unboxable.
+  (define (collect-unboxable-def-labels unboxable-vars)
+    (define (add-unboxable-def unboxable-defs var label)
+      (intmap-add unboxable-defs var (intset label) intset-union))
+    (intset-fold (lambda (label unboxable-defs)
                    (match (intmap-ref cps label)
                      (($ $kargs _ _ ($ $continue k _ exp))
                       (match exp
-                        ((or ($ $primcall 'f64->scm (_))
-                             ($ $const (and (? number?) (? inexact?) (? 
real?))))
+                        ((? exp-result-unboxable?)
                          (match (intmap-ref cps k)
                            (($ $kargs (_) (def))
-                            (add-f64-def f64-defs def label))))
+                            (add-unboxable-def unboxable-defs def label))))
                         (($ $values vars)
                          (match (intmap-ref cps k)
                            (($ $kargs _ defs)
-                            (fold (lambda (var def f64-defs)
-                                    (if (intset-ref f64-vars var)
-                                        (add-f64-def f64-defs def label)
-                                        f64-defs))
-                                  f64-defs vars defs))
+                            (fold
+                             (lambda (var def unboxable-defs)
+                               (if (intset-ref unboxable-vars var)
+                                   (add-unboxable-def unboxable-defs def label)
+                                   unboxable-defs))
+                             unboxable-defs vars defs))
                            ;; Could be $ktail for $values.
-                           (_ f64-defs)))
-                        (_ f64-defs)))
-                     (_ f64-defs)))
+                           (_ unboxable-defs)))
+                        (_ unboxable-defs)))
+                     (_ unboxable-defs)))
                  body empty-intmap))
 
-  ;; Compute the set of vars which are always f64-valued.
-  (define (compute-f64-defs)
+  ;; Compute the set of vars which are always unboxable.
+  (define (compute-unboxable-defs)
     (fixpoint
-     (lambda (f64-vars)
+     (lambda (unboxable-vars)
        (intmap-fold
-        (lambda (def f64-pred-labels f64-vars)
-          (if (and (not (intset-ref f64-vars def))
-                   ;; Are all defining expressions f64-valued?
+        (lambda (def unboxable-pred-labels unboxable-vars)
+          (if (and (not (intset-ref unboxable-vars def))
+                   ;; Are all defining expressions unboxable?
                    (and-map (lambda (pred)
-                              (intset-ref f64-pred-labels pred))
+                              (intset-ref unboxable-pred-labels pred))
                             (intmap-ref preds (intmap-ref defs def))))
-              (intset-add f64-vars def)
-              f64-vars))
-        (collect-f64-def-labels f64-vars)
-        f64-vars))
+              (intset-add unboxable-vars def)
+              unboxable-vars))
+        (collect-unboxable-def-labels unboxable-vars)
+        unboxable-vars))
      empty-intset))
 
   ;; Compute the set of vars that may ever be unboxed.
-  (define (compute-f64-uses f64-defs)
+  (define (compute-unbox-uses unboxable-defs)
     (intset-fold
-     (lambda (label f64-uses)
+     (lambda (label unbox-uses)
        (match (intmap-ref cps label)
          (($ $kargs _ _ ($ $continue k _ exp))
           (match exp
-            (($ $primcall 'scm->f64 (var))
-             (intset-add f64-uses var))
+            (($ $primcall (? (lambda (op) (eq? op unbox-op))) (var))
+             (intset-add unbox-uses var))
             (($ $values vars)
              (match (intmap-ref cps k)
                (($ $kargs _ defs)
-                (fold (lambda (var def f64-uses)
-                        (if (intset-ref f64-defs def)
-                            (intset-add f64-uses var)
-                            f64-uses))
-                      f64-uses vars defs))
+                (fold (lambda (var def unbox-uses)
+                        (if (intset-ref unboxable-defs def)
+                            (intset-add unbox-uses var)
+                            unbox-uses))
+                      unbox-uses vars defs))
                (($ $ktail)
-                ;; Assume return is rare and that any f64-valued def can
+                ;; Assume return is rare and that any unboxable def can
                 ;; be reboxed when leaving the procedure.
-                (fold (lambda (var f64-uses)
-                        (intset-add f64-uses var))
-                      f64-uses vars))))
-            (_ f64-uses)))
-         (_ f64-uses)))
+                (fold (lambda (var unbox-uses)
+                        (intset-add unbox-uses var))
+                      unbox-uses vars))))
+            (_ unbox-uses)))
+         (_ unbox-uses)))
      body empty-intset))
 
-  (let ((f64-defs (compute-f64-defs)))
-    (intset-intersect f64-defs (compute-f64-uses f64-defs))))
+  (let ((unboxable-defs (compute-unboxable-defs)))
+    (intset-intersect unboxable-defs (compute-unbox-uses unboxable-defs))))
+
+;; Compute vars whose definitions are all inexact reals and whose uses
+;; include an unbox operation.
+(define (compute-specializable-f64-vars cps body preds defs)
+  ;; Can the result of EXP definitely be unboxed as an f64?
+  (define (exp-result-f64? exp)
+    (match exp
+      ((or ($ $primcall 'f64->scm (_))
+           ($ $const (and (? number?) (? inexact?) (? real?))))
+       #t)
+      (_ #f)))
+  (compute-specializable-vars cps body preds defs exp-result-f64? 'scm->f64))
+
+;; Compute vars whose definitions are all exact integers in the u64
+;; range and whose uses include an unbox operation.
+(define (compute-specializable-u64-vars cps body preds defs)
+  ;; Can the result of EXP definitely be unboxed as a u64?
+  (define (exp-result-u64? exp)
+    (match exp
+      ((or ($ $primcall 'u64->scm (_))
+           ($ $const (and (? number?) (? exact-integer?)
+                          (? (lambda (n) (<= 0 n #xffffffffffffffff))))))
+       #t)
+      (_ #f)))
+
+  (compute-specializable-vars cps body preds defs exp-result-u64? 'scm->u64))
 
 (define (compute-phi-vars cps preds)
   (intmap-fold (lambda (label preds phis)
@@ -278,6 +302,10 @@
     (match (intmap-ref phis var)
       ('f64 'scm->f64)
       ('u64 'scm->u64)))
+  (define (box-op var)
+    (match (intmap-ref phis var)
+      ('f64 'f64->scm)
+      ('u64 'u64->scm)))
   (define (unbox-operands)
     (define (unbox-arg cps arg def-var have-arg)
       (if (intmap-ref phis def-var (lambda (_) #f))
@@ -348,13 +376,14 @@
                                     (intmap-ref boxed var (lambda (var) var)))
                                   vars)))
             (define (box-var cps name var done)
-              (let ((f64 (intmap-ref boxed var (lambda (_) #f))))
-                (if f64
+              (let ((unboxed (intmap-ref boxed var (lambda (_) #f))))
+                (if unboxed
                     (with-cps cps
                       (let$ term (done))
                       (letk kboxed ($kargs (name) (var) ,term))
                       (build-term
-                        ($continue kboxed #f ($primcall 'f64->scm (f64)))))
+                        ($continue kboxed #f
+                          ($primcall (box-op var) (unboxed)))))
                     (done cps))))
             (define (box-vars cps names vars done)
               (match vars