[Guile-commits] 03/03: Compiler specializes comparisons to immediate integers

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 0951551fb4a2b905a436edf0eae622c2e12d608a
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 15 14:01:00 2017 +0100

    Compiler specializes comparisons to immediate integers
    
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/language/cps/effects-analysis.scm (load-const/unlikely):
    * module/language/cps/types.scm (load-const/unlikely):
    * module/language/cps/primitives.scm (*macro-instruction-arities*): Add
      new primcall, load-const/unlikely.
    * module/language/cps/specialize-numbers.scm: Rework comparison
      specialization.  Add support for specializing comparisons against
      integer immediates.
---
 module/language/cps/compile-bytecode.scm   |   2 +
 module/language/cps/effects-analysis.scm   |   1 +
 module/language/cps/primitives.scm         |   1 +
 module/language/cps/specialize-numbers.scm | 190 +++++++++++++++++++++--------
 module/language/cps/types.scm              |   7 ++
 5 files changed, 152 insertions(+), 49 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index f11a4c1..6391a67 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -135,6 +135,8 @@
          (maybe-mov dst (slot arg)))
         (($ $const exp)
          (emit-load-constant asm (from-sp dst) exp))
+        (($ $primcall 'load-const/unlikely exp ())
+         (emit-load-constant asm (from-sp dst) exp))
         (($ $closure k 0)
          (emit-load-static-procedure asm (from-sp dst) k))
         (($ $closure k nfree)
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 178079e..5ef22c2 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -259,6 +259,7 @@ is or might be a read or a write to the same location as A."
 
 ;; Miscellaneous.
 (define-primitive-effects
+  ((load-const/unlikely))
   ((values . _)))
 
 ;; Generic effect-free predicates.
diff --git a/module/language/cps/primitives.scm 
b/module/language/cps/primitives.scm
index ed2aeae..c9688d1 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -69,6 +69,7 @@
   '((u64->scm/unlikely . (1 . 1))
     (s64->scm/unlikely . (1 . 1))
     (tag-fixnum/unlikely . (1 . 1))
+    (load-const/unlikely . (0 . 1))
     (cache-current-module! . (0 . 1))
     (cached-toplevel-box . (1 . 0))
     (cached-module-box . (1 . 0))))
diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index ced7a3b..0e8ae93 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -202,22 +202,32 @@
       ($continue kbox src
         ($primcall unbox-a #f (scm))))))
 
-(define (specialize-fixnum-comparison cps kf kt src op a b)
-  (let ((op (match op ('= 'u64-=) ('< 's64-<))))
-    (with-cps cps
-      (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 'untag-fixnum #f (b)))))
-      (build-term
-        ($continue kunbox-b src
-          ($primcall 'untag-fixnum #f (a)))))))
+(define* (specialize-int-comparison cps kf kt src op a b
+                                    unbox-a unbox-b)
+  (with-cps cps
+    (letv ia ib)
+    (letk kop ($kargs ('ib) (ib)
+                ($continue kf src
+                  ($branch kt ($primcall op #f (ia ib))))))
+    (letk kunbox-b ($kargs ('ia) (ia)
+                     ($continue kop src
+                       ($primcall unbox-b #f (b)))))
+    (build-term
+      ($continue kunbox-b src
+        ($primcall unbox-a #f (a))))))
+
+(define* (specialize-int-imm-comparison cps kf kt src op a b
+                                        unbox-a)
+  (with-cps cps
+    (letv ia)
+    (letk kop ($kargs ('ia) (ia)
+                ($continue kf src
+                  ($branch kt ($primcall op b (ia))))))
+    (build-term
+      ($continue kop src ($primcall unbox-a #f (a))))))
 
 (define (specialize-fixnum-scm-comparison cps kf kt src op a-fx b-scm)
-  (let ((s64-op (match op ('= 'u64-=) ('< 's64-<))))
+  (let ((s64-op (match op ('= 's64-=) ('< 's64-<))))
     (with-cps cps
       (letv a b sunk)
       (letk kheap ($kargs ('sunk) (sunk)
@@ -272,21 +282,30 @@
          ($continue kb src
            ($primcall 'untag-fixnum #f (b-fx))))))))
 
-(define* (specialize-u64-comparison cps kf kt src op a b #:key
-                                    (unbox-a 'scm->u64)
-                                    (unbox-b 'scm->u64))
-  (let ((op (symbol-append 'u64- op)))
-    (with-cps cps
-      (letv u64-a u64-b)
-      (letk kop ($kargs ('u64-b) (u64-b)
+(define (specialize-imm-scm-comparison cps kf kt src op a b-scm
+                                       compare-scm)
+  (with-cps cps
+    (letv b sunk)
+    (let$ sunk-compare-exp (compare-scm sunk))
+    (letk kheap ($kargs ('sunk) (sunk)
                   ($continue kf src
-                    ($branch kt ($primcall op #f (u64-a u64-b))))))
-      (letk kunbox-b ($kargs ('u64-a) (u64-a)
-                       ($continue kop src
-                         ($primcall unbox-b #f (b)))))
-      (build-term
-        ($continue kunbox-b src
-          ($primcall unbox-a #f (a)))))))
+                    ($branch kt ,sunk-compare-exp))))
+    ;; Re-box the variable.  FIXME: currently we use a specially marked
+    ;; load-const to avoid CSE from hoisting the constant.  Instead we
+    ;; should just use a $const directly and implement an allocation
+    ;; sinking pass that should handle this..
+    (letk kretag ($kargs () ()
+                   ($continue kheap src
+                     ($primcall 'load-const/unlikely a ()))))
+    (letk kb ($kargs ('b) (b)
+               ($continue kf src
+                 ($branch kt ($primcall op a (b))))))
+    (letk kfix ($kargs () ()
+                 ($continue kb src
+                   ($primcall 'untag-fixnum #f (b-scm)))))
+    (build-term
+      ($continue kretag src
+        ($branch kfix ($primcall 'fixnum? #f (b-scm)))))))
 
 (define (specialize-f64-comparison cps kf kt src op a b)
   (let ((op (symbol-append 'f64- op)))
@@ -485,6 +504,9 @@ BITS indicating the significant bits needed for a variable. 
 BITS may be
         (and (zero? (logand (logior typea typeb) (lognot &real)))
              (or (eqv? typea &flonum)
                  (eqv? typeb &flonum)))))
+    (define (constant-arg arg)
+      (let-values (((type min max) (lookup-pre-type types label arg)))
+        (and (= min max) min)))
     (define (integer-unbox-op arg)
       (let-values (((type min max) (lookup-pre-type types label arg)))
         (cond
@@ -657,23 +679,88 @@ BITS indicating the significant bits needed for a 
variable.  BITS may be
             (let$ body (specialize-f64-comparison k kt src op a b))
             (setk label ($kargs names vars ,body))))
          ((fixnum-operand? a)
-          (let ((specialize (if (fixnum-operand? b)
-                                specialize-fixnum-comparison
-                                specialize-fixnum-scm-comparison)))
+          (cond
+           ((fixnum-operand? b)
+            (cond
+             ((constant-arg a)
+              => (lambda (a)
+                   (let ((op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
+                     (with-cps cps
+                       (let$ body (specialize-int-imm-comparison
+                                   k kt src op b a
+                                   'untag-fixnum))
+                       (setk label ($kargs names vars ,body))))))
+             ((constant-arg b)
+              => (lambda (b)
+                   (let ((op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
+                     (with-cps cps
+                       (let$ body (specialize-int-imm-comparison
+                                   k kt src op a b
+                                   'untag-fixnum))
+                       (setk label ($kargs names vars ,body))))))
+             (else
+              (let ((op (match op ('= 's64-=) ('< 's64-<))))
+                (with-cps cps
+                  (let$ body (specialize-int-comparison k kt src op a b
+                                                        'untag-fixnum
+                                                        'untag-fixnum))
+                  (setk label ($kargs names vars ,body)))))))
+           ((constant-arg a)
+            => (lambda (a)
+                 (let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
+                   (with-cps cps
+                     (let$ body (specialize-imm-scm-comparison
+                                 k kt src imm-op a b
+                                 (lambda (cps a)
+                                   (with-cps cps
+                                     (build-exp ($primcall op #f (a b)))))))
+                     (setk label ($kargs names vars ,body))))))
+           (else
             (with-cps cps
-              (let$ body (specialize k kt src op a b))
-              (setk label ($kargs names vars ,body)))))
+              (let$ body (specialize-fixnum-scm-comparison k kt src op a b))
+              (setk label ($kargs names vars ,body))))))
          ((fixnum-operand? b)
-          (with-cps cps
-            (let$ body (specialize-scm-fixnum-comparison k kt src op a b))
-            (setk label ($kargs names vars ,body))))
+          (cond
+           ((constant-arg b)
+            => (lambda (b)
+                 (let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
+                   (with-cps cps
+                     (let$ body (specialize-imm-scm-comparison
+                                 k kt src imm-op b a
+                                 (lambda (cps b)
+                                   (with-cps cps
+                                     (build-exp ($primcall op #f (a b)))))))
+                     (setk label ($kargs names vars ,body))))))
+           (else
+            (with-cps cps
+              (let$ body (specialize-scm-fixnum-comparison k kt src op a b))
+              (setk label ($kargs names vars ,body))))))
          ((and (u64-operand? a) (u64-operand? b))
-          (with-cps cps
-            (let$ body (specialize-u64-comparison
-                        k kt src op a b
-                        #:unbox-a (integer-unbox-op/truncate a)
-                        #:unbox-b (integer-unbox-op/truncate b)))
-            (setk label ($kargs names vars ,body))))
+          (cond
+           ((constant-arg a)
+            => (lambda (a)
+                 (let ((op (match op ('= 'u64-imm-=) ('< 'imm-u64-<))))
+                   (with-cps cps
+                     (let$ body (specialize-int-imm-comparison
+                                 k kt src op b a
+                                 (integer-unbox-op/truncate b)))
+                     (setk label ($kargs names vars ,body))))))
+           ((constant-arg b)
+            => (lambda (b)
+                 (let ((op (match op ('= 'u64-imm-=) ('< 'u64-imm-<))))
+                   (with-cps cps
+                     (let$ body (specialize-int-imm-comparison
+                                 k kt src op a b
+                                 (integer-unbox-op/truncate a)))
+                     (setk label ($kargs names vars ,body))))))
+           (else
+            (let ((op (match op ('= 'u64-=) ('< 'u64-<))))
+              (with-cps cps
+                (let$ body (specialize-int-comparison
+                            k kt src op a b
+                            (integer-unbox-op/truncate a)
+                            (integer-unbox-op/truncate b)))
+                (setk label ($kargs names vars ,body)))))))
          (else cps))
         types
         sigbits))
@@ -794,11 +881,14 @@ BITS indicating the significant bits needed for a 
variable.  BITS may be
 (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)
+    (define (u64? n)
+      (and (number? n) (exact-integer? n)
+           (<= 0 n #xffffffffffffffff)))
     (match exp
       ((or ($ $primcall 'u64->scm #f (_))
            ($ $primcall 'u64->scm/unlikely #f (_))
-           ($ $const (and (? number?) (? exact-integer?)
-                          (? (lambda (n) (<= 0 n #xffffffffffffffff))))))
+           ($ $primcall 'load-const/unlikely (? u64?) ())
+           ($ $const (? u64?)))
        #t)
       (_ #f)))
 
@@ -810,14 +900,16 @@ BITS indicating the significant bits needed for a 
variable.  BITS may be
 (define (compute-specializable-fixnum-vars cps body preds defs)
   ;; Is the result of EXP definitely a fixnum?
   (define (exp-result-fixnum? exp)
+    (define (fixnum? n)
+      (and (number? n) (exact-integer? n)
+           (<= (target-most-negative-fixnum)
+               n
+               (target-most-positive-fixnum))))
     (match exp
       ((or ($ $primcall 'tag-fixnum #f (_))
            ($ $primcall 'tag-fixnum/unlikely #f (_))
-           ($ $const (and (? number?) (? exact-integer?)
-                          (? (lambda (n)
-                               (<= (target-most-negative-fixnum)
-                                   n
-                                   (target-most-positive-fixnum)))))))
+           ($ $const (? fixnum?))
+           ($ $primcall 'load-const/unlikely (? fixnum?) ()))
        #t)
       (_ #f)))
 
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 841d29f..f56ce0f 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -671,6 +671,13 @@ minimum, and maximum."
 
 
 
+(define-type-inferrer/param (load-const/unlikely param result)
+  (let ((ent (constant-type param)))
+    (define! result (type-entry-type ent)
+      (type-entry-min ent) (type-entry-max ent))))
+
+
+
 ;;;
 ;;; Fluids.  Note that we can't track bound-ness of fluids, as pop-fluid
 ;;; can change boundness.