[Guile-commits] 22/41: Specialize u64 comparisons

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 163fcf5adb5700c8d5fe2e9bd0a57ce7c7bf1c34
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 20 09:26:56 2015 +0100

    Specialize u64 comparisons
    
    * module/language/cps/specialize-numbers.scm
      (specialize-u64-comparison): New function.
    * module/language/cps/specialize-numbers.scm (specialize-operations):
      Rename from specialize-f64-operations, as it will specialize both
      kinds.  Add a case to specialize u64 comparisons.
    * module/language/cps/specialize-numbers.scm (specialize-numbers): Adapt
      to specialize-operations name change.
---
 module/language/cps/specialize-numbers.scm |   35 ++++++++++++++++++++++++++-
 1 files changed, 33 insertions(+), 2 deletions(-)

diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index 5f15806..1050865 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -81,7 +81,22 @@
         ($continue kunbox-b src
           ($primcall 'scm->f64 (a)))))))
 
-(define (specialize-f64-operations cps)
+(define (specialize-u64-comparison cps kf kt src op a b)
+  (pk 'specialize cps kf kt src op a b)
+  (let ((op (symbol-append 'u64- op)))
+    (with-cps cps
+      (letv u64-a u64-b)
+      (letk kop ($kargs ('u64-b) (u64-b)
+                  ($continue kf src
+                    ($branch kt ($primcall op (u64-a u64-b))))))
+      (letk kunbox-b ($kargs ('u64-a) (u64-a)
+                       ($continue kop src
+                         ($primcall 'scm->u64 (b)))))
+      (build-term
+        ($continue kunbox-b src
+          ($primcall 'scm->u64 (a)))))))
+
+(define (specialize-operations cps)
   (define (visit-cont label cont cps types)
     (match cont
       (($ $kfun)
@@ -101,6 +116,22 @@
                      (setk label ($kargs names vars ,body)))
                    cps)
                types))))))
+      (($ $kargs names vars
+          ($ $continue k src
+             ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a 
b)))))
+       (call-with-values (lambda () (lookup-pre-type types label a))
+         (lambda (a-type a-min a-max)
+           (call-with-values (lambda () (lookup-pre-type types label b))
+             (lambda (b-type b-min b-max)
+               (values
+                (if (and (eqv? a-type b-type &exact-integer)
+                         (<= 0 a-min a-max #xffffffffffffffff)
+                         (<= 0 b-min b-max #xffffffffffffffff))
+                    (with-cps cps
+                      (let$ body (specialize-u64-comparison k kt src op a b))
+                      (setk label ($kargs names vars ,body)))
+                    cps)
+                types))))))
       (_ (values cps types))))
 
   (values (intmap-fold visit-cont cps cps #f)))
@@ -342,4 +373,4 @@
   ;; Type inference wants a renumbered graph; OK.
   (let ((cps (renumber cps)))
     (with-fresh-name-state cps
-      (specialize-f64-phis (specialize-f64-operations cps)))))
+      (specialize-f64-phis (specialize-operations cps)))))