guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 04/12: Specialize comparisons to SCM as s64


From: Andy Wingo
Subject: [Guile-commits] 04/12: Specialize comparisons to SCM as s64
Date: Sat, 11 Nov 2017 16:12:24 -0500 (EST)

wingo pushed a commit to branch master
in repository guile.

commit 9da03136e52a60fb5f11812a6fd701ef963ead5b
Author: Andy Wingo <address@hidden>
Date:   Thu Nov 9 13:16:14 2017 +0100

    Specialize comparisons to SCM as s64
    
    * module/language/cps/specialize-numbers.scm (specialize-s64-comparison)
      (specialize-s64-scm-comparison, specialize-scm-s64-comparison): New
      helpers.
      (specialize-scm-u64-comparison, specialize-u64-scm-comparison):
      Remove.  Comparing SCM as s64 is better as fixnums are a subset of
      s64, not u64.
      (specialize-operations): Prefer s64 comparisons when we can't
      specialize both arguments; this at least inlines the fixnum case.
---
 module/language/cps/specialize-numbers.scm | 103 ++++++++++++++++-------------
 1 file changed, 57 insertions(+), 46 deletions(-)

diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index 48a0d20..1f6bd5f 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -189,71 +189,75 @@
         ($continue kunbox-b src
           ($primcall 'scm->u64 #f (a)))))))
 
-(define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm)
-  (let ((u64-op (symbol-append 'u64- op)))
+(define (specialize-s64-comparison cps kf kt src op a b)
+  (let ((op (symbol-append 's64- op)))
     (with-cps cps
-      (letv u64 s64 z64 sunk)
+      (letv s64-a s64-b)
+      (letk kop ($kargs ('s64-b) (s64-b)
+                  ($continue kf src
+                    ($branch kt ($primcall op #f (s64-a s64-b))))))
+      (letk kunbox-b ($kargs ('s64-a) (s64-a)
+                       ($continue kop src
+                         ($primcall 'scm->s64 #f (b)))))
+      (build-term
+        ($continue kunbox-b src
+          ($primcall 'scm->s64 #f (a)))))))
+
+(define (specialize-s64-scm-comparison cps kf kt src op a-s64 b-scm)
+  (let ((s64-op (match op ('= 's64-=) ('< 's64-<))))
+    (with-cps cps
+      (letv a b sunk)
       (letk kheap ($kargs ('sunk) (sunk)
                     ($continue kf src
                       ($branch kt ($primcall op #f (sunk b-scm))))))
       ;; Re-box the variable.  FIXME: currently we use a specially
-      ;; marked u64->scm to avoid CSE from hoisting the allocation
-      ;; again.  Instaed we should just use a-u64 directly and implement
+      ;; marked s64->scm to avoid CSE from hoisting the allocation
+      ;; again.  Instaed we should just use a-s64 directly and implement
       ;; an allocation sinking pass that should handle this..
       (letk kretag ($kargs () ()
                      ($continue kheap src
-                       ($primcall 'u64->scm/unlikely #f (u64)))))
-      (letk kcmp ($kargs () ()
-                   ($continue kf src
-                     ($branch kt ($primcall u64-op #f (u64 s64))))))
-      (letk kz64 ($kargs ('z64) (z64)
-                   ($continue kcmp src
-                     ($branch kf ($primcall 's64-< #f (s64 z64))))))
-      (letk ks64 ($kargs ('s64) (s64)
-                   ($continue kz64 src ($primcall 'load-s64 0 ()))))
+                       ($primcall 's64->scm/unlikely #f (a)))))
+      (letk kb ($kargs ('b) (b)
+                 ($continue kf src
+                   ($branch kt ($primcall s64-op #f (a b))))))
       (letk kfix ($kargs () ()
-                   ($continue ks64 src
+                   ($continue kb src
                      ($primcall 'untag-fixnum #f (b-scm)))))
-      (letk ku64 ($kargs ('u64) (u64)
-                   ($continue kretag src
-                     ($branch kfix ($primcall 'fixnum? #f (b-scm))))))
+      (letk ka ($kargs ('a) (a)
+                 ($continue kretag src
+                   ($branch kfix ($primcall 'fixnum? #f (b-scm))))))
       (build-term
-        ($continue ku64 src
-          ($primcall 'scm->u64 #f (a-u64)))))))
+        ($continue ka src
+          ($primcall 'scm->s64 #f (a-s64)))))))
 
-(define (specialize-scm-u64-comparison cps kf kt src op a-scm b-u64)
+(define (specialize-scm-s64-comparison cps kf kt src op a-scm b-s64)
   (match op
-    ('= (specialize-u64-scm-comparison cps kf kt src op b-u64 a-scm))
+    ('= (specialize-s64-scm-comparison cps kf kt src op b-s64 a-scm))
     ('<
      (with-cps cps
-       (letv u64 s64 z64 sunk)
+       (letv a b sunk)
        (letk kheap ($kargs ('sunk) (sunk)
                      ($continue kf src
                        ($branch kt ($primcall '< #f (a-scm sunk))))))
        ;; Re-box the variable.  FIXME: currently we use a specially
-       ;; marked u64->scm to avoid CSE from hoisting the allocation
-       ;; again.  Instaed we should just use a-u64 directly and implement
+       ;; marked s64->scm to avoid CSE from hoisting the allocation
+       ;; again.  Instaed we should just use a-s64 directly and implement
        ;; an allocation sinking pass that should handle this..
        (letk kretag ($kargs () ()
                       ($continue kheap src
-                        ($primcall 'u64->scm/unlikely #f (u64)))))
-       (letk kcmp ($kargs () ()
-                    ($continue kf src
-                      ($branch kt ($primcall 'u64-< #f (s64 u64))))))
-       (letk kz64 ($kargs ('z64) (z64)
-                    ($continue kcmp src
-                      ($branch kt ($primcall 's64-< #f (s64 z64))))))
-       (letk ks64 ($kargs ('s64) (s64)
-                    ($continue kz64 src ($primcall 'load-s64 0 ()))))
+                        ($primcall 's64->scm/unlikely #f (b)))))
+       (letk ka ($kargs ('a) (a)
+                  ($continue kf src
+                    ($branch kt ($primcall 's64-< #f (a b))))))
        (letk kfix ($kargs () ()
-                    ($continue ks64 src
+                    ($continue ka src
                       ($primcall 'untag-fixnum #f (a-scm)))))
-       (letk ku64 ($kargs ('u64) (u64)
-                    ($continue kretag src
-                      ($branch kfix ($primcall 'fixnum? #f (a-scm))))))
+       (letk kb ($kargs ('b) (b)
+                  ($continue kretag src
+                    ($branch kfix ($primcall 'fixnum? #f (a-scm))))))
        (build-term
-         ($continue ku64 src
-           ($primcall 'scm->u64 #f (b-u64))))))))
+         ($continue kb src
+           ($primcall 'scm->s64 #f (b-s64))))))))
 
 (define (specialize-f64-comparison cps kf kt src op a b)
   (let ((op (symbol-append 'f64- op)))
@@ -395,6 +399,9 @@ BITS indicating the significant bits needed for a variable. 
 BITS may be
           (and (type<=? type &type) (<= &min min max &max)))))
     (define (u64-operand? var)
       (operand-in-range? var &exact-integer 0 #xffffffffffffffff))
+    (define (s64-operand? var)
+      (operand-in-range? var &exact-integer
+                         (- #x8000000000000000) #x7fffffffffffffff))
     (define (all-u64-bits-set? var)
       (operand-in-range? var &exact-integer
                          #xffffffffffffffff
@@ -566,16 +573,20 @@ BITS indicating the significant bits needed for a 
variable.  BITS may be
           (with-cps cps
             (let$ body (specialize-f64-comparison k kt src op a b))
             (setk label ($kargs names vars ,body))))
-         ((u64-operand? a)
-          (let ((specialize (if (u64-operand? b)
-                                specialize-u64-comparison
-                                specialize-u64-scm-comparison)))
+         ((and (u64-operand? a) (u64-operand? b))
+          (with-cps cps
+            (let$ body (specialize-u64-comparison k kt src op a b))
+            (setk label ($kargs names vars ,body))))
+         ((s64-operand? a)
+          (let ((specialize (if (s64-operand? b)
+                                specialize-s64-comparison
+                                specialize-s64-scm-comparison)))
             (with-cps cps
               (let$ body (specialize k kt src op a b))
               (setk label ($kargs names vars ,body)))))
-         ((u64-operand? b)
+         ((s64-operand? b)
           (with-cps cps
-            (let$ body (specialize-scm-u64-comparison k kt src op a b))
+            (let$ body (specialize-scm-s64-comparison k kt src op a b))
             (setk label ($kargs names vars ,body))))
          (else cps))
         types



reply via email to

[Prev in Thread] Current Thread [Next in Thread]