parsley-core 1.1.0.0 → 1.2.0.0

raw patch · 9 files changed

+194/−120 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• parsley-core.cabal +1/−1
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +10/−8
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs +89/−84
• src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs +68/−18
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs +1/−1
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs +3/−2
• src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs +6/−2
• src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs +4/−4

@@ -18,3 +18,15 @@  * Switched both backends to make use of `Lam` instead of `Core.Defunc`, reducing burden on GHC * Added duplication avoidance optimisation when value to be duplicated is `Lam.Var True`++## 1.2.0.0 -- 2021-07-01++* For GHC 8.10+, leveraged the static structure of functions:+  * Handlers are now static functions, reducing the beta-reduction required by GHC, `fatal` now generates better code+  * Return continuations are also static functions, reducing beta-reduction required by GHC, `halt` generates better code+  * Recursive calls are also static functions, removing a lot of junk with the conversion from iterators to recursion+* Registers are now bound once for recursive parsers, which close over their free-registers+* Strictness has been updated to reflect the reduced burden on GHC to optimise: now strictness is for performance, and +  not to coax GHC to optimise at the cost of performance+* Removed the "bad" binding for `Sat`, handlers are always bound on creation, so the binding is basically meaningless+* Performance on 8.10+ is anywhere from 10-20% faster than 1.1.0.0

@@ -5,7 +5,7 @@ --                   | +------- breaking internal API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.1.0.0+version:             1.2.0.0 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         This package contains the internals of the @parsley@ package.                      .

@@ -33,7 +33,7 @@      $$(let ?ops = InputOps [||more||] [||next||]         in letRec fs              nameLet-             (\exp rs names -> buildRec rs (emptyCtx names) (readyMachine exp))+             (\μ exp rs names -> buildRec μ rs (emptyCtx names) (readyMachine exp))              (\names -> run (readyMachine p) (Γ Empty (halt @o) [||offset||] (VCons (fatal @o) VNil)) (emptyCtx names)))   ||]   where@@ -73,10 +73,10 @@ evalRet :: MachineMonad s o (x : xs) n x a evalRet = return $! retCont >>= resume -evalCall :: forall s o a x xs n r. ContOps o => MVar x -> Machine s o (x : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a+evalCall :: forall s o a x xs n r. MarshalOps o => MVar x -> Machine s o (x : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a evalCall μ (Machine k) = liftM2 (\mk sub γ@Γ{..} -> callWithContinuation @o sub (suspend mk γ) input handlers) k (askSub μ) -evalJump :: forall s o a x n. MVar x -> MachineMonad s o '[] (Succ n) x a+evalJump :: forall s o a x n. MarshalOps o => MVar x -> MachineMonad s o '[] (Succ n) x a evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation @o sub retCont input handlers  evalPush :: Defunc x -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a@@ -98,7 +98,8 @@   where     maybeEmitCheck Nothing mk γ = sat (genDefunc1 p) mk (raise γ) γ     maybeEmitCheck (Just n) mk γ =-      [|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (genDefunc1 p) mk [||bad||]) [||bad||] γ)||]+      --[|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (genDefunc1 p) mk [||bad||]) [||bad||] γ)||]+      emitLengthCheck n (sat (genDefunc1 p) mk (raise γ)) (raise γ) γ  evalEmpt :: MachineMonad s o xs (Succ n) r a evalEmpt = return $! raise@@ -107,7 +108,7 @@ evalCommit (Machine k) = k <&> \mk γ -> let VCons _ hs = handlers γ in mk (γ {handlers = hs})  evalCatch :: HandlerOps o => Machine s o xs (Succ n) r a -> Machine s o (o : xs) n r a -> MachineMonad s o xs n r a-evalCatch (Machine k) (Machine h) = liftM2 (\mk mh γ -> setupHandler γ (buildHandler γ mh) mk) k h+evalCatch (Machine k) (Machine h) = liftM2 (\mk mh γ -> bindHandler γ (buildHandler γ mh) mk) k h  evalTell :: Machine s o (o : xs) n r a -> MachineMonad s o xs n r a evalTell (Machine k) = k <&> \mk γ -> mk (γ {operands = Op (OFFSET (input γ)) (operands γ)})@@ -133,7 +134,7 @@       ||]     go _ _ _ def γ = def γ -evalIter :: (RecBuilder o, ReturnOps o, HandlerOps o)+evalIter :: RecBuilder o          => MVar Void -> Machine s o '[] One Void a -> Machine s o (o : xs) n r a          -> MachineMonad s o xs n r a evalIter μ l (Machine h) = liftM2 (\mh ctx γ -> buildIter ctx μ l (buildHandler γ mh) (input γ)) h ask@@ -165,9 +166,10 @@   let Op x xs = operands γ   in writeΣ σ a x (run k (γ {operands = xs})) ctx -evalLogEnter :: (?ops :: InputOps (Rep o), LogHandler o) => String -> Machine s o xs (Succ (Succ n)) r a -> MachineMonad s o xs (Succ n) r a+evalLogEnter :: (?ops :: InputOps (Rep o), LogHandler o, HandlerOps o)+             => String -> Machine s o xs (Succ (Succ n)) r a -> MachineMonad s o xs (Succ n) r a evalLogEnter name (Machine mk) =-  liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '>' γ ctx "") $$(setupHandler γ (logHandler name ctx γ) k)||])+  liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '>' γ ctx "") $$(bindHandler γ (logHandler name ctx γ) k)||])     (local debugUp mk)     ask 

@@ -21,14 +21,17 @@ import Data.Void                                     (Void) import Debug.Trace                                   (trace) import GHC.Exts                                      (Int(..), (-#))+import Language.Haskell.TH.Syntax                    (liftTyped) import Parsley.Internal.Backend.Machine.Defunc       (Defunc(OFFSET), genDefunc, pattern FREEVAR) import Parsley.Internal.Backend.Machine.Identifiers  (MVar, ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps     (PositionOps(..), LogOps(..), InputOps, next, more) import Parsley.Internal.Backend.Machine.InputRep     (Rep{-, representationTypes-}) import Parsley.Internal.Backend.Machine.Instructions (Access(..)) import Parsley.Internal.Backend.Machine.LetBindings  (Regs(..))-import Parsley.Internal.Backend.Machine.State        (Γ(..), Ctx, Handler, Machine(..), MachineMonad, Cont, SubRoutine, OpStack(..), Func,-                                                      run, voidCoins, insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, cachedΣ, concreteΣ, debugLevel)+import Parsley.Internal.Backend.Machine.State        (Γ(..), Ctx, Machine(..), MachineMonad, StaSubRoutine, OpStack(..), DynFunc,+                                                      StaHandler(..), StaCont(..), DynHandler, DynCont, staHandler#, mkStaHandler, staCont#, mkStaCont,+                                                      run, voidCoins, insertSub, insertΦ, insertNewΣ, cacheΣ, cachedΣ, concreteΣ, debugLevel,+                                                      takeFreeRegisters) import Parsley.Internal.Common                       (One, Code, Vec(..), Nat(..)) import Parsley.Internal.Core.InputTypes              (Text16, CharList, Stream) import System.Console.Pretty                         (color, Color(Green, White, Red, Blue))@@ -45,7 +48,7 @@ derivation(Lazy.ByteString)        \ derivation(Text) -type Ops o = (LogHandler o, ContOps o, HandlerOps o, JoinBuilder o, RecBuilder o, ReturnOps o, PositionOps o, LogOps (Rep o))+type Ops o = (HandlerOps o, JoinBuilder o, RecBuilder o, PositionOps o, MarshalOps o, LogOps (Rep o))  {- Input Operations -} sat :: (?ops :: InputOps (Rep o)) => (Code Char -> Code Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))@@ -58,7 +61,7 @@ emitLengthCheck 0 good _ γ   = good γ emitLengthCheck 1 good bad γ = [|| if $$more $$(input γ) then $$(good γ) else $$bad ||] emitLengthCheck (I# n) good bad γ = [||-  if $$more $$(shiftRight (Proxy @o) (input γ) [||n -# 1#||]) then $$(good γ)+  if $$more $$(shiftRight (Proxy @o) (input γ) (liftTyped (n -# 1#))) then $$(good γ)   else $$bad ||]  {- General Operations -}@@ -93,75 +96,60 @@   ||]  {- Handler Operations -}-class HandlerOps o where-  buildHandler :: Γ s o xs n r a-               -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))-               -> Code (Rep o) -> Code (Handler s o a)-  fatal :: Code (Handler s o a)+buildHandler :: Γ s o xs n r a+             -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))+             -> Code (Rep o) -> StaHandler s o a+buildHandler γ h c = mkStaHandler $ \o# -> h (γ {operands = Op (OFFSET c) (operands γ), input = o#}) -setupHandler :: Γ s o xs n r a-             -> (Code (Rep o) -> Code (Handler s o a))-             -> (Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))-setupHandler γ h k = [||-    let handler = $$(h (input γ))-    in $$(k (γ {handlers = VCons [||handler||] (handlers γ)}))-  ||]+fatal :: forall o s a. StaHandler s o a+fatal = mkStaHandler $ const [|| returnST Nothing ||] -raise :: Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))-raise γ = let VCons h _ = handlers γ in [|| $$h $$(input γ) ||]+class HandlerOps o where+  bindHandler :: Γ s o xs n r a+              -> (Code (Rep o) -> StaHandler s o a)+              -> (Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -#define deriveHandlerOps(_o)                        \-instance HandlerOps _o where                        \-{                                                   \-  buildHandler γ h c = [||\(o# :: Rep _o) ->        \-    $$(h (γ {operands = Op (OFFSET c) (operands γ), \-             input = [||o#||]}))||];                \-  fatal = [||\(!_) -> returnST Nothing ||];         \+#define deriveHandlerOps(_o)                                                    \+instance HandlerOps _o where                                                    \+{                                                                               \+  bindHandler γ h k = [||                                                       \+    let handler (o# :: Rep _o) = $$(staHandler# (h (input γ)) [||o#||])         \+    in $$(k (γ {handlers = VCons (staHandler @_o [||handler||]) (handlers γ)})) \+  ||]                                                                           \ }; inputInstances(deriveHandlerOps) -{- Control Flow Operations -}-class ContOps o where-  suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -> Γ s o xs n r a -> Code (Cont s o a x)+raise :: Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))+raise γ = let VCons h _ = handlers γ in staHandler# h (input γ) -class ReturnOps o where-  halt :: Code (Cont s o a a)-  noreturn :: Code (Cont s o a Void)+{- Control Flow Operations -}+suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -> Γ s o xs n r a -> StaCont s o a x+suspend m γ = mkStaCont $ \x o# -> m (γ {operands = Op (FREEVAR x) (operands γ), input = o#}) -callWithContinuation :: forall o s a x n. Code (SubRoutine s o a x) -> Code (Cont s o a x) -> Code (Rep o) -> Vec (Succ n) (Code (Handler s o a)) -> Code (ST s (Maybe a))-callWithContinuation sub ret input (VCons h _) = [||$$sub $$ret $$input $! $$h||]+halt :: forall o s a. StaCont s o a a+halt = mkStaCont $ \x _ -> [||returnST $! Just $$x||] -resume :: Code (Cont s o a x) -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))-resume k γ = let Op x _ = operands γ in [|| $$k $$(genDefunc x) $$(input γ) ||]+noreturn :: forall o s a. StaCont s o a Void+noreturn = mkStaCont $ \_ _ -> [||error "Return is not permitted here"||] -#define deriveContOps(_o)                                                              \-instance ContOps _o where                                                              \-{                                                                                      \-  suspend m γ = [|| \x !(o# :: Rep _o) -> $$(m (γ {operands = Op (FREEVAR [||x||]) (operands γ), \-                                         input = [||o#||]})) ||];                      \-};-inputInstances(deriveContOps)+callWithContinuation :: forall o s a x n. MarshalOps o => StaSubRoutine s o a x -> StaCont s o a x -> Code (Rep o) -> Vec (Succ n) (StaHandler s o a) -> Code (ST s (Maybe a))+callWithContinuation sub ret input (VCons h _) = sub (dynCont @o ret) input (dynHandler @o h) -#define deriveReturnOps(_o)                                      \-instance ReturnOps _o where                                      \-{                                                                \-  halt = [||\x _ -> returnST $! Just x||];                       \-  noreturn = [||\_ _ -> error "Return is not permitted here"||]; \-};-inputInstances(deriveReturnOps)+resume :: StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))+resume k γ = let Op x _ = operands γ in staCont# k (genDefunc x) (input γ)  {- Builder Operations -} class JoinBuilder o where   setupJoinPoint :: ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a  class RecBuilder o where-  buildIter :: ReturnOps o-            => Ctx s o a -> MVar Void -> Machine s o '[] One Void a-            -> (Code (Rep o) -> Code (Handler s o a)) -> Code (Rep o) -> Code (ST s (Maybe a))-  buildRec  :: Regs rs+  buildIter :: Ctx s o a -> MVar Void -> Machine s o '[] One Void a+            -> (Code (Rep o) -> StaHandler s o a) -> Code (Rep o) -> Code (ST s (Maybe a))+  buildRec  :: MVar r+            -> Regs rs             -> Ctx s o a             -> Machine s o '[] One r a-            -> Code (Func rs s o a r)+            -> DynFunc rs s o a r  #define deriveJoinBuilder(_o)                                                       \ instance JoinBuilder _o where                                                       \@@ -170,37 +158,63 @@     liftM2 (\mk ctx γ -> [||                                                        \       let join x !(o# :: Rep _o) =                                                  \         $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||o#||]})) \-      in $$(run mx γ (insertΦ φ [||join||] ctx))                                    \+      in $$(run mx γ (insertΦ φ (staCont @_o [||join||]) ctx))                      \     ||]) (local voidCoins k) ask;                                                   \ }; inputInstances(deriveJoinBuilder) -#define deriveRecBuilder(_o)                                                \-instance RecBuilder _o where                                                \-{                                                                           \-  buildIter ctx μ l h o = [||                                               \-      let handler !(o# :: Rep _o) = $$(h [||o#||]);                                     \-          loop !(o# :: Rep _o) =                                                        \-        $$(run l                                                            \-            (Γ Empty (noreturn @_o) [||o#||] (VCons [||handler o#||] VNil)) \-            (voidCoins (insertSub μ [||\_ !(o# :: Rep _o) _ -> loop o#||] ctx)))      \-      in loop $$o                                                           \-    ||];                                                                    \-  buildRec rs ctx k = takeFreeRegisters rs ctx (\ctx ->                     \-    [|| \(!ret) !(o# :: Rep _o) h ->                                                  \-      $$(run k (Γ Empty [||ret||] [||o#||] (VCons [||h||] VNil)) ctx) ||]); \+#define deriveRecBuilder(_o)                                                                               \+instance RecBuilder _o where                                                                               \+{                                                                                                          \+  buildIter ctx μ l h o = [||                                                                              \+      let handler (c# :: Rep _o) !(o# :: Rep _o) = $$(staHandler# (h [||c#||]) [||o#||]);                  \+          loop !(o# :: Rep _o) =                                                                           \+        $$(run l                                                                                           \+            (Γ Empty (noreturn @_o) [||o#||] (VCons (staHandler @_o [||handler o#||]) VNil))               \+            (voidCoins (insertSub μ (\_ o# _ -> [|| loop $$(o#) ||]) ctx)))                                \+      in loop $$o                                                                                          \+    ||];                                                                                                   \+  buildRec μ rs ctx k = takeFreeRegisters rs ctx (\ctx ->                                                  \+    {- The idea here is to try and reduce the number of times registers have to be passed around -}        \+    {-[|| \ ret !(o# :: Rep _o) h ->                                                                       \+      $$(run k (Γ Empty (staCont @_o [||ret||]) [||o#||] (VCons (staHandler @_o [||h||]) VNil)) ctx) ||]-} \+    [|| let self ret !(o# :: Rep _o) h =                                                                   \+          $$(run k                                                                                         \+              (Γ Empty (staCont @_o [||ret||]) [||o#||] (VCons (staHandler @_o [||h||]) VNil))             \+              (insertSub μ (\k o# h -> [|| self $$k $$(o#) $$h ||]) ctx)) in self ||]  );                  \ }; inputInstances(deriveRecBuilder) -takeFreeRegisters :: Regs rs -> Ctx s o a -> (Ctx s o a -> Code (SubRoutine s o a x)) -> Code (Func rs s o a x)-takeFreeRegisters NoRegs ctx body = body ctx-takeFreeRegisters (FreeReg σ σs) ctx body = [||\(!reg) -> $$(takeFreeRegisters σs (insertScopedΣ σ [||reg||] ctx) body)||]+{- Marshalling Operations -}+class MarshalOps o where+  dynHandler :: StaHandler s o a -> DynHandler s o a+  dynCont :: StaCont s o a x -> DynCont s o a x +staHandler :: forall o s a. DynHandler s o a -> StaHandler s o a+staHandler dh = StaHandler (\o# -> [|| $$dh $$(o#) ||]) (Just dh)++staCont :: forall o s a x. DynCont s o a x -> StaCont s o a x+staCont dk = StaCont (\x o# -> [|| $$dk $$x $$(o#) ||]) (Just dk)++#define deriveMarshalOps(_o)                                                            \+instance MarshalOps _o where                                                            \+{                                                                                       \+  dynHandler (StaHandler sh Nothing) = [||\ !(o# :: Rep _o) -> $$(sh [||o#||]) ||];     \+  dynHandler (StaHandler _ (Just dh)) = dh;                                             \+  dynCont (StaCont sk Nothing) = [||\ x (o# :: Rep _o) -> $$(sk [||x||] [||o#||]) ||]; \+  dynCont (StaCont _ (Just dk)) = dk;                                                   \+};+inputInstances(deriveMarshalOps)+ {- Debugger Operations -}-class (PositionOps o, LogOps (Rep o)) => LogHandler o where-  logHandler :: (?ops :: InputOps (Rep o)) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Code (Rep o) -> Code (Handler s o a)+type LogHandler o = (PositionOps o, LogOps (Rep o)) -preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps o, LogOps (Rep o)) => String -> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String+logHandler :: (?ops :: InputOps (Rep o), LogHandler o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Code (Rep o) -> StaHandler s o a+logHandler name ctx γ _ = let VCons h _ = handlers γ in mkStaHandler $ \o# -> [||+    trace $$(preludeString name '<' (γ {input = o#}) ctx (color Red " Fail")) $$(staHandler# h o#)+  ||]++preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), LogHandler o) => String -> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String preludeString name dir γ ctx ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]   where     offset     = input γ@@ -218,15 +232,6 @@     eof        = [|| if $$more $$end then $$inputTrace else $$inputTrace ++ color Red "•" ||]     prelude    = [|| concat [indent, dir : name, dir : " (", show ($$(offToInt offset)), "): "] ||]     caretSpace = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]--#define deriveLogHandler(_o)                                                                   \-instance LogHandler _o where                                                                   \-{                                                                                              \-  logHandler name ctx γ _ = let VCons h _ = handlers γ in [||\ !(o# :: Rep _o) ->                         \-      trace $$(preludeString name '<' (γ {input = [||o#||]}) ctx (color Red " Fail")) ($$h o#) \-    ||];                                                                                       \-};-inputInstances(deriveLogHandler)  -- RIP Dream :( {-$(let derive _o = [d|

@@ -1,14 +1,18 @@ {-# LANGUAGE DeriveAnyClass,              ExistentialQuantification,+             MagicHash,              TypeFamilies,              DerivingStrategies #-} module Parsley.Internal.Backend.Machine.State (-    HandlerStack, Handler, Cont, SubRoutine, MachineMonad, Func,+    StaHandler(..), StaCont(..), StaSubRoutine, staHandler#, mkStaHandler, staCont#, mkStaCont,+    DynHandler, DynCont, DynSubRoutine, DynFunc,+    MachineMonad, Func,     Γ(..), Ctx, OpStack(..),-    QSubRoutine(..), QJoin(..), Machine(..),+    QSubRoutine, QJoin(..), Machine(..),     run,     emptyCtx,-    insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ,+    insertSub, insertΦ, insertNewΣ, cacheΣ, concreteΣ, cachedΣ, qSubRoutine,+    takeFreeRegisters,     askSub, askΦ,     debugUp, debugDown, debugLevel,     storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins,@@ -32,18 +36,58 @@ import qualified Data.Dependent.Map as DMap             ((!), insert, empty, lookup) import qualified Parsley.Internal.Common.Queue as Queue (empty, null, foldr) -type HandlerStack n s o a = Vec n (Code (Handler s o a))-type Handler s o a = Rep o -> ST s (Maybe a)-type Cont s o a x = x -> Rep o -> ST s (Maybe a)-type SubRoutine s o a x = Cont s o a x -> Rep o -> Handler s o a -> ST s (Maybe a) type MachineMonad s o xs n r a = Reader (Ctx s o a) (Γ s o xs n r a -> Code (ST s (Maybe a))) +-- Statics+type StaHandler# s o a = Code (Rep o) -> Code (ST s (Maybe a))+data StaHandler s o a = StaHandler (StaHandler# s o a) (Maybe (DynHandler s o a))++staHandler# :: StaHandler s o a -> StaHandler# s o a+staHandler# (StaHandler sh _) = sh++mkStaHandler :: StaHandler# s o a -> StaHandler s o a+mkStaHandler sh = StaHandler sh Nothing++type StaCont# s o a x = Code x -> Code (Rep o) -> Code (ST s (Maybe a))+data StaCont s o a x = StaCont (StaCont# s o a x) (Maybe (DynCont s o a x))++staCont# :: StaCont s o a x -> StaCont# s o a x+staCont# (StaCont sk _) = sk++mkStaCont :: StaCont# s o a x -> StaCont s o a x+mkStaCont sk = StaCont sk Nothing++type StaSubRoutine s o a x = DynCont s o a x -> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a))+type family StaFunc (rs :: [Type]) s o a x where+  StaFunc '[] s o a x      = StaSubRoutine s o a x+  StaFunc (r : rs) s o a x = Code (STRef s r) -> StaFunc rs s o a x++data QSubRoutine s o a x = forall rs. QSubRoutine (StaFunc rs s o a x) (Regs rs)++-- Dynamics+type DynHandler s o a = Code (Handler# s o a)+type DynCont s o a x = Code (Cont# s o a x)+type DynSubRoutine s o a x = Code (SubRoutine# s o a x)++type DynFunc (rs :: [Type]) s o a x = Code (Func rs s o a x)++qSubRoutine :: forall s o a x rs. DynFunc rs s o a x -> Regs rs -> QSubRoutine s o a x+qSubRoutine func frees = QSubRoutine (staFunc frees func) frees+  where+    staFunc :: forall rs. Regs rs -> DynFunc rs s o a x -> StaFunc rs s o a x+    staFunc NoRegs func = \dk o# dh -> [|| $$func $$dk $$(o#) $$dh ||]+    staFunc (FreeReg _ witness) func = \r -> staFunc witness [|| $$func $$r ||]++-- Base+type Handler# s o a = Rep o -> ST s (Maybe a)+type Cont# s o a x = x -> Rep o -> ST s (Maybe a)+type SubRoutine# s o a x = Cont# s o a x -> Rep o -> Handler# s o a -> ST s (Maybe a)+ type family Func (rs :: [Type]) s o a x where-  Func '[] s o a x      = SubRoutine s o a x+  Func '[] s o a x      = SubRoutine# s o a x   Func (r : rs) s o a x = STRef s r -> Func rs s o a x -data QSubRoutine s o a x = forall rs. QSubRoutine  (Code (Func rs s o a x)) (Regs rs)-newtype QJoin s o a x = QJoin { unwrapJoin :: Code (Cont s o a x) }+newtype QJoin s o a x = QJoin { unwrapJoin :: StaCont s o a x } newtype Machine s o xs n r a = Machine { getMachine :: MachineMonad s o xs n r a }  run :: Machine s o xs n r a -> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))@@ -57,9 +101,9 @@                    , getCached :: Maybe (Defunc x) }  data Γ s o xs n r a = Γ { operands :: OpStack xs-                        , retCont  :: Code (Cont s o a r)+                        , retCont  :: StaCont s o a r                         , input    :: Code (Rep o)-                        , handlers :: HandlerStack n s o a }+                        , handlers :: Vec n (StaHandler s o a) }  data Ctx s o a = Ctx { μs         :: DMap MVar (QSubRoutine s o a)                      , φs         :: DMap ΦVar (QJoin s o a)@@ -71,10 +115,10 @@ emptyCtx :: DMap MVar (QSubRoutine s o a) -> Ctx s o a emptyCtx μs = Ctx μs DMap.empty DMap.empty 0 0 Queue.empty -insertSub :: MVar x -> Code (SubRoutine s o a x) -> Ctx s o a -> Ctx s o a+insertSub :: MVar x -> StaSubRoutine s o a x -> Ctx s o a -> Ctx s o a insertSub μ q ctx = ctx {μs = DMap.insert μ (QSubRoutine q NoRegs) (μs ctx)} -insertΦ :: ΦVar x -> Code (Cont s o a x) -> Ctx s o a -> Ctx s o a+insertΦ :: ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a insertΦ φ qjoin ctx = ctx {φs = DMap.insert φ (QJoin qjoin) (φs ctx)}  insertNewΣ :: ΣVar x -> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a@@ -94,7 +138,7 @@ cachedΣ :: ΣVar x -> Ctx s o a -> Defunc x cachedΣ σ = fromMaybe (throw (registerFault σ)) . (>>= getCached) . DMap.lookup σ . σs -askSub :: MonadReader (Ctx s o a) m => MVar x -> m (Code (SubRoutine s o a x))+askSub :: MonadReader (Ctx s o a) m => MVar x -> m (StaSubRoutine s o a x) askSub μ =   do QSubRoutine sub rs <- askSubUnbound μ      asks (provideFreeRegisters sub rs)@@ -102,11 +146,17 @@ askSubUnbound :: MonadReader (Ctx s o a) m => MVar x -> m (QSubRoutine s o a x) askSubUnbound μ = asks (fromMaybe (throw (missingDependency μ)) . DMap.lookup μ . μs) -provideFreeRegisters :: Code (Func rs s o a x) -> Regs rs -> Ctx s o a -> Code (SubRoutine s o a x)+-- This needs to return a DynFunc: it is fed back to shared territory+takeFreeRegisters :: Regs rs -> Ctx s o a -> (Ctx s o a -> DynSubRoutine s o a x) -> DynFunc rs s o a x+takeFreeRegisters NoRegs ctx body = body ctx+takeFreeRegisters (FreeReg σ σs) ctx body = [||\(!reg) -> $$(takeFreeRegisters σs (insertScopedΣ σ [||reg||] ctx) body)||]++-- This needs to take a StaFunc+provideFreeRegisters :: StaFunc rs s o a x -> Regs rs -> Ctx s o a -> StaSubRoutine s o a x provideFreeRegisters sub NoRegs _ = sub-provideFreeRegisters f (FreeReg σ σs) ctx = provideFreeRegisters [||$$f $$(concreteΣ σ ctx)||] σs ctx+provideFreeRegisters f (FreeReg σ σs) ctx = provideFreeRegisters (f (concreteΣ σ ctx)) σs ctx -askΦ :: MonadReader (Ctx s o a) m => ΦVar x -> m (Code (Cont s o a x))+askΦ :: MonadReader (Ctx s o a) m => ΦVar x -> m (StaCont s o a x) askΦ φ = asks (unwrapJoin . (DMap.! φ) . φs)  debugUp :: Ctx s o a -> Ctx s o a

@@ -31,7 +31,7 @@      $$(let ?ops = InputOps [||more||] [||next||]         in letRec fs              nameLet-             (\exp rs names -> buildRec rs (emptyCtx names) (readyMachine exp))+             (\μ exp rs names -> buildRec μ rs (emptyCtx names) (readyMachine exp))              (\names -> run (readyMachine p) (Γ Empty (halt @o) [||offset||] (VCons (fatal @o) VNil)) (emptyCtx names)))   ||]   where

@@ -147,7 +147,8 @@   buildIter :: ReturnOps o             => Ctx s o a -> MVar Void -> Machine s o '[] One Void a             -> (Code o -> Code (Handler s o a)) -> Code o -> Code (ST s (Maybe a))-  buildRec  :: Regs rs+  buildRec  :: MVar r+            -> Regs rs             -> Ctx s o a             -> Machine s o '[] One r a             -> Code (Func rs s o a r)@@ -175,7 +176,7 @@             (voidCoins (insertSub μ [||\_ (!o#) _ -> loop o#||] ctx)))           \       in loop ($$unbox $$o)                                                      \     ||];                                                                         \-  buildRec rs ctx k = let bx = box in takeFreeRegisters rs ctx (\ctx ->          \+  buildRec _ rs ctx k = let bx = box in takeFreeRegisters rs ctx (\ctx ->        \     [|| \(!ret) (!o#) h ->                                                       \       $$(run k (Γ Empty [||ret||] [||$$bx o#||] (VCons [||h||] VNil)) ctx) ||]); \ };

@@ -5,10 +5,10 @@ module Parsley.Internal.Backend.Machine.State (     HandlerStack, Handler, Cont, SubRoutine, MachineMonad, Func,     Γ(..), Ctx, OpStack(..),-    QSubRoutine(..), QJoin(..), Machine(..),+    QSubRoutine, QJoin(..), Machine(..),     run,     emptyCtx,-    insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ,+    insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ, qSubRoutine,     askSub, askΦ,     debugUp, debugDown, debugLevel,     storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins,@@ -43,6 +43,10 @@   Func (r : rs) s o a x = STRef s r -> Func rs s o a x  data QSubRoutine s o a x = forall rs. QSubRoutine  (Code (Func rs s o a x)) (Regs rs)++qSubRoutine :: Code (Func rs s o a x) -> Regs rs -> QSubRoutine s o a x+qSubRoutine func frees = QSubRoutine func frees+ newtype QJoin s o a x = QJoin { unwrapJoin :: Code (Cont s o a x) } newtype Machine s o xs n r a = Machine { getMachine :: MachineMonad s o xs n r a } 

@@ -13,7 +13,7 @@ import Language.Haskell.TH.Syntax                   (unTypeCode, unsafeCodeCoerce, Exp(VarE, LetE), Dec(FunD), Clause(Clause), Body(NormalB)) #endif import Parsley.Internal.Backend.Machine.LetBindings (LetBinding(..), Binding, Regs)-import Parsley.Internal.Backend.Machine.State       (QSubRoutine(..), Func)+import Parsley.Internal.Backend.Machine.State       (QSubRoutine, qSubRoutine, Func) import Parsley.Internal.Common.Utils                (Code)  import Data.Dependent.Map as DMap (DMap, (!), map, toList, traverseWithKey)@@ -27,7 +27,7 @@  letRec :: GCompare key => {-bindings-}   DMap key (LetBinding o a)                        -> {-nameof-}     (forall x. key x -> String)-                       -> {-genBinding-} (forall x rs. Binding o a x -> Regs rs -> DMap key (QSubRoutine s o a) -> Code (Func rs s o a x))+                       -> {-genBinding-} (forall x rs. key x -> Binding o a x -> Regs rs -> DMap key (QSubRoutine s o a) -> Code (Func rs s o a x))                        -> {-expr-}       (DMap key (QSubRoutine s o a) -> Code b)                        -> Code b letRec bindings nameOf genBinding expr = unsafeCodeCoerce $@@ -38,7 +38,7 @@      -- Generate each binding providing them with the names      let makeDecl (k :=> LetBinding body frees) =           do let Const (name, _) = names ! k-             func <- unTypeCode (genBinding body frees typedNames)+             func <- unTypeCode (genBinding k body frees typedNames)              return (FunD name [Clause [] (NormalB func) []])      decls <- traverse makeDecl (toList bindings)      -- Generate the main expression using the same names@@ -47,4 +47,4 @@      return (LetE decls exp)   where      makeTypedName :: Const (Name, Some Regs) x -> QSubRoutine s o a x-     makeTypedName (Const (name, Some frees)) = QSubRoutine (unsafeCodeCoerce (return (VarE name))) frees+     makeTypedName (Const (name, Some frees)) = qSubRoutine (unsafeCodeCoerce (return (VarE name))) frees