From 9d5911fc12728e003959745542c3b80f7b6edf1b Mon Sep 17 00:00:00 2001
From: Chris Penner <christopher.penner@gmail.com>
Date: Fri, 8 Nov 2024 12:51:43 -0800
Subject: [PATCH] Define new instrs for lt, neq

---
 unison-runtime/src/Unison/Runtime/ANF.hs     |  6 ++
 unison-runtime/src/Unison/Runtime/Builtin.hs | 59 +++++++++-----------
 unison-runtime/src/Unison/Runtime/MCode.hs   | 12 ++++
 unison-runtime/src/Unison/Runtime/Machine.hs | 36 ++++++++++++
 unison-runtime/src/Unison/Runtime/Stack.hs   |  4 +-
 5 files changed, 80 insertions(+), 37 deletions(-)

diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs
index 6c0c82350d..cc0db3e12b 100644
--- a/unison-runtime/src/Unison/Runtime/ANF.hs
+++ b/unison-runtime/src/Unison/Runtime/ANF.hs
@@ -1292,7 +1292,9 @@ data POp
   | INCI -- inc
   | DECI -- dec
   | LEQI -- <=
+  | LESI -- <
   | EQLI -- ==
+  | NEQI -- !=
   | TRNC -- truncate0
   -- Nat
   | ADDN -- +
@@ -1314,7 +1316,9 @@ data POp
   | INCN -- inc
   | DECN -- dec
   | LEQN -- <=
+  | LESN -- <
   | EQLN -- ==
+  | NEQN -- !=
   -- Float
   | ADDF -- +
   | SUBF -- -
@@ -1323,7 +1327,9 @@ data POp
   | MINF -- min
   | MAXF -- max
   | LEQF -- <=
+  | LESF -- <
   | EQLF -- ==
+  | NEQF -- !=
   | POWF -- pow
   | EXPF -- exp
   | SQRT -- sqrt
diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs
index 0b0e3cae4d..488e0cb526 100644
--- a/unison-runtime/src/Unison/Runtime/Builtin.hs
+++ b/unison-runtime/src/Unison/Runtime/Builtin.hs
@@ -325,28 +325,19 @@ binop ::
 binop pop =
   binop0 0 $ \[x, y] -> TPrm pop [x, y]
 
--- | Lift a comparison op.
-cmpop :: (Var v) => POp -> SuperNormal v
-cmpop pop =
-  binop0 1 $ \[x, y, b] ->
-    TLetD b UN (TPrm pop [x, y]) $
-      boolift b
+-- | Like `binop`, but swaps the arguments.
+binopSwap :: (Var v) => POp -> SuperNormal v
+binopSwap pop =
+  binop0 0 $ \[x, y] -> TPrm pop [y, x]
 
--- | Like `cmpop`, but swaps the arguments.
+-- | Like `binop`, but swaps the arguments.
 cmpopb :: (Var v) => POp -> SuperNormal v
 cmpopb pop =
   binop0 1 $ \[x, y, b] ->
     TLetD b UN (TPrm pop [y, x]) $
       boolift b
 
--- | Like `cmpop`, but negates the result.
-cmpopn :: (Var v) => POp -> SuperNormal v
-cmpopn pop =
-  binop0 1 $ \[x, y, b] ->
-    TLetD b UN (TPrm pop [x, y]) $
-      notlift b
-
--- | Like `cmpop`, but swaps arguments then negates the result.
+-- | Like `binop`, but swaps arguments then negates the result.
 cmpopbn :: (Var v) => POp -> SuperNormal v
 cmpopbn pop =
   binop0 1 $ \[x, y, b] ->
@@ -375,17 +366,17 @@ pown = binop POWN
 dropn = binop DRPN
 
 eqi, eqn, lti, ltn, lei, len :: (Var v) => SuperNormal v
-eqi = cmpop EQLI
-lti = cmpopbn LEQI
-lei = cmpop LEQI
-eqn = cmpop EQLN
-ltn = cmpopbn LEQN
-len = cmpop LEQN
+eqi = binop EQLI
+lti = binop LESI
+lei = binop LEQI
+eqn = binop EQLN
+ltn = binop LESN
+len = binop LEQN
 
 gti, gtn, gei, gen :: (Var v) => SuperNormal v
-gti = cmpopn LEQI
+gti = binopSwap LESI
 gei = cmpopb LEQI
-gtn = cmpopn LEQN
+gtn = binopSwap LESN
 gen = cmpopb LEQN
 
 inci, incn :: (Var v) => SuperNormal v
@@ -462,11 +453,11 @@ atan2f = binop ATN2
 
 ltf, gtf, lef, gef, eqf, neqf :: (Var v) => SuperNormal v
 ltf = cmpopbn LEQF
-gtf = cmpopn LEQF
-lef = cmpop LEQF
+gtf = binopSwap LESF
+lef = binop LEQF
 gef = cmpopb LEQF
-eqf = cmpop EQLF
-neqf = cmpopn EQLF
+eqf = binop EQLF
+neqf = binop NEQF
 
 minf, maxf :: (Var v) => SuperNormal v
 minf = binop MINF
@@ -988,13 +979,13 @@ any'extract =
 
 -- Refs
 
- -- The docs for IORef state that IORef operations can be observed
-  -- out of order ([1]) but actually GHC does emit the appropriate
-  -- load and store barriers nowadays ([2], [3]).
-  --
-  -- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2
-  -- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286
-  -- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298
+-- The docs for IORef state that IORef operations can be observed
+-- out of order ([1]) but actually GHC does emit the appropriate
+-- load and store barriers nowadays ([2], [3]).
+--
+-- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2
+-- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286
+-- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298
 ref'read :: SuperNormal Symbol
 ref'read =
   unop0 0 $ \[ref] -> (TPrm REFR [ref])
diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs
index 898661f8a5..90935cee4a 100644
--- a/unison-runtime/src/Unison/Runtime/MCode.hs
+++ b/unison-runtime/src/Unison/Runtime/MCode.hs
@@ -346,8 +346,12 @@ data UPrim2
   | POWN
   | EQLI -- ==
   | EQLN
+  | NEQI -- !=
+  | NEQN
   | LEQI -- <=
   | LEQN
+  | LESI -- <
+  | LESN
   | ANDN -- and
   | ANDI
   | IORN -- or
@@ -356,7 +360,9 @@ data UPrim2
   | XORI
   | -- floating
     EQLF -- ==
+  | NEQF -- !=
   | LEQF -- <=
+  | LESF -- <
   | ADDF -- +
   | SUBF -- -
   | MULF
@@ -1222,9 +1228,13 @@ emitPOp ANF.SHLN = emitP2 SHLN -- Note: left shift behaves uniformly
 emitPOp ANF.SHRI = emitP2 SHRI
 emitPOp ANF.SHRN = emitP2 SHRN
 emitPOp ANF.LEQI = emitP2 LEQI
+emitPOp ANF.LESI = emitP2 LESI
 emitPOp ANF.LEQN = emitP2 LEQN
+emitPOp ANF.LESN = emitP2 LESN
 emitPOp ANF.EQLI = emitP2 EQLI
+emitPOp ANF.NEQI = emitP2 NEQI
 emitPOp ANF.EQLN = emitP2 EQLN
+emitPOp ANF.NEQN = emitP2 NEQN
 emitPOp ANF.SGNI = emitP1 SGNI
 emitPOp ANF.NEGI = emitP1 NEGI
 emitPOp ANF.INCI = emitP1 INCI
@@ -1249,7 +1259,9 @@ emitPOp ANF.SUBF = emitP2 SUBF
 emitPOp ANF.MULF = emitP2 MULF
 emitPOp ANF.DIVF = emitP2 DIVF
 emitPOp ANF.LEQF = emitP2 LEQF
+emitPOp ANF.LESF = emitP2 LESF
 emitPOp ANF.EQLF = emitP2 EQLF
+emitPOp ANF.NEQF = emitP2 NEQF
 emitPOp ANF.MINF = emitP2 MINF
 emitPOp ANF.MAXF = emitP2 MAXF
 emitPOp ANF.POWF = emitP2 POWF
diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs
index aa3b188f04..2bf8686c90 100644
--- a/unison-runtime/src/Unison/Runtime/Machine.hs
+++ b/unison-runtime/src/Unison/Runtime/Machine.hs
@@ -1325,12 +1325,24 @@ uprim2 !stk EQLI !i !j = do
   stk <- bump stk
   pokeBool stk $ m == n
   pure stk
+uprim2 !stk NEQI !i !j = do
+  m <- upeekOff stk i
+  n <- upeekOff stk j
+  stk <- bump stk
+  pokeBool stk $ m /= n
+  pure stk
 uprim2 !stk EQLN !i !j = do
   m <- peekOffN stk i
   n <- peekOffN stk j
   stk <- bump stk
   pokeBool stk $ m == n
   pure stk
+uprim2 !stk NEQN !i !j = do
+  m <- peekOffN stk i
+  n <- peekOffN stk j
+  stk <- bump stk
+  pokeBool stk $ m /= n
+  pure stk
 uprim2 !stk LEQI !i !j = do
   m <- upeekOff stk i
   n <- upeekOff stk j
@@ -1343,6 +1355,18 @@ uprim2 !stk LEQN !i !j = do
   stk <- bump stk
   pokeBool stk $ m <= n
   pure stk
+uprim2 !stk LESI !i !j = do
+  m <- upeekOff stk i
+  n <- upeekOff stk j
+  stk <- bump stk
+  pokeBool stk $ m < n
+  pure stk
+uprim2 !stk LESN !i !j = do
+  m <- peekOffN stk i
+  n <- peekOffN stk j
+  stk <- bump stk
+  pokeBool stk $ m < n
+  pure stk
 uprim2 !stk DIVN !i !j = do
   m <- peekOffN stk i
   n <- peekOffN stk j
@@ -1409,12 +1433,24 @@ uprim2 !stk EQLF !i !j = do
   stk <- bump stk
   pokeBool stk $ x == y
   pure stk
+uprim2 !stk NEQF !i !j = do
+  x <- peekOffD stk i
+  y <- peekOffD stk j
+  stk <- bump stk
+  pokeBool stk $ x /= y
+  pure stk
 uprim2 !stk LEQF !i !j = do
   x <- peekOffD stk i
   y <- peekOffD stk j
   stk <- bump stk
   pokeBool stk $ x <= y
   pure stk
+uprim2 !stk LESF !i !j = do
+  x <- peekOffD stk i
+  y <- peekOffD stk j
+  stk <- bump stk
+  pokeBool stk $ x < y
+  pure stk
 uprim2 !stk ATN2 !i !j = do
   x <- peekOffD stk i
   y <- peekOffD stk j
diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs
index 857fa7721f..13f3b5dce3 100644
--- a/unison-runtime/src/Unison/Runtime/Stack.hs
+++ b/unison-runtime/src/Unison/Runtime/Stack.hs
@@ -774,9 +774,7 @@ peekTagOff = peekOffI
 
 pokeBool :: DebugCallStack => Stack -> Bool -> IO ()
 pokeBool stk b =
-  -- Currently this is implemented as a tag, which is branched on to put a packed bool constructor on the stack, but
-  -- we'll want to change it to have its own unboxed type tag eventually.
-  pokeTag stk $ if b then 1 else 0
+  poke stk $ if b then trueVal else falseVal
 {-# INLINE pokeBool #-}
 
 -- | Store a boxed value.