[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/03: Compiler specializes comparisons to immediate int
From: |
Andy Wingo |
Subject: |
[Guile-commits] 03/03: Compiler specializes comparisons to immediate integers |
Date: |
Wed, 15 Nov 2017 08:19:21 -0500 (EST) |
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.