From 4829cb3ce9d80b45d26e4f987d962a089ef74c91 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 16 Jan 2018 16:19:12 +0100
Subject: [PATCH] Add assume-u64 and assume-s64 dataflow restrictions

* module/language/cps/effects-analysis.scm::
* module/language/cps/reify-primitives.scm (reify-primitives):
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/types.scm (assume-u64, assume-s64): Add primitives
  that assume the range of a u64 or s64 value is within certain bounds.
  This is useful when extracting e.g. a length from a 64-bit word when
  you know the length is less than 2**48.
---
 module/language/cps/effects-analysis.scm | 2 ++
 module/language/cps/reify-primitives.scm | 6 ++++++
 module/language/cps/slot-allocation.scm  | 2 ++
 module/language/cps/types.scm            | 9 +++++++++
 4 files changed, 19 insertions(+)

diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 6038d5af2..4fa00dbe9 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -427,6 +427,8 @@ the LABELS that are clobbered by the effects of LABEL."
   ((s64->scm/unlikely _))
   ((u64->s64 _))
   ((s64->u64 _))
+  ((assume-u64 _))
+  ((assume-s64 _))
   ((untag-fixnum _))
   ((tag-fixnum _))
   ((tag-fixnum/unlikely _)))
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 98371b6a9..327700de4 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -268,6 +268,12 @@
                     ($continue k src ($primcall 'mul #f (a b*)))))
          (setk label ($kargs names vars
                        ($continue kb src ($const b))))))
+      (($ $kargs names vars
+          ($ $continue k src
+             ($ $primcall (or 'assume-u64 'assume-s64) (lo . hi) (val))))
+       (with-cps cps
+         (setk label ($kargs names vars
+                       ($continue k src ($values (val)))))))
       (($ $kargs names vars ($ $continue k src ($ $primcall name param args)))
        (cond
         ((hashq-ref *ephemeral-reifiers* name)
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 4a39a89fc..2729c034a 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -754,6 +754,7 @@ are comparable with eqv?.  A tmp slot may be used."
              (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
                                'char->integer 's64->u64
                                'bv-length 'string-length
+                               'assume-u64
                                'uadd 'usub 'umul
                                'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
                                'uadd/immediate 'usub/immediate 'umul/immediate
@@ -763,6 +764,7 @@ are comparable with eqv?.  A tmp slot may be used."
                                'word-ref 'word-ref/immediate))
               (intmap-add representations var 'u64))
              (($ $primcall (or 'untag-fixnum
+                               'assume-s64
                                'scm->s64 'load-s64 'u64->s64
                                'srsh 'srsh/immediate
                                's8-ref 's16-ref 's32-ref 's64-ref
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 50f169776..5f15f3a0b 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -787,6 +787,15 @@ minimum, and maximum."
 (define-type-inferrer/param (pointer-ref/immediate param obj result)
   (define! result &other-heap-object -inf.0 +inf.0))
 
+(define-type-inferrer/param (assume-u64 param val result)
+  (match param
+    ((lo . hi)
+     (define! result &u64 (max lo (&min val)) (min hi (&max val))))))
+(define-type-inferrer/param (assume-s64 param val result)
+  (match param
+    ((lo . hi)
+     (define! result &s64 (max lo (&min val)) (min hi (&max val))))))
+