From 72fe466ac9ca8316c77d68d39c336075ed884e92 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= <bjourne@gmail.com>
Date: Wed, 24 Jun 2015 18:07:05 +0200
Subject: [PATCH] compiler.tree.propagation.known-words: more precise output
 class assignment for all mod words

The compiler can better optimize a quotation like [ 20 fixnum-mod 55 + ]
if it knows fixnum-mod outputs a fixnum.
---
 .../known-words/known-words.factor            |  22 +++-
 .../propagation/simple/simple-tests.factor    | 122 ++++++++++++++++++
 2 files changed, 138 insertions(+), 6 deletions(-)
 create mode 100644 basis/compiler/tree/propagation/simple/simple-tests.factor

diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 8f81bf9c61..b3221a4b40 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -123,14 +123,24 @@ IN: compiler.tree.propagation.known-words
 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
 
-\ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
+\ mod [ interval-mod ] [ real-valued ] binary-op
+\ fmod [ interval-mod ] [ real-valued ] binary-op
+\ mod-integer-integer [ interval-mod ] [ integer-valued ] binary-op
+\ bignum-mod [ interval-mod ] [ integer-valued ] binary-op
+\ fixnum-mod [ interval-mod ] [ fixnum-valued ] binary-op
+\ mod-fixnum-integer [ interval-mod ] [ integer-valued ] binary-op
+\ mod-integer-fixnum [ interval-mod ] [ integer-valued ] binary-op
+
 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
 
-{ /mod fixnum/mod } [
-    \ /i \ mod
-    [ "outputs" word-prop ] bi@
-    '[ _ _ 2bi ] "outputs" set-word-prop
-] each
+! /mod is the combination of /i and mod, fixnum/mod of /i and fixnum-mod
+\ /mod
+\ /i \ mod [ "outputs" word-prop ] bi@
+'[ _ _ 2bi ] "outputs" set-word-prop
+
+\ fixnum/mod
+\ /i \ fixnum-mod [ "outputs" word-prop ] bi@
+'[ _ _ 2bi ] "outputs" set-word-prop
 
 : shift-op-class ( info1 info2 -- newclass )
     [ class>> ] bi@
diff --git a/basis/compiler/tree/propagation/simple/simple-tests.factor b/basis/compiler/tree/propagation/simple/simple-tests.factor
new file mode 100644
index 0000000000..c8b40550f4
--- /dev/null
+++ b/basis/compiler/tree/propagation/simple/simple-tests.factor
@@ -0,0 +1,122 @@
+USING: accessors arrays assocs compiler.tree
+compiler.tree.propagation.constraints compiler.tree.propagation.copy
+compiler.tree.propagation.info compiler.tree.propagation.simple kernel math
+math.intervals math.private namespaces sequences system tools.test words ;
+IN: compiler.tree.propagation.simple.tests
+
+: fixnum-value-infos ( -- infos )
+    {
+        H{
+            {
+                1
+                T{ value-info-state
+                   { class fixnum }
+                   { interval
+                     T{ interval
+                        { from { 56977 t } }
+                        { to { 56977 t } }
+                     }
+                   }
+                   { literal 56977 }
+                   { literal? t }
+                }
+            }
+            {
+                2
+                T{ value-info-state
+                   { class fixnum }
+                   { interval
+                     T{ interval
+                        { from { 8098 t } }
+                        { to { 8098 t } }
+                     }
+                   }
+                   { literal 8098 }
+                   { literal? t }
+                }
+            }
+        }
+    } ;
+
+: object-value-infos ( -- infos )
+    {
+        H{
+            {
+                1
+                T{ value-info-state
+                   { class object }
+                   { interval full-interval }
+                }
+            }
+            {
+                2
+                T{ value-info-state
+                   { class object }
+                   { interval full-interval }
+                }
+            }
+        }
+    } ;
+
+: setup-value-infos ( value-infos -- )
+    value-infos set
+    H{ { 1 1 } { 2 2 } { 3 3 } } copies set ;
+
+: #call-fixnum* ( -- node )
+    T{ #call { word fixnum* } { in-d V{ 1 2 } } { out-d { 3 } } } ;
+
+: #call-fixnum/mod ( -- node )
+    T{ #call { word fixnum/mod } { in-d V{ 1 2 } } { out-d { 4 5 } } } ;
+
+{ } [
+    fixnum-value-infos setup-value-infos
+    #call-fixnum* dup word>> "input-classes" word-prop
+    propagate-input-classes
+] unit-test
+
+{ t } [
+    fixnum-value-infos setup-value-infos 1 value-info literal?>>
+] unit-test
+
+{
+    {
+        T{ value-info-state
+           { class fixnum }
+           { interval
+             T{ interval { from { 7 t } } { to { 7 t } } }
+           }
+           { literal 7 }
+           { literal? t }
+        }
+        T{ value-info-state
+           { class fixnum }
+           { interval
+             T{ interval { from { 0 t } } { to { 8097 t } } }
+           }
+        }
+    }
+} [
+    fixnum-value-infos setup-value-infos
+    #call-fixnum/mod dup word>> call-outputs-quot
+] unit-test
+
+! The result of fixnum-mod should always be a fixnum.
+cpu x86.64? [
+    {
+        {
+            T{ value-info-state
+               { class fixnum }
+               { interval
+                 T{ interval
+                    { from { -576460752303423488 t } }
+                    { to { 576460752303423487 t } }
+                 }
+               }
+            }
+        }
+    } [
+        object-value-infos setup-value-infos
+        T{ #call { word fixnum-mod } { in-d V{ 1 2 } } { out-d { 4 } } }
+        dup word>> call-outputs-quot
+    ] unit-test
+] when