From aeeaa381889e74efef9cfea50153aeb89cb6ed15 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 2 Jan 2025 11:06:24 -0800 Subject: [PATCH] Move all non-prim instructions into Section --- .../src/Unison/Runtime/Interface.hs | 34 +- unison-runtime/src/Unison/Runtime/MCode.hs | 307 ++++++++++++------ .../src/Unison/Runtime/MCode/Serialize.hs | 154 ++++----- unison-runtime/src/Unison/Runtime/Machine.hs | 160 ++++----- 4 files changed, 385 insertions(+), 270 deletions(-) diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index dfa54e01e4..fbf34b6fad 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -109,7 +109,6 @@ import Unison.Runtime.Exception import Unison.Runtime.MCode ( Args (..), CombIx (..), - GInstr (..), GSection (..), RCombs, RefNums (..), @@ -1063,7 +1062,7 @@ executeMainComb :: CCache -> IO (Either (Pretty ColorText) ()) executeMainComb init cc = do - rSection <- resolveSection cc $ Ins (Pack RF.unitRef (PackedTag 0) ZArgs) $ Call True init init (VArg1 0) + rSection <- resolveSection cc $ Pack RF.unitRef (PackedTag 0) ZArgs $ Call True init init (VArg1 0) result <- UnliftIO.try . eval0 cc Nothing $ rSection case result of @@ -1440,18 +1439,19 @@ buildSCache crsrc cssrc cacheableCombs trsrc ftm fty int rtmsrc rtysrc sndbx = restrictTyR m = Map.restrictKeys m typeRefs standalone :: CCache -> Word64 -> IO StoredCache -standalone cc init = readTVarIO (combRefs cc) >>= \crs -> - case EC.lookup init crs of - Just rinit -> - buildSCache crs - <$> readTVarIO (srcCombs cc) - <*> readTVarIO (cacheableCombs cc) - <*> readTVarIO (tagRefs cc) - <*> readTVarIO (freshTm cc) - <*> readTVarIO (freshTy cc) - <*> (readTVarIO (intermed cc) >>= traceNeeded rinit) - <*> readTVarIO (refTm cc) - <*> readTVarIO (refTy cc) - <*> readTVarIO (sandbox cc) - Nothing -> - die $ "standalone: unknown combinator: " ++ show init +standalone cc init = + readTVarIO (combRefs cc) >>= \crs -> + case EC.lookup init crs of + Just rinit -> + buildSCache crs + <$> readTVarIO (srcCombs cc) + <*> readTVarIO (cacheableCombs cc) + <*> readTVarIO (tagRefs cc) + <*> readTVarIO (freshTm cc) + <*> readTVarIO (freshTy cc) + <*> (readTVarIO (intermed cc) >>= traceNeeded rinit) + <*> readTVarIO (refTm cc) + <*> readTVarIO (refTy cc) + <*> readTVarIO (sandbox cc) + Nothing -> + die $ "standalone: unknown combinator: " ++ show init diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index bc40170db8..c6dcd46494 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -503,50 +503,6 @@ data GInstr comb !BPrim2 !Int !Int - | -- Use a check-and-set ticket to update a reference - -- (ref stack index, ticket stack index, new value stack index) - RefCAS !Int !Int !Int - | -- Call out to a Haskell function. - ForeignCall - !Bool -- catch exceptions - !ForeignFunc -- FFI call - !Args -- arguments - | -- Set the value of a dynamic reference - SetDyn - !Word64 -- the prompt tag of the reference - !Int -- the stack index of the closure to store - | -- Capture the continuation up to a given marker. - Capture !Word64 -- the prompt tag - | -- This is essentially the opposite of `Call`. Pack a given - -- statically known function into a closure with arguments. - -- No stack is necessary, because no nested evaluation happens, - -- so the instruction directly takes a follow-up. - Name !(GRef comb) !Args - | -- Dump some debugging information about the machine state to - -- the screen. - Info !String -- prefix for output - | -- Pack a data type value into a closure and place it - -- on the stack. - Pack - !Reference -- data type reference - !PackedTag -- tag - !Args -- arguments to pack - | -- Push a particular value onto the appropriate stack - Lit !MLit -- value to push onto the stack - | -- Print a value on the unboxed stack - Print !Int -- index of the primitive value to print - | -- Put a delimiter on the continuation - Reset !(EnumSet Word64) -- prompt ids - | -- Fork thread evaluating delayed computation on boxed stack - Fork !Int - | -- Atomic transaction evaluating delayed computation on boxed stack - Atomically !Int - | -- Build a sequence consisting of a variable number of arguments - Seq !Args - | -- Force a delayed expression, catching any runtime exceptions involved - TryForce !Int - | -- Attempted to use a builtin that was not allowed in the current sandboxing context. - SandboxingFailure !Text.Text -- The name of the builtin which failed was sandboxed. deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) type Section = GSection CombIx @@ -620,6 +576,80 @@ data GSection comb !Int -- index of request item on the boxed stack !(GSection comb) -- pure case !(EnumMap Word64 (GBranch comb)) -- effect cases + | -- Embedded instructions + -- Conceptually these belong nested into 'GInstr', but we save a couple pointer jumps by embedding them here instead. + -- Use a check-and-set ticket to update a reference + -- (ref stack index, ticket stack index, new value stack index) + RefCAS + !Int + !Int + !Int + !(GSection comb) -- Next + | -- Call out to a Haskell function. + ForeignCall + !Bool -- catch exceptions + !ForeignFunc -- FFI call + !Args -- arguments + !(GSection comb) -- Next + | -- Set the value of a dynamic reference + SetDyn + !Word64 -- the prompt tag of the reference + !Int -- the stack index of the closure to store + !(GSection comb) -- Next + | -- Capture the continuation up to a given marker. + Capture + !Word64 -- the prompt tag + !(GSection comb) -- Next + | -- This is essentially the opposite of `Call`. Pack a given + -- statically known function into a closure with arguments. + -- No stack is necessary, because no nested evaluation happens, + -- so the instruction directly takes a follow-up. + Name + !(GRef comb) + !Args + !(GSection comb) -- Next + | -- Dump some debugging information about the machine state to + -- the screen. + Info + !String -- prefix for output + !(GSection comb) -- Next + | -- Pack a data type value into a closure and place it + -- on the stack. + Pack + !Reference -- data type reference + !PackedTag -- tag + !Args -- arguments to pack + !(GSection comb) -- Next + | -- Push a particular value onto the appropriate stack + Lit + !MLit -- value to push onto the stack + !(GSection comb) -- Next + | -- Print a value on the unboxed stack + Print + !Int -- index of the primitive value to print + !(GSection comb) -- Next + | -- Put a delimiter on the continuation + Reset + !(EnumSet Word64) -- prompt ids + !(GSection comb) -- Next + | -- Fork thread evaluating delayed computation on boxed stack + Fork + !Int + !(GSection comb) -- Next + | -- Atomic transaction evaluating delayed computation on boxed stack + Atomically + !Int + !(GSection comb) -- Next + | -- Build a sequence consisting of a variable number of arguments + Seq + !Args + !(GSection comb) -- Next + | -- Force a delayed expression, catching any runtime exceptions involved + TryForce + !Int + !(GSection comb) -- Next + | -- Attempted to use a builtin that was not allowed in the current sandboxing context. + SandboxingFailure !Text.Text -- The name of the builtin which failed was sandboxed. deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) data CombIx @@ -985,17 +1015,17 @@ emitSection rns grpr grpn rec ctx (TLets d us ms bu bo) = emitSection rns grpr grpn rec ctx (TName u (Left f) args bo) = emitClosures grpr grpn rec ctx args $ \ctx as -> let cix = (CIx f (cnum rns f) 0) - in Ins (Name (Env cix cix) as) + in (Name (Env cix cix) as) <$> emitSection rns grpr grpn rec (Var u BX ctx) bo emitSection rns grpr grpn rec ctx (TName u (Right v) args bo) | Just (i, BX) <- ctxResolve ctx v = emitClosures grpr grpn rec ctx args $ \ctx as -> - Ins (Name (Stk i) as) + (Name (Stk i) as) <$> emitSection rns grpr grpn rec (Var u BX ctx) bo | Just n <- rctxResolve rec v = emitClosures grpr grpn rec ctx args $ \ctx as -> let cix = (CIx grpr grpn n) - in Ins (Name (Env cix cix) as) + in (Name (Env cix cix) as) <$> emitSection rns grpr grpn rec (Var u BX ctx) bo | otherwise = emitSectionVErr v emitSection _ grpr grpn rec ctx (TVar v) @@ -1009,14 +1039,14 @@ emitSection _ _ grpn _ ctx (TPrm p args) = -- a prim op will need for its results. addCount 3 . countCtx ctx - . Ins (emitPOp p $ emitArgs grpn ctx args) + . (emitPOp p $ emitArgs grpn ctx args) . Yield . VArgV $ countBlock ctx emitSection _ _ grpn _ ctx (TFOp p args) = addCount 3 . countCtx ctx - . Ins (emitFOp p $ emitArgs grpn ctx args) + . (emitFOp p $ emitArgs grpn ctx args) . Yield . VArgV $ countBlock ctx @@ -1024,7 +1054,7 @@ emitSection rns grpr grpn rec ctx (TApp f args) = emitClosures grpr grpn rec ctx args $ \ctx as -> countCtx ctx $ emitFunction rns grpr grpn rec ctx f as emitSection _ _ _ _ ctx (TLit l) = - c . countCtx ctx . Ins (emitLit l) . Yield $ VArg1 0 + c . countCtx ctx . emitLit l . Yield $ VArg1 0 where c | ANF.T {} <- l = addCount 1 @@ -1032,7 +1062,7 @@ emitSection _ _ _ _ ctx (TLit l) = | ANF.LY {} <- l = addCount 1 | otherwise = addCount 1 emitSection _ _ _ _ ctx (TBLit l) = - addCount 1 . countCtx ctx . Ins (emitLit l) . Yield $ VArg1 0 + addCount 1 . countCtx ctx . 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 = @@ -1094,14 +1124,14 @@ emitSection rns grpr grpn rec ctx (TMatch v bs) "emitSection: could not resolve match variable: " ++ show (ctx, v) emitSection rns grpr grpn rec ctx (THnd rs h b) | Just (i, BX) <- ctxResolve ctx h = - Ins (Reset (EC.setFromList ws)) - . flip (foldr (\r -> Ins (SetDyn r i))) ws + Reset (EC.setFromList ws) + . flip (foldr (\r -> SetDyn r i)) ws <$> emitSection rns grpr grpn rec ctx b | otherwise = emitSectionVErr h where ws = dnum rns <$> rs emitSection rns grpr grpn rec ctx (TShift r v e) = - Ins (Capture $ dnum rns r) + Capture (dnum rns r) <$> emitSection rns grpr grpn rec (Var v BX ctx) e emitSection _ _ _ _ ctx (TFrc v) | Just (i, BX) <- ctxResolve ctx v = @@ -1143,7 +1173,7 @@ emitFunction rns _grpr _ _ _ (FComb r) as n = cnum rns r cix = CIx r n 0 emitFunction rns _grpr _ _ _ (FCon r t) as = - Ins (Pack r (packTags rt t) as) + Pack r (packTags rt t) as . Yield $ VArg1 0 where @@ -1152,7 +1182,7 @@ emitFunction rns _grpr _ _ _ (FReq r e) as = -- Currently implementing packed calling convention for abilities -- TODO ct is 16 bits, but a is 48 bits. This will be a problem if we have -- more than 2^16 types. - Ins (Pack r (packTags rt e) as) + Pack r (packTags rt e) as . App True (Dyn a) $ VArg1 0 where @@ -1210,9 +1240,9 @@ emitLet :: Emit Section -> Emit Section emitLet _ _ _ _ _ _ _ (TLit l) = - fmap (Ins $ emitLit l) + fmap (emitLit l) emitLet _ _ _ _ _ _ _ (TBLit l) = - fmap (Ins $ emitLit l) + fmap (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. @@ -1221,11 +1251,11 @@ emitLet _ _ _ _ _ _ _ (TBLit l) = -- where -- n = cnum rns r emitLet rns _ grpn _ _ _ ctx (TApp (FCon r n) args) = - fmap (Ins . Pack r (packTags rt n) $ emitArgs grpn ctx args) + fmap (Pack r (packTags rt n) $ emitArgs grpn ctx args) where rt = toEnum . fromIntegral $ dnum rns r emitLet _ _ grpn _ _ _ ctx (TApp (FPrim p) args) = - fmap (Ins . either emitPOp emitFOp p $ emitArgs grpn ctx args) + fmap (either emitPOp emitFOp p $ emitArgs grpn ctx args) emitLet rns grpr grpn rec d vcs ctx bnd | Direct <- d = internalBug $ "unsupported compound direct let: " ++ show bnd @@ -1242,7 +1272,7 @@ emitLet rns grpr grpn rec d vcs ctx bnd -- Translate from ANF prim ops to machine code operations. The -- machine code operations are divided with respect to more detailed -- information about expected number and types of arguments. -emitPOp :: ANF.POp -> Args -> Instr +emitPOp :: ANF.POp -> Args -> Section -> Section -- Integral emitPOp ANF.ADDI = emitP2 ADDI emitPOp ANF.ADDN = emitP2 ADDN @@ -1420,40 +1450,40 @@ emitPOp ANF.TFRC = \case -- to 'foreing function' calls, but there is a special case for the -- standard handle access function, because it does not yield an -- explicit error. -emitFOp :: ForeignFunc -> Args -> Instr +emitFOp :: ForeignFunc -> Args -> Section -> Section emitFOp fop = ForeignCall True fop -- Helper functions for packing the variable argument representation -- into the indexes stored in prim op instructions -emitP1 :: UPrim1 -> Args -> Instr -emitP1 p (VArg1 i) = UPrim1 p i +emitP1 :: UPrim1 -> Args -> Section -> Section +emitP1 p (VArg1 i) = Ins $ UPrim1 p i emitP1 p a = internalBug $ "wrong number of args for unary unboxed primop: " ++ show (p, a) -emitP2 :: UPrim2 -> Args -> Instr -emitP2 p (VArg2 i j) = UPrim2 p i j +emitP2 :: UPrim2 -> Args -> Section -> Section +emitP2 p (VArg2 i j) = Ins $ UPrim2 p i j emitP2 p a = internalBug $ "wrong number of args for binary unboxed primop: " ++ show (p, a) -emitBP1 :: BPrim1 -> Args -> Instr -emitBP1 p (VArg1 i) = BPrim1 p i +emitBP1 :: BPrim1 -> Args -> Section -> Section +emitBP1 p (VArg1 i) = Ins $ BPrim1 p i emitBP1 p a = internalBug $ "wrong number of args for unary boxed primop: " ++ show (p, a) -emitBP2 :: BPrim2 -> Args -> Instr -emitBP2 p (VArg2 i j) = BPrim2 p i j +emitBP2 :: BPrim2 -> Args -> Section -> Section +emitBP2 p (VArg2 i j) = Ins $ BPrim2 p i j emitBP2 p a = internalBug $ "wrong number of args for binary boxed primop: " ++ show (p, a) -refCAS :: Args -> Instr +refCAS :: Args -> Section -> Section refCAS (VArgN (primArrayToList -> [i, j, k])) = RefCAS i j k refCAS a = internalBug $ @@ -1575,7 +1605,7 @@ 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 :: ANF.Lit -> Section -> Section emitLit = Lit . litToMLit -- Emits some fix-up code for calling functions. Some of the @@ -1602,7 +1632,7 @@ emitClosures grpr grpn rec ctx args k = | Just _ <- ctxResolve ctx a = allocate ctx as k | Just n <- rctxResolve rec a = let cix = (CIx grpr grpn n) - in Ins (Name (Env cix cix) ZArgs) <$> allocate (Var a BX ctx) as k + in Name (Env cix cix) ZArgs <$> allocate (Var a BX ctx) as k | otherwise = internalBug $ "emitClosures: unknown reference: " ++ show a ++ show grpr @@ -1642,9 +1672,8 @@ sectionDeps (DMatch _ _ br) = branchDeps br sectionDeps (RMatch _ pu br) = sectionDeps pu ++ foldMap branchDeps br sectionDeps (NMatch _ _ br) = branchDeps br -sectionDeps (Ins i s) - | Name (Env (CIx _ w _) _) _ <- i = w : sectionDeps s - | otherwise = sectionDeps s +sectionDeps (Name (Env (CIx _ w _) _) _ s) = w : sectionDeps s +sectionDeps (Ins _i s) = sectionDeps s sectionDeps (Let s (CIx _ w _) _ b) = w : sectionDeps s ++ sectionDeps b sectionDeps _ = [] @@ -1657,13 +1686,13 @@ sectionTypes (DMatch _ _ br) = branchTypes br sectionTypes (NMatch _ _ br) = branchTypes br sectionTypes (RMatch _ pu br) = sectionTypes pu ++ foldMap branchTypes br +sectionTypes (Pack _ (PackedTag w) _ next) = [w `shiftR` 16] ++ sectionTypes next +sectionTypes (Reset ws next) = setToList ws ++ sectionTypes next +sectionTypes (Capture w next) = [w] ++ sectionTypes next +sectionTypes (SetDyn w _ next) = [w] ++ sectionTypes next sectionTypes _ = [] instrTypes :: GInstr comb -> [Word64] -instrTypes (Pack _ (PackedTag w) _) = [w `shiftR` 16] -instrTypes (Reset ws) = setToList ws -instrTypes (Capture w) = [w] -instrTypes (SetDyn w _) = [w] instrTypes _ = [] branchDeps :: GBranch comb -> [Word64] @@ -1736,6 +1765,24 @@ prettySection ind sec = Yield as -> showString "Yield " . prettyArgs as Ins i nx -> prettyIns i . showString "\n" . prettySection ind nx + Pack r i as next -> + showString "Pack " + . prettyRef r + . (' ' :) + . shows i + . (' ' :) + . prettyArgs as + . prettySection ind next + Lit l next -> + showString "Lit " + . showsPrec 11 l + . prettySection ind next + Name r as next -> + showString "Name " + . prettyGRef 12 r + . (' ' :) + . prettyArgs as + . prettySection ind next Let s _ _ b -> showString "Let\n" . prettySection (ind + 2) s @@ -1765,6 +1812,72 @@ prettySection ind sec = . shows i . showString " ->\n" . prettyBranches (ind + 1) e + RefCAS a b c nx -> + showString "RefCAS " + . shows a + . showString " " + . shows b + . showString " " + . shows c + . showString "\n" + . prettySection ind nx + ForeignCall b ff args nx -> + showString "ForeignCall " + . shows b + . showString " " + . shows ff + . showString " " + . prettyArgs args + . showString "\n" + . prettySection ind nx + SetDyn a b nx -> + showString "SetDyn " + . shows a + . showString " " + . shows b + . showString "\n" + . prettySection ind nx + Capture a nx -> + showString "Capture " + . shows a + . showString "\n" + . prettySection ind nx + Print a nx -> + showString "Print " + . shows a + . showString "\n" + . prettySection ind nx + Reset ws nx -> + showString "Reset " + . shows ws + . showString "\n" + . prettySection ind nx + Fork a nx -> + showString "Fork " + . shows a + . showString "\n" + . prettySection ind nx + Atomically a nx -> + showString "Atomically " + . shows a + . showString "\n" + . prettySection ind nx + Info s nx -> + showString "Info " + . shows s + . showString "\n" + . prettySection ind nx + Seq a nx -> + showString "Seq " + . shows a + . showString "\n" + . prettySection ind nx + TryForce a nx -> + showString "TryForce " + . shows a + . showString "\n" + . prettySection ind nx + SandboxingFailure s -> showString $ "SandboxingFailure " ++ show s prettyCIx :: CombIx -> ShowS prettyCIx (CIx r _ n) = @@ -1805,20 +1918,6 @@ prettyBranches ind bs = . prettySection (ind + 1) e prettyIns :: (Show comb) => GInstr comb -> ShowS -prettyIns (Pack r i as) = - showString "Pack " - . prettyRef r - . (' ' :) - . shows i - . (' ' :) - . prettyArgs as -prettyIns (Lit l) = - showString "Lit " . showsPrec 11 l -prettyIns (Name r as) = - showString "Name " - . prettyGRef 12 r - . (' ' :) - . prettyArgs as prettyIns i = shows i prettyArgs :: Args -> ShowS @@ -1838,10 +1937,24 @@ sanitizeComb sandboxedForeigns = \case -- | Crawl the source code and statically replace all sandboxed foreign funcs with an error. sanitizeSection :: Set ForeignFunc -> GSection CombIx -> GSection CombIx sanitizeSection sandboxedForeigns section = case section of - Ins (ForeignCall _ f as) nx - | Set.member f sandboxedForeigns -> Ins (SandboxingFailure (foreignFuncBuiltinName f)) (sanitizeSection sandboxedForeigns nx) - | otherwise -> Ins (ForeignCall True f as) (sanitizeSection sandboxedForeigns nx) + ForeignCall _ f as nx + | Set.member f sandboxedForeigns -> SandboxingFailure (foreignFuncBuiltinName f) + | otherwise -> ForeignCall True f as (sanitizeSection sandboxedForeigns nx) Ins i nx -> Ins i (sanitizeSection sandboxedForeigns nx) + RefCAS a b c nx -> RefCAS a b c (sanitizeSection sandboxedForeigns nx) + SetDyn a b nx -> SetDyn a b (sanitizeSection sandboxedForeigns nx) + Capture a nx -> Capture a (sanitizeSection sandboxedForeigns nx) + Name a b nx -> Name a b (sanitizeSection sandboxedForeigns nx) + Info a nx -> Info a (sanitizeSection sandboxedForeigns nx) + Pack a b c nx -> Pack a b c (sanitizeSection sandboxedForeigns nx) + Lit a nx -> Lit a (sanitizeSection sandboxedForeigns nx) + Print a nx -> Print a (sanitizeSection sandboxedForeigns nx) + Reset a nx -> Reset a (sanitizeSection sandboxedForeigns nx) + Fork a nx -> Fork a (sanitizeSection sandboxedForeigns nx) + Atomically a nx -> Atomically a (sanitizeSection sandboxedForeigns nx) + Seq a nx -> Seq a (sanitizeSection sandboxedForeigns nx) + TryForce a nx -> TryForce a (sanitizeSection sandboxedForeigns nx) + SandboxingFailure a -> SandboxingFailure a App {} -> section Call {} -> section Jump {} -> section diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs index e6946403d9..fbb7bdd2b8 100644 --- a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -75,6 +75,21 @@ data SectionT | DMatchT | NMatchT | RMatchT + | ForeignCallT + | SetDynT + | CaptureT + | NameT + | InfoT + | PackT + | LitT + | PrintT + | ResetT + | ForkT + | AtomicallyT + | SeqT + | TryForceT + | RefCAST + | SandboxingFailureT instance Tag SectionT where tag2word AppT = 0 @@ -89,6 +104,21 @@ instance Tag SectionT where tag2word DMatchT = 9 tag2word NMatchT = 10 tag2word RMatchT = 11 + tag2word ForeignCallT = 12 + tag2word SetDynT = 13 + tag2word CaptureT = 14 + tag2word NameT = 15 + tag2word InfoT = 16 + tag2word PackT = 17 + tag2word LitT = 18 + tag2word PrintT = 19 + tag2word ResetT = 20 + tag2word ForkT = 21 + tag2word AtomicallyT = 22 + tag2word SeqT = 23 + tag2word TryForceT = 24 + tag2word RefCAST = 25 + tag2word SandboxingFailureT = 26 word2tag 0 = pure AppT word2tag 1 = pure CallT @@ -102,6 +132,21 @@ instance Tag SectionT where word2tag 9 = pure DMatchT word2tag 10 = pure NMatchT word2tag 11 = pure RMatchT + word2tag 12 = pure ForeignCallT + word2tag 13 = pure SetDynT + word2tag 14 = pure CaptureT + word2tag 15 = pure NameT + word2tag 16 = pure InfoT + word2tag 17 = pure PackT + word2tag 18 = pure LitT + word2tag 19 = pure PrintT + word2tag 20 = pure ResetT + word2tag 21 = pure ForkT + word2tag 22 = pure AtomicallyT + word2tag 23 = pure SeqT + word2tag 24 = pure TryForceT + word2tag 25 = pure RefCAST + word2tag 26 = pure SandboxingFailureT word2tag i = unknownTag "SectionT" i putSection :: (MonadPut m) => GSection cix -> m () @@ -127,6 +172,23 @@ putSection = \case *> pInt i *> putSection pu *> putEnumMap pWord putBranch bs + RefCAS i j k nx -> putTag RefCAST *> pInt i *> pInt j *> pInt k *> putSection nx + ForeignCall b ff a nx -> putTag ForeignCallT *> serialize b *> putMForeignFunc ff *> putArgs a *> putSection nx + SetDyn w i nx -> putTag SetDynT *> pWord w *> pInt i *> putSection nx + Capture w nx -> putTag CaptureT *> pWord w *> putSection nx + Name r a nx -> putTag NameT *> putRef r *> putArgs a *> putSection nx + Info s nx -> putTag InfoT *> serialize s *> putSection nx + Pack r w a nx -> putTag PackT *> putReference r *> putPackedTag w *> putArgs a *> putSection nx + Lit l nx -> putTag LitT *> putLit l *> putSection nx + Print i nx -> putTag PrintT *> pInt i *> putSection nx + Reset s nx -> putTag ResetT *> putEnumSet pWord s *> putSection nx + Fork i nx -> putTag ForkT *> pInt i *> putSection nx + Atomically i nx -> putTag AtomicallyT *> pInt i *> putSection nx + Seq a nx -> putTag SeqT *> putArgs a *> putSection nx + TryForce i nx -> putTag TryForceT *> pInt i *> putSection nx + SandboxingFailure {} -> + -- Sandboxing failures should only exist in code we're actively running, it shouldn't be serialized. + error "putInstr: Unexpected serialized Sandboxing Failure" getSection :: (MonadGet m) => m Section getSection = @@ -149,68 +211,38 @@ getSection = NMatchT -> NMatch <$> getMaybe getReference <*> gInt <*> getBranch RMatchT -> RMatch <$> gInt <*> getSection <*> getEnumMap gWord getBranch + RefCAST -> RefCAS <$> gInt <*> gInt <*> gInt <*> getSection + ForeignCallT -> ForeignCall <$> deserialize <*> getMForeignFunc <*> getArgs <*> getSection + SetDynT -> SetDyn <$> gWord <*> gInt <*> getSection + CaptureT -> Capture <$> gWord <*> getSection + NameT -> Name <$> getRef <*> getArgs <*> getSection + InfoT -> Info <$> deserialize <*> getSection + PackT -> Pack <$> getReference <*> getPackedTag <*> getArgs <*> getSection + LitT -> Lit <$> getLit <*> getSection + PrintT -> Print <$> gInt <*> getSection + ResetT -> Reset <$> getEnumSet gWord <*> getSection + ForkT -> Fork <$> gInt <*> getSection + AtomicallyT -> Atomically <$> gInt <*> getSection + SeqT -> Seq <$> getArgs <*> getSection + TryForceT -> TryForce <$> gInt <*> getSection + SandboxingFailureT -> error "getInstr: Unexpected serialized Sandboxing Failure" data InstrT = UPrim1T | UPrim2T | BPrim1T | BPrim2T - | ForeignCallT - | SetDynT - | CaptureT - | NameT - | InfoT - | PackT - | LitT - | PrintT - | ResetT - | ForkT - | AtomicallyT - | SeqT - | TryForceT - | RefCAST - | SandboxingFailureT instance Tag InstrT where tag2word UPrim1T = 0 tag2word UPrim2T = 1 tag2word BPrim1T = 2 tag2word BPrim2T = 3 - tag2word ForeignCallT = 4 - tag2word SetDynT = 5 - tag2word CaptureT = 6 - tag2word NameT = 7 - tag2word InfoT = 8 - tag2word PackT = 9 - tag2word LitT = 10 - tag2word PrintT = 11 - tag2word ResetT = 12 - tag2word ForkT = 13 - tag2word AtomicallyT = 14 - tag2word SeqT = 15 - tag2word TryForceT = 16 - tag2word RefCAST = 17 - tag2word SandboxingFailureT = 18 word2tag 0 = pure UPrim1T word2tag 1 = pure UPrim2T word2tag 2 = pure BPrim1T word2tag 3 = pure BPrim2T - word2tag 4 = pure ForeignCallT - word2tag 5 = pure SetDynT - word2tag 6 = pure CaptureT - word2tag 7 = pure NameT - word2tag 8 = pure InfoT - word2tag 9 = pure PackT - word2tag 10 = pure LitT - word2tag 11 = pure PrintT - word2tag 12 = pure ResetT - word2tag 13 = pure ForkT - word2tag 14 = pure AtomicallyT - word2tag 15 = pure SeqT - word2tag 16 = pure TryForceT - word2tag 17 = pure RefCAST - word2tag 18 = pure SandboxingFailureT word2tag n = unknownTag "InstrT" n putInstr :: (MonadPut m) => GInstr cix -> m () @@ -219,23 +251,6 @@ putInstr = \case (UPrim2 up i j) -> putTag UPrim2T *> putTag up *> pInt i *> pInt j (BPrim1 bp i) -> putTag BPrim1T *> putTag bp *> pInt i (BPrim2 bp i j) -> putTag BPrim2T *> putTag bp *> pInt i *> pInt j - (RefCAS i j k) -> putTag RefCAST *> pInt i *> pInt j *> pInt k - (ForeignCall b ff a) -> putTag ForeignCallT *> serialize b *> putMForeignFunc ff *> putArgs a - (SetDyn w i) -> putTag SetDynT *> pWord w *> pInt i - (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 *> putPackedTag w *> putArgs a - (Lit l) -> putTag LitT *> putLit l - (Print i) -> putTag PrintT *> pInt i - (Reset s) -> putTag ResetT *> putEnumSet pWord s - (Fork i) -> putTag ForkT *> pInt i - (Atomically i) -> putTag AtomicallyT *> pInt i - (Seq a) -> putTag SeqT *> putArgs a - (TryForce i) -> putTag TryForceT *> pInt i - (SandboxingFailure {}) -> - -- Sandboxing failures should only exist in code we're actively running, it shouldn't be serialized. - error "putInstr: Unexpected serialized Sandboxing Failure" getInstr :: (MonadGet m) => m Instr getInstr = @@ -244,21 +259,6 @@ getInstr = UPrim2T -> UPrim2 <$> getTag <*> gInt <*> gInt BPrim1T -> BPrim1 <$> getTag <*> gInt BPrim2T -> BPrim2 <$> getTag <*> gInt <*> gInt - RefCAST -> RefCAS <$> gInt <*> gInt <*> gInt - ForeignCallT -> ForeignCall <$> deserialize <*> getMForeignFunc <*> getArgs - SetDynT -> SetDyn <$> gWord <*> gInt - CaptureT -> Capture <$> gWord - NameT -> Name <$> getRef <*> getArgs - InfoT -> Info <$> deserialize - PackT -> Pack <$> getReference <*> getPackedTag <*> getArgs - LitT -> Lit <$> getLit - PrintT -> Print <$> gInt - ResetT -> Reset <$> getEnumSet gWord - ForkT -> Fork <$> gInt - AtomicallyT -> Atomically <$> gInt - SeqT -> Seq <$> getArgs - TryForceT -> TryForce <$> gInt - SandboxingFailureT -> error "getInstr: Unexpected serialized Sandboxing Failure" data ArgsT = ZArgsT diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index bfc7ab0c00..e2766a8957 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -336,22 +336,6 @@ 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 - v <- resolve env denv stk r - stk <- name stk args v - pure (denv, stk, k) -exec _ !denv !_activeThreads !stk !k _ (SetDyn p i) = do - 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 - poke stk cap - pure (denv, stk, k) exec _ !denv !_activeThreads !stk !k _ (UPrim1 op i) = do stk <- uprim1 stk op i pure (denv, stk, k) @@ -555,69 +539,6 @@ exec env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) exec _ !denv !_trackThreads !stk !k _ (BPrim2 op i j) = do stk <- bprim2 stk op i j pure (denv, stk, k) -exec env !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) - | sandboxed env = die "attempted to use sandboxed operation: Ref.cas" - | otherwise = do - (ref :: IORef Val) <- peekOffBi stk refI - -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it - -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal - -- forcing of the values and tickets. - !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI - v <- peekOff stk valI - (r, _) <- Atomic.casIORef ref ticket v - stk <- bump stk - pokeBool stk r - pure (denv, stk, k) -exec _ !denv !_activeThreads !stk !k _ (Pack r t args) = do - clo <- buildData stk r t args - stk <- bump stk - bpoke stk clo - pure (denv, stk, k) -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 ml) = do - stk <- bump stk - poke stk $ litToVal ml - pure (denv, stk, k) -exec _ !denv !_activeThreads !stk !k _ (Reset ps) = do - (stk, a) <- saveArgs stk - pure (denv, stk, Mark a ps clos k) - where - clos = EC.restrictKeys denv ps -exec _ !denv !_activeThreads !stk !k _ (Seq as) = do - l <- closureArgs stk as - stk <- bump stk - pokeS stk $ Sq.fromList l - pure (denv, stk, k) -exec _env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = do - stk <- xStackIOToIO $ foreignCall func args (unpackXStack stk) - pure (denv, stk, k) -exec env !denv !activeThreads !stk !k _ (Fork i) - | sandboxed env = die "attempted to use sandboxed operation: fork" - | otherwise = do - 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 - v <- peekOff stk i - stk <- bump stk - 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 - 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 (poke stk) v - stk <- encodeExn stk ev - pure (denv, stk, k) -exec !_ !_ !_ !_ !_ _ (SandboxingFailure t) = do - die $ "Attempted to use disallowed builtin in sandboxed environment: " <> DTx.unpack t {-# INLINE exec #-} encodeExn :: @@ -728,6 +649,87 @@ eval env !denv !activeThreads !stk !k r (Ins i nx) = do eval env denv activeThreads stk k r nx eval _ !_ !_ !_activeThreads !_ _ Exit = pure () eval _ !_ !_ !_activeThreads !_ _ (Die s) = die s +eval env !denv !activeThreads !stk !k r (Info tx nx) = do + info tx stk + info tx k + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k ref (Name r args nx) = do + v <- resolve env denv stk r + stk <- name stk args v + eval env denv activeThreads stk k ref nx +eval env !denv !activeThreads !stk !k r (SetDyn p i nx) = do + val <- peekOff stk i + let denv' = EC.mapInsert p val denv + eval env denv' activeThreads stk k r nx +eval env !denv !activeThreads !stk !k r (Capture p nx) = do + (cap, denv, stk, k) <- splitCont denv stk k p + stk <- bump stk + poke stk cap + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k r (RefCAS refI ticketI valI nx) + | sandboxed env = die "attempted to use sandboxed operation: Ref.cas" + | otherwise = do + (ref :: IORef Val) <- peekOffBi stk refI + -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it + -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal + -- forcing of the values and tickets. + !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI + v <- peekOff stk valI + (result, _) <- Atomic.casIORef ref ticket v + stk <- bump stk + pokeBool stk result + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k ref (Pack r t args nx) = do + clo <- buildData stk r t args + stk <- bump stk + bpoke stk clo + eval env denv activeThreads stk k ref nx +eval env !denv !activeThreads !stk !k r (Print i nx) = do + t <- peekOffBi stk i + Tx.putStrLn (Util.Text.toText t) + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k r (Lit ml nx) = do + stk <- bump stk + poke stk $ litToVal ml + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k r (Reset ps nx) = do + (stk, a) <- saveArgs stk + let k' = Mark a ps clos k + eval env denv activeThreads stk k' r nx + where + clos = EC.restrictKeys denv ps +eval env !denv !activeThreads !stk !k r (Seq as nx) = do + l <- closureArgs stk as + stk <- bump stk + pokeS stk $ Sq.fromList l + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k r (ForeignCall _ func args nx) = do + stk <- xStackIOToIO $ foreignCall func args (unpackXStack stk) + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k r (Fork i nx) + | sandboxed env = die "attempted to use sandboxed operation: fork" + | otherwise = do + tid <- forkEval env activeThreads =<< peekOff stk i + stk <- bump stk + bpoke stk . Foreign . Wrap Rf.threadIdRef $ tid + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k r (Atomically i nx) + | sandboxed env = die $ "attempted to use sandboxed operation: atomically" + | otherwise = do + v <- peekOff stk i + stk <- bump stk + atomicEval env activeThreads (poke stk) v + eval env denv activeThreads stk k r nx +eval env !denv !activeThreads !stk !k r (TryForce i nx) + | sandboxed env = die $ "attempted to use sandboxed operation: tryForce" + | otherwise = do + 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 (poke stk) v + stk <- encodeExn stk ev + eval env denv activeThreads stk k r nx +eval !_ !_ !_ !_ !_ _ (SandboxingFailure t) = do + die $ "Attempted to use disallowed builtin in sandboxed environment: " <> DTx.unpack t {-# NOINLINE eval #-} unhandledAbilityRequest :: (HasCallStack) => IO a