wingo pushed a commit to branch master
in repository guile.
commit 163fcf5adb5700c8d5fe2e9bd0a57ce7c7bf1c34
Author: Andy Wingo <[email protected]>
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)))))
