diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/parsley-core.cabal b/parsley-core.cabal --- a/parsley-core.cabal +++ b/parsley-core.cabal @@ -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. . diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs --- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs @@ -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 diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs --- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs @@ -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| diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs --- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs @@ -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 diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs --- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs @@ -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 diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs --- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs @@ -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) ||]); \ }; diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs --- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs @@ -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 } diff --git a/src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs b/src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs --- a/src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs +++ b/src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs @@ -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