diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index 6bbcaa9cac..994b29c96f 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -36,6 +36,8 @@ data DebugFlag | -- | Useful for adding temporary debugging statements during development. -- Remove uses of Debug.Temp before merging to keep things clean for the next person :) Temp + | -- | Debugging the interpreter + Interpreter | -- | Shows Annotations when printing terms Annotations | -- | Debug endpoints of the local UI (or Share) server @@ -65,6 +67,7 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of "LSP" -> pure LSP "TIMING" -> pure Timing "TEMP" -> pure Temp + "INTERPRETER" -> pure Interpreter "ANNOTATIONS" -> pure Annotations "SERVER" -> pure Server "PATTERN_COVERAGE" -> pure PatternCoverage @@ -114,6 +117,10 @@ debugTemp :: Bool debugTemp = Temp `Set.member` debugFlags {-# NOINLINE debugTemp #-} +debugInterpreter :: Bool +debugInterpreter = Interpreter `Set.member` debugFlags +{-# NOINLINE debugInterpreter #-} + debugAnnotations :: Bool debugAnnotations = Annotations `Set.member` debugFlags {-# NOINLINE debugAnnotations #-} @@ -187,6 +194,7 @@ shouldDebug = \case LSP -> debugLSP Timing -> debugTiming Temp -> debugTemp + Interpreter -> debugInterpreter Annotations -> debugAnnotations Server -> debugServer PatternCoverage -> debugPatternCoverage diff --git a/parser-typechecker/src/Unison/Codebase/Runtime.hs b/parser-typechecker/src/Unison/Codebase/Runtime.hs index b9c92aec5e..f790076f27 100644 --- a/parser-typechecker/src/Unison/Codebase/Runtime.hs +++ b/parser-typechecker/src/Unison/Codebase/Runtime.hs @@ -34,7 +34,7 @@ data CompileOpts = COpts } defaultCompileOpts :: CompileOpts -defaultCompileOpts = COpts { profile = False } +defaultCompileOpts = COpts {profile = False} data Runtime v = Runtime { terminate :: IO (), diff --git a/parser-typechecker/src/Unison/Util/EnumContainers.hs b/parser-typechecker/src/Unison/Util/EnumContainers.hs index 0a84aa4dd2..fe62ee69d7 100644 --- a/parser-typechecker/src/Unison/Util/EnumContainers.hs +++ b/parser-typechecker/src/Unison/Util/EnumContainers.hs @@ -32,6 +32,7 @@ module Unison.Util.EnumContainers where import Data.Bifunctor +import Data.Functor.Classes (Eq1, Ord1) import Data.IntMap.Strict qualified as IM import Data.IntSet qualified as IS import Data.Word (Word16, Word64) @@ -60,7 +61,9 @@ newtype EnumMap k a = EM (IM.IntMap a) ) deriving newtype ( Monoid, - Semigroup + Semigroup, + Eq1, + Ord1 ) newtype EnumSet k = ES IS.IntSet diff --git a/unison-runtime/package.yaml b/unison-runtime/package.yaml index ec35ffbd1d..e9221c6d3e 100644 --- a/unison-runtime/package.yaml +++ b/unison-runtime/package.yaml @@ -8,10 +8,15 @@ flags: arraychecks: manual: true default: false + stackchecks: + manual: true + default: false when: - condition: flag(arraychecks) cpp-options: -DARRAY_CHECK + - condition: flag(stackchecks) + cpp-options: -DSTACK_CHECK library: diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index 0cdd4cb213..3e06f7dc0b 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -54,10 +54,10 @@ module Unison.Runtime.ANF ANormal, RTag, CTag, + PackedTag (..), Tag (..), GroupRef (..), Code (..), - UBValue, ValList, Value (..), Cont (..), @@ -92,12 +92,11 @@ module Unison.Runtime.ANF where import Control.Exception (throw) -import Control.Lens (foldMapOf, folded, snoc, unsnoc, _Right) +import Control.Lens (snoc, unsnoc) import Control.Monad.Reader (ReaderT (..), ask, local) import Control.Monad.State (MonadState (..), State, gets, modify, runState) import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import Data.Functor.Compose (Compose (..)) import Data.List hiding (and, or) import Data.Map qualified as Map @@ -116,6 +115,7 @@ import Unison.Prelude import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId)) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Runtime.Array qualified as PA +import Unison.Runtime.TypeTags (CTag (..), PackedTag (..), RTag (..), Tag (..), maskTags, packTags, unpackTags) import Unison.Symbol (Symbol) import Unison.Term hiding (List, Ref, Text, arity, float, fresh, resolve) import Unison.Type qualified as Ty @@ -127,7 +127,6 @@ import Unison.Util.Text qualified as Util.Text import Unison.Var (Var, typed) import Unison.Var qualified as Var import Prelude hiding (abs, and, or, seq) -import Prelude qualified -- For internal errors data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText) @@ -668,7 +667,7 @@ inline inls (Rec bs entry) = Rec (fmap go0 <$> bs) (go0 entry) go n = ABTN.visitPure \case TApp (FComb r) args | Just (arity, expr) <- Map.lookup r inls -> - go (n-1) <$> tweak expr args arity + go (n - 1) <$> tweak expr args arity _ -> Nothing tweak (ABTN.TAbss vs body) args arity @@ -749,72 +748,6 @@ data ANormalF v e | AVar v deriving (Show, Eq, Functor, Foldable, Traversable) --- Types representing components that will go into the runtime tag of --- a data type value. RTags correspond to references, while CTags --- correspond to constructors. -newtype RTag = RTag Word64 - deriving stock (Eq, Ord, Show, Read) - deriving newtype (EC.EnumKey) - -newtype CTag = CTag Word16 - deriving stock (Eq, Ord, Show, Read) - deriving newtype (EC.EnumKey) - -class Tag t where rawTag :: t -> Word64 - -instance Tag RTag where rawTag (RTag w) = w - -instance Tag CTag where rawTag (CTag w) = fromIntegral w - -packTags :: RTag -> CTag -> Word64 -packTags (RTag rt) (CTag ct) = ri .|. ci - where - ri = rt `shiftL` 16 - ci = fromIntegral ct - -unpackTags :: Word64 -> (RTag, CTag) -unpackTags w = (RTag $ w `shiftR` 16, CTag . fromIntegral $ w .&. 0xFFFF) - --- Masks a packed tag to extract just the constructor tag portion -maskTags :: Word64 -> Word64 -maskTags w = w .&. 0xFFFF - -ensureRTag :: (Ord n, Show n, Num n) => String -> n -> r -> r -ensureRTag s n x - | n > 0xFFFFFFFFFFFF = - internalBug $ s ++ "@RTag: too large: " ++ show n - | otherwise = x - -ensureCTag :: (Ord n, Show n, Num n) => String -> n -> r -> r -ensureCTag s n x - | n > 0xFFFF = - internalBug $ s ++ "@CTag: too large: " ++ show n - | otherwise = x - -instance Enum RTag where - toEnum i = ensureRTag "toEnum" i . RTag $ toEnum i - fromEnum (RTag w) = fromEnum w - -instance Enum CTag where - toEnum i = ensureCTag "toEnum" i . CTag $ toEnum i - fromEnum (CTag w) = fromEnum w - -instance Num RTag where - fromInteger i = ensureRTag "fromInteger" i . RTag $ fromInteger i - (+) = internalBug "RTag: +" - (*) = internalBug "RTag: *" - abs = internalBug "RTag: abs" - signum = internalBug "RTag: signum" - negate = internalBug "RTag: negate" - -instance Num CTag where - fromInteger i = ensureCTag "fromInteger" i . CTag $ fromInteger i - (+) = internalBug "CTag: +" - (*) = internalBug "CTag: *" - abs = internalBug "CTag: abs" - signum = internalBug "CTag: signum" - negate = internalBug "CTag: negate" - instance Bifunctor ANormalF where bimap f _ (AVar v) = AVar (f v) bimap _ _ (ALit l) = ALit l @@ -1321,8 +1254,8 @@ data Lit | F Double | T Util.Text.Text | C Char - | LM Referent - | LY Reference + | LM Referent -- Term Link + | LY Reference -- Type Link deriving (Show, Eq) litRef :: Lit -> Reference @@ -1340,139 +1273,144 @@ litRef (LY _) = Ty.typeLinkRef -- formats that we want to control and version. data POp = -- Int - ADDI - | SUBI + ADDI -- + + | SUBI -- - | MULI - | DIVI -- +,-,*,/ - | SGNI - | NEGI - | MODI -- sgn,neg,mod - | POWI - | SHLI - | SHRI -- pow,shiftl,shiftr - | INCI - | DECI - | LEQI - | EQLI -- inc,dec,<=,== + | DIVI -- / + | SGNI -- sgn + | NEGI -- neg + | MODI -- mod + | POWI -- pow + | SHLI -- shiftl + | SHRI -- shiftr + | ANDI -- and + | IORI -- or + | XORI -- xor + | COMI -- complement + | INCI -- inc + | DECI -- dec + | LEQI -- <= + | EQLI -- == -- Nat - | ADDN - | SUBN + | ADDN -- + + | SUBN -- - | MULN - | DIVN -- +,-,*,/ - | MODN - | TZRO - | LZRO - | POPC -- mod,trailing/leadingZeros,popCount - | POWN - | SHLN - | SHRN -- pow,shiftl,shiftr - | ANDN - | IORN - | XORN - | COMN -- and,or,xor,complement - | INCN - | DECN - | LEQN - | EQLN -- inc,dec,<=,== + | DIVN -- / + | MODN -- mod + | TZRO -- trailingZeros + | LZRO -- leadingZeros + | POPC -- popCount + | POWN -- pow + | SHLN -- shiftl + | SHRN -- shiftr + | ANDN -- and + | IORN -- or + | XORN -- xor + | COMN -- complement + | INCN -- inc + | DECN -- dec + | LEQN -- <= + | EQLN -- == -- Float - | ADDF - | SUBF + | ADDF -- + + | SUBF -- - | MULF - | DIVF -- +,-,*,/ - | MINF - | MAXF - | LEQF - | EQLF -- min,max,<=,== - | POWF - | EXPF - | SQRT - | LOGF -- pow,exp,sqrt,log + | DIVF -- / + | MINF -- min + | MAXF -- max + | LEQF -- <= + | EQLF -- == + | POWF -- pow + | EXPF -- exp + | SQRT -- sqrt + | LOGF -- log | LOGB -- logBase - | ABSF - | CEIL - | FLOR - | TRNF -- abs,ceil,floor,truncate + | ABSF -- abs + | CEIL -- ceil + | FLOR -- floor + | TRNF -- truncate | RNDF -- round -- Trig - | COSF - | ACOS - | COSH - | ACSH -- cos,acos,cosh,acosh - | SINF - | ASIN - | SINH - | ASNH -- sin,asin,sinh,asinh - | TANF - | ATAN - | TANH - | ATNH -- tan,atan,tanh,atanh + | COSF -- cos + | ACOS -- acos + | COSH -- cosh + | ACSH -- acosh + | SINF -- sin + | ASIN -- asin + | SINH -- sinh + | ASNH -- asinh + | TANF -- tan + | ATAN -- atan + | TANH -- tanh + | ATNH -- atanh | ATN2 -- atan2 -- Text - | CATT - | TAKT - | DRPT - | SIZT -- ++,take,drop,size + | CATT -- ++ + | TAKT -- take + | DRPT -- drop + | SIZT -- size | IXOT -- indexOf - | UCNS - | USNC - | EQLT - | LEQT -- uncons,unsnoc,==,<= - | PAKT - | UPKT -- pack,unpack + | UCNS -- uncons + | USNC -- unsnoc + | EQLT -- == + | LEQT -- <= + | PAKT -- pack + | UPKT -- unpack -- Sequence - | CATS - | TAKS - | DRPS - | SIZS -- ++,take,drop,size - | CONS - | SNOC - | IDXS - | BLDS -- cons,snoc,at,build - | VWLS - | VWRS - | SPLL - | SPLR -- viewl,viewr,splitl,splitr + | CATS -- ++ + | TAKS -- take + | DRPS -- drop + | SIZS -- size + | CONS -- cons + | SNOC -- snoc + | IDXS -- at + | BLDS -- build + | VWLS -- viewl + | VWRS -- viewr + | SPLL -- splitl + | SPLR -- splitr -- Bytes - | PAKB - | UPKB - | TAKB - | DRPB -- pack,unpack,take,drop + | PAKB -- pack + | UPKB -- unpack + | TAKB -- take + | DRPB -- drop | IXOB -- indexOf - | IDXB - | SIZB - | FLTB - | CATB -- index,size,flatten,append + | IDXB -- index + | SIZB -- size + | FLTB -- flatten + | CATB -- append -- Conversion - | ITOF - | NTOF - | ITOT - | NTOT - | TTOI - | TTON - | TTOF - | FTOT + | ITOF -- intToFloat + | NTOF -- natToFloat + | ITOT -- intToText + | NTOT -- natToText + | TTOI -- textToInt + | TTON -- textToNat + | TTOF -- textToFloat + | FTOT -- floatToText + | CAST -- runtime type cast for unboxed values. | -- Concurrency - FORK + FORK -- fork | -- Universal operations - EQLU - | CMPU - | EROR + EQLU -- == + | CMPU -- compare + | EROR -- error | -- Code - MISS - | CACH - | LKUP - | LOAD -- isMissing,cache_,lookup,load - | CVLD - | SDBX -- validate, sandbox - | VALU - | TLTT -- value, Term.Link.toText + MISS -- isMissing + | CACH -- cache_ + | LKUP -- lookup + | LOAD -- load + | CVLD -- validate + | SDBX -- sandbox + | VALU -- value + | TLTT -- Term.Link.toText -- Debug - | PRNT - | INFO - | TRCE - | DBTX + | PRNT -- print + | INFO -- info + | TRCE -- trace + | DBTX -- debugText | -- STM - ATOM + ATOM -- atomically | TFRC -- try force | SDBL -- sandbox link list | SDBV -- sandbox check for Values @@ -1544,12 +1482,12 @@ arities (Rec bs e) = arity e : fmap (arity . snd) bs -- Checks the body of a SuperGroup makes it eligible for inlining. -- See below for the discussion. -isInlinable :: Var v => Reference -> ANormal v -> Bool +isInlinable :: (Var v) => Reference -> ANormal v -> Bool isInlinable r (TApp (FComb s) _) = r /= s isInlinable _ TApp {} = True isInlinable _ TBLit {} = True isInlinable _ TVar {} = True -isInlinable _ _ = False +isInlinable _ _ = False -- Checks a SuperGroup makes it eligible to be inlined. -- Unfortunately we need to be quite conservative about this. @@ -1593,13 +1531,13 @@ inlineInfo _ _ = Nothing -- They are all tested for inlinability, and the result map -- contains only the information for groups that are able to be -- inlined. -buildInlineMap - :: (Var v) => - Map Reference (SuperGroup v) -> - Map Reference (Int, ANormal v) +buildInlineMap :: + (Var v) => + Map Reference (SuperGroup v) -> + Map Reference (Int, ANormal v) buildInlineMap = - runIdentity . - Map.traverseMaybeWithKey (\r g -> Identity $ inlineInfo r g) + runIdentity + . Map.traverseMaybeWithKey (\r g -> Identity $ inlineInfo r g) -- Checks if two SuperGroups are equivalent up to renaming. The rest -- of the structure must match on the nose. If the two groups are not @@ -1635,12 +1573,9 @@ type ANFD v = Compose (ANFM v) (Directed ()) data GroupRef = GR Reference Word64 deriving (Show, Eq) --- | A value which is either unboxed or boxed. -type UBValue = Either Word64 Value - -- | A list of either unboxed or boxed values. -- Each slot is one of unboxed or boxed but not both. -type ValList = [UBValue] +type ValList = [Value] data Value = Partial GroupRef ValList @@ -1698,11 +1633,12 @@ data BLit | Quote Value | Code Code | BArr PA.ByteArray - | Pos Word64 + | Arr (PA.Array Value) + | -- Despite the following being in the Boxed Literal type, they all represent unboxed values + Pos Word64 | Neg Word64 | Char Char | Float Double - | Arr (PA.Array Value) deriving (Show, Eq) groupVars :: ANFM v (Set v) @@ -2222,11 +2158,11 @@ valueTermLinks = Set.toList . valueLinks f valueLinks :: (Monoid a) => (Bool -> Reference -> a) -> Value -> a valueLinks f (Partial (GR cr _) vs) = - f False cr <> foldMapOf (folded . _Right) (valueLinks f) vs + f False cr <> foldMap (valueLinks f) vs valueLinks f (Data dr _ vs) = - f True dr <> foldMapOf (folded . _Right) (valueLinks f) vs + f True dr <> foldMap (valueLinks f) vs valueLinks f (Cont vs k) = - foldMapOf (folded . _Right) (valueLinks f) vs <> contLinks f k + foldMap (valueLinks f) vs <> contLinks f k valueLinks f (BLit l) = blitLinks f l contLinks :: (Monoid a) => (Bool -> Reference -> a) -> Cont -> a diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index 75c27ba79d..61f2a753f8 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -649,6 +649,11 @@ pOpCode op = case op of IXOB -> 121 SDBL -> 122 SDBV -> 123 + CAST -> 124 + ANDI -> 125 + IORI -> 126 + XORI -> 127 + COMI -> 128 pOpAssoc :: [(POp, Word16)] pOpAssoc = map (\op -> (op, pOpCode op)) [minBound .. maxBound] @@ -854,23 +859,19 @@ putValue :: (MonadPut m) => Version -> Value -> m () putValue v (Partial gr vs) = putTag PartialT *> putGroupRef gr - *> putFoldable (putUBValue v) vs + *> putFoldable (putValue v) vs putValue v (Data r t vs) = putTag DataT *> putReference r *> putWord64be t - *> putFoldable (putUBValue v) vs + *> putFoldable (putValue v) vs putValue v (Cont bs k) = putTag ContT - *> putFoldable (putUBValue v) bs + *> putFoldable (putValue v) bs *> putCont v k putValue v (BLit l) = putTag BLitT *> putBLit v l -putUBValue :: (MonadPut m) => Version -> UBValue -> m () -putUBValue _v Left {} = exn "putUBValue: Unboxed values no longer supported" -putUBValue v (Right a) = putValue v a - getValue :: (MonadGet m) => Version -> m Value getValue v = getTag >>= \case @@ -879,11 +880,11 @@ getValue v = vn < 4 -> do gr <- getGroupRef getList getWord64be >>= assertEmptyUnboxed - bs <- getList getUBValue + bs <- getList (getValue v) pure $ Partial gr bs | otherwise -> do gr <- getGroupRef - vs <- getList getUBValue + vs <- getList (getValue v) pure $ Partial gr vs DataT | Transfer vn <- v, @@ -891,29 +892,26 @@ getValue v = r <- getReference w <- getWord64be getList getWord64be >>= assertEmptyUnboxed - vs <- getList getUBValue + vs <- getList (getValue v) pure $ Data r w vs | otherwise -> do r <- getReference w <- getWord64be - vs <- getList getUBValue + vs <- getList (getValue v) pure $ Data r w vs ContT | Transfer vn <- v, vn < 4 -> do getList getWord64be >>= assertEmptyUnboxed - bs <- getList getUBValue + bs <- getList (getValue v) k <- getCont v pure $ Cont bs k | otherwise -> do - bs <- getList getUBValue + bs <- getList (getValue v) k <- getCont v pure $ Cont bs k BLitT -> BLit <$> getBLit v where - -- Only Boxed values are supported. - getUBValue :: (MonadGet m) => m UBValue - getUBValue = Right <$> getValue v assertEmptyUnboxed :: (MonadGet m) => [a] -> m () assertEmptyUnboxed [] = pure () assertEmptyUnboxed _ = exn "getValue: unboxed values no longer supported" diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 1044e1ceb5..a26d37109b 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -44,7 +44,6 @@ import Crypto.PubKey.Ed25519 qualified as Ed25519 import Crypto.PubKey.RSA.PKCS15 qualified as RSA import Crypto.Random (getRandomBytes) import Data.Bits (shiftL, shiftR, (.|.)) -import Unison.Runtime.Builtin.Types import Data.ByteArray qualified as BA import Data.ByteString (hGet, hGetSome, hPut) import Data.ByteString.Lazy qualified as L @@ -165,6 +164,7 @@ import Unison.Runtime.ANF as ANF import Unison.Runtime.ANF.Rehash (checkGroupHashes) import Unison.Runtime.ANF.Serialize as ANF import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Builtin.Types import Unison.Runtime.Crypto.Rsa as Rsa import Unison.Runtime.Exception (die) import Unison.Runtime.Foreign @@ -174,10 +174,9 @@ import Unison.Runtime.Foreign ) import Unison.Runtime.Foreign qualified as F import Unison.Runtime.Foreign.Function -import Unison.Runtime.Stack (Closure) +import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), emptyVal, unboxedTypeTagToInt) import Unison.Runtime.Stack qualified as Closure import Unison.Symbol -import Unison.Type (charRef) import Unison.Type qualified as Ty import Unison.Util.Bytes qualified as Bytes import Unison.Util.EnumContainers as EC @@ -197,7 +196,7 @@ import Unison.Util.Text qualified as Util.Text import Unison.Util.Text.Pattern qualified as TPat import Unison.Var -type Failure = F.Failure Closure +type Failure = F.Failure Val freshes :: (Var v) => Int -> [v] freshes = freshes' mempty @@ -301,11 +300,6 @@ notlift :: (Var v) => v -> ANormal v notlift v = TMatch v $ MatchIntegral (mapFromList [(1, fls), (0, tru)]) Nothing -unbox :: (Var v) => v -> Reference -> v -> ANormal v -> ANormal v -unbox v0 r v b = - TMatch v0 $ - MatchData r (mapSingleton 0 $ ([UN], TAbs v b)) Nothing - unenum :: (Var v) => Int -> v -> Reference -> v -> ANormal v -> ANormal v unenum n v0 r v nx = TMatch v0 $ MatchData r cases Nothing @@ -329,124 +323,105 @@ binop0 n f = where xs@(x0 : y0 : _) = freshes (2 + n) -unop :: (Var v) => POp -> Reference -> SuperNormal v -unop pop rf = unop' pop rf rf - -unop' :: (Var v) => POp -> Reference -> Reference -> SuperNormal v -unop' pop rfi rfo = - unop0 2 $ \[x0, x, r] -> - unbox x0 rfi x - . TLetD r UN (TPrm pop [x]) - $ TCon rfo 0 [r] - -binop :: (Var v) => POp -> Reference -> SuperNormal v -binop pop rf = binop' pop rf rf rf +unop :: (Var v) => POp -> SuperNormal v +unop pop = + unop0 0 $ \[x] -> + (TPrm pop [x]) -binop' :: +binop :: (Var v) => POp -> - Reference -> - Reference -> - Reference -> SuperNormal v -binop' pop rfx rfy rfr = - binop0 3 $ \[x0, y0, x, y, r] -> - unbox x0 rfx x - . unbox y0 rfy y - . TLetD r UN (TPrm pop [x, y]) - $ TCon rfr 0 [r] - -cmpop :: (Var v) => POp -> Reference -> SuperNormal v -cmpop pop rf = - binop0 3 $ \[x0, y0, x, y, b] -> - unbox x0 rf x - . unbox y0 rf y - . TLetD b UN (TPrm pop [x, y]) - $ boolift b - -cmpopb :: (Var v) => POp -> Reference -> SuperNormal v -cmpopb pop rf = - binop0 3 $ \[x0, y0, x, y, b] -> - unbox x0 rf x - . unbox y0 rf y - . TLetD b UN (TPrm pop [y, x]) - $ boolift b - -cmpopn :: (Var v) => POp -> Reference -> SuperNormal v -cmpopn pop rf = - binop0 3 $ \[x0, y0, x, y, b] -> - unbox x0 rf x - . unbox y0 rf y - . TLetD b UN (TPrm pop [x, y]) - $ notlift b - -cmpopbn :: (Var v) => POp -> Reference -> SuperNormal v -cmpopbn pop rf = - binop0 3 $ \[x0, y0, x, y, b] -> - unbox x0 rf x - . unbox y0 rf y - . TLetD b UN (TPrm pop [y, x]) - $ notlift b +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 `cmpop`, 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. +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 Ty.intRef -subi = binop SUBI Ty.intRef -muli = binop MULI Ty.intRef -divi = binop DIVI Ty.intRef -modi = binop MODI Ty.intRef -shli = binop' SHLI Ty.intRef Ty.natRef Ty.intRef -shri = binop' SHRI Ty.intRef Ty.natRef Ty.intRef -powi = binop' POWI Ty.intRef Ty.natRef Ty.intRef +addi = binop ADDI +subi = binop SUBI +muli = binop MULI +divi = binop DIVI +modi = binop MODI +shli = binop SHLI +shri = binop SHRI +powi = binop POWI addn, subn, muln, divn, modn, shln, shrn, pown :: (Var v) => SuperNormal v -addn = binop ADDN Ty.natRef -subn = binop' SUBN Ty.natRef Ty.natRef Ty.intRef -muln = binop MULN Ty.natRef -divn = binop DIVN Ty.natRef -modn = binop MODN Ty.natRef -shln = binop SHLN Ty.natRef -shrn = binop SHRN Ty.natRef -pown = binop POWN Ty.natRef +addn = binop ADDN +subn = binop SUBN +muln = binop MULN +divn = binop DIVN +modn = binop MODN +shln = binop SHLN +shrn = binop SHRN +pown = binop POWN eqi, eqn, lti, ltn, lei, len :: (Var v) => SuperNormal v -eqi = cmpop EQLI Ty.intRef -lti = cmpopbn LEQI Ty.intRef -lei = cmpop LEQI Ty.intRef -eqn = cmpop EQLN Ty.natRef -ltn = cmpopbn LEQN Ty.natRef -len = cmpop LEQN Ty.natRef +eqi = cmpop EQLI +lti = cmpopbn LEQI +lei = cmpop LEQI +eqn = cmpop EQLN +ltn = cmpopbn LEQN +len = cmpop LEQN gti, gtn, gei, gen :: (Var v) => SuperNormal v -gti = cmpopn LEQI Ty.intRef -gei = cmpopb LEQI Ty.intRef -gtn = cmpopn LEQN Ty.intRef -gen = cmpopb LEQN Ty.intRef +gti = cmpopn LEQI +gei = cmpopb LEQI +gtn = cmpopn LEQN +gen = cmpopb LEQN inci, incn :: (Var v) => SuperNormal v -inci = unop INCI Ty.intRef -incn = unop INCN Ty.natRef +inci = unop INCI +incn = unop INCN sgni, negi :: (Var v) => SuperNormal v -sgni = unop SGNI Ty.intRef -negi = unop NEGI Ty.intRef +sgni = unop SGNI +negi = unop NEGI lzeron, tzeron, lzeroi, tzeroi, popn, popi :: (Var v) => SuperNormal v -lzeron = unop LZRO Ty.natRef -tzeron = unop TZRO Ty.natRef -popn = unop POPC Ty.natRef -popi = unop' POPC Ty.intRef Ty.natRef -lzeroi = unop' LZRO Ty.intRef Ty.natRef -tzeroi = unop' TZRO Ty.intRef Ty.natRef +lzeron = unop LZRO +tzeron = unop TZRO +popn = unop POPC +popi = unop POPC +lzeroi = unop LZRO +tzeroi = unop TZRO andn, orn, xorn, compln, andi, ori, xori, compli :: (Var v) => SuperNormal v -andn = binop ANDN Ty.natRef -orn = binop IORN Ty.natRef -xorn = binop XORN Ty.natRef -compln = unop COMN Ty.natRef -andi = binop ANDN Ty.intRef -ori = binop IORN Ty.intRef -xori = binop XORN Ty.intRef -compli = unop COMN Ty.intRef +andn = binop ANDN +orn = binop IORN +xorn = binop XORN +compln = unop COMN +andi = binop ANDI +ori = binop IORI +xori = binop XORI +compli = unop COMI addf, subf, @@ -457,26 +432,26 @@ addf, logf, logbf :: (Var v) => SuperNormal v -addf = binop ADDF Ty.floatRef -subf = binop SUBF Ty.floatRef -mulf = binop MULF Ty.floatRef -divf = binop DIVF Ty.floatRef -powf = binop POWF Ty.floatRef -sqrtf = unop SQRT Ty.floatRef -logf = unop LOGF Ty.floatRef -logbf = binop LOGB Ty.floatRef +addf = binop ADDF +subf = binop SUBF +mulf = binop MULF +divf = binop DIVF +powf = binop POWF +sqrtf = unop SQRT +logf = unop LOGF +logbf = binop LOGB expf, absf :: (Var v) => SuperNormal v -expf = unop EXPF Ty.floatRef -absf = unop ABSF Ty.floatRef +expf = unop EXPF +absf = unop ABSF cosf, sinf, tanf, acosf, asinf, atanf :: (Var v) => SuperNormal v -cosf = unop COSF Ty.floatRef -sinf = unop SINF Ty.floatRef -tanf = unop TANF Ty.floatRef -acosf = unop ACOS Ty.floatRef -asinf = unop ASIN Ty.floatRef -atanf = unop ATAN Ty.floatRef +cosf = unop COSF +sinf = unop SINF +tanf = unop TANF +acosf = unop ACOS +asinf = unop ASIN +atanf = unop ATAN coshf, sinhf, @@ -486,49 +461,51 @@ coshf, atanhf, atan2f :: (Var v) => SuperNormal v -coshf = unop COSH Ty.floatRef -sinhf = unop SINH Ty.floatRef -tanhf = unop TANH Ty.floatRef -acoshf = unop ACSH Ty.floatRef -asinhf = unop ASNH Ty.floatRef -atanhf = unop ATNH Ty.floatRef -atan2f = binop ATN2 Ty.floatRef +coshf = unop COSH +sinhf = unop SINH +tanhf = unop TANH +acoshf = unop ACSH +asinhf = unop ASNH +atanhf = unop ATNH +atan2f = binop ATN2 ltf, gtf, lef, gef, eqf, neqf :: (Var v) => SuperNormal v -ltf = cmpopbn LEQF Ty.floatRef -gtf = cmpopn LEQF Ty.floatRef -lef = cmpop LEQF Ty.floatRef -gef = cmpopb LEQF Ty.floatRef -eqf = cmpop EQLF Ty.floatRef -neqf = cmpopn EQLF Ty.floatRef +ltf = cmpopbn LEQF +gtf = cmpopn LEQF +lef = cmpop LEQF +gef = cmpopb LEQF +eqf = cmpop EQLF +neqf = cmpopn EQLF minf, maxf :: (Var v) => SuperNormal v -minf = binop MINF Ty.floatRef -maxf = binop MAXF Ty.floatRef +minf = binop MINF +maxf = binop MAXF ceilf, floorf, truncf, roundf, i2f, n2f :: (Var v) => SuperNormal v -ceilf = unop' CEIL Ty.floatRef Ty.intRef -floorf = unop' FLOR Ty.floatRef Ty.intRef -truncf = unop' TRNF Ty.floatRef Ty.intRef -roundf = unop' RNDF Ty.floatRef Ty.intRef -i2f = unop' ITOF Ty.intRef Ty.floatRef -n2f = unop' NTOF Ty.natRef Ty.floatRef +ceilf = unop CEIL +floorf = unop FLOR +truncf = unop TRNF +roundf = unop RNDF +i2f = unop ITOF +n2f = unop NTOF trni :: (Var v) => SuperNormal v -trni = unop0 3 $ \[x0, x, z, b] -> - unbox x0 Ty.intRef x - . TLetD z UN (TLit $ I 0) +trni = unop0 4 $ \[x, z, b, tag, n] -> + -- TODO: Do we need to do all calculations _before_ the branch? + -- Should probably just replace this with an instruction. + TLetD z UN (TLit $ N 0) . TLetD b UN (TPrm LEQI [x, z]) + . TLetD tag UN (TLit $ I $ fromIntegral $ unboxedTypeTagToInt NatTag) + . TLetD n UN (TPrm CAST [x, tag]) . TMatch b $ MatchIntegral - (mapSingleton 1 $ TCon Ty.natRef 0 [z]) - (Just $ TCon Ty.natRef 0 [x]) + (mapSingleton 1 $ TVar z) + (Just $ TVar n) modular :: (Var v) => POp -> (Bool -> ANormal v) -> SuperNormal v modular pop ret = - unop0 3 $ \[x0, x, m, t] -> - unbox x0 Ty.intRef x - . TLetD t UN (TLit $ I 2) + unop0 2 $ \[x, m, t] -> + TLetD t UN (TLit $ I 2) . TLetD m UN (TPrm pop [x, t]) . TMatch m $ MatchIntegral @@ -542,47 +519,40 @@ evnn = modular MODN (\b -> if b then fls else tru) oddn = modular MODN (\b -> if b then tru else fls) dropn :: (Var v) => SuperNormal v -dropn = binop0 4 $ \[x0, y0, x, y, b, r] -> - unbox x0 Ty.natRef x - . unbox y0 Ty.natRef y - . TLetD b UN (TPrm LEQN [x, y]) - . TLet - (Indirect 1) - r - UN - ( TMatch b $ +dropn = binop0 4 $ \[x, y, b, r, tag, n] -> + TLetD b UN (TPrm LEQN [x, y]) + -- TODO: Can we avoid this work until after the branch? + -- Should probably just replace this with an instruction. + . TLetD tag UN (TLit $ I $ fromIntegral $ unboxedTypeTagToInt NatTag) + . TLetD r UN (TPrm SUBN [x, y]) + . TLetD n UN (TPrm CAST [r, tag]) + $ ( TMatch b $ MatchIntegral (mapSingleton 1 $ TLit $ N 0) - (Just $ TPrm SUBN [x, y]) + (Just $ TVar n) ) - $ TCon Ty.natRef 0 [r] appendt, taket, dropt, indext, indexb, sizet, unconst, unsnoct :: (Var v) => SuperNormal v appendt = binop0 0 $ \[x, y] -> TPrm CATT [x, y] -taket = binop0 1 $ \[x0, y, x] -> - unbox x0 Ty.natRef x $ - TPrm TAKT [x, y] -dropt = binop0 1 $ \[x0, y, x] -> - unbox x0 Ty.natRef x $ - TPrm DRPT [x, y] - -atb = binop0 4 $ \[n0, b, n, t, r0, r] -> - unbox n0 Ty.natRef n - . TLetD t UN (TPrm IDXB [n, b]) +taket = binop0 0 $ \[x, y] -> + TPrm TAKT [x, y] +dropt = binop0 0 $ \[x, y] -> + TPrm DRPT [x, y] + +atb = binop0 2 $ \[n, b, t, r] -> + TLetD t UN (TPrm IDXB [n, b]) . TMatch t . MatchSum $ mapFromList [ (0, ([], none)), ( 1, ( [UN], - TAbs r0 - . TLetD r BX (TCon Ty.natRef 0 [r0]) - $ some r + TAbs r $ some r ) ) ] -indext = binop0 3 $ \[x, y, t, r0, r] -> +indext = binop0 2 $ \[x, y, t, r] -> TLetD t UN (TPrm IXOT [x, y]) . TMatch t . MatchSum @@ -590,14 +560,12 @@ indext = binop0 3 $ \[x, y, t, r0, r] -> [ (0, ([], none)), ( 1, ( [UN], - TAbs r0 - . TLetD r BX (TCon Ty.natRef 0 [r0]) - $ some r + TAbs r $ some r ) ) ] -indexb = binop0 3 $ \[x, y, t, i, r] -> +indexb = binop0 2 $ \[x, y, t, r] -> TLetD t UN (TPrm IXOB [x, y]) . TMatch t . MatchSum @@ -605,18 +573,14 @@ indexb = binop0 3 $ \[x, y, t, i, r] -> [ (0, ([], none)), ( 1, ( [UN], - TAbs i - . TLetD r BX (TCon Ty.natRef 0 [i]) - $ some r + TAbs r $ some r ) ) ] -sizet = unop0 1 $ \[x, r] -> - TLetD r UN (TPrm SIZT [x]) $ - TCon Ty.natRef 0 [r] +sizet = unop0 0 $ \[x] -> TPrm SIZT [x] -unconst = unop0 7 $ \[x, t, c0, c, y, p, u, yp] -> +unconst = unop0 6 $ \[x, t, c, y, p, u, yp] -> TLetD t UN (TPrm UCNS [x]) . TMatch t . MatchSum @@ -624,17 +588,16 @@ unconst = unop0 7 $ \[x, t, c0, c, y, p, u, yp] -> [ (0, ([], none)), ( 1, ( [UN, BX], - TAbss [c0, y] + TAbss [c, y] . TLetD u BX (TCon Ty.unitRef 0 []) . TLetD yp BX (TCon Ty.pairRef 0 [y, u]) - . TLetD c BX (TCon Ty.charRef 0 [c0]) . TLetD p BX (TCon Ty.pairRef 0 [c, yp]) $ some p ) ) ] -unsnoct = unop0 7 $ \[x, t, c0, c, y, p, u, cp] -> +unsnoct = unop0 6 $ \[x, t, c, y, p, u, cp] -> TLetD t UN (TPrm USNC [x]) . TMatch t . MatchSum @@ -642,9 +605,8 @@ unsnoct = unop0 7 $ \[x, t, c0, c, y, p, u, cp] -> [ (0, ([], none)), ( 1, ( [BX, UN], - TAbss [y, c0] + TAbss [y, c] . TLetD u BX (TCon Ty.unitRef 0 []) - . TLetD c BX (TCon Ty.charRef 0 [c0]) . TLetD cp BX (TCon Ty.pairRef 0 [c, u]) . TLetD p BX (TCon Ty.pairRef 0 [y, cp]) $ some p @@ -657,24 +619,12 @@ appends = binop0 0 $ \[x, y] -> TPrm CATS [x, y] conss = binop0 0 $ \[x, y] -> TPrm CONS [x, y] snocs = binop0 0 $ \[x, y] -> TPrm SNOC [x, y] -coerceType :: (Var v) => Reference -> Reference -> SuperNormal v -coerceType fromType toType = unop0 1 $ \[x, r] -> - unbox x fromType r $ - TCon toType 0 [r] - takes, drops, sizes, ats, emptys :: (Var v) => SuperNormal v -takes = binop0 1 $ \[x0, y, x] -> - unbox x0 Ty.natRef x $ - TPrm TAKS [x, y] -drops = binop0 1 $ \[x0, y, x] -> - unbox x0 Ty.natRef x $ - TPrm DRPS [x, y] -sizes = unop0 1 $ \[x, r] -> - TLetD r UN (TPrm SIZS [x]) $ - TCon Ty.natRef 0 [r] -ats = binop0 3 $ \[x0, y, x, t, r] -> - unbox x0 Ty.natRef x - . TLetD t UN (TPrm IDXS [x, y]) +takes = binop0 0 $ \[x, y] -> TPrm TAKS [x, y] +drops = binop0 0 $ \[x, y] -> TPrm DRPS [x, y] +sizes = unop0 0 $ \[x] -> (TPrm SIZS [x]) +ats = binop0 2 $ \[x, y, t, r] -> + TLetD t UN (TPrm IDXS [x, y]) . TMatch t . MatchSum $ mapFromList @@ -702,18 +652,16 @@ viewrs = unop0 3 $ \[s, u, i, l] -> ] splitls, splitrs :: (Var v) => SuperNormal v -splitls = binop0 4 $ \[n0, s, n, t, l, r] -> - unbox n0 Ty.natRef n - . TLetD t UN (TPrm SPLL [n, s]) +splitls = binop0 3 $ \[n, s, t, l, r] -> + TLetD t UN (TPrm SPLL [n, s]) . TMatch t . MatchSum $ mapFromList [ (0, ([], seqViewEmpty)), (1, ([BX, BX], TAbss [l, r] $ seqViewElem l r)) ] -splitrs = binop0 4 $ \[n0, s, n, t, l, r] -> - unbox n0 Ty.natRef n - . TLetD t UN (TPrm SPLR [n, s]) +splitrs = binop0 3 $ \[n, s, t, l, r] -> + TLetD t UN (TPrm SPLR [n, s]) . TMatch t . MatchSum $ mapFromList @@ -757,30 +705,18 @@ emptyb = appendb = binop0 0 $ \[x, y] -> TPrm CATB [x, y] takeb, dropb, atb, sizeb, flattenb :: SuperNormal Symbol -takeb = binop0 1 $ \[n0, b, n] -> - unbox n0 Ty.natRef n $ - TPrm TAKB [n, b] -dropb = binop0 1 $ \[n0, b, n] -> - unbox n0 Ty.natRef n $ - TPrm DRPB [n, b] -sizeb = unop0 1 $ \[b, n] -> - TLetD n UN (TPrm SIZB [b]) $ - TCon Ty.natRef 0 [n] +takeb = binop0 0 $ \[n, b] -> TPrm TAKB [n, b] +dropb = binop0 0 $ \[n, b] -> TPrm DRPB [n, b] +sizeb = unop0 0 $ \[b] -> (TPrm SIZB [b]) flattenb = unop0 0 $ \[b] -> TPrm FLTB [b] i2t, n2t, f2t :: SuperNormal Symbol -i2t = unop0 1 $ \[n0, n] -> - unbox n0 Ty.intRef n $ - TPrm ITOT [n] -n2t = unop0 1 $ \[n0, n] -> - unbox n0 Ty.natRef n $ - TPrm NTOT [n] -f2t = unop0 1 $ \[f0, f] -> - unbox f0 Ty.floatRef f $ - TPrm FTOT [f] +i2t = unop0 0 $ \[n] -> TPrm ITOT [n] +n2t = unop0 0 $ \[n] -> TPrm NTOT [n] +f2t = unop0 0 $ \[f] -> TPrm FTOT [f] t2i, t2n, t2f :: SuperNormal Symbol -t2i = unop0 3 $ \[x, t, n0, n] -> +t2i = unop0 2 $ \[x, t, n] -> TLetD t UN (TPrm TTOI [x]) . TMatch t . MatchSum @@ -788,13 +724,11 @@ t2i = unop0 3 $ \[x, t, n0, n] -> [ (0, ([], none)), ( 1, ( [UN], - TAbs n0 - . TLetD n BX (TCon Ty.intRef 0 [n0]) - $ some n + TAbs n $ some n ) ) ] -t2n = unop0 3 $ \[x, t, n0, n] -> +t2n = unop0 2 $ \[x, t, n] -> TLetD t UN (TPrm TTON [x]) . TMatch t . MatchSum @@ -802,13 +736,11 @@ t2n = unop0 3 $ \[x, t, n0, n] -> [ (0, ([], none)), ( 1, ( [UN], - TAbs n0 - . TLetD n BX (TCon Ty.natRef 0 [n0]) - $ some n + TAbs n $ some n ) ) ] -t2f = unop0 3 $ \[x, t, f0, f] -> +t2f = unop0 2 $ \[x, t, f] -> TLetD t UN (TPrm TTOF [x]) . TMatch t . MatchSum @@ -816,9 +748,7 @@ t2f = unop0 3 $ \[x, t, f0, f] -> [ (0, ([], none)), ( 1, ( [UN], - TAbs f0 - . TLetD f BX (TCon Ty.floatRef 0 [f0]) - $ some f + TAbs f $ some f ) ) ] @@ -829,10 +759,9 @@ equ = binop0 1 $ \[x, y, b] -> boolift b cmpu :: SuperNormal Symbol -cmpu = binop0 2 $ \[x, y, c, i] -> - TLetD c UN (TPrm CMPU [x, y]) - . TLetD i UN (TPrm DECI [c]) - $ TCon Ty.intRef 0 [i] +cmpu = binop0 1 $ \[x, y, c] -> + TLetD c UN (TPrm CMPU [x, y]) $ + (TPrm DECI [c]) ltu :: SuperNormal Symbol ltu = binop0 1 $ \[x, y, c] -> @@ -881,14 +810,13 @@ andb = binop0 0 $ \[p, q] -> TMatch p . flip (MatchData Ty.booleanRef) Nothing $ mapFromList [(0, ([], fls)), (1, ([], TVar q))] --- unsafeCoerce, used for numeric types where conversion is a --- no-op on the representation. Ideally this will be inlined and --- eliminated so that no instruction is necessary. -cast :: Reference -> Reference -> SuperNormal Symbol -cast ri ro = - unop0 1 $ \[x0, x] -> - unbox x0 ri x $ - TCon ro 0 [x] +-- A runtime type-cast. Used to unsafely coerce between unboxed +-- types at runtime without changing their representation. +coerceType :: UnboxedTypeTag -> SuperNormal Symbol +coerceType destType = + unop0 1 $ \[v, tag] -> + TLetD tag UN (TLit $ I $ fromIntegral $ unboxedTypeTagToInt destType) $ + TPrm CAST [v, tag] -- This version of unsafeCoerce is the identity function. It works -- only if the two types being coerced between are actually the same, @@ -1096,11 +1024,10 @@ seek'handle instr = ([BX, BX, BX],) . TAbss [arg1, arg2, arg3] . unenum 3 arg2 Ty.seekModeRef seek - . unbox arg3 Ty.intRef nat - . TLetD result UN (TFOp instr [arg1, seek, nat]) + . TLetD result UN (TFOp instr [arg1, seek, arg3]) $ outIoFailUnit stack1 stack2 stack3 unit fail result where - (arg1, arg2, arg3, seek, nat, stack1, stack2, stack3, unit, fail, result) = fresh + (arg1, arg2, arg3, seek, stack1, stack2, stack3, unit, fail, result) = fresh no'buf, line'buf, block'buf, sblock'buf :: (Enum e) => e no'buf = toEnum $ fromIntegral Ty.bufferModeNoBufferingId @@ -1113,25 +1040,17 @@ infixr 0 --> (-->) :: a -> b -> (a, b) x --> y = (x, y) --- Box an unboxed value --- Takes the boxed variable, the unboxed variable, and the type of the value -box :: (Var v) => v -> v -> Reference -> Term ANormalF v -> Term ANormalF v -box b u ty = TLetD b BX (TCon ty 0 [u]) - time'zone :: ForeignOp time'zone instr = ([BX],) - . TAbss [bsecs] - . unbox bsecs Ty.intRef secs + . TAbss [secs] . TLets Direct [offset, summer, name] [UN, UN, BX] (TFOp instr [secs]) - . box bsummer summer Ty.natRef - . box boffset offset Ty.intRef . TLetD un BX (TCon Ty.unitRef 0 []) . TLetD p2 BX (TCon Ty.pairRef 0 [name, un]) - . TLetD p1 BX (TCon Ty.pairRef 0 [bsummer, p2]) - $ TCon Ty.pairRef 0 [boffset, p1] + . TLetD p1 BX (TCon Ty.pairRef 0 [summer, p2]) + $ TCon Ty.pairRef 0 [offset, p1] where - (secs, bsecs, offset, boffset, summer, bsummer, name, un, p2, p1) = fresh + (secs, offset, summer, name, un, p2, p1) = fresh start'process :: ForeignOp start'process instr = @@ -1204,8 +1123,7 @@ get'buffering'output eitherResult stack1 stack2 stack3 resultTag anyVar failVar sblock'buf --> [UN] --> TAbs stack1 - . TLetD stack2 BX (TCon Ty.natRef 0 [stack1]) - . TLetD successVar BX (TCon Ty.bufferModeRef sblock'buf [stack2]) + . TLetD successVar BX (TCon Ty.bufferModeRef sblock'buf [stack1]) $ right successVar ] ) @@ -1213,7 +1131,7 @@ get'buffering'output eitherResult stack1 stack2 stack3 resultTag anyVar failVar get'buffering :: ForeignOp get'buffering = - inBx arg1 eitherResult $ + in1 arg1 eitherResult $ get'buffering'output eitherResult n n2 n3 resultTag anyVar failVar successVar where (arg1, eitherResult, n, n2, n3, resultTag, anyVar, failVar, successVar) = fresh @@ -1232,10 +1150,9 @@ murmur'hash instr = ([BX],) . TAbss [x] . TLetD vl BX (TPrm VALU [x]) - . TLetD result UN (TFOp instr [vl]) - $ TCon Ty.natRef 0 [result] + $ TFOp instr [vl] where - (x, vl, result) = fresh + (x, vl) = fresh crypto'hmac :: ForeignOp crypto'hmac instr = @@ -1246,13 +1163,12 @@ crypto'hmac instr = where (alg, by, x, vl) = fresh --- Input Shape -- these will represent different argument lists a +-- Input Shape -- these represent different argument lists a -- foreign might expect -- --- They will be named according to their shape: --- inBx : one boxed input arg --- inNat : one Nat input arg --- inBxBx : two boxed input args +-- They are named according to their shape: +-- inUnit : one input arg, unit output +-- in1 : one input arg -- -- All of these functions will have take (at least) the same three arguments -- @@ -1266,20 +1182,23 @@ inUnit :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) inUnit unit result cont instr = ([BX], TAbs unit $ TLetD result UN (TFOp instr []) cont) +inN :: forall v. (Var v) => [v] -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inN args result cont instr = + (args $> BX,) + . TAbss args + $ TLetD result UN (TFOp instr args) cont + -- a -> ... -inBx :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBx arg result cont instr = - ([BX],) - . TAbs arg - $ TLetD result UN (TFOp instr [arg]) cont +in1 :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in1 arg result cont instr = inN [arg] result cont instr --- Nat -> ... -inNat :: forall v. (Var v) => v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inNat arg nat result cont instr = - ([BX],) - . TAbs arg - . unbox arg Ty.natRef nat - $ TLetD result UN (TFOp instr [nat]) cont +-- a -> b -> ... +in2 :: forall v. (Var v) => v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in2 arg1 arg2 result cont instr = inN [arg1, arg2] result cont instr + +-- a -> b -> c -> ... +in3 :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in3 arg1 arg2 arg3 result cont instr = inN [arg1, arg2, arg3] result cont instr -- Maybe a -> b -> ... inMaybeBx :: forall v. (Var v) => v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) @@ -1298,20 +1217,6 @@ inMaybeBx arg1 arg2 arg3 mb result cont instr = (fromIntegral Ty.someId, ([BX], TAbs arg3 . TLetD mb UN (TLit $ I 1) $ TLetD result UN (TFOp instr [mb, arg3, arg2]) cont)) ] --- a -> b -> ... -inBxBx :: forall v. (Var v) => v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxBx arg1 arg2 result cont instr = - ([BX, BX],) - . TAbss [arg1, arg2] - $ TLetD result UN (TFOp instr [arg1, arg2]) cont - --- a -> b -> c -> ... -inBxBxBx :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxBxBx arg1 arg2 arg3 result cont instr = - ([BX, BX, BX],) - . TAbss [arg1, arg2, arg3] - $ TLetD result UN (TFOp instr [arg1, arg2, arg3]) cont - set'echo :: ForeignOp set'echo instr = ([BX, BX],) @@ -1322,33 +1227,9 @@ set'echo instr = where (arg1, arg2, bol, stack1, stack2, stack3, unit, fail, result) = fresh --- a -> Nat -> ... -inBxNat :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxNat arg1 arg2 nat result cont instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . unbox arg2 Ty.natRef nat - $ TLetD result UN (TFOp instr [arg1, nat]) cont - -inBxNatNat :: - (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxNatNat arg1 arg2 arg3 nat1 nat2 result cont instr = - ([BX, BX, BX],) - . TAbss [arg1, arg2, arg3] - . unbox arg2 Ty.natRef nat1 - . unbox arg3 Ty.natRef nat2 - $ TLetD result UN (TFOp instr [arg1, nat1, nat2]) cont - -inBxNatBx :: (Var v) => v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxNatBx arg1 arg2 arg3 nat result cont instr = - ([BX, BX, BX],) - . TAbss [arg1, arg2, arg3] - . unbox arg2 Ty.natRef nat - $ TLetD result UN (TFOp instr [arg1, nat, arg3]) cont - -- a -> IOMode -> ... -inBxIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) -inBxIomr arg1 arg2 fm result cont instr = +inIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inIomr arg1 arg2 fm result cont instr = ([BX, BX],) . TAbss [arg1, arg2] . unenum 4 arg2 Ty.fileModeRef fm @@ -1367,29 +1248,15 @@ inBxIomr arg1 arg2 fm result cont instr = -- outMaybe :: forall v. (Var v) => v -> v -> ANormal v -outMaybe maybe result = - TMatch result . MatchSum $ - mapFromList - [ (0, ([], none)), - (1, ([BX], TAbs maybe $ some maybe)) - ] - -outMaybeNat :: (Var v) => v -> v -> v -> ANormal v -outMaybeNat tag result n = +outMaybe tag result = TMatch tag . MatchSum $ mapFromList [ (0, ([], none)), - ( 1, - ( [UN], - TAbs result - . TLetD n BX (TCon Ty.natRef 0 [n]) - $ some n - ) - ) + (1, ([BX], TAbs result $ some result)) ] -outMaybeNTup :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> v -> ANormal v -outMaybeNTup a b n u bp p result = +outMaybeNTup :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v +outMaybeNTup a b u bp p result = TMatch result . MatchSum $ mapFromList [ (0, ([], none)), @@ -1398,8 +1265,7 @@ outMaybeNTup a b n u bp p result = TAbss [a, b] . TLetD u BX (TCon Ty.unitRef 0 []) . TLetD bp BX (TCon Ty.pairRef 0 [b, u]) - . TLetD n BX (TCon Ty.natRef 0 [a]) - . TLetD p BX (TCon Ty.pairRef 0 [n, bp]) + . TLetD p BX (TCon Ty.pairRef 0 [a, bp]) $ some p ) ) @@ -1431,19 +1297,6 @@ outIoFail stack1 stack2 stack3 any fail result = (1, ([BX], TAbs stack1 $ right stack1)) ] -outIoFailNat :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailNat stack1 stack2 stack3 fail extra result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 extra fail, - ( 1, - ([UN],) - . TAbs stack3 - . TLetD extra BX (TCon Ty.natRef 0 [stack3]) - $ right extra - ) - ] - outIoFailChar :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v outIoFailChar stack1 stack2 stack3 fail extra result = TMatch result . MatchSum $ @@ -1451,8 +1304,7 @@ outIoFailChar stack1 stack2 stack3 fail extra result = [ failureCase stack1 stack2 stack3 extra fail, ( 1, ([UN],) - . TAbs stack3 - . TLetD extra BX (TCon Ty.charRef 0 [stack3]) + . TAbs extra $ right extra ) ] @@ -1477,19 +1329,6 @@ exnCase stack1 stack2 stack3 any fail = . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, any]) $ TReq Ty.exceptionRef 0 [fail] -outIoExnNat :: - forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoExnNat stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ exnCase stack1 stack2 stack3 any fail, - ( 1, - ([UN],) - . TAbs stack1 - $ TCon Ty.natRef 0 [stack1] - ) - ] - outIoExnUnit :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v outIoExnUnit stack1 stack2 stack3 any fail result = @@ -1499,18 +1338,18 @@ outIoExnUnit stack1 stack2 stack3 any fail result = (1, ([], TCon Ty.unitRef 0 [])) ] -outIoExnBox :: +outIoExn :: (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoExnBox stack1 stack2 stack3 any fail result = +outIoExn stack1 stack2 stack3 any fail result = TMatch result . MatchSum $ mapFromList [ exnCase stack1 stack2 stack3 any fail, (1, ([BX], TAbs stack1 $ TVar stack1)) ] -outIoExnEBoxBox :: +outIoExnEither :: (Var v) => v -> v -> v -> v -> v -> v -> v -> v -> ANormal v -outIoExnEBoxBox stack1 stack2 stack3 any fail t0 t1 res = +outIoExnEither stack1 stack2 stack3 any fail t0 t1 res = TMatch t0 . MatchSum $ mapFromList [ exnCase stack1 stack2 stack3 any fail, @@ -1526,18 +1365,6 @@ outIoExnEBoxBox stack1 stack2 stack3 any fail t0 t1 res = ) ] -outIoFailBox :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v -outIoFailBox stack1 stack2 stack3 any fail result = - TMatch result . MatchSum $ - mapFromList - [ failureCase stack1 stack2 stack3 any fail, - ( 1, - ([BX],) - . TAbs stack1 - $ right stack1 - ) - ] - outIoFailUnit :: forall v. (Var v) => v -> v -> v -> v -> v -> v -> ANormal v outIoFailUnit stack1 stack2 stack3 extra fail result = TMatch result . MatchSum $ @@ -1604,7 +1431,7 @@ outIoFailG stack1 stack2 stack3 fail result output k = -- -- These are pairings of input and output functions to handle a -- foreign call. The input function represents the numbers and types --- of the inputs to a forein call. The output function takes the +-- of the inputs to a foreign call. The output function takes the -- result of the foreign call and turns it into a Unison type. -- @@ -1612,71 +1439,37 @@ outIoFailG stack1 stack2 stack3 fail result output k = direct :: ForeignOp direct instr = ([], TFOp instr []) --- () -> a -unitDirect :: ForeignOp -unitDirect instr = ([BX],) . TAbs arg $ TFOp instr [] where arg = fresh1 - --- a -> b -boxDirect :: ForeignOp -boxDirect instr = - ([BX],) - . TAbs arg - $ TFOp instr [arg] - where - arg = fresh1 - --- () -> Either Failure Nat -unitToEFNat :: ForeignOp -unitToEFNat = - inUnit unit result $ - outIoFailNat stack1 stack2 stack3 fail nat result - where - (unit, stack1, stack2, stack3, fail, nat, result) = fresh - --- () -> Int -unitToInt :: ForeignOp -unitToInt = - inUnit unit result $ - TCon Ty.intRef 0 [result] +-- () -> r +unitToR :: ForeignOp +unitToR = + inUnit unit result $ TVar result where (unit, result) = fresh -- () -> Either Failure a -unitToEFBox :: ForeignOp -unitToEFBox = +unitToEF :: ForeignOp +unitToEF = inUnit unit result $ - outIoFailBox stack1 stack2 stack3 any fail result + outIoFail stack1 stack2 stack3 any fail result where (unit, stack1, stack2, stack3, fail, any, result) = fresh --- a -> Int -boxToInt :: ForeignOp -boxToInt = inBx arg result (TCon Ty.intRef 0 [result]) - where - (arg, result) = fresh - --- a -> Nat -boxToNat :: ForeignOp -boxToNat = inBx arg result (TCon Ty.natRef 0 [result]) - where - (arg, result) = fresh - -boxIomrToEFBox :: ForeignOp -boxIomrToEFBox = - inBxIomr arg1 arg2 enum result $ - outIoFailBox stack1 stack2 stack3 any fail result +argIomrToEF :: ForeignOp +argIomrToEF = + inIomr arg1 arg2 enum result $ + outIoFail stack1 stack2 stack3 any fail result where (arg1, arg2, enum, stack1, stack2, stack3, any, fail, result) = fresh -- a -> () -boxTo0 :: ForeignOp -boxTo0 = inBx arg result (TCon Ty.unitRef 0 []) +argToUnit :: ForeignOp +argToUnit = in1 arg result (TCon Ty.unitRef 0 []) where (arg, result) = fresh -- a -> b ->{E} () -boxBoxTo0 :: ForeignOp -boxBoxTo0 instr = +arg2To0 :: ForeignOp +arg2To0 instr = ([BX, BX],) . TAbss [arg1, arg2] . TLets Direct [] [] (TFOp instr [arg1, arg2]) @@ -1684,136 +1477,49 @@ boxBoxTo0 instr = where (arg1, arg2) = fresh --- a -> b ->{E} Nat -boxBoxToNat :: ForeignOp -boxBoxToNat instr = - ([BX, BX],) - . TAbss [arg1, arg2] - . TLetD result UN (TFOp instr [arg1, arg2]) - $ TCon Ty.natRef 0 [result] +-- ... -> Bool +argNToBool :: Int -> ForeignOp +argNToBool n instr = + (replicate n BX,) + . TAbss args + $ TLetD result UN (TFOp instr args) (boolift result) where - (arg1, arg2, result) = fresh - --- a -> b -> Option c + (result : args) = freshes (n + 1) --- a -> Bool -boxToBool :: ForeignOp -boxToBool = - inBx arg result $ - boolift result +argNDirect :: Int -> ForeignOp +argNDirect n instr = + (replicate n BX,) + . TAbss args + $ TFOp instr args where - (arg, result) = fresh + args = freshes n --- a -> b -> Bool -boxBoxToBool :: ForeignOp -boxBoxToBool = - inBxBx arg1 arg2 result $ boolift result - where - (arg1, arg2, result) = fresh - --- a -> b -> c -> Bool -boxBoxBoxToBool :: ForeignOp -boxBoxBoxToBool = - inBxBxBx arg1 arg2 arg3 result $ boolift result - where - (arg1, arg2, arg3, result) = fresh - --- Nat -> c --- Works for an type that's packed into a word, just --- pass `wordDirect Ty.natRef`, `wordDirect Ty.floatRef` --- etc -wordDirect :: Reference -> ForeignOp -wordDirect wordType instr = - ([BX],) - . TAbss [b1] - . unbox b1 wordType ub1 - $ TFOp instr [ub1] - where - (b1, ub1) = fresh - --- Nat -> Bool -boxWordToBool :: Reference -> ForeignOp -boxWordToBool wordType instr = - ([BX, BX],) - . TAbss [b1, w1] - . unbox w1 wordType uw1 - $ TLetD result UN (TFOp instr [b1, uw1]) (boolift result) - where - (b1, w1, uw1, result) = fresh - --- Nat -> Nat -> c -wordWordDirect :: Reference -> Reference -> ForeignOp -wordWordDirect word1 word2 instr = - ([BX, BX],) - . TAbss [b1, b2] - . unbox b1 word1 ub1 - . unbox b2 word2 ub2 - $ TFOp instr [ub1, ub2] - where - (b1, b2, ub1, ub2) = fresh - --- Nat -> a -> c --- Works for an type that's packed into a word, just --- pass `wordBoxDirect Ty.natRef`, `wordBoxDirect Ty.floatRef` --- etc -wordBoxDirect :: Reference -> ForeignOp -wordBoxDirect wordType instr = - ([BX, BX],) - . TAbss [b1, b2] - . unbox b1 wordType ub1 - $ TFOp instr [ub1, b2] - where - (b1, b2, ub1) = fresh - --- a -> Nat -> c --- works for any second argument type that is packed into a word -boxWordDirect :: Reference -> ForeignOp -boxWordDirect wordType instr = - ([BX, BX],) - . TAbss [b1, b2] - . unbox b2 wordType ub2 - $ TFOp instr [b1, ub2] - where - (b1, b2, ub2) = fresh - --- a -> b -> c -boxBoxDirect :: ForeignOp -boxBoxDirect instr = - ([BX, BX],) - . TAbss [b1, b2] - $ TFOp instr [b1, b2] - where - (b1, b2) = fresh - --- a -> b -> c -> d -boxBoxBoxDirect :: ForeignOp -boxBoxBoxDirect instr = - ([BX, BX, BX],) - . TAbss [b1, b2, b3] - $ TFOp instr [b1, b2, b3] - where - (b1, b2, b3) = fresh +-- () -> a +-- +-- Unit is unique in that we don't actually pass it as an arg +unitDirect :: ForeignOp +unitDirect instr = ([BX],) . TAbs arg $ TFOp instr [] where arg = fresh1 -- a -> Either Failure b -boxToEFBox :: ForeignOp -boxToEFBox = - inBx arg result $ - outIoFailBox stack1 stack2 stack3 any fail result +argToEF :: ForeignOp +argToEF = + in1 arg result $ + outIoFail stack1 stack2 stack3 any fail result where (arg, result, stack1, stack2, stack3, any, fail) = fresh -- a -> Either Failure (b, c) -boxToEFTup :: ForeignOp -boxToEFTup = - inBx arg result $ +argToEFTup :: ForeignOp +argToEFTup = + in1 arg result $ outIoFailTup stack1 stack2 stack3 stack4 stack5 extra fail result where (arg, result, stack1, stack2, stack3, stack4, stack5, extra, fail) = fresh -- a -> Either Failure (Maybe b) -boxToEFMBox :: ForeignOp -boxToEFMBox = - inBx arg result +argToEFM :: ForeignOp +argToEFM = + in1 arg result . outIoFailG stack1 stack2 stack3 fail result output $ \k -> ( [UN], @@ -1827,227 +1533,161 @@ boxToEFMBox = (arg, result, stack1, stack2, stack3, stack4, fail, output) = fresh -- a -> Maybe b -boxToMaybeBox :: ForeignOp -boxToMaybeBox = - inBx arg result $ outMaybe maybe result - where - (arg, maybe, result) = fresh - --- a -> Maybe Nat -boxToMaybeNat :: ForeignOp -boxToMaybeNat = inBx arg tag $ outMaybeNat tag result n +argToMaybe :: ForeignOp +argToMaybe = in1 arg tag $ outMaybe tag result where - (arg, tag, result, n) = fresh + (arg, tag, result) = fresh -- a -> Maybe (Nat, b) -boxToMaybeNTup :: ForeignOp -boxToMaybeNTup = - inBx arg result $ outMaybeNTup a b c u bp p result +argToMaybeNTup :: ForeignOp +argToMaybeNTup = + in1 arg result $ outMaybeNTup a b u bp p result where - (arg, a, b, c, u, bp, p, result) = fresh + (arg, a, b, u, bp, p, result) = fresh -- a -> b -> Maybe (c, d) -boxBoxToMaybeTup :: ForeignOp -boxBoxToMaybeTup = - inBxBx arg1 arg2 result $ outMaybeTup a b u bp ap result +arg2ToMaybeTup :: ForeignOp +arg2ToMaybeTup = + in2 arg1 arg2 result $ outMaybeTup a b u bp ap result where (arg1, arg2, a, b, u, bp, ap, result) = fresh -- a -> Either Failure Bool -boxToEFBool :: ForeignOp -boxToEFBool = - inBx arg result $ +argToEFBool :: ForeignOp +argToEFBool = + in1 arg result $ outIoFailBool stack1 stack2 stack3 bool fail result where (arg, stack1, stack2, stack3, bool, fail, result) = fresh -- a -> Either Failure Char -boxToEFChar :: ForeignOp -boxToEFChar = - inBx arg result $ +argToEFChar :: ForeignOp +argToEFChar = + in1 arg result $ outIoFailChar stack1 stack2 stack3 bool fail result where (arg, stack1, stack2, stack3, bool, fail, result) = fresh -- a -> b -> Either Failure Bool -boxBoxToEFBool :: ForeignOp -boxBoxToEFBool = - inBxBx arg1 arg2 result $ +arg2ToEFBool :: ForeignOp +arg2ToEFBool = + in2 arg1 arg2 result $ outIoFailBool stack1 stack2 stack3 bool fail result where (arg1, arg2, stack1, stack2, stack3, bool, fail, result) = fresh -- a -> b -> c -> Either Failure Bool -boxBoxBoxToEFBool :: ForeignOp -boxBoxBoxToEFBool = - inBxBxBx arg1 arg2 arg3 result $ +arg3ToEFBool :: ForeignOp +arg3ToEFBool = + in3 arg1 arg2 arg3 result $ outIoFailBool stack1 stack2 stack3 bool fail result where (arg1, arg2, arg3, stack1, stack2, stack3, bool, fail, result) = fresh -- a -> Either Failure () -boxToEF0 :: ForeignOp -boxToEF0 = - inBx arg result $ +argToEF0 :: ForeignOp +argToEF0 = + in1 arg result $ outIoFailUnit stack1 stack2 stack3 unit fail result where (arg, result, stack1, stack2, stack3, unit, fail) = fresh -- a -> b -> Either Failure () -boxBoxToEF0 :: ForeignOp -boxBoxToEF0 = - inBxBx arg1 arg2 result $ +arg2ToEF0 :: ForeignOp +arg2ToEF0 = + in2 arg1 arg2 result $ outIoFailUnit stack1 stack2 stack3 fail unit result where (arg1, arg2, result, stack1, stack2, stack3, fail, unit) = fresh -- a -> b -> c -> Either Failure () -boxBoxBoxToEF0 :: ForeignOp -boxBoxBoxToEF0 = - inBxBxBx arg1 arg2 arg3 result $ +arg3ToEF0 :: ForeignOp +arg3ToEF0 = + in3 arg1 arg2 arg3 result $ outIoFailUnit stack1 stack2 stack3 fail unit result where (arg1, arg2, arg3, result, stack1, stack2, stack3, fail, unit) = fresh --- a -> Either Failure Nat -boxToEFNat :: ForeignOp -boxToEFNat = - inBx arg result $ - outIoFailNat stack1 stack2 stack3 nat fail result +-- a -> Either Failure b +argToEFNat :: ForeignOp +argToEFNat = + in1 arg result $ + outIoFail stack1 stack2 stack3 nat fail result where (arg, result, stack1, stack2, stack3, nat, fail) = fresh -- Maybe a -> b -> Either Failure c -maybeBoxToEFBox :: ForeignOp -maybeBoxToEFBox = +maybeToEF :: ForeignOp +maybeToEF = inMaybeBx arg1 arg2 arg3 mb result $ outIoFail stack1 stack2 stack3 any fail result where (arg1, arg2, arg3, mb, result, stack1, stack2, stack3, any, fail) = fresh -- a -> b -> Either Failure c -boxBoxToEFBox :: ForeignOp -boxBoxToEFBox = - inBxBx arg1 arg2 result $ +arg2ToEF :: ForeignOp +arg2ToEF = + in2 arg1 arg2 result $ outIoFail stack1 stack2 stack3 any fail result where (arg1, arg2, result, stack1, stack2, stack3, any, fail) = fresh -- a -> b -> c -> Either Failure d -boxBoxBoxToEFBox :: ForeignOp -boxBoxBoxToEFBox = - inBxBxBx arg1 arg2 arg3 result $ +arg3ToEF :: ForeignOp +arg3ToEF = + in3 arg1 arg2 arg3 result $ outIoFail stack1 stack2 stack3 any fail result where (arg1, arg2, arg3, result, stack1, stack2, stack3, any, fail) = fresh --- Nat -> a --- Nat only -natToBox :: ForeignOp -natToBox = wordDirect Ty.natRef - --- Nat -> Nat -> a --- Nat only -natNatToBox :: ForeignOp -natNatToBox = wordWordDirect Ty.natRef Ty.natRef - --- Nat -> Nat -> a -> b -natNatBoxToBox :: ForeignOp -natNatBoxToBox instr = - ([BX, BX, BX],) - . TAbss [a1, a2, a3] - . unbox a1 Ty.natRef ua1 - . unbox a2 Ty.natRef ua2 - $ TFOp instr [ua1, ua2, a3] - where - (a1, a2, a3, ua1, ua2) = fresh - --- a -> Nat -> c --- Nat only -boxNatToBox :: ForeignOp -boxNatToBox = boxWordDirect Ty.natRef - --- a -> Nat -> Either Failure b -boxNatToEFBox :: ForeignOp -boxNatToEFBox = - inBxNat arg1 arg2 nat result $ - outIoFail stack1 stack2 stack3 any fail result +-- a -> b ->{Exception} c +arg2ToExn :: ForeignOp +arg2ToExn = + in2 arg1 arg2 result $ + outIoExn stack1 stack2 stack3 any fail result where - (arg1, arg2, nat, stack1, stack2, stack3, any, fail, result) = fresh + (arg1, arg2, stack1, stack2, stack3, any, fail, result) = fresh --- a -> Nat ->{Exception} b -boxNatToExnBox :: ForeignOp -boxNatToExnBox = - inBxNat arg1 arg2 nat result $ - outIoExnBox stack1 stack2 stack3 fail any result - where - (arg1, arg2, nat, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> Nat -> b ->{Exception} () -boxNatBoxToExnUnit :: ForeignOp -boxNatBoxToExnUnit = - inBxNatBx arg1 arg2 arg3 nat result $ - outIoExnUnit stack1 stack2 stack3 any fail result - where - (arg1, arg2, arg3, nat, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> Nat ->{Exception} Nat -boxNatToExnNat :: ForeignOp -boxNatToExnNat = - inBxNat arg1 arg2 nat result $ - outIoExnNat stack1 stack2 stack3 any fail result - where - (arg1, arg2, nat, stack1, stack2, stack3, any, fail, result) = fresh - --- a -> Nat -> Nat ->{Exception} () -boxNatNatToExnUnit :: ForeignOp -boxNatNatToExnUnit = - inBxNatNat arg1 arg2 arg3 nat1 nat2 result $ +-- a -> b -> c ->{Exception} () +arg3ToExnUnit :: ForeignOp +arg3ToExnUnit = + in3 arg1 arg2 arg3 result $ outIoExnUnit stack1 stack2 stack3 any fail result where - (arg1, arg2, arg3, nat1, nat2, result, stack1, stack2, stack3, any, fail) = fresh + (arg1, arg2, arg3, stack1, stack2, stack3, any, fail, result) = fresh -- a -> Nat -> Nat ->{Exception} b -boxNatNatToExnBox :: ForeignOp -boxNatNatToExnBox = - inBxNatNat arg1 arg2 arg3 nat1 nat2 result $ - outIoExnBox stack1 stack2 stack3 any fail result +arg3ToExn :: ForeignOp +arg3ToExn = + in3 arg1 arg2 arg3 result $ + outIoExn stack1 stack2 stack3 any fail result where - (arg1, arg2, arg3, nat1, nat2, result, stack1, stack2, stack3, any, fail) = fresh + (arg1, arg2, arg3, result, stack1, stack2, stack3, any, fail) = fresh -- a -> Nat -> b -> Nat -> Nat ->{Exception} () -boxNatBoxNatNatToExnUnit :: ForeignOp -boxNatBoxNatNatToExnUnit instr = +arg5ToExnUnit :: ForeignOp +arg5ToExnUnit instr = ([BX, BX, BX, BX, BX],) - . TAbss [a0, a1, a2, a3, a4] - . unbox a1 Ty.natRef ua1 - . unbox a3 Ty.natRef ua3 - . unbox a4 Ty.natRef ua4 + . TAbss [a0, ua1, a2, ua3, ua4] . TLetD result UN (TFOp instr [a0, ua1, a2, ua3, ua4]) $ outIoExnUnit stack1 stack2 stack3 any fail result where - (a0, a1, a2, a3, a4, ua1, ua3, ua4, result, stack1, stack2, stack3, any, fail) = fresh + (a0, a2, ua1, ua3, ua4, result, stack1, stack2, stack3, any, fail) = fresh -- a ->{Exception} Either b c -boxToExnEBoxBox :: ForeignOp -boxToExnEBoxBox instr = +argToExnE :: ForeignOp +argToExnE instr = ([BX],) . TAbs a . TLetD t0 UN (TFOp instr [a]) - $ outIoExnEBoxBox stack1 stack2 stack3 any fail t0 t1 result + $ outIoExnEither stack1 stack2 stack3 any fail t0 t1 result where (a, stack1, stack2, stack3, any, fail, t0, t1, result) = fresh --- Nat -> Either Failure b --- natToEFBox :: ForeignOp --- natToEFBox = inNat arg nat result $ outIoFail stack1 stack2 fail result --- where --- (arg, nat, stack1, stack2, fail, result) = fresh - -- Nat -> Either Failure () -natToEFUnit :: ForeignOp -natToEFUnit = - inNat arg nat result +argToEFUnit :: ForeignOp +argToEFUnit = + in1 nat result . TMatch result . MatchSum $ mapFromList @@ -2059,11 +1699,11 @@ natToEFUnit = ) ] where - (arg, nat, result, fail, stack1, stack2, stack3, unit) = fresh + (nat, result, fail, stack1, stack2, stack3, unit) = fresh -- a -> Either b c -boxToEBoxBox :: ForeignOp -boxToEBoxBox instr = +argToEither :: ForeignOp +argToEither instr = ([BX],) . TAbss [b] . TLetD e UN (TFOp instr [b]) @@ -2090,8 +1730,8 @@ builtinLookup = ("Int.<=", (Untracked, lei)), ("Int.>", (Untracked, gti)), ("Int.>=", (Untracked, gei)), - ("Int.fromRepresentation", (Untracked, coerceType Ty.natRef Ty.intRef)), - ("Int.toRepresentation", (Untracked, coerceType Ty.intRef Ty.natRef)), + ("Int.fromRepresentation", (Untracked, coerceType IntTag)), + ("Int.toRepresentation", (Untracked, coerceType NatTag)), ("Int.increment", (Untracked, inci)), ("Int.signum", (Untracked, sgni)), ("Int.negate", (Untracked, negi)), @@ -2135,7 +1775,7 @@ builtinLookup = ("Nat.complement", (Untracked, compln)), ("Nat.pow", (Untracked, pown)), ("Nat.drop", (Untracked, dropn)), - ("Nat.toInt", (Untracked, cast Ty.natRef Ty.intRef)), + ("Nat.toInt", (Untracked, coerceType IntTag)), ("Nat.toFloat", (Untracked, n2f)), ("Nat.toText", (Untracked, n2t)), ("Nat.fromText", (Untracked, t2n)), @@ -2148,8 +1788,8 @@ builtinLookup = ("Float.log", (Untracked, logf)), ("Float.logBase", (Untracked, logbf)), ("Float.sqrt", (Untracked, sqrtf)), - ("Float.fromRepresentation", (Untracked, coerceType Ty.natRef Ty.floatRef)), - ("Float.toRepresentation", (Untracked, coerceType Ty.floatRef Ty.natRef)), + ("Float.fromRepresentation", (Untracked, coerceType FloatTag)), + ("Float.toRepresentation", (Untracked, coerceType NatTag)), ("Float.min", (Untracked, minf)), ("Float.max", (Untracked, maxf)), ("Float.<", (Untracked, ltf)), @@ -2205,8 +1845,8 @@ builtinLookup = ("Debug.trace", (Tracked, gen'trace)), ("Debug.toText", (Tracked, debug'text)), ("unsafe.coerceAbilities", (Untracked, poly'coerce)), - ("Char.toNat", (Untracked, cast Ty.charRef Ty.natRef)), - ("Char.fromNat", (Untracked, cast Ty.natRef Ty.charRef)), + ("Char.toNat", (Untracked, coerceType NatTag)), + ("Char.fromNat", (Untracked, coerceType CharTag)), ("Bytes.empty", (Untracked, emptyb)), ("Bytes.fromList", (Untracked, packb)), ("Bytes.toList", (Untracked, unpackb)), @@ -2302,11 +1942,11 @@ mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue handleIOE (Right a) = Right a -unitValue :: Closure -unitValue = Closure.Enum Ty.unitRef 0 +unitValue :: Val +unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) -natValue :: Word64 -> Closure -natValue w = Closure.DataU1 Ty.natRef 0 (fromIntegral w) +natValue :: Word64 -> Val +natValue w = NatVal w mkForeignTls :: forall a r. @@ -2343,35 +1983,35 @@ mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) declareUdpForeigns :: FDecl Symbol () declareUdpForeigns = do - declareForeign Tracked "IO.UDP.clientSocket.impl.v1" boxBoxToEFBox + declareForeign Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF . mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> let hostStr = Util.Text.toString host portStr = Util.Text.toString port in UDP.clientSocket hostStr portStr True - declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" boxToEFBox + declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF . mkForeignIOF $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock - declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" boxBoxToEF0 + declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 . mkForeignIOF $ \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> UDP.send sock (Bytes.toArray bytes) - declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" boxToEF0 + declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 . mkForeignIOF $ \(sock :: UDPSocket) -> UDP.close sock - declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" boxToEF0 + declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 . mkForeignIOF $ \(sock :: ListenSocket) -> UDP.stop sock - declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" boxDirect + declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) . mkForeign $ \(sock :: UDPSocket) -> pure $ show sock - declareForeign Tracked "IO.UDP.serverSocket.impl.v1" boxBoxToEFBox + declareForeign Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF . mkForeignIOF $ \(ip :: Util.Text.Text, port :: Util.Text.Text) -> let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP @@ -2381,19 +2021,19 @@ declareUdpForeigns = do (_, Nothing) -> fail "Invalid Port Number" (Just ip, Just pt) -> UDP.serverSocket (ip, pt) - declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" boxDirect + declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) . mkForeign $ \(sock :: ListenSocket) -> pure $ show sock - declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" boxToEFTup + declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup . mkForeignIOF $ fmap (first Bytes.fromArray) <$> UDP.recvFrom - declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" boxDirect + declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) . mkForeign $ \(sock :: ClientSockAddr) -> pure $ show sock - declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" boxBoxBoxToEF0 + declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 . mkForeignIOF $ \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> UDP.sendTo socket (Bytes.toArray bytes) addr @@ -2401,7 +2041,7 @@ declareUdpForeigns = do declareForeigns :: FDecl Symbol () declareForeigns = do declareUdpForeigns - declareForeign Tracked "IO.openFile.impl.v3" boxIomrToEFBox $ + declareForeign Tracked "IO.openFile.impl.v3" argIomrToEF $ mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> let fname = Util.Text.toString fnameText mode = case n of @@ -2411,19 +2051,19 @@ declareForeigns = do _ -> ReadWriteMode in openFile fname mode - declareForeign Tracked "IO.closeFile.impl.v3" boxToEF0 $ mkForeignIOF hClose - declareForeign Tracked "IO.isFileEOF.impl.v3" boxToEFBool $ mkForeignIOF hIsEOF - declareForeign Tracked "IO.isFileOpen.impl.v3" boxToEFBool $ mkForeignIOF hIsOpen - declareForeign Tracked "IO.getEcho.impl.v1" boxToEFBool $ mkForeignIOF hGetEcho - declareForeign Tracked "IO.ready.impl.v1" boxToEFBool $ mkForeignIOF hReady - declareForeign Tracked "IO.getChar.impl.v1" boxToEFChar $ mkForeignIOF hGetChar - declareForeign Tracked "IO.isSeekable.impl.v3" boxToEFBool $ mkForeignIOF hIsSeekable + declareForeign Tracked "IO.closeFile.impl.v3" argToEF0 $ mkForeignIOF hClose + declareForeign Tracked "IO.isFileEOF.impl.v3" argToEFBool $ mkForeignIOF hIsEOF + declareForeign Tracked "IO.isFileOpen.impl.v3" argToEFBool $ mkForeignIOF hIsOpen + declareForeign Tracked "IO.getEcho.impl.v1" argToEFBool $ mkForeignIOF hGetEcho + declareForeign Tracked "IO.ready.impl.v1" argToEFBool $ mkForeignIOF hReady + declareForeign Tracked "IO.getChar.impl.v1" argToEFChar $ mkForeignIOF hGetChar + declareForeign Tracked "IO.isSeekable.impl.v3" argToEFBool $ mkForeignIOF hIsSeekable declareForeign Tracked "IO.seekHandle.impl.v3" seek'handle . mkForeignIOF $ \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) - declareForeign Tracked "IO.handlePosition.impl.v3" boxToEFNat + declareForeign Tracked "IO.handlePosition.impl.v3" argToEFNat -- TODO: truncating integer . mkForeignIOF $ \h -> fromInteger @Word64 <$> hTell h @@ -2437,48 +2077,48 @@ declareForeigns = do declareForeign Tracked "IO.setEcho.impl.v1" set'echo . mkForeignIOF $ uncurry hSetEcho - declareForeign Tracked "IO.getLine.impl.v1" boxToEFBox $ + declareForeign Tracked "IO.getLine.impl.v1" argToEF $ mkForeignIOF $ fmap Util.Text.fromText . Text.IO.hGetLine - declareForeign Tracked "IO.getBytes.impl.v3" boxNatToEFBox . mkForeignIOF $ + declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF . mkForeignIOF $ \(h, n) -> Bytes.fromArray <$> hGet h n - declareForeign Tracked "IO.getSomeBytes.impl.v1" boxNatToEFBox . mkForeignIOF $ + declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF . mkForeignIOF $ \(h, n) -> Bytes.fromArray <$> hGetSome h n - declareForeign Tracked "IO.putBytes.impl.v3" boxBoxToEF0 . mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 . mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) - declareForeign Tracked "IO.systemTime.impl.v3" unitToEFNat $ + declareForeign Tracked "IO.systemTime.impl.v3" unitToEF $ mkForeignIOF $ \() -> getPOSIXTime - declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToInt $ + declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToR $ mkForeign $ \() -> fmap (1e6 *) getPOSIXTime - declareForeign Tracked "Clock.internals.monotonic.v1" unitToEFBox $ + declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF $ mkForeignIOF $ \() -> getTime Monotonic - declareForeign Tracked "Clock.internals.realtime.v1" unitToEFBox $ + declareForeign Tracked "Clock.internals.realtime.v1" unitToEF $ mkForeignIOF $ \() -> getTime Realtime - declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEFBox $ + declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF $ mkForeignIOF $ \() -> getTime ProcessCPUTime - declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEFBox $ + declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF $ mkForeignIOF $ \() -> getTime ThreadCPUTime - declareForeign Tracked "Clock.internals.sec.v1" boxToInt $ + declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) $ mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) -- A TimeSpec that comes from getTime never has negative nanos, -- so we can safely cast to Nat - declareForeign Tracked "Clock.internals.nsec.v1" boxToNat $ + declareForeign Tracked "Clock.internals.nsec.v1" (argNDirect 1) $ mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone $ @@ -2490,116 +2130,116 @@ declareForeigns = do let chop = reverse . dropWhile isPathSeparator . reverse - declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEFBox $ + declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF $ mkForeignIOF $ \() -> chop <$> getTemporaryDirectory - declareForeign Tracked "IO.createTempDirectory.impl.v3" boxToEFBox $ + declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF $ mkForeignIOF $ \prefix -> do temp <- getTemporaryDirectory chop <$> createTempDirectory temp prefix - declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEFBox + declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEF . mkForeignIOF $ \() -> getCurrentDirectory - declareForeign Tracked "IO.setCurrentDirectory.impl.v3" boxToEF0 $ + declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 $ mkForeignIOF setCurrentDirectory - declareForeign Tracked "IO.fileExists.impl.v3" boxToEFBool $ + declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool $ mkForeignIOF doesPathExist - declareForeign Tracked "IO.getEnv.impl.v1" boxToEFBox $ + declareForeign Tracked "IO.getEnv.impl.v1" argToEF $ mkForeignIOF getEnv - declareForeign Tracked "IO.getArgs.impl.v1" unitToEFBox $ + declareForeign Tracked "IO.getArgs.impl.v1" unitToEF $ mkForeignIOF $ \() -> fmap Util.Text.pack <$> SYS.getArgs - declareForeign Tracked "IO.isDirectory.impl.v3" boxToEFBool $ + declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool $ mkForeignIOF doesDirectoryExist - declareForeign Tracked "IO.createDirectory.impl.v3" boxToEF0 $ + declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 $ mkForeignIOF $ createDirectoryIfMissing True - declareForeign Tracked "IO.removeDirectory.impl.v3" boxToEF0 $ + declareForeign Tracked "IO.removeDirectory.impl.v3" argToEF0 $ mkForeignIOF removeDirectoryRecursive - declareForeign Tracked "IO.renameDirectory.impl.v3" boxBoxToEF0 $ + declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 $ mkForeignIOF $ uncurry renameDirectory - declareForeign Tracked "IO.directoryContents.impl.v3" boxToEFBox $ + declareForeign Tracked "IO.directoryContents.impl.v3" argToEF $ mkForeignIOF $ (fmap Util.Text.pack <$>) . getDirectoryContents - declareForeign Tracked "IO.removeFile.impl.v3" boxToEF0 $ + declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 $ mkForeignIOF removeFile - declareForeign Tracked "IO.renameFile.impl.v3" boxBoxToEF0 $ + declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 $ mkForeignIOF $ uncurry renameFile - declareForeign Tracked "IO.getFileTimestamp.impl.v3" boxToEFNat + declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat . mkForeignIOF $ fmap utcTimeToPOSIXSeconds . getModificationTime - declareForeign Tracked "IO.getFileSize.impl.v3" boxToEFNat + declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat -- TODO: truncating integer . mkForeignIOF $ \fp -> fromInteger @Word64 <$> getFileSize fp - declareForeign Tracked "IO.serverSocket.impl.v3" maybeBoxToEFBox + declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF . mkForeignIOF $ \( mhst :: Maybe Util.Text.Text, port ) -> fst <$> SYS.bindSock (hostPreference mhst) port - declareForeign Tracked "Socket.toText" boxDirect + declareForeign Tracked "Socket.toText" (argNDirect 1) . mkForeign $ \(sock :: Socket) -> pure $ show sock - declareForeign Tracked "Handle.toText" boxDirect + declareForeign Tracked "Handle.toText" (argNDirect 1) . mkForeign $ \(hand :: Handle) -> pure $ show hand - declareForeign Tracked "ThreadId.toText" boxDirect + declareForeign Tracked "ThreadId.toText" (argNDirect 1) . mkForeign $ \(threadId :: ThreadId) -> pure $ show threadId - declareForeign Tracked "IO.socketPort.impl.v3" boxToEFNat + declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat . mkForeignIOF $ \(handle :: Socket) -> do n <- SYS.socketPort handle return (fromIntegral n :: Word64) - declareForeign Tracked "IO.listen.impl.v3" boxToEF0 + declareForeign Tracked "IO.listen.impl.v3" argToEF0 . mkForeignIOF $ \sk -> SYS.listenSock sk 2048 - declareForeign Tracked "IO.clientSocket.impl.v3" boxBoxToEFBox + declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF . mkForeignIOF $ fmap fst . uncurry SYS.connectSock - declareForeign Tracked "IO.closeSocket.impl.v3" boxToEF0 $ + declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 $ mkForeignIOF SYS.closeSock - declareForeign Tracked "IO.socketAccept.impl.v3" boxToEFBox + declareForeign Tracked "IO.socketAccept.impl.v3" argToEF . mkForeignIOF $ fmap fst . SYS.accept - declareForeign Tracked "IO.socketSend.impl.v3" boxBoxToEF0 + declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 . mkForeignIOF $ \(sk, bs) -> SYS.send sk (Bytes.toArray bs) - declareForeign Tracked "IO.socketReceive.impl.v3" boxNatToEFBox + declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF . mkForeignIOF $ \(hs, n) -> maybe mempty Bytes.fromArray <$> SYS.recv hs n - declareForeign Tracked "IO.kill.impl.v3" boxToEF0 $ mkForeignIOF killThread + declareForeign Tracked "IO.kill.impl.v3" argToEF0 $ mkForeignIOF killThread let mx :: Word64 mx = fromIntegral (maxBound :: Int) @@ -2609,7 +2249,7 @@ declareForeigns = do | n < mx = threadDelay (fromIntegral n) | otherwise = threadDelay maxBound >> customDelay (n - mx) - declareForeign Tracked "IO.delay.impl.v3" natToEFUnit $ + declareForeign Tracked "IO.delay.impl.v3" argToEFUnit $ mkForeignIOF customDelay declareForeign Tracked "IO.stdHandle" standard'handle @@ -2623,7 +2263,7 @@ declareForeigns = do let exitDecode ExitSuccess = 0 exitDecode (ExitFailure n) = n - declareForeign Tracked "IO.process.call" boxBoxToNat . mkForeign $ + declareForeign Tracked "IO.process.call" (argNDirect 2) . mkForeign $ \(exe, map Util.Text.unpack -> args) -> withCreateProcess (proc exe args) $ \_ _ _ p -> exitDecode <$> waitForProcess p @@ -2632,77 +2272,77 @@ declareForeigns = do \(exe, map Util.Text.unpack -> args) -> runInteractiveProcess exe args Nothing Nothing - declareForeign Tracked "IO.process.kill" boxTo0 . mkForeign $ + declareForeign Tracked "IO.process.kill" argToUnit . mkForeign $ terminateProcess - declareForeign Tracked "IO.process.wait" boxToNat . mkForeign $ + declareForeign Tracked "IO.process.wait" (argNDirect 1) . mkForeign $ \ph -> exitDecode <$> waitForProcess ph - declareForeign Tracked "IO.process.exitCode" boxToMaybeNat . mkForeign $ + declareForeign Tracked "IO.process.exitCode" argToMaybe . mkForeign $ fmap (fmap exitDecode) . getProcessExitCode - declareForeign Tracked "MVar.new" boxDirect + declareForeign Tracked "MVar.new" (argNDirect 1) . mkForeign - $ \(c :: Closure) -> newMVar c + $ \(c :: Val) -> newMVar c declareForeign Tracked "MVar.newEmpty.v2" unitDirect . mkForeign - $ \() -> newEmptyMVar @Closure + $ \() -> newEmptyMVar @Val - declareForeign Tracked "MVar.take.impl.v3" boxToEFBox + declareForeign Tracked "MVar.take.impl.v3" argToEF . mkForeignIOF - $ \(mv :: MVar Closure) -> takeMVar mv + $ \(mv :: MVar Val) -> takeMVar mv - declareForeign Tracked "MVar.tryTake" boxToMaybeBox + declareForeign Tracked "MVar.tryTake" argToMaybe . mkForeign - $ \(mv :: MVar Closure) -> tryTakeMVar mv + $ \(mv :: MVar Val) -> tryTakeMVar mv - declareForeign Tracked "MVar.put.impl.v3" boxBoxToEF0 + declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 . mkForeignIOF - $ \(mv :: MVar Closure, x) -> putMVar mv x + $ \(mv :: MVar Val, x) -> putMVar mv x - declareForeign Tracked "MVar.tryPut.impl.v3" boxBoxToEFBool + declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool . mkForeignIOF - $ \(mv :: MVar Closure, x) -> tryPutMVar mv x + $ \(mv :: MVar Val, x) -> tryPutMVar mv x - declareForeign Tracked "MVar.swap.impl.v3" boxBoxToEFBox + declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF . mkForeignIOF - $ \(mv :: MVar Closure, x) -> swapMVar mv x + $ \(mv :: MVar Val, x) -> swapMVar mv x - declareForeign Tracked "MVar.isEmpty" boxToBool + declareForeign Tracked "MVar.isEmpty" (argNToBool 1) . mkForeign - $ \(mv :: MVar Closure) -> isEmptyMVar mv + $ \(mv :: MVar Val) -> isEmptyMVar mv - declareForeign Tracked "MVar.read.impl.v3" boxToEFBox + declareForeign Tracked "MVar.read.impl.v3" argToEF . mkForeignIOF - $ \(mv :: MVar Closure) -> readMVar mv + $ \(mv :: MVar Val) -> readMVar mv - declareForeign Tracked "MVar.tryRead.impl.v3" boxToEFMBox + declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM . mkForeignIOF - $ \(mv :: MVar Closure) -> tryReadMVar mv + $ \(mv :: MVar Val) -> tryReadMVar mv - declareForeign Untracked "Char.toText" (wordDirect Ty.charRef) . mkForeign $ + declareForeign Untracked "Char.toText" (argNDirect 1) . mkForeign $ \(ch :: Char) -> pure (Util.Text.singleton ch) - declareForeign Untracked "Text.repeat" (wordBoxDirect Ty.natRef) . mkForeign $ + declareForeign Untracked "Text.repeat" (argNDirect 2) . mkForeign $ \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) - declareForeign Untracked "Text.reverse" boxDirect . mkForeign $ + declareForeign Untracked "Text.reverse" (argNDirect 1) . mkForeign $ pure . Util.Text.reverse - declareForeign Untracked "Text.toUppercase" boxDirect . mkForeign $ + declareForeign Untracked "Text.toUppercase" (argNDirect 1) . mkForeign $ pure . Util.Text.toUppercase - declareForeign Untracked "Text.toLowercase" boxDirect . mkForeign $ + declareForeign Untracked "Text.toLowercase" (argNDirect 1) . mkForeign $ pure . Util.Text.toLowercase - declareForeign Untracked "Text.toUtf8" boxDirect . mkForeign $ + declareForeign Untracked "Text.toUtf8" (argNDirect 1) . mkForeign $ pure . Util.Text.toUtf8 - declareForeign Untracked "Text.fromUtf8.impl.v3" boxToEFBox . mkForeign $ + declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF . mkForeign $ pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 - declareForeign Tracked "Tls.ClientConfig.default" boxBoxDirect . mkForeign $ + declareForeign Tracked "Tls.ClientConfig.default" (argNDirect 2) . mkForeign $ \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> fmap ( \store -> @@ -2713,7 +2353,7 @@ declareForeigns = do ) X.getSystemCertificateStore - declareForeign Tracked "Tls.ServerConfig.default" boxBoxDirect $ + declareForeign Tracked "Tls.ServerConfig.default" (argNDirect 2) $ mkForeign $ \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> pure $ @@ -2724,44 +2364,44 @@ declareForeigns = do let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ClientConfig.certificates.set" boxBoxDirect . mkForeign $ + in declareForeign Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) . mkForeign $ \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ServerConfig.certificates.set" boxBoxDirect . mkForeign $ + in declareForeign Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) . mkForeign $ \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params - declareForeign Tracked "TVar.new" boxDirect . mkForeign $ - \(c :: Closure) -> unsafeSTMToIO $ STM.newTVar c + declareForeign Tracked "TVar.new" (argNDirect 1) . mkForeign $ + \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c - declareForeign Tracked "TVar.read" boxDirect . mkForeign $ - \(v :: STM.TVar Closure) -> unsafeSTMToIO $ STM.readTVar v + declareForeign Tracked "TVar.read" (argNDirect 1) . mkForeign $ + \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v - declareForeign Tracked "TVar.write" boxBoxTo0 . mkForeign $ - \(v :: STM.TVar Closure, c :: Closure) -> + declareForeign Tracked "TVar.write" arg2To0 . mkForeign $ + \(v :: STM.TVar Val, c :: Val) -> unsafeSTMToIO $ STM.writeTVar v c - declareForeign Tracked "TVar.newIO" boxDirect . mkForeign $ - \(c :: Closure) -> STM.newTVarIO c + declareForeign Tracked "TVar.newIO" (argNDirect 1) . mkForeign $ + \(c :: Val) -> STM.newTVarIO c - declareForeign Tracked "TVar.readIO" boxDirect . mkForeign $ - \(v :: STM.TVar Closure) -> STM.readTVarIO v + declareForeign Tracked "TVar.readIO" (argNDirect 1) . mkForeign $ + \(v :: STM.TVar Val) -> STM.readTVarIO v - declareForeign Tracked "TVar.swap" boxBoxDirect . mkForeign $ - \(v, c :: Closure) -> unsafeSTMToIO $ STM.swapTVar v c + declareForeign Tracked "TVar.swap" (argNDirect 2) . mkForeign $ + \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c declareForeign Tracked "STM.retry" unitDirect . mkForeign $ - \() -> unsafeSTMToIO STM.retry :: IO Closure + \() -> unsafeSTMToIO STM.retry :: IO Val -- Scope and Ref stuff - declareForeign Untracked "Scope.ref" boxDirect + declareForeign Untracked "Scope.ref" (argNDirect 1) . mkForeign - $ \(c :: Closure) -> newIORef c + $ \(c :: Val) -> newIORef c - declareForeign Tracked "IO.ref" boxDirect + declareForeign Tracked "IO.ref" (argNDirect 1) . mkForeign - $ \(c :: Closure) -> evaluate c >>= newIORef + $ \(c :: Val) -> evaluate c >>= newIORef -- The docs for IORef state that IORef operations can be observed -- out of order ([1]) but actually GHC does emit the appropriate @@ -2770,17 +2410,17 @@ declareForeigns = do -- [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 - declareForeign Untracked "Ref.read" boxDirect . mkForeign $ - \(r :: IORef Closure) -> readIORef r + declareForeign Untracked "Ref.read" (argNDirect 1) . mkForeign $ + \(r :: IORef Val) -> readIORef r - declareForeign Untracked "Ref.write" boxBoxTo0 . mkForeign $ - \(r :: IORef Closure, c :: Closure) -> evaluate c >>= writeIORef r + declareForeign Untracked "Ref.write" arg2To0 . mkForeign $ + \(r :: IORef Val, c :: Val) -> evaluate c >>= writeIORef r - declareForeign Tracked "Ref.readForCas" boxDirect . mkForeign $ - \(r :: IORef Closure) -> readForCAS r + declareForeign Tracked "Ref.readForCas" (argNDirect 1) . mkForeign $ + \(r :: IORef Val) -> readForCAS r - declareForeign Tracked "Ref.Ticket.read" boxDirect . mkForeign $ - \(t :: Ticket Closure) -> pure $ peekTicket t + declareForeign Tracked "Ref.Ticket.read" (argNDirect 1) . mkForeign $ + \(t :: Ticket Val) -> pure $ peekTicket t -- In GHC, CAS returns both a Boolean and the current value of the -- IORef, which can be used to retry a failed CAS. @@ -2795,39 +2435,39 @@ declareForeigns = do -- -- [1]: https://github.com/ghc/ghc/blob/master/rts/PrimOps.cmm#L697 -- [2]: https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L285 - declareForeign Tracked "Ref.cas" boxBoxBoxToBool . mkForeign $ - \(r :: IORef Closure, t :: Ticket Closure, v :: Closure) -> fmap fst $ + declareForeign Tracked "Ref.cas" (argNToBool 3) . mkForeign $ + \(r :: IORef Val, t :: Ticket Val, v :: Val) -> fmap fst $ do t <- evaluate t casIORef r t v declareForeign Tracked "Promise.new" unitDirect . mkForeign $ - \() -> newPromise @Closure + \() -> newPromise @Val -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign Tracked "Promise.read" boxDirect . mkForeign $ - \(p :: Promise Closure) -> readPromise p + declareForeign Tracked "Promise.read" (argNDirect 1) . mkForeign $ + \(p :: Promise Val) -> readPromise p - declareForeign Tracked "Promise.tryRead" boxToMaybeBox . mkForeign $ - \(p :: Promise Closure) -> tryReadPromise p + declareForeign Tracked "Promise.tryRead" argToMaybe . mkForeign $ + \(p :: Promise Val) -> tryReadPromise p - declareForeign Tracked "Promise.write" boxBoxToBool . mkForeign $ - \(p :: Promise Closure, a :: Closure) -> writePromise p a + declareForeign Tracked "Promise.write" (argNToBool 2) . mkForeign $ + \(p :: Promise Val, a :: Val) -> writePromise p a - declareForeign Tracked "Tls.newClient.impl.v3" boxBoxToEFBox . mkForeignTls $ + declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF . mkForeignTls $ \( config :: TLS.ClientParams, socket :: SYS.Socket ) -> TLS.contextNew socket config - declareForeign Tracked "Tls.newServer.impl.v3" boxBoxToEFBox . mkForeignTls $ + declareForeign Tracked "Tls.newServer.impl.v3" arg2ToEF . mkForeignTls $ \( config :: TLS.ServerParams, socket :: SYS.Socket ) -> TLS.contextNew socket config - declareForeign Tracked "Tls.handshake.impl.v3" boxToEF0 . mkForeignTls $ + declareForeign Tracked "Tls.handshake.impl.v3" argToEF0 . mkForeignTls $ \(tls :: TLS.Context) -> TLS.handshake tls - declareForeign Tracked "Tls.send.impl.v3" boxBoxToEF0 . mkForeignTls $ + declareForeign Tracked "Tls.send.impl.v3" arg2ToEF0 . mkForeignTls $ \( tls :: TLS.Context, bytes :: Bytes.Bytes ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) @@ -2840,53 +2480,53 @@ declareForeigns = do Left l -> Left l asCert :: PEM -> Either String X.SignedCertificate asCert pem = X.decodeSignedCertificate $ pemContent pem - in declareForeign Tracked "Tls.decodeCert.impl.v3" boxToEFBox . mkForeignTlsE $ + in declareForeign Tracked "Tls.decodeCert.impl.v3" argToEF . mkForeignTlsE $ \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes - declareForeign Tracked "Tls.encodeCert" boxDirect . mkForeign $ + declareForeign Tracked "Tls.encodeCert" (argNDirect 1) . mkForeign $ \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert - declareForeign Tracked "Tls.decodePrivateKey" boxDirect . mkForeign $ + declareForeign Tracked "Tls.decodePrivateKey" (argNDirect 1) . mkForeign $ \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes - declareForeign Tracked "Tls.encodePrivateKey" boxDirect . mkForeign $ + declareForeign Tracked "Tls.encodePrivateKey" (argNDirect 1) . mkForeign $ \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey - declareForeign Tracked "Tls.receive.impl.v3" boxToEFBox . mkForeignTls $ + declareForeign Tracked "Tls.receive.impl.v3" argToEF . mkForeignTls $ \(tls :: TLS.Context) -> do bs <- TLS.recvData tls pure $ Bytes.fromArray bs - declareForeign Tracked "Tls.terminate.impl.v3" boxToEF0 . mkForeignTls $ + declareForeign Tracked "Tls.terminate.impl.v3" argToEF0 . mkForeignTls $ \(tls :: TLS.Context) -> TLS.bye tls - declareForeign Untracked "Code.validateLinks" boxToExnEBoxBox + declareForeign Untracked "Code.validateLinks" argToExnE . mkForeign $ \(lsgs0 :: [(Referent, Code)]) -> do let f (msg, rs) = Failure Ty.miscFailureRef (Util.Text.fromText msg) rs pure . first f $ checkGroupHashes lsgs0 - declareForeign Untracked "Code.dependencies" boxDirect + declareForeign Untracked "Code.dependencies" (argNDirect 1) . mkForeign $ \(CodeRep sg _) -> pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg - declareForeign Untracked "Code.serialize" boxDirect + declareForeign Untracked "Code.serialize" (argNDirect 1) . mkForeign $ \(co :: Code) -> pure . Bytes.fromArray $ serializeCode builtinForeignNames co - declareForeign Untracked "Code.deserialize" boxToEBoxBox + declareForeign Untracked "Code.deserialize" argToEither . mkForeign $ pure . deserializeCode . Bytes.toArray - declareForeign Untracked "Code.display" boxBoxDirect . mkForeign $ + declareForeign Untracked "Code.display" (argNDirect 2) . mkForeign $ \(nm, (CodeRep sg _)) -> pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" - declareForeign Untracked "Value.dependencies" boxDirect + declareForeign Untracked "Value.dependencies" (argNDirect 1) . mkForeign $ pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks - declareForeign Untracked "Value.serialize" boxDirect + declareForeign Untracked "Value.serialize" (argNDirect 1) . mkForeign $ pure . Bytes.fromArray . serializeValue - declareForeign Untracked "Value.deserialize" boxToEBoxBox + declareForeign Untracked "Value.deserialize" argToEither . mkForeign $ pure . deserializeValue . Bytes.toArray -- Hashing functions @@ -2906,12 +2546,12 @@ declareForeigns = do declareHashAlgorithm "Blake2s_256" Hash.Blake2s_256 declareHashAlgorithm "Md5" Hash.MD5 - declareForeign Untracked "crypto.hashBytes" boxBoxDirect . mkForeign $ + declareForeign Untracked "crypto.hashBytes" (argNDirect 2) . mkForeign $ \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> let ctx = Hash.hashInitWith alg in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) - declareForeign Untracked "crypto.hmacBytes" boxBoxBoxDirect + declareForeign Untracked "crypto.hmacBytes" (argNDirect 3) . mkForeign $ \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) @@ -2940,19 +2580,19 @@ declareForeigns = do $ L.toChunks s in pure . Bytes.fromArray . hmac alg $ serializeValueForHash x - declareForeign Untracked "crypto.Ed25519.sign.impl" boxBoxBoxToEFBox + declareForeign Untracked "crypto.Ed25519.sign.impl" arg3ToEF . mkForeign $ pure . signEd25519Wrapper - declareForeign Untracked "crypto.Ed25519.verify.impl" boxBoxBoxToEFBool + declareForeign Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool . mkForeign $ pure . verifyEd25519Wrapper - declareForeign Untracked "crypto.Rsa.sign.impl" boxBoxToEFBox + declareForeign Untracked "crypto.Rsa.sign.impl" arg2ToEF . mkForeign $ pure . signRsaWrapper - declareForeign Untracked "crypto.Rsa.verify.impl" boxBoxBoxToEFBool + declareForeign Untracked "crypto.Rsa.verify.impl" arg3ToEFBool . mkForeign $ pure . verifyRsaWrapper @@ -2966,45 +2606,45 @@ declareForeigns = do declareForeign Untracked "Universal.murmurHash" murmur'hash . mkForeign $ pure . asWord64 . hash64 . serializeValueForHash - declareForeign Tracked "IO.randomBytes" natToBox . mkForeign $ + declareForeign Tracked "IO.randomBytes" (argNDirect 1) . mkForeign $ \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n - declareForeign Untracked "Bytes.zlib.compress" boxDirect . mkForeign $ pure . Bytes.zlibCompress - declareForeign Untracked "Bytes.gzip.compress" boxDirect . mkForeign $ pure . Bytes.gzipCompress - declareForeign Untracked "Bytes.zlib.decompress" boxToEBoxBox . mkForeign $ \bs -> + declareForeign Untracked "Bytes.zlib.compress" (argNDirect 1) . mkForeign $ pure . Bytes.zlibCompress + declareForeign Untracked "Bytes.gzip.compress" (argNDirect 1) . mkForeign $ pure . Bytes.gzipCompress + declareForeign Untracked "Bytes.zlib.decompress" argToEither . mkForeign $ \bs -> catchAll (pure (Bytes.zlibDecompress bs)) - declareForeign Untracked "Bytes.gzip.decompress" boxToEBoxBox . mkForeign $ \bs -> + declareForeign Untracked "Bytes.gzip.decompress" argToEither . mkForeign $ \bs -> catchAll (pure (Bytes.gzipDecompress bs)) - declareForeign Untracked "Bytes.toBase16" boxDirect . mkForeign $ pure . Bytes.toBase16 - declareForeign Untracked "Bytes.toBase32" boxDirect . mkForeign $ pure . Bytes.toBase32 - declareForeign Untracked "Bytes.toBase64" boxDirect . mkForeign $ pure . Bytes.toBase64 - declareForeign Untracked "Bytes.toBase64UrlUnpadded" boxDirect . mkForeign $ pure . Bytes.toBase64UrlUnpadded + declareForeign Untracked "Bytes.toBase16" (argNDirect 1) . mkForeign $ pure . Bytes.toBase16 + declareForeign Untracked "Bytes.toBase32" (argNDirect 1) . mkForeign $ pure . Bytes.toBase32 + declareForeign Untracked "Bytes.toBase64" (argNDirect 1) . mkForeign $ pure . Bytes.toBase64 + declareForeign Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) . mkForeign $ pure . Bytes.toBase64UrlUnpadded - declareForeign Untracked "Bytes.fromBase16" boxToEBoxBox . mkForeign $ + declareForeign Untracked "Bytes.fromBase16" argToEither . mkForeign $ pure . mapLeft Util.Text.fromText . Bytes.fromBase16 - declareForeign Untracked "Bytes.fromBase32" boxToEBoxBox . mkForeign $ + declareForeign Untracked "Bytes.fromBase32" argToEither . mkForeign $ pure . mapLeft Util.Text.fromText . Bytes.fromBase32 - declareForeign Untracked "Bytes.fromBase64" boxToEBoxBox . mkForeign $ + declareForeign Untracked "Bytes.fromBase64" argToEither . mkForeign $ pure . mapLeft Util.Text.fromText . Bytes.fromBase64 - declareForeign Untracked "Bytes.fromBase64UrlUnpadded" boxToEBoxBox . mkForeign $ + declareForeign Untracked "Bytes.fromBase64UrlUnpadded" argToEither . mkForeign $ pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded - declareForeign Untracked "Bytes.decodeNat64be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64be - declareForeign Untracked "Bytes.decodeNat64le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64le - declareForeign Untracked "Bytes.decodeNat32be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32be - declareForeign Untracked "Bytes.decodeNat32le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32le - declareForeign Untracked "Bytes.decodeNat16be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16be - declareForeign Untracked "Bytes.decodeNat16le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16le - - declareForeign Untracked "Bytes.encodeNat64be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat64be - declareForeign Untracked "Bytes.encodeNat64le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat64le - declareForeign Untracked "Bytes.encodeNat32be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat32be - declareForeign Untracked "Bytes.encodeNat32le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat32le - declareForeign Untracked "Bytes.encodeNat16be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16be - declareForeign Untracked "Bytes.encodeNat16le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16le - - declareForeign Untracked "MutableArray.copyTo!" boxNatBoxNatNatToExnUnit + declareForeign Untracked "Bytes.decodeNat64be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64be + declareForeign Untracked "Bytes.decodeNat64le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64le + declareForeign Untracked "Bytes.decodeNat32be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32be + declareForeign Untracked "Bytes.decodeNat32le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32le + declareForeign Untracked "Bytes.decodeNat16be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16be + declareForeign Untracked "Bytes.decodeNat16le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16le + + declareForeign Untracked "Bytes.encodeNat64be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat64be + declareForeign Untracked "Bytes.encodeNat64le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat64le + declareForeign Untracked "Bytes.encodeNat32be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat32be + declareForeign Untracked "Bytes.encodeNat32le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat32le + declareForeign Untracked "Bytes.encodeNat16be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat16be + declareForeign Untracked "Bytes.encodeNat16le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat16le + + declareForeign Untracked "MutableArray.copyTo!" arg5ToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> let name = "MutableArray.copyTo!" @@ -3014,14 +2654,14 @@ declareForeigns = do checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ Right - <$> PA.copyMutableArray @IO @Closure + <$> PA.copyMutableArray @IO @Val dst (fromIntegral doff) src (fromIntegral soff) (fromIntegral l) - declareForeign Untracked "MutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.copyTo!" arg5ToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> let name = "MutableByteArray.copyTo!" @@ -3038,7 +2678,7 @@ declareForeigns = do (fromIntegral soff) (fromIntegral l) - declareForeign Untracked "ImmutableArray.copyTo!" boxNatBoxNatNatToExnUnit + declareForeign Untracked "ImmutableArray.copyTo!" arg5ToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> let name = "ImmutableArray.copyTo!" @@ -3048,23 +2688,23 @@ declareForeigns = do checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ checkBounds name (PA.sizeofArray src) (soff + l - 1) $ Right - <$> PA.copyArray @IO @Closure + <$> PA.copyArray @IO @Val dst (fromIntegral doff) src (fromIntegral soff) (fromIntegral l) - declareForeign Untracked "ImmutableArray.size" boxToNat . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofArray @Closure - declareForeign Untracked "MutableArray.size" boxToNat . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Closure - declareForeign Untracked "ImmutableByteArray.size" boxToNat . mkForeign $ + declareForeign Untracked "ImmutableArray.size" (argNDirect 1) . mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val + declareForeign Untracked "MutableArray.size" (argNDirect 1) . mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val + declareForeign Untracked "ImmutableByteArray.size" (argNDirect 1) . mkForeign $ pure . fromIntegral @Int @Word64 . PA.sizeofByteArray - declareForeign Untracked "MutableByteArray.size" boxToNat . mkForeign $ + declareForeign Untracked "MutableByteArray.size" (argNDirect 1) . mkForeign $ pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld - declareForeign Untracked "ImmutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit + declareForeign Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> let name = "ImmutableByteArray.copyTo!" @@ -3081,72 +2721,72 @@ declareForeigns = do (fromIntegral soff) (fromIntegral l) - declareForeign Untracked "MutableArray.read" boxNatToExnBox + declareForeign Untracked "MutableArray.read" arg2ToExn . mkForeign $ checkedRead "MutableArray.read" - declareForeign Untracked "MutableByteArray.read8" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read8" arg2ToExn . mkForeign $ checkedRead8 "MutableByteArray.read8" - declareForeign Untracked "MutableByteArray.read16be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read16be" arg2ToExn . mkForeign $ checkedRead16 "MutableByteArray.read16be" - declareForeign Untracked "MutableByteArray.read24be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read24be" arg2ToExn . mkForeign $ checkedRead24 "MutableByteArray.read24be" - declareForeign Untracked "MutableByteArray.read32be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read32be" arg2ToExn . mkForeign $ checkedRead32 "MutableByteArray.read32be" - declareForeign Untracked "MutableByteArray.read40be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read40be" arg2ToExn . mkForeign $ checkedRead40 "MutableByteArray.read40be" - declareForeign Untracked "MutableByteArray.read64be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read64be" arg2ToExn . mkForeign $ checkedRead64 "MutableByteArray.read64be" - declareForeign Untracked "MutableArray.write" boxNatBoxToExnUnit + declareForeign Untracked "MutableArray.write" arg3ToExnUnit . mkForeign $ checkedWrite "MutableArray.write" - declareForeign Untracked "MutableByteArray.write8" boxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.write8" arg3ToExnUnit . mkForeign $ checkedWrite8 "MutableByteArray.write8" - declareForeign Untracked "MutableByteArray.write16be" boxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.write16be" arg3ToExnUnit . mkForeign $ checkedWrite16 "MutableByteArray.write16be" - declareForeign Untracked "MutableByteArray.write32be" boxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.write32be" arg3ToExnUnit . mkForeign $ checkedWrite32 "MutableByteArray.write32be" - declareForeign Untracked "MutableByteArray.write64be" boxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.write64be" arg3ToExnUnit . mkForeign $ checkedWrite64 "MutableByteArray.write64be" - declareForeign Untracked "ImmutableArray.read" boxNatToExnBox + declareForeign Untracked "ImmutableArray.read" arg2ToExn . mkForeign $ checkedIndex "ImmutableArray.read" - declareForeign Untracked "ImmutableByteArray.read8" boxNatToExnNat + declareForeign Untracked "ImmutableByteArray.read8" arg2ToExn . mkForeign $ checkedIndex8 "ImmutableByteArray.read8" - declareForeign Untracked "ImmutableByteArray.read16be" boxNatToExnNat + declareForeign Untracked "ImmutableByteArray.read16be" arg2ToExn . mkForeign $ checkedIndex16 "ImmutableByteArray.read16be" - declareForeign Untracked "ImmutableByteArray.read24be" boxNatToExnNat + declareForeign Untracked "ImmutableByteArray.read24be" arg2ToExn . mkForeign $ checkedIndex24 "ImmutableByteArray.read24be" - declareForeign Untracked "ImmutableByteArray.read32be" boxNatToExnNat + declareForeign Untracked "ImmutableByteArray.read32be" arg2ToExn . mkForeign $ checkedIndex32 "ImmutableByteArray.read32be" - declareForeign Untracked "ImmutableByteArray.read40be" boxNatToExnNat + declareForeign Untracked "ImmutableByteArray.read40be" arg2ToExn . mkForeign $ checkedIndex40 "ImmutableByteArray.read40be" - declareForeign Untracked "ImmutableByteArray.read64be" boxNatToExnNat + declareForeign Untracked "ImmutableByteArray.read64be" arg2ToExn . mkForeign $ checkedIndex64 "ImmutableByteArray.read64be" - declareForeign Untracked "MutableByteArray.freeze!" boxDirect . mkForeign $ + declareForeign Untracked "MutableByteArray.freeze!" (argNDirect 1) . mkForeign $ PA.unsafeFreezeByteArray - declareForeign Untracked "MutableArray.freeze!" boxDirect . mkForeign $ - PA.unsafeFreezeArray @IO @Closure + declareForeign Untracked "MutableArray.freeze!" (argNDirect 1) . mkForeign $ + PA.unsafeFreezeArray @IO @Val - declareForeign Untracked "MutableByteArray.freeze" boxNatNatToExnBox . mkForeign $ + declareForeign Untracked "MutableByteArray.freeze" arg3ToExn . mkForeign $ \(src, off, len) -> if len == 0 then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 @@ -3158,10 +2798,10 @@ declareForeigns = do 0 $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) - declareForeign Untracked "MutableArray.freeze" boxNatNatToExnBox . mkForeign $ - \(src :: PA.MutableArray PA.RealWorld Closure, off, len) -> + declareForeign Untracked "MutableArray.freeze" arg3ToExn . mkForeign $ + \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> if len == 0 - then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 ( Closure.BlackHole) + then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal else checkBounds "MutableArray.freeze" @@ -3169,37 +2809,37 @@ declareForeigns = do (off + len - 1) $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) - declareForeign Untracked "MutableByteArray.length" boxToNat . mkForeign $ + declareForeign Untracked "MutableByteArray.length" (argNDirect 1) . mkForeign $ pure . PA.sizeofMutableByteArray @PA.RealWorld - declareForeign Untracked "ImmutableByteArray.length" boxToNat . mkForeign $ + declareForeign Untracked "ImmutableByteArray.length" (argNDirect 1) . mkForeign $ pure . PA.sizeofByteArray - declareForeign Tracked "IO.array" natToBox . mkForeign $ - \n -> PA.newArray n (Closure.BlackHole :: Closure) - declareForeign Tracked "IO.arrayOf" boxNatToBox . mkForeign $ - \(v :: Closure, n) -> PA.newArray n v - declareForeign Tracked "IO.bytearray" natToBox . mkForeign $ PA.newByteArray - declareForeign Tracked "IO.bytearrayOf" natNatToBox + declareForeign Tracked "IO.array" (argNDirect 1) . mkForeign $ + \n -> PA.newArray n emptyVal + declareForeign Tracked "IO.arrayOf" (argNDirect 2) . mkForeign $ + \(v :: Val, n) -> PA.newArray n v + declareForeign Tracked "IO.bytearray" (argNDirect 1) . mkForeign $ PA.newByteArray + declareForeign Tracked "IO.bytearrayOf" (argNDirect 2) . mkForeign $ \(init, sz) -> do arr <- PA.newByteArray sz PA.fillByteArray arr 0 sz init pure arr - declareForeign Untracked "Scope.array" natToBox . mkForeign $ - \n -> PA.newArray n (Closure.BlackHole :: Closure) - declareForeign Untracked "Scope.arrayOf" boxNatToBox . mkForeign $ - \(v :: Closure, n) -> PA.newArray n v - declareForeign Untracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray - declareForeign Untracked "Scope.bytearrayOf" natNatToBox + declareForeign Untracked "Scope.array" (argNDirect 1) . mkForeign $ + \n -> PA.newArray n emptyVal + declareForeign Untracked "Scope.arrayOf" (argNDirect 2) . mkForeign $ + \(v :: Val, n) -> PA.newArray n v + declareForeign Untracked "Scope.bytearray" (argNDirect 1) . mkForeign $ PA.newByteArray + declareForeign Untracked "Scope.bytearrayOf" (argNDirect 2) . mkForeign $ \(init, sz) -> do arr <- PA.newByteArray sz PA.fillByteArray arr 0 sz init pure arr - declareForeign Untracked "Text.patterns.literal" boxDirect . mkForeign $ + declareForeign Untracked "Text.patterns.literal" (argNDirect 1) . mkForeign $ \txt -> evaluate . TPat.cpattern $ TPat.Literal txt declareForeign Untracked "Text.patterns.digit" direct . mkForeign $ let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v @@ -3213,52 +2853,51 @@ declareForeigns = do let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v declareForeign Untracked "Text.patterns.eof" direct . mkForeign $ let v = TPat.cpattern TPat.Eof in \() -> pure v - let ccd = wordWordDirect Ty.charRef Ty.charRef - declareForeign Untracked "Text.patterns.charRange" ccd . mkForeign $ + declareForeign Untracked "Text.patterns.charRange" (argNDirect 2) . mkForeign $ \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.notCharRange" ccd . mkForeign $ + declareForeign Untracked "Text.patterns.notCharRange" (argNDirect 2) . mkForeign $ \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.charIn" boxDirect . mkForeign $ \ccs -> do + declareForeign Untracked "Text.patterns.charIn" (argNDirect 1) . mkForeign $ \ccs -> do cs <- for ccs $ \case - Closure.DataU1 _ _ i -> pure (toEnum i) + CharVal c -> pure c _ -> die "Text.patterns.charIn: non-character closure" evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs - declareForeign Untracked "Text.patterns.notCharIn" boxDirect . mkForeign $ \ccs -> do + declareForeign Untracked "Text.patterns.notCharIn" (argNDirect 1) . mkForeign $ \ccs -> do cs <- for ccs $ \case - Closure.DataU1 _ _ i -> pure (toEnum i) + CharVal c -> pure c _ -> die "Text.patterns.notCharIn: non-character closure" evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs - declareForeign Untracked "Pattern.many" boxDirect . mkForeign $ + declareForeign Untracked "Pattern.many" (argNDirect 1) . mkForeign $ \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p - declareForeign Untracked "Pattern.many.corrected" boxDirect . mkForeign $ + declareForeign Untracked "Pattern.many.corrected" (argNDirect 1) . mkForeign $ \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p - declareForeign Untracked "Pattern.capture" boxDirect . mkForeign $ + declareForeign Untracked "Pattern.capture" (argNDirect 1) . mkForeign $ \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p - declareForeign Untracked "Pattern.captureAs" boxBoxDirect . mkForeign $ + declareForeign Untracked "Pattern.captureAs" (argNDirect 2) . mkForeign $ \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p - declareForeign Untracked "Pattern.join" boxDirect . mkForeign $ \ps -> + declareForeign Untracked "Pattern.join" (argNDirect 1) . mkForeign $ \ps -> evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps - declareForeign Untracked "Pattern.or" boxBoxDirect . mkForeign $ + declareForeign Untracked "Pattern.or" (argNDirect 2) . mkForeign $ \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r - declareForeign Untracked "Pattern.replicate" natNatBoxToBox . mkForeign $ + declareForeign Untracked "Pattern.replicate" (argNDirect 3) . mkForeign $ \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> let m = fromIntegral m0; n = fromIntegral n0 in evaluate . TPat.cpattern $ TPat.Replicate m n p - declareForeign Untracked "Pattern.run" boxBoxToMaybeTup . mkForeign $ + declareForeign Untracked "Pattern.run" arg2ToMaybeTup . mkForeign $ \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input - declareForeign Untracked "Pattern.isMatch" boxBoxToBool . mkForeign $ + declareForeign Untracked "Pattern.isMatch" (argNToBool 2) . mkForeign $ \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input declareForeign Untracked "Char.Class.any" direct . mkForeign $ \() -> pure TPat.Any - declareForeign Untracked "Char.Class.not" boxDirect . mkForeign $ pure . TPat.Not - declareForeign Untracked "Char.Class.and" boxBoxDirect . mkForeign $ \(a, b) -> pure $ TPat.Intersect a b - declareForeign Untracked "Char.Class.or" boxBoxDirect . mkForeign $ \(a, b) -> pure $ TPat.Union a b - declareForeign Untracked "Char.Class.range" (wordWordDirect charRef charRef) . mkForeign $ \(a, b) -> pure $ TPat.CharRange a b - declareForeign Untracked "Char.Class.anyOf" boxDirect . mkForeign $ \ccs -> do + declareForeign Untracked "Char.Class.not" (argNDirect 1) . mkForeign $ pure . TPat.Not + declareForeign Untracked "Char.Class.and" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.Intersect a b + declareForeign Untracked "Char.Class.or" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.Union a b + declareForeign Untracked "Char.Class.range" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.CharRange a b + declareForeign Untracked "Char.Class.anyOf" (argNDirect 1) . mkForeign $ \ccs -> do cs <- for ccs $ \case - Closure.DataU1 _ _ i -> pure (toEnum i) + CharVal c -> pure c _ -> die "Text.patterns.charIn: non-character closure" evaluate $ TPat.CharSet cs declareForeign Untracked "Char.Class.alphanumeric" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) @@ -3273,14 +2912,14 @@ 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" (boxWordToBool charRef) . mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c - declareForeign Untracked "Text.patterns.char" boxDirect . mkForeign $ \c -> + declareForeign Untracked "Char.Class.is" (argNToBool 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 type RW = PA.PrimState IO checkedRead :: - Text -> (PA.MutableArray RW Closure, Word64) -> IO (Either Failure Closure) + Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) checkedRead name (arr, w) = checkBounds name @@ -3289,7 +2928,7 @@ checkedRead name (arr, w) = (Right <$> PA.readArray arr (fromIntegral w)) checkedWrite :: - Text -> (PA.MutableArray RW Closure, Word64, Closure) -> IO (Either Failure ()) + Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) checkedWrite name (arr, w, v) = checkBounds name @@ -3298,7 +2937,7 @@ checkedWrite name (arr, w, v) = (Right <$> PA.writeArray arr (fromIntegral w) v) checkedIndex :: - Text -> (PA.Array Closure, Word64) -> IO (Either Failure Closure) + Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) checkedIndex name (arr, w) = checkBounds name @@ -3665,7 +3304,7 @@ baseSandboxInfo = builtinArities :: Map Reference Int builtinArities = Map.fromList $ - [ (r, arity s) | (r, (_, s)) <- Map.toList builtinLookup ] + [(r, arity s) | (r, (_, s)) <- Map.toList builtinLookup] builtinInlineInfo :: Map Reference (Int, ANormal Symbol) builtinInlineInfo = diff --git a/unison-runtime/src/Unison/Runtime/Decompile.hs b/unison-runtime/src/Unison/Runtime/Decompile.hs index 564c08e16b..b650f450c9 100644 --- a/unison-runtime/src/Unison/Runtime/Decompile.hs +++ b/unison-runtime/src/Unison/Runtime/Decompile.hs @@ -35,6 +35,9 @@ import Unison.Runtime.IOSource (iarrayFromListRef, ibarrayFromBytesRef) import Unison.Runtime.MCode (CombIx (..)) import Unison.Runtime.Stack ( Closure (..), + USeq, + UnboxedTypeTag (..), + Val (..), pattern DataC, pattern PApV, ) @@ -62,21 +65,16 @@ import Unison.Term qualified as Term import Unison.Type ( anyRef, booleanRef, - charRef, - floatRef, iarrayRef, ibytearrayRef, - intRef, listRef, - natRef, termLinkRef, typeLinkRef, ) import Unison.Util.Bytes qualified as By -import Unison.Util.Pretty (indentN, lines, lit, syntaxToColor, wrap) +import Unison.Util.Pretty (indentN, lines, lit, shown, syntaxToColor, wrap) import Unison.Util.Text qualified as Text import Unison.Var (Var) -import Unsafe.Coerce -- for Int -> Double import Prelude hiding (lines) con :: (Var v) => Reference -> Word64 -> Term v () @@ -90,7 +88,7 @@ err err x = (singleton err, x) data DecompError = BadBool !Word64 - | BadUnboxed !Reference + | BadUnboxed !UnboxedTypeTag | BadForeign !Reference | BadData !Reference | BadPAp !Reference @@ -105,16 +103,19 @@ type DecompResult v = (Set DecompError, Term v ()) prf :: Reference -> Error prf = syntaxToColor . prettyReference 10 +printUnboxedTypeTag :: UnboxedTypeTag -> Error +printUnboxedTypeTag = shown + renderDecompError :: DecompError -> Error renderDecompError (BadBool n) = lines [ wrap "A boolean value had an unexpected constructor tag:", indentN 2 . lit . fromString $ show n ] -renderDecompError (BadUnboxed rf) = +renderDecompError (BadUnboxed tt) = lines - [ wrap "An apparent numeric type had an unrecognized reference:", - indentN 2 $ prf rf + [ wrap "An apparent numeric type had an unrecognized packed tag:", + indentN 2 $ printUnboxedTypeTag tt ] renderDecompError (BadForeign rf) = lines @@ -147,42 +148,45 @@ renderDecompError Cont = "A continuation value was encountered" renderDecompError Exn = "An exception value was encountered" decompile :: + forall v. (Var v) => (Reference -> Maybe Reference) -> (Word64 -> Word64 -> Maybe (Term v ())) -> - Closure -> + Val -> DecompResult v decompile backref topTerms = \case - DataC rf (maskTags -> ct) [] - | rf == booleanRef -> tag2bool ct - DataC rf (maskTags -> ct) [Left i] -> - decompileUnboxed rf ct i - (DataC rf _ [Right b]) - | rf == anyRef -> - app () (builtin () "Any.Any") <$> decompile backref topTerms b - (DataC rf (maskTags -> ct) vs) - -- Only match lists of boxed args. - | ([], bs) <- partitionEithers vs -> - apps' (con rf ct) <$> traverse (decompile backref topTerms) bs - (PApV (CIx rf rt k) _ (partitionEithers -> ([], bs))) - | rf == Builtin "jumpCont" -> - err Cont $ bug "" - | Builtin nm <- rf -> - apps' (builtin () nm) <$> traverse (decompile backref topTerms) bs - | Just t <- topTerms rt k -> - Term.etaReduceEtaVars . substitute t - <$> traverse (decompile backref topTerms) bs - | k > 0, - Just _ <- topTerms rt 0 -> - err (UnkLocal rf k) $ bug "" - | otherwise -> err (UnkComb rf) $ ref () rf - (PAp (CIx rf _ _) _ _) -> - err (BadPAp rf) $ bug "" - (DataC rf _ _) -> err (BadData rf) $ bug "" - BlackHole -> err Exn $ bug "" - (Captured {}) -> err Cont $ bug "" - (Foreign f) -> - decompileForeign backref topTerms f + CharVal c -> pure (char () c) + NatVal n -> pure (nat () n) + IntVal i -> pure (int () (fromIntegral i)) + DoubleVal f -> pure (float () f) + Val i (UnboxedTypeTag tt) -> + err (BadUnboxed tt) . nat () $ fromIntegral $ i + Val _u clos -> case clos of + DataC rf (maskTags -> ct) [] + | rf == booleanRef -> tag2bool ct + (DataC rf _ [b]) + | rf == anyRef -> + app () (builtin () "Any.Any") <$> decompile backref topTerms b + (DataC rf (maskTags -> ct) vs) -> + apps' (con rf ct) <$> traverse (decompile backref topTerms) vs + (PApV (CIx rf rt k) _ vs) + | rf == Builtin "jumpCont" -> + err Cont $ bug "" + | Builtin nm <- rf -> + apps' (builtin () nm) <$> traverse (decompile backref topTerms) vs + | Just t <- topTerms rt k -> + Term.etaReduceEtaVars . substitute t + <$> traverse (decompile backref topTerms) vs + | k > 0, + Just _ <- topTerms rt 0 -> + err (UnkLocal rf k) $ bug "" + | otherwise -> err (UnkComb rf) $ ref () rf + (PAp (CIx rf _ _) _ _) -> + err (BadPAp rf) $ bug "" + BlackHole -> err Exn $ bug "" + (Captured {}) -> err Cont $ bug "" + (Foreign f) -> + decompileForeign backref topTerms f tag2bool :: (Var v) => Word64 -> DecompResult v tag2bool 0 = pure (boolean () False) @@ -197,15 +201,6 @@ substitute = align [] -- this should not happen align vts tm ts = apps' (substs vts tm) ts -decompileUnboxed :: - (Var v) => Reference -> Word64 -> Int -> DecompResult v -decompileUnboxed r _ i - | r == natRef = pure . nat () $ fromIntegral i - | r == intRef = pure . int () $ fromIntegral i - | r == floatRef = pure . float () $ unsafeCoerce i - | r == charRef = pure . char () $ toEnum i - | otherwise = err (BadUnboxed r) . nat () $ fromIntegral i - decompileForeign :: (Var v) => (Reference -> Maybe Reference) -> @@ -222,7 +217,7 @@ decompileForeign backref topTerms f _ -> l | Just l <- maybeUnwrapForeign typeLinkRef f = pure $ typeLink () l - | Just (a :: Array Closure) <- maybeUnwrapForeign iarrayRef f = + | Just (a :: Array Val) <- maybeUnwrapForeign iarrayRef f = app () (ref () iarrayFromListRef) . list () <$> traverse (decompile backref topTerms) (toList a) | Just (a :: ByteArray) <- maybeUnwrapForeign ibytearrayRef f = @@ -250,5 +245,5 @@ decompileBytes = decompileHashAlgorithm :: (Var v) => HashAlgorithm -> Term v () decompileHashAlgorithm (HashAlgorithm r _) = ref () r -unwrapSeq :: Foreign -> Maybe (Seq Closure) +unwrapSeq :: Foreign -> Maybe USeq unwrapSeq = maybeUnwrapForeign listRef diff --git a/unison-runtime/src/Unison/Runtime/Exception.hs b/unison-runtime/src/Unison/Runtime/Exception.hs index 16a149d953..7d0d7bd5ea 100644 --- a/unison-runtime/src/Unison/Runtime/Exception.hs +++ b/unison-runtime/src/Unison/Runtime/Exception.hs @@ -10,7 +10,7 @@ import Unison.Util.Pretty as P data RuntimeExn = PE CallStack (P.Pretty P.ColorText) - | BU [(Reference, Int)] Text Closure + | BU [(Reference, Int)] Text Val deriving (Show) instance Exception RuntimeExn diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index a8f72d6388..b9bb278112 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -17,7 +17,6 @@ import Control.Concurrent.MVar (MVar) import Control.Concurrent.STM (TVar) import Control.Exception (evaluate) import Data.Atomics (Ticket) -import Data.Char qualified as Char import Data.Foldable (toList) import Data.IORef (IORef) import Data.Sequence qualified as Sq @@ -29,8 +28,8 @@ import Network.UDP (UDPSocket) import System.IO (BufferMode (..), Handle, IOMode, SeekMode) import Unison.Builtin.Decls qualified as Ty import Unison.Reference (Reference) -import Unison.Runtime.ANF (Code, Value, internalBug) import Unison.Runtime.Array qualified as PA +import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug) import Unison.Runtime.Exception import Unison.Runtime.Foreign import Unison.Runtime.MCode @@ -88,11 +87,11 @@ mkForeign ev = FF readArgs writeForeign ev "mkForeign: too many arguments for foreign function" instance ForeignConvention Int where - readForeign (i : args) stk = (args,) <$> upeekOff stk i + readForeign (i : args) stk = (args,) <$> peekOffI stk i readForeign [] _ = foreignCCError "Int" writeForeign stk i = do stk <- bump stk - stk <$ upoke stk i + stk <$ pokeI stk i instance ForeignConvention Word64 where readForeign (i : args) stk = (args,) <$> peekOffN stk i @@ -101,6 +100,8 @@ instance ForeignConvention Word64 where stk <- bump stk stk <$ pokeN stk n +-- We don't have a clear mapping from these types to Unison types, most are just mapped to Nats. + instance ForeignConvention Word8 where readForeign = readForeignAs (fromIntegral :: Word64 -> Word8) writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) @@ -114,11 +115,18 @@ instance ForeignConvention Word32 where writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) instance ForeignConvention Char where - readForeign (i : args) stk = (args,) . Char.chr <$> upeekOff stk i + readForeign (i : args) stk = (args,) <$> peekOffC stk i readForeign [] _ = foreignCCError "Char" writeForeign stk ch = do stk <- bump stk - stk <$ upoke stk (Char.ord ch) + stk <$ pokeC stk ch + +instance ForeignConvention Val where + readForeign (i : args) stk = (args,) <$> peekOff stk i + readForeign [] _ = foreignCCError "Val" + writeForeign stk v = do + stk <- bump stk + stk <$ (poke stk =<< evaluate v) -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. @@ -167,18 +175,18 @@ instance (ForeignConvention a) => ForeignConvention (Maybe a) where writeForeign stk Nothing = do stk <- bump stk - stk <$ upoke stk 0 + stk <$ pokeTag stk 0 writeForeign stk (Just x) = do stk <- writeForeign stk x stk <- bump stk - stk <$ upoke stk 1 + stk <$ pokeTag stk 1 instance (ForeignConvention a, ForeignConvention b) => ForeignConvention (Either a b) where readForeign (i : args) stk = - upeekOff stk i >>= \case + peekTagOff stk i >>= \case 0 -> readForeignAs Left args stk 1 -> readForeignAs Right args stk _ -> foreignCCError "Either" @@ -187,11 +195,11 @@ instance writeForeign stk (Left a) = do stk <- writeForeign stk a stk <- bump stk - stk <$ upoke stk 0 + stk <$ pokeTag stk 0 writeForeign stk (Right b) = do stk <- writeForeign stk b stk <- bump stk - stk <$ upoke stk 1 + stk <$ pokeTag stk 1 ioeDecode :: Int -> IOErrorType ioeDecode 0 = AlreadyExists @@ -394,7 +402,7 @@ instance stk <- writeForeign stk b writeForeign stk a -no'buf, line'buf, block'buf, sblock'buf :: Int +no'buf, line'buf, block'buf, sblock'buf :: Word64 no'buf = fromIntegral Ty.bufferModeNoBufferingId line'buf = fromIntegral Ty.bufferModeLineBufferingId block'buf = fromIntegral Ty.bufferModeBlockBufferingId @@ -402,7 +410,7 @@ sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId instance ForeignConvention BufferMode where readForeign (i : args) stk = - upeekOff stk i >>= \case + peekOffN stk i >>= \case t | t == no'buf -> pure (args, NoBuffering) | t == line'buf -> pure (args, LineBuffering) @@ -418,45 +426,55 @@ instance ForeignConvention BufferMode where writeForeign stk bm = bump stk >>= \stk -> case bm of - NoBuffering -> stk <$ upoke stk no'buf - LineBuffering -> stk <$ upoke stk line'buf - BlockBuffering Nothing -> stk <$ upoke stk block'buf + NoBuffering -> stk <$ pokeN stk no'buf + LineBuffering -> stk <$ pokeN stk line'buf + BlockBuffering Nothing -> stk <$ pokeN stk block'buf BlockBuffering (Just n) -> do - upoke stk n + pokeI stk n stk <- bump stk - stk <$ upoke stk sblock'buf + stk <$ pokeN stk sblock'buf -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. -instance ForeignConvention [Closure] where +instance {-# OVERLAPPING #-} ForeignConvention [Val] where readForeign (i : args) stk = (args,) . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[Closure]" + readForeign _ _ = foreignCCError "[Val]" writeForeign stk l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList l) +-- In reality this fixes the type to be 'RClosure', but allows us to defer +-- the typechecker a bit and avoid a bunch of annoying type annotations. +instance {-# OVERLAPPING #-} ForeignConvention [Closure] where + readForeign (i : args) stk = + (args,) . fmap getBoxedVal . toList <$> peekOffS stk i + readForeign _ _ = foreignCCError "[Closure]" + writeForeign stk l = do + stk <- bump stk + stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) + instance ForeignConvention [Foreign] where readForeign = readForeignAs (fmap marshalToForeign) writeForeign = writeForeignAs (fmap Foreign) -instance ForeignConvention (MVar Closure) where +instance ForeignConvention (MVar Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap mvarRef) -instance ForeignConvention (TVar Closure) where +instance ForeignConvention (TVar Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap tvarRef) -instance ForeignConvention (IORef Closure) where +instance ForeignConvention (IORef Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap refRef) -instance ForeignConvention (Ticket Closure) where +instance ForeignConvention (Ticket Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap ticketRef) -instance ForeignConvention (Promise Closure) where +instance ForeignConvention (Promise Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap promiseRef) @@ -472,7 +490,7 @@ instance ForeignConvention Foreign where readForeign = readForeignAs marshalToForeign writeForeign = writeForeignAs Foreign -instance ForeignConvention (PA.MutableArray s Closure) where +instance ForeignConvention (PA.MutableArray s Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap marrayRef) @@ -480,7 +498,7 @@ instance ForeignConvention (PA.MutableByteArray s) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) -instance ForeignConvention (PA.Array Closure) where +instance ForeignConvention (PA.Array Val) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) @@ -492,8 +510,8 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where readForeign = readForeignBuiltin writeForeign = writeForeignBuiltin -fromUnisonPair :: Closure -> (a, b) -fromUnisonPair (DataC _ _ [Right x, Right (DataC _ _ [Right y, Right _])]) = +fromUnisonPair :: (BuiltinForeign a, BuiltinForeign b) => Closure -> (a, b) +fromUnisonPair (DataC _ _ [BoxedVal x, BoxedVal (DataC _ _ [BoxedVal y, BoxedVal _unit])]) = (unwrapForeignClosure x, unwrapForeignClosure y) fromUnisonPair _ = error "fromUnisonPair: invalid closure" @@ -502,10 +520,10 @@ toUnisonPair :: toUnisonPair (x, y) = DataC Ty.pairRef - 0 - [Right $ wr x, Right $ DataC Ty.pairRef 0 [Right $ wr y, Right $ un]] + (PackedTag 0) + [BoxedVal $ wr x, BoxedVal $ DataC Ty.pairRef (PackedTag 0) [BoxedVal $ wr y, BoxedVal $ un]] where - un = DataC Ty.unitRef 0 [] + un = DataC Ty.unitRef (PackedTag 0) [] wr z = Foreign $ wrapBuiltin z unwrapForeignClosure :: Closure -> a @@ -514,25 +532,25 @@ unwrapForeignClosure = unwrapForeign . marshalToForeign instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where readForeign (i : args) stk = (args,) - . fmap fromUnisonPair + . fmap (fromUnisonPair . getBoxedVal) . toList <$> peekOffS stk i readForeign _ _ = foreignCCError "[(a,b)]" writeForeign stk l = do stk <- bump stk - stk <$ pokeS stk (toUnisonPair <$> Sq.fromList l) + stk <$ pokeS stk (boxedVal . toUnisonPair <$> Sq.fromList l) instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where readForeign (i : args) stk = (args,) - . fmap unwrapForeignClosure + . fmap (unwrapForeignClosure . getBoxedVal) . toList <$> peekOffS stk i readForeign _ _ = foreignCCError "[b]" writeForeign stk l = do stk <- bump stk - stk <$ pokeS stk (Foreign . wrapBuiltin <$> Sq.fromList l) + stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) foreignCCError :: String -> IO a foreignCCError nm = diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index fc6eee5657..a9103e1ec4 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -505,14 +505,14 @@ compileValue base = flip pair (rf base) . ANF.BLit . List . Seq.fromList . fmap cpair where rf = ANF.BLit . TmLink . RF.Ref - cons x y = Data RF.pairRef 0 [Right x, Right y] + cons x y = Data RF.pairRef 0 [x, y] tt = Data RF.unitRef 0 [] code sg = ANF.BLit (Code sg) pair x y = cons x (cons y tt) cpair (r, sg) = pair (rf r) (code sg) decompileCtx :: - EnumMap Word64 Reference -> EvalCtx -> Closure -> DecompResult Symbol + EnumMap Word64 Reference -> EvalCtx -> Val -> DecompResult Symbol decompileCtx crs ctx = decompile ib $ backReferenceTm crs fr ir dt where ib = intermedToBase ctx @@ -858,8 +858,8 @@ prepareEvaluation ppe tm ctx = do Just r -> r Nothing -> error "prepareEvaluation: could not remap main ref" -watchHook :: IORef Closure -> Stack -> IO () -watchHook r stk = bpeek stk >>= writeIORef r +watchHook :: IORef Val -> Stack -> IO () +watchHook r stk = peek stk >>= writeIORef r backReferenceTm :: EnumMap Word64 Reference -> @@ -1029,7 +1029,7 @@ evalInContext :: Word64 -> IO (Either Error ([Error], Term Symbol)) evalInContext ppe ctx activeThreads w = do - r <- newIORef BlackHole + r <- newIORef (boxedVal BlackHole) crs <- readTVarIO (combRefs $ ccache ctx) let hook = watchHook r decom = decompileCtx crs ctx @@ -1041,14 +1041,14 @@ evalInContext ppe ctx activeThreads w = do where tr = first (backmapRef ctx) <$> tr0 - debugText fancy c = case decom c of + debugText fancy val = case decom val of (errs, dv) | null errs -> SimpleTrace . debugTextFormat fancy $ pretty ppe dv | otherwise -> MsgTrace (debugTextFormat fancy $ tabulateErrors errs) - (show c) + (show val) (debugTextFormat fancy $ pretty ppe dv) result <- @@ -1063,7 +1063,7 @@ executeMainComb :: CCache -> IO (Either (Pretty ColorText) ()) executeMainComb init cc = do - rSection <- resolveSection cc $ Ins (Pack RF.unitRef 0 ZArgs) $ Call True init init (VArg1 0) + rSection <- resolveSection cc $ Ins (Pack RF.unitRef (PackedTag 0) ZArgs) $ Call True init init (VArg1 0) result <- UnliftIO.try . eval0 cc Nothing $ rSection case result of @@ -1365,7 +1365,7 @@ restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do srcCombs = let builtinCombs = mapWithKey (\k v -> emitComb @Symbol rns (rf k) k mempty (0, v)) numberedTermLookup in builtinCombs <> cs - combs :: EnumMap Word64 (RCombs Closure) + combs :: EnumMap Word64 (RCombs Val) combs = srcCombs & absurdCombs diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 41c97dc6f2..26d392d99a 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -57,6 +57,8 @@ import Data.Bits (shiftL, shiftR, (.|.)) import Data.Coerce import Data.Functor ((<&>)) import Data.Map.Strict qualified as M +import Data.Primitive.PrimArray +import Data.Primitive.PrimArray qualified as PA import Data.Text as Text (unpack) import Data.Void (Void, absurd) import Data.Word (Word16, Word64) @@ -71,6 +73,7 @@ import Unison.Runtime.ANF Direction (..), Func (..), Mem (..), + PackedTag (..), SuperGroup (..), SuperNormal (..), internalBug, @@ -89,9 +92,6 @@ import Unison.Runtime.ANF pattern TVar, ) import Unison.Runtime.ANF qualified as ANF -import Unison.Runtime.Array -import Unison.Runtime.Array qualified as PA -import Unison.Runtime.Builtin.Types (builtinTypeNumbering) import Unison.Util.EnumContainers as EC import Unison.Util.Text (Text) import Unison.Var (Var) @@ -289,101 +289,114 @@ countArgs (VArgV {}) = internalBug "countArgs: DArgV" data UPrim1 = -- integral - DECI - | INCI - | NEGI - | SGNI -- decrement,increment,negate,signum - | LZRO - | TZRO - | COMN - | POPC -- leading/trailingZeroes,complement + DECI -- decrement + | DECN + | INCI -- increment + | INCN + | NEGI -- negate + | SGNI -- signum + | LZRO -- leadingZeroes + | TZRO -- trailingZeroes + | COMN -- complement + | COMI -- complement + | POPC -- popCount -- floating - | ABSF - | EXPF - | LOGF - | SQRT -- abs,exp,log,sqrt - | COSF - | ACOS - | COSH - | ACSH -- cos,acos,cosh,acosh - | SINF - | ASIN - | SINH - | ASNH -- sin,asin,sinh,asinh - | TANF - | ATAN - | TANH - | ATNH -- tan,atan,tanh,atanh - | ITOF - | NTOF - | CEIL - | FLOR -- intToFloat,natToFloat,ceiling,floor - | TRNF - | RNDF -- truncate,round + | ABSF -- abs + | EXPF -- exp + | LOGF -- log + | SQRT -- sqrt + | COSF -- cos + | ACOS -- acos + | COSH -- cosh + | ACSH -- acosh + | SINF -- sin + | ASIN -- asin + | SINH -- sinh + | ASNH -- asinh + | TANF -- tan + | ATAN -- atan + | TANH -- tanh + | ATNH -- atanh + | ITOF -- intToFloat + | NTOF -- natToFloat + | CEIL -- ceiling + | FLOR -- floor + | TRNF -- truncate + | RNDF -- round deriving (Show, Eq, Ord, Enum, Bounded) data UPrim2 = -- integral - ADDI - | SUBI + ADDI -- + + | ADDN + | SUBI -- - + | SUBN | MULI - | DIVI - | MODI -- +,-,*,/,mod + | MULN + | DIVI -- / | DIVN + | MODI -- mod | MODN - | SHLI - | SHRI + | SHLI -- shiftl + | SHLN + | SHRI -- shiftr | SHRN - | POWI -- shiftl,shiftr,shiftr,pow - | EQLI - | LEQI - | LEQN -- ==,<=,<= - | ANDN - | IORN - | XORN -- and,or,xor - -- floating - | EQLF - | LEQF -- ==,<= - | ADDF - | SUBF + | POWI -- pow + | POWN + | EQLI -- == + | EQLN + | LEQI -- <= + | LEQN + | ANDN -- and + | ANDI + | IORN -- or + | IORI + | XORN -- xor + | XORI + | -- floating + EQLF -- == + | LEQF -- <= + | ADDF -- + + | SUBF -- - | MULF - | DIVF - | ATN2 -- +,-,*,/,atan2 - | POWF - | LOGB - | MAXF - | MINF -- pow,low,max,min + | DIVF -- / + | ATN2 -- atan2 + | POWF -- pow + | LOGB -- logBase + | MAXF -- max + | MINF -- min + | CAST -- unboxed runtime type cast (int to nat, etc.) deriving (Show, Eq, Ord, Enum, Bounded) data BPrim1 = -- text - SIZT - | USNC - | UCNS -- size,unsnoc,uncons - | ITOT - | NTOT - | FTOT -- intToText,natToText,floatToText - | TTOI - | TTON - | TTOF -- textToInt,textToNat,textToFloat - | PAKT - | UPKT -- pack,unpack + SIZT -- size + | USNC -- unsnoc + | UCNS -- uncons + | ITOT -- intToText + | NTOT -- natToText + | FTOT -- floatToText + | TTOI -- textToInt + | TTON -- textToNat + | TTOF -- textToFloat + | PAKT -- pack + | UPKT -- unpack -- sequence - | VWLS - | VWRS - | SIZS -- viewl,viewr,size - | PAKB - | UPKB - | SIZB -- pack,unpack,size + | VWLS -- viewl + | VWRS -- viewr + | SIZS -- size + | PAKB -- pack + | UPKB -- unpack + | SIZB -- size | FLTB -- flatten -- code - | MISS - | CACH - | LKUP - | LOAD -- isMissing,cache_,lookup,load + | MISS -- isMissing + | CACH -- cache + | LKUP -- lookup + | LOAD -- load | CVLD -- validate - | VALU - | TLTT -- value, Term.Link.toText + | VALU -- value + | TLTT -- Term.Link.toText -- debug | DBTX -- debug text | SDBL -- sandbox link list @@ -391,30 +404,30 @@ data BPrim1 data BPrim2 = -- universal - EQLU - | CMPU -- ==,compare + EQLU -- == + | CMPU -- compare -- text - | DRPT - | CATT - | TAKT -- drop,append,take + | DRPT -- drop + | CATT -- append + | TAKT -- take | IXOT -- indexof - | EQLT - | LEQT - | LEST -- ==,<=,< + | EQLT -- == + | LEQT -- <= + | LEST -- < -- sequence - | DRPS - | CATS - | TAKS -- drop,append,take - | CONS - | SNOC - | IDXS -- cons,snoc,index - | SPLL - | SPLR -- splitLeft,splitRight + | DRPS -- drop + | CATS -- append + | TAKS -- take + | CONS -- cons + | SNOC -- snoc + | IDXS -- index + | SPLL -- splitLeft + | SPLR -- splitRight -- bytes - | TAKB - | DRPB - | IDXB - | CATB -- take,drop,index,append + | TAKB -- take + | DRPB -- drop + | IDXB -- index + | CATB -- append | IXOB -- indexof -- general | THRO -- throw @@ -426,15 +439,17 @@ data BPrim2 data MLit = MI !Int + | MN !Word64 + | MC !Char | MD !Double | MT !Text - | MM !Referent - | MY !Reference + | MM !Referent -- Term Link + | MY !Reference -- Type Link deriving (Show, Eq, Ord) type Instr = GInstr CombIx -type RInstr clos = GInstr (RComb clos) +type RInstr val = GInstr (RComb val) -- Instructions for manipulating the data stack in the main portion of -- a block @@ -481,12 +496,10 @@ data GInstr comb -- on the stack. Pack !Reference -- data type reference - !Word64 -- tag + !PackedTag -- tag !Args -- arguments to pack | -- Push a particular value onto the appropriate stack Lit !MLit -- value to push onto the stack - | -- Push a particular value directly onto the boxed stack - BLit !Reference !Word64 {- packed type tag for the ref -} !MLit | -- Print a value on the unboxed stack Print !Int -- index of the primitive value to print | -- Put a delimiter on the continuation @@ -503,7 +516,7 @@ data GInstr comb type Section = GSection CombIx -type RSection clos = GSection (RComb clos) +type RSection val = GSection (RComb val) data GSection comb = -- Apply a function to arguments. This is the 'slow path', and @@ -609,18 +622,18 @@ data GCombInfo comb !(GSection comb) -- Entry deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) -data GComb clos comb +data GComb val comb = Comb {-# UNPACK #-} !(GCombInfo comb) | -- A pre-evaluated comb, typically a pure top-level const - CachedClosure !Word64 {- top level comb ix -} !clos + CachedVal !Word64 {- top level comb ix -} !val deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) pattern Lam :: - Int -> Int -> GSection comb -> GComb clos comb + Int -> Int -> GSection comb -> GComb val comb pattern Lam a f sect = Comb (LamI a f sect) -- it seems GHC can't figure this out itself -{-# COMPLETE CachedClosure, Lam #-} +{-# COMPLETE CachedVal, Lam #-} instance Bifunctor GComb where bimap = bimapDefault @@ -629,36 +642,48 @@ instance Bifoldable GComb where bifoldMap = bifoldMapDefault instance Bitraversable GComb where - bitraverse f _ (CachedClosure cix c) = CachedClosure cix <$> f c + bitraverse f _ (CachedVal cix c) = CachedVal cix <$> f c bitraverse _ f (Lam a fr s) = Lam a fr <$> traverse f s -type RCombs clos = GCombs clos (RComb clos) +type RCombs val = GCombs val (RComb val) -- | The fixed point of a GComb where all references to a Comb are themselves Combs. -newtype RComb clos = RComb {unRComb :: GComb clos (RComb clos)} +newtype RComb val = RComb {unRComb :: GComb val (RComb val)} -type RCombInfo clos = GCombInfo (RComb clos) +type RCombInfo val = GCombInfo (RComb val) -instance Show (RComb clos) where +instance Show (RComb val) where show _ = "" -- | Map of combinators, parameterized by comb reference type -type GCombs clos comb = EnumMap Word64 (GComb clos comb) +type GCombs val comb = EnumMap Word64 (GComb val comb) -- | A reference to a combinator, parameterized by comb type Ref = GRef CombIx -type RRef clos = GRef (RComb clos) +type RRef val = GRef (RComb val) data GRef comb = Stk !Int -- stack reference to a closure | Env !CombIx {- Lazy! Might be cyclic -} comb | Dyn !Word64 -- dynamic scope reference to a closure - deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + deriving (Show, Functor, Foldable, Traversable) + +instance Eq (GRef comb) where + a == b = compare a b == EQ + +instance Ord (GRef comb) where + compare (Stk a) (Stk b) = compare a b + compare (Stk {}) _ = LT + compare _ (Stk {}) = GT + compare (Env a _) (Env b _) = compare a b + compare (Env {}) _ = LT + compare _ (Env {}) = GT + compare (Dyn a) (Dyn b) = compare a b type Branch = GBranch CombIx -type RBranch clos = GBranch (RComb clos) +type RBranch val = GBranch (RComb val) data GBranch comb = -- if tag == n then t else f @@ -783,10 +808,10 @@ emitCombs rns grpr grpn (Rec grp ent) = -- tying the knot recursively when necessary. resolveCombs :: -- Existing in-scope combs that might be referenced - Maybe (EnumMap Word64 (RCombs clos)) -> + Maybe (EnumMap Word64 (RCombs val)) -> -- Combinators which need their knots tied. - EnumMap Word64 (GCombs clos CombIx) -> - EnumMap Word64 (RCombs clos) + EnumMap Word64 (GCombs val CombIx) -> + EnumMap Word64 (RCombs val) resolveCombs mayExisting combs = -- Fixed point lookup; -- We make sure not to force resolved Combs or we'll loop forever. @@ -955,7 +980,7 @@ emitSection _ _ _ _ ctx (TLit l) = | ANF.LY {} <- l = addCount 1 | otherwise = addCount 1 emitSection _ _ _ _ ctx (TBLit l) = - addCount 1 . countCtx ctx . Ins (emitBLit l) . Yield $ VArg1 0 + addCount 1 . countCtx ctx . Ins (emitLit l) . Yield $ VArg1 0 emitSection rns grpr grpn rec ctx (TMatch v bs) | Just (i, BX) <- ctxResolve ctx v, MatchData r cs df <- bs = @@ -1135,7 +1160,7 @@ emitLet :: emitLet _ _ _ _ _ _ _ (TLit l) = fmap (Ins $ emitLit l) emitLet _ _ _ _ _ _ _ (TBLit l) = - fmap (Ins $ emitBLit l) + fmap (Ins $ emitLit l) -- emitLet rns grp _ _ _ ctx (TApp (FComb r) args) -- -- We should be able to tell if we are making a saturated call -- -- or not here. We aren't carrying the information here yet, though. @@ -1168,38 +1193,42 @@ emitLet rns grpr grpn rec d vcs ctx bnd emitPOp :: ANF.POp -> Args -> Instr -- Integral emitPOp ANF.ADDI = emitP2 ADDI -emitPOp ANF.ADDN = emitP2 ADDI +emitPOp ANF.ADDN = emitP2 ADDN emitPOp ANF.SUBI = emitP2 SUBI -emitPOp ANF.SUBN = emitP2 SUBI +emitPOp ANF.SUBN = emitP2 SUBN emitPOp ANF.MULI = emitP2 MULI -emitPOp ANF.MULN = emitP2 MULI +emitPOp ANF.MULN = emitP2 MULN emitPOp ANF.DIVI = emitP2 DIVI emitPOp ANF.DIVN = emitP2 DIVN emitPOp ANF.MODI = emitP2 MODI -- TODO: think about how these behave emitPOp ANF.MODN = emitP2 MODN -- TODO: think about how these behave emitPOp ANF.POWI = emitP2 POWI -emitPOp ANF.POWN = emitP2 POWI +emitPOp ANF.POWN = emitP2 POWN emitPOp ANF.SHLI = emitP2 SHLI -emitPOp ANF.SHLN = emitP2 SHLI -- Note: left shift behaves uniformly +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.LEQN = emitP2 LEQN emitPOp ANF.EQLI = emitP2 EQLI -emitPOp ANF.EQLN = emitP2 EQLI +emitPOp ANF.EQLN = emitP2 EQLN emitPOp ANF.SGNI = emitP1 SGNI emitPOp ANF.NEGI = emitP1 NEGI emitPOp ANF.INCI = emitP1 INCI -emitPOp ANF.INCN = emitP1 INCI +emitPOp ANF.INCN = emitP1 INCN emitPOp ANF.DECI = emitP1 DECI -emitPOp ANF.DECN = emitP1 DECI +emitPOp ANF.DECN = emitP1 DECN emitPOp ANF.TZRO = emitP1 TZRO emitPOp ANF.LZRO = emitP1 LZRO emitPOp ANF.POPC = emitP1 POPC emitPOp ANF.ANDN = emitP2 ANDN +emitPOp ANF.ANDI = emitP2 ANDI emitPOp ANF.IORN = emitP2 IORN +emitPOp ANF.IORI = emitP2 IORI +emitPOp ANF.XORI = emitP2 XORI emitPOp ANF.XORN = emitP2 XORN emitPOp ANF.COMN = emitP1 COMN +emitPOp ANF.COMI = emitP1 COMI -- Float emitPOp ANF.ADDF = emitP2 ADDF emitPOp ANF.SUBF = emitP2 SUBF @@ -1241,6 +1270,7 @@ emitPOp ANF.FTOT = emitBP1 FTOT emitPOp ANF.TTON = emitBP1 TTON emitPOp ANF.TTOI = emitBP1 TTOI emitPOp ANF.TTOF = emitBP1 TTOF +emitPOp ANF.CAST = emitP2 CAST -- text emitPOp ANF.CATT = emitBP2 CATT emitPOp ANF.TAKT = emitBP2 TAKT @@ -1456,34 +1486,18 @@ emitSumCase rns grpr grpn rec ctx v (ccs, TAbss vs bo) = emitSection rns grpr grpn rec (sumCtx ctx v $ zip vs ccs) bo litToMLit :: ANF.Lit -> MLit -litToMLit (ANF.I i) = MI $ fromIntegral i -litToMLit (ANF.N n) = MI $ fromIntegral n -litToMLit (ANF.C c) = MI $ fromEnum c +litToMLit (ANF.I i) = MI (fromIntegral i) +litToMLit (ANF.N n) = MN n +litToMLit (ANF.C c) = MC c litToMLit (ANF.F d) = MD d litToMLit (ANF.T t) = MT t litToMLit (ANF.LM r) = MM r litToMLit (ANF.LY r) = MY r +-- | Emit a literal as a machine literal of the correct boxed/unboxed format. emitLit :: ANF.Lit -> Instr emitLit = Lit . litToMLit -doubleToInt :: Double -> Int -doubleToInt d = indexByteArray (byteArrayFromList [d]) 0 - -emitBLit :: ANF.Lit -> Instr -emitBLit l = case l of - (ANF.F d) -> BLit lRef builtinTypeTag (MI $ doubleToInt d) - _ -> BLit lRef builtinTypeTag (litToMLit l) - where - lRef = ANF.litRef l - builtinTypeTag :: Word64 - builtinTypeTag = - case M.lookup (ANF.litRef l) builtinTypeNumbering of - Nothing -> error "emitBLit: unknown builtin type reference" - Just n -> - let rt = toEnum (fromIntegral n) - in (packTags rt 0) - -- Emits some fix-up code for calling functions. Some of the -- variables in scope come from the top-level let rec, but these -- are definitions, not values on the stack. These definitions cannot @@ -1510,7 +1524,7 @@ emitClosures grpr grpn rec ctx args k = let cix = (CIx grpr grpn n) in Ins (Name (Env cix cix) ZArgs) <$> allocate (Var a BX ctx) as k | otherwise = - internalBug $ "emitClosures: unknown reference: " ++ show a + internalBug $ "emitClosures: unknown reference: " ++ show a ++ show grpr emitArgs :: (Var v) => Word64 -> Ctx v -> [v] -> Args emitArgs grpn ctx args @@ -1532,13 +1546,13 @@ demuxArgs = \case [(i, _), (j, _)] -> VArg2 i j args -> VArgN $ PA.primArrayFromList (fst <$> args) -combDeps :: GComb clos comb -> [Word64] +combDeps :: GComb val comb -> [Word64] combDeps (Lam _ _ s) = sectionDeps s -combDeps (CachedClosure {}) = [] +combDeps (CachedVal {}) = [] combTypes :: GComb any comb -> [Word64] combTypes (Lam _ _ s) = sectionTypes s -combTypes (CachedClosure {}) = [] +combTypes (CachedVal {}) = [] sectionDeps :: GSection comb -> [Word64] sectionDeps (App _ (Env (CIx _ w _) _) _) = [w] @@ -1566,7 +1580,7 @@ sectionTypes (RMatch _ pu br) = sectionTypes _ = [] instrTypes :: GInstr comb -> [Word64] -instrTypes (Pack _ w _) = [w `shiftR` 16] +instrTypes (Pack _ (PackedTag w) _) = [w `shiftR` 16] instrTypes (Reset ws) = setToList ws instrTypes (Capture w) = [w] instrTypes (SetDyn w _) = [w] @@ -1603,7 +1617,7 @@ prettyCombs w es = id (mapToList es) -prettyComb :: (Show clos, Show comb) => Word64 -> Word64 -> GComb clos comb -> ShowS +prettyComb :: (Show val, Show comb) => Word64 -> Word64 -> GComb val comb -> ShowS prettyComb w i = \case (Lam a _ s) -> shows w @@ -1613,7 +1627,7 @@ prettyComb w i = \case . shows a . showString "\n" . prettySection 2 s - (CachedClosure a b) -> + (CachedVal a b) -> shows w . showString ":" . shows i @@ -1718,13 +1732,8 @@ prettyIns (Pack r i as) = . shows i . (' ' :) . prettyArgs as -prettyIns (BLit r t l) = - showString "BLit " - . prettyRef r - . (' ' :) - . shows t - . (' ' :) - . showsPrec 11 l +prettyIns (Lit l) = + showString "Lit " . showsPrec 11 l prettyIns (Name r as) = showString "Name " . prettyGRef 12 r diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs index 91e54afe3e..92f0c6074a 100644 --- a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -18,9 +18,11 @@ import Data.Void (Void) import Data.Word (Word64) import GHC.Exts (IsList (..)) import Unison.Runtime.Array (PrimArray) +import Unison.Runtime.ANF (PackedTag (..)) import Unison.Runtime.MCode hiding (MatchT) import Unison.Runtime.Serialize import Unison.Util.Text qualified as Util.Text +import Prelude hiding (getChar, putChar) data CombT = LamT | CachedClosureT @@ -32,12 +34,18 @@ instance Tag CombT where word2tag 1 = pure CachedClosureT word2tag n = unknownTag "CombT" n +putPackedTag :: (MonadPut m) => PackedTag -> m () +putPackedTag (PackedTag w) = pWord w + +getPackedTag :: (MonadGet m) => m PackedTag +getPackedTag = PackedTag <$> gWord + putComb :: (MonadPut m) => (clos -> m ()) -> GComb clos comb -> m () putComb pClos = \case (Lam a f body) -> putTag LamT *> pInt a *> pInt f *> putSection body - (CachedClosure w c) -> - putTag CachedClosureT *> putNat w *> pClos c + (CachedVal w v) -> + putTag CachedClosureT *> putNat w *> pClos v getComb :: (MonadGet m) => m (GComb Void CombIx) getComb = @@ -152,7 +160,6 @@ data InstrT | AtomicallyT | SeqT | TryForceT - | BLitT instance Tag InstrT where tag2word UPrim1T = 0 @@ -172,7 +179,6 @@ instance Tag InstrT where tag2word AtomicallyT = 14 tag2word SeqT = 15 tag2word TryForceT = 16 - tag2word BLitT = 17 word2tag 0 = pure UPrim1T word2tag 1 = pure UPrim2T @@ -191,7 +197,6 @@ instance Tag InstrT where word2tag 14 = pure AtomicallyT word2tag 15 = pure SeqT word2tag 16 = pure TryForceT - word2tag 17 = pure BLitT word2tag n = unknownTag "InstrT" n putInstr :: (MonadPut m) => GInstr cix -> m () @@ -205,9 +210,8 @@ putInstr = \case (Capture w) -> putTag CaptureT *> pWord w (Name r a) -> putTag NameT *> putRef r *> putArgs a (Info s) -> putTag InfoT *> serialize s - (Pack r w a) -> putTag PackT *> putReference r *> pWord w *> putArgs a + (Pack r w a) -> putTag PackT *> putReference r *> putPackedTag w *> putArgs a (Lit l) -> putTag LitT *> putLit l - (BLit r tt l) -> putTag BLitT *> putReference r *> putNat tt *> putLit l (Print i) -> putTag PrintT *> pInt i (Reset s) -> putTag ResetT *> putEnumSet pWord s (Fork i) -> putTag ForkT *> pInt i @@ -227,9 +231,8 @@ getInstr = CaptureT -> Capture <$> gWord NameT -> Name <$> getRef <*> getArgs InfoT -> Info <$> deserialize - PackT -> Pack <$> getReference <*> gWord <*> getArgs + PackT -> Pack <$> getReference <*> getPackedTag <*> getArgs LitT -> Lit <$> getLit - BLitT -> BLit <$> getReference <*> getNat <*> getLit PrintT -> Print <$> gInt ResetT -> Reset <$> getEnumSet gWord ForkT -> Fork <$> gInt @@ -311,24 +314,30 @@ putCombIx (CIx r n i) = putReference r *> pWord n *> pWord i getCombIx :: (MonadGet m) => m CombIx getCombIx = CIx <$> getReference <*> gWord <*> gWord -data MLitT = MIT | MDT | MTT | MMT | MYT +data MLitT = MIT | MNT | MCT | MDT | MTT | MMT | MYT instance Tag MLitT where tag2word MIT = 0 - tag2word MDT = 1 - tag2word MTT = 2 - tag2word MMT = 3 - tag2word MYT = 4 + tag2word MNT = 1 + tag2word MCT = 2 + tag2word MDT = 3 + tag2word MTT = 4 + tag2word MMT = 5 + tag2word MYT = 6 word2tag 0 = pure MIT - word2tag 1 = pure MDT - word2tag 2 = pure MTT - word2tag 3 = pure MMT - word2tag 4 = pure MYT + word2tag 1 = pure MNT + word2tag 2 = pure MCT + word2tag 3 = pure MDT + word2tag 4 = pure MTT + word2tag 5 = pure MMT + word2tag 6 = pure MYT word2tag n = unknownTag "MLitT" n putLit :: (MonadPut m) => MLit -> m () putLit (MI i) = putTag MIT *> pInt i +putLit (MN n) = putTag MNT *> pWord n +putLit (MC c) = putTag MCT *> putChar c putLit (MD d) = putTag MDT *> putFloat d putLit (MT t) = putTag MTT *> putText (Util.Text.toText t) putLit (MM r) = putTag MMT *> putReferent r @@ -338,6 +347,8 @@ getLit :: (MonadGet m) => m MLit getLit = getTag >>= \case MIT -> MI <$> gInt + MNT -> MN <$> gWord + MCT -> MC <$> getChar MDT -> MD <$> getFloat MTT -> MT . Util.Text.fromText <$> getText MMT -> MM <$> getReferent diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 58c6630d96..795d7a9d29 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -1,9 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} module Unison.Runtime.Machine where @@ -11,11 +8,10 @@ import Control.Concurrent (ThreadId) import Control.Concurrent.STM as STM import Control.Exception import Control.Lens -import Data.Bitraversable (Bitraversable (..)) import Data.Bits +import Data.Functor.Classes (Eq1 (..), Ord1 (..)) import Data.Map.Strict qualified as M import Data.Ord (comparing) -import Data.Primitive.ByteArray qualified as BA import Data.Sequence qualified as Sq import Data.Set qualified as S import Data.Set qualified as Set @@ -38,6 +34,7 @@ import Unison.Runtime.ANF as ANF ( Cacheability (..), Code (..), CompileExn (..), + PackedTag (..), SuperGroup, codeGroup, foldGroup, @@ -54,17 +51,26 @@ import Unison.Runtime.Foreign import Unison.Runtime.Foreign.Function import Unison.Runtime.MCode import Unison.Runtime.Stack +import Unison.Runtime.TypeTags qualified as TT import Unison.ShortHash qualified as SH import Unison.Symbol (Symbol) import Unison.Type qualified as Rf import Unison.Util.Bytes qualified as By import Unison.Util.EnumContainers as EC +import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty (toPlainUnbroken) import Unison.Util.Text qualified as Util.Text import UnliftIO (IORef) import UnliftIO qualified import UnliftIO.Concurrent qualified as UnliftIO +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +import Unison.Debug qualified as Debug +import System.IO.Unsafe (unsafePerformIO) +#endif +{- ORMOLU_ENABLE -} + -- | A ref storing every currently active thread. -- This is helpful for cleaning up orphaned threads when the main process -- completes. @@ -77,21 +83,21 @@ type ActiveThreads = Maybe (IORef (Set ThreadId)) type Tag = Word64 -- dynamic environment -type DEnv = EnumMap Word64 Closure +type DEnv = EnumMap Word64 Val -type MCombs = RCombs Closure +type MCombs = RCombs Val type Combs = GCombs Void CombIx -type MSection = RSection Closure +type MSection = RSection Val -type MBranch = RBranch Closure +type MBranch = RBranch Val -type MInstr = RInstr Closure +type MInstr = RInstr Val -type MComb = RComb Closure +type MComb = RComb Val -type MRef = RRef Closure +type MRef = RRef Val data Tracer = NoTrace @@ -102,7 +108,7 @@ data Tracer data CCache = CCache { foreignFuncs :: EnumMap Word64 ForeignFunc, sandboxed :: Bool, - tracer :: Bool -> Closure -> Tracer, + tracer :: Bool -> Val -> Tracer, -- Combinators in their original form, where they're easier to serialize into SCache srcCombs :: TVar (EnumMap Word64 Combs), combs :: TVar (EnumMap Word64 MCombs), @@ -195,10 +201,10 @@ eval0 !env !activeThreads !co = do topDEnv cmbs <$> readTVarIO (refTy env) <*> readTVarIO (refTm env) eval env denv activeThreads stk (k KE) dummyRef co -mCombClosure :: CombIx -> MComb -> Closure -mCombClosure cix (RComb (Comb comb)) = - PAp cix comb nullSeg -mCombClosure _ (RComb (CachedClosure _ clo)) = clo +mCombVal :: CombIx -> MComb -> Val +mCombVal cix (RComb (Comb comb)) = + BoxedVal (PAp cix comb nullSeg) +mCombVal _ (RComb (CachedVal _ clo)) = clo topDEnv :: EnumMap Word64 MCombs -> @@ -210,7 +216,7 @@ topDEnv combs rfTy rfTm rcrf <- Builtin (DTx.pack "raise"), Just j <- M.lookup rcrf rfTm, cix <- CIx rcrf j 0, - clo <- mCombClosure cix $ rCombSection combs cix = + clo <- mCombVal cix $ rCombSection combs cix = ( EC.mapSingleton n clo, Mark 0 (EC.setSingleton n) mempty ) @@ -239,10 +245,10 @@ apply0 !callback !env !threadTracker !i = do let entryCix = (CIx r i 0) case unRComb $ rCombSection cmbs entryCix of Comb entryComb -> do - apply env denv threadTracker stk (kf k0) True ZArgs $ + apply env denv threadTracker stk (kf k0) True ZArgs . BoxedVal $ PAp entryCix entryComb nullSeg -- if it's cached, we can just finish - CachedClosure _ clo -> bump stk >>= \stk -> bpoke stk clo + CachedVal _ val -> bump stk >>= \stk -> poke stk val where k0 = maybe KE (CB . Hook) callback @@ -252,11 +258,11 @@ apply1 :: (Stack -> IO ()) -> CCache -> ActiveThreads -> - Closure -> + Val -> IO () apply1 callback env threadTracker clo = do stk <- alloc - apply env mempty threadTracker stk k0 True ZArgs clo + apply env mempty threadTracker stk k0 True ZArgs $ clo where k0 = CB $ Hook callback @@ -276,23 +282,48 @@ jump0 !callback !env !activeThreads !clo = do (denv, kf) <- topDEnv cmbs <$> readTVarIO (refTy env) <*> readTVarIO (refTm env) stk <- bump stk - bpoke stk (Enum Rf.unitRef unitTag) + bpoke stk (Enum Rf.unitRef TT.unitTag) jump env denv activeThreads stk (kf k0) (VArg1 0) clo where k0 = CB (Hook callback) unitValue :: Closure -unitValue = Enum Rf.unitRef unitTag - -lookupDenv :: Word64 -> DEnv -> Closure -lookupDenv p denv = fromMaybe BlackHole $ EC.lookup p denv - -buildLit :: Reference -> Word64 -> MLit -> Closure -buildLit rf tt (MI i) = DataU1 rf tt i -buildLit _ _ (MT t) = Foreign (Wrap Rf.textRef t) -buildLit _ _ (MM r) = Foreign (Wrap Rf.termLinkRef r) -buildLit _ _ (MY r) = Foreign (Wrap Rf.typeLinkRef r) -buildLit _ _ (MD _) = error "buildLit: double" +unitValue = Enum Rf.unitRef TT.unitTag + +lookupDenv :: Word64 -> DEnv -> Val +lookupDenv p denv = fromMaybe (BoxedVal BlackHole) $ EC.lookup p denv + +litToVal :: MLit -> Val +litToVal = \case + MT t -> BoxedVal $ Foreign (Wrap Rf.textRef t) + MM r -> BoxedVal $ Foreign (Wrap Rf.termLinkRef r) + MY r -> BoxedVal $ Foreign (Wrap Rf.typeLinkRef r) + MI i -> IntVal i + MN n -> NatVal n + MC c -> CharVal c + MD d -> DoubleVal d +{-# INLINE litToVal #-} + +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +debugger :: (Show a) => Stack -> String -> a -> Bool +debugger stk msg a = unsafePerformIO $ do + dumpStack stk + Debug.debugLogM Debug.Interpreter (msg ++ ": " ++ show a) + pure False + +dumpStack :: Stack -> IO () +dumpStack stk@(Stack ap fp sp _ustk _bstk) + | sp - fp < 0 = Debug.debugLogM Debug.Interpreter "Stack before 👇: Empty" + | otherwise = do + stkLocals <- for [0 .. ((sp - fp) - 1)] $ \i -> do + peekOff stk i + Debug.debugM Debug.Interpreter "Stack frame locals 👇:" stkLocals + stkArgs <- for [0 .. ((fp - ap) - 1)] $ \i -> do + peekOff stk (i + (sp - fp)) + Debug.debugM Debug.Interpreter "Stack args 👇:" stkArgs +#endif +{- ORMOLU_ENABLE -} -- | Execute an instruction exec :: @@ -304,20 +335,27 @@ exec :: Reference -> MInstr -> IO (DEnv, Stack, K) +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +exec !_ !_ !_ !stk !_ !_ instr + | debugger stk "exec" instr = undefined +#endif +{- ORMOLU_ENABLE -} exec !_ !denv !_activeThreads !stk !k _ (Info tx) = do info tx stk info tx k pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (Name r args) = do - stk <- name stk args =<< resolve env denv stk r + v <- resolve env denv stk r + stk <- name stk args v pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (SetDyn p i) = do - clo <- bpeekOff stk i - pure (EC.mapInsert p clo denv, stk, k) + val <- peekOff stk i + pure (EC.mapInsert p val denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (Capture p) = do (cap, denv, stk, k) <- splitCont denv stk k p stk <- bump stk - bpoke stk cap + poke stk cap pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (UPrim1 op i) = do stk <- uprim1 stk op i @@ -334,7 +372,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 MISS i) _ -> error "exec:BPrim1:MISS: Expected Ref" m <- readTVarIO (intermed env) stk <- bump stk - if (link `M.member` m) then upoke stk 1 else upoke stk 0 + pokeTag stk $ if (link `M.member` m) then 1 else 0 pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) | sandboxed env = die "attempted to use sandboxed operation: cache" @@ -345,7 +383,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) stk <- bump stk pokeS stk - (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) + (Sq.fromList $ boxedVal . Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) | sandboxed env = die "attempted to use sandboxed operation: validate" @@ -355,7 +393,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) codeValidate (second codeGroup <$> news) env >>= \case Nothing -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure (denv, stk, k) Just (Failure ref msg clo) -> do stk <- bumpn stk 3 @@ -363,7 +401,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) pokeOffBi stk 1 msg bpokeOff stk 2 clo stk <- bump stk - upoke stk 1 + pokeTag stk 1 pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) | sandboxed env = die "attempted to use sandboxed operation: lookup" @@ -382,8 +420,8 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) Just sn <- EC.lookup w numberedTermLookup -> do pokeBi stk (CodeRep (ANF.Rec [] sn) Uncacheable) stk <- bump stk - stk <$ upoke stk 1 - | otherwise -> stk <$ upoke stk 0 + stk <$ pokeTag stk 1 + | otherwise -> stk <$ pokeTag stk 0 Just sg -> do let ch | Just n <- M.lookup link rfn, @@ -392,7 +430,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) | otherwise = Uncacheable pokeBi stk (CodeRep sg ch) stk <- bump stk - stk <$ upoke stk 1 + stk <$ pokeTag stk 1 pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (BPrim1 TLTT i) = do clink <- bpeekOff stk i @@ -412,15 +450,15 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 LOAD i) Left miss -> do pokeOffS stk 1 $ Sq.fromList $ - Foreign . Wrap Rf.termLinkRef . Ref <$> miss - upoke stk 0 + boxedVal . Foreign . Wrap Rf.termLinkRef . Ref <$> miss + pokeTag stk 0 Right x -> do - bpokeOff stk 1 x - upoke stk 1 + pokeOff stk 1 x + pokeTag stk 1 pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim1 VALU i) = do m <- readTVarIO (tagRefs env) - c <- bpeekOff stk i + c <- peekOff stk i stk <- bump stk pokeBi stk =<< reflectValue m c pure (denv, stk, k) @@ -428,18 +466,18 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 DBTX i) | sandboxed env = die "attempted to use sandboxed operation: Debug.toText" | otherwise = do - clo <- bpeekOff stk i + val <- peekOff stk i stk <- bump stk - stk <- case tracer env False clo of - NoTrace -> stk <$ upoke stk 0 + stk <- case tracer env False val of + NoTrace -> stk <$ pokeTag stk 0 MsgTrace _ _ tx -> do pokeBi stk (Util.Text.pack tx) stk <- bump stk - stk <$ upoke stk 1 + stk <$ pokeTag stk 1 SimpleTrace tx -> do pokeBi stk (Util.Text.pack tx) stk <- bump stk - stk <$ upoke stk 2 + stk <$ pokeTag stk 2 pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) | sandboxed env = @@ -458,7 +496,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do l <- decodeSandboxArgument s b <- checkSandboxing env l c stk <- bump stk - upoke stk $ if b then 1 else 0 + pokeBool stk $ b pure (denv, stk, k) exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBV i j) | sandboxed env = @@ -472,26 +510,26 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBV i j) bpoke stk $ encodeSandboxResult res pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (BPrim2 EQLU i j) = do - x <- bpeekOff stk i - y <- bpeekOff stk j + x <- peekOff stk i + y <- peekOff stk j stk <- bump stk - upoke stk $ if universalEq (==) x y then 1 else 0 + pokeBool stk $ universalEq (==) x y pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (BPrim2 CMPU i j) = do - x <- bpeekOff stk i - y <- bpeekOff stk j + x <- peekOff stk i + y <- peekOff stk j stk <- bump stk - upoke stk . fromEnum $ universalCompare compare x y + pokeI stk . 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 - x <- bpeekOff stk j + x <- peekOff stk j throwIO (BU (traceK r k) (Util.Text.toText name) x) exec !env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) | sandboxed env = die "attempted to use sandboxed operation: trace" | otherwise = do tx <- peekOffBi stk i - clo <- bpeekOff stk j + clo <- peekOff stk j case tracer env True clo of NoTrace -> pure () SimpleTrace str -> do @@ -518,29 +556,9 @@ exec !_ !denv !_activeThreads !stk !k _ (Print i) = do t <- peekOffBi stk i Tx.putStrLn (Util.Text.toText t) pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Lit (MI n)) = do - stk <- bump stk - upoke stk n - pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Lit (MD d)) = do - stk <- bump stk - pokeD stk d - pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Lit (MT t)) = do - stk <- bump stk - bpoke stk (Foreign (Wrap Rf.textRef t)) - pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Lit (MM r)) = do +exec !_ !denv !_activeThreads !stk !k _ (Lit ml) = do stk <- bump stk - bpoke stk (Foreign (Wrap Rf.termLinkRef r)) - pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Lit (MY r)) = do - stk <- bump stk - bpoke stk (Foreign (Wrap Rf.typeLinkRef r)) - pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BLit rf tt l) = do - stk <- bump stk - bpoke stk $ buildLit rf tt l + poke stk $ litToVal ml pure (denv, stk, k) exec !_ !denv !_activeThreads !stk !k _ (Reset ps) = do (stk, a) <- saveArgs stk @@ -561,23 +579,23 @@ exec !env !denv !_activeThreads !stk !k _ (ForeignCall _ w args) exec !env !denv !activeThreads !stk !k _ (Fork i) | sandboxed env = die "attempted to use sandboxed operation: fork" | otherwise = do - tid <- forkEval env activeThreads =<< bpeekOff stk i + tid <- forkEval env activeThreads =<< peekOff stk i stk <- bump stk bpoke stk . Foreign . Wrap Rf.threadIdRef $ tid pure (denv, stk, k) exec !env !denv !activeThreads !stk !k _ (Atomically i) | sandboxed env = die $ "attempted to use sandboxed operation: atomically" | otherwise = do - c <- bpeekOff stk i + v <- peekOff stk i stk <- bump stk - atomicEval env activeThreads (bpoke stk) c + atomicEval env activeThreads (poke stk) v pure (denv, stk, k) exec !env !denv !activeThreads !stk !k _ (TryForce i) | sandboxed env = die $ "attempted to use sandboxed operation: tryForce" | otherwise = do - c <- bpeekOff stk i + v <- peekOff stk i stk <- bump stk -- Bump the boxed stack to make a slot for the result, which will be written in the callback if we succeed. - ev <- Control.Exception.try $ nestEval env activeThreads (bpoke stk) c + ev <- Control.Exception.try $ nestEval env activeThreads (poke stk) v stk <- encodeExn stk ev pure (denv, stk, k) {-# INLINE exec #-} @@ -590,40 +608,40 @@ encodeExn stk exc = do case exc of Right () -> do stk <- bump stk - stk <$ upoke stk 1 + stk <$ pokeTag stk 1 Left exn -> do -- If we hit an exception, we have one unused slot on the stack -- from where the result _would_ have been placed. -- So here we bump one less than it looks like we should, and re-use -- that slot. stk <- bumpn stk 3 - upoke stk 0 + pokeTag stk 0 bpokeOff stk 1 $ Foreign (Wrap Rf.typeLinkRef link) pokeOffBi stk 2 msg - stk <$ bpokeOff stk 3 extra + stk <$ pokeOff stk 3 extra where disp e = Util.Text.pack $ show e (link, msg, extra) | Just (ioe :: IOException) <- fromException exn = - (Rf.ioFailureRef, disp ioe, unitValue) + (Rf.ioFailureRef, disp ioe, boxedVal unitValue) | Just re <- fromException exn = case re of PE _stk msg -> - (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue) - BU _ tx cl -> (Rf.runtimeFailureRef, Util.Text.fromText tx, cl) + (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, boxedVal unitValue) + BU _ tx val -> (Rf.runtimeFailureRef, Util.Text.fromText tx, val) | Just (ae :: ArithException) <- fromException exn = - (Rf.arithmeticFailureRef, disp ae, unitValue) + (Rf.arithmeticFailureRef, disp ae, boxedVal unitValue) | Just (nae :: NestedAtomically) <- fromException exn = - (Rf.stmFailureRef, disp nae, unitValue) + (Rf.stmFailureRef, disp nae, boxedVal unitValue) | Just (be :: BlockedIndefinitelyOnSTM) <- fromException exn = - (Rf.stmFailureRef, disp be, unitValue) + (Rf.stmFailureRef, disp be, boxedVal unitValue) | Just (be :: BlockedIndefinitelyOnMVar) <- fromException exn = - (Rf.ioFailureRef, disp be, unitValue) + (Rf.ioFailureRef, disp be, boxedVal unitValue) | Just (ie :: AsyncException) <- fromException exn = - (Rf.threadKilledFailureRef, disp ie, unitValue) - | otherwise = (Rf.miscFailureRef, disp exn, unitValue) + (Rf.threadKilledFailureRef, disp ie, boxedVal unitValue) + | otherwise = (Rf.miscFailureRef, disp exn, boxedVal unitValue) -numValue :: Maybe Reference -> Closure -> IO Word64 -numValue _ (DataU1 _ _ i) = pure (fromIntegral i) +numValue :: Maybe Reference -> Val -> IO Word64 +numValue _ (UnboxedVal v _) = pure (fromIntegral @Int @Word64 v) numValue mr clo = die $ "numValue: bad closure: " @@ -640,6 +658,12 @@ eval :: Reference -> MSection -> IO () +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +eval !_ !_ !_ !stk !_ !_ section + | debugger stk "eval" section = undefined +#endif +{- ORMOLU_ENABLE -} eval !env !denv !activeThreads !stk !k r (Match i (TestT df cs)) = do t <- peekOffBi stk i eval env denv activeThreads stk k r $ selectTextBranch t df cs @@ -647,15 +671,15 @@ eval !env !denv !activeThreads !stk !k r (Match i br) = do n <- peekOffN stk i eval env denv activeThreads stk k r $ selectBranch n br eval !env !denv !activeThreads !stk !k r (DMatch mr i br) = do - (t, stk) <- dumpDataNoTag mr stk =<< bpeekOff stk i + (t, stk) <- dumpDataNoTag mr stk =<< peekOff stk i eval env denv activeThreads stk k r $ selectBranch (maskTags t) br -eval !env !denv !activeThreads !stk !k r (NMatch mr i br) = do - n <- numValue mr =<< bpeekOff stk i +eval !env !denv !activeThreads !stk !k r (NMatch _mr i br) = do + n <- peekOffN stk i eval env denv activeThreads stk k r $ selectBranch n br eval !env !denv !activeThreads !stk !k r (RMatch i pu br) = do - (t, stk) <- dumpDataNoTag Nothing stk =<< bpeekOff stk i - if t == 0 + (t, stk) <- dumpDataNoTag Nothing stk =<< peekOff stk i + if t == PackedTag 0 then eval env denv activeThreads stk k r pu else case ANF.unpackTags t of (ANF.rawTag -> e, ANF.rawTag -> t) @@ -665,7 +689,7 @@ eval !env !denv !activeThreads !stk !k r (RMatch i pu br) = do eval !env !denv !activeThreads !stk !k _ (Yield args) | asize stk > 0, VArg1 i <- args = - bpeekOff stk i >>= apply env denv activeThreads stk k False ZArgs + peekOff stk i >>= apply env denv activeThreads stk k False ZArgs | otherwise = do stk <- moveArgs stk args stk <- frameArgs stk @@ -694,7 +718,7 @@ eval !_ !_ !_ !_activeThreads !_ _ Exit = pure () eval !_ !_ !_ !_activeThreads !_ _ (Die s) = die s {-# NOINLINE eval #-} -forkEval :: CCache -> ActiveThreads -> Closure -> IO ThreadId +forkEval :: CCache -> ActiveThreads -> Val -> IO ThreadId forkEval env activeThreads clo = do threadId <- @@ -720,15 +744,15 @@ forkEval env activeThreads clo = UnliftIO.atomicModifyIORef' activeThreads (\ids -> (Set.delete myThreadId ids, ())) {-# INLINE forkEval #-} -nestEval :: CCache -> ActiveThreads -> (Closure -> IO ()) -> Closure -> IO () -nestEval env activeThreads write clo = apply1 readBack env activeThreads clo +nestEval :: CCache -> ActiveThreads -> (Val -> IO ()) -> Val -> IO () +nestEval env activeThreads write val = apply1 readBack env activeThreads val where - readBack stk = bpeek stk >>= write + readBack stk = peek stk >>= write {-# INLINE nestEval #-} -atomicEval :: CCache -> ActiveThreads -> (Closure -> IO ()) -> Closure -> IO () -atomicEval env activeThreads write clo = - atomically . unsafeIOToSTM $ nestEval env activeThreads write clo +atomicEval :: CCache -> ActiveThreads -> (Val -> IO ()) -> Val -> IO () +atomicEval env activeThreads write val = + atomically . unsafeIOToSTM $ nestEval env activeThreads write val {-# INLINE atomicEval #-} -- fast path application @@ -750,22 +774,22 @@ enter !env !denv !activeThreads !stk !k !cref !sck !args = \case stk <- moveArgs stk args stk <- acceptArgs stk a eval env denv activeThreads stk k cref entry - (RComb (CachedClosure _cix clos)) -> do + (RComb (CachedVal _ val)) -> do stk <- discardFrame stk stk <- bump stk - bpoke stk clos + poke stk val yield env denv activeThreads stk k {-# INLINE enter #-} -- fast path by-name delaying -name :: Stack -> Args -> Closure -> IO Stack -name !stk !args clo = case clo of - PAp cix comb seg -> do +name :: Stack -> Args -> Val -> IO Stack +name !stk !args = \case + BoxedVal (PAp cix comb seg) -> do seg <- closeArgs I stk seg args stk <- bump stk bpoke stk $ PAp cix comb seg pure stk - _ -> die $ "naming non-function: " ++ show clo + v -> die $ "naming non-function: " ++ show v {-# INLINE name #-} -- slow path application @@ -777,37 +801,44 @@ apply :: K -> Bool -> Args -> - Closure -> + Val -> IO () -apply !env !denv !activeThreads !stk !k !ck !args = \case - (PAp cix@(CIx combRef _ _) comb seg) -> - case comb of - LamI a f entry - | ck || a <= ac -> do - stk <- ensure stk f - stk <- moveArgs stk args - stk <- dumpSeg stk seg A - stk <- acceptArgs stk a - eval env denv activeThreads stk k combRef entry - | otherwise -> do - seg <- closeArgs C stk seg args - stk <- discardFrame =<< frameArgs stk - stk <- bump stk - bpoke stk $ PAp cix comb seg - yield env denv activeThreads stk k - where - ac = asize stk + countArgs args + scount seg - clo -> zeroArgClosure clo +{- ORMOLU_DISABLE -} +#ifdef STACK_CHECK +apply !_env !_denv !_activeThreads !stk !_k !_ck !args !val + | debugger stk "apply" (args, val) = undefined +#endif +{- ORMOLU_ENABLE -} +apply !env !denv !activeThreads !stk !k !ck !args !val = + case val of + BoxedVal (PAp cix@(CIx combRef _ _) comb seg) -> + case comb of + LamI a f entry + | ck || a <= ac -> do + stk <- ensure stk f + stk <- moveArgs stk args + stk <- dumpSeg stk seg A + stk <- acceptArgs stk a + eval env denv activeThreads stk k combRef entry + | otherwise -> do + seg <- closeArgs C stk seg args + stk <- discardFrame =<< frameArgs stk + stk <- bump stk + bpoke stk $ PAp cix comb seg + yield env denv activeThreads stk k + where + ac = asize stk + countArgs args + scount seg + v -> zeroArgClosure v where - zeroArgClosure :: Closure -> IO () - zeroArgClosure clo + zeroArgClosure :: Val -> IO () + zeroArgClosure v | ZArgs <- args, asize stk == 0 = do stk <- discardFrame stk stk <- bump stk - bpoke stk clo + poke stk v yield env denv activeThreads stk k - | otherwise = die $ "applying non-function: " ++ show clo + | otherwise = die $ "applying non-function: " ++ show v {-# INLINE apply #-} jump :: @@ -892,56 +923,34 @@ moveArgs !stk (VArgV i) = do l = fsize stk - i {-# INLINE moveArgs #-} -closureArgs :: Stack -> Args -> IO [Closure] +closureArgs :: Stack -> Args -> IO [Val] closureArgs !_ ZArgs = pure [] closureArgs !stk (VArg1 i) = do - x <- bpeekOff stk i + x <- peekOff stk i pure [x] closureArgs !stk (VArg2 i j) = do - x <- bpeekOff stk i - y <- bpeekOff stk j + x <- peekOff stk i + y <- peekOff stk j pure [x, y] closureArgs !stk (VArgR i l) = - for (take l [i ..]) (bpeekOff stk) + for (take l [i ..]) (peekOff stk) closureArgs !stk (VArgN bs) = - for (PA.primArrayToList bs) (bpeekOff stk) + for (PA.primArrayToList bs) (peekOff stk) closureArgs !_ _ = error "closure arguments can only be boxed." {-# INLINE closureArgs #-} --- | TODO: Experiment: --- In cases where we need to check the boxed stack to see where the argument lives --- we can either fetch from both unboxed and boxed stacks, then check the boxed result; --- OR we can just fetch from the boxed stack and check the result, then conditionally --- fetch from the unboxed stack. --- --- The former puts more work before the branch, which _may_ be better for cpu pipelining, --- but the latter avoids an unnecessary fetch from the unboxed stack in cases where all args are boxed. +-- | Pack some number of args into a data type of the provided ref/tag type. buildData :: - Stack -> Reference -> Tag -> Args -> IO Closure + Stack -> Reference -> PackedTag -> Args -> IO Closure buildData !_ !r !t ZArgs = pure $ Enum r t buildData !stk !r !t (VArg1 i) = do - bv <- bpeekOff stk i - case bv of - BlackHole -> do - uv <- upeekOff stk i - pure $ DataU1 r t uv - _ -> pure $ DataB1 r t bv + v <- peekOff stk i + pure $ Data1 r t v buildData !stk !r !t (VArg2 i j) = do - b1 <- bpeekOff stk i - b2 <- bpeekOff stk j - case (b1, b2) of - (BlackHole, BlackHole) -> do - u1 <- upeekOff stk i - u2 <- upeekOff stk j - pure $ DataU2 r t u1 u2 - (BlackHole, _) -> do - u1 <- upeekOff stk i - pure $ DataUB r t u1 b2 - (_, BlackHole) -> do - u2 <- upeekOff stk j - pure $ DataUB r t u2 b1 - _ -> pure $ DataB2 r t b1 b2 + v1 <- peekOff stk i + v2 <- peekOff stk j + pure $ Data2 r t v1 v2 buildData !stk !r !t (VArgR i l) = do seg <- augSeg I stk nullSeg (Just $ ArgR i l) pure $ DataG r t seg @@ -963,45 +972,41 @@ buildData !stk !r !t (VArgV i) = do dumpDataNoTag :: Maybe Reference -> Stack -> - Closure -> - IO (Word64, Stack) -dumpDataNoTag !_ !stk (Enum _ t) = pure (t, stk) -dumpDataNoTag !_ !stk (DataU1 _ t x) = do - stk <- bump stk - upoke stk x - pure (t, stk) -dumpDataNoTag !_ !stk (DataU2 _ t x y) = do - stk <- bumpn stk 2 - upokeOff stk 1 y - upoke stk x - pure (t, stk) -dumpDataNoTag !_ !stk (DataB1 _ t x) = do - stk <- bump stk - bpoke stk x - pure (t, stk) -dumpDataNoTag !_ !stk (DataB2 _ t x y) = do - stk <- bumpn stk 2 - bpokeOff stk 1 y - bpoke stk x - pure (t, stk) -dumpDataNoTag !_ !stk (DataUB _ t x y) = do - stk <- bumpn stk 2 - upoke stk x - bpokeOff stk 1 y - pure (t, stk) -dumpDataNoTag !_ !stk (DataBU _ t x y) = do - stk <- bumpn stk 2 - bpoke stk x - upokeOff stk 1 y - pure (t, stk) -dumpDataNoTag !_ !stk (DataG _ t seg) = do - stk <- dumpSeg stk seg S - pure (t, stk) -dumpDataNoTag !mr !_ clo = - die $ - "dumpDataNoTag: bad closure: " - ++ show clo - ++ maybe "" (\r -> "\nexpected type: " ++ show r) mr + Val -> + IO (PackedTag, Stack) +dumpDataNoTag !mr !stk = \case + -- Normally we want to avoid dumping unboxed values since it's unnecessary, but sometimes we don't know the type of + -- the incoming value and end up dumping unboxed values, so we just push them back to the stack as-is. e.g. in type-casts/coercions + val@(UnboxedVal _ t) -> do + stk <- bump stk + poke stk val + pure (unboxedPackedTag t, stk) + BoxedVal clos -> case clos of + (Enum _ t) -> pure (t, stk) + (Data1 _ t x) -> do + stk <- bump stk + poke stk x + pure (t, stk) + (Data2 _ t x y) -> do + stk <- bumpn stk 2 + pokeOff stk 1 y + poke stk x + pure (t, stk) + (DataG _ t seg) -> do + stk <- dumpSeg stk seg S + pure (t, stk) + clo -> + die $ + "dumpDataNoTag: bad closure: " + ++ show clo + ++ maybe "" (\r -> "\nexpected type: " ++ show r) mr + where + unboxedPackedTag :: UnboxedTypeTag -> PackedTag + unboxedPackedTag = \case + CharTag -> TT.charTag + FloatTag -> TT.floatTag + IntTag -> TT.intTag + NatTag -> TT.natTag {-# INLINE dumpDataNoTag #-} -- Note: although the representation allows it, it is impossible @@ -1038,24 +1043,34 @@ peekForeign stk i = uprim1 :: Stack -> UPrim1 -> Int -> IO Stack uprim1 !stk DECI !i = do - m <- upeekOff stk i + m <- peekOffI stk i + stk <- bump stk + pokeI stk (m - 1) + pure stk +uprim1 !stk DECN !i = do + m <- peekOffN stk i stk <- bump stk - upoke stk (m - 1) + pokeN stk (m - 1) pure stk uprim1 !stk INCI !i = do - m <- upeekOff stk i + m <- peekOffI stk i + stk <- bump stk + pokeI stk (m + 1) + pure stk +uprim1 !stk INCN !i = do + m <- peekOffN stk i stk <- bump stk - upoke stk (m + 1) + pokeN stk (m + 1) pure stk uprim1 !stk NEGI !i = do m <- upeekOff stk i stk <- bump stk - upoke stk (-m) + pokeI stk (-m) pure stk uprim1 !stk SGNI !i = do m <- upeekOff stk i stk <- bump stk - upoke stk (signum m) + pokeI stk (signum m) pure stk uprim1 !stk ABSF !i = do d <- peekOffD stk i @@ -1065,22 +1080,22 @@ uprim1 !stk ABSF !i = do uprim1 !stk CEIL !i = do d <- peekOffD stk i stk <- bump stk - upoke stk (ceiling d) + pokeI stk (ceiling d) pure stk uprim1 !stk FLOR !i = do d <- peekOffD stk i stk <- bump stk - upoke stk (floor d) + pokeI stk (floor d) pure stk uprim1 !stk TRNF !i = do d <- peekOffD stk i stk <- bump stk - upoke stk (truncate d) + pokeI stk (truncate d) pure stk uprim1 !stk RNDF !i = do d <- peekOffD stk i stk <- bump stk - upoke stk (round d) + pokeI stk (round d) pure stk uprim1 !stk EXPF !i = do d <- peekOffD stk i @@ -1170,67 +1185,96 @@ uprim1 !stk NTOF !i = do uprim1 !stk LZRO !i = do n <- peekOffN stk i stk <- bump stk - upoke stk (countLeadingZeros n) + unsafePokeIasN stk (countLeadingZeros n) pure stk uprim1 !stk TZRO !i = do n <- peekOffN stk i stk <- bump stk - upoke stk (countTrailingZeros n) + unsafePokeIasN stk (countTrailingZeros n) pure stk uprim1 !stk POPC !i = do n <- peekOffN stk i stk <- bump stk - upoke stk (popCount n) + unsafePokeIasN stk (popCount n) pure stk uprim1 !stk COMN !i = do n <- peekOffN stk i stk <- bump stk pokeN stk (complement n) pure stk +uprim1 !stk COMI !i = do + n <- peekOffI stk i + stk <- bump stk + pokeI stk (complement n) + pure stk {-# INLINE uprim1 #-} -uprim2 :: Stack -> UPrim2 -> Int -> Int -> IO Stack +uprim2 :: (HasCallStack) => Stack -> UPrim2 -> Int -> Int -> IO Stack uprim2 !stk ADDI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk (m + n) + pokeI stk (m + n) + pure stk +uprim2 !stk ADDN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeN stk (m + n) pure stk uprim2 !stk SUBI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk (m - n) + pokeI stk (m - n) + pure stk +uprim2 !stk SUBN !i !j = do + m <- peekOffI stk i + n <- peekOffI stk j + stk <- bump stk + pokeI stk (m - n) pure stk uprim2 !stk MULI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk (m * n) + pokeI stk (m * n) + pure stk +uprim2 !stk MULN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeN stk (m * n) pure stk uprim2 !stk DIVI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk (m `div` n) + pokeI stk (m `div` n) pure stk uprim2 !stk MODI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk (m `mod` n) + pokeI stk (m `mod` n) pure stk uprim2 !stk SHLI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk (m `shiftL` n) + pokeI stk (m `shiftL` n) + pure stk +uprim2 !stk SHLN !i !j = do + m <- peekOffN stk i + n <- upeekOff stk j + stk <- bump stk + pokeN stk (m `shiftL` n) pure stk uprim2 !stk SHRI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk (m `shiftR` n) + pokeI stk (m `shiftR` n) pure stk uprim2 !stk SHRN !i !j = do m <- peekOffN stk i @@ -1242,25 +1286,37 @@ uprim2 !stk POWI !i !j = do m <- upeekOff stk i n <- peekOffN stk j stk <- bump stk - upoke stk (m ^ n) + pokeI stk (m ^ n) + pure stk +uprim2 !stk POWN !i !j = do + m <- peekOffN stk i + n <- peekOffN stk j + stk <- bump stk + pokeN stk (m ^ n) pure stk uprim2 !stk EQLI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk $ if m == n then 1 else 0 + 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 LEQI !i !j = do m <- upeekOff stk i n <- upeekOff stk j stk <- bump stk - upoke stk $ if m <= n then 1 else 0 + pokeBool stk $ m <= n pure stk uprim2 !stk LEQN !i !j = do m <- peekOffN stk i n <- peekOffN stk j stk <- bump stk - upoke stk $ if m <= n then 1 else 0 + pokeBool stk $ m <= n pure stk uprim2 !stk DIVN !i !j = do m <- peekOffN stk i @@ -1326,13 +1382,13 @@ uprim2 !stk EQLF !i !j = do x <- peekOffD stk i y <- peekOffD stk j stk <- bump stk - upoke stk (if x == y then 1 else 0) + pokeBool stk $ x == y pure stk uprim2 !stk LEQF !i !j = do x <- peekOffD stk i y <- peekOffD stk j stk <- bump stk - upoke stk (if x <= y then 1 else 0) + pokeBool stk $ x <= y pure stk uprim2 !stk ATN2 !i !j = do x <- peekOffD stk i @@ -1346,18 +1402,42 @@ uprim2 !stk ANDN !i !j = do stk <- bump stk pokeN stk (x .&. y) pure stk +uprim2 !stk ANDI !i !j = do + x <- peekOffI stk i + y <- peekOffI stk j + stk <- bump stk + pokeI stk (x .&. y) + pure stk uprim2 !stk IORN !i !j = do x <- peekOffN stk i y <- peekOffN stk j stk <- bump stk pokeN stk (x .|. y) pure stk +uprim2 !stk IORI !i !j = do + x <- peekOffI stk i + y <- peekOffI stk j + stk <- bump stk + pokeI stk (x .|. y) + pure stk uprim2 !stk XORN !i !j = do x <- peekOffN stk i y <- peekOffN stk j stk <- bump stk pokeN stk (xor x y) pure stk +uprim2 !stk XORI !i !j = do + x <- peekOffI stk i + y <- peekOffI stk j + stk <- bump stk + pokeI stk (xor x y) + pure stk +uprim2 !stk CAST !vi !ti = do + newTypeTag <- peekOffI stk ti + v <- upeekOff stk vi + stk <- bump stk + poke stk $ UnboxedVal v (unboxedTypeTagFromInt newTypeTag) + pure stk {-# INLINE uprim2 #-} bprim1 :: @@ -1368,12 +1448,12 @@ bprim1 :: bprim1 !stk SIZT i = do t <- peekOffBi stk i stk <- bump stk - upoke stk $ Util.Text.size t + unsafePokeIasN stk $ Util.Text.size t pure stk bprim1 !stk SIZS i = do s <- peekOffS stk i stk <- bump stk - upoke stk $ Sq.length s + unsafePokeIasN stk $ Sq.length s pure stk bprim1 !stk ITOT i = do n <- upeekOff stk i @@ -1394,25 +1474,25 @@ bprim1 !stk USNC i = peekOffBi stk i >>= \t -> case Util.Text.unsnoc t of Nothing -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk Just (t, c) -> do stk <- bumpn stk 3 - upokeOff stk 2 $ fromEnum c -- char value + pokeOffC stk 2 $ c -- char value pokeOffBi stk 1 t -- remaining text - upoke stk 1 -- 'Just' tag + pokeTag stk 1 -- 'Just' tag pure stk bprim1 !stk UCNS i = peekOffBi stk i >>= \t -> case Util.Text.uncons t of Nothing -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk Just (c, t) -> do stk <- bumpn stk 3 pokeOffBi stk 2 t -- remaining text - upokeOff stk 1 $ fromEnum c -- char value - upoke stk 1 -- 'Just' tag + pokeOffC stk 1 $ c -- char value + pokeTag stk 1 -- 'Just' tag pure stk bprim1 !stk TTOI i = peekOffBi stk i >>= \t -> case readm $ Util.Text.unpack t of @@ -1420,12 +1500,12 @@ bprim1 !stk TTOI i = | fromIntegral (minBound :: Int) <= n, n <= fromIntegral (maxBound :: Int) -> do stk <- bumpn stk 2 - upoke stk 1 - upokeOff stk 1 (fromInteger n) + pokeTag stk 1 + pokeOffI stk 1 (fromInteger n) pure stk _ -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk where readm ('+' : s) = readMaybe s @@ -1436,83 +1516,86 @@ bprim1 !stk TTON i = | 0 <= n, n <= fromIntegral (maxBound :: Word) -> do stk <- bumpn stk 2 - upoke stk 1 + pokeTag stk 1 pokeOffN stk 1 (fromInteger n) pure stk _ -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk bprim1 !stk TTOF i = peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of Nothing -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk Just f -> do stk <- bumpn stk 2 - upoke stk 1 + pokeTag stk 1 pokeOffD stk 1 f pure stk bprim1 !stk VWLS i = peekOffS stk i >>= \case Sq.Empty -> do stk <- bump stk - upoke stk 0 -- 'Empty' tag + pokeTag stk 0 -- 'Empty' tag pure stk x Sq.:<| xs -> do stk <- bumpn stk 3 pokeOffS stk 2 xs -- remaining seq - bpokeOff stk 1 x -- head - upoke stk 1 -- ':<|' tag + pokeOff stk 1 x -- head + pokeTag stk 1 -- ':<|' tag pure stk bprim1 !stk VWRS i = peekOffS stk i >>= \case Sq.Empty -> do stk <- bump stk - upoke stk 0 -- 'Empty' tag + pokeTag stk 0 -- 'Empty' tag pure stk xs Sq.:|> x -> do stk <- bumpn stk 3 - bpokeOff stk 2 x -- last + pokeOff stk 2 x -- last pokeOffS stk 1 xs -- remaining seq - upoke stk 1 -- ':|>' tag + pokeTag stk 1 -- ':|>' tag pure stk bprim1 !stk PAKT i = do s <- peekOffS stk i stk <- bump stk - pokeBi stk . Util.Text.pack . toList $ clo2char <$> s + pokeBi stk . Util.Text.pack . toList $ val2char <$> s pure stk where - clo2char (DataU1 _ t i) | t == charTag = toEnum i - clo2char c = error $ "pack text: non-character closure: " ++ show c + val2char :: Val -> Char + val2char (CharVal c) = c + val2char c = error $ "pack text: non-character closure: " ++ show c bprim1 !stk UPKT i = do t <- peekOffBi stk i stk <- bump stk pokeS stk . Sq.fromList - . fmap (DataU1 Rf.charRef charTag . fromEnum) + . fmap CharVal . Util.Text.unpack $ t pure stk bprim1 !stk PAKB i = do s <- peekOffS stk i stk <- bump stk - pokeBi stk . By.fromWord8s . fmap clo2w8 $ toList s + pokeBi stk . By.fromWord8s . fmap val2w8 $ toList s pure stk where - clo2w8 (DataU1 _ t n) | t == natTag = toEnum n - clo2w8 c = error $ "pack bytes: non-natural closure: " ++ show c + -- TODO: Should we have a tag for bytes specifically? + val2w8 :: Val -> Word8 + val2w8 (NatVal n) = toEnum . fromEnum $ n + val2w8 c = error $ "pack bytes: non-natural closure: " ++ show c bprim1 !stk UPKB i = do b <- peekOffBi stk i stk <- bump stk - pokeS stk . Sq.fromList . fmap (DataU1 Rf.natRef natTag . fromEnum) $ + pokeS stk . Sq.fromList . fmap (NatVal . toEnum @Word64 . fromEnum @Word8) $ By.toWord8s b pure stk bprim1 !stk SIZB i = do b <- peekOffBi stk i stk <- bump stk - upoke stk $ By.size b + unsafePokeIasN stk $ By.size b pure stk bprim1 !stk FLTB i = do b <- peekOffBi stk i @@ -1537,23 +1620,17 @@ bprim2 :: Int -> Int -> IO Stack -bprim2 !stk EQLU i j = do - x <- bpeekOff stk i - y <- bpeekOff stk j - stk <- bump stk - upoke stk $ if universalEq (==) x y then 1 else 0 - pure stk bprim2 !stk IXOT i j = do x <- peekOffBi stk i y <- peekOffBi stk j case Util.Text.indexOf x y of Nothing -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk Just i -> do stk <- bumpn stk 2 - upoke stk 1 + pokeTag stk 1 pokeOffN stk 1 i pure stk bprim2 !stk IXOB i j = do @@ -1562,11 +1639,11 @@ bprim2 !stk IXOB i j = do case By.indexOf x y of Nothing -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk Just i -> do stk <- bumpn stk 2 - upoke stk 1 + pokeTag stk 1 pokeOffN stk 1 i pure stk bprim2 !stk DRPT i j = do @@ -1598,19 +1675,19 @@ bprim2 !stk EQLT i j = do x <- peekOffBi @Util.Text.Text stk i y <- peekOffBi stk j stk <- bump stk - upoke stk $ if x == y then 1 else 0 + pokeBool stk $ x == y pure stk bprim2 !stk LEQT i j = do x <- peekOffBi @Util.Text.Text stk i y <- peekOffBi stk j stk <- bump stk - upoke stk $ if x <= y then 1 else 0 + pokeBool stk $ x <= y pure stk bprim2 !stk LEST i j = do x <- peekOffBi @Util.Text.Text stk i y <- peekOffBi stk j stk <- bump stk - upoke stk $ if x < y then 1 else 0 + pokeBool stk $ x < y pure stk bprim2 !stk DRPS i j = do n <- upeekOff stk i @@ -1633,14 +1710,14 @@ bprim2 !stk TAKS i j = do pokeS stk $ if n < 0 then s else Sq.take n s pure stk bprim2 !stk CONS i j = do - x <- bpeekOff stk i + x <- peekOff stk i s <- peekOffS stk j stk <- bump stk pokeS stk $ x Sq.<| s pure stk bprim2 !stk SNOC i j = do s <- peekOffS stk i - x <- bpeekOff stk j + x <- peekOff stk j stk <- bump stk pokeS stk $ s Sq.|> x pure stk @@ -1656,13 +1733,13 @@ bprim2 !stk IDXS i j = do case Sq.lookup n s of Nothing -> do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk Just x -> do stk <- bump stk - bpoke stk x + poke stk x stk <- bump stk - upoke stk 1 + pokeTag stk 1 pure stk bprim2 !stk SPLL i j = do n <- upeekOff stk i @@ -1670,7 +1747,7 @@ bprim2 !stk SPLL i j = do if Sq.length s < n then do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk else do stk <- bumpn stk 2 @@ -1678,7 +1755,7 @@ bprim2 !stk SPLL i j = do pokeOffS stk 1 r pokeS stk l stk <- bump stk - upoke stk 1 + pokeTag stk 1 pure stk bprim2 !stk SPLR i j = do n <- upeekOff stk i @@ -1686,7 +1763,7 @@ bprim2 !stk SPLR i j = do if Sq.length s < n then do stk <- bump stk - upoke stk 0 + pokeTag stk 0 pure stk else do stk <- bumpn stk 2 @@ -1694,7 +1771,7 @@ bprim2 !stk SPLR i j = do pokeOffS stk 1 r pokeS stk l stk <- bump stk - upoke stk 1 + pokeTag stk 1 pure stk bprim2 !stk TAKB i j = do n <- upeekOff stk i @@ -1717,11 +1794,11 @@ bprim2 !stk IDXB i j = do b <- peekOffBi stk j stk <- bump stk stk <- case By.at n b of - Nothing -> stk <$ upoke stk 0 + Nothing -> stk <$ pokeTag stk 0 Just x -> do - upoke stk $ fromIntegral x + pokeByte stk x stk <- bump stk - stk <$ upoke stk 1 + stk <$ pokeTag stk 1 pure stk bprim2 !stk CATB i j = do l <- peekOffBi stk i @@ -1731,6 +1808,7 @@ bprim2 !stk CATB i j = do pure stk bprim2 !stk THRO _ _ = pure stk -- impossible bprim2 !stk TRCE _ _ = pure stk -- impossible +bprim2 !stk EQLU _ _ = pure stk -- impossible bprim2 !stk CMPU _ _ = pure stk -- impossible bprim2 !stk SDBX _ _ = pure stk -- impossible bprim2 !stk SDBV _ _ = pure stk -- impossible @@ -1747,10 +1825,12 @@ yield !env !denv !activeThreads !stk !k = leap denv k where leap !denv0 (Mark a ps cs k) = do let denv = cs <> EC.withoutKeys denv0 ps - clo = denv0 EC.! EC.findMin ps - bpoke stk . DataB1 Rf.effectRef 0 =<< bpeek stk + val = denv0 EC.! EC.findMin ps + v <- peek stk + stk <- bump stk + bpoke stk $ Data1 Rf.effectRef (PackedTag 0) v stk <- adjustArgs stk a - apply env denv activeThreads stk k False (VArg1 0) clo + apply env denv activeThreads stk k False (VArg1 0) val leap !denv (Push fsz asz (CIx ref _ _) f nx k) = do stk <- restoreFrame stk fsz asz stk <- ensure stk f @@ -1793,12 +1873,12 @@ splitCont :: Stack -> K -> Word64 -> - IO (Closure, DEnv, Stack, K) + IO (Val, DEnv, Stack, K) splitCont !denv !stk !k !p = walk denv asz KE k where asz = asize stk - walk :: EnumMap Word64 Closure -> SZ -> K -> K -> IO (Closure, EnumMap Word64 Closure, Stack, K) + walk :: EnumMap Word64 Val -> SZ -> K -> K -> IO (Val, EnumMap Word64 Val, Stack, K) walk !denv !sz !ck KE = die "fell off stack" >> finish denv sz 0 ck KE walk !denv !sz !ck (CB _) = @@ -1816,11 +1896,11 @@ splitCont !denv !stk !k !p = (Push n a br p brSect ck) k - finish :: EnumMap Word64 Closure -> SZ -> SZ -> K -> K -> (IO (Closure, EnumMap Word64 Closure, Stack, K)) + finish :: EnumMap Word64 Val -> SZ -> SZ -> K -> K -> (IO (Val, EnumMap Word64 Val, Stack, K)) finish !denv !sz !a !ck !k = do (seg, stk) <- grab stk sz stk <- adjustArgs stk a - return (Captured ck asz seg, denv, stk, k) + return (BoxedVal $ Captured ck asz seg, denv, stk, k) {-# INLINE splitCont #-} discardCont :: @@ -1834,11 +1914,11 @@ discardCont denv stk k p = <&> \(_, denv, stk, k) -> (denv, stk, k) {-# INLINE discardCont #-} -resolve :: CCache -> DEnv -> Stack -> MRef -> IO Closure -resolve _ _ _ (Env cix mcomb) = pure $ mCombClosure cix mcomb -resolve _ _ stk (Stk i) = bpeekOff stk i +resolve :: CCache -> DEnv -> Stack -> MRef -> IO Val +resolve _ _ _ (Env cix mcomb) = pure $ mCombVal cix mcomb +resolve _ _ stk (Stk i) = peekOff stk i resolve env denv _ (Dyn i) = case EC.lookup i denv of - Just clo -> pure clo + Just val -> pure val Nothing -> unhandledErr "resolve" env i unhandledErr :: String -> CCache -> Word64 -> IO a @@ -1881,36 +1961,36 @@ refLookup s m r error $ "refLookup:" ++ s ++ ": unknown reference: " ++ show r decodeCacheArgument :: - Sq.Seq Closure -> IO [(Reference, Code)] + USeq -> IO [(Reference, Code)] decodeCacheArgument s = for (toList s) $ \case - DataB2 _ _ (Foreign x) (DataB2 _ _ (Foreign y) _) -> + (Val _unboxed (Data2 _ _ (BoxedVal (Foreign x)) (BoxedVal (Data2 _ _ (BoxedVal (Foreign y)) _)))) -> case unwrapForeign x of Ref r -> pure (r, unwrapForeign y) _ -> die "decodeCacheArgument: Con reference" _ -> die "decodeCacheArgument: unrecognized value" -decodeSandboxArgument :: Sq.Seq Closure -> IO [Reference] +decodeSandboxArgument :: USeq -> IO [Reference] decodeSandboxArgument s = fmap join . for (toList s) $ \case - Foreign x -> case unwrapForeign x of + Val _ (Foreign x) -> case unwrapForeign x of Ref r -> pure [r] _ -> pure [] -- constructor _ -> die "decodeSandboxArgument: unrecognized value" -encodeSandboxListResult :: [Reference] -> Sq.Seq Closure +encodeSandboxListResult :: [Reference] -> Sq.Seq Val encodeSandboxListResult = - Sq.fromList . fmap (Foreign . Wrap Rf.termLinkRef . Ref) + Sq.fromList . fmap (boxedVal . Foreign . Wrap Rf.termLinkRef . Ref) encodeSandboxResult :: Either [Reference] [Reference] -> Closure encodeSandboxResult (Left rfs) = - encodeLeft . Foreign . Wrap Rf.listRef $ encodeSandboxListResult rfs + encodeLeft . boxedVal . Foreign . Wrap Rf.listRef $ encodeSandboxListResult rfs encodeSandboxResult (Right rfs) = - encodeRight . Foreign . Wrap Rf.listRef $ encodeSandboxListResult rfs + encodeRight . boxedVal . Foreign . Wrap Rf.listRef $ encodeSandboxListResult rfs -encodeLeft :: Closure -> Closure -encodeLeft = DataB1 Rf.eitherRef leftTag +encodeLeft :: Val -> Closure +encodeLeft = Data1 Rf.eitherRef TT.leftTag -encodeRight :: Closure -> Closure -encodeRight = DataB1 Rf.eitherRef rightTag +encodeRight :: Val -> Closure +encodeRight = Data1 Rf.eitherRef TT.rightTag addRefs :: TVar Word64 -> @@ -2062,15 +2142,15 @@ cacheAdd0 ntys0 termSuperGroups sands cc = do pure $ int `seq` rtm `seq` newCombRefs `seq` updatedCombs `seq` nsn `seq` ncc `seq` nsc `seq` (unresolvedCacheableCombs, unresolvedNonCacheableCombs) preEvalTopLevelConstants unresolvedCacheableCombs unresolvedNonCacheableCombs cc -preEvalTopLevelConstants :: (EnumMap Word64 (GCombs Closure CombIx)) -> (EnumMap Word64 (GCombs Closure CombIx)) -> CCache -> IO () +preEvalTopLevelConstants :: (EnumMap Word64 (GCombs Val CombIx)) -> (EnumMap Word64 (GCombs Val CombIx)) -> CCache -> IO () preEvalTopLevelConstants cacheableCombs newCombs cc = do activeThreads <- Just <$> UnliftIO.newIORef mempty evaluatedCacheableCombsVar <- newTVarIO mempty for_ (EC.mapToList cacheableCombs) \(w, _) -> do let hook stk = do - clos <- bpeek stk + val <- peek stk atomically $ do - modifyTVar evaluatedCacheableCombsVar $ EC.mapInsert w (EC.mapSingleton 0 $ CachedClosure w clos) + modifyTVar evaluatedCacheableCombsVar $ EC.mapInsert w (EC.mapSingleton 0 $ CachedVal w val) apply0 (Just hook) cc activeThreads w evaluatedCacheableCombs <- readTVarIO evaluatedCacheableCombsVar @@ -2120,7 +2200,7 @@ cacheAdd l cc = do then [] <$ cacheAdd0 tys l'' (expandSandbox sand l') cc else pure $ S.toList missing -reflectValue :: EnumMap Word64 Reference -> Closure -> IO ANF.Value +reflectValue :: EnumMap Word64 Reference -> Val -> IO ANF.Value reflectValue rty = goV where err s = "reflectValue: cannot prepare value for serialization: " ++ s @@ -2131,16 +2211,28 @@ reflectValue rty = goV goIx (CIx r _ i) = ANF.GR r i - goV :: Closure -> IO ANF.Value - goV (PApV cix _rComb args) = - ANF.Partial (goIx cix) <$> traverse (bitraverse (pure . fromIntegral) goV) args - goV (DataC _ t [Left w]) = ANF.BLit <$> reflectUData t w - goV (DataC r t segs) = - ANF.Data r (maskTags t) <$> traverse (bitraverse (pure . fromIntegral) goV) segs - goV (CapV k _ segs) = - ANF.Cont <$> traverse (bitraverse (pure . fromIntegral) goV) segs <*> goK k - goV (Foreign f) = ANF.BLit <$> goF f - goV BlackHole = die $ err "black hole" + goV :: Val -> IO ANF.Value + goV = \case + -- For back-compatibility we reflect all Unboxed values into boxed literals, we could change this in the future, + -- but there's not much of a big reason to. + + NatVal n -> pure . ANF.BLit $ ANF.Pos n + IntVal n + | n >= 0 -> pure . ANF.BLit $ ANF.Pos (fromIntegral n) + | otherwise -> pure . ANF.BLit $ ANF.Neg (fromIntegral (abs n)) + DoubleVal f -> pure . ANF.BLit $ ANF.Float f + CharVal c -> pure . ANF.BLit $ ANF.Char c + val@(Val _ clos) -> + case clos of + (PApV cix _rComb args) -> + ANF.Partial (goIx cix) <$> traverse goV args + (DataC r t segs) -> + ANF.Data r (maskTags t) <$> traverse goV segs + (CapV k _ segs) -> + ANF.Cont <$> traverse goV segs <*> goK k + (Foreign f) -> ANF.BLit <$> goF f + BlackHole -> die $ err "black hole" + UnboxedTypeTag {} -> die $ err $ "unknown unboxed value" <> show val goK (CB _) = die $ err "callback continuation" goK KE = pure ANF.KE @@ -2176,16 +2268,7 @@ reflectValue rty = goV ANF.Arr <$> traverse goV a | otherwise = die $ err $ "foreign value: " <> (show f) - reflectUData :: Word64 -> Int -> IO ANF.BLit - reflectUData t v - | t == natTag = pure $ ANF.Pos (fromIntegral v) - | t == charTag = pure $ ANF.Char (toEnum v) - | t == intTag, v >= 0 = pure $ ANF.Pos (fromIntegral v) - | t == intTag, v < 0 = pure $ ANF.Neg (fromIntegral (-v)) - | t == floatTag = pure $ ANF.Float (intToDouble v) - | otherwise = die . err $ "unboxed data: " <> show (t, v) - -reifyValue :: CCache -> ANF.Value -> IO (Either [Reference] Closure) +reifyValue :: CCache -> ANF.Value -> IO (Either [Reference] Val) reifyValue cc val = do erc <- atomically $ do @@ -2205,7 +2288,7 @@ reifyValue cc val = do reifyValue0 :: (EnumMap Word64 MCombs, M.Map Reference Word64, M.Map Reference Word64) -> ANF.Value -> - IO Closure + IO Val reifyValue0 (combs, rty, rtm) = goV where err s = "reifyValue: cannot restore value: " ++ s @@ -2221,18 +2304,22 @@ reifyValue0 (combs, rty, rtm) = goV let cix = (CIx r n i) in (cix, rCombSection combs cix) + goV :: ANF.Value -> IO Val goV (ANF.Partial gr vs) = goIx gr >>= \case - (cix, RComb (Comb rcomb)) -> PApV cix rcomb <$> traverse (bitraverse (pure . fromIntegral) goV) vs - (_, RComb (CachedClosure _ clo)) - | [] <- vs -> pure clo + (cix, RComb (Comb rcomb)) -> boxedVal . PApV cix rcomb <$> traverse goV vs + (_, RComb (CachedVal _ val)) + | [] <- vs -> pure val | otherwise -> die . err $ msg where msg = "reifyValue0: non-trivial partial application to cached value" goV (ANF.Data r t0 vs) = do t <- flip packTags (fromIntegral t0) . fromIntegral <$> refTy r - DataC r t <$> traverse (bitraverse (pure . fromIntegral) goV) vs - goV (ANF.Cont vs k) = cv <$> goK k <*> traverse (bitraverse (pure . fromIntegral) goV) vs + boxedVal . DataC r t <$> traverse goV vs + goV (ANF.Cont vs k) = do + k' <- goK k + vs' <- traverse goV vs + pure . boxedVal $ cv k' vs' where cv k s = CapV k a s where @@ -2244,7 +2331,7 @@ reifyValue0 (combs, rty, rtm) = goV goK (ANF.Mark a ps de k) = mrk <$> traverse refTy ps - <*> traverse (\(k, v) -> (,) <$> refTy k <*> goV v) (M.toList de) + <*> traverse (\(k, v) -> (,) <$> refTy k <*> (goV v)) (M.toList de) <*> goK k where mrk ps de k = @@ -2264,28 +2351,22 @@ reifyValue0 (combs, rty, rtm) = goV "tried to reify a continuation with a cached value resumption" ++ show r - goL (ANF.Text t) = pure . Foreign $ Wrap Rf.textRef t - goL (ANF.List l) = Foreign . Wrap Rf.listRef <$> traverse goV l - goL (ANF.TmLink r) = pure . Foreign $ Wrap Rf.termLinkRef r - goL (ANF.TyLink r) = pure . Foreign $ Wrap Rf.typeLinkRef r - goL (ANF.Bytes b) = pure . Foreign $ Wrap Rf.bytesRef b - goL (ANF.Quote v) = pure . Foreign $ Wrap Rf.valueRef v - goL (ANF.Code g) = pure . Foreign $ Wrap Rf.codeRef g - goL (ANF.BArr a) = pure . Foreign $ Wrap Rf.ibytearrayRef a - goL (ANF.Char c) = pure $ DataU1 Rf.charRef charTag (fromEnum c) + goL :: ANF.BLit -> IO Val + goL (ANF.Text t) = pure . boxedVal . Foreign $ Wrap Rf.textRef t + goL (ANF.List l) = boxedVal . Foreign . Wrap Rf.listRef <$> traverse goV l + goL (ANF.TmLink r) = pure . boxedVal . Foreign $ Wrap Rf.termLinkRef r + goL (ANF.TyLink r) = pure . boxedVal . Foreign $ Wrap Rf.typeLinkRef r + goL (ANF.Bytes b) = pure . boxedVal . Foreign $ Wrap Rf.bytesRef b + goL (ANF.Quote v) = pure . boxedVal . Foreign $ Wrap Rf.valueRef v + goL (ANF.Code g) = pure . boxedVal . Foreign $ Wrap Rf.codeRef g + goL (ANF.BArr a) = pure . boxedVal . Foreign $ Wrap Rf.ibytearrayRef a + goL (ANF.Char c) = pure $ CharVal c goL (ANF.Pos w) = - pure $ DataU1 Rf.natRef natTag (fromIntegral w) - goL (ANF.Neg w) = - pure $ DataU1 Rf.intRef intTag (-fromIntegral w) - goL (ANF.Float d) = - pure $ DataU1 Rf.floatRef floatTag (doubleToInt d) - goL (ANF.Arr a) = Foreign . Wrap Rf.iarrayRef <$> traverse goV a - -doubleToInt :: Double -> Int -doubleToInt d = indexByteArray (BA.byteArrayFromList [d]) 0 - -intToDouble :: Int -> Double -intToDouble w = indexByteArray (BA.byteArrayFromList [w]) 0 + -- TODO: Should this be a Nat or an Int? + pure $ NatVal w + goL (ANF.Neg w) = pure $ IntVal (negate (fromIntegral w :: Int)) + goL (ANF.Float d) = pure $ DoubleVal d + goL (ANF.Arr a) = boxedVal . Foreign . Wrap Rf.iarrayRef <$> traverse goV a -- Universal comparison functions @@ -2294,18 +2375,25 @@ closureNum PAp {} = 0 closureNum DataC {} = 1 closureNum Captured {} = 2 closureNum Foreign {} = 3 -closureNum BlackHole {} = error "BlackHole" +closureNum UnboxedTypeTag {} = 4 +closureNum BlackHole {} = 5 universalEq :: (Foreign -> Foreign -> Bool) -> - Closure -> - Closure -> + Val -> + Val -> Bool -universalEq frn = eqc +universalEq frn = eqVal where + eql :: (a -> b -> Bool) -> [a] -> [b] -> Bool eql cm l r = length l == length r && and (zipWith cm l r) - eqc (DataC _ ct1 [Left w1]) (DataC _ ct2 [Left w2]) = - matchTags ct1 ct2 && w1 == w2 + eqVal :: Val -> Val -> Bool + eqVal (UnboxedVal v1 t1) (UnboxedVal v2 t2) = matchUnboxedTypes t1 t2 && v1 == v2 + eqVal (BoxedVal x) (BoxedVal y) = eqc x y + eqVal _ _ = False + eqc :: Closure -> Closure -> Bool + eqc (DataC _ ct1 [w1]) (DataC _ ct2 [w2]) = + matchTags ct1 ct2 && eqVal w1 w2 eqc (DataC _ ct1 vs1) (DataC _ ct2 vs2) = ct1 == ct2 && eqValList vs1 vs2 @@ -2313,34 +2401,48 @@ universalEq frn = eqc cix1 == cix2 && eqValList segs1 segs2 eqc (CapV k1 a1 vs1) (CapV k2 a2 vs2) = - k1 == k2 + eqK k1 k2 && a1 == a2 && eqValList vs1 vs2 eqc (Foreign fl) (Foreign fr) - | Just al <- maybeUnwrapForeign Rf.iarrayRef fl, - Just ar <- maybeUnwrapForeign Rf.iarrayRef fr = - arrayEq eqc al ar - | Just sl <- maybeUnwrapForeign Rf.listRef fl, - Just sr <- maybeUnwrapForeign Rf.listRef fr = - length sl == length sr && and (Sq.zipWith eqc sl sr) + | Just al <- maybeUnwrapForeign @(PA.Array Val) Rf.iarrayRef fl, + Just ar <- maybeUnwrapForeign @(PA.Array Val) Rf.iarrayRef fr = + arrayEq eqVal al ar + | Just sl <- maybeUnwrapForeign @(Seq Val) Rf.listRef fl, + Just sr <- maybeUnwrapForeign @(Seq Val) Rf.listRef fr = + length sl == length sr && and (Sq.zipWith eqVal sl sr) | otherwise = frn fl fr eqc c d = closureNum c == closureNum d - -- Written this way to maintain back-compat with the - -- old val lists which were separated by unboxed/boxed. - eqValList vs1 vs2 = - let (us1, bs1) = partitionEithers vs1 - (us2, bs2) = partitionEithers vs2 - in eql (==) us1 us2 - && eql eqc bs1 bs2 - - -- serialization doesn't necessarily preserve Int tags, so be - -- more accepting for those. - matchTags ct1 ct2 = - ct1 == ct2 - || (ct1 == intTag && ct2 == natTag) - || (ct1 == natTag && ct2 == intTag) -arrayEq :: (Closure -> Closure -> Bool) -> PA.Array Closure -> PA.Array Closure -> Bool + eqValList :: [Val] -> [Val] -> Bool + eqValList vs1 vs2 = eql eqVal vs1 vs2 + + eqK :: K -> K -> Bool + eqK KE KE = True + eqK (CB cb) (CB cb') = cb == cb' + eqK (Mark a ps m k) (Mark a' ps' m' k') = + a == a' && ps == ps' && liftEq eqVal m m' && eqK k k' + eqK (Push f a ci _ _sect k) (Push f' a' ci' _ _sect' k') = + f == f' && a == a' && ci == ci' && eqK k k' + eqK _ _ = False + +-- serialization doesn't necessarily preserve Int tags, so be +-- more accepting for those. +matchTags :: PackedTag -> PackedTag -> Bool +matchTags ct1 ct2 = + ct1 == ct2 + || (ct1 == TT.intTag && ct2 == TT.natTag) + || (ct1 == TT.natTag && ct2 == TT.intTag) + +-- serialization doesn't necessarily preserve Int tags, so be +-- more accepting for those. +matchUnboxedTypes :: UnboxedTypeTag -> UnboxedTypeTag -> Bool +matchUnboxedTypes ct1 ct2 = + ct1 == ct2 + || (ct1 == IntTag && ct2 == NatTag) + || (ct1 == NatTag && ct2 == IntTag) + +arrayEq :: (a -> a -> Bool) -> PA.Array a -> PA.Array a -> Bool arrayEq eqc l r | PA.sizeofArray l /= PA.sizeofArray r = False | otherwise = go (PA.sizeofArray l - 1) @@ -2380,109 +2482,100 @@ compareAsFloat i j where clear k = clearBit k 64 -compareAsNat :: Int -> Int -> Ordering -compareAsNat i j = compare ni nj - where - ni, nj :: Word - ni = fromIntegral i - nj = fromIntegral j - -floatTag :: Word64 -floatTag - | Just n <- M.lookup Rf.floatRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: floatTag" - -natTag :: Word64 -natTag - | Just n <- M.lookup Rf.natRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: natTag" - -intTag :: Word64 -intTag - | Just n <- M.lookup Rf.intRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: intTag" - -charTag :: Word64 -charTag - | Just n <- M.lookup Rf.charRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: charTag" - -unitTag :: Word64 -unitTag - | Just n <- M.lookup Rf.unitRef builtinTypeNumbering, - rt <- toEnum (fromIntegral n) = - packTags rt 0 - | otherwise = error "internal error: unitTag" - -leftTag, rightTag :: Word64 -(leftTag, rightTag) - | Just n <- M.lookup Rf.eitherRef builtinTypeNumbering, - et <- toEnum (fromIntegral n), - lt <- toEnum (fromIntegral Rf.eitherLeftId), - rt <- toEnum (fromIntegral Rf.eitherRightId) = - (packTags et lt, packTags et rt) - | otherwise = error "internal error: either tags" - universalCompare :: (Foreign -> Foreign -> Ordering) -> - Closure -> - Closure -> + Val -> + Val -> Ordering -universalCompare frn = cmpc False +universalCompare frn = cmpVal False where + cmpVal :: Bool -> Val -> Val -> Ordering + cmpVal tyEq = \cases + (BoxedVal c1) (BoxedVal c2) -> cmpc tyEq c1 c2 + (UnboxedVal {}) (BoxedVal {}) -> LT + (BoxedVal {}) (UnboxedVal {}) -> GT + (NatVal i) (NatVal j) -> compare i j + (UnboxedVal v1 t1) (UnboxedVal v2 t2) -> cmpUnboxed tyEq (t1, v1) (t2, v2) + cmpl :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering cmpl cm l r = compare (length l) (length r) <> fold (zipWith cm l r) - cmpc _ (DataC _ ct1 [Left i]) (DataC _ ct2 [Left j]) - | ct1 == floatTag, ct2 == floatTag = compareAsFloat i j - | ct1 == natTag, ct2 == natTag = compareAsNat i j - | ct1 == intTag, ct2 == natTag = compare i j - | ct1 == natTag, ct2 == intTag = compare i j - cmpc tyEq (DataC rf1 ct1 vs1) (DataC rf2 ct2 vs2) = - (if tyEq && ct1 /= ct2 then compare rf1 rf2 else EQ) - <> compare (maskTags ct1) (maskTags ct2) - -- when comparing corresponding `Any` values, which have - -- existentials inside check that type references match - <> cmpValList (tyEq || rf1 == Rf.anyRef) vs1 vs2 - cmpc tyEq (PApV cix1 _ segs1) (PApV cix2 _ segs2) = - compare cix1 cix2 - <> cmpValList tyEq segs1 segs2 - cmpc _ (CapV k1 a1 vs1) (CapV k2 a2 vs2) = - compare k1 k2 - <> compare a1 a2 - <> cmpValList True vs1 vs2 - cmpc tyEq (Foreign fl) (Foreign fr) - | Just sl <- maybeUnwrapForeign Rf.listRef fl, - Just sr <- maybeUnwrapForeign Rf.listRef fr = - fold (Sq.zipWith (cmpc tyEq) sl sr) - <> compare (length sl) (length sr) - | Just al <- maybeUnwrapForeign Rf.iarrayRef fl, - Just ar <- maybeUnwrapForeign Rf.iarrayRef fr = - arrayCmp (cmpc tyEq) al ar - | otherwise = frn fl fr - cmpc _ c d = comparing closureNum c d - -- Written this way to maintain back-compat with the - -- old val lists which were separated by unboxed/boxed. - cmpValList tyEq vs1 vs2 = - let (us1, bs1) = (partitionEithers vs1) - (us2, bs2) = (partitionEithers vs2) - in cmpl compare us1 us2 <> cmpl (cmpc tyEq) bs1 bs2 + cmpc :: Bool -> Closure -> Closure -> Ordering + cmpc tyEq = \cases + (DataC rf1 ct1 vs1) (DataC rf2 ct2 vs2) -> + (if tyEq && ct1 /= ct2 then compare rf1 rf2 else EQ) + <> compare (maskTags ct1) (maskTags ct2) + -- when comparing corresponding `Any` values, which have + -- existentials inside check that type references match + <> cmpValList (tyEq || rf1 == Rf.anyRef) vs1 vs2 + (PApV cix1 _ segs1) (PApV cix2 _ segs2) -> + compare cix1 cix2 + <> cmpValList tyEq segs1 segs2 + (CapV k1 a1 vs1) (CapV k2 a2 vs2) -> + cmpK tyEq k1 k2 + <> compare a1 a2 + <> cmpValList True vs1 vs2 + (Foreign fl) (Foreign fr) + | Just sl <- maybeUnwrapForeign @(Seq Val) Rf.listRef fl, + Just sr <- maybeUnwrapForeign @(Seq Val) Rf.listRef fr -> + fold (Sq.zipWith (cmpVal tyEq) sl sr) + <> compare (length sl) (length sr) + | Just al <- maybeUnwrapForeign @(PA.Array Val) Rf.iarrayRef fl, + Just ar <- maybeUnwrapForeign @(PA.Array Val) Rf.iarrayRef fr -> + arrayCmp (cmpVal tyEq) al ar + | otherwise -> frn fl fr + (UnboxedTypeTag t1) (UnboxedTypeTag t2) -> compare t1 t2 + (BlackHole) (BlackHole) -> EQ + c d -> comparing closureNum c d + + cmpUnboxed :: Bool -> (UnboxedTypeTag, Int) -> (UnboxedTypeTag, Int) -> Ordering + cmpUnboxed tyEq = \cases + -- Need to cast to Nat or else maxNat == -1 and it flips comparisons of large Nats. + -- TODO: Investigate whether bit-twiddling is faster than using Haskell's fromIntegral. + (IntTag, n1) (IntTag, n2) -> compare n1 n2 + (NatTag, n1) (NatTag, n2) -> compare (fromIntegral n1 :: Word64) (fromIntegral n2 :: Word64) + (NatTag, n1) (IntTag, n2) + | n2 < 0 -> GT + | otherwise -> compare (fromIntegral n1 :: Word64) (fromIntegral n2 :: Word64) + (IntTag, n1) (NatTag, n2) + | n1 < 0 -> LT + | otherwise -> compare (fromIntegral n1 :: Word64) (fromIntegral n2 :: Word64) + (FloatTag, n1) (FloatTag, n2) -> compareAsFloat n1 n2 + (t1, v1) (t2, v2) -> + Monoid.whenM tyEq (compare t1 t2) + <> compare v1 v2 + + cmpValList :: Bool -> [Val] -> [Val] -> Ordering + cmpValList tyEq vs1 vs2 = cmpl (cmpVal tyEq) vs1 vs2 + + cmpK :: Bool -> K -> K -> Ordering + cmpK tyEq = \cases + KE KE -> EQ + (CB cb) (CB cb') -> compare cb cb' + (Mark a ps m k) (Mark a' ps' m' k') -> + compare a a' + <> compare ps ps' + <> liftCompare (cmpVal tyEq) m m' + <> cmpK tyEq k k' + (Push f a ci _ _sect k) (Push f' a' ci' _ _sect' k') -> + compare f f' + <> compare a a' + <> compare ci ci' + <> cmpK tyEq k k' + KE _ -> LT + _ KE -> GT + (CB {}) _ -> LT + _ (CB {}) -> GT + (Mark {}) _ -> LT + _ (Mark {}) -> GT arrayCmp :: - (Closure -> Closure -> Ordering) -> - PA.Array Closure -> - PA.Array Closure -> + (a -> a -> Ordering) -> + PA.Array a -> + PA.Array a -> Ordering -arrayCmp cmpc l r = +arrayCmp cmpVal l r = comparing PA.sizeofArray l r <> go (PA.sizeofArray l - 1) where go i | i < 0 = EQ - | otherwise = cmpc (PA.indexArray l i) (PA.indexArray r i) <> go (i - 1) + | otherwise = cmpVal (PA.indexArray l i) (PA.indexArray r i) <> go (i - 1) diff --git a/unison-runtime/src/Unison/Runtime/Serialize.hs b/unison-runtime/src/Unison/Runtime/Serialize.hs index 825f3f864b..cd6cf61b0b 100644 --- a/unison-runtime/src/Unison/Runtime/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/Serialize.hs @@ -296,126 +296,152 @@ getConstructorReference = instance Tag UPrim1 where tag2word DECI = 0 - tag2word INCI = 1 - tag2word NEGI = 2 - tag2word SGNI = 3 - tag2word LZRO = 4 - tag2word TZRO = 5 - tag2word COMN = 6 - tag2word POPC = 7 - tag2word ABSF = 8 - tag2word EXPF = 9 - tag2word LOGF = 10 - tag2word SQRT = 11 - tag2word COSF = 12 - tag2word ACOS = 13 - tag2word COSH = 14 - tag2word ACSH = 15 - tag2word SINF = 16 - tag2word ASIN = 17 - tag2word SINH = 18 - tag2word ASNH = 19 - tag2word TANF = 20 - tag2word ATAN = 21 - tag2word TANH = 22 - tag2word ATNH = 23 - tag2word ITOF = 24 - tag2word NTOF = 25 - tag2word CEIL = 26 - tag2word FLOR = 27 - tag2word TRNF = 28 - tag2word RNDF = 29 + tag2word DECN = 1 + tag2word INCI = 2 + tag2word INCN = 3 + tag2word NEGI = 4 + tag2word SGNI = 5 + tag2word LZRO = 6 + tag2word TZRO = 7 + tag2word COMN = 8 + tag2word COMI = 9 + tag2word POPC = 10 + tag2word ABSF = 11 + tag2word EXPF = 12 + tag2word LOGF = 13 + tag2word SQRT = 14 + tag2word COSF = 15 + tag2word ACOS = 16 + tag2word COSH = 17 + tag2word ACSH = 18 + tag2word SINF = 19 + tag2word ASIN = 20 + tag2word SINH = 21 + tag2word ASNH = 22 + tag2word TANF = 23 + tag2word ATAN = 24 + tag2word TANH = 25 + tag2word ATNH = 26 + tag2word ITOF = 27 + tag2word NTOF = 28 + tag2word CEIL = 29 + tag2word FLOR = 30 + tag2word TRNF = 31 + tag2word RNDF = 32 word2tag 0 = pure DECI - word2tag 1 = pure INCI - word2tag 2 = pure NEGI - word2tag 3 = pure SGNI - word2tag 4 = pure LZRO - word2tag 5 = pure TZRO - word2tag 6 = pure COMN - word2tag 7 = pure POPC - word2tag 8 = pure ABSF - word2tag 9 = pure EXPF - word2tag 10 = pure LOGF - word2tag 11 = pure SQRT - word2tag 12 = pure COSF - word2tag 13 = pure ACOS - word2tag 14 = pure COSH - word2tag 15 = pure ACSH - word2tag 16 = pure SINF - word2tag 17 = pure ASIN - word2tag 18 = pure SINH - word2tag 19 = pure ASNH - word2tag 20 = pure TANF - word2tag 21 = pure ATAN - word2tag 22 = pure TANH - word2tag 23 = pure ATNH - word2tag 24 = pure ITOF - word2tag 25 = pure NTOF - word2tag 26 = pure CEIL - word2tag 27 = pure FLOR - word2tag 28 = pure TRNF - word2tag 29 = pure RNDF + word2tag 1 = pure DECN + word2tag 2 = pure INCI + word2tag 3 = pure INCN + word2tag 4 = pure NEGI + word2tag 5 = pure SGNI + word2tag 6 = pure LZRO + word2tag 7 = pure TZRO + word2tag 8 = pure COMN + word2tag 9 = pure COMI + word2tag 10 = pure POPC + word2tag 11 = pure ABSF + word2tag 12 = pure EXPF + word2tag 13 = pure LOGF + word2tag 14 = pure SQRT + word2tag 15 = pure COSF + word2tag 16 = pure ACOS + word2tag 17 = pure COSH + word2tag 18 = pure ACSH + word2tag 19 = pure SINF + word2tag 20 = pure ASIN + word2tag 21 = pure SINH + word2tag 22 = pure ASNH + word2tag 23 = pure TANF + word2tag 24 = pure ATAN + word2tag 25 = pure TANH + word2tag 26 = pure ATNH + word2tag 27 = pure ITOF + word2tag 28 = pure NTOF + word2tag 29 = pure CEIL + word2tag 30 = pure FLOR + word2tag 31 = pure TRNF + word2tag 32 = pure RNDF word2tag n = unknownTag "UPrim1" n instance Tag UPrim2 where tag2word ADDI = 0 - tag2word SUBI = 1 - tag2word MULI = 2 - tag2word DIVI = 3 - tag2word MODI = 4 - tag2word DIVN = 5 - tag2word MODN = 6 - tag2word SHLI = 7 - tag2word SHRI = 8 - tag2word SHRN = 9 - tag2word POWI = 10 - tag2word EQLI = 11 - tag2word LEQI = 12 - tag2word LEQN = 13 - tag2word ANDN = 14 - tag2word IORN = 15 - tag2word XORN = 16 - tag2word EQLF = 17 - tag2word LEQF = 18 - tag2word ADDF = 19 - tag2word SUBF = 20 - tag2word MULF = 21 - tag2word DIVF = 22 - tag2word ATN2 = 23 - tag2word POWF = 24 - tag2word LOGB = 25 - tag2word MAXF = 26 - tag2word MINF = 27 + tag2word ADDN = 1 + tag2word SUBI = 2 + tag2word SUBN = 3 + tag2word MULI = 4 + tag2word MULN = 5 + tag2word DIVI = 6 + tag2word MODI = 7 + tag2word DIVN = 8 + tag2word MODN = 9 + tag2word SHLI = 10 + tag2word SHLN = 11 + tag2word SHRI = 12 + tag2word SHRN = 13 + 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 word2tag 0 = pure ADDI - word2tag 1 = pure SUBI - word2tag 2 = pure MULI - word2tag 3 = pure DIVI - word2tag 4 = pure MODI - word2tag 5 = pure DIVN - word2tag 6 = pure MODN - word2tag 7 = pure SHLI - word2tag 8 = pure SHRI - word2tag 9 = pure SHRN - word2tag 10 = pure POWI - word2tag 11 = pure EQLI - word2tag 12 = pure LEQI - word2tag 13 = pure LEQN - word2tag 14 = pure ANDN - word2tag 15 = pure IORN - word2tag 16 = pure XORN - word2tag 17 = pure EQLF - word2tag 18 = pure LEQF - word2tag 19 = pure ADDF - word2tag 20 = pure SUBF - word2tag 21 = pure MULF - word2tag 22 = pure DIVF - word2tag 23 = pure ATN2 - word2tag 24 = pure POWF - word2tag 25 = pure LOGB - word2tag 26 = pure MAXF - word2tag 27 = pure MINF + word2tag 1 = pure ADDN + word2tag 2 = pure SUBI + word2tag 3 = pure SUBN + word2tag 4 = pure MULI + word2tag 5 = pure MULN + word2tag 6 = pure DIVI + word2tag 7 = pure MODI + word2tag 8 = pure DIVN + word2tag 9 = pure MODN + word2tag 10 = pure SHLI + word2tag 11 = pure SHLN + word2tag 12 = pure SHRI + word2tag 13 = pure SHRN + 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 n = unknownTag "UPrim2" n instance Tag BPrim1 where diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index d548c8531f..ebc9ef33dd 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} module Unison.Runtime.Stack ( K (..), @@ -16,17 +11,17 @@ module Unison.Runtime.Stack CapV, PAp, Enum, - DataU1, - DataU2, - DataB1, - DataB2, - DataUB, - DataBU, + Data1, + Data2, DataG, Captured, Foreign, - BlackHole + BlackHole, + UnboxedTypeTag ), + UnboxedTypeTag (..), + unboxedTypeTagToInt, + unboxedTypeTagFromInt, IxClosure, Callback (..), Augment (..), @@ -38,6 +33,19 @@ module Unison.Runtime.Stack Seg, USeg, BSeg, + SegList, + Val + ( .., + CharVal, + NatVal, + DoubleVal, + IntVal, + UnboxedVal, + BoxedVal + ), + emptyVal, + boxedVal, + USeq, traceK, frameDataSize, marshalToForeign, @@ -46,12 +54,26 @@ module Unison.Runtime.Stack nullSeg, peekD, peekOffD, + peekC, + peekOffC, + poke, pokeD, pokeOffD, + pokeC, + pokeOffC, + pokeBool, + pokeTag, + peekTag, + peekTagOff, + peekI, + peekOffI, peekN, peekOffN, pokeN, pokeOffN, + pokeI, + pokeOffI, + pokeByte, peekBi, peekOffBi, pokeBi, @@ -73,8 +95,10 @@ module Unison.Runtime.Stack bpeekOff, bpoke, bpokeOff, - upoke, - upokeOff, + pokeOff, + upokeT, + upokeOffT, + unsafePokeIasN, bump, bumpn, grab, @@ -92,15 +116,25 @@ module Unison.Runtime.Stack adjustArgs, fsize, asize, + + -- * Unboxed type tags + natTypeTag, + intTypeTag, + charTypeTag, + floatTypeTag, ) where import Control.Monad.Primitive +import Data.Char qualified as Char +import Data.Kind (Constraint) import Data.Primitive (sizeOf) +import Data.Primitive.ByteArray qualified as BA import Data.Word import GHC.Exts as L (IsList (..)) import Unison.Prelude import Unison.Reference (Reference) +import Unison.Runtime.ANF (PackedTag) import Unison.Runtime.Array import Unison.Runtime.Foreign import Unison.Runtime.MCode @@ -108,6 +142,49 @@ import Unison.Type qualified as Ty import Unison.Util.EnumContainers as EC 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 +unboxedSentinel = -99 + +boxedSentinel :: Closure +boxedSentinel = (Closure GUnboxedSentinel) + +assertBumped :: HasCallStack => Stack -> Off -> IO () +assertBumped (Stack _ _ sp ustk bstk) i = do + u <- readByteArray ustk (sp - i) + b :: BVal <- readArray bstk (sp - i) + when (u /= unboxedSentinel || not (isBoxedSentinel b)) do + error $ "Expected stack slot to have been bumped, but it was:" <> show (Val u b) + where + isBoxedSentinel :: Closure -> Bool + isBoxedSentinel (Closure GUnboxedSentinel) = True + isBoxedSentinel _ = False + +assertUnboxed :: HasCallStack => Stack -> Off -> IO () +assertUnboxed (Stack _ _ sp ustk bstk) i = do + (u :: Int) <- readByteArray ustk (sp - i) + b <- readArray bstk (sp - i) + case b of + UnboxedTypeTag _ -> pure () + _ -> error $ "Expected stack val to be unboxed, but it was:" <> show (Val u b) + +pokeSentinelOff :: Stack -> Off -> IO () +pokeSentinelOff (Stack _ _ sp ustk bstk) off = do + writeByteArray ustk (sp - off) unboxedSentinel + writeArray bstk (sp - off) boxedSentinel +#else +-- Don't track callstacks in production, it's expensive +type DebugCallStack = (() :: Constraint) +#endif +{- ORMOLU_ENABLE -} + newtype Callback = Hook (Stack -> IO ()) instance Eq Callback where _ == _ = True @@ -123,7 +200,7 @@ data K Mark !Int -- pending args !(EnumSet Word64) - !(EnumMap Word64 Closure) + !(EnumMap Word64 Val) !K | -- save information about a frame for later resumption Push @@ -131,94 +208,114 @@ data K !Int -- pending args !CombIx -- resumption section reference !Int -- stack guard - !(RSection Closure) -- resumption section + !(RSection Val) -- resumption section !K -instance Eq K where - KE == KE = True - (CB cb) == (CB cb') = cb == cb' - (Mark a ps m k) == (Mark a' ps' m' k') = - a == a' && ps == ps' && m == m' && k == k' - (Push f a ci _ _sect k) == (Push f' a' ci' _ _sect' k') = - f == f' && a == a' && ci == ci' && k == k' - _ == _ = False - -instance Ord K where - compare KE KE = EQ - compare (CB cb) (CB cb') = compare cb cb' - compare (Mark a ps m k) (Mark a' ps' m' k') = - compare (a, ps, m, k) (a', ps', m', k') - compare (Push f a ci _ _sect k) (Push f' a' ci' _ _sect' k') = - compare (f, a, ci, k) (f', a', ci', k') - compare KE _ = LT - compare _ KE = GT - compare (CB {}) _ = LT - compare _ (CB {}) = GT - compare (Mark {}) _ = LT - compare _ (Mark {}) = GT - -newtype Closure = Closure {unClosure :: (GClosure (RComb Closure))} - deriving stock (Show, Eq, Ord) +newtype Closure = Closure {unClosure :: (GClosure (RComb Val))} + deriving stock (Show) + +-- | Implementation for Unison sequences. +type USeq = Seq Val type IxClosure = GClosure CombIx +-- Don't re-order these, the ord instance affects Universal.compare +data UnboxedTypeTag + = CharTag + | FloatTag + | IntTag + | NatTag + deriving stock (Show, Eq, Ord) + +unboxedTypeTagToInt :: UnboxedTypeTag -> Int +unboxedTypeTagToInt = \case + CharTag -> 0 + FloatTag -> 1 + IntTag -> 2 + NatTag -> 3 + +unboxedTypeTagFromInt :: (HasCallStack) => Int -> UnboxedTypeTag +unboxedTypeTagFromInt = \case + 0 -> CharTag + 1 -> FloatTag + 2 -> IntTag + 3 -> NatTag + _ -> error "intToUnboxedTypeTag: invalid tag" + +{- ORMOLU_DISABLE -} data GClosure comb = GPAp !CombIx {-# UNPACK #-} !(GCombInfo comb) {-# UNPACK #-} !Seg -- args - | GEnum !Reference !Word64 - | GDataU1 !Reference !Word64 {- <- packed type tag -} !Int - | GDataU2 !Reference !Word64 {- <- packed type tag -} !Int !Int - | GDataB1 !Reference !Word64 {- <- packed type tag -} !(GClosure comb) - | GDataB2 !Reference !Word64 {- <- packed type tag -} !(GClosure comb) !(GClosure comb) - | GDataUB !Reference !Word64 {- <- packed type tag -} !Int !(GClosure comb) - | GDataBU !Reference !Word64 {- <- packed type tag -} !(GClosure comb) !Int - | GDataG !Reference !Word64 {- <- packed type tag -} {-# UNPACK #-} !Seg + | GEnum !Reference !PackedTag + | GData1 !Reference !PackedTag !Val + | GData2 !Reference !PackedTag !Val !Val + | GDataG !Reference !PackedTag {-# UNPACK #-} !Seg | -- code cont, arg size, u/b data stacks GCaptured !K !Int {-# UNPACK #-} !Seg | GForeign !Foreign + | -- The type tag for the value in the corresponding unboxed stack slot. + -- We should consider adding separate constructors for common builtin type tags. + -- GHC will optimize nullary constructors into singletons. + GUnboxedTypeTag !UnboxedTypeTag | GBlackHole +#ifdef STACK_CHECK + | GUnboxedSentinel +#endif deriving stock (Show, Functor, Foldable, Traversable) +{- ORMOLU_ENABLE -} -instance Eq (GClosure comb) where - -- This is safe because the embedded CombIx will break disputes - a == b = (a $> ()) == (b $> ()) - -instance Ord (GClosure comb) where - compare a b = compare (a $> ()) (b $> ()) - +pattern PAp :: CombIx -> GCombInfo (RComb Val) -> Seg -> Closure pattern PAp cix comb seg = Closure (GPAp cix comb seg) +pattern Enum :: Reference -> PackedTag -> Closure pattern Enum r t = Closure (GEnum r t) -pattern DataU1 r t i = Closure (GDataU1 r t i) +pattern Data1 r t i = Closure (GData1 r t i) -pattern DataU2 r t i j = Closure (GDataU2 r t i j) +pattern Data2 r t i j = Closure (GData2 r t i j) -pattern DataB1 r t x <- Closure (GDataB1 r t (Closure -> x)) - where - DataB1 r t x = Closure (GDataB1 r t (unClosure x)) +pattern DataG r t seg = Closure (GDataG r t seg) -pattern DataB2 r t x y <- Closure (GDataB2 r t (Closure -> x) (Closure -> y)) - where - DataB2 r t x y = Closure (GDataB2 r t (unClosure x) (unClosure y)) +pattern Captured k a seg = Closure (GCaptured k a seg) -pattern DataUB r t i y <- Closure (GDataUB r t i (Closure -> y)) - where - DataUB r t i y = Closure (GDataUB r t i (unClosure y)) +pattern Foreign x = Closure (GForeign x) -pattern DataBU r t y i <- Closure (GDataBU r t (Closure -> y) i) +pattern BlackHole = Closure GBlackHole + +pattern UnboxedTypeTag t <- Closure (GUnboxedTypeTag t) where - DataBU r t y i = Closure (GDataBU r t (unClosure y) i) + UnboxedTypeTag t = case t of + CharTag -> charTypeTag + FloatTag -> floatTypeTag + IntTag -> intTypeTag + NatTag -> natTypeTag -pattern DataG r t seg = Closure (GDataG r t seg) +{-# COMPLETE PAp, Enum, Data1, Data2, DataG, Captured, Foreign, UnboxedTypeTag, BlackHole #-} -pattern Captured k a seg = Closure (GCaptured k a seg) +{-# COMPLETE DataC, PAp, Captured, Foreign, BlackHole, UnboxedTypeTag #-} -pattern Foreign x = Closure (GForeign x) +{-# COMPLETE DataC, PApV, Captured, Foreign, BlackHole, UnboxedTypeTag #-} -pattern BlackHole = Closure GBlackHole +{-# COMPLETE DataC, PApV, CapV, Foreign, BlackHole, UnboxedTypeTag #-} + +-- We can avoid allocating a closure for common type tags on each poke by having shared top-level closures for them. +natTypeTag :: Closure +natTypeTag = (Closure (GUnboxedTypeTag NatTag)) +{-# NOINLINE natTypeTag #-} + +intTypeTag :: Closure +intTypeTag = (Closure (GUnboxedTypeTag IntTag)) +{-# NOINLINE intTypeTag #-} + +charTypeTag :: Closure +charTypeTag = (Closure (GUnboxedTypeTag CharTag)) +{-# NOINLINE charTypeTag #-} + +floatTypeTag :: Closure +floatTypeTag = (Closure (GUnboxedTypeTag FloatTag)) +{-# NOINLINE floatTypeTag #-} traceK :: Reference -> K -> [(Reference, Int)] traceK begin = dedup (begin, 1) @@ -229,26 +326,14 @@ traceK begin = dedup (begin, 1) | otherwise = p : dedup (r, 1) k dedup p _ = [p] -splitData :: Closure -> Maybe (Reference, Word64, SegList) +splitData :: Closure -> Maybe (Reference, PackedTag, SegList) splitData = \case (Enum r t) -> Just (r, t, []) - (DataU1 r t i) -> Just (r, t, [Left i]) - (DataU2 r t i j) -> Just (r, t, [Left i, Left j]) - (DataB1 r t x) -> Just (r, t, [Right x]) - (DataB2 r t x y) -> Just (r, t, [Right x, Right y]) - (DataUB r t u b) -> Just (r, t, [Left u, Right b]) - (DataBU r t b u) -> Just (r, t, [Right b, Left u]) + (Data1 r t u) -> Just (r, t, [u]) + (Data2 r t i j) -> Just (r, t, [i, j]) (DataG r t seg) -> Just (r, t, segToList seg) _ -> Nothing --- | Converts an unboxed segment to a list of integers for a more interchangeable --- representation. The segments are stored in backwards order, so this reverses --- the contents. -ints :: ByteArray -> [Int] -ints ba = fmap (indexByteArray ba) [n - 1, n - 2 .. 0] - where - n = sizeofByteArray ba `div` intSize - -- | Converts a list of integers representing an unboxed segment back into the -- appropriate segment. Segments are stored backwards in the runtime, so this -- reverses the list. @@ -266,14 +351,10 @@ bsegToList = reverse . L.toList bseg :: [Closure] -> BSeg bseg = L.fromList . reverse -formData :: Reference -> Word64 -> SegList -> Closure +formData :: Reference -> PackedTag -> SegList -> Closure formData r t [] = Enum r t -formData r t [Left i] = DataU1 r t i -formData r t [Left i, Left j] = DataU2 r t i j -formData r t [Right x] = DataB1 r t x -formData r t [Right x, Right y] = DataB2 r t x y -formData r t [Left u, Right b] = DataUB r t u b -formData r t [Right b, Left u] = DataBU r t b u +formData r t [v1] = Data1 r t v1 +formData r t [v1, v2] = Data2 r t v1 v2 formData r t segList = DataG r t (segFromList segList) frameDataSize :: K -> Int @@ -285,15 +366,63 @@ frameDataSize = go 0 go sz (Push f a _ _ _ k) = go (sz + f + a) k -pattern DataC :: Reference -> Word64 -> SegList -> Closure +pattern DataC :: Reference -> PackedTag -> SegList -> Closure pattern DataC rf ct segs <- (splitData -> Just (rf, ct, segs)) where DataC rf ct segs = formData rf ct segs -type SegList = [Either Int Closure] +matchCharVal :: Val -> Maybe Char +matchCharVal = \case + (UnboxedVal u CharTag) -> Just (Char.chr u) + _ -> Nothing + +pattern CharVal :: Char -> Val +pattern CharVal c <- (matchCharVal -> Just c) + where + CharVal c = Val (Char.ord c) charTypeTag + +matchNatVal :: Val -> Maybe Word64 +matchNatVal = \case + (UnboxedVal u NatTag) -> Just (fromIntegral u) + _ -> Nothing + +pattern NatVal :: Word64 -> Val +pattern NatVal n <- (matchNatVal -> Just n) + where + NatVal n = Val (fromIntegral n) natTypeTag + +matchDoubleVal :: Val -> Maybe Double +matchDoubleVal = \case + (UnboxedVal u FloatTag) -> Just (intToDouble u) + _ -> Nothing + +pattern DoubleVal :: Double -> Val +pattern DoubleVal d <- (matchDoubleVal -> Just d) + where + DoubleVal d = Val (doubleToInt d) floatTypeTag + +matchIntVal :: Val -> Maybe Int +matchIntVal = \case + (UnboxedVal u IntTag) -> Just u + _ -> Nothing + +pattern IntVal :: Int -> Val +pattern IntVal i <- (matchIntVal -> Just i) + where + IntVal i = Val i intTypeTag + +doubleToInt :: Double -> Int +doubleToInt d = indexByteArray (BA.byteArrayFromList [d]) 0 +{-# INLINE doubleToInt #-} -pattern PApV :: CombIx -> RCombInfo Closure -> SegList -> Closure +intToDouble :: Int -> Double +intToDouble w = indexByteArray (BA.byteArrayFromList [w]) 0 +{-# INLINE intToDouble #-} + +type SegList = [Val] + +pattern PApV :: CombIx -> RCombInfo Val -> SegList -> Closure pattern PApV cix rcomb segs <- PAp cix rcomb (segToList -> segs) where @@ -308,31 +437,25 @@ pattern CapV k a segs <- Captured k a (segToList -> segs) -- so this reverses the contents segToList :: Seg -> SegList segToList (u, b) = - zipWith combine (ints u) (bsegToList b) + zipWith Val (ints u) (bsegToList b) + +-- | Converts an unboxed segment to a list of integers for a more interchangeable +-- representation. The segments are stored in backwards order, so this reverses +-- the contents. +ints :: ByteArray -> [Int] +ints ba = fmap (indexByteArray ba) [n - 1, n - 2 .. 0] where - combine i c = case c of - BlackHole -> Left i - _ -> Right c + n = sizeofByteArray ba `div` 8 -- | Converts from the list representation of a segment to the efficient stack form. Segments are stored backwards, -- so this reverses the contents. segFromList :: SegList -> Seg -segFromList xs = (useg u, bseg b) - where - u = - xs <&> \case - Left i -> i - Right _ -> 0 - b = - xs <&> \case - Left _ -> BlackHole - Right c -> c - -{-# COMPLETE DataC, PAp, Captured, Foreign, BlackHole #-} - -{-# COMPLETE DataC, PApV, Captured, Foreign, BlackHole #-} - -{-# COMPLETE DataC, PApV, CapV, Foreign, BlackHole #-} +segFromList xs = + xs + & foldMap + ( \(Val unboxed boxed) -> ([unboxed], [boxed]) + ) + & \(us, bs) -> (useg us, bseg bs) marshalToForeign :: (HasCallStack) => Closure -> Foreign marshalToForeign (Foreign x) = x @@ -397,7 +520,7 @@ uargOnto stk sp cop cp0 (ArgN v) = do loop $ i - 1 loop $ sz - 1 when overwrite $ - copyMutableByteArray cop (bytes $ cp + 1) buf 0 (bytes sz) + copyMutableByteArray cop (bytes $ cp0 + 1) buf 0 (bytes sz) pure cp where cp = cp0 + sz @@ -478,16 +601,44 @@ instance Show Stack where show (Stack ap fp sp _ _) = "Stack " ++ show ap ++ " " ++ show fp ++ " " ++ show sp -type UElem = Int +type UVal = Int + +-- | A runtime value, which is either a boxed or unboxed value, but we may not know which. +data Val = Val {getUnboxedVal :: !UVal, getBoxedVal :: !BVal} + -- The Eq instance for Val is deliberately omitted because you need to take into account the fact that if a Val is boxed, the + -- unboxed side is garbage and should not be compared. + -- See universalEq. + deriving (Show) + +-- | A nulled out value you can use when filling empty arrays, etc. +emptyVal :: Val +emptyVal = Val (-1) BlackHole + +pattern UnboxedVal :: Int -> UnboxedTypeTag -> Val +pattern UnboxedVal v t = (Val v (UnboxedTypeTag t)) + +valToBoxed :: Val -> Maybe Closure +valToBoxed UnboxedVal {} = Nothing +valToBoxed (Val _ b) = Just b + +-- | Matches a Val which is known to be boxed, and returns the closure portion. +pattern BoxedVal :: Closure -> Val +pattern BoxedVal b <- (valToBoxed -> Just b) + where + BoxedVal b = Val (-1) b + +{-# COMPLETE UnboxedVal, BoxedVal #-} + +-- | Lift a boxed val into an Val +boxedVal :: BVal -> Val +boxedVal = Val 0 type USeg = ByteArray -type BElem = Closure +type BVal = Closure type BSeg = Array Closure -type Elem = (UElem, BElem) - type Seg = (USeg, BSeg) alloc :: IO Stack @@ -497,59 +648,139 @@ alloc = do pure $ Stack {ap = -1, fp = -1, sp = -1, ustk, bstk} {-# INLINE alloc #-} -peek :: Stack -> IO Elem -peek stk = do - u <- upeek stk +{- ORMOLU_DISABLE -} +peek :: DebugCallStack => Stack -> IO Val +peek stk@(Stack _ _ sp ustk _) = do + -- Can't use upeek here because in stack-check mode it will assert that the stack slot is unboxed. + u <- readByteArray ustk sp b <- bpeek stk - pure (u, b) + pure (Val u b) {-# INLINE peek #-} -bpeek :: Stack -> IO BElem +peekI :: DebugCallStack => Stack -> IO Int +peekI _stk@(Stack _ _ sp ustk _) = do +#ifdef STACK_CHECK + assertUnboxed _stk 0 +#endif + readByteArray ustk sp +{-# INLINE peekI #-} + +peekOffI :: DebugCallStack => Stack -> Off -> IO Int +peekOffI _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + readByteArray ustk (sp - i) +{-# INLINE peekOffI #-} + +bpeek :: DebugCallStack => Stack -> IO BVal bpeek (Stack _ _ sp _ bstk) = readArray bstk sp {-# INLINE bpeek #-} -upeek :: Stack -> IO UElem -upeek (Stack _ _ sp ustk _) = readByteArray ustk sp +upeek :: DebugCallStack => Stack -> IO UVal +upeek _stk@(Stack _ _ sp ustk _) = do +#ifdef STACK_CHECK + assertUnboxed _stk 0 +#endif + readByteArray ustk sp {-# INLINE upeek #-} -peekOff :: Stack -> Off -> IO Elem -peekOff stk i = do - u <- upeekOff stk i +peekOff :: DebugCallStack => Stack -> Off -> IO Val +peekOff stk@(Stack _ _ sp ustk _) i = do + -- Can't use upeekOff here because in stack-check mode it will assert that the stack slot is unboxed. + u <- readByteArray ustk (sp - i) b <- bpeekOff stk i - pure (u, b) + pure $ Val u b {-# INLINE peekOff #-} -bpeekOff :: Stack -> Off -> IO BElem +bpeekOff :: DebugCallStack => Stack -> Off -> IO BVal bpeekOff (Stack _ _ sp _ bstk) i = readArray bstk (sp - i) {-# INLINE bpeekOff #-} -upeekOff :: Stack -> Off -> IO UElem -upeekOff (Stack _ _ sp ustk _) i = readByteArray ustk (sp - i) +upeekOff :: DebugCallStack => Stack -> Off -> IO UVal +upeekOff _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + readByteArray ustk (sp - i) {-# INLINE upeekOff #-} --- | Store an unboxed value and null out the boxed stack at that location, both so we know there's no value there, --- and so garbage collection can clean up any value that was referenced there. -upoke :: Stack -> UElem -> IO () -upoke stk@(Stack _ _ sp ustk _) u = do - bpoke stk BlackHole +upokeT :: DebugCallStack => Stack -> UVal -> BVal -> IO () +upokeT !stk@(Stack _ _ sp ustk _) !u !t = do + bpoke stk t writeByteArray ustk sp u -{-# INLINE upoke #-} +{-# INLINE upokeT #-} + +poke :: DebugCallStack => Stack -> Val -> IO () +poke _stk@(Stack _ _ sp ustk bstk) (Val u b) = do +#ifdef STACK_CHECK + assertBumped _stk 0 +#endif + writeByteArray ustk sp u + writeArray bstk sp b +{-# INLINE poke #-} + +-- | Sometimes we get back an int from a foreign call which we want to use as a Nat. +-- If we know it's positive and smaller than 2^63 then we can safely store the Int directly as a Nat without +-- checks. +unsafePokeIasN :: DebugCallStack => Stack -> Int -> IO () +unsafePokeIasN stk n = do + upokeT stk n natTypeTag +{-# INLINE unsafePokeIasN #-} + +-- | Store an unboxed tag to later match on. +-- Often used to indicate the constructor of a data type that's been unpacked onto the stack, +-- or some tag we're about to branch on. +pokeTag :: DebugCallStack => Stack -> Int -> IO () +pokeTag = + -- For now we just use ints, but maybe should have a separate type for tags so we can detect if we're leaking them. + pokeI +{-# INLINE pokeTag #-} + +peekTag :: DebugCallStack => Stack -> IO Int +peekTag = peekI +{-# INLINE peekTag #-} + +peekTagOff :: DebugCallStack => Stack -> Off -> IO Int +peekTagOff = peekOffI +{-# INLINE peekTagOff #-} + +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 +{-# INLINE pokeBool #-} -- | Store a boxed value. -- We don't bother nulling out the unboxed stack, -- it's extra work and there's nothing to garbage collect. -bpoke :: Stack -> BElem -> IO () -bpoke (Stack _ _ sp _ bstk) b = writeArray bstk sp b +bpoke :: DebugCallStack => Stack -> BVal -> IO () +bpoke _stk@(Stack _ _ sp _ bstk) b = do +#ifdef STACK_CHECK + assertBumped _stk 0 +#endif + writeArray bstk sp b {-# INLINE bpoke #-} -upokeOff :: Stack -> Off -> UElem -> IO () -upokeOff stk i u = do - bpokeOff stk i BlackHole +pokeOff :: DebugCallStack => Stack -> Off -> Val -> IO () +pokeOff stk i (Val u t) = do + bpokeOff stk i t writeByteArray (ustk stk) (sp stk - i) u -{-# INLINE upokeOff #-} +{-# INLINE pokeOff #-} -bpokeOff :: Stack -> Off -> BElem -> IO () -bpokeOff (Stack _ _ sp _ bstk) i b = writeArray bstk (sp - i) b +upokeOffT :: DebugCallStack => Stack -> Off -> UVal -> BVal -> IO () +upokeOffT stk i u t = do + bpokeOff stk i t + writeByteArray (ustk stk) (sp stk - i) u +{-# INLINE upokeOffT #-} + +bpokeOff :: DebugCallStack => Stack -> Off -> BVal -> IO () +bpokeOff _stk@(Stack _ _ sp _ bstk) i b = do +#ifdef STACK_CHECK + assertBumped _stk i +#endif + writeArray bstk (sp - i) b {-# INLINE bpokeOff #-} -- | Eats up arguments @@ -598,11 +829,22 @@ ensure stk@(Stack ap fp sp ustk bstk) sze {-# INLINE ensure #-} bump :: Stack -> IO Stack -bump (Stack ap fp sp ustk bstk) = pure $ Stack ap fp (sp + 1) ustk bstk +bump (Stack ap fp sp ustk bstk) = do + let stk' = Stack ap fp (sp + 1) ustk bstk +#ifdef STACK_CHECK + pokeSentinelOff stk' 0 +#endif + pure stk' {-# INLINE bump #-} bumpn :: Stack -> SZ -> IO Stack -bumpn (Stack ap fp sp ustk bstk) n = pure $ Stack ap fp (sp + n) ustk bstk +bumpn (Stack ap fp sp ustk bstk) n = do + let stk' = Stack ap fp (sp + n) ustk bstk +#ifdef STACK_CHECK + for_ [0..n-1] $ \i -> + pokeSentinelOff stk' i +#endif + pure stk' {-# INLINE bumpn #-} duplicate :: Stack -> IO Stack @@ -734,45 +976,106 @@ asize (Stack ap fp _ _ _) = fp - ap {-# INLINE asize #-} peekN :: Stack -> IO Word64 -peekN (Stack _ _ sp ustk _) = readByteArray ustk sp +peekN _stk@(Stack _ _ sp ustk _) = do +#ifdef STACK_CHECK + assertUnboxed _stk 0 +#endif + readByteArray ustk sp {-# INLINE peekN #-} peekD :: Stack -> IO Double -peekD (Stack _ _ sp ustk _) = readByteArray ustk sp +peekD _stk@(Stack _ _ sp ustk _) = do +#ifdef STACK_CHECK + assertUnboxed _stk 0 +#endif + readByteArray ustk sp {-# INLINE peekD #-} +peekC :: Stack -> IO Char +peekC stk = do + Char.chr <$> peekI stk +{-# INLINE peekC #-} + peekOffN :: Stack -> Int -> IO Word64 -peekOffN (Stack _ _ sp ustk _) i = readByteArray ustk (sp - i) +peekOffN _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + readByteArray ustk (sp - i) {-# INLINE peekOffN #-} peekOffD :: Stack -> Int -> IO Double -peekOffD (Stack _ _ sp ustk _) i = readByteArray ustk (sp - i) +peekOffD _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + readByteArray ustk (sp - i) {-# INLINE peekOffD #-} +peekOffC :: Stack -> Int -> IO Char +peekOffC _stk@(Stack _ _ sp ustk _) i = do +#ifdef STACK_CHECK + assertUnboxed _stk i +#endif + Char.chr <$> readByteArray ustk (sp - i) +{-# INLINE peekOffC #-} + +{- ORMOLU_ENABLE -} + pokeN :: Stack -> Word64 -> IO () pokeN stk@(Stack _ _ sp ustk _) n = do - bpoke stk BlackHole + bpoke stk natTypeTag writeByteArray ustk sp n {-# INLINE pokeN #-} pokeD :: Stack -> Double -> IO () pokeD stk@(Stack _ _ sp ustk _) d = do - bpoke stk BlackHole + bpoke stk floatTypeTag writeByteArray ustk sp d {-# INLINE pokeD #-} +pokeC :: Stack -> Char -> IO () +pokeC stk@(Stack _ _ sp ustk _) c = do + bpoke stk charTypeTag + writeByteArray ustk sp (Char.ord c) +{-# INLINE pokeC #-} + +-- | Note: This is for poking an unboxed value that has the UNISON type 'int', not just any unboxed data. +pokeI :: Stack -> Int -> IO () +pokeI stk@(Stack _ _ sp ustk _) i = do + bpoke stk intTypeTag + writeByteArray ustk sp i +{-# INLINE pokeI #-} + +pokeByte :: Stack -> Word8 -> IO () +pokeByte stk b = do + -- NOTE: currently we just store bytes as Word64s, but we should have a separate type runtime type tag for them. + pokeN stk (fromIntegral b) +{-# INLINE pokeByte #-} + pokeOffN :: Stack -> Int -> Word64 -> IO () pokeOffN stk@(Stack _ _ sp ustk _) i n = do - bpokeOff stk i BlackHole + bpokeOff stk i natTypeTag writeByteArray ustk (sp - i) n {-# INLINE pokeOffN #-} pokeOffD :: Stack -> Int -> Double -> IO () pokeOffD stk@(Stack _ _ sp ustk _) i d = do - bpokeOff stk i BlackHole + bpokeOff stk i floatTypeTag writeByteArray ustk (sp - i) d {-# INLINE pokeOffD #-} +pokeOffI :: Stack -> Int -> Int -> IO () +pokeOffI stk@(Stack _ _ sp ustk _) i n = do + bpokeOff stk i intTypeTag + writeByteArray ustk (sp - i) n +{-# INLINE pokeOffI #-} + +pokeOffC :: Stack -> Int -> Char -> IO () +pokeOffC stk i c = do + upokeOffT stk i (Char.ord c) charTypeTag +{-# INLINE pokeOffC #-} + pokeBi :: (BuiltinForeign b) => Stack -> b -> IO () pokeBi stk x = bpoke stk (Foreign $ wrapBuiltin x) {-# INLINE pokeBi #-} @@ -789,16 +1092,16 @@ peekOffBi :: (BuiltinForeign b) => Stack -> Int -> IO b peekOffBi stk i = unwrapForeign . marshalToForeign <$> bpeekOff stk i {-# INLINE peekOffBi #-} -peekOffS :: Stack -> Int -> IO (Seq Closure) +peekOffS :: Stack -> Int -> IO USeq peekOffS stk i = unwrapForeign . marshalToForeign <$> bpeekOff stk i {-# INLINE peekOffS #-} -pokeS :: Stack -> Seq Closure -> IO () +pokeS :: Stack -> USeq -> IO () pokeS stk s = bpoke stk (Foreign $ Wrap Ty.listRef s) {-# INLINE pokeS #-} -pokeOffS :: Stack -> Int -> Seq Closure -> IO () +pokeOffS :: Stack -> Int -> USeq -> IO () pokeOffS stk i s = bpokeOff stk i (Foreign $ Wrap Ty.listRef s) {-# INLINE pokeOffS #-} @@ -849,21 +1152,24 @@ closureTermRefs :: (Monoid m) => (Reference -> m) -> (Closure -> m) closureTermRefs f = \case PAp (CIx r _ _) _ (_useg, bseg) -> f r <> foldMap (closureTermRefs f) bseg - (DataB1 _ _ c) -> closureTermRefs f c - (DataB2 _ _ c1 c2) -> - closureTermRefs f c1 <> closureTermRefs f c2 - (DataUB _ _ _ c) -> - closureTermRefs f c + (DataC _ _ vs) -> + vs & foldMap \case + BoxedVal c -> closureTermRefs f c + UnboxedVal {} -> mempty (Captured k _ (_useg, bseg)) -> contTermRefs f k <> foldMap (closureTermRefs f) bseg (Foreign fo) - | Just (cs :: Seq Closure) <- maybeUnwrapForeign Ty.listRef fo -> - foldMap (closureTermRefs f) cs + | Just (cs :: USeq) <- maybeUnwrapForeign Ty.listRef fo -> + foldMap (\(Val _i clos) -> closureTermRefs f clos) cs _ -> mempty contTermRefs :: (Monoid m) => (Reference -> m) -> K -> m contTermRefs f (Mark _ _ m k) = - foldMap (closureTermRefs f) m <> contTermRefs f k + ( m & foldMap \case + BoxedVal clo -> closureTermRefs f clo + _ -> mempty + ) + <> contTermRefs f k contTermRefs f (Push _ _ (CIx r _ _) _ _ k) = f r <> contTermRefs f k contTermRefs _ _ = mempty diff --git a/unison-runtime/src/Unison/Runtime/TypeTags.hs b/unison-runtime/src/Unison/Runtime/TypeTags.hs new file mode 100644 index 0000000000..8bccb00f81 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/TypeTags.hs @@ -0,0 +1,144 @@ +module Unison.Runtime.TypeTags + ( Tag (..), + RTag (..), + CTag (..), + PackedTag (..), + packTags, + unpackTags, + maskTags, + floatTag, + natTag, + intTag, + charTag, + unitTag, + leftTag, + rightTag, + ) +where + +import Control.Exception (throw) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.List hiding (and, or) +import Data.Map qualified as Map +import GHC.Stack (CallStack, callStack) +import U.Codebase.Reference (Reference) +import Unison.Builtin.Decls qualified as Ty +import Unison.Prelude +import Unison.Runtime.Builtin.Types (builtinTypeNumbering) +import Unison.Type qualified as Ty +import Unison.Util.EnumContainers as EC +import Unison.Util.Pretty qualified as Pretty +import Prelude hiding (abs, and, or, seq) +import Prelude qualified + +-- For internal errors +data CompileExn = CE CallStack (Pretty.Pretty Pretty.ColorText) + deriving (Show) + +instance Exception CompileExn + +internalBug :: (HasCallStack) => String -> a +internalBug = throw . CE callStack . Pretty.lit . fromString + +-- Types representing components that will go into the runtime tag of +-- a data type value. RTags correspond to references, while CTags +-- correspond to constructors. +newtype RTag = RTag Word64 + deriving stock (Eq, Ord, Show, Read) + deriving newtype (EC.EnumKey) + +newtype CTag = CTag Word16 + deriving stock (Eq, Ord, Show, Read) + deriving newtype (EC.EnumKey) + +-- | A combined tag, which is a packed representation of an RTag and a CTag +newtype PackedTag = PackedTag Word64 + deriving stock (Eq, Ord, Show, Read) + deriving newtype (EC.EnumKey) + +class Tag t where rawTag :: t -> Word64 + +instance Tag RTag where rawTag (RTag w) = w + +instance Tag CTag where rawTag (CTag w) = fromIntegral w + +packTags :: RTag -> CTag -> PackedTag +packTags (RTag rt) (CTag ct) = PackedTag (ri .|. ci) + where + ri = rt `shiftL` 16 + ci = fromIntegral ct + +unpackTags :: PackedTag -> (RTag, CTag) +unpackTags (PackedTag w) = (RTag $ w `shiftR` 16, CTag . fromIntegral $ w .&. 0xFFFF) + +-- Masks a packed tag to extract just the constructor tag portion +maskTags :: PackedTag -> Word64 +maskTags (PackedTag w) = (w .&. 0xFFFF) + +ensureRTag :: (Ord n, Show n, Num n) => String -> n -> r -> r +ensureRTag s n x + | n > 0xFFFFFFFFFFFF = + internalBug $ s ++ "@RTag: too large: " ++ show n + | otherwise = x + +ensureCTag :: (Ord n, Show n, Num n) => String -> n -> r -> r +ensureCTag s n x + | n > 0xFFFF = + internalBug $ s ++ "@CTag: too large: " ++ show n + | otherwise = x + +instance Enum RTag where + toEnum i = ensureRTag "toEnum" i . RTag $ toEnum i + fromEnum (RTag w) = fromEnum w + +instance Enum CTag where + toEnum i = ensureCTag "toEnum" i . CTag $ toEnum i + fromEnum (CTag w) = fromEnum w + +instance Num RTag where + fromInteger i = ensureRTag "fromInteger" i . RTag $ fromInteger i + (+) = internalBug "RTag: +" + (*) = internalBug "RTag: *" + abs = internalBug "RTag: abs" + signum = internalBug "RTag: signum" + negate = internalBug "RTag: negate" + +instance Num CTag where + fromInteger i = ensureCTag "fromInteger" i . CTag $ fromInteger i + (+) = internalBug "CTag: +" + (*) = internalBug "CTag: *" + abs = internalBug "CTag: abs" + signum = internalBug "CTag: signum" + negate = internalBug "CTag: negate" + +floatTag :: PackedTag +floatTag = mkSimpleTag "floatTag" Ty.floatRef + +natTag :: PackedTag +natTag = mkSimpleTag "natTag" Ty.natRef + +intTag :: PackedTag +intTag = mkSimpleTag "intTag" Ty.intRef + +charTag :: PackedTag +charTag = mkSimpleTag "charTag" Ty.charRef + +unitTag :: PackedTag +unitTag = mkSimpleTag "unitTag" Ty.unitRef + +leftTag, rightTag :: PackedTag +(leftTag, rightTag) + | Just n <- Map.lookup Ty.eitherRef builtinTypeNumbering, + et <- toEnum (fromIntegral n), + lt <- toEnum (fromIntegral Ty.eitherLeftId), + rt <- toEnum (fromIntegral Ty.eitherRightId) = + (packTags et lt, packTags et rt) + | otherwise = error "internal error: either tags" + +-- | Construct a tag for a single-constructor builtin type +mkSimpleTag :: String -> Reference -> PackedTag +mkSimpleTag msg r + | Just n <- Map.lookup r builtinTypeNumbering, + rt <- toEnum (fromIntegral n) = + packTags rt 0 + | otherwise = internalBug $ "internal error: " <> msg diff --git a/unison-runtime/tests/Unison/Test/Runtime/ANF/Serialization.hs b/unison-runtime/tests/Unison/Test/Runtime/ANF/Serialization.hs index 1d6f9dc554..92b206ea56 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/ANF/Serialization.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/ANF/Serialization.hs @@ -40,16 +40,8 @@ genUBytes = Util.Bytes.fromByteString <$> Gen.bytes (Range.linear 0 4) genGroupRef :: Gen GroupRef genGroupRef = GR <$> genReference <*> genSmallWord64 -genUBValue :: Gen UBValue -genUBValue = - Gen.choice - [ -- Unboxed values are no longer valid in ANF serialization. - -- Left <$> genSmallWord64, - Right <$> genValue - ] - genValList :: Gen ValList -genValList = Gen.list (Range.linear 0 4) genUBValue +genValList = Gen.list (Range.linear 0 4) genValue genCont :: Gen Cont genCont = do diff --git a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs index ef05644c22..18e4529001 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs @@ -16,6 +16,7 @@ import Unison.Prelude import Unison.Runtime.Interface import Unison.Runtime.MCode (Args (..), BPrim1, BPrim2, Branch, Comb, CombIx (..), GBranch (..), GComb (..), GCombInfo (..), GInstr (..), GRef (..), GSection (..), Instr, MLit (..), Ref, Section, UPrim1, UPrim2) import Unison.Runtime.Machine (Combs) +import Unison.Runtime.TypeTags (PackedTag(..)) import Unison.Test.Gen import Unison.Util.EnumContainers (EnumMap, EnumSet) import Unison.Util.EnumContainers qualified as EC @@ -105,6 +106,9 @@ genMLit = MY <$> genReference ] +genPackedTag :: Gen PackedTag +genPackedTag = PackedTag <$> genSmallWord64 + genInstr :: Gen Instr genInstr = Gen.choice @@ -117,9 +121,8 @@ genInstr = Capture <$> genSmallWord64, Name <$> genGRef <*> genArgs, Info <$> Gen.string (Range.linear 0 10) Gen.alphaNum, - Pack <$> genReference <*> genSmallWord64 <*> genArgs, + Pack <$> genReference <*> genPackedTag <*> genArgs, Lit <$> genMLit, - BLit <$> genReference <*> genSmallWord64 <*> genMLit, Print <$> genSmallInt, Reset <$> genEnumSet genSmallWord64, Fork <$> genSmallInt, diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index 44145a2a88..cc6e59bc6a 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -21,6 +21,10 @@ flag arraychecks manual: True default: False +flag stackchecks + manual: True + default: False + library exposed-modules: Unison.Codebase.Execute @@ -45,6 +49,7 @@ library Unison.Runtime.Serialize Unison.Runtime.SparseVector Unison.Runtime.Stack + Unison.Runtime.TypeTags Unison.Runtime.Vector hs-source-dirs: src @@ -135,6 +140,8 @@ library default-language: Haskell2010 if flag(arraychecks) cpp-options: -DARRAY_CHECK + if flag(stackchecks) + cpp-options: -DSTACK_CHECK test-suite runtime-tests type: exitcode-stdio-1.0 @@ -212,3 +219,5 @@ test-suite runtime-tests default-language: Haskell2010 if flag(arraychecks) cpp-options: -DARRAY_CHECK + if flag(stackchecks) + cpp-options: -DSTACK_CHECK diff --git a/unison-src/transcripts/runtime-tests.md b/unison-src/transcripts/runtime-tests.md new file mode 100644 index 0000000000..0691e7ce21 --- /dev/null +++ b/unison-src/transcripts/runtime-tests.md @@ -0,0 +1,71 @@ +# An assortment of regression tests that exercise various interesting cases within the runtime. + +```ucm:hide +scratch/main> builtins.merge lib.builtins +``` + + +```unison +negativeCaseMatch = match -10 with + +1 -> "bad" + -10 -> "good" + +3 -> "bad" + _ -> "bad" +> negativeCaseMatch + +funcWithMoreThanTwoUnboxedArgs : Nat -> Nat -> Nat -> Nat +funcWithMoreThanTwoUnboxedArgs x y z = + x + y + z + +> funcWithMoreThanTwoUnboxedArgs 1 2 3 + +funcWithMixedArgTypes : Nat -> Text -> Nat -> Text +funcWithMixedArgTypes x y z = + Nat.toText x ++ y ++ Nat.toText z + +> funcWithMixedArgTypes 1 "hello" 2 + +unboxedAndBoxedArgsInSequences = ([1, 2, 3], ["x", "y", "z"]) +> unboxedAndBoxedArgsInSequences + +casting = (Nat.toInt 100, + Float.toRepresentation 3.14, + Float.fromRepresentation 4614253070214989087, + Int.fromRepresentation 100, + Int.toRepresentation +10, + Int.toRepresentation -10) +> casting + + +> 1 Universal.== Int.toRepresentation +1 +> [1, 2, 3] Universal.== [Int.toRepresentation +1, Int.toRepresentation +2, Int.toRepresentation +3] + +-- Float edge cases +> compare 0.0 0.0 +> compare +0.0 (-0.0) +> compare -0.0 (+0.0) +> compare -1.0 1.0 + +-- Currently, the same NaN's are equal, but different NaN's are not... +> (0.0/0.0) == (0.0/0.0) +> (0.0/0.0) == (1.0/0.0) + +> Universal.compare [] [1] +> Universal.compare [1, 2] [2, 3] +> Universal.compare [2, 3] [1, 2] + +-- Values in 'Any' are compared a bit strangely. +-- Currently we have special-cases to compare the values of Nats and Ints directly, ignoring their type, for better or +-- worse. +-- This helps to counter a different issue we have, where `load (save +10)` will load a `Nat` runtime type rather than +-- an Int, since we don't actually store the type of numerics in the ANF.Value type. +> Universal.compare (Any [1, 2]) (Any [+1, +2]) + +-- Regression test for a problem with universalCompare where Nats larger than maxInt would compare incorrectly, but only +-- when nested within other types due to how lists of constructor fields were compared. +> Universal.compare (1,()) (18446744073709551615, ()) + +-- Types in tuples should compare one by one left-to-right +> Universal.compare (1, "", 2) (1, "", 3) +> Universal.compare (1, "", 3) (1, "", 2) +``` diff --git a/unison-src/transcripts/runtime-tests.output.md b/unison-src/transcripts/runtime-tests.output.md new file mode 100644 index 0000000000..4696419b79 --- /dev/null +++ b/unison-src/transcripts/runtime-tests.output.md @@ -0,0 +1,181 @@ +# An assortment of regression tests that exercise various interesting cases within the runtime. + +``` unison +negativeCaseMatch = match -10 with + +1 -> "bad" + -10 -> "good" + +3 -> "bad" + _ -> "bad" +> negativeCaseMatch + +funcWithMoreThanTwoUnboxedArgs : Nat -> Nat -> Nat -> Nat +funcWithMoreThanTwoUnboxedArgs x y z = + x + y + z + +> funcWithMoreThanTwoUnboxedArgs 1 2 3 + +funcWithMixedArgTypes : Nat -> Text -> Nat -> Text +funcWithMixedArgTypes x y z = + Nat.toText x ++ y ++ Nat.toText z + +> funcWithMixedArgTypes 1 "hello" 2 + +unboxedAndBoxedArgsInSequences = ([1, 2, 3], ["x", "y", "z"]) +> unboxedAndBoxedArgsInSequences + +casting = (Nat.toInt 100, + Float.toRepresentation 3.14, + Float.fromRepresentation 4614253070214989087, + Int.fromRepresentation 100, + Int.toRepresentation +10, + Int.toRepresentation -10) +> casting + + +> 1 Universal.== Int.toRepresentation +1 +> [1, 2, 3] Universal.== [Int.toRepresentation +1, Int.toRepresentation +2, Int.toRepresentation +3] + +-- Float edge cases +> compare 0.0 0.0 +> compare +0.0 (-0.0) +> compare -0.0 (+0.0) +> compare -1.0 1.0 + +-- Currently, the same NaN's are equal, but different NaN's are not... +> (0.0/0.0) == (0.0/0.0) +> (0.0/0.0) == (1.0/0.0) + +> Universal.compare [] [1] +> Universal.compare [1, 2] [2, 3] +> Universal.compare [2, 3] [1, 2] + +-- Values in 'Any' are compared a bit strangely. +-- Currently we have special-cases to compare the values of Nats and Ints directly, ignoring their type, for better or +-- worse. +-- This helps to counter a different issue we have, where `load (save +10)` will load a `Nat` runtime type rather than +-- an Int, since we don't actually store the type of numerics in the ANF.Value type. +> Universal.compare (Any [1, 2]) (Any [+1, +2]) + +-- Regression test for a problem with universalCompare where Nats larger than maxInt would compare incorrectly, but only +-- when nested within other types due to how lists of constructor fields were compared. +> Universal.compare (1,()) (18446744073709551615, ()) + +-- Types in tuples should compare one by one left-to-right +> Universal.compare (1, "", 2) (1, "", 3) +> Universal.compare (1, "", 3) (1, "", 2) +``` + +``` ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + casting : ( Int, + Nat, + Float, + Int, + Nat, + Nat) + funcWithMixedArgTypes : Nat + -> Text + -> Nat + -> Text + funcWithMoreThanTwoUnboxedArgs : Nat -> Nat -> Nat -> Nat + negativeCaseMatch : Text + unboxedAndBoxedArgsInSequences : ([Nat], [Text]) + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 6 | > negativeCaseMatch + ⧩ + "good" + + 12 | > funcWithMoreThanTwoUnboxedArgs 1 2 3 + ⧩ + 6 + + 18 | > funcWithMixedArgTypes 1 "hello" 2 + ⧩ + "1hello2" + + 21 | > unboxedAndBoxedArgsInSequences + ⧩ + ([1, 2, 3], ["x", "y", "z"]) + + 29 | > casting + ⧩ + ( +100 + , 4614253070214989087 + , 3.14 + , +100 + , 10 + , 18446744073709551606 + ) + + 32 | > 1 Universal.== Int.toRepresentation +1 + ⧩ + true + + 33 | > [1, 2, 3] Universal.== [Int.toRepresentation +1, Int.toRepresentation +2, Int.toRepresentation +3] + ⧩ + true + + 36 | > compare 0.0 0.0 + ⧩ + +0 + + 37 | > compare +0.0 (-0.0) + ⧩ + -1 + + 38 | > compare -0.0 (+0.0) + ⧩ + +1 + + 39 | > compare -1.0 1.0 + ⧩ + -1 + + 42 | > (0.0/0.0) == (0.0/0.0) + ⧩ + true + + 43 | > (0.0/0.0) == (1.0/0.0) + ⧩ + false + + 45 | > Universal.compare [] [1] + ⧩ + -1 + + 46 | > Universal.compare [1, 2] [2, 3] + ⧩ + -1 + + 47 | > Universal.compare [2, 3] [1, 2] + ⧩ + +1 + + 54 | > Universal.compare (Any [1, 2]) (Any [+1, +2]) + ⧩ + +0 + + 58 | > Universal.compare (1,()) (18446744073709551615, ()) + ⧩ + -1 + + 61 | > Universal.compare (1, "", 2) (1, "", 3) + ⧩ + -1 + + 62 | > Universal.compare (1, "", 3) (1, "", 2) + ⧩ + +1 + +```