From 79a2748f83bade00c68f61ea58335c2d02158649 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 29 Oct 2017 19:33:00 +0100
Subject: [PATCH] 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 565104797..131249cdc 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 843111ba2..641e420cf 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 62071526a..1437a4e97 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 9dd0d45a7..fdddd4a6d 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 966ef3892..2787cb540 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)