From 89c2fe2a31fc8c2d348e36f29e05253e577c1e3a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Nov 2024 12:27:38 -0800 Subject: [PATCH 1/7] Define BoolVal patterns and true/false singleton vals --- unison-runtime/src/Unison/Runtime/ANF.hs | 16 +++++++++---- unison-runtime/src/Unison/Runtime/Stack.hs | 23 +++++++++++++++++++ unison-runtime/src/Unison/Runtime/TypeTags.hs | 15 ++++++++++-- 3 files changed, 47 insertions(+), 7 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index 9a217f19c1..6c0c82350d 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -15,6 +15,8 @@ module Unison.Runtime.ANF pattern TApv, pattern TCom, pattern TCon, + pattern UFalse, + pattern UTrue, pattern TKon, pattern TReq, pattern TPrm, @@ -1742,9 +1744,13 @@ anfHandled body = cc = case l of T {} -> BX; LM {} -> BX; LY {} -> BX; _ -> UN p -> pure p -fls, tru :: (Var v) => ANormal v -fls = TCon Ty.booleanRef 0 [] -tru = TCon Ty.booleanRef 1 [] +pattern UFalse <- TCon ((== Ty.booleanRef) -> True) 0 [] + where + UFalse = TCon Ty.booleanRef 0 [] + +pattern UTrue <- TCon ((== Ty.booleanRef) -> True) 1 [] + where + UTrue = TCon Ty.booleanRef 1 [] -- Helper function for renaming a variable arising from a -- let v = u @@ -1882,7 +1888,7 @@ anfBlock (And' l r) = do let tree = TMatch vl . MatchDataCover Ty.booleanRef $ mapFromList - [ (0, ([], fls)), + [ (0, ([], UFalse)), (1, ([], tmr)) ] pure (lctx, (Indirect () <> d, tree)) @@ -1892,7 +1898,7 @@ anfBlock (Or' l r) = do let tree = TMatch vl . MatchDataCover Ty.booleanRef $ mapFromList - [ (1, ([], tru)), + [ (1, ([], UTrue)), (0, ([], tmr)) ] pure (lctx, (Indirect () <> d, tree)) diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index 0051285ff7..857fa7721f 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -40,10 +40,13 @@ module Unison.Runtime.Stack NatVal, DoubleVal, IntVal, + BoolVal, UnboxedVal, BoxedVal ), emptyVal, + falseVal, + trueVal, boxedVal, USeq, traceK, @@ -140,6 +143,7 @@ import Unison.Runtime.ANF (PackedTag) import Unison.Runtime.Array import Unison.Runtime.Foreign import Unison.Runtime.MCode +import Unison.Runtime.TypeTags qualified as TT import Unison.Type qualified as Ty import Unison.Util.EnumContainers as EC import Prelude hiding (words) @@ -414,6 +418,25 @@ pattern IntVal i <- (matchIntVal -> Just i) where IntVal i = Val i intTypeTag +matchBoolVal :: Val -> Maybe Bool +matchBoolVal = \case + (BoxedVal (Enum r t)) | r == Ty.booleanRef -> Just (t == TT.falseTag) + _ -> Nothing + +pattern BoolVal :: Bool -> Val +pattern BoolVal b <- (matchBoolVal -> Just b) + where + BoolVal b = if b then (BoxedVal (Enum Ty.booleanRef TT.trueTag)) else (BoxedVal (Enum Ty.booleanRef TT.trueTag)) + +-- Define singletons we can use for the bools to prevent allocation where possible. +falseVal :: Val +falseVal = BoxedVal (Enum Ty.booleanRef TT.falseTag) +{-# NOINLINE falseVal #-} + +trueVal :: Val +trueVal = BoxedVal (Enum Ty.booleanRef TT.trueTag) +{-# NOINLINE trueVal #-} + doubleToInt :: Double -> Int doubleToInt d = indexByteArray (BA.byteArrayFromList [d]) 0 {-# INLINE doubleToInt #-} diff --git a/unison-runtime/src/Unison/Runtime/TypeTags.hs b/unison-runtime/src/Unison/Runtime/TypeTags.hs index 8bccb00f81..e489138414 100644 --- a/unison-runtime/src/Unison/Runtime/TypeTags.hs +++ b/unison-runtime/src/Unison/Runtime/TypeTags.hs @@ -13,6 +13,8 @@ module Unison.Runtime.TypeTags unitTag, leftTag, rightTag, + falseTag, + trueTag, ) where @@ -126,6 +128,12 @@ charTag = mkSimpleTag "charTag" Ty.charRef unitTag :: PackedTag unitTag = mkSimpleTag "unitTag" Ty.unitRef +falseTag :: PackedTag +falseTag = mkEnumTag "falseTag" Ty.booleanRef 0 + +trueTag :: PackedTag +trueTag = mkEnumTag "trueTag" Ty.booleanRef 1 + leftTag, rightTag :: PackedTag (leftTag, rightTag) | Just n <- Map.lookup Ty.eitherRef builtinTypeNumbering, @@ -137,8 +145,11 @@ leftTag, rightTag :: PackedTag -- | Construct a tag for a single-constructor builtin type mkSimpleTag :: String -> Reference -> PackedTag -mkSimpleTag msg r +mkSimpleTag msg r = mkEnumTag msg r 0 + +mkEnumTag :: String -> Reference -> Int -> PackedTag +mkEnumTag msg r i | Just n <- Map.lookup r builtinTypeNumbering, rt <- toEnum (fromIntegral n) = - packTags rt 0 + packTags rt (toEnum i) | otherwise = internalBug $ "internal error: " <> msg From 9d5911fc12728e003959745542c3b80f7b6edf1b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Nov 2024 12:51:43 -0800 Subject: [PATCH 2/7] 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. From 2424312be2fe20a3ef99c29895cdfc8978b281d8 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Nov 2024 14:59:31 -0800 Subject: [PATCH 3/7] Remove boolift/notlift --- unison-runtime/src/Unison/Runtime/ANF.hs | 6 + .../src/Unison/Runtime/ANF/Serialize.hs | 11 + unison-runtime/src/Unison/Runtime/Builtin.hs | 121 +++------- .../src/Unison/Runtime/Foreign/Function.hs | 10 +- unison-runtime/src/Unison/Runtime/MCode.hs | 13 ++ unison-runtime/src/Unison/Runtime/Machine.hs | 35 ++- .../src/Unison/Runtime/Serialize.hs | 214 ++++++++++-------- unison-runtime/src/Unison/Runtime/Stack.hs | 18 ++ 8 files changed, 233 insertions(+), 195 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index cc0db3e12b..259987f07c 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -1404,6 +1404,8 @@ data POp | -- Universal operations EQLU -- == | CMPU -- compare + | LEQU -- <= + | LESU -- < | EROR -- error | -- Code MISS -- isMissing @@ -1431,6 +1433,10 @@ data POp | RCAS -- Ref.cas | RRFC -- Ref.readForCas | TIKR -- Ref.Ticket.read + -- Bools + | NOTB -- not + | ANDB -- and + | IORB -- or deriving (Show, Eq, Ord, Enum, Bounded) type ANormal = ABTN.Term ANormalF diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index a629401dca..9b6c575232 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -662,6 +662,17 @@ pOpCode op = case op of RCAS -> 134 RRFC -> 135 TIKR -> 136 + LESI -> 137 + NEQI -> 138 + LESN -> 139 + NEQN -> 140 + LESF -> 141 + NEQF -> 142 + LEQU -> 143 + LESU -> 144 + NOTB -> 145 + ANDB -> 146 + IORB -> 147 pOpAssoc :: [(POp, Word16)] pOpAssoc = map (\op -> (op, pOpCode op)) [minBound .. maxBound] diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 488e0cb526..26d9c1f042 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -282,14 +282,6 @@ seqViewEmpty = TCon Ty.seqViewRef (fromIntegral Ty.seqViewEmpty) [] seqViewElem :: (Var v) => v -> v -> ANormal v seqViewElem l r = TCon Ty.seqViewRef (fromIntegral Ty.seqViewElem) [l, r] -boolift :: (Var v) => v -> ANormal v -boolift v = - TMatch v $ MatchIntegral (mapFromList [(0, fls), (1, tru)]) Nothing - -notlift :: (Var v) => v -> ANormal v -notlift v = - TMatch v $ MatchIntegral (mapFromList [(1, fls), (0, tru)]) Nothing - unenum :: (Var v) => Int -> v -> Reference -> v -> ANormal v -> ANormal v unenum n v0 r v nx = TMatch v0 $ MatchData r cases Nothing @@ -330,20 +322,6 @@ binopSwap :: (Var v) => POp -> SuperNormal v binopSwap pop = binop0 0 $ \[x, y] -> TPrm pop [y, x] --- | 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 `binop`, but swaps arguments then negates the result. -cmpopbn :: (Var v) => POp -> SuperNormal v -cmpopbn pop = - binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm pop [y, x]) $ - notlift b - addi, subi, muli, divi, modi, shli, shri, powi :: (Var v) => SuperNormal v addi = binop ADDI subi = binop SUBI @@ -375,9 +353,9 @@ len = binop LEQN gti, gtn, gei, gen :: (Var v) => SuperNormal v gti = binopSwap LESI -gei = cmpopb LEQI +gei = binopSwap LEQI gtn = binopSwap LESN -gen = cmpopb LEQN +gen = binopSwap LEQN inci, incn :: (Var v) => SuperNormal v inci = unop INCI @@ -452,10 +430,10 @@ atanhf = unop ATNH atan2f = binop ATN2 ltf, gtf, lef, gef, eqf, neqf :: (Var v) => SuperNormal v -ltf = cmpopbn LEQF +ltf = binop LESF gtf = binopSwap LESF lef = binop LEQF -gef = cmpopb LEQF +gef = binopSwap LEQF eqf = binop EQLF neqf = binop NEQF @@ -628,24 +606,18 @@ splitrs = binop0 3 $ \[n, s, t, l, r] -> ] eqt, neqt, leqt, geqt, lesst, great :: SuperNormal Symbol -eqt = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm EQLT [x, y]) $ - boolift b +eqt = binop EQLT neqt = binop0 1 $ \[x, y, b] -> TLetD b UN (TPrm EQLT [x, y]) $ - notlift b -leqt = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm LEQT [x, y]) $ - boolift b -geqt = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm LEQT [y, x]) $ - boolift b + TPrm NOTB [b] +leqt = binop LEQT +geqt = binopSwap LEQT lesst = binop0 1 $ \[x, y, b] -> TLetD b UN (TPrm LEQT [y, x]) $ - notlift b + TPrm NOTB [b] great = binop0 1 $ \[x, y, b] -> TLetD b UN (TPrm LEQT [x, y]) $ - notlift b + TPrm NOTB [b] packt, unpackt :: SuperNormal Symbol packt = unop0 0 $ \[s] -> TPrm PAKT [s] @@ -712,61 +684,31 @@ t2f = unop0 2 $ \[x, t, f] -> ] equ :: SuperNormal Symbol -equ = binop0 1 $ \[x, y, b] -> - TLetD b UN (TPrm EQLU [x, y]) $ - boolift b +equ = binop EQLU cmpu :: SuperNormal Symbol -cmpu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) $ - (TPrm DECI [c]) +cmpu = binop CMPU ltu :: SuperNormal Symbol -ltu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) - . TMatch c - $ MatchIntegral - (mapFromList [(0, TCon Ty.booleanRef 1 [])]) - (Just $ TCon Ty.booleanRef 0 []) +ltu = binop LESU gtu :: SuperNormal Symbol -gtu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) - . TMatch c - $ MatchIntegral - (mapFromList [(2, TCon Ty.booleanRef 1 [])]) - (Just $ TCon Ty.booleanRef 0 []) +gtu = binopSwap LESU geu :: SuperNormal Symbol -geu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) - . TMatch c - $ MatchIntegral - (mapFromList [(0, TCon Ty.booleanRef 0 [])]) - (Just $ TCon Ty.booleanRef 1 []) +geu = binopSwap LEQU leu :: SuperNormal Symbol -leu = binop0 1 $ \[x, y, c] -> - TLetD c UN (TPrm CMPU [x, y]) - . TMatch c - $ MatchIntegral - (mapFromList [(2, TCon Ty.booleanRef 0 [])]) - (Just $ TCon Ty.booleanRef 1 []) +leu = binop LEQU notb :: SuperNormal Symbol -notb = unop0 0 $ \[b] -> - TMatch b . flip (MatchData Ty.booleanRef) Nothing $ - mapFromList [(0, ([], tru)), (1, ([], fls))] +notb = unop NOTB orb :: SuperNormal Symbol -orb = binop0 0 $ \[p, q] -> - TMatch p . flip (MatchData Ty.booleanRef) Nothing $ - mapFromList [(1, ([], tru)), (0, ([], TVar q))] +orb = binop IORB andb :: SuperNormal Symbol -andb = binop0 0 $ \[p, q] -> - TMatch p . flip (MatchData Ty.booleanRef) Nothing $ - mapFromList [(0, ([], fls)), (1, ([], TVar q))] +andb = binop ANDB -- A runtime type-cast. Used to unsafely coerce between unboxed -- types at runtime without changing their representation. @@ -865,10 +807,7 @@ debug'text = ] code'missing :: SuperNormal Symbol -code'missing = - unop0 1 $ \[link, b] -> - TLetD b UN (TPrm MISS [link]) $ - boolift b +code'missing = unop MISS code'cache :: SuperNormal Symbol code'cache = unop0 0 $ \[new] -> TPrm CACH [new] @@ -923,13 +862,7 @@ value'create :: SuperNormal Symbol value'create = unop0 0 $ \[x] -> TPrm VALU [x] check'sandbox :: SuperNormal Symbol -check'sandbox = - Lambda [BX, BX] - . TAbss [refs, val] - . TLetD b UN (TPrm SDBX [refs, val]) - $ boolift b - where - (refs, val, b) = fresh +check'sandbox = binop SDBX sandbox'links :: SuperNormal Symbol sandbox'links = Lambda [BX] . TAbs ln $ TPrm SDBL [ln] @@ -1011,10 +944,9 @@ ref'cas :: SuperNormal Symbol ref'cas = Lambda [BX, BX, BX] . TAbss [x, y, z] - . TLetD b UN (TPrm RCAS [x, y, z]) - $ boolift b + $ TPrm RCAS [x, y, z] where - (x, y, z, b) = fresh + (x, y, z) = fresh ref'ticket'read :: SuperNormal Symbol ref'ticket'read = unop0 0 $ TPrm TIKR @@ -1391,8 +1323,7 @@ outIoFailBool stack1 stack2 stack3 extra fail result = ( 1, ([UN],) . TAbs stack3 - . TLet (Indirect 1) extra BX (boolift stack3) - $ right extra + $ right stack3 ) ] @@ -1488,9 +1419,9 @@ argNToBool :: Int -> ForeignOp argNToBool n instr = (replicate n BX,) . TAbss args - $ TLetD result UN (TFOp instr args) (boolift result) + $ TFOp instr args where - (result : args) = freshes (n + 1) + args = freshes n argNDirect :: Int -> ForeignOp argNDirect n instr = diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 13b85e2b14..60808351e1 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -295,8 +295,14 @@ instance ForeignConvention Double where pure stk instance ForeignConvention Bool where - readForeign = readForeignEnum - writeForeign = writeForeignEnum + readForeign (i : args) stk = do + b <- peekOffBool stk i + pure (args, b) + readForeign _ _ = foreignCCError "Bool" + writeForeign stk b = do + stk <- bump stk + pokeBool stk b + pure stk instance ForeignConvention String where readForeign = readForeignAs unpack diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 90935cee4a..b307c8a935 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -324,6 +324,8 @@ data UPrim1 | TRNF -- truncate | RNDF -- round | TRNC -- truncate + -- Bools + | NOTB -- not deriving (Show, Eq, Ord, Enum, Bounded) data UPrim2 @@ -374,6 +376,9 @@ data UPrim2 | MINF -- min | CAST -- unboxed runtime type cast (int to nat, etc.) | DRPN -- dropn + -- Bools + | ANDB -- and + | IORB -- or deriving (Show, Eq, Ord, Enum, Bounded) data BPrim1 @@ -419,6 +424,8 @@ data BPrim2 = -- universal EQLU -- == | CMPU -- compare + | LEQU -- <= + | LESU -- < -- text | DRPT -- drop | CATT -- append @@ -1333,6 +1340,8 @@ emitPOp ANF.FLTB = emitBP1 FLTB emitPOp ANF.CATB = emitBP2 CATB -- universal comparison emitPOp ANF.EQLU = emitBP2 EQLU +emitPOp ANF.LEQU = emitBP2 LEQU +emitPOp ANF.LESU = emitBP2 LESU emitPOp ANF.CMPU = emitBP2 CMPU -- code operations emitPOp ANF.MISS = emitBP1 MISS @@ -1358,6 +1367,10 @@ emitPOp ANF.RRFC = emitBP1 RRFC emitPOp ANF.TIKR = emitBP1 TIKR -- non-prim translations emitPOp ANF.BLDS = Seq +-- Bools +emitPOp ANF.NOTB = emitP1 NOTB +emitPOp ANF.ANDB = emitP2 ANDB +emitPOp ANF.IORB = emitP2 IORB emitPOp ANF.FORK = \case VArg1 i -> Fork i _ -> internalBug "fork takes exactly one boxed argument" diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 2bf8686c90..596f355353 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -374,7 +374,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 MISS i) _ -> error "exec:BPrim1:MISS: Expected Ref" m <- readTVarIO (intermed env) stk <- bump stk - pokeTag stk $ if (link `M.member` m) then 1 else 0 + pokeBool stk $ (link `M.member` m) pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) | sandboxed env = die "attempted to use sandboxed operation: cache" @@ -517,11 +517,23 @@ exec !_ !denv !_activeThreads !stk !k _ (BPrim2 EQLU i j) = do stk <- bump stk pokeBool stk $ universalEq (==) x y pure (denv, stk, k) +exec !_ !denv !_activeThreads !stk !k _ (BPrim2 LEQU i j) = do + x <- peekOff stk i + y <- peekOff stk j + stk <- bump stk + pokeBool stk $ (universalCompare compare x y) /= GT + pure (denv, stk, k) +exec !_ !denv !_activeThreads !stk !k _ (BPrim2 LESU i j) = do + x <- peekOff stk i + y <- peekOff stk j + stk <- bump stk + pokeBool stk $ (universalCompare compare x y) == LT + pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (BPrim2 CMPU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk - pokeI stk . fromEnum $ universalCompare compare x y + pokeI stk . pred . fromEnum $ universalCompare compare x y pure (denv, stk, k) exec !_ !_ !_activeThreads !stk !k r (BPrim2 THRO i j) = do name <- peekOffBi @Util.Text.Text stk i @@ -1225,6 +1237,11 @@ uprim1 !stk COMI !i = do stk <- bump stk pokeI stk (complement n) pure stk +uprim1 !stk NOTB !i = do + b <- peekOffBool stk i + stk <- bump stk + pokeBool stk (not b) + pure stk {-# INLINE uprim1 #-} uprim2 :: Stack -> UPrim2 -> Int -> Int -> IO Stack @@ -1499,6 +1516,18 @@ uprim2 !stk CAST !vi !ti = do stk <- bump stk poke stk $ UnboxedVal v (unboxedTypeTagFromInt newTypeTag) pure stk +uprim2 !stk ANDB !i !j = do + x <- peekOffBool stk i + y <- peekOffBool stk j + stk <- bump stk + pokeBool stk (x && y) + pure stk +uprim2 !stk IORB !i !j = do + x <- peekOffBool stk i + y <- peekOffBool stk j + stk <- bump stk + pokeBool stk (x || y) + pure stk {-# INLINE uprim2 #-} bprim1 :: @@ -1913,6 +1942,8 @@ bprim2 !stk REFW i j = do bprim2 !stk THRO _ _ = pure stk -- impossible bprim2 !stk TRCE _ _ = pure stk -- impossible bprim2 !stk EQLU _ _ = pure stk -- impossible +bprim2 !stk LEQU _ _ = pure stk -- impossible +bprim2 !stk LESU _ _ = pure stk -- impossible bprim2 !stk CMPU _ _ = pure stk -- impossible bprim2 !stk SDBX _ _ = pure stk -- impossible bprim2 !stk SDBV _ _ = pure stk -- impossible diff --git a/unison-runtime/src/Unison/Runtime/Serialize.hs b/unison-runtime/src/Unison/Runtime/Serialize.hs index 6b5c1979b3..251040ff5d 100644 --- a/unison-runtime/src/Unison/Runtime/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/Serialize.hs @@ -329,6 +329,7 @@ instance Tag UPrim1 where tag2word TRNF = 31 tag2word RNDF = 32 tag2word TRNC = 33 + tag2word NOTB = 34 word2tag 0 = pure DECI word2tag 1 = pure DECN @@ -364,6 +365,7 @@ instance Tag UPrim1 where word2tag 31 = pure TRNF word2tag 32 = pure RNDF word2tag 33 = pure TRNC + word2tag 34 = pure NOTB word2tag n = unknownTag "UPrim1" n instance Tag UPrim2 where @@ -384,28 +386,36 @@ instance Tag UPrim2 where tag2word POWI = 14 tag2word POWN = 15 tag2word EQLI = 16 - tag2word EQLN = 17 - tag2word LEQI = 18 - tag2word LEQN = 19 - tag2word ANDN = 20 - tag2word ANDI = 21 - tag2word IORN = 22 - tag2word IORI = 23 - tag2word XORN = 24 - tag2word XORI = 25 - tag2word EQLF = 26 - tag2word LEQF = 27 - tag2word ADDF = 28 - tag2word SUBF = 29 - tag2word MULF = 30 - tag2word DIVF = 31 - tag2word ATN2 = 32 - tag2word POWF = 33 - tag2word LOGB = 34 - tag2word MAXF = 35 - tag2word MINF = 36 - tag2word CAST = 37 - tag2word DRPN = 38 + tag2word NEQI = 17 + tag2word EQLN = 18 + tag2word NEQN = 19 + tag2word LEQI = 20 + tag2word LEQN = 21 + tag2word LESI = 22 + tag2word LESN = 23 + tag2word ANDN = 24 + tag2word ANDI = 25 + tag2word IORN = 26 + tag2word IORI = 27 + tag2word XORN = 28 + tag2word XORI = 29 + tag2word EQLF = 30 + tag2word NEQF = 31 + tag2word LEQF = 32 + tag2word LESF = 33 + tag2word ADDF = 34 + tag2word SUBF = 35 + tag2word MULF = 36 + tag2word DIVF = 37 + tag2word ATN2 = 38 + tag2word POWF = 39 + tag2word LOGB = 40 + tag2word MAXF = 41 + tag2word MINF = 42 + tag2word CAST = 43 + tag2word DRPN = 44 + tag2word ANDB = 45 + tag2word IORB = 46 word2tag 0 = pure ADDI word2tag 1 = pure ADDN @@ -424,28 +434,36 @@ instance Tag UPrim2 where word2tag 14 = pure POWI word2tag 15 = pure POWN word2tag 16 = pure EQLI - word2tag 17 = pure EQLN - word2tag 18 = pure LEQI - word2tag 19 = pure LEQN - word2tag 20 = pure ANDN - word2tag 21 = pure ANDI - word2tag 22 = pure IORN - word2tag 23 = pure IORI - word2tag 24 = pure XORN - word2tag 25 = pure XORI - word2tag 26 = pure EQLF - word2tag 27 = pure LEQF - word2tag 28 = pure ADDF - word2tag 29 = pure SUBF - word2tag 30 = pure MULF - word2tag 31 = pure DIVF - word2tag 32 = pure ATN2 - word2tag 33 = pure POWF - word2tag 34 = pure LOGB - word2tag 35 = pure MAXF - word2tag 36 = pure MINF - word2tag 37 = pure CAST - word2tag 38 = pure DRPN + word2tag 17 = pure NEQI + word2tag 18 = pure EQLN + word2tag 19 = pure NEQN + word2tag 20 = pure LEQI + word2tag 21 = pure LEQN + word2tag 22 = pure LESI + word2tag 23 = pure LESN + word2tag 24 = pure ANDN + word2tag 25 = pure ANDI + word2tag 26 = pure IORN + word2tag 27 = pure IORI + word2tag 28 = pure XORN + word2tag 29 = pure XORI + word2tag 30 = pure EQLF + word2tag 31 = pure NEQF + word2tag 32 = pure LEQF + word2tag 33 = pure LESF + word2tag 34 = pure ADDF + word2tag 35 = pure SUBF + word2tag 36 = pure MULF + word2tag 37 = pure DIVF + word2tag 38 = pure ATN2 + word2tag 39 = pure POWF + word2tag 40 = pure LOGB + word2tag 41 = pure MAXF + word2tag 42 = pure MINF + word2tag 43 = pure CAST + word2tag 44 = pure DRPN + word2tag 45 = pure ANDB + word2tag 46 = pure IORB word2tag n = unknownTag "UPrim2" n instance Tag BPrim1 where @@ -516,58 +534,62 @@ instance Tag BPrim1 where instance Tag BPrim2 where tag2word EQLU = 0 - tag2word CMPU = 1 - tag2word DRPT = 2 - tag2word CATT = 3 - tag2word TAKT = 4 - tag2word EQLT = 5 - tag2word LEQT = 6 - tag2word LEST = 7 - tag2word DRPS = 8 - tag2word CATS = 9 - tag2word TAKS = 10 - tag2word CONS = 11 - tag2word SNOC = 12 - tag2word IDXS = 13 - tag2word SPLL = 14 - tag2word SPLR = 15 - tag2word TAKB = 16 - tag2word DRPB = 17 - tag2word IDXB = 18 - tag2word CATB = 19 - tag2word THRO = 20 - tag2word TRCE = 21 - tag2word SDBX = 22 - tag2word IXOT = 23 - tag2word IXOB = 24 - tag2word SDBV = 25 - tag2word REFW = 26 + tag2word LEQU = 1 + tag2word LESU = 2 + tag2word CMPU = 3 + tag2word DRPT = 4 + tag2word CATT = 5 + tag2word TAKT = 6 + tag2word EQLT = 7 + tag2word LEQT = 8 + tag2word LEST = 9 + tag2word DRPS = 10 + tag2word CATS = 11 + tag2word TAKS = 12 + tag2word CONS = 13 + tag2word SNOC = 14 + tag2word IDXS = 15 + tag2word SPLL = 16 + tag2word SPLR = 17 + tag2word TAKB = 18 + tag2word DRPB = 19 + tag2word IDXB = 20 + tag2word CATB = 21 + tag2word THRO = 22 + tag2word TRCE = 23 + tag2word SDBX = 24 + tag2word IXOT = 25 + tag2word IXOB = 26 + tag2word SDBV = 27 + tag2word REFW = 28 word2tag 0 = pure EQLU - word2tag 1 = pure CMPU - word2tag 2 = pure DRPT - word2tag 3 = pure CATT - word2tag 4 = pure TAKT - word2tag 5 = pure EQLT - word2tag 6 = pure LEQT - word2tag 7 = pure LEST - word2tag 8 = pure DRPS - word2tag 9 = pure CATS - word2tag 10 = pure TAKS - word2tag 11 = pure CONS - word2tag 12 = pure SNOC - word2tag 13 = pure IDXS - word2tag 14 = pure SPLL - word2tag 15 = pure SPLR - word2tag 16 = pure TAKB - word2tag 17 = pure DRPB - word2tag 18 = pure IDXB - word2tag 19 = pure CATB - word2tag 20 = pure THRO - word2tag 21 = pure TRCE - word2tag 22 = pure SDBX - word2tag 23 = pure IXOT - word2tag 24 = pure IXOB - word2tag 25 = pure SDBV - word2tag 26 = pure REFW + word2tag 1 = pure LEQU + word2tag 2 = pure LESU + word2tag 3 = pure CMPU + word2tag 4 = pure DRPT + word2tag 5 = pure CATT + word2tag 6 = pure TAKT + word2tag 7 = pure EQLT + word2tag 8 = pure LEQT + word2tag 9 = pure LEST + word2tag 10 = pure DRPS + word2tag 11 = pure CATS + word2tag 12 = pure TAKS + word2tag 13 = pure CONS + word2tag 14 = pure SNOC + word2tag 15 = pure IDXS + word2tag 16 = pure SPLL + word2tag 17 = pure SPLR + word2tag 18 = pure TAKB + word2tag 19 = pure DRPB + word2tag 20 = pure IDXB + word2tag 21 = pure CATB + word2tag 22 = pure THRO + word2tag 23 = pure TRCE + word2tag 24 = pure SDBX + word2tag 25 = pure IXOT + word2tag 26 = pure IXOB + word2tag 27 = pure SDBV + word2tag 28 = pure REFW word2tag n = unknownTag "BPrim2" n diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index 13f3b5dce3..d689680202 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -81,6 +81,8 @@ module Unison.Runtime.Stack peekOffBi, pokeBi, pokeOffBi, + peekBool, + peekOffBool, peekOffS, pokeS, pokeOffS, @@ -1117,6 +1119,22 @@ peekOffBi :: (BuiltinForeign b) => Stack -> Int -> IO b peekOffBi stk i = unwrapForeign . marshalToForeign <$> bpeekOff stk i {-# INLINE peekOffBi #-} +peekBool :: Stack -> IO Bool +peekBool stk = do + b <- bpeek stk + pure $ case b of + Enum _ t -> t /= TT.falseTag + _ -> error "peekBool: not a boolean" +{-# INLINE peekBool #-} + +peekOffBool :: Stack -> Int -> IO Bool +peekOffBool stk i = do + b <- bpeekOff stk i + pure $ case b of + Enum _ t -> t /= TT.falseTag + _ -> error "peekBool: not a boolean" +{-# INLINE peekOffBool #-} + peekOffS :: Stack -> Int -> IO USeq peekOffS stk i = unwrapForeign . marshalToForeign <$> bpeekOff stk i From 845833c22599dd571bddd411eb66bcbdf57cc1c2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Nov 2024 15:30:08 -0800 Subject: [PATCH 4/7] Remove superfluous bool combinators --- unison-runtime/src/Unison/Runtime/Builtin.hs | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 26d9c1f042..16f49e9316 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -1414,15 +1414,6 @@ arg2To0 instr = where (arg1, arg2) = fresh --- ... -> Bool -argNToBool :: Int -> ForeignOp -argNToBool n instr = - (replicate n BX,) - . TAbss args - $ TFOp instr args - where - args = freshes n - argNDirect :: Int -> ForeignOp argNDirect n instr = (replicate n BX,) @@ -2253,7 +2244,7 @@ declareForeigns = do . mkForeignIOF $ \(mv :: MVar Val, x) -> swapMVar mv x - declareForeign Tracked "MVar.isEmpty" (argNToBool 1) + declareForeign Tracked "MVar.isEmpty" (argNDirect 1) . mkForeign $ \(mv :: MVar Val) -> isEmptyMVar mv @@ -2348,7 +2339,7 @@ declareForeigns = do declareForeign Tracked "Promise.tryRead" argToMaybe . mkForeign $ \(p :: Promise Val) -> tryReadPromise p - declareForeign Tracked "Promise.write" (argNToBool 2) . mkForeign $ + declareForeign Tracked "Promise.write" (argNDirect 2) . mkForeign $ \(p :: Promise Val, a :: Val) -> writePromise p a declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF . mkForeignTls $ @@ -2784,7 +2775,7 @@ declareForeigns = do declareForeign Untracked "Pattern.run" arg2ToMaybeTup . mkForeign $ \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input - declareForeign Untracked "Pattern.isMatch" (argNToBool 2) . mkForeign $ + declareForeign Untracked "Pattern.isMatch" (argNDirect 2) . mkForeign $ \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input declareForeign Untracked "Char.Class.any" direct . mkForeign $ \() -> pure TPat.Any @@ -2809,7 +2800,7 @@ declareForeigns = do declareForeign Untracked "Char.Class.symbol" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) declareForeign Untracked "Char.Class.separator" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) declareForeign Untracked "Char.Class.letter" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) - declareForeign Untracked "Char.Class.is" (argNToBool 2) . mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c + declareForeign Untracked "Char.Class.is" (argNDirect 2) . mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c declareForeign Untracked "Text.patterns.char" (argNDirect 1) . mkForeign $ \c -> let v = TPat.cpattern (TPat.Char c) in pure v From 17531ab775cece8839592197269748dbfc252785 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 18 Nov 2024 14:03:00 -0800 Subject: [PATCH 5/7] Fix up bool pattern matching --- unison-runtime/src/Unison/Runtime/Stack.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index d689680202..2c8b001bb4 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -428,7 +428,7 @@ matchBoolVal = \case pattern BoolVal :: Bool -> Val pattern BoolVal b <- (matchBoolVal -> Just b) where - BoolVal b = if b then (BoxedVal (Enum Ty.booleanRef TT.trueTag)) else (BoxedVal (Enum Ty.booleanRef TT.trueTag)) + BoolVal b = if b then trueVal else falseVal -- Define singletons we can use for the bools to prevent allocation where possible. falseVal :: Val From 91b64058bbb4c1d04a0b5fd8c20355db1b8ae139 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 21 Nov 2024 11:14:17 -0800 Subject: [PATCH 6/7] Fix Stack.hs in stackcheck mode --- unison-runtime/src/Unison/Runtime/Stack.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index 2c8b001bb4..4e0375c957 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -152,10 +152,6 @@ import Prelude hiding (words) {- ORMOLU_DISABLE -} #ifdef STACK_CHECK -import Data.Text.IO (hPutStrLn) -import UnliftIO (stderr, throwIO) -import GHC.Stack (CallStack, callStack) - type DebugCallStack = (HasCallStack :: Constraint) unboxedSentinel :: Int From b04aa8bb8eb2c7720d55e01453340b3380261c7a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 21 Nov 2024 13:40:07 -0800 Subject: [PATCH 7/7] Add dumpcore flag --- unison-runtime/package.yaml | 6 +++++- unison-runtime/unison-runtime.cabal | 8 ++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/unison-runtime/package.yaml b/unison-runtime/package.yaml index e9221c6d3e..850a83046c 100644 --- a/unison-runtime/package.yaml +++ b/unison-runtime/package.yaml @@ -11,13 +11,17 @@ flags: stackchecks: manual: true default: false + dumpcore: + manual: true + default: false when: - condition: flag(arraychecks) cpp-options: -DARRAY_CHECK - condition: flag(stackchecks) cpp-options: -DSTACK_CHECK - + - condition: flag(dumpcore) + ghc-options: -ddump-simpl -ddump-stg-final -ddump-to-file -dsuppress-coercions -dsuppress-idinfo -dsuppress-module-prefixes # -dsuppress-type-applications -dsuppress-type-signatures library: source-dirs: src diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index cc6e59bc6a..a23132a3f9 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -21,6 +21,10 @@ flag arraychecks manual: True default: False +flag dumpcore + manual: True + default: False + flag stackchecks manual: True default: False @@ -142,6 +146,8 @@ library cpp-options: -DARRAY_CHECK if flag(stackchecks) cpp-options: -DSTACK_CHECK + if flag(dumpcore) + ghc-options: -ddump-simpl -ddump-stg-final -ddump-to-file -dsuppress-coercions -dsuppress-idinfo -dsuppress-module-prefixes test-suite runtime-tests type: exitcode-stdio-1.0 @@ -221,3 +227,5 @@ test-suite runtime-tests cpp-options: -DARRAY_CHECK if flag(stackchecks) cpp-options: -DSTACK_CHECK + if flag(dumpcore) + ghc-options: -ddump-simpl -ddump-stg-final -ddump-to-file -dsuppress-coercions -dsuppress-idinfo -dsuppress-module-prefixes