[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 06/11: Add compiler support for s64 comparisons.
From: |
Andy Wingo |
Subject: |
[Guile-commits] 06/11: Add compiler support for s64 comparisons. |
Date: |
Sun, 29 Oct 2017 16:05:01 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 79a2748f83bade00c68f61ea58335c2d02158649
Author: Andy Wingo <address@hidden>
Date: Sun Oct 29 19:33:00 2017 +0100
Add compiler support for s64 comparisons.
* module/language/cps/compile-bytecode.scm (compile-function): Add
emitters for s64 comparisons.
* module/language/cps/effects-analysis.scm: Add entries.
* module/language/cps/primitives.scm (*comparisons*):
* module/language/cps/type-fold.scm (s64-<, s64-<=, s64-=, s64->=)
(s64->): Add folders.
* module/language/cps/types.scm (s64-<, s64-<=, s64-=, s64->=, s64->):
Add type checkers and inferrers.
---
module/language/cps/compile-bytecode.scm | 5 +++++
module/language/cps/effects-analysis.scm | 5 +++++
module/language/cps/primitives.scm | 5 +++++
module/language/cps/type-fold.scm | 5 +++++
module/language/cps/types.scm | 38 ++++++++++++++++++++++++++++++++
5 files changed, 58 insertions(+)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 5651047..131249c 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -458,6 +458,11 @@
(($ $primcall 'u64-= (a b)) (binary-test emit-u64=? a b))
(($ $primcall 'u64->= (a b)) (binary* emit-u64<? emit-jnl emit-jl a b))
(($ $primcall 'u64-> (a b)) (binary* emit-u64<? emit-jl emit-jnl b a))
+ (($ $primcall 's64-< (a b)) (binary* emit-s64<? emit-jl emit-jnl a b))
+ (($ $primcall 's64-<= (a b)) (binary* emit-s64<? emit-jnl emit-jl b a))
+ (($ $primcall 's64-= (a b)) (binary-test emit-s64=? a b))
+ (($ $primcall 's64->= (a b)) (binary* emit-s64<? emit-jnl emit-jl a b))
+ (($ $primcall 's64-> (a b)) (binary* emit-s64<? emit-jl emit-jnl b a))
(($ $primcall 'f64-< (a b)) (binary* emit-f64<? emit-jl emit-jnl a b))
(($ $primcall 'f64-<= (a b)) (binary* emit-f64<? emit-jge emit-jnge b
a))
(($ $primcall 'f64-= (a b)) (binary-test emit-f64=? a b))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 843111b..641e420 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -449,6 +449,11 @@ is or might be a read or a write to the same location as
A."
((u64-=-scm . _) &type-check)
((u64->=-scm . _) &type-check)
((u64->-scm . _) &type-check)
+ ((s64-= . _))
+ ((s64-< . _))
+ ((s64-> . _))
+ ((s64-<= . _))
+ ((s64->= . _))
((f64-= . _))
((f64-< . _))
((f64-> . _))
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 6207152..1437a4e 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -134,6 +134,9 @@ before it is lowered to CPS?"
u64-<
u64-<=
u64-=
+ s64-<
+ s64-<=
+ s64-=
f64-=
f64-<
f64-<=
@@ -149,6 +152,8 @@ before it is lowered to CPS?"
>=
u64->
u64->=
+ s64->
+ s64->=
u64->=-scm
u64->-scm
f64->
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index 9dd0d45..fdddd4a 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -144,6 +144,7 @@
((= >= >) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-< <)
+(define-branch-folder-alias s64-< <)
(define-branch-folder-alias u64-<-scm <)
;; We currently cannot define branch folders for floating point
;; comparison ops like the commented one below because we can't prove
@@ -157,6 +158,7 @@
((>) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-<= <=)
+(define-branch-folder-alias s64-<= <=)
(define-branch-folder-alias u64-<=-scm <=)
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
@@ -165,6 +167,7 @@
((< >) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-= =)
+(define-branch-folder-alias s64-= =)
(define-branch-folder-alias u64-=-scm =)
(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
@@ -173,6 +176,7 @@
((<) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64->= >=)
+(define-branch-folder-alias s64->= >=)
(define-branch-folder-alias u64->=-scm >=)
(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
@@ -181,6 +185,7 @@
((= <= <) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-> >)
+(define-branch-folder-alias s64-> >)
(define-branch-folder-alias u64->-scm >)
(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 966ef38..2787cb5 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1032,6 +1032,44 @@ minimum, and maximum."
(define-simple-type-checker (u64-> &u64 &u64))
(define-u64-comparison-inferrer (u64-> > <=))
+;; Signed unboxed comparisons.
+(define-simple-type-checker (s64-= &s64 &s64))
+(define-predicate-inferrer (s64-= a b true?)
+ (when true?
+ (let ((min (max (&min/s64 a) (&min/s64 b)))
+ (max (min (&max/s64 a) (&max/s64 b))))
+ (restrict! a &s64 min max)
+ (restrict! b &s64 min max))))
+
+(define (infer-s64-comparison-ranges op min0 max0 min1 max1)
+ (match op
+ ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
+ ('<= (values min0 (min max0 max1) (max min0 min1) max1))
+ ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
+ ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
+(define-syntax-rule (define-s64-comparison-inferrer (s64-op op inverse))
+ (define-predicate-inferrer (s64-op a b true?)
+ (call-with-values
+ (lambda ()
+ (infer-s64-comparison-ranges (if true? 'op 'inverse)
+ (&min/s64 a) (&max/s64 a)
+ (&min/s64 b) (&max/s64 b)))
+ (lambda (min0 max0 min1 max1)
+ (restrict! a &s64 min0 max0)
+ (restrict! b &s64 min1 max1)))))
+
+(define-simple-type-checker (s64-< &s64 &s64))
+(define-s64-comparison-inferrer (s64-< < >=))
+
+(define-simple-type-checker (s64-<= &s64 &s64))
+(define-s64-comparison-inferrer (s64-<= <= >))
+
+(define-simple-type-checker (s64->= &s64 &s64))
+(define-s64-comparison-inferrer (s64-<= >= <))
+
+(define-simple-type-checker (s64-> &s64 &s64))
+(define-s64-comparison-inferrer (s64-> > <=))
+
;; Arithmetic.
(define-syntax-rule (define-unary-result! a result min max)
(let ((min* min)
- [Guile-commits] branch master updated (9d1235a -> d1c69b5), Andy Wingo, 2017/10/29
- [Guile-commits] 01/11: Minor optimization compiling 'and', Andy Wingo, 2017/10/29
- [Guile-commits] 08/11: Add untag-fixnum instruction, Andy Wingo, 2017/10/29
- [Guile-commits] 10/11: Inline u64/scm comparisons, Andy Wingo, 2017/10/29
- [Guile-commits] 02/11: Rename "number" tag to "heap-number", Andy Wingo, 2017/10/29
- [Guile-commits] 03/11: Simplify lowering of branching primcalls to CPS, Andy Wingo, 2017/10/29
- [Guile-commits] 11/11: Remove compiler support for u64-scm comparisons, Andy Wingo, 2017/10/29
- [Guile-commits] 05/11: Lower eqv? and equal? to new instructions., Andy Wingo, 2017/10/29
- [Guile-commits] 04/11: Add missing compiler support for heap-object? primcall et al., Andy Wingo, 2017/10/29
- [Guile-commits] 07/11: Add compiler support for fixnum? primcall predicate, Andy Wingo, 2017/10/29
- [Guile-commits] 06/11: Add compiler support for s64 comparisons.,
Andy Wingo <=
- [Guile-commits] 09/11: Add hacks around lack of allocation sinking, Andy Wingo, 2017/10/29