diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,6 @@ # Revision history for `parsley-core` -## 1.0.0.0 -- 2021-06-12 +## 1.0.0.0 -- 2021-06-12 * First version. Released on an unsuspecting world. * Core factored out of the main `parsley` package @@ -40,3 +40,18 @@ * Improved the `Lam` reduction algorithm * Preliminary support for `if true` reduction from `item` and `const True` * Introduced `_if` and `ap` in `Machine.Defunc`, removed `genDefunc1` + +## 1.4.0.0 -- 2021-07-22 +NOTE: The API exposed to `parsley` has changed, however, the changed types match up +and the underlying types are not exposed. This means that `parsley` cannot write +the type down to begin with, so the API change does not _actually_ result in any +backward incompatiblity _unless_ the `Parsley.Internal.*` modules are imported: +this meets requirements for internal major change. + +* Removed an `unsafeCoerce` from register creation, using more existentials. +* Changed `CharList`'s `more` check to test for `[]` and not length (faster!) +* Added static information to offset in the machine +* Leveraged static information to refine handlers at compile time, offering up + to 20% performance improvement +* Code restructuring and refactoring +* Added copious amounts of documentation 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.3.0.0 +version: 1.4.0.0 synopsis: A fast parser combinator library backed by Typed Template Haskell description: This package contains the internals of the @parsley@ package. . @@ -73,8 +73,19 @@ Parsley.Internal.Backend.Machine.InputRep, Parsley.Internal.Backend.Machine.Instructions, Parsley.Internal.Backend.Machine.Ops, - Parsley.Internal.Backend.Machine.State + Parsley.Internal.Backend.Machine.Types, + Parsley.Internal.Backend.Machine.Types.State + + if impl(ghc >= 8.10) + exposed-modules: Parsley.Internal.Backend.Machine.BindingOps, + + Parsley.Internal.Backend.Machine.Types.Base, + Parsley.Internal.Backend.Machine.Types.Context, + Parsley.Internal.Backend.Machine.Types.Dynamics, + Parsley.Internal.Backend.Machine.Types.Offset, + Parsley.Internal.Backend.Machine.Types.Statics + default-extensions: BangPatterns, DataKinds, GADTs, @@ -132,4 +143,4 @@ source-repository head type: git - location: https://github.com/j-mie6/HaskellParsley + location: https://github.com/j-mie6/ParsleyHaskell diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs --- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs @@ -9,7 +9,6 @@ -} module Parsley.Internal.Backend.Machine ( Input, eval, - PositionOps, module Parsley.Internal.Backend.Machine.Instructions, module Parsley.Internal.Backend.Machine.Defunc, module Parsley.Internal.Backend.Machine.Identifiers, @@ -20,9 +19,9 @@ import Data.ByteString (ByteString) import Data.Dependent.Map (DMap) import Data.Text (Text) -import Parsley.Internal.Backend.Machine.Defunc (Defunc(SAME), user, userBool) +import Parsley.Internal.Backend.Machine.Defunc (user, userBool) import Parsley.Internal.Backend.Machine.Identifiers -import Parsley.Internal.Backend.Machine.InputOps (InputPrep(..), PositionOps) +import Parsley.Internal.Backend.Machine.InputOps (InputPrep(..)) import Parsley.Internal.Backend.Machine.Instructions import Parsley.Internal.Backend.Machine.LetBindings (LetBinding, makeLetBinding) import Parsley.Internal.Backend.Machine.Ops (Ops) @@ -33,9 +32,21 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Parsley.Internal.Backend.Machine.Eval as Eval (eval) +{-| +This function is exposed to parsley itself and is used to generate the Haskell code +for a parser. + +@since 0.1.0.0 +-} eval :: forall input a. (Input input, Trace) => Code input -> (LetBinding input a a, DMap MVar (LetBinding input a)) -> Code (Maybe a) eval input (toplevel, bindings) = Eval.eval (prepare input) toplevel bindings +{-| +This class is exposed to parsley itself and is used to denote which types may be +used as input for a parser. + +@since 0.1.0.0 +-} class (InputPrep input, Ops input) => Input input instance Input [Char] instance Input (UArray Int Char) diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/BindingOps.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/BindingOps.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/BindingOps.hs @@ -0,0 +1,175 @@ +{-# OPTIONS_GHC -Wno-monomorphism-restriction #-} +{-# LANGUAGE AllowAmbiguousTypes, + CPP, + MagicHash #-} +{-| +Module : Parsley.Internal.Backend.Machine.BindingOps +Description : Various functions that handle levity-polymorphic code bindings +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the parts of the code-base that deal with levity-polymorphic code. + +For performance, and to help GHC optimise, parsley takes an aggressive stance with unboxing +and representing input using unlifted types. This means that the code generator is levity +polymorphic. While the generated code itself is not polymorphic, to respect the soundness +of GHC, any code that is generated which explicitly creates an unlifted value is kept in +type-class methods and instantiated for every input type. All of these classes are found +here. + +@since 1.4.0.0 +-} +module Parsley.Internal.Backend.Machine.BindingOps (module Parsley.Internal.Backend.Machine.BindingOps) where + +import Control.Monad.ST (ST) +import Data.Array.Unboxed (UArray) +import Data.ByteString.Internal (ByteString) +import Data.Text (Text) +import Parsley.Internal.Backend.Machine.InputRep (Rep) +import Parsley.Internal.Backend.Machine.Types.Base (Handler#) +import Parsley.Internal.Backend.Machine.Types.Dynamics (DynSubroutine, DynCont, DynHandler) +import Parsley.Internal.Backend.Machine.Types.Statics (StaCont#, StaHandler#) +import Parsley.Internal.Common.Utils (Code) +import Parsley.Internal.Core.InputTypes (Text16, CharList, Stream) + +import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString) + +#define inputInstances(derivation) \ +derivation([Char]) \ +derivation((UArray Int Char)) \ +derivation(Text16) \ +derivation(ByteString) \ +derivation(CharList) \ +derivation(Stream) \ +derivation(Lazy.ByteString) \ +derivation(Text) + +{-| +Used to generate a binding for a handler. + +@since 1.4.0.0 +-} +class HandlerOps o where + {-| + Generate a let-bound handler and provide it to another continuation. + + @since 1.4.0.0 + -} + bindHandler# :: StaHandler# s o a -- ^ Static handler to bind + -> (DynHandler s o a -> Code b) -- ^ The continuation that expects the bound handler + -> Code b + +#define deriveHandlerOps(_o) \ +instance HandlerOps _o where \ +{ \ + bindHandler# h k = [|| \ + let handler (o# :: Rep _o) = $$(h [||o#||]) \ + in $$(k [||handler||]) \ + ||]; \ +}; +inputInstances(deriveHandlerOps) + +{-| +Generates join-point bindings. + +@since 1.4.0.0 +-} +class JoinBuilder o where + {-| + Generate a let-bound join point and provide it to another continuation. + + @since 1.4.0.0 + -} + setupJoinPoint# :: StaCont# s o a x -- ^ The join point to bind. + -> (DynCont s o a x -> Code b) -- ^ The continuation that expects the bound join point + -> Code b + +#define deriveJoinBuilder(_o) \ +instance JoinBuilder _o where \ +{ \ + setupJoinPoint# binding k = \ + [|| let join x !(o# :: Rep _o) = $$(binding [||x||] [||o#||]) in $$(k [||join||]) ||] \ +}; +inputInstances(deriveJoinBuilder) + +{-| +Various functions for creating bindings for recursive parsers. + +@since 1.4.0.0 +-} +class RecBuilder o where + {-| + Create a binder for specialist iterating handlers: these have two arguments, + one for the current captured offset and then the second for the offset at + point of failure. + + @since 1.4.0.0 + -} + bindIterHandler# :: (Code (Rep o) -> StaHandler# s o a) -- ^ The iter handler to bind + -> (Code (Rep o -> Handler# s o a) -> Code b) -- ^ The continuation that accepts the bound handler + -> Code b + + {-| + Creates a binding for a tail-recursive loop. + + @since 1.4.0.0 + -} + bindIter# :: Code (Rep o) -- ^ Initial offset for the loop. + -> (DynHandler s o a -> Code (Rep o) -> Code (ST s (Maybe a))) -- ^ The code for the loop given handler and offset. + -> Code (ST s (Maybe a)) -- ^ Code of the executing loop. + + {-| + Creates a binding for a regular let-bound parser. + + @since 1.4.0.0 + -} + bindRec# :: (DynSubroutine s o a x -> DynCont s o a x -> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a))) -- ^ Code for the binding, accepting itself as an argument. + -> DynSubroutine s o a x -- ^ The code that represents this binding's name. + +#define deriveRecBuilder(_o) \ +instance RecBuilder _o where \ +{ \ + bindIterHandler# h k = [|| \ + let handler (c# :: Rep _o) (o# :: Rep _o) = $$(h [||c#||] [||o#||]) in $$(k [||handler||]) \ + ||]; \ + bindIter# o l = [|| \ + let loop !(o# :: Rep _o) = $$(l [||loop||] [||o#||]) \ + in loop $$o \ + ||]; \ + bindRec# binding = \ + {- The idea here is to try and reduce the number of times registers have to be passed around -} \ + [|| let self ret !(o# :: Rep _o) h = $$(binding [||self||] [||ret||] [||o#||] [||h||]) in self ||] \ +}; +inputInstances(deriveRecBuilder) + +{- Marshalling Operations -} +{-| +These operations are responsible for materialising the static handlers +and continuations into dynamic forms that can be passed into other bindings +at runtime. + +@since 1.4.0.0 +-} +class MarshalOps o where + {-| + Converts a static handler into a dynamic one (represented as a lambda) + + @since 1.4.0.0 + -} + dynHandler# :: StaHandler# s o a -> DynHandler s o a + + {-| + Converts a static continuation into a dynamic one (represented as a lambda) + + @since 1.4.0.0 + -} + dynCont# :: StaCont# s o a x -> DynCont s o a x + +#define deriveMarshalOps(_o) \ +instance MarshalOps _o where \ +{ \ + dynHandler# sh = [||\ !(o# :: Rep _o) -> $$(sh [||o#||]) ||]; \ + dynCont# sk = [||\ x (o# :: Rep _o) -> $$(sk [||x||] [||o#||]) ||]; \ +}; +inputInstances(deriveMarshalOps) diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs --- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs @@ -1,38 +1,100 @@ {-# LANGUAGE PatternSynonyms, StandaloneKindSignatures, TypeApplications, ViewPatterns #-} -module Parsley.Internal.Backend.Machine.Defunc (module Parsley.Internal.Backend.Machine.Defunc) where +{-| +Module : Parsley.Internal.Backend.Machine.Defunc +Description : Machine-level defunctionalisation +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental -import Data.Proxy (Proxy(Proxy)) -import Parsley.Internal.Backend.Machine.InputOps (PositionOps(same)) -import Parsley.Internal.Backend.Machine.InputRep (Rep) -import Parsley.Internal.Common.Utils (Code) -import Parsley.Internal.Core.Lam (Lam, normaliseGen, normalise) +This module contains the infrastructure and definitions of defunctionalised +terms used solely within the machine. +@since 1.0.0.0 +-} +module Parsley.Internal.Backend.Machine.Defunc ( + Defunc(..), + user, userBool, + ap, ap2, + _if, + genDefunc, + pattern NormLam, pattern FREEVAR + ) where + +import Parsley.Internal.Backend.Machine.Types.Offset (Offset) +import Parsley.Internal.Common.Utils (Code) +import Parsley.Internal.Core.Lam (Lam, normaliseGen, normalise) + import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm, lamTermBool) import qualified Parsley.Internal.Core.Lam as Lam (Lam(..)) +{-| +Machine level defunctionalisation, for terms that can only be introduced by +the code generator, and that do not require value level representations. + +@since 1.4.0.0 +-} data Defunc a where + {-| + Wraps `Lam` terms so that they can be used within the machine. + + @since 1.1.0.0 + -} LAM :: Lam a -> Defunc a + {-| + Represents Haskell's @undefined@, which may be used by high-level + optimisers to replace redundant values whilst preserving the types. + + @since 1.0.0.0 + -} BOTTOM :: Defunc a - SAME :: PositionOps o => Defunc (o -> o -> Bool) - OFFSET :: Code (Rep o) -> Defunc o + {-| + Allows the static `Offset`s to be pushed onto the operand stack, which + is the easiest way to get them to persist as arguments to handlers, and + interact with `Parsley.Internal.Backend.Machine.Instructions.Seek` and + `Parsley.Internal.Backend.Machine.Instructions.Tell`. + @since 1.4.0.0 + -} + OFFSET :: Offset o -> Defunc o + +{-| +Promotes a @Defunc@ value from the Frontend API into a Backend one. + +@since 1.1.0.0 +-} user :: Core.Defunc a -> Defunc a user = LAM . Core.lamTerm +{-| +Promotes a @Defunc@ value from the Frontend API into a Backend one, +for values representing @a -> Bool@. + +@since 1.3.0.0 +-} userBool :: Core.Defunc (a -> Bool) -> Defunc (a -> Bool) userBool = LAM . Core.lamTermBool +{-| +Applies a function to a value when both are `Defunc`. + +@since 1.3.0.0 +-} ap :: Defunc (a -> b) -> Defunc a -> Defunc b ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x)) +{-| +Applies a function to two values when all are `Defunc`. + +@since 1.3.0.0 +-} ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c -ap2 f@SAME (OFFSET o1) (OFFSET o2) = LAM (Lam.Var False (apSame f o1 o2)) - where - apSame :: forall o. Defunc (o -> o -> Bool) -> Code (Rep o) -> Code (Rep o) -> Code Bool - apSame SAME = same (Proxy @o) - apSame _ = undefined -ap2 f x y = ap (ap f x) y +ap2 f x = ap (ap f x) +{-| +Acts as an @if@-expression lifted to the `Defunc` level. + +@since 1.3.0.0 +-} _if :: Defunc Bool -> Code a -> Code a -> Code a _if c t e = normaliseGen (Lam.If (unliftDefunc c) (Lam.Var False t) (Lam.Var False e)) @@ -40,15 +102,30 @@ unliftDefunc (LAM x) = x unliftDefunc x = Lam.Var False (genDefunc x) +{-| +Generate the Haskell code that represents this defunctionalised value. + +@since 1.0.0.0 +-} genDefunc :: Defunc a -> Code a genDefunc (LAM x) = normaliseGen x genDefunc BOTTOM = [||undefined||] -genDefunc SAME = error "Cannot materialise the same function in the regular way" genDefunc (OFFSET _) = error "Cannot materialise an unboxed offset in the regular way" +{-| +Pattern that normalises a `Lam` before returning it. + +@since 1.1.0.0 +-} pattern NormLam :: Lam a -> Defunc a pattern NormLam t <- LAM (normalise -> t) +{-| +Pattern that represents simple `Lam` variables, +post-normalisation. + +@since 1.1.0.0 +-} pattern FREEVAR :: Code a -> Defunc a pattern FREEVAR v <- NormLam (Lam.Var True v) where @@ -56,7 +133,6 @@ instance Show (Defunc a) where show (LAM x) = show x - show SAME = "same" show BOTTOM = "[[irrelevant]]" show (FREEVAR _) = "x" - show (OFFSET _) = "an offset" + show (OFFSET o) = "offset " ++ show o 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 @@ -4,37 +4,60 @@ RecordWildCards, TypeApplications, UnboxedTuples #-} +{-| +Module : Parsley.Internal.Backend.Machine.Eval +Description : Entry point for the evaluator +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module exports the `eval` functions used to convert a machine into code. + +@since 1.0.0.0 +-} module Parsley.Internal.Backend.Machine.Eval (eval) where import Data.Dependent.Map (DMap) import Data.Functor ((<&>)) import Data.Void (Void) -import Control.Monad (forM, liftM2) +import Control.Monad (forM, liftM2, liftM3) import Control.Monad.Reader (ask, asks, local) import Control.Monad.ST (runST) import Parsley.Internal.Backend.Machine.Defunc (Defunc(OFFSET), pattern FREEVAR, genDefunc, ap, ap2, _if) import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΦVar, ΣVar) -import Parsley.Internal.Backend.Machine.InputOps (InputDependant, PositionOps, LogOps, InputOps(InputOps)) +import Parsley.Internal.Backend.Machine.InputOps (InputDependant, InputOps(InputOps)) import Parsley.Internal.Backend.Machine.InputRep (Rep) -import Parsley.Internal.Backend.Machine.Instructions (Instr(..), MetaInstr(..), Access(..)) +import Parsley.Internal.Backend.Machine.Instructions (Instr(..), MetaInstr(..), Access(..), Handler(..)) import Parsley.Internal.Backend.Machine.LetBindings (LetBinding(..)) -import Parsley.Internal.Backend.Machine.LetRecBuilder +import Parsley.Internal.Backend.Machine.LetRecBuilder (letRec) +import Parsley.Internal.Backend.Machine.Types (MachineMonad, Machine(..), run) +import Parsley.Internal.Backend.Machine.Types.Context +import Parsley.Internal.Backend.Machine.Types.Offset (mkOffset, offset) import Parsley.Internal.Backend.Machine.Ops -import Parsley.Internal.Backend.Machine.State +import Parsley.Internal.Backend.Machine.Types.State (Γ(..), OpStack(..)) import Parsley.Internal.Common (Fix4, cata4, One, Code, Vec(..), Nat(..)) import Parsley.Internal.Trace (Trace(trace)) import System.Console.Pretty (color, Color(Green)) import qualified Debug.Trace (trace) -eval :: forall o a. (Trace, Ops o) => Code (InputDependant (Rep o)) -> LetBinding o a a -> DMap MVar (LetBinding o a) -> Code (Maybe a) -eval input (LetBinding !p _) fs = trace ("EVALUATING TOP LEVEL") [|| runST $ +{-| +This function performs the evaluation on the top-level let-bound parser to convert it into code. + +@since 1.0.0.0 +-} +eval :: forall o a. (Trace, Ops o) + => Code (InputDependant (Rep o)) -- ^ The input as provided by the user. + -> LetBinding o a a -- ^ The binding to be generated. + -> DMap MVar (LetBinding o a) -- ^ The map of all other required bindings. + -> Code (Maybe a) -- ^ The code for this parser. +eval input (LetBinding !p _) fs = trace "EVALUATING TOP LEVEL" [|| runST $ do let !(# next, more, offset #) = $$input $$(let ?ops = InputOps [||more||] [||next||] in letRec fs nameLet (\μ exp rs names -> buildRec μ rs (emptyCtx names) (readyMachine exp)) - (\names -> run (readyMachine p) (Γ Empty (halt @o) [||offset||] (VCons (fatal @o) VNil)) (emptyCtx names))) + (run (readyMachine p) (Γ Empty halt (mkOffset [||offset||] 0) (VCons fatal VNil)) . nextUnique . emptyCtx)) ||] where nameLet :: MVar x -> String @@ -74,10 +97,10 @@ evalRet = return $! retCont >>= resume 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 μ) +evalCall μ (Machine k) = freshUnique $ \u -> liftM2 (\mk sub γ@Γ{..} -> callWithContinuation @o sub (suspend mk γ u) (offset input) handlers) k (askSub μ) 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 +evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation @o sub retCont (offset input) handlers evalPush :: Defunc x -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a evalPush x (Machine k) = k <&> \m γ -> m (γ {operands = Op x (operands γ)}) @@ -88,18 +111,18 @@ evalLift2 :: Defunc (x -> y -> z) -> Machine s o (z : xs) n r a -> MachineMonad s o (y : x : xs) n r a evalLift2 f (Machine k) = k <&> \m γ -> m (γ {operands = let Op y (Op x xs) = operands γ in Op (ap2 f x y) xs}) -evalSat :: (?ops :: InputOps (Rep o), PositionOps o, Trace) => Defunc (Char -> Bool) -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a +evalSat :: (?ops :: InputOps (Rep o), PositionOps (Rep o), Trace) => Defunc (Char -> Bool) -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a evalSat p (Machine k) = do bankrupt <- asks isBankrupt hasChange <- asks hasCoin if | bankrupt -> maybeEmitCheck (Just 1) <$> k | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k - | otherwise -> trace "I have a piggy :)" $ local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k) + | otherwise -> trace "I have a piggy :)" $ local breakPiggy (asks ((maybeEmitCheck . Just) . coins) <*> local spendCoin k) where maybeEmitCheck Nothing mk γ = sat (ap p) mk (raise γ) γ maybeEmitCheck (Just n) mk γ = --[|| let bad = $$(raise γ) in $$(emitLengthCheck n (sat (ap p) mk [||bad||]) [||bad||] γ)||] - emitLengthCheck n (sat (ap p) mk (raise γ)) (raise γ) γ + emitLengthCheck n (sat (ap p) mk (raise γ) γ) (raise γ) (input γ) evalEmpt :: MachineMonad s o xs (Succ n) r a evalEmpt = return $! raise @@ -107,8 +130,12 @@ evalCommit :: Machine s o xs n r a -> MachineMonad s o xs (Succ n) r a 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 γ -> bindHandler γ (buildHandler γ mh) mk) k h +evalCatch :: (PositionOps (Rep o), HandlerOps o) => Machine s o xs (Succ n) r a -> Handler o (Machine s o) (o : xs) n r a -> MachineMonad s o xs n r a +evalCatch (Machine k) h = freshUnique $ \u -> case h of + Always (Machine h) -> + liftM2 (\mk mh γ -> bindAlwaysHandler γ (buildHandler γ mh u) mk) k h + Same (Machine yes) (Machine no) -> + liftM3 (\mk myes mno γ -> bindSameHandler γ (buildYesHandler γ myes u) (buildHandler γ mno u) mk) k yes no 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 γ)}) @@ -131,10 +158,17 @@ go x (f:fs) (mk:mks) def γ = _if (ap f x) (mk γ) (go x fs mks def γ) go _ _ _ def γ = def γ -evalIter :: RecBuilder o - => MVar Void -> Machine s o '[] One Void a -> Machine s o (o : xs) n r a +evalIter :: (RecBuilder o, PositionOps (Rep o), HandlerOps o) + => MVar Void -> Machine s o '[] One Void a -> Handler o (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 +evalIter μ l h = + freshUnique $ \u1 -> -- This one is used for the handler's offset from point of failure + freshUnique $ \u2 -> -- This one is used for the handler's check and loop offset + case h of + Always (Machine h) -> + liftM2 (\mh ctx γ -> buildIterAlways ctx μ l (buildHandler γ mh u1) (input γ) u2) h ask + Same (Machine yes) (Machine no) -> + liftM3 (\myes mno ctx γ -> buildIterSame ctx μ l (buildYesHandler γ myes u1) (buildHandler γ mno u1) (input γ) u2) yes no ask evalJoin :: ΦVar x -> MachineMonad s o (x : xs) n r a evalJoin φ = askΦ φ <&> resume @@ -151,35 +185,35 @@ in dup x $ \dupx -> mk (γ {operands = Op dupx (Op dupx xs)}) evalMake :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a -evalMake σ a k = asks $! \ctx γ -> +evalMake σ a k = asks $ \ctx γ -> let Op x xs = operands γ in newΣ σ a x (run k (γ {operands = xs})) ctx evalGet :: ΣVar x -> Access -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a -evalGet σ a k = asks $! \ctx γ -> readΣ σ a (\x -> run k (γ {operands = Op x (operands γ)})) ctx +evalGet σ a k = asks $ \ctx γ -> readΣ σ a (\x -> run k (γ {operands = Op x (operands γ)})) ctx evalPut :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a -evalPut σ a k = asks $! \ctx γ -> +evalPut σ a k = asks $ \ctx γ -> let Op x xs = operands γ in writeΣ σ a x (run k (γ {operands = xs})) ctx 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 "") $$(bindHandler γ (logHandler name ctx γ) k)||]) +evalLogEnter name (Machine mk) = freshUnique $ \u -> + liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '>' γ ctx "") $$(bindAlwaysHandler γ (logHandler name ctx γ u) k)||]) (local debugUp mk) ask -evalLogExit :: (?ops :: InputOps (Rep o), PositionOps o, LogOps (Rep o)) => String -> Machine s o xs n r a -> MachineMonad s o xs n r a +evalLogExit :: (?ops :: InputOps (Rep o), PositionOps (Rep o), LogOps (Rep o)) => String -> Machine s o xs n r a -> MachineMonad s o xs n r a evalLogExit name (Machine mk) = liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '<' γ (debugDown ctx) (color Green " Good")) $$(k γ) ||]) (local debugDown mk) ask -evalMeta :: (?ops :: InputOps (Rep o), PositionOps o) => MetaInstr n -> Machine s o xs n r a -> MachineMonad s o xs n r a +evalMeta :: (?ops :: InputOps (Rep o), PositionOps (Rep o)) => MetaInstr n -> Machine s o xs n r a -> MachineMonad s o xs n r a evalMeta (AddCoins coins) (Machine k) = do requiresPiggy <- asks hasCoin if requiresPiggy then local (storePiggy coins) k - else local (giveCoins coins) k <&> \mk γ -> emitLengthCheck coins mk (raise γ) γ + else local (giveCoins coins) k <&> \mk γ -> emitLengthCheck coins (mk γ) (raise γ) (input γ) evalMeta (RefundCoins coins) (Machine k) = local (giveCoins coins) k -evalMeta (DrainCoins coins) (Machine k) = liftM2 (\n mk γ -> emitLengthCheck n mk (raise γ) γ) (asks ((coins -) . liquidate)) k +evalMeta (DrainCoins coins) (Machine k) = liftM2 (\n mk γ -> emitLengthCheck n (mk γ) (raise γ) (input γ)) (asks ((coins -) . liquidate)) k diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs --- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs @@ -1,7 +1,20 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE ImplicitParams, MagicHash, TypeApplications, UnboxedTuples #-} +{-| +Module : Parsley.Internal.Backend.Machine.InputOps +Description : Primitive operations for working with input. +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the primitive operations required by the +parsing machinery to work with input. + +@since 1.0.0.0 +-} module Parsley.Internal.Backend.Machine.InputOps ( InputPrep(..), PositionOps(..), LogOps(..), InputOps(..), more, next, @@ -13,7 +26,6 @@ import Data.Text.Array (aBA{-, empty-}) import Data.Text.Internal (Text(..)) import Data.Text.Unsafe (iter, Iter(..){-, iter_, reverseIter_-}) -import Data.Proxy (Proxy) import GHC.Exts (Int(..), Char(..), TYPE, Int#) import GHC.ForeignPtr (ForeignPtr(..)) import GHC.Prim (indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#), (-#)) @@ -25,28 +37,113 @@ --import qualified Data.Text as Text (length, index) {- Auxillary Representation -} +{-| +Given some associated representation type, defines the operations +that work with a /closed over/ instance of that type. These are: + +* @next@: extract the next character from the input (existence not included) +* @more@: query whether another character /can/ be read +* @init@: the initial state of the input. + +@since 1.0.0.0 +-} type InputDependant (rep :: TYPE r) = (# {-next-} rep -> (# Char, rep #) , {-more-} rep -> Bool , {-init-} rep #) {- Typeclasses -} +{-| +This class is responsible for converting the user's input into a form that +parsley can work with efficiently. + +@since 1.0.0.0 +-} class InputPrep input where + {-| + Given the user's input to the parser, in its original form, this function + distils it first into @`Rep` input@, which is parsley's internal representation, + and then produces an `InputDependant` containing the core operations. + + @since 1.0.0.0 + -} prepare :: rep ~ Rep input => Code input -> Code (InputDependant rep) -class PositionOps input where - same :: rep ~ Rep input => Proxy input -> Code rep -> Code rep -> Code Bool - shiftRight :: rep ~ Rep input => Proxy input -> Code rep -> Code Int# -> Code rep +{-| +Defines operations for manipulating offsets for regular use. These are not +tied to the original captured input but instead to the representation of its +offset. +@since 1.0.0.0 +-} +class PositionOps (rep :: TYPE r) where + {-| + Compares two "input"s for equality. In reality this usually means an offset + present in the @rep@. + + @since 1.0.0.0 + -} + same :: Code rep -> Code rep -> Code Bool + + {-| + Advances the input by several characters at a time (existence not included). + This can be used to check if characters exist at a future point in the input + in conjunction with `more`. + + @since 1.0.0.0 + -} + shiftRight :: Code rep -> Code Int# -> Code rep + +{-| +Defines operation used for debugging operations. + +@since 1.0.0.0 +-} class LogOps (rep :: TYPE r) where + {-| + If possible, shifts the input back several characters. + This is used to provide the previous input characters for the debugging combinator. + + @since 1.0.0.0 + -} shiftLeft :: Code rep -> Code Int# -> Code rep + + {-| + Converts the represention of the input into an @Int@. + + @since 1.0.0.0 + -} offToInt :: Code rep -> Code Int -data InputOps (rep :: TYPE r) = InputOps { _more :: Code (rep -> Bool) - , _next :: Code (rep -> (# Char, rep #)) +{-| +This is a psuedo-typeclass, which depends directly on the values obtained from +`InputDependant`. Because this instance must depend on local information, it is +synthesised and passed around using @ImplicitParams@. + +@since 1.0.0.0 +-} +data InputOps (rep :: TYPE r) = InputOps { _more :: Code (rep -> Bool) -- ^ Does the input have any more characters? + , _next :: Code (rep -> (# Char, rep #)) -- ^ Read the next character (without checking existence) } -more :: forall r (rep :: TYPE r). (?ops :: InputOps rep) => Code (rep -> Bool) -more = _more ?ops +{-| +Wraps around `InputOps` and `_more`. + +Queries the input to see if another character may be consumed. + +@since 1.4.0.0 +-} +more :: forall r (rep :: TYPE r). (?ops :: InputOps rep) => Code rep -> Code Bool +more qo# = [|| $$(_more ?ops) $$(qo#) ||] + +{-| +Wraps around `InputOps` and `_next`. + +Given some input and a continuation that accepts new input and a character, it will read +a character off (without checking that it exists!) and feeds it and the remaining input +to the continuation. + +@since 1.0.0.0 +-} next :: forall r (rep :: TYPE r) a. (?ops :: InputOps rep) => Code rep -> (Code Char -> Code rep -> Code a) -> Code a next ts k = [|| let !(# t, ts' #) = $$(_next ?ops) $$ts in $$(k [||t||] [||ts'||]) ||] @@ -84,10 +181,9 @@ prepare qinput = [|| let CharList input = $$qinput next (# i#, c:cs #) = (# c, (# i# +# 1#, cs #) #) - I# size# = length input - more (# i#, _ #) = $$(intLess [||i#||] [||size#||]) - --more (OffWith _ []) = False - --more _ = True + more :: (# Int#, [Char] #) -> Bool + more (# _, [] #) = False + more _ = True in (# next, more, $$(offWith [||input||]) #) ||] @@ -131,38 +227,29 @@ shiftRightInt qo# qi# = [||$$(qo#) +# $$(qi#)||] -- PositionOps Instances -instance PositionOps [Char] where - same _ = intSame - shiftRight _ = shiftRightInt -instance PositionOps (UArray Int Char) where - same _ = intSame - shiftRight _ = shiftRightInt -instance PositionOps Text16 where - same _ = intSame - shiftRight _ = shiftRightInt -instance PositionOps ByteString where - same _ = intSame - shiftRight _ = shiftRightInt +instance PositionOps Int# where + same = intSame + shiftRight = shiftRightInt -instance PositionOps CharList where - same _ = offWithSame - shiftRight _ qo# qi# = offWithShiftRight [||drop||] qo# qi# +instance PositionOps (# Int#, [Char] #) where + same = offWithSame + shiftRight qo# qi# = offWithShiftRight [||drop||] qo# qi# -instance PositionOps Stream where - same _ = offWithSame - shiftRight _ qo# qi# = offWithShiftRight [||dropStream||] qo# qi# +instance PositionOps (# Int#, Stream #) where + same = offWithSame + shiftRight qo# qi# = offWithShiftRight [||dropStream||] qo# qi# instance PositionOps Text where - same _ qt1 qt2 = [||$$(offsetText qt1) == $$(offsetText qt2)||] - shiftRight _ qo# qi# = [||textShiftRight $$(qo#) (I# $$(qi#))||] + same qt1 qt2 = [||$$(offsetText qt1) == $$(offsetText qt2)||] + shiftRight qo# qi# = [||textShiftRight $$(qo#) (I# $$(qi#))||] -instance PositionOps Lazy.ByteString where - same _ qx# qy# = [|| +instance PositionOps UnpackedLazyByteString where + same qx# qy# = [|| case $$(qx#) of (# i#, _, _, _, _, _ #) -> case $$(qy#) of (# j#, _, _, _, _, _ #) -> $$(intSame [||i#||] [||j#||]) ||] - shiftRight _ qo# qi# = [||byteStringShiftRight $$(qo#) $$(qi#)||] + shiftRight qo# qi# = [||byteStringShiftRight $$(qo#) $$(qi#)||] -- LogOps Instances instance LogOps Int# where diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputRep.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputRep.hs --- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputRep.hs +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputRep.hs @@ -1,17 +1,42 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE MagicHash, TypeFamilies, UnboxedTuples, StandaloneKindSignatures #-} +{-| +Module : Parsley.Internal.Backend.Machine.InputRep +Description : Internal representations of input and miscellaneous operations. +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the translation from user input type to the +underlying parsley representation of it, as well as some miscellaneous +functions for working with specific types of input (these do not appear +in the rest of the machinery, but in "Parsley.Internal.Backend.Machine.InputOps" +and potentially the generated code). + +@since 1.0.0.0 +-} module Parsley.Internal.Backend.Machine.InputRep ( + -- * Representation Type-Families Rep, RepKind, + -- * @Int#@ Operations intSame, intLess, min#, max#, + -- * @Offwith@ Operations OffWith, offWith, offWithSame, offWithShiftRight, --OffWithStreamAnd(..), + -- * @LazyByteString@ Operations UnpackedLazyByteString, emptyUnpackedLazyByteString, + -- * @Stream@ Operations Stream, dropStream, + -- * @Text@ Operations offsetText, - representationTypes, - -- These must be exposed + -- * Crucial Exposed Functions + {- | + These functions must be exposed, since they can appear + in the generated code. + -} textShiftRight, textShiftLeft, byteStringShiftRight, byteStringShiftLeft ) where @@ -28,11 +53,24 @@ import Parsley.Internal.Core.InputTypes (Text16, CharList, Stream(..)) import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..)) -import qualified Language.Haskell.TH as TH (Q, Type) {- Representation Types -} +{-| +This allows types like @String@ and @Stream@ to be manipulated +more efficiently by packaging them along with an offset which can +be used for quicker comparisons. + +@since 1.0.0.0 +-} type OffWith ts = (# Int#, ts #) + --data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts + +{-| +This type unpacks /lazy/ `Lazy.ByteString`s for efficiency. + +@since 1.0.0.0 +-} type UnpackedLazyByteString = (# Int#, Addr#, @@ -42,20 +80,34 @@ Lazy.ByteString #) -representationTypes :: [TH.Q TH.Type] -representationTypes = [[t|[Char]|], [t|UArray Int Char|], [t|Text16|], [t|ByteString|], [t|CharList|], [t|Stream|], [t|Lazy.ByteString|], [t|Text|]] +{-| +Initialises an `OffWith` type, with a starting offset of @0@. +@since 1.0.0.0 +-} offWith :: Code ts -> Code (OffWith ts) offWith qts = [||(# 0#, $$qts #)||] +{-| +Initialises an `UnpackedLazyByteString` with a specified offset. +This offset varies as each lazy chunk is consumed. + +@since 1.0.0.0 +-} emptyUnpackedLazyByteString :: Code Int# -> Code UnpackedLazyByteString emptyUnpackedLazyByteString qi# = [|| (# $$(qi#), nullAddr#, error "nullForeignPtr", 0#, 0#, Lazy.Empty #) ||] {- Representation Mappings -} --- When a new input type is added here, it needs an Input instance in Parsley.Backend.Machine +-- NOTE: When a new input type is added here, it needs an Input instance in Parsley.Backend.Machine +{-| +The representation type of an input `Rep`, does not have to be a lifted type. To match a +representation of an input with the correct kind, this type family must be used. + +@since 1.0.0.0 +-} type RepKind :: Type -> RuntimeRep type family RepKind input where - RepKind [Char] = IntRep + RepKind [Char] = IntRep RepKind (UArray Int Char) = IntRep RepKind Text16 = IntRep RepKind ByteString = IntRep @@ -66,6 +118,13 @@ --RepKind (OffWithStreamAnd _) = 'TupleRep '[IntRep, LiftedRep, LiftedRep] --REMOVE --RepKind (Text, Stream) = 'TupleRep '[LiftedRep, LiftedRep] --REMOVE +{-| +This type family relates a user input type with the underlying parsley +representation, which is significantly more efficient to work with. +Most parts of the machine work with `Rep`. + +@since 1.0.0.0 +-} type Rep :: forall (rep :: Type) -> TYPE (RepKind rep) type family Rep input where Rep [Char] = Int# @@ -80,25 +139,55 @@ --Rep (Text, Stream) = (# Text, Stream #) {- Generic Representation Operations -} +{-| +Verifies that two `Int#`s are equal. + +@since 1.0.0.0 +-} intSame :: Code Int# -> Code Int# -> Code Bool intSame qi# qj# = [||isTrue# ($$(qi#) ==# $$(qj#))||] +{-| +Is the first argument is less than the second? + +@since 1.0.0.0 +-} intLess :: Code Int# -> Code Int# -> Code Bool intLess qi# qj# = [||isTrue# ($$(qi#) <# $$(qj#))||] +{-| +Extracts the offset from `Text`. + +@since 1.0.0.0 +-} offsetText :: Code Text -> Code Int offsetText qt = [||case $$qt of Text _ off _ -> off||] -offWithSame :: Code (# Int#, ts #) -> Code (# Int#, ts #) -> Code Bool +{-| +Compares the bundled offsets of two `OffWith`s are equal: does not +need to inspect the corresponding input. + +@since 1.0.0.0 +-} +offWithSame :: Code (OffWith ts) -> Code (OffWith ts) -> Code Bool offWithSame qi# qj# = [|| case $$(qi#) of (# i#, _ #) -> case $$(qj#) of (# j#, _ #) -> $$(intSame [||i#||] [||j#||]) ||] -offWithShiftRight :: Code (Int -> ts -> ts) -> Code (# Int#, ts #) -> Code Int# -> Code (# Int#, ts #) +{-| +Shifts an `OffWith` to the right, taking care to also drop tokens from the +companion input. + +@since 1.0.0.0 +-} +offWithShiftRight :: Code (Int -> ts -> ts) -- ^ A @drop@ function for underlying input. + -> Code (OffWith ts) -- ^ The `OffWith` to shift. + -> Code Int# -- ^ How much to shift by. + -> Code (OffWith ts) offWithShiftRight drop qo# qi# = [|| - case $$(qo#) of (# o#, ts #) -> (# (o# +# $$(qi#)), ($$drop (I# $$(qi#)) ts) #) + case $$(qo#) of (# o#, ts #) -> (# o# +# $$(qi#), $$drop (I# $$(qi#)) ts #) ||] {-offWithStreamAnd :: ts -> OffWithStreamAnd ts @@ -107,10 +196,20 @@ offWithStreamAndToInt :: OffWithStreamAnd ts -> Int offWithStreamAndToInt (OffWithStreamAnd i _ _) = i-} +{-| +Drops tokens off of a `Stream`. + +@since 1.0.0.0 +-} dropStream :: Int -> Stream -> Stream dropStream 0 cs = cs dropStream n (_ :> cs) = dropStream (n-1) cs +{-| +Drops tokens off of `Text`. + +@since 1.0.0.0 +-} textShiftRight :: Text -> Int -> Text textShiftRight (Text arr off unconsumed) i = go i off unconsumed where @@ -120,6 +219,11 @@ in go (n-1) (off'+d) (unconsumed'-d) | otherwise = Text arr off' unconsumed' +{-| +Rewinds input consumption on `Text` where the input is still available (i.e. in the same chunk). + +@since 1.0.0.0 +-} textShiftLeft :: Text -> Int -> Text textShiftLeft (Text arr off unconsumed) i = go i off unconsumed where @@ -132,6 +236,11 @@ emptyUnpackedLazyByteString' :: Int# -> UnpackedLazyByteString emptyUnpackedLazyByteString' i# = (# i#, nullAddr#, error "nullForeignPtr", 0#, 0#, Lazy.Empty #) +{-| +Drops tokens off of a lazy `Lazy.ByteString`. + +@since 1.0.0.0 +-} byteStringShiftRight :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString byteStringShiftRight (# i#, addr#, final, off#, size#, cs #) j# | isTrue# (j# <# size#) = (# i# +# j#, addr#, final, off# +# j#, size# -# j#, cs #) @@ -139,16 +248,31 @@ Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' -> byteStringShiftRight (# i# +# size#, addr'#, final', off'#, size'#, cs' #) (j# -# size#) Lazy.Empty -> emptyUnpackedLazyByteString' (i# +# size#) +{-| +Rewinds input consumption on a lazy `Lazy.ByteString` if input is still available (within the same chunk). + +@since 1.0.0.0 +-} byteStringShiftLeft :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString byteStringShiftLeft (# i#, addr#, final, off#, size#, cs #) j# = let d# = min# off# j# in (# i# -# d#, addr#, final, off# -# d#, size# +# d#, cs #) +{-| +Finds the minimum of two `Int#` values. + +@since 1.0.0.0 +-} min# :: Int# -> Int# -> Int# min# i# j# = case i# <# j# of 0# -> j# _ -> i# +{-| +Finds the maximum of two `Int#` values. + +@since 1.0.0.0 +-} max# :: Int# -> Int# -> Int# max# i# j# = case i# <# j# of 0# -> i# 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 @@ -1,237 +1,513 @@ {-# OPTIONS_GHC -Wno-monomorphism-restriction #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE AllowAmbiguousTypes, ConstrainedClassMethods, ConstraintKinds, - CPP, ImplicitParams, MagicHash, + NamedFieldPuns, PatternSynonyms, RecordWildCards, TypeApplications #-} -module Parsley.Internal.Backend.Machine.Ops (module Parsley.Internal.Backend.Machine.Ops) where - -import Control.Monad (liftM2) -import Control.Monad.Reader (ask, local) -import Control.Monad.ST (ST) -import Data.Array.Unboxed (UArray) -import Data.ByteString.Internal (ByteString) -import Data.STRef (writeSTRef, readSTRef, newSTRef) -import Data.Proxy (Proxy(Proxy)) -import Data.Text (Text) -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, _if, 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, 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)) - -import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString) - -#define inputInstances(derivation) \ -derivation([Char]) \ -derivation((UArray Int Char)) \ -derivation(Text16) \ -derivation(ByteString) \ -derivation(CharList) \ -derivation(Stream) \ -derivation(Lazy.ByteString) \ -derivation(Text) +{-| +Module : Parsley.Internal.Backend.Machine.Ops +Description : Higher-level operations used by evaluation. +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental -type Ops o = (HandlerOps o, JoinBuilder o, RecBuilder o, PositionOps o, MarshalOps o, LogOps (Rep o)) +This module contains all the relevant operations for the evaluation +of a machine. These are used by "Parsley.Internal.Backend.Machine.Eval" +to provide the various instruction interpretations. -{- Input Operations -} -sat :: (?ops :: InputOps (Rep o)) => (Defunc Char -> Defunc 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)) -sat p k bad γ@Γ{..} = next input $ \c input' -> let v = FREEVAR c in _if (p v) (k (γ {operands = Op v operands, input = input'})) bad +@since 1.0.0.0 +-} +module Parsley.Internal.Backend.Machine.Ops ( + -- * Core Machine Operations + dup, returnST, + -- ** Abstracted Input Operations + sat, emitLengthCheck, + -- ** Register Operations + newΣ, writeΣ, readΣ, + -- ** Handler Operations + -- *** Basic handlers and operations + fatal, raise, + -- *** Handler preparation + buildHandler, buildYesHandler, + -- *** Handler binding + bindAlwaysHandler, bindSameHandler, + -- ** Continuation Operations + -- *** Basic continuations and operations + halt, noreturn, + resume, callWithContinuation, + -- *** Continuation preparation + suspend, + -- ** Join Point Operations + setupJoinPoint, + -- ** Iteration Operations + buildIterAlways, + buildIterSame, + -- ** Recursion Operations + buildRec, + -- ** Marshalling Operations + dynHandler, dynCont, + -- ** Log Operations + logHandler, preludeString, + -- ** Convenience Types + Ops, LogHandler, StaHandlerBuilder, + -- * Re-exports from "Parsley.Internal.Backend.Machine.InputOps" + HandlerOps, JoinBuilder, RecBuilder, PositionOps, MarshalOps, LogOps + ) where -emitLengthCheck :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps o) => Int -> (Γ s o 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)) -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 γ) (liftTyped (n -# 1#))) then $$(good γ) - else $$bad ||] +import Control.Monad (liftM2) +import Control.Monad.Reader (ask, local) +import Control.Monad.ST (ST) +import Data.STRef (writeSTRef, readSTRef, newSTRef) +import Data.Void (Void) +import Debug.Trace (trace) +import GHC.Exts (Int(..), (-#)) +import Language.Haskell.TH.Syntax (liftTyped) +import Parsley.Internal.Backend.Machine.BindingOps +import Parsley.Internal.Backend.Machine.Defunc (Defunc(OFFSET), genDefunc, _if, 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) +import Parsley.Internal.Backend.Machine.Instructions (Access(..)) +import Parsley.Internal.Backend.Machine.LetBindings (Regs(..)) +import Parsley.Internal.Backend.Machine.Types (MachineMonad, Machine(..), run) +import Parsley.Internal.Backend.Machine.Types.Context +import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynCont, DynHandler) +import Parsley.Internal.Backend.Machine.Types.Offset (Offset(..), moveOne, mkOffset) +import Parsley.Internal.Backend.Machine.Types.State (Γ(..), OpStack(..)) +import Parsley.Internal.Backend.Machine.Types.Statics +import Parsley.Internal.Common (One, Code, Vec(..), Nat(..)) +import System.Console.Pretty (color, Color(Green, White, Red, Blue)) {- General Operations -} +{-| +Creates a let-binding that allows the same value to be +used multiple times without re-computation. + +@since 1.0.0.0 +-} dup :: Defunc x -> (Defunc x -> Code r) -> Code r dup (FREEVAR x) k = k (FREEVAR x) +dup (OFFSET o) k = k (OFFSET o) dup x k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||] +{-| +This is just plain ol' `return`. It is given a concrete +type here so that "Ambiuous Type Error" is avoided in the +generated code. + +@since 1.0.0.0 +-} {-# INLINE returnST #-} returnST :: forall s a. a -> ST s a returnST = return @(ST s) +{- Abstracted Input Operations -} +{-| +Given a predicate, a continuation that accepts an updated state `Γ`, +code to execute on failure, and a state @γ@, tries to read a character +from the input within @γ@, executing the failure code if it does not +exist or does not match. + +@since 1.0.0.0 +-} +sat :: (?ops :: InputOps (Rep o)) + => (Defunc Char -> Defunc Bool) -- ^ Predicate to test the character with. + -> (Γ s o (Char : xs) n r a -> Code b) -- ^ Code to execute with updated state on success. + -> Code b -- ^ Code to execute on any failure. + -> Γ s o xs n r a -- ^ State @γ@ which contains the input. + -> Code b +sat p k bad γ@Γ{..} = next (offset input) $ \c offset' -> let v = FREEVAR c in _if (p v) (k (γ {operands = Op v operands, input = moveOne input offset'})) bad + +{-| +Emits a length check for a number of characters \(n\) in the most efficient +way it can. It takes two continuations a @good@ and a @bad@: the @good@ is used +when the \(n\) characters are available and the @bad@ when they are not. + +@since 1.4.0.0 +-} +emitLengthCheck :: (?ops :: InputOps (Rep o), PositionOps (Rep o)) + => Int -- ^ The number of required characters \(n\). + -> Code a -- ^ The good continuation if \(n\) characters are available. + -> Code a -- ^ The bad continuation if the characters are unavailable. + -> Offset o -- ^ The input to test on. + -> Code a +emitLengthCheck 0 good _ _ = good +emitLengthCheck 1 good bad input = [|| if $$(more (offset input)) then $$good else $$bad ||] +emitLengthCheck (I# n) good bad input = [|| + if $$(more (shiftRight (offset input) (liftTyped (n -# 1#)))) then $$good + else $$bad ||] + {- Register Operations -} -newΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a)) -newΣ σ Soft x k ctx = dup x $ \dupx -> k $! insertNewΣ σ Nothing dupx ctx +{-| +Depending on the access type either generates the code for a new register and +registers it with the `Ctx`, or generates a binding with `dup` and registers +that in the `Ctx` cache. + +@since 1.0.0.0 +-} +newΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r) +newΣ σ Soft x k ctx = dup x $ \dupx -> k (insertNewΣ σ Nothing dupx ctx) newΣ σ Hard x k ctx = dup x $ \dupx -> [|| do ref <- newSTRef $$(genDefunc dupx) - $$(k $! insertNewΣ σ (Just [||ref||]) dupx ctx) + $$(k (insertNewΣ σ (Just [||ref||]) dupx ctx)) ||] -writeΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a)) -writeΣ σ Soft x k ctx = dup x $ \dupx -> k $! cacheΣ σ dupx ctx +{-| +Depending on the access type, either generates the code for a write to a register +(and caching that result) or updates the cache with the register's new value. + +@since 1.0.0.0 +-} +writeΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r) +writeΣ σ Soft x k ctx = dup x $ \dupx -> k (cacheΣ σ dupx ctx) writeΣ σ Hard x k ctx = let ref = concreteΣ σ ctx in dup x $ \dupx -> [|| do writeSTRef $$ref $$(genDefunc dupx) - $$(k $! cacheΣ σ dupx ctx) + $$(k (cacheΣ σ dupx ctx)) ||] -readΣ :: ΣVar x -> Access -> (Defunc x -> Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a)) -readΣ σ Soft k ctx = (k $! cachedΣ σ ctx) $! ctx +{-| +Depending on the access type, either generates a read from a register or fetches +the value from the cache and feeds it to a continuation. + +@since 1.0.0.0 +-} +readΣ :: ΣVar x -> Access -> (Defunc x -> Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r) +readΣ σ Soft k ctx = k (cachedΣ σ ctx) ctx readΣ σ Hard k ctx = let ref = concreteΣ σ ctx in [|| do x <- readSTRef $$ref - $$(let fv = FREEVAR [||x||] in k fv $! cacheΣ σ fv ctx) + $$(let fv = FREEVAR [||x||] in k fv (cacheΣ σ fv ctx)) ||] {- Handler Operations -} -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#}) - -fatal :: forall o s a. StaHandler s o a -fatal = mkStaHandler $ const [|| returnST Nothing ||] +-- Basic handlers and operations +{-| +This is the root-most handler, when it is executed the parser fails immediately +by returning @Nothing@. -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)) +@since 1.2.0.0 +-} +fatal :: StaHandler s o a +fatal = mkStaHandlerNoOffset (const [|| 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) +{-| +Fails by evaluating the next handler with the current input. Makes +use of `staHandlerEval` to make use of static information available +about the state of the input (since 1.4.0.0). +@since 1.0.0.0 +-} raise :: Γ s o xs (Succ n) r a -> Code (ST s (Maybe a)) -raise γ = let VCons h _ = handlers γ in staHandler# h (input γ) +raise γ = let VCons h _ = handlers γ in staHandlerEval h (input γ) -{- 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#}) +-- Handler preparation +{-| +Converts a partially evaluated parser into a handler: this is done by +completing the evaluation in the context of a future offset, and taking +a captured offset and pushing it to the stack. Returns a `StaHandlerBuilder`, +which takes the captured offset as the first argument. -halt :: forall o s a. StaCont s o a a -halt = mkStaCont $ \x _ -> [||returnST $! Just $$x||] +@since 1.2.0.0 +-} +buildHandler :: Γ s o xs n r a -- ^ State to execute the handler with. + -> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a))) -- ^ Partial parser accepting the modified state. + -> Word -- ^ The unique identifier for the offset on failure. + -> StaHandlerBuilder s o a +buildHandler γ h u c = mkStaHandler c $ \o# -> h (γ {operands = Op (OFFSET c) (operands γ), input = mkOffset o# u}) -noreturn :: forall o s a. StaCont s o a Void +{-| +Converts a partially evaluated parser into a "yes" handler: this means that +the handler /always/ knows that the inputs are equal, so does not require +both a captured and a current offset. Otherwise, is similar to `buildHandler`. + +@since 1.4.0.0 +-} +buildYesHandler :: Γ s o xs n r a + -> (Γ s o xs n r a -> Code (ST s (Maybe a))) + -> Word + -> StaHandler s o a +buildYesHandler γ h u = mkStaHandlerNoOffset $ \o# -> h (γ {input = mkOffset o# u}) + +-- Handler binding +{-| +Wraps around `bindHandler#` to create a binding for "always" handlers, which always +perform the same action regardless of if the captured and current offsets match or +not. + +@since 1.4.0.0 +-} +bindAlwaysHandler :: forall s o xs n r a b. HandlerOps o + => Γ s o xs n r a -- ^ The state from which to capture the offset. + -> StaHandlerBuilder s o a -- ^ The handler waiting to receive the captured offset and be bound. + -> (Γ s o xs (Succ n) r a -> Code b) -- ^ The parser to receive the binding. + -> Code b +bindAlwaysHandler γ h k = bindHandler# @o (staHandler# (h (input γ))) $ \qh -> + k (γ {handlers = VCons (mkStaHandlerDyn (Just (input γ)) qh) (handlers γ)}) + +{-| +Wraps around `bindHandler#` to create /three/ bindings for a handler that acts +differently depending on whether inputs match or not. The three bindings are +for the case where they are the same, the case where they differ, and the case +where they are unknown (which is defined in terms of the previous two). + +@since 1.4.0.0 +-} +bindSameHandler :: forall s o xs n r a b. (HandlerOps o, PositionOps (Rep o)) + => Γ s o xs n r a -- ^ The state from which to capture the offset. + -> StaHandler s o a -- ^ The handler that handles matching input. + -> StaHandlerBuilder s o a -- ^ The handler that handles mismatched input. + -> (Γ s o xs (Succ n) r a -> Code b) -- ^ The parser to receive the composite handler. + -> Code b +bindSameHandler γ yes no k = [|| + let yesSame = $$(staHandler# yes (offset (input γ))) + in $$(bindHandler# @o (staHandler# (no (input γ))) $ \qno -> + let handler = mkStaHandler (input γ) $ \o -> + [||if $$(same (offset (input γ)) o) then yesSame else $$qno $$o||] + in bindHandler# @o (staHandler# handler) $ \qhandler -> + k (γ {handlers = VCons (mkStaHandlerFull (input γ) qhandler [||yesSame||] qno) (handlers γ)})) + ||] + +{- Continuation Operations -} +-- Basic continuations and operations +{-| +The root-most return continuation, this is used when the top-level +parser returns: it returns the result with @Just@ and terminates +the entire parser. + +@since 1.2.0.0 +-} +halt :: StaCont s o a a +halt = mkStaCont $ \x _ -> [||returnST (Just $$x)||] + +{-| +This continuation is used for binding that never return, which is +enforced by the `Void` in the type. This signifies that a binding +may only exit on failure, which is the case with iterating parsers. + +@since 1.2.0.0 +-} +noreturn :: StaCont s o a Void noreturn = mkStaCont $ \_ _ -> [||error "Return is not permitted here"||] -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) +{-| +Executes a given continuation (which may be a return continuation or a +join point) taking the required components from the state `Γ`. +@since 1.2.0.0 +-} 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 γ) +resume k γ = let Op x _ = operands γ in staCont# k (genDefunc x) (offset (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 +{-| +A form of @callCC@, this calls a subroutine with a given return continuation +passed to it. This may be the current continuation, but also may just be a +previous return continuation in the case of a tail call. -class RecBuilder o where - 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 - -> DynFunc rs s o a r +@since 1.2.0.0 +-} +callWithContinuation :: MarshalOps o + => StaSubroutine s o a x -- ^ The subroutine @sub@ that will be called. + -> StaCont s o a x -- ^ The return continuation for the subroutine. + -> Code (Rep o) -- ^ The input to feed to @sub@. + -> Vec (Succ n) (StaHandler s o a) -- ^ The stack from which to obtain the handler to pass to @sub@. + -> Code (ST s (Maybe a)) +callWithContinuation sub ret input (VCons h _) = sub (dynCont ret) input (dynHandler h) -#define deriveJoinBuilder(_o) \ -instance JoinBuilder _o where \ -{ \ - setupJoinPoint φ (Machine k) mx = \ - liftM2 (\mk ctx γ -> [|| \ - let join x !(o# :: Rep _o) = \ - $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||o#||]})) \ - in $$(run mx γ (insertΦ φ (staCont @_o [||join||]) ctx)) \ - ||]) (local voidCoins k) ask; \ -}; -inputInstances(deriveJoinBuilder) +-- Continuation preparation +{-| +Converts a partial parser into a return continuation in a manner similar +to `buildHandler`. -#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) +@since 1.4.0.0 +-} +suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -- ^ The partial parser to turn into a return continuation. + -> Γ s o xs n r a -- ^ The state to execute the continuation with. + -> Word -- ^ The unique identifier to assign to the continuation's input. + -> StaCont s o a x +suspend m γ u = mkStaCont $ \x o# -> m (γ {operands = Op (FREEVAR x) (operands γ), input = mkOffset o# u}) +{- Join Point Operations -} +{-| +Wraps around `setupJoinPoint#` to make a join point and register it +into the `Ctx`. + +@since 1.4.0.0 +-} +setupJoinPoint :: forall s o xs n r a x. JoinBuilder o + => ΦVar x -- ^ The name of the binding. + -> Machine s o (x : xs) n r a -- ^ The definition of the binding. + -> Machine s o xs n r a -- ^ The scope within which the binding is valid. + -> MachineMonad s o xs n r a +setupJoinPoint φ (Machine k) mx = freshUnique $ \u -> + liftM2 (\mk ctx γ -> + setupJoinPoint# @o + (\qx qo# -> mk (γ {operands = Op (FREEVAR qx) (operands γ), input = mkOffset qo# u})) + (\qjoin -> run mx γ (insertΦ φ (mkStaContDyn qjoin) ctx))) + (local voidCoins k) ask + +{- Iteration Operations -} +{-| +Uses `bindIterHandler#` and `bindIter#` to create an iterated parser +from its loop body and return continuation. The exit of a loop is done +using failure, and this failure does not discriminate whether or not +the loop consumed input in its final iteration. + +@since 1.4.0.0 +-} +buildIterAlways :: forall s o a. RecBuilder o + => Ctx s o a -- ^ The context to keep the binding + -> MVar Void -- ^ The name of the binding. + -> Machine s o '[] One Void a -- ^ The body of the loop. + -> StaHandlerBuilder s o a -- ^ What to do after the loop exits (by failing) + -> Offset o -- ^ The initial offset to provide to the loop + -> Word -- ^ The unique name for captured offset /and/ iteration offset + -> Code (ST s (Maybe a)) +buildIterAlways ctx μ l h o u = + bindIterHandler# @o (\qc# -> staHandler# (h (mkOffset qc# u))) $ \qhandler -> + bindIter# @o (offset o) $ \qloop qo# -> + let off = mkOffset qo# u + in run l (Γ Empty noreturn off (VCons (mkStaHandlerDyn (Just off) [||$$qhandler $$(qo#)||]) VNil)) + (voidCoins (insertSub μ (\_ o# _ -> [|| $$qloop $$(o#) ||]) ctx)) + +{-| +Similar to `buildIterAlways`, but builds a handler that performs in +the same way as `bindSameHandler`. + +@since 1.4.0.0 +-} +buildIterSame :: forall s o a. (RecBuilder o, HandlerOps o, PositionOps (Rep o)) + => Ctx s o a -- ^ The context to store the binding in. + -> MVar Void -- ^ The name of the binding. + -> Machine s o '[] One Void a -- ^ The loop body. + -> StaHandler s o a -- ^ The handler when input is the same. + -> StaHandlerBuilder s o a -- ^ The handler when input differs. + -> Offset o -- ^ The initial offset of the loop. + -> Word -- ^ The unique name of the captured offsets /and/ the iteration offset. + -> Code (ST s (Maybe a)) +buildIterSame ctx μ l yes no o u = + bindHandler# @o (staHandler# yes) $ \qyes -> + bindIterHandler# @o (\qc# -> staHandler# (no (mkOffset qc# u))) $ \qno -> + let handler qc# = mkStaHandler (mkOffset @o qc# u) $ \o -> + [||if $$(same qc# o) then $$qyes $$(qc#) else $$qno $$(qc#) $$o||] + in bindIterHandler# @o (staHandler# . handler) $ \qhandler -> + bindIter# @o (offset o) $ \qloop qo# -> + let off = mkOffset qo# u + in run l (Γ Empty noreturn off (VCons (mkStaHandlerFull off [||$$qhandler $$(qo#)||] [||$$qyes $$(qo#)||] [||$$qno $$(qo#)||]) VNil)) + (voidCoins (insertSub μ (\_ o# _ -> [|| $$qloop $$(o#) ||]) ctx)) + +{- Recursion Operations -} +{-| +Wraps around `bindRec#` to produce a recursive parser binding. This function +also provides all the free-registers which are closed over by the binding. +This eliminates recursive calls from having to pass all of the same registers +each time round. + +@since 1.4.0.0 +-} +buildRec :: forall rs s o a r. RecBuilder o + => MVar r -- ^ The name of the binding. + -> Regs rs -- ^ The registered required by the binding. + -> Ctx s o a -- ^ The context to re-insert the register-less binding + -> Machine s o '[] One r a -- ^ The body of the binding. + -> DynFunc rs s o a r +buildRec μ rs ctx k = + takeFreeRegisters rs ctx $ \ctx -> + bindRec# @o $ \qself qret qo# qh -> + run k (Γ Empty (mkStaContDyn qret) (mkOffset qo# 0) (VCons (mkStaHandlerDyn Nothing qh) VNil)) + (insertSub μ (\k o# h -> [|| $$qself $$k $$(o#) $$h ||]) (nextUnique ctx)) + {- 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 +{-| +Wraps around `dynHandler#`, but ensures that if the `StaHandler` +originated from a `DynHandler` itself, that no work is performed. -staHandler :: forall o s a. DynHandler s o a -> StaHandler s o a -staHandler dh = StaHandler (\o# -> [|| $$dh $$(o#) ||]) (Just dh) +@since 1.4.0.0 +-} +dynHandler :: forall s o a. MarshalOps o => StaHandler s o a -> DynHandler s o a +dynHandler sh@(StaHandler _ _ Nothing) = dynHandler# @o (staHandler# sh) +dynHandler (StaHandler _ _ (Just dh)) = 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) +{-| +Wraps around `dynCont#`, but ensures that if the `StaCont` +originated from a `DynCont` itself, that no work is performed. -#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) +@since 1.4.0.0 +-} +dynCont :: forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x +dynCont (StaCont sk Nothing) = dynCont# @o sk +dynCont (StaCont _ (Just dk)) = dk -{- Debugger Operations -} -type LogHandler o = (PositionOps o, LogOps (Rep o)) +{- Log Operations =-} +{-| +The specialised handler for the @debug@ combinator. It will fail again after +having printed the debug information. -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#) +@since 1.2.0.0 +-} +logHandler :: (?ops :: InputOps (Rep o), LogHandler o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Word -> StaHandlerBuilder s o a +logHandler name ctx γ u o = let VCons h _ = handlers γ in mkStaHandler o $ \o# -> [|| + trace $$(preludeString name '<' (γ {input = mkOffset o# u}) 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 +{-| +Used for the debug instructions and handler, produces the debugging information +string. + +@since 1.2.0.0 +-} +preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), LogHandler o) + => String -- ^ The name as per the debug combinator + -> Char -- ^ Either @<@ or @>@ depending on whether we are entering or leaving. + -> Γ s o xs n r a + -> Ctx s o a + -> String -- ^ String that represents the current status + -> Code String preludeString name dir γ ctx ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||] where - offset = input γ - proxy = Proxy @o - indent = replicate (debugLevel ctx * 2) ' ' - start = shiftLeft offset [||5#||] - end = shiftRight proxy offset [||5#||] - inputTrace = [|| let replace '\n' = color Green "↙" - replace ' ' = color White "·" - replace c = return c - go i# - | $$(same proxy [||i#||] end) || not ($$more i#) = [] - | otherwise = $$(next [||i#||] (\qc qi' -> [||replace $$qc ++ go $$qi'||])) - in go $$start ||] - 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)) ' ' ||] + Offset {offset} = input γ + indent = replicate (debugLevel ctx * 2) ' ' + start = shiftLeft offset [||5#||] + end = shiftRight offset [||5#||] + inputTrace = [|| let replace '\n' = color Green "↙" + replace ' ' = color White "·" + replace c = return c + go i# + | $$(same [||i#||] end) || not $$(more [||i#||]) = [] + | otherwise = $$(next [||i#||] (\qc qi' -> [||replace $$qc ++ go $$qi'||])) + in go $$start ||] + 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)) ' ' ||] --- RIP Dream :( -{-$(let derive _o = [d| - instance HandlerOps _o where - fatal = [||\(!o#) -> return Nothing :: ST s (Maybe a)||] - |] in traverse derive representationTypes)-} +{- Convenience Types -} +{-| +A convience bundle of all of the type class constraints. + +@since 1.0.0.0 +-} +type Ops o = + ( HandlerOps o + , JoinBuilder o + , RecBuilder o + , PositionOps (Rep o) + , MarshalOps o + , LogOps (Rep o) + ) + +{-| +The constraints needed to build a `logHandler`. + +@since 1.0.0.0 +-} +type LogHandler o = (PositionOps (Rep o), LogOps (Rep o)) + +{-| +A `StaHandler` that has not yet captured its offset. + +@since 1.2.0.0 +-} +type StaHandlerBuilder s o a = Offset o -> StaHandler s o a diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs deleted file mode 100644 --- a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/State.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE DeriveAnyClass, - ExistentialQuantification, - MagicHash, - TypeFamilies, - DerivingStrategies #-} -module Parsley.Internal.Backend.Machine.State ( - StaHandler(..), StaCont(..), StaSubRoutine, staHandler#, mkStaHandler, staCont#, mkStaCont, - DynHandler, DynCont, DynSubRoutine, DynFunc, - MachineMonad, Func, - Γ(..), Ctx, OpStack(..), - QSubRoutine, QJoin(..), Machine(..), - run, - emptyCtx, - insertSub, insertΦ, insertNewΣ, cacheΣ, concreteΣ, cachedΣ, qSubRoutine, - takeFreeRegisters, - askSub, askΦ, - debugUp, debugDown, debugLevel, - storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins, - hasCoin, isBankrupt, liquidate - ) where - -import Control.Exception (Exception, throw) -import Control.Monad (liftM2) -import Control.Monad.Reader (asks, MonadReader, Reader, runReader) -import Control.Monad.ST (ST) -import Data.STRef (STRef) -import Data.Dependent.Map (DMap) -import Data.Kind (Type) -import Data.Maybe (fromMaybe) -import Parsley.Internal.Backend.Machine.Defunc (Defunc) -import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΣVar(..), ΦVar, IMVar, IΣVar) -import Parsley.Internal.Backend.Machine.InputRep (Rep) -import Parsley.Internal.Backend.Machine.LetBindings (Regs(..)) -import Parsley.Internal.Common (Queue, enqueue, dequeue, Code, Vec) - -import qualified Data.Dependent.Map as DMap ((!), insert, empty, lookup) -import qualified Parsley.Internal.Common.Queue as Queue (empty, null, foldr) - -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 (r : rs) s o a x = STRef s r -> Func rs 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)) -run = flip . runReader . getMachine - -data OpStack xs where - Empty :: OpStack '[] - Op :: Defunc x -> OpStack xs -> OpStack (x ': xs) - -data Reg s x = Reg { getReg :: Maybe (Code (STRef s x)) - , getCached :: Maybe (Defunc x) } - -data Γ s o xs n r a = Γ { operands :: OpStack xs - , retCont :: StaCont s o a r - , input :: Code (Rep o) - , 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) - , σs :: DMap ΣVar (Reg s) - , debugLevel :: Int - , coins :: Int - , piggies :: Queue Int } - -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 -> 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 -> 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 -insertNewΣ σ qref x ctx = ctx {σs = DMap.insert σ (Reg qref (Just x)) (σs ctx)} - -insertScopedΣ :: ΣVar x -> Code (STRef s x) -> Ctx s o a -> Ctx s o a -insertScopedΣ σ qref ctx = ctx {σs = DMap.insert σ (Reg (Just qref) Nothing) (σs ctx)} - -cacheΣ :: ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a -cacheΣ σ x ctx = case DMap.lookup σ (σs ctx) of - Just (Reg ref _) -> ctx {σs = DMap.insert σ (Reg ref (Just x)) (σs ctx)} - Nothing -> throw (outOfScopeRegister σ) - -concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x) -concreteΣ σ = fromMaybe (throw (intangibleRegister σ)) . (>>= getReg) . DMap.lookup σ . σs - -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 (StaSubRoutine s o a x) -askSub μ = - do QSubRoutine sub rs <- askSubUnbound μ - asks (provideFreeRegisters sub rs) - -askSubUnbound :: MonadReader (Ctx s o a) m => MVar x -> m (QSubRoutine s o a x) -askSubUnbound μ = asks (fromMaybe (throw (missingDependency μ)) . DMap.lookup μ . μs) - --- 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 - -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 -debugUp ctx = ctx {debugLevel = debugLevel ctx + 1} - -debugDown :: Ctx s o a -> Ctx s o a -debugDown ctx = ctx {debugLevel = debugLevel ctx - 1} - --- Piggy bank functions -storePiggy :: Int -> Ctx s o a -> Ctx s o a -storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx)} - -breakPiggy :: Ctx s o a -> Ctx s o a -breakPiggy ctx = let (coins, piggies') = dequeue (piggies ctx) in ctx {coins = coins, piggies = piggies'} - -hasCoin :: Ctx s o a -> Bool -hasCoin = (> 0) . coins - -isBankrupt :: Ctx s o a -> Bool -isBankrupt = liftM2 (&&) (not . hasCoin) (Queue.null . piggies) - -spendCoin :: Ctx s o a -> Ctx s o a -spendCoin ctx = ctx {coins = coins ctx - 1} - -giveCoins :: Int -> Ctx s o a -> Ctx s o a -giveCoins c ctx = ctx {coins = coins ctx + c} - -voidCoins :: Ctx s o a -> Ctx s o a -voidCoins ctx = ctx {coins = 0, piggies = Queue.empty} - -liquidate :: Ctx s o a -> Int -liquidate ctx = Queue.foldr (+) (coins ctx) (piggies ctx) - -newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception -newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Exception -newtype IntangibleRegister = IntangibleRegister IΣVar deriving anyclass Exception -newtype RegisterFault = RegisterFault IΣVar deriving anyclass Exception - -missingDependency :: MVar x -> MissingDependency -missingDependency (MVar v) = MissingDependency v -outOfScopeRegister :: ΣVar x -> OutOfScopeRegister -outOfScopeRegister (ΣVar σ) = OutOfScopeRegister σ -intangibleRegister :: ΣVar x -> IntangibleRegister -intangibleRegister (ΣVar σ) = IntangibleRegister σ -registerFault :: ΣVar x -> RegisterFault -registerFault (ΣVar σ) = RegisterFault σ - -instance Show MissingDependency where show (MissingDependency μ) = "Dependency μ" ++ show μ ++ " has not been compiled" -instance Show OutOfScopeRegister where show (OutOfScopeRegister σ) = "Register r" ++ show σ ++ " is out of scope" -instance Show IntangibleRegister where show (IntangibleRegister σ) = "Register r" ++ show σ ++ " is intangible in this scope" -instance Show RegisterFault where show (RegisterFault σ) = "Attempting to access register r" ++ show σ ++ " from cache has failed" diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types.hs @@ -0,0 +1,53 @@ +{-| +Module : Parsley.Internal.Backend.Machine.Types +Description : Core machine monads and re-exported internal types. +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the monadic machinery used in the evaluation of a parser +machine. It also rexports parts of @Base@ and @Statics@ for compatiblity with +the ghc 8.6+ backend, which shares common code for @LetRecBuilder.hs@. + +@since 1.4.0.0 +-} +module Parsley.Internal.Backend.Machine.Types ( + module Parsley.Internal.Backend.Machine.Types, + -- * Compatibility Re-exports + module Parsley.Internal.Backend.Machine.Types.Base, + module Parsley.Internal.Backend.Machine.Types.Statics + ) where + +import Control.Monad.Reader (Reader, runReader) +import Control.Monad.ST (ST) +import Parsley.Internal.Backend.Machine.Types.Base (Func) +import Parsley.Internal.Backend.Machine.Types.Context (Ctx) +import Parsley.Internal.Backend.Machine.Types.State (Γ) +import Parsley.Internal.Backend.Machine.Types.Statics (QSubroutine, qSubroutine) +import Parsley.Internal.Common.Utils (Code) + +{-| +The monad stack used to evaluate a parser machine, see `run`. + +@since 1.4.0.0 +-} +type MachineMonad s o xs n r a = Reader (Ctx s o a) (Γ s o xs n r a -> Code (ST s (Maybe a))) + +{-| +Wraps up the `MachineMonad` type so that it can serve as the carrier of `Parsley.Internal.Common.Indexed.cata4`. + +@since 1.4.0.0 +-} +newtype Machine s o xs n r a = Machine { getMachine :: MachineMonad s o xs n r a } + +{-| +Used to execute the evaluator for a parser machine, resulting in the final code +to be returned back to the User API. + +@since 1.4.0.0 +-} +run :: Machine s o xs n r a -- ^ The action that will generate the final code. + -> Γ s o xs n r a -- ^ The informaton that is threaded through the parsing machinery, which appears in some form in the generated code. + -> Ctx s o a -- ^ Static information used in the code generation process, but not in the generated code. + -> Code (ST s (Maybe a)) -- ^ The code that represents this parser (after having been given an input). +run = flip . runReader . getMachine diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Base.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Base.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Base.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE MagicHash, + TypeFamilies #-} +{-| +Module : Parsley.Internal.Backend.Machine.Types.Base +Description : Base types representing core machine components +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the core types of components that make up +the underlying machinery for compiled code. + +@since 1.4.0.0 +-} +module Parsley.Internal.Backend.Machine.Types.Base ( + module Parsley.Internal.Backend.Machine.Types.Base + ) where + +import Control.Monad.ST (ST) +import Data.STRef (STRef) +import Data.Kind (Type) +import Parsley.Internal.Backend.Machine.InputRep (Rep) + +{-| +@Handler#@ represents the functions that handle failure within a +parser. For most of their life, handlers are represented as +`Parsley.Internal.Backend.Machine.Types.Statics.StaHandler`, +but @Handler#@ is used at the boundaries, such as for recursion. + +@since 1.4.0.0 +-} +type Handler# s o a = Rep o -- ^ The current input on failure + -> ST s (Maybe a) + +{-| +@Cont#@ represents return continuation from recursive parsers. They +feed back their result @x@ back to the caller as well as the updated input. + +@since 1.4.0.0 +-} +type Cont# s o a x = x -- ^ The value to be returned to the caller + -> Rep o -- ^ The new input after the call is executed + -> ST s (Maybe a) + +{-| +@Subroutine#@ represents top-level parsers, which require a return continuation, +input, an error handler in order to produce (or contribute to) a result of type @a@. + +@since 1.4.0.0 +-} +type Subroutine# s o a x = Cont# s o a x -- ^ What to do when this parser returns + -> Rep o -- ^ The input on entry to the call + -> Handler# s o a -- ^ How to handle failure within the call + -> ST s (Maybe a) + +{-| +A @Func@ is a `Subroutine#` augmented with extra arguments with which to handle over +the required free-registers of the parser. These are registers that are not created +by the parser, but are used to execute it. + +@since 1.4.0.0 +-} +type family Func (rs :: [Type]) s o a x where + 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 diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE DeriveAnyClass, + MagicHash, + DerivingStrategies #-} +{-| +Module : Parsley.Internal.Backend.Machine.Types.Context +Description : Fully static context required to generate a parser +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the compile-time state of a parser, which is +used to aid code generation. + +@since 1.4.0.0 +-} +module Parsley.Internal.Backend.Machine.Types.Context ( + -- * Core Data-types + Ctx, + QJoin, + emptyCtx, + + -- * Subroutines + -- $sub-doc + insertSub, askSub, + + -- * Join Points + -- $join-doc + insertΦ, askΦ, + + -- * Registers + -- $reg-doc + + -- ** Putters + insertNewΣ, cacheΣ, + -- ** Getters + concreteΣ, cachedΣ, + takeFreeRegisters, + + -- * Debug Level Tracking + -- $debug-doc + debugUp, debugDown, debugLevel, + + -- * Unique Offsets + -- $offset-doc + freshUnique, nextUnique, + + -- * Token Credit System (Piggy-banks) + -- $piggy-doc + + -- ** Modifiers + storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, + -- ** Getters + coins, hasCoin, isBankrupt, liquidate + ) where + +import Control.Exception (Exception, throw) +import Control.Monad (liftM2, (<=<)) +import Control.Monad.Reader (asks, local, MonadReader) +import Data.STRef (STRef) +import Data.Dependent.Map (DMap) +import Data.Maybe (fromMaybe) +import Parsley.Internal.Backend.Machine.Defunc (Defunc) +import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΣVar(..), ΦVar, IMVar, IΣVar) +import Parsley.Internal.Backend.Machine.LetBindings (Regs(..)) +import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynSubroutine) +import Parsley.Internal.Backend.Machine.Types.Statics (QSubroutine(..), StaFunc, StaSubroutine, StaCont) +import Parsley.Internal.Common (Queue, enqueue, dequeue, Code) + +import qualified Data.Dependent.Map as DMap ((!), insert, empty, lookup) +import qualified Parsley.Internal.Common.Queue as Queue (empty, null, foldr) + +-- Core Data-types +{-| +The `Ctx` stores information that aids or facilitates the generation of parser code, +but its components are fully static and do not materialise as runtime values, but +may form part of the generated code. + +@since 1.0.0.0 +-} +data Ctx s o a = Ctx { μs :: DMap MVar (QSubroutine s o a) -- ^ Map of subroutine bindings. + , φs :: DMap ΦVar (QJoin s o a) -- ^ Map of join point bindings. + , σs :: DMap ΣVar (Reg s) -- ^ Map of available registers. + , debugLevel :: Int -- ^ Approximate depth of debug combinator. + , coins :: Int -- ^ Number of tokens free to consume without length check. + , offsetUniq :: Word -- ^ Next unique offset identifier. + , piggies :: Queue Int -- ^ Queue of future length check credit. + } + +{-| +`QJoin` represents Φ-nodes in the generated parser, and is represented +as a `Parsley.Internal.Backend.Machine.Types.Statics.StaCont`. + +@since 1.0.0.0 +-} +newtype QJoin s o a x = QJoin { unwrapJoin :: StaCont s o a x } + +{-| +Creates an empty `Ctx` populated with a map of the top-level (recursive) +bindings: information about their required free-registers is included. + +@since 1.0.0.0 +-} +emptyCtx :: DMap MVar (QSubroutine s o a) -> Ctx s o a +emptyCtx μs = Ctx μs DMap.empty DMap.empty 0 0 0 Queue.empty + +-- Subroutines +{- $sub-doc +Subroutines are the representations of let-bindings or recursive parsers +in the original user program. They are factored out to prevent code-explosion. + +The names of these bindings are helpfully stored within the `Ctx` and can be +accessed statically. While the initial context is always populated with the +top-level recursive bindings, additional bindings can be added "dynamically" +during evaluation, for instance iterative bindings and recursive bindings that +capture their free-registers. +-} +{-| +Registers a new subroutine into the context, which will be available +according to "local" @Reader@ semantics. + +@since 1.2.0.0 +-} +insertSub :: MVar x -- ^ The name of the binding. + -> StaSubroutine s o a x -- ^ The binding to register. + -> Ctx s o a -- ^ The current context. + -> Ctx s o a -- ^ The new context. +insertSub μ q ctx = ctx {μs = DMap.insert μ (QSubroutine q NoRegs) (μs ctx)} + +{-| +Fetches a binding from the context according to its name (See `Parsley.Internal.Core.Identifiers.MVar`). +In the (hopefully impossible!) event that it is not found in the map, will throw a @MissingDependency@ +exception. If this binding had free registers, these are generously provided by the `Ctx`. + +@since 1.2.0.0 +-} +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) + +askSubUnbound :: MonadReader (Ctx s o a) m => MVar x -> m (QSubroutine s o a x) +askSubUnbound μ = asks (fromMaybe (throw (missingDependency μ)) . DMap.lookup μ . μs) + +-- Join Points +{- $join-doc +Similar to the subroutines, join points (or Φ-nodes) are used by the parsley engine +to factor out common branches of code. When generated, access to these bindings is +available via the `Ctx`. +-} +{-| +Registers a new binding into the `Ctx` so that it can be retrieved later. Binding +expires according to "local" @Reader@ semantics. + +@since 1.0.0.0 +-} +insertΦ :: ΦVar x -- ^ The name of the new binding. + -> StaCont s o a x -- ^ The binding to add. + -> Ctx s o a -- ^ The old context. + -> Ctx s o a -- ^ The new context. +insertΦ φ qjoin ctx = ctx {φs = DMap.insert φ (QJoin qjoin) (φs ctx)} + +{-| +Fetches a binding from the `Ctx`. + +@since 1.2.0.0 +-} +askΦ :: MonadReader (Ctx s o a) m => ΦVar x -> m (StaCont s o a x) +askΦ φ = asks (unwrapJoin . (DMap.! φ) . φs) + +-- Registers +{- $reg-doc +Registers are used within parsley to persist state across different parts of a parser. +Across recursion and call-boundaries, these materialise as @STRef@s. These are stored +in the `Ctx` and can be looked up when required. + +However, parsley does not mandate that registers /must/ exist in this form. Registers +can be subject to caching, where a register's static "most-recently known" may be +stored within the `Ctx` in addition to the "true" binding. This can, in effect, mean +that registers do not exist at runtime. Both forms of register data can be extracted, +however exceptions will guard against mis-management. +-} +data Reg s x = Reg { getReg :: Maybe (Code (STRef s x)) -- ^ The "true" register + , getCached :: Maybe (Defunc x) } -- ^ The "most-recently known" value + +{-| +Registers a recently created register into the `Ctx`. This must be provided with +the original value in the register, which is injected into the cache. + +@since 1.0.0.0 +-} +insertNewΣ :: ΣVar x -- ^ The name of the register. + -> Maybe (Code (STRef s x)) -- ^ The runtime representation, if available. + -> Defunc x -- ^ The initial value stored into the register. + -> Ctx s o a -- ^ The old context. + -> Ctx s o a -- ^ The new context. +insertNewΣ σ qref x ctx = ctx {σs = DMap.insert σ (Reg qref (Just x)) (σs ctx)} + +{-| +Updated the "last-known value" of a register in the cache. + +@since 1.0.0.0 +-} +cacheΣ :: ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a +cacheΣ σ x ctx = case DMap.lookup σ (σs ctx) of + Just (Reg ref _) -> ctx {σs = DMap.insert σ (Reg ref (Just x)) (σs ctx)} + Nothing -> throw (outOfScopeRegister σ) + +{-| +Fetches a known to be concrete register (i.e. one that must be materialised +at runtime as an @STRef@). If this register does not exist, this throws an +@IntangibleRegister@ exception. + +@since 1.0.0.0 +-} +concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x) +concreteΣ σ = fromMaybe (throw (intangibleRegister σ)) . (getReg <=< DMap.lookup σ . σs) + +{-| +Fetches the cached "last-known value" of a register. If the cache is unaware of +this value, a @RegisterFault@ exception is thrown. + +@since 1.0.0.0 +-} +cachedΣ :: ΣVar x -> Ctx s o a -> Defunc x +cachedΣ σ = fromMaybe (throw (registerFault σ)) . (getCached <=< (DMap.lookup σ . σs)) + +{-| +When a binding is generated, it needs to generate function arguments for each of the +free registers it requires. This is performed by this function, which also adds each +of these freshly bound registers into the `Ctx`. Has the effect of converting a +`Parsley.Internal.Backend.Machine.Types.Dynamics.DynSubroutine` into a +`Parsley.Internal.Backend.Machine.Types.Dynamics.DynFunc`. + +@since 1.2.0.0 +-} +-- This needs to return a DynFunc: it is fed back to shared territory +takeFreeRegisters :: Regs rs -- ^ The free registers demanded by the binding. + -> Ctx s o a -- ^ The old context. + -> (Ctx s o a -> DynSubroutine s o a x) -- ^ Given the new context, function that produces the subroutine. + -> DynFunc rs s o a x -- ^ The newly produced dynamic function. +takeFreeRegisters NoRegs ctx body = body ctx +takeFreeRegisters (FreeReg σ σs) ctx body = [||\(!reg) -> $$(takeFreeRegisters σs (insertScopedΣ σ [||reg||] ctx) body)||] + +insertScopedΣ :: ΣVar x -> Code (STRef s x) -> Ctx s o a -> Ctx s o a +insertScopedΣ σ qref ctx = ctx {σs = DMap.insert σ (Reg (Just qref) Nothing) (σs ctx)} + +-- This needs to take a StaFunc, it is fed back via `askSub` +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 + +-- Debug Level Tracking +{- $debug-doc +The debug combinator generates runtime diagnostic information. To make this more ergonomic, +it would be nice to indent nested debug info. To do this perfectly, a debug level that controls +indentation would need to be added to `Parsley.Internal.Backend.Machine.Types.State.Γ`. This +is problematic since, without a lot of work and complexity, it would introduce a runtime penalty +for not just debug parsers, but all other parsers too. As a compromise, the debug level is stored +purely statically in the `Ctx`: the consequence is that the indentation level resets across a +call-boundary. +-} +{-| +Increase the debug level for the forseeable static future. + +@since 1.0.0.0 +-} +debugUp :: Ctx s o a -> Ctx s o a +debugUp ctx = ctx {debugLevel = debugLevel ctx + 1} + +{-| +Decrease the debug level for the forseeable static future. + +@since 1.0.0.0 +-} +debugDown :: Ctx s o a -> Ctx s o a +debugDown ctx = ctx {debugLevel = debugLevel ctx - 1} + +-- Unique Offsets +{- $offset-doc +The `Parsley.Internal.Backend.Machine.Types.Offset.Offset` type refines dynamic offsets +with statically known properties such as input consumed and the source of the offset. +These sources are unique and must be generated statically, with "local" @Reader@ semantics. +This means that the `Ctx` lends itself nicely to managing the pool of fresh offset names. +-} +{-| +Advances the unique identifier stored in the `Ctx`. This is used to /skip/ a given name. + +@since 1.4.0.0 +-} +nextUnique :: Ctx s o a -> Ctx s o a +nextUnique ctx = ctx {offsetUniq = offsetUniq ctx + 1} + +{-| +Generate a fresh name that is valid for the scope of the provided continuation. + +@since 1.4.0.0 +-} +freshUnique :: MonadReader (Ctx s o a) m => (Word -> m b) -> m b +freshUnique f = + do unique <- asks offsetUniq + local nextUnique (f unique) + +-- Token Credit System (Piggy-banks) +{- $piggy-doc +Parsley has analysis in place to factor out length checks when it is statically known that +/n/ tokens must be consumed in order for a parser to succeed. Part of this analysis is the +cut analysis performed in the frontend, and then the coins analysis in the backend during +code generation. The meta instructions that reference "coins" interact with a system during +interpretation called the "Piggy-bank" system: this is all stored and accessed via the `Ctx`. + +The system works like this: + +* The `Ctx` stores two components: some coins and some piggybanks. +* When there are coins present in the `Ctx`, these can be "spent" to read a token without + emitting a length check for it (the guarantee is that a length check was generated to + get hold of those coins). +* When the coins run out a piggy-bank can be broken to get more coins: this should generate + a length check for value of the coins in the bank +* When all the piggy-banks are exhausted, a length check must be generated for each + token that is consumed. +* When adding coins into the system, if the `Ctx` is bankrupt, then the coins are added + immediately along with a length check, otherwise a piggy-bank is added. + +These are the basic principles behind this system, and it works effectively. There are some +extra edge-case operations that are described in their corresponding documentation. The +reason why piggy-banks are stored in the context and /not/ consumed immediately to add to +the coin count is so that length checks are delayed to the last possible moment: you should +have used all of your current allocation before asking for more! +-} +{-| +Place a piggy-bank into the reserve, delaying the corresponding length check until it is +broken. + +@since 1.0.0.0 +-} +storePiggy :: Int -> Ctx s o a -> Ctx s o a +storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx)} + +{-| +Break the next piggy-bank in the queue, and fill the coins in return. + +__Note__: This should generate a length check when used! + +@since 1.0.0.0 +-} +breakPiggy :: Ctx s o a -> Ctx s o a +breakPiggy ctx = let (coins, piggies') = dequeue (piggies ctx) in ctx {coins = coins, piggies = piggies'} + +{-| +Does the context have coins available? + +@since 1.0.0.0 +-} +hasCoin :: Ctx s o a -> Bool +hasCoin = (> 0) . coins + +{-| +Is it the case that there are no coins /and/ no piggy-banks remaining? + +@since 1.0.0.0 +-} +isBankrupt :: Ctx s o a -> Bool +isBankrupt = liftM2 (&&) (not . hasCoin) (Queue.null . piggies) + +{-| +Spend a single coin, used when a token is consumed. + +@since 1.0.0.0 +-} +spendCoin :: Ctx s o a -> Ctx s o a +spendCoin ctx = ctx {coins = coins ctx - 1} + +{-| +Adds coins into the current supply. + +@since 1.0.0.0 +-} +giveCoins :: Int -> Ctx s o a -> Ctx s o a +giveCoins c ctx = ctx {coins = coins ctx + c} + +{-| +Removes all coins and piggy-banks, such that @isBankrupt == True@. + +@since 1.0.0.0 +-} +voidCoins :: Ctx s o a -> Ctx s o a +voidCoins ctx = ctx {coins = 0, piggies = Queue.empty} + +{-| +Collect all coins and the value of every piggy bank. + +This is used when a join-point is called, so that a length check can be +generated to cover the cost of the binding. + +@since 1.0.0.0 +-} +liquidate :: Ctx s o a -> Int +liquidate ctx = Queue.foldr (+) (coins ctx) (piggies ctx) + +-- Exceptions +newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception +newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Exception +newtype IntangibleRegister = IntangibleRegister IΣVar deriving anyclass Exception +newtype RegisterFault = RegisterFault IΣVar deriving anyclass Exception + +missingDependency :: MVar x -> MissingDependency +missingDependency (MVar v) = MissingDependency v +outOfScopeRegister :: ΣVar x -> OutOfScopeRegister +outOfScopeRegister (ΣVar σ) = OutOfScopeRegister σ +intangibleRegister :: ΣVar x -> IntangibleRegister +intangibleRegister (ΣVar σ) = IntangibleRegister σ +registerFault :: ΣVar x -> RegisterFault +registerFault (ΣVar σ) = RegisterFault σ + +instance Show MissingDependency where show (MissingDependency μ) = "Dependency μ" ++ show μ ++ " has not been compiled" +instance Show OutOfScopeRegister where show (OutOfScopeRegister σ) = "Register r" ++ show σ ++ " is out of scope" +instance Show IntangibleRegister where show (IntangibleRegister σ) = "Register r" ++ show σ ++ " is intangible in this scope" +instance Show RegisterFault where show (RegisterFault σ) = "Attempting to access register r" ++ show σ ++ " from cache has failed" diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Dynamics.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Dynamics.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Dynamics.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE MagicHash #-} +{-| +Module : Parsley.Internal.Backend.Machine.Types.Dynamics +Description : Representation of components that cross function boundaries +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the types that represent information that crosses +a function boundary. + +@since 1.4.0.0 +-} +module Parsley.Internal.Backend.Machine.Types.Dynamics ( + module Parsley.Internal.Backend.Machine.Types.Dynamics + ) where + +import Data.Kind (Type) +import Parsley.Internal.Backend.Machine.Types.Base (Handler#, Cont#, Subroutine#, Func) +import Parsley.Internal.Common.Utils (Code) + +{-| +Template Haskell representation of `Parsley.Internal.Backend.Machine.Types.Base.Handler#` + +@since 1.4.0.0 +-} +type DynHandler s o a = Code (Handler# s o a) + +{-| +Template Haskell representation of `Parsley.Internal.Backend.Machine.Types.Base.Cont#` + +@since 1.4.0.0 +-} +type DynCont s o a x = Code (Cont# s o a x) + +{-| +Template Haskell representation of `Parsley.Internal.Backend.Machine.Types.Base.Subroutine#` + +@since 1.4.0.0 +-} +type DynSubroutine s o a x = Code (Subroutine# s o a x) + +{-| +Template Haskell representation of `Parsley.Internal.Backend.Machine.Types.Base.Func#` + +@since 1.4.0.0 +-} +type DynFunc (rs :: [Type]) s o a x = Code (Func rs s o a x) diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Offset.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Offset.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Offset.hs @@ -0,0 +1,65 @@ +{-| +Module : Parsley.Internal.Backend.Machine.Types.Offset +Description : Statically refined offsets. +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the statically refined `Offset` type, +which can be used to reason about input in different parts of +a parser as it is evaluated. + +@since 1.4.0.0 +-} +module Parsley.Internal.Backend.Machine.Types.Offset (module Parsley.Internal.Backend.Machine.Types.Offset) where + +import Parsley.Internal.Backend.Machine.InputRep (Rep) +import Parsley.Internal.Common.Utils (Code) + +{-| +Augments a regular @'Code' ('Rep' o)@ with information about its origins and +how much input is known to have been consumed since it came into existence. +This can be used to statically evaluate handlers (see +`Parsley.Internal.Backend.Machine.Types.Statics.staHandlerEval`). + +@since 1.4.0.0 +-} +data Offset o = Offset { + -- | The underlying code that represents the current offset into the input. + offset :: Code (Rep o), + -- | The unique identifier that determines where this offset originated from. + unique :: Word, + -- | The amount of input that has been consumed on this offset since it was born. + moved :: Word + } +instance Show (Offset o) where show o = show (unique o) ++ "+" ++ show (moved o) + +{-| +Given two `Offset`s, this determines whether or not they represent the same +offset into the input stream at runtime. This comparison only makes sense when +both `Offset`s share the same origin, hence the @Maybe@. + +@since 1.4.0.0 +-} +same :: Offset o -> Offset o -> Maybe Bool +same o1 o2 + | unique o1 == unique o2 = Just (moved o1 == moved o2) + | otherwise = Nothing + +{-| +Updates an `Offset` with its new underlying representation of a real +runtime offset and records that another character has been consumed. + +@since 1.4.0.0 +-} +moveOne :: Offset o -> Code (Rep o) -> Offset o +moveOne off o = off { offset = o, moved = moved off + 1 } + +{-| +Makes a fresh `Offset` that has not had any input consumed off of it +yet. + +@since 1.4.0.0 +-} +mkOffset :: Code (Rep o) -> Word -> Offset o +mkOffset offset unique = Offset offset unique 0 diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/State.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/State.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/State.hs @@ -0,0 +1,48 @@ +{-| +Module : Parsley.Internal.Backend.Machine.Types.State +Description : Partially static components of a parser +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the runtime state of a parser, which is +is partially static, since there are many refinements that can be +used to improve it but ultimately, most of this exists at runtime +in some form or another. + +@since 1.4.0.0 +-} +module Parsley.Internal.Backend.Machine.Types.State ( + Γ(..), OpStack(..), + ) where + +import Parsley.Internal.Backend.Machine.Defunc (Defunc) +import Parsley.Internal.Backend.Machine.Types.Offset (Offset) +import Parsley.Internal.Backend.Machine.Types.Statics (StaCont, StaHandler) +import Parsley.Internal.Common.Vec (Vec) + +{-| +The stack that represents the applicative arguments to a parser. +These values, when converted to @Code@ will appear in the generated +code, but can be manipulated and combined using this stack, which will +not appear in the generated code. + +@since 1.4.0.0 +-} +data OpStack xs where + -- | The empty stack, with no operands available. + Empty :: OpStack '[] + -- | A pushed item on the stack, which takes the form of a defunctionalised value. + Op :: Defunc x -> OpStack xs -> OpStack (x ': xs) + +{-| +A record that bundles together all of the runtime components +of a parser in their variously statically augmented forms. + +@since 1.4.0.0 +-} +data Γ s o xs n r a = Γ { operands :: OpStack xs -- ^ The current values available for applicative application. + , retCont :: StaCont s o a r -- ^ The current return continuation when this parser is finished. + , input :: Offset o -- ^ The current offset into the input of the parser. + , handlers :: Vec n (StaHandler s o a) -- ^ The failure handlers that are used to process failure during a parser. + } diff --git a/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Statics.hs b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Statics.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Statics.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE AllowAmbiguousTypes, + MagicHash, + TypeApplications, + TypeFamilies #-} +{-| +Module : Parsley.Internal.Backend.Machine.Types.Statics +Description : Representation of components that exist within a statically known component +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module contains the types that represent statically known information that can be +refined and manipulated within a single compilation unit: i.e. not crossing recursion or +call boundaries. + +@since 1.4.0.0 +-} +module Parsley.Internal.Backend.Machine.Types.Statics ( + -- * Handlers + StaHandler#, StaHandler(..), + + -- ** @StaHandler@ Builders + -- | The following functions are builders of `StaHandler`. + mkStaHandler, mkStaHandlerNoOffset, mkStaHandlerDyn, mkStaHandlerFull, + + -- ** @StaHandler@ Interpreters + -- | The following functions interpret or extract information from `StaHandler`. + staHandler#, staHandlerEval, + + -- * Return Continuations + StaCont#, StaCont(..), + mkStaCont, mkStaContDyn, + staCont#, + + -- * Subroutines + QSubroutine(..), StaSubroutine, StaFunc, + qSubroutine + ) where + +import Control.Monad.ST (ST) +import Data.STRef (STRef) +import Data.Kind (Type) +import Data.Maybe (fromMaybe) +import Parsley.Internal.Backend.Machine.InputRep (Rep) +import Parsley.Internal.Backend.Machine.LetBindings (Regs(..)) +import Parsley.Internal.Backend.Machine.Types.Dynamics (DynCont, DynHandler, DynFunc) +import Parsley.Internal.Backend.Machine.Types.Offset (Offset(offset), same) +import Parsley.Internal.Common.Utils (Code) + +-- Handlers +{-| +This represents the translation of `Parsley.Internal.Backend.Machine.Types.Base.Handler#` +but where the static function structure has been exposed. This allows for β-reduction +on handlers, a simple form of inlining optimisation. + +@since 1.4.0.0 +-} +type StaHandler# s o a = Code (Rep o) -> Code (ST s (Maybe a)) + +mkStaHandler# :: forall o s a. DynHandler s o a -> StaHandler# s o a +mkStaHandler# dh qo# = [||$$dh $$(qo#)||] + +{-| +Compared with `StaHandler#`, this type allows for the encoding of various static +properties of handlers which can be carried around during the lifetime of the handlers. +This information allows the engine to optimise more aggressively, leveraging +domain-specific optimisation data. + +Note that @StaHandlerCase@ is not exposed, but is potentially three handlers: one for +unknown offset cases, one for offset known to be the same, and another for offset known +to be different (see `mkStaHandlerFull`). + +@since 1.4.0.0 +-} +data StaHandler s o a = + StaHandler + (Maybe (Offset o)) -- ^ The statically bound offset for this handler, if available. + {-# UNPACK #-} !(StaHandlerCase s o a) -- ^ The static function representing this handler when offsets are incomparable. + (Maybe (DynHandler s o a)) -- ^ The dynamic handler that has been wrapped in this handler, if available. + +{-| +Given a static handler, extracts the underlying handler which +has "forgotten" any static domain-specific information it had been +attached to. + +@since 1.4.0.0 +-} +staHandler# :: StaHandler s o a -> StaHandler# s o a +staHandler# (StaHandler _ sh _) = unknown sh + +_mkStaHandler :: Maybe (Offset o) -> StaHandler# s o a -> StaHandler s o a +_mkStaHandler o sh = StaHandler o (mkUnknown sh) Nothing + +{-| +Augments a `StaHandler#` with information about what the offset is that +the handler has captured. This is a purely static handler, which is not +derived from a dynamic one. + +@since 1.4.0.0 +-} +mkStaHandler :: Offset o -> StaHandler# s o a -> StaHandler s o a +mkStaHandler = _mkStaHandler . Just + +{-| +Converts a `StaHandler#` into a `StaHandler` without any information +about the captured offset. This is a purely static handler, not derived +from a dynamic one. + +@since 1.4.0.0 +-} +mkStaHandlerNoOffset :: StaHandler# s o a -> StaHandler s o a +mkStaHandlerNoOffset = _mkStaHandler Nothing + +{-| +Converts a `Parsley.Internal.Machine.Types.Dynamics.DynHandler` into a +`StaHandler` taking into account the possibility that captured offset +information is available. The dynamic handler used to construct this +static handler is maintained as the origin of the handler. This means +if it is converted back the conversion is free. + +@since 1.4.0.0 +-} +mkStaHandlerDyn :: forall s o a. Maybe (Offset o) -> DynHandler s o a -> StaHandler s o a +mkStaHandlerDyn c dh = StaHandler c (mkUnknown (mkStaHandler# @o dh)) (Just dh) + +{-| +When the behaviours of a handler given input that matches or does not match +its captured offset are known, this function can be used to construct a +`StaHandler` that stores this information. This can in turn be used in +conjunction with `staHandlerEval` to statically refine the application of +a handler to its argument. + +@since 1.4.0.0 +-} +mkStaHandlerFull :: forall s o a. Offset o -- ^ The offset captured by the creation of the handler. + -> DynHandler s o a -- ^ The full handler, which can be used when offsets are incomparable and must perform the check. + -> Code (ST s (Maybe a)) -- ^ The code that is executed when the captured offset matches the input. + -> DynHandler s o a -- ^ The handler to be executed when offsets are known not to match. + -> StaHandler s o a -- ^ A handler that carries this information around for later refinement. +mkStaHandlerFull c handler yes no = StaHandler (Just c) + (mkFull (mkStaHandler# @o handler) + yes + (mkStaHandler# @o no)) + (Just handler) + +{-| +Unlike `staHandler#`, which returns a handler that accepts @'Code' ('Rep' o)@, this +function accepts a full `Parsley.Internal.Backend.Machine.Types.Offset.Offset`, +which can be used to refine the outcome of the execution of the handler as follows: + + * If the handler has a registered captured offset, and these offsets are comparable: + + * If the offsets are equal, use the code to be executed on matching offset (See `mkStaHandlerFull`) + * If the offsets are not equal, invoke the sub-handler, skipping the if check (see `mkStaHandlerFull`) + + * If the handler is missing a captured offset, or they are incomparable (from different sources) + then execute the full handler, which will perform a runtime check for equivalence. + +@since 1.4.0.0 +-} +staHandlerEval :: StaHandler s o a -> Offset o -> Code (ST s (Maybe a)) +staHandlerEval (StaHandler (Just c) sh _) o + | Just True <- same c o = maybe (unknown sh) const (yesSame sh) (offset o) + | Just False <- same c o = fromMaybe (unknown sh) (notSame sh) (offset o) +staHandlerEval (StaHandler _ sh _) o = unknown sh (offset o) + +data StaHandlerCase s o a = StaHandlerCase { + -- | The static function representing this handler when offsets are incomparable. + unknown :: StaHandler# s o a, + -- | The static value representing this handler when offsets are known to match, if available. + yesSame :: Maybe (Code (ST s (Maybe a))), + -- | The static function representing this handler when offsets are known not to match, if available. + notSame :: Maybe (StaHandler# s o a) +} + +mkUnknown :: StaHandler# s o a -> StaHandlerCase s o a +mkUnknown h = StaHandlerCase h Nothing Nothing + +mkFull :: StaHandler# s o a -> Code (ST s (Maybe a)) -> StaHandler# s o a -> StaHandlerCase s o a +mkFull h yes no = StaHandlerCase h (Just yes) (Just no) + +-- Continuations +{-| +This represents the translation of `Parsley.Internal.Backend.Machine.Types.Base.Cont#` +but where the static function structure has been exposed. This allows for β-reduction +on continuations, a simple form of inlining optimisation. + +@since 1.4.0.0 +-} +type StaCont# s o a x = Code x -> Code (Rep o) -> Code (ST s (Maybe a)) + +{-| +Compared with `StaCont#`, this type also bundles the static continuation +with its dynamic origin, if available. + +@since 1.4.0.0 +-} +data StaCont s o a x = StaCont (StaCont# s o a x) (Maybe (DynCont s o a x)) + +{-| +Converts a `Parsley.Internal.Machine.Types.Dynamics.DynCont` into a +`StaCont`. The dynamic continuation used to construct this +static continuation is maintained as the origin of the continuation. This means +if it is converted back the conversion is free. + +@since 1.4.0.0 +-} +mkStaContDyn :: DynCont s o a x -> StaCont s o a x +mkStaContDyn dk = StaCont (\x o# -> [|| $$dk $$x $$(o#) ||]) (Just dk) + +{-| +Given a static continuation, extracts the underlying continuation which +has "forgotten" any static domain-specific information it had been +attached to. + +@since 1.4.0.0 +-} +staCont# :: StaCont s o a x -> StaCont# s o a x +staCont# (StaCont sk _) = sk + +{-| +Wraps a `StaCont#` up, under the knowledge that it is purely static and +not derived from any dynamic continuation. + +@since 1.4.0.0 +-} +mkStaCont :: StaCont# s o a x -> StaCont s o a x +mkStaCont sk = StaCont sk Nothing + +-- Subroutines +{-| +This represents the translation of `Parsley.Internal.Backend.Machine.Types.Base.Subroutine#` +but where the static function structure has been exposed. This allows for β-reduction +on subroutines, a simple form of inlining optimisation: useful for iteration. + +@since 1.4.0.0 +-} +type StaSubroutine s o a x = DynCont s o a x -> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a)) + +{-| +This represents the translation of `Parsley.Internal.Backend.Machine.Types.Base.Func` +but where the static function structure has been exposed. This allows for β-reduction +on subroutines with registers, a simple form of inlining optimisation. + +@since 1.4.0.0 +-} +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 + +{-| +Wraps a `StaFunc` with its free registers, which are kept existential. + +@since 1.4.0.0 +-} +data QSubroutine s o a x = forall rs. QSubroutine (StaFunc rs s o a x) (Regs rs) + +{-| +Converts a `Parsley.Internal.Backend.Machine.Types.Dynamics.DynFunc` that relies +on zero or more free registers into a `QSubroutine`, where the registers are +existentially bounds to the function. + +@since 1.4.0.0 +-} +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 ||] diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs --- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs @@ -9,7 +9,6 @@ -} module Parsley.Internal.Backend.Machine ( Input, eval, - PositionOps, module Parsley.Internal.Backend.Machine.Instructions, module Parsley.Internal.Backend.Machine.Defunc, module Parsley.Internal.Backend.Machine.Identifiers, @@ -20,9 +19,9 @@ import Data.ByteString (ByteString) import Data.Dependent.Map (DMap) import Data.Text (Text) -import Parsley.Internal.Backend.Machine.Defunc (Defunc(SAME), user, userBool) +import Parsley.Internal.Backend.Machine.Defunc (user, userBool) import Parsley.Internal.Backend.Machine.Identifiers -import Parsley.Internal.Backend.Machine.InputOps (InputPrep(..), PositionOps) +import Parsley.Internal.Backend.Machine.InputOps (InputPrep(..)) import Parsley.Internal.Backend.Machine.InputRep (Rep) import Parsley.Internal.Backend.Machine.Instructions import Parsley.Internal.Backend.Machine.LetBindings (LetBinding, makeLetBinding) diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs --- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs @@ -23,7 +23,7 @@ ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x)) ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c -ap2 f x y = ap (ap f x) y +ap2 f x = ap (ap f x) _if :: Defunc Bool -> Code a -> Code a -> Code a _if c t e = normaliseGen (Lam.If (unliftDefunc c) (Lam.Var False t) (Lam.Var False e)) 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 @@ -11,28 +11,31 @@ import Control.Monad (forM, liftM2) import Control.Monad.Reader (ask, asks, local) import Control.Monad.ST (runST) -import Parsley.Internal.Backend.Machine.Defunc (Defunc, pattern FREEVAR, genDefunc, ap, ap2, _if) +import Parsley.Internal.Backend.Machine.Defunc (Defunc(LAM, SAME), pattern FREEVAR, genDefunc, ap, ap2, _if) import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΦVar, ΣVar) import Parsley.Internal.Backend.Machine.InputOps (InputDependant(..), PositionOps, BoxOps, LogOps, InputOps(InputOps)) import Parsley.Internal.Backend.Machine.Instructions (Instr(..), MetaInstr(..), Access(..)) import Parsley.Internal.Backend.Machine.LetBindings (LetBinding(..)) import Parsley.Internal.Backend.Machine.LetRecBuilder import Parsley.Internal.Backend.Machine.Ops -import Parsley.Internal.Backend.Machine.State +import Parsley.Internal.Backend.Machine.Types.State import Parsley.Internal.Common (Fix4, cata4, One, Code, Vec(..), Nat(..)) import Parsley.Internal.Trace (Trace(trace)) import System.Console.Pretty (color, Color(Green)) +import Parsley.Internal.Core.Lam (Lam(Abs)) + import qualified Debug.Trace (trace) +import qualified Parsley.Internal.Backend.Machine.Instructions as Instructions (Handler(..)) eval :: forall o a. (Trace, Ops o) => Code (InputDependant o) -> LetBinding o a a -> DMap MVar (LetBinding o a) -> Code (Maybe a) -eval input (LetBinding !p _) fs = trace ("EVALUATING TOP LEVEL") [|| runST $ +eval input (LetBinding !p _) fs = trace "EVALUATING TOP LEVEL" [|| runST $ do let !(InputDependant next more offset) = $$input $$(let ?ops = InputOps [||more||] [||next||] in letRec fs nameLet (\μ exp rs names -> buildRec μ rs (emptyCtx names) (readyMachine exp)) - (\names -> run (readyMachine p) (Γ Empty (halt @o) [||offset||] (VCons (fatal @o) VNil)) (emptyCtx names))) + (run (readyMachine p) (Γ Empty (halt @o) [||offset||] (VCons (fatal @o) VNil)) . emptyCtx)) ||] where nameLet :: MVar x -> String @@ -51,12 +54,12 @@ alg (Sat p k) = evalSat p k alg Empt = evalEmpt alg (Commit k) = evalCommit k - alg (Catch k h) = evalCatch k h + alg (Catch k h) = evalCatch k (evalHandler h) alg (Tell k) = evalTell k alg (Seek k) = evalSeek k alg (Case p q) = evalCase p q alg (Choices fs ks def) = evalChoices fs ks def - alg (Iter μ l k) = evalIter μ l k + alg (Iter μ l k) = evalIter μ l (evalHandler k) alg (Join φ) = evalJoin φ alg (MkJoin φ p k) = evalMkJoin φ p k alg (Swap k) = evalSwap k @@ -92,7 +95,7 @@ hasChange <- asks hasCoin if | bankrupt -> maybeEmitCheck (Just 1) <$> k | hasChange -> maybeEmitCheck Nothing <$> local spendCoin k - | otherwise -> trace "I have a piggy :)" $ local breakPiggy (maybeEmitCheck . Just <$> asks coins <*> local spendCoin k) + | otherwise -> trace "I have a piggy :)" $ local breakPiggy (asks ((maybeEmitCheck . Just) . coins) <*> local spendCoin k) where maybeEmitCheck Nothing mk γ = sat (ap p) mk (raise γ) γ maybeEmitCheck (Just n) mk γ = @@ -107,6 +110,14 @@ evalCatch :: (BoxOps o, 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 +evalHandler :: PositionOps o => Instructions.Handler o (Machine s o) (o : xs) n r a -> Machine s o (o : xs) n r a +evalHandler (Instructions.Always k) = k +evalHandler (Instructions.Same yes no) = + Machine (evalDup ( + Machine (evalTell ( + Machine (evalLift2 SAME ( + Machine (evalChoices [LAM (Abs id)] [Machine (evalPop yes)] no))))))) + evalTell :: Machine s o (o : xs) n r a -> MachineMonad s o xs n r a evalTell (Machine k) = k <&> \mk γ -> mk (γ {operands = Op (FREEVAR (input γ)) (operands γ)}) @@ -148,15 +159,15 @@ in dup x $ \dupx -> mk (γ {operands = Op dupx (Op dupx xs)}) evalMake :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a -evalMake σ a k = asks $! \ctx γ -> +evalMake σ a k = asks $ \ctx γ -> let Op x xs = operands γ in newΣ σ a x (run k (γ {operands = xs})) ctx evalGet :: ΣVar x -> Access -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a -evalGet σ a k = asks $! \ctx γ -> readΣ σ a (\x -> run k (γ {operands = Op x (operands γ)})) ctx +evalGet σ a k = asks $ \ctx γ -> readΣ σ a (\x -> run k (γ {operands = Op x (operands γ)})) ctx evalPut :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a -evalPut σ a k = asks $! \ctx γ -> +evalPut σ a k = asks $ \ctx γ -> let Op x xs = operands γ in writeΣ σ a x (run k (γ {operands = xs})) ctx diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputOps.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputOps.hs --- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputOps.hs +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputOps.hs @@ -18,7 +18,7 @@ import GHC.Prim (indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#)) import Parsley.Internal.Backend.Machine.InputRep import Parsley.Internal.Common.Utils (Code) -import Parsley.Internal.Core.InputTypes +import Parsley.Internal.Core.InputTypes (Stream((:>)), CharList(..), Text16(..)) import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..)) --import qualified Data.Text as Text (length, index) @@ -85,10 +85,8 @@ prepare qinput = [|| let CharList input = $$qinput next (OffWith i (c:cs)) = (# c, OffWith (i+1) cs #) - size = length input - more (OffWith i _) = i < size - --more (OffWith _ []) = False - --more _ = True + more (OffWith _ []) = False + more _ = True in InputDependant next more ($$offWith input) ||] @@ -147,7 +145,7 @@ -- BoxOps Instances instance BoxOps Int where - box = [||\i# -> I# i#||] + box = [||I#||] unbox = [||\(I# i#) -> i#||] instance BoxOps (OffWith ts) where @@ -159,7 +157,7 @@ unbox = [||id||] instance BoxOps UnpackedLazyByteString where - box = [||\(!(# i#, addr#, final, off#, size#, cs #)) -> UnpackedLazyByteString (I# i#) addr# final (I# off#) (I# size#) cs||] + box = [||\(# i#, addr#, final, off#, size#, cs #) -> UnpackedLazyByteString (I# i#) addr# final (I# off#) (I# size#) cs||] unbox = [||\(UnpackedLazyByteString (I# i#) addr# final (I# off#) (I# size#) cs) -> (# i#, addr#, final, off#, size#, cs #)||] -- LogOps Instances diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputRep.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputRep.hs --- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputRep.hs +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputRep.hs @@ -1,5 +1,4 @@ {-# LANGUAGE MagicHash, - TypeFamilies, TypeFamilyDependencies, UnboxedTuples #-} module Parsley.Internal.Backend.Machine.InputRep ( @@ -119,7 +118,7 @@ | otherwise = Text arr off' unconsumed' byteStringShiftRight :: UnpackedLazyByteString -> Int -> UnpackedLazyByteString -byteStringShiftRight !(UnpackedLazyByteString i addr# final off size cs) j +byteStringShiftRight (UnpackedLazyByteString i addr# final off size cs) j | j < size = UnpackedLazyByteString (i + j) addr# final (off + j) (size - j) cs | otherwise = case cs of Lazy.Chunk (PS (ForeignPtr addr'# final') off' size') cs' -> byteStringShiftRight (UnpackedLazyByteString (i + size) addr'# final' off' size' cs') (j - size) 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 @@ -23,7 +23,7 @@ import Parsley.Internal.Backend.Machine.InputRep (Unboxed, OffWith, UnpackedLazyByteString, Stream{-, 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, +import Parsley.Internal.Backend.Machine.Types.State (Γ(..), Ctx, Handler, Machine(..), MachineMonad, Cont, Subroutine, OpStack(..), Func, run, voidCoins, insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, cachedΣ, concreteΣ, debugLevel) import Parsley.Internal.Common (One, Code, Vec(..), Nat(..)) import System.Console.Pretty (color, Color(Green, White, Red, Blue)) @@ -112,7 +112,7 @@ class BoxOps o => 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) resume :: Code (Cont s o a x) -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a)) - callWithContinuation :: Code (SubRoutine s o a x) -> Code (Cont s o a x) -> Code o -> Vec (Succ n) (Code (Handler s o a)) -> Code (ST s (Maybe a)) + callWithContinuation :: Code (Subroutine s o a x) -> Code (Cont s o a x) -> Code o -> Vec (Succ n) (Code (Handler s o a)) -> Code (ST s (Maybe a)) class ReturnOps o where halt :: Code (Cont s o a a) @@ -179,7 +179,7 @@ }; 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 :: 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)||] diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs deleted file mode 100644 --- a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/State.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE DeriveAnyClass, - ExistentialQuantification, - TypeFamilies, - DerivingStrategies #-} -module Parsley.Internal.Backend.Machine.State ( - HandlerStack, Handler, Cont, SubRoutine, MachineMonad, Func, - Γ(..), Ctx, OpStack(..), - QSubRoutine, QJoin(..), Machine(..), - run, - emptyCtx, - insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ, qSubRoutine, - askSub, askΦ, - debugUp, debugDown, debugLevel, - storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins, - hasCoin, isBankrupt, liquidate - ) where - -import Control.Exception (Exception, throw) -import Control.Monad (liftM2) -import Control.Monad.Reader (asks, MonadReader, Reader, runReader) -import Control.Monad.ST (ST) -import Data.STRef (STRef) -import Data.Dependent.Map (DMap) -import Data.Kind (Type) -import Data.Maybe (fromMaybe) -import Parsley.Internal.Backend.Machine.Defunc (Defunc) -import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΣVar(..), ΦVar, IMVar, IΣVar) -import Parsley.Internal.Backend.Machine.InputRep (Unboxed) -import Parsley.Internal.Backend.Machine.LetBindings (Regs(..)) -import Parsley.Internal.Common (Queue, enqueue, dequeue, Code, Vec) - -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 = Unboxed o -> ST s (Maybe a) -type Cont s o a x = x -> Unboxed o -> ST s (Maybe a) -type SubRoutine s o a x = Cont s o a x -> Unboxed 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))) - -type family Func (rs :: [Type]) s o a x where - 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) - -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 } - -run :: Machine s o xs n r a -> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a)) -run = flip . runReader . getMachine - -data OpStack xs where - Empty :: OpStack '[] - Op :: Defunc x -> OpStack xs -> OpStack (x ': xs) - -data Reg s x = Reg { getReg :: Maybe (Code (STRef s x)) - , getCached :: Maybe (Defunc x) } - -data Γ s o xs n r a = Γ { operands :: OpStack xs - , retCont :: Code (Cont s o a r) - , input :: Code o - , handlers :: HandlerStack n s o a } - -data Ctx s o a = Ctx { μs :: DMap MVar (QSubRoutine s o a) - , φs :: DMap ΦVar (QJoin s o a) - , σs :: DMap ΣVar (Reg s) - , debugLevel :: Int - , coins :: Int - , piggies :: Queue Int } - -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 μ 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Φ φ 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 -insertNewΣ σ qref x ctx = ctx {σs = DMap.insert σ (Reg qref (Just x)) (σs ctx)} - -insertScopedΣ :: ΣVar x -> Code (STRef s x) -> Ctx s o a -> Ctx s o a -insertScopedΣ σ qref ctx = ctx {σs = DMap.insert σ (Reg (Just qref) Nothing) (σs ctx)} - -cacheΣ :: ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a -cacheΣ σ x ctx = case DMap.lookup σ (σs ctx) of - Just (Reg ref _) -> ctx {σs = DMap.insert σ (Reg ref (Just x)) (σs ctx)} - Nothing -> throw (outOfScopeRegister σ) - -concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x) -concreteΣ σ = fromMaybe (throw (intangibleRegister σ)) . (>>= getReg) . DMap.lookup σ . σs - -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 μ = - do QSubRoutine sub rs <- askSubUnbound μ - asks (provideFreeRegisters sub rs) - -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) -provideFreeRegisters sub NoRegs _ = sub -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Φ φ = asks (unwrapJoin . (DMap.! φ) . φs) - -debugUp :: Ctx s o a -> Ctx s o a -debugUp ctx = ctx {debugLevel = debugLevel ctx + 1} - -debugDown :: Ctx s o a -> Ctx s o a -debugDown ctx = ctx {debugLevel = debugLevel ctx - 1} - --- Piggy bank functions -storePiggy :: Int -> Ctx s o a -> Ctx s o a -storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx)} - -breakPiggy :: Ctx s o a -> Ctx s o a -breakPiggy ctx = let (coins, piggies') = dequeue (piggies ctx) in ctx {coins = coins, piggies = piggies'} - -hasCoin :: Ctx s o a -> Bool -hasCoin = (> 0) . coins - -isBankrupt :: Ctx s o a -> Bool -isBankrupt = liftM2 (&&) (not . hasCoin) (Queue.null . piggies) - -spendCoin :: Ctx s o a -> Ctx s o a -spendCoin ctx = ctx {coins = coins ctx - 1} - -giveCoins :: Int -> Ctx s o a -> Ctx s o a -giveCoins c ctx = ctx {coins = coins ctx + c} - -voidCoins :: Ctx s o a -> Ctx s o a -voidCoins ctx = ctx {coins = 0, piggies = Queue.empty} - -liquidate :: Ctx s o a -> Int -liquidate ctx = Queue.foldr (+) (coins ctx) (piggies ctx) - -newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception -newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Exception -newtype IntangibleRegister = IntangibleRegister IΣVar deriving anyclass Exception -newtype RegisterFault = RegisterFault IΣVar deriving anyclass Exception - -missingDependency :: MVar x -> MissingDependency -missingDependency (MVar v) = MissingDependency v -outOfScopeRegister :: ΣVar x -> OutOfScopeRegister -outOfScopeRegister (ΣVar σ) = OutOfScopeRegister σ -intangibleRegister :: ΣVar x -> IntangibleRegister -intangibleRegister (ΣVar σ) = IntangibleRegister σ -registerFault :: ΣVar x -> RegisterFault -registerFault (ΣVar σ) = RegisterFault σ - -instance Show MissingDependency where show (MissingDependency μ) = "Dependency μ" ++ show μ ++ " has not been compiled" -instance Show OutOfScopeRegister where show (OutOfScopeRegister σ) = "Register r" ++ show σ ++ " is out of scope" -instance Show IntangibleRegister where show (IntangibleRegister σ) = "Register r" ++ show σ ++ " is intangible in this scope" -instance Show RegisterFault where show (RegisterFault σ) = "Attempting to access register r" ++ show σ ++ " from cache has failed" diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types.hs @@ -0,0 +1,5 @@ +module Parsley.Internal.Backend.Machine.Types ( + module Parsley.Internal.Backend.Machine.Types.State + ) where + +import Parsley.Internal.Backend.Machine.Types.State (Func, QSubroutine, qSubroutine) diff --git a/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types/State.hs b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types/State.hs new file mode 100644 --- /dev/null +++ b/src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types/State.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveAnyClass, + ExistentialQuantification, + TypeFamilies, + DerivingStrategies #-} +module Parsley.Internal.Backend.Machine.Types.State ( + HandlerStack, Handler, Cont, Subroutine, MachineMonad, Func, + Γ(..), Ctx, OpStack(..), + QSubroutine, QJoin(..), Machine(..), + run, + emptyCtx, + insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ, qSubroutine, + askSub, askΦ, + debugUp, debugDown, debugLevel, + storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins, + hasCoin, isBankrupt, liquidate + ) where + +import Control.Exception (Exception, throw) +import Control.Monad (liftM2, (<=<)) +import Control.Monad.Reader (asks, MonadReader, Reader, runReader) +import Control.Monad.ST (ST) +import Data.STRef (STRef) +import Data.Dependent.Map (DMap) +import Data.Kind (Type) +import Data.Maybe (fromMaybe) +import Parsley.Internal.Backend.Machine.Defunc (Defunc) +import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΣVar(..), ΦVar, IMVar, IΣVar) +import Parsley.Internal.Backend.Machine.InputRep (Unboxed) +import Parsley.Internal.Backend.Machine.LetBindings (Regs(..)) +import Parsley.Internal.Common (Queue, enqueue, dequeue, Code, Vec) + +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 = Unboxed o -> ST s (Maybe a) +type Cont s o a x = x -> Unboxed o -> ST s (Maybe a) +type Subroutine s o a x = Cont s o a x -> Unboxed 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))) + +type family Func (rs :: [Type]) s o a x where + 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) + +qSubroutine :: Code (Func rs s o a x) -> Regs rs -> QSubroutine s o a x +qSubroutine = QSubroutine + +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 } + +run :: Machine s o xs n r a -> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a)) +run = flip . runReader . getMachine + +data OpStack xs where + Empty :: OpStack '[] + Op :: Defunc x -> OpStack xs -> OpStack (x ': xs) + +data Reg s x = Reg { getReg :: Maybe (Code (STRef s x)) + , getCached :: Maybe (Defunc x) } + +data Γ s o xs n r a = Γ { operands :: OpStack xs + , retCont :: Code (Cont s o a r) + , input :: Code o + , handlers :: HandlerStack n s o a } + +data Ctx s o a = Ctx { μs :: DMap MVar (QSubroutine s o a) + , φs :: DMap ΦVar (QJoin s o a) + , σs :: DMap ΣVar (Reg s) + , debugLevel :: Int + , coins :: Int + , piggies :: Queue Int } + +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 μ 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Φ φ 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 +insertNewΣ σ qref x ctx = ctx {σs = DMap.insert σ (Reg qref (Just x)) (σs ctx)} + +insertScopedΣ :: ΣVar x -> Code (STRef s x) -> Ctx s o a -> Ctx s o a +insertScopedΣ σ qref ctx = ctx {σs = DMap.insert σ (Reg (Just qref) Nothing) (σs ctx)} + +cacheΣ :: ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a +cacheΣ σ x ctx = case DMap.lookup σ (σs ctx) of + Just (Reg ref _) -> ctx {σs = DMap.insert σ (Reg ref (Just x)) (σs ctx)} + Nothing -> throw (outOfScopeRegister σ) + +concreteΣ :: ΣVar x -> Ctx s o a -> Code (STRef s x) +concreteΣ σ = fromMaybe (throw (intangibleRegister σ)) . (getReg <=< DMap.lookup σ . σs) + +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 μ = + do QSubroutine sub rs <- askSubUnbound μ + asks (provideFreeRegisters sub rs) + +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) +provideFreeRegisters sub NoRegs _ = sub +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Φ φ = asks (unwrapJoin . (DMap.! φ) . φs) + +debugUp :: Ctx s o a -> Ctx s o a +debugUp ctx = ctx {debugLevel = debugLevel ctx + 1} + +debugDown :: Ctx s o a -> Ctx s o a +debugDown ctx = ctx {debugLevel = debugLevel ctx - 1} + +-- Piggy bank functions +storePiggy :: Int -> Ctx s o a -> Ctx s o a +storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx)} + +breakPiggy :: Ctx s o a -> Ctx s o a +breakPiggy ctx = let (coins, piggies') = dequeue (piggies ctx) in ctx {coins = coins, piggies = piggies'} + +hasCoin :: Ctx s o a -> Bool +hasCoin = (> 0) . coins + +isBankrupt :: Ctx s o a -> Bool +isBankrupt = liftM2 (&&) (not . hasCoin) (Queue.null . piggies) + +spendCoin :: Ctx s o a -> Ctx s o a +spendCoin ctx = ctx {coins = coins ctx - 1} + +giveCoins :: Int -> Ctx s o a -> Ctx s o a +giveCoins c ctx = ctx {coins = coins ctx + c} + +voidCoins :: Ctx s o a -> Ctx s o a +voidCoins ctx = ctx {coins = 0, piggies = Queue.empty} + +liquidate :: Ctx s o a -> Int +liquidate ctx = Queue.foldr (+) (coins ctx) (piggies ctx) + +newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception +newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Exception +newtype IntangibleRegister = IntangibleRegister IΣVar deriving anyclass Exception +newtype RegisterFault = RegisterFault IΣVar deriving anyclass Exception + +missingDependency :: MVar x -> MissingDependency +missingDependency (MVar v) = MissingDependency v +outOfScopeRegister :: ΣVar x -> OutOfScopeRegister +outOfScopeRegister (ΣVar σ) = OutOfScopeRegister σ +intangibleRegister :: ΣVar x -> IntangibleRegister +intangibleRegister (ΣVar σ) = IntangibleRegister σ +registerFault :: ΣVar x -> RegisterFault +registerFault (ΣVar σ) = RegisterFault σ + +instance Show MissingDependency where show (MissingDependency μ) = "Dependency μ" ++ show μ ++ " has not been compiled" +instance Show OutOfScopeRegister where show (OutOfScopeRegister σ) = "Register r" ++ show σ ++ " is out of scope" +instance Show IntangibleRegister where show (IntangibleRegister σ) = "Register r" ++ show σ ++ " is intangible in this scope" +instance Show RegisterFault where show (RegisterFault σ) = "Attempting to access register r" ++ show σ ++ " from cache has failed" diff --git a/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs b/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs --- a/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +++ b/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs @@ -1,14 +1,26 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# LANGUAGE PatternSynonyms #-} +{-| +Module : Parsley.Internal.Backend.CodeGenerator +Description : Translation of Combinator AST into Machine +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module exports `codeGen` used to translation from the high-level representation +to the low-level representation. + +@since 1.0.0.0 +-} module Parsley.Internal.Backend.CodeGenerator (codeGen) where import Data.Maybe (isJust) import Data.Set (Set, elems) import Control.Monad.Trans (lift) -import Parsley.Internal.Backend.Machine (Defunc(SAME), user, userBool, LetBinding, makeLetBinding, Instr(..), - _Fmap, _App, _Modify, _Get, _Put, _Make, _If, - addCoins, refundCoins, drainCoins, PositionOps, - IMVar, IΦVar, IΣVar, MVar(..), ΦVar(..), ΣVar(..)) +import Parsley.Internal.Backend.Machine (user, userBool, LetBinding, makeLetBinding, Instr(..), Handler(..), + _Fmap, _App, _Modify, _Get, _Put, _Make, + addCoins, refundCoins, drainCoins, + IMVar, IΦVar, IΣVar, MVar(..), ΦVar(..), ΣVar(..), SomeΣVar) import Parsley.Internal.Backend.InstructionAnalyser (coinsNeeded) import Parsley.Internal.Common.Fresh (VFreshT, HFresh, evalFreshT, evalFresh, construct, MonadFresh(..), mapVFreshT) import Parsley.Internal.Common.Indexed (Fix, Fix4(In4), Cofree(..), Nat(..), imap, histo, extract, (|>)) @@ -20,21 +32,29 @@ type CodeGenStack a = VFreshT IΦVar (VFreshT IMVar (HFresh IΣVar)) a runCodeGenStack :: CodeGenStack a -> IMVar -> IΦVar -> IΣVar -> a -runCodeGenStack m μ0 φ0 σ0 = - (flip evalFresh σ0 . - flip evalFreshT μ0 . - flip evalFreshT φ0) m +runCodeGenStack m μ0 φ0 = evalFresh (evalFreshT (evalFreshT m φ0) μ0) newtype CodeGen o a x = CodeGen {runCodeGen :: forall xs n r. Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)} +{-| +Translates a parser represented with combinators into its machine representation. + +@since 1.0.0.0 +-} {-# INLINEABLE codeGen #-} -codeGen :: (Trace, PositionOps o) => Maybe (MVar x) -> Fix Combinator x -> Set IΣVar -> IMVar -> IΣVar -> LetBinding o a x -codeGen letBound p rs μ0 σ0 = trace ("GENERATING " ++ name ++ ": " ++ show p ++ "\nMACHINE: " ++ show (map ΣVar (elems rs)) ++ " => " ++ show m) $ makeLetBinding m rs +codeGen :: Trace + => Maybe (MVar x) -- ^ The name of the parser, if it exists. + -> Fix Combinator x -- ^ The definition of the parser. + -> Set SomeΣVar -- ^ The free registers it requires to run. + -> IMVar -- ^ The binding identifier to start name generation from. + -> IΣVar -- ^ The register identifier to start name generation from. + -> LetBinding o a x +codeGen letBound p rs μ0 σ0 = trace ("GENERATING " ++ name ++ ": " ++ show p ++ "\nMACHINE: " ++ show (elems rs) ++ " => " ++ show m) $ makeLetBinding m rs where name = maybe "TOP LEVEL" show letBound m = finalise (histo alg p) - alg :: PositionOps o => Combinator (Cofree Combinator (CodeGen o a)) x -> CodeGen o a x + alg :: Combinator (Cofree Combinator (CodeGen o a)) x -> CodeGen o a x alg = deep |> (\x -> CodeGen (shallow (imap extract x))) finalise cg = let m = runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0 σ0 @@ -47,14 +67,14 @@ pattern TryOrElse :: k a -> k a -> Combinator (Cofree Combinator k) a pattern TryOrElse p q <- (_ :< Try (p :< _)) :<|>: (q :< _) -rollbackHandler :: Fix4 (Instr o) (o : xs) (Succ n) r a -rollbackHandler = In4 (Seek (In4 Empt)) +rollbackHandler :: Handler o (Fix4 (Instr o)) (o : xs) (Succ n) r a +rollbackHandler = Always (In4 (Seek (In4 Empt))) -parsecHandler :: PositionOps o => Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) (o : xs) (Succ n) r a -parsecHandler k = In4 (Tell (In4 (Lift2 SAME (In4 (_If k (In4 Empt)))))) +parsecHandler :: Fix4 (Instr o) xs (Succ n) r a -> Handler o (Fix4 (Instr o)) (o : xs) (Succ n) r a +parsecHandler k = Same k (In4 Empt) altNoCutCompile :: CodeGen o a y -> CodeGen o a x - -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) (o : xs) (Succ n) r a) + -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Handler o (Fix4 (Instr o)) (o : xs) (Succ n) r a) -> (forall n xs r. Fix4 (Instr o) (x : xs) n r a -> Fix4 (Instr o) (y : xs) n r a) -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a) altNoCutCompile p q handler post m = @@ -67,7 +87,7 @@ let dq = nq - min np nq return $! binder (In4 (Catch (addCoins dp pc) (handler (addCoins dq qc)))) -chainPreCompile :: PositionOps o => CodeGen o a (x -> x) -> CodeGen o a x +chainPreCompile :: CodeGen o a (x -> x) -> CodeGen o a x -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a) -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a) -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a) @@ -78,7 +98,7 @@ pc <- freshM (runCodeGen p (In4 (_App m))) return $! In4 (Push (user ID) (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preP pc))))))))) -chainPostCompile :: PositionOps o => CodeGen o a x -> CodeGen o a (x -> x) +chainPostCompile :: CodeGen o a x -> CodeGen o a (x -> x) -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a) -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a) -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a) @@ -88,11 +108,11 @@ opc <- freshM (runCodeGen op (In4 (_Modify σ (In4 (Jump μ))))) freshM (runCodeGen p (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preM m))))))))) -deep :: PositionOps o => Combinator (Cofree Combinator (CodeGen o a)) x -> Maybe (CodeGen o a x) +deep :: Combinator (Cofree Combinator (CodeGen o a)) x -> Maybe (CodeGen o a x) deep (f :<$>: (p :< _)) = Just $ CodeGen $ \m -> runCodeGen p (In4 (_Fmap (user f) m)) -deep (TryOrElse p q) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) id -deep ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) (In4 . Pop . In4 . Push (user x)) -deep ((_ :< (f :<$>: (_ :< Try (p :< _)))) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) (In4 . _Fmap (user f)) +deep (TryOrElse p q) = Just $ CodeGen $ altNoCutCompile p q (Always . In4 . Seek) id +deep ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (Always . In4 . Seek) (In4 . Pop . In4 . Push (user x)) +deep ((_ :< (f :<$>: (_ :< Try (p :< _)))) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (Always . In4 . Seek) (In4 . _Fmap (user f)) deep (MetaCombinator RequiresCut (_ :< ((p :< _) :<|>: (q :< _)))) = Just $ CodeGen $ \m -> do (binder, φ) <- makeΦ m pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ)) @@ -106,7 +126,7 @@ addCoinsNeeded :: Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a addCoinsNeeded = coinsNeeded >>= addCoins -shallow :: PositionOps o => Combinator (CodeGen o a) x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a) +shallow :: Combinator (CodeGen o a) x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a) shallow (Pure x) m = do return $! In4 (Push (user x) m) shallow (Satisfy p) m = do return $! In4 (Sat (userBool p) m) shallow (pf :<*>: px) m = do pxc <- runCodeGen px (In4 (_App m)); runCodeGen pf pxc @@ -122,7 +142,7 @@ do pc <- runCodeGen p (In4 (Pop (In4 (Seek (In4 (Commit (In4 Empt))))))) let np = coinsNeeded pc let nm = coinsNeeded m - return $! In4 (Catch (addCoins (max (np - nm) 0) (In4 (Tell pc))) (In4 (Seek (In4 (Push (user UNIT) m))))) + return $! In4 (Catch (addCoins (max (np - nm) 0) (In4 (Tell pc))) (Always (In4 (Seek (In4 (Push (user UNIT) m)))))) shallow (Branch b p q) m = do (binder, φ) <- makeΦ m pc <- freshΦ (runCodeGen p (In4 (Swap (In4 (_App φ))))) @@ -171,7 +191,7 @@ freshΦ = newScope makeΦ :: Fix4 (Instr o) (x ': xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a, Fix4 (Instr o) (x : xs) (Succ n) r a) -makeΦ m | elidable m = return $! (id, m) +makeΦ m | elidable m = return (id, m) where elidable :: Fix4 (Instr o) (x ': xs) (Succ n) r a -> Bool -- This is double-φ optimisation: If a φ-node points shallowly to another φ-node, then it can be elided diff --git a/src/ghc/Parsley/Internal/Backend/InstructionAnalyser.hs b/src/ghc/Parsley/Internal/Backend/InstructionAnalyser.hs --- a/src/ghc/Parsley/Internal/Backend/InstructionAnalyser.hs +++ b/src/ghc/Parsley/Internal/Backend/InstructionAnalyser.hs @@ -4,7 +4,7 @@ module Parsley.Internal.Backend.InstructionAnalyser (coinsNeeded, relevancy, Length) where import Data.Kind (Type) -import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..)) +import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..), Handler(..)) import Parsley.Internal.Common.Indexed (cata4, Fix4, Const4(..)) import Parsley.Internal.Common.Vec (Vec(..), Nat(..), SNat(..), SingNat(..), zipWithVec, replicateVec) @@ -29,12 +29,12 @@ alg (Jump _) = (0, False) alg Empt = (0, True) alg (Commit k) = getConst4 k - alg (Catch k h) = algCatch (getConst4 k) (getConst4 h) + alg (Catch k h) = algCatch (getConst4 k) (algHandler h) alg (Tell k) = getConst4 k alg (Seek k) = getConst4 k alg (Case p q) = algCatch (getConst4 p) (getConst4 q) alg (Choices _ ks def) = foldr (algCatch . getConst4) (getConst4 def) ks - alg (Iter _ _ (Const4 k)) = (0, snd k) + alg (Iter _ _ h) = (0, snd (algHandler h)) alg (Join _) = (0, False) alg (MkJoin _ (Const4 b) (Const4 k)) = (fst k + fst b, snd k || snd b) alg (Swap k) = getConst4 k @@ -48,6 +48,10 @@ alg (MetaInstr (RefundCoins n) (Const4 k)) = (max (fst k - n) 0, snd k) -- These were refunded, so deduct alg (MetaInstr (DrainCoins _) (Const4 k)) = (fst k, False) + algHandler :: Handler o (Const4 (Int, Bool)) xs n r a -> (Int, Bool) + algHandler (Same yes no) = algCatch (getConst4 yes) (getConst4 no) + algHandler (Always k) = getConst4 k + {- TODO Live Value Analysis ------------------- @@ -113,7 +117,7 @@ alg (Seek k) (SSucc n) = VCons True (getStack k n) alg (Case p q) n = VCons True (let VCons _ xs = zipRelevancy (getStack p n) (getStack q n) in xs) alg (Choices _ ks def) (SSucc n) = VCons True (foldr (zipRelevancy . (`getStack` n)) (getStack def n) ks) - alg (Iter _ _ k) n = let VCons _ xs = getStack k (SSucc n) in xs + alg (Iter _ _ h) n = let VCons _ xs = algHandler h (SSucc n) in xs alg (Join _) (SSucc n) = VCons True (replicateVec n False) alg (MkJoin _ b _) n = let VCons _ xs = getStack b (SSucc n) in xs alg (Swap k) n = let VCons rel1 (VCons rel2 xs) = getStack k n in VCons rel2 (VCons rel1 xs) @@ -124,3 +128,7 @@ alg (LogEnter _ k) n = getStack k n alg (LogExit _ k) n = getStack k n alg (MetaInstr _ k) n = getStack k n + + algHandler :: Handler o RelevancyStack xs n r a -> SNat (Length xs) -> Vec (Length xs) Bool + algHandler (Same yes no) (SSucc n) = VCons True (let VCons _ xs = zipRelevancy (VCons False (getStack yes n)) (getStack no (SSucc n)) in xs) + algHandler (Always k) n = getStack k n diff --git a/src/ghc/Parsley/Internal/Backend/Machine/Identifiers.hs b/src/ghc/Parsley/Internal/Backend/Machine/Identifiers.hs --- a/src/ghc/Parsley/Internal/Backend/Machine/Identifiers.hs +++ b/src/ghc/Parsley/Internal/Backend/Machine/Identifiers.hs @@ -1,6 +1,19 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-} +{-| +Module : Parsley.Internal.Backend.Machine.Identifiers +Description : Machine specific identifiers +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +This module extends "Parsley.Internal.Core.Identifiers" with +`ΦVar`, which is used for join points. Re-exports other +identifiers. + +@since 1.0.0.0 +-} module Parsley.Internal.Backend.Machine.Identifiers ( ΦVar(..), IΦVar, module Parsley.Internal.Core.Identifiers, @@ -13,7 +26,19 @@ import Parsley.Internal.Core.Identifiers -- for re-export import Unsafe.Coerce (unsafeCoerce) +{-| +Represents a join point which requires an argument +of type @a@. + +@since 1.0.0.0 +-} newtype ΦVar (a :: Type) = ΦVar IΦVar + +{-| +Underlying untyped identifier, which is numeric but otherwise opaque. + +@since 1.0.0.0 +-} newtype IΦVar = IΦVar Word64 deriving newtype (Ord, Eq, Num, Enum, Show) instance Show (ΦVar a) where show (ΦVar φ) = "φ" ++ show φ diff --git a/src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs b/src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs --- a/src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +++ b/src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs @@ -1,8 +1,32 @@ {-# LANGUAGE OverloadedStrings, PatternSynonyms, DerivingStrategies #-} -module Parsley.Internal.Backend.Machine.Instructions (module Parsley.Internal.Backend.Machine.Instructions) where +{-| +Module : Parsley.Internal.Backend.Machine.Instructions +Description : Core instructions that make up a low-level parser. +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental +This contains the instructions and satelite datatypes for representing +parsers at the lowest CPS-form level. These are indexed by multiple types, +which are documented in the source (if not on Haddock!). + +@since 1.0.0.0 +-} +module Parsley.Internal.Backend.Machine.Instructions ( + -- * Main Instructions + Instr(..), + -- * Auxilliary Types + Handler(..), + Access(..), + MetaInstr(..), + -- * Smart Instructions + _App, _Fmap, _Modify, _Make, _Put, _Get, + -- * Smart Meta-Instructions + addCoins, refundCoins, drainCoins + ) where + import Data.Kind (Type) import Data.Void (Void) import Parsley.Internal.Backend.Machine.Identifiers (MVar, ΦVar, ΣVar) @@ -11,73 +35,297 @@ import Parsley.Internal.Backend.Machine.Defunc as Machine (Defunc, user) import Parsley.Internal.Core.Defunc as Core (Defunc(ID), pattern FLIP_H) -data Instr (o :: Type) (k :: [Type] -> Nat -> Type -> Type -> Type) (xs :: [Type]) (n :: Nat) (r :: Type) (a :: Type) where - Ret :: Instr o k '[x] n x a - Push :: Machine.Defunc x -> k (x : xs) n r a -> Instr o k xs n r a - Pop :: k xs n r a -> Instr o k (x : xs) n r a - Lift2 :: Machine.Defunc (x -> y -> z) -> k (z : xs) n r a -> Instr o k (y : x : xs) n r a - Sat :: Machine.Defunc (Char -> Bool) -> k (Char : xs) (Succ n) r a -> Instr o k xs (Succ n) r a - Call :: MVar x -> k (x : xs) (Succ n) r a -> Instr o k xs (Succ n) r a - Jump :: MVar x -> Instr o k '[] (Succ n) x a - Empt :: Instr o k xs (Succ n) r a - Commit :: k xs n r a -> Instr o k xs (Succ n) r a - Catch :: k xs (Succ n) r a -> k (o : xs) n r a -> Instr o k xs n r a - Tell :: k (o : xs) n r a -> Instr o k xs n r a - Seek :: k xs n r a -> Instr o k (o : xs) n r a - Case :: k (x : xs) n r a -> k (y : xs) n r a -> Instr o k (Either x y : xs) n r a - Choices :: [Machine.Defunc (x -> Bool)] -> [k xs n r a] -> k xs n r a -> Instr o k (x : xs) n r a - Iter :: MVar Void -> k '[] One Void a -> k (o : xs) n r a -> Instr o k xs n r a - Join :: ΦVar x -> Instr o k (x : xs) n r a - MkJoin :: ΦVar x -> k (x : xs) n r a -> k xs n r a -> Instr o k xs n r a - Swap :: k (x : y : xs) n r a -> Instr o k (y : x : xs) n r a - Dup :: k (x : x : xs) n r a -> Instr o k (x : xs) n r a - Make :: ΣVar x -> Access -> k xs n r a -> Instr o k (x : xs) n r a - Get :: ΣVar x -> Access -> k (x : xs) n r a -> Instr o k xs n r a - Put :: ΣVar x -> Access -> k xs n r a -> Instr o k (x : xs) n r a - LogEnter :: String -> k xs (Succ (Succ n)) r a -> Instr o k xs (Succ n) r a - LogExit :: String -> k xs n r a -> Instr o k xs n r a - MetaInstr :: MetaInstr n -> k xs n r a -> Instr o k xs n r a +{-| +This represents the instructions of the machine, in CPS form as an indexed functor. -data Access = Hard | Soft deriving stock Show +When an instruction has a `Succ` in the type, it indicates that it is capable of failing. +@since 1.4.0.0 +-} +data Instr (o :: Type) -- The FIXED input type + (k :: [Type] -> Nat -> Type -> Type -> Type) -- The FIXED continuation parameter + (xs :: [Type]) -- The VARIABLE type defining the required types on the stack on entry + (n :: Nat) -- The VARIABLE type defining how many handlers are required on entry + (r :: Type) -- The VARIABLE intermediate type defining what value this parser immediately produces + (a :: Type) -- The (technically VARIABLE) type specifying the final result of the parser + where + {-| This instruction returns from either calls or the entire parser at the top-level. + + @since 1.0.0.0 -} + Ret :: Instr o k '[x] n x a {- ^ -} + {-| Pushes a value onto the stack, which is required by the continuation parameter. + + @since 1.0.0.0 -} + Push :: Machine.Defunc x {- ^ Value to push. -} -> k (x : xs) n r a {- ^ Machine requiring value. -} -> Instr o k xs n r a + {-| Removes a value from the stack, so it is the correct shape for the continuation parameter. + + @since 1.0.0.0 -} + Pop :: k xs n r a {- ^ -} -> Instr o k (x : xs) n r a + {-| Applies a function to the top two elements of the stack, converting them to something else and pushing it back on. + + @since 1.0.0.0 -} + Lift2 :: Machine.Defunc (x -> y -> z) {- ^ Function to apply. -} + -> k (z : xs) n r a {- ^ Machine requiring new value. -} + -> Instr o k (y : x : xs) n r a + {-| Reads a character so long as it matches a given predicate. If it does not, or no input is available, this instruction fails. + + @since 1.0.0.0 -} + Sat :: Machine.Defunc (Char -> Bool) {- ^ Predicate to apply. -} + -> k (Char : xs) (Succ n) r a {- ^ Machine requiring read character. -} + -> Instr o k xs (Succ n) r a + {-| Calls another let-bound parser. + + @since 1.0.0.0 -} + Call :: MVar x {- ^ The binding to invoke. -} + -> k (x : xs) (Succ n) r a {- ^ Continuation to do after the call. -} + -> Instr o k xs (Succ n) r a + {-| Jumps to another let-bound parser tail-recursively. + + @since 1.0.0.0 -} + Jump :: MVar x {- ^ The binding to jump to. -} -> Instr o k '[] (Succ n) x a + {-| Fails unconditionally. + + @since 1.0.0.0 -} + Empt :: Instr o k xs (Succ n) r a {- ^ -} + {-| Discards a failure handler, so that it is no longer in scope. + + @since 1.0.0.0 -} + Commit :: k xs n r a {- ^ Next machine, which will /not/ require the discarded handler. -} -> Instr o k xs (Succ n) r a + {-| Registers a handler to deal with possible failure in the given machine. + + @since 1.4.0.0 -} + Catch :: k xs (Succ n) r a {- ^ Machine where failure is handled by the handler. -} + -> Handler o k (o : xs) n r a {- ^ The handler to register. -} + -> Instr o k xs n r a + {-| Pushes the current input offset onto the stack. + + @since 1.0.0.0 -} + Tell :: k (o : xs) n r a {- ^ The machine that accepts the input. -} -> Instr o k xs n r a + {-| Pops the input offset off of the stack and makes that the current input offset. + + @since 1.0.0.0 -} + Seek :: k xs n r a {- ^ Machine to continue with new input. -} -> Instr o k (o : xs) n r a + {-| Picks one of two continuations based on whether a `Left` or `Right` is on the stack. + + @since 1.0.0.0 -} + Case :: k (x : xs) n r a {- ^ Machine to execute if `Left` on stack. -} + -> k (y : xs) n r a {- ^ Machine to execute if `Right` on stack. -} + -> Instr o k (Either x y : xs) n r a + {-| Given a collection of predicates and machines, this instruction will execute the first machine + for which the corresponding predicate returns true for the value on the top of the stack. + + @since 1.0.0.0 -} + Choices :: [Machine.Defunc (x -> Bool)] {- ^ A list of predicates to try. -} + -> [k xs n r a] {- ^ A corresponding list of machines. -} + -> k xs n r a {- ^ A default machine to execute if no predicates match. -} + -> Instr o k (x : xs) n r a + {-| Sets up an iteration, where the second argument is executed repeatedly until it fails, which is + handled by the given handler. The use of `Void` indicates that `Ret` is illegal within the loop. + + @since 1.0.0.0 -} + Iter :: MVar Void {- ^ The name of the binding. -} + -> k '[] One Void a {- ^ The body of the loop: it cannot return "normally". -} + -> Handler o k (o : xs) n r a {- ^ The handler for the loop's exit. -} + -> Instr o k xs n r a + {-| Jumps to a given join point. + + @since 1.0.0.0 -} + Join :: ΦVar x {- ^ The join point to jump to. -} -> Instr o k (x : xs) n r a + {-| Sets up a new join point binding. + + @since 1.0.0.0 -} + MkJoin :: ΦVar x {- ^ The name of the binding that can be referred to later. -} + -> k (x : xs) n r a {- ^ The body of the join point binding. -} + -> k xs n r a {- ^ The scope within which the binding is valid. -} + -> Instr o k xs n r a + {-| Swaps the top two elements on the stack + + @since 1.0.0.0 -} + Swap :: k (x : y : xs) n r a {- ^ The machine that requires the reversed stack. -} -> Instr o k (y : x : xs) n r a + {-| Duplicates the top value on the stack. May produce a let-binding. + + @since 1.0.0.0 -} + Dup :: k (x : x : xs) n r a {- ^ Machine that requires doubled element. -} -> Instr o k (x : xs) n r a + {-| Initialises a new register for use within the continuation. Initial value is on the stack. + + @since 1.0.0.0 -} + Make :: ΣVar x {- ^ The name of the new register. -} + -> Access {- ^ Whether or not the register is "concrete". -} + -> k xs n r a {- ^ The scope within which the register is accessible. -} + -> Instr o k (x : xs) n r a + {-| Pushes the value contained within a register onto the stack. + + @since 1.0.0.0 -} + Get :: ΣVar x {- ^ Name of the register to read. -} + -> Access {- ^ Whether or not the value is cached. -} + -> k (x : xs) n r a {- ^ The machine that requires the value. -} + -> Instr o k xs n r a + {-| Places the value on the top of the stack into a given register. + + @since 1.0.0.0 -} + Put :: ΣVar x {- ^ Name of the register to update. -} + -> Access {- ^ Whether or not the value needs to be stored in a concrete register. -} + -> k xs n r a + -> Instr o k (x : xs) n r a + {-| Begins a debugging scope, the inner scope requires /two/ handlers, + the first is the log handler itself, and then the second is the + "real" fail handler for when the log handler is executed. + + @since 1.0.0.0 -} + LogEnter :: String {- ^ The message to be printed. -} + -> k xs (Succ (Succ n)) r a {- ^ The machine to be debugged. -} + -> Instr o k xs (Succ n) r a + {-| Ends the log scope after a succesful execution. + + @since 1.0.0.0 -} + LogExit :: String {- ^ The message to be printed. -} + -> k xs n r a {- ^ The machine that follows. -} + -> Instr o k xs n r a + {-| Executes a meta-instruction, which is interacting with + implementation specific static information. + + @since 1.0.0.0 -} + MetaInstr :: MetaInstr n {- ^ A meta-instruction to perform. -} + -> k xs n r a {- ^ The machine that follows. -} + -> Instr o k xs n r a + +{-| +There are two types of organic handlers within parsley, which are +captured by this type, which is also an IFunctor and wraps around +`Instr`. + +@since 1.4.0.0 +-} +data Handler (o :: Type) (k :: [Type] -> Nat -> Type -> Type -> Type) (xs :: [Type]) (n :: Nat) (r :: Type) (a :: Type) where + {-| These handlers have two distinct behaviours depending on whether the + captured offset matches the current offset or not. + + @since 1.4.0.0 -} + Same :: k xs n r a -- ^ Execute when the input matches, notice that the captured offset is discarded since it is equal to the current. + -> k (o : xs) n r a -- ^ Execute when the input does not match, the resulting behaviour could use the captured or current input. + -> Handler o k (o : xs) n r a + {-| These handlers are unconditional on the input, and will always do the same + thing regardless of the input provided. + + @since 1.4.0.0 -} + Always :: k (o : xs) n r a -> Handler o k (o : xs) n r a + +{-| +This determines whether or not an interaction with an register should be materialised +in the generated code or not. + +@since 1.0.0.0 +-} +data Access = Hard -- ^ Register exists at runtime and this interaction will use it. + | Soft -- ^ Register may not exist, and the interaction should be with cache regardless. + deriving stock Show + +{-| +These are meta-instructions, which interact with static information to direct the +code-generation process. They are not formally part of parsley's semantics and can +be omitted from an implementation without consequence. + +@since 1.0.0.0 +-} data MetaInstr (n :: Nat) where + {-| Adds coins to the piggy-bank system (see "Parsley.Internal.Backend.Machine.Types.Context" for more information). + If there are coins already available, add a piggy-bank, otherwise generate a length check and add the coins. + + A handler is required, in case the length check fails. + + @since 1.0.0.0 -} AddCoins :: Int -> MetaInstr (Succ n) + {-| Refunds to the piggy-bank system (see "Parsley.Internal.Backend.Machine.Types.Context" for more information). + This always happens for free, and is added straight to the coins. + + @since 1.0.0.0 -} RefundCoins :: Int -> MetaInstr n + {-| Remove coins from piggy-bank system (see "Parsley.Internal.Backend.Machine.Types.Context" for more information) + This is used to pay for more expensive calls to bindings with known required input. + + A handler is required, as there may not be enough coins to pay the cost and a length check causes a failure. + + @since 1.0.0.0 -} DrainCoins :: Int -> MetaInstr (Succ n) + mkCoin :: (Int -> MetaInstr n) -> Int -> Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a mkCoin _ 0 = id mkCoin meta n = In4 . MetaInstr (meta n) +{-| +Smart-constuctor around `AddCoins`. + +@since 1.0.0.0 +-} addCoins :: Int -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a addCoins = mkCoin AddCoins + +{-| +Smart-constuctor around `RefundCoins`. + +@since 1.0.0.0 +-} refundCoins :: Int -> Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a refundCoins = mkCoin RefundCoins + +{-| +Smart-constuctor around `DrainCoins`. + +@since 1.0.0.0 +-} drainCoins :: Int -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a drainCoins = mkCoin DrainCoins +{-| +Applies a value on the top of the stack to a function on the second-most top of the stack. + +@since 1.0.0.0 +-} _App :: Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : (x -> y) : xs) n r a -_App k = Lift2 (user ID) k +_App = Lift2 (user ID) +{-| +Adjusts the value on the top of the stack with the given function. + +@since 1.0.0.0 +-} _Fmap :: Machine.Defunc (x -> y) -> Fix4 (Instr o) (y : xs) n r a -> Instr o (Fix4 (Instr o)) (x : xs) n r a _Fmap f k = Push f (In4 (Lift2 (user (FLIP_H ID)) k)) +{-| +Updates the value in a given register using the function on the top of the stack. + +@since 1.0.0.0 +-} _Modify :: ΣVar x -> Fix4 (Instr o) xs n r a -> Instr o (Fix4 (Instr o)) ((x -> x) : xs) n r a _Modify σ = _Get σ . In4 . _App . In4 . _Put σ +{-| +Smart-instruction for `Make` that uses a `Hard` access. + +@since 1.0.0.0 +-} _Make :: ΣVar x -> k xs n r a -> Instr o k (x : xs) n r a _Make σ = Make σ Hard +{-| +Smart-instruction for `Put` that uses a `Hard` access. + +@since 1.0.0.0 +-} _Put :: ΣVar x -> k xs n r a -> Instr o k (x : xs) n r a _Put σ = Put σ Hard +{-| +Smart-instruction for `Get` that uses a `Hard` access. + +@since 1.0.0.0 +-} _Get :: ΣVar x -> k (x : xs) n r a -> Instr o k xs n r a _Get σ = Get σ Hard --- This this is a nice little trick to get this instruction to generate optimised code -_If :: Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a -> Instr o (Fix4 (Instr o)) (Bool : xs) n r a -_If t e = Choices [user ID] [t] e - +-- Instances instance IFunctor4 (Instr o) where imap4 _ Ret = Ret imap4 f (Push x k) = Push x (f k) @@ -88,12 +336,12 @@ imap4 _ (Jump μ) = Jump μ imap4 _ Empt = Empt imap4 f (Commit k) = Commit (f k) - imap4 f (Catch p h) = Catch (f p) (f h) + imap4 f (Catch p h) = Catch (f p) (imap4 f h) imap4 f (Tell k) = Tell (f k) imap4 f (Seek k) = Seek (f k) imap4 f (Case p q) = Case (f p) (f q) imap4 f (Choices fs ks def) = Choices fs (map f ks) (f def) - imap4 f (Iter μ l h) = Iter μ (f l) (f h) + imap4 f (Iter μ l h) = Iter μ (f l) (imap4 f h) imap4 _ (Join φ) = Join φ imap4 f (MkJoin φ p k) = MkJoin φ (f p) (f k) imap4 f (Swap k) = Swap (f k) @@ -105,6 +353,10 @@ imap4 f (LogExit name k) = LogExit name (f k) imap4 f (MetaInstr m k) = MetaInstr m (f k) +instance IFunctor4 (Handler o) where + imap4 f (Same yes no) = Same (f yes) (f no) + imap4 f (Always k) = Always (f k) + instance Show (Fix4 (Instr o) xs n r a) where show = ($ "") . getConst4 . cata4 (Const4 . alg) where @@ -118,12 +370,12 @@ alg (Sat f k) = "(Sat " . shows f . " " . getConst4 k . ")" alg Empt = "Empt" alg (Commit k) = "(Commit " . getConst4 k . ")" - alg (Catch p h) = "(Catch " . getConst4 p . " " . getConst4 h . ")" + alg (Catch p h) = "(Catch " . getConst4 p . " " . shows h . ")" alg (Tell k) = "(Tell " . getConst4 k . ")" alg (Seek k) = "(Seek " . getConst4 k . ")" alg (Case p q) = "(Case " . getConst4 p . " " . getConst4 q . ")" alg (Choices fs ks def) = "(Choices " . shows fs . " [" . intercalateDiff ", " (map getConst4 ks) . "] " . getConst4 def . ")" - alg (Iter μ l h) = "{Iter " . shows μ . " " . getConst4 l . " " . getConst4 h . "}" + alg (Iter μ l h) = "{Iter " . shows μ . " " . getConst4 l . " " . shows h . "}" alg (Join φ) = shows φ alg (MkJoin φ p k) = "(let " . shows φ . " = " . getConst4 p . " in " . getConst4 k . ")" alg (Swap k) = "(Swap " . getConst4 k . ")" @@ -134,6 +386,10 @@ alg (LogEnter _ k) = getConst4 k alg (LogExit _ k) = getConst4 k alg (MetaInstr m k) = "[" . shows m . "] " . getConst4 k + +instance Show (Handler o (Const4 (String -> String)) (o : xs) n r a) where + show (Same yes no) = "(Dup (Tell (Lift2 same (If " (getConst4 yes (" " (getConst4 no "))))"))) + show (Always k) = getConst4 k "" instance Show (MetaInstr n) where show (AddCoins n) = "Add " ++ show n ++ " coins" diff --git a/src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs b/src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs --- a/src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs +++ b/src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs @@ -1,6 +1,16 @@ -{-# LANGUAGE ExistentialQuantification, - StandaloneDeriving, - DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} +{-| +Module : Parsley.Internal.Backend.Machine.LetBindings +Description : Let-binding and free registers. +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +Definitions for various encapsulating datatypes for machines, and defining +free registers. + +@since 1.0.0.0 +-} module Parsley.Internal.Backend.Machine.LetBindings ( LetBinding(..), Regs(..), @@ -11,22 +21,55 @@ import Prelude hiding (foldr) import Data.Kind (Type) import Data.Set (Set, foldr) -import Parsley.Internal.Backend.Machine.Identifiers (IΣVar, ΣVar(..)) +import Data.Some (Some, pattern Some) +import Parsley.Internal.Backend.Machine.Identifiers (ΣVar, SomeΣVar(..)) import Parsley.Internal.Backend.Machine.Instructions (Instr) import Parsley.Internal.Common (Fix4, One) -import Unsafe.Coerce (unsafeCoerce) +{-| +Type represents a binding, which is a completed parser that can +be refered to by other parsers. This is characterised by requiring +no initial stack and exactly one handler. The top-level binding is +the one of type @`Binding` o a a@. + +@since 1.0.0.0 +-} type Binding o a x = Fix4 (Instr o) '[] One x a -data LetBinding o a x = forall rs. LetBinding (Binding o a x) (Regs rs) -deriving stock instance Show (LetBinding o a x) -makeLetBinding :: Binding o a x -> Set IΣVar -> LetBinding o a x -makeLetBinding m rs = LetBinding m (unsafeMakeRegs rs) +{-| +Packages a binding along with its free registers that are required +for it, which are left existential. This is possible since the `Regs` +datatype serves as a singleton-style witness of the original registers +and their types. +@since 1.4.0.0 +-} +data LetBinding o a x = LetBinding (Binding o a x) (Some Regs) + +{-| +Given a `Binding` and a set of existential `ΣVar`s, produces a +`LetBinding` instance. + +@since 1.4.0.0 +-} +makeLetBinding :: Binding o a x -> Set SomeΣVar -> LetBinding o a x +makeLetBinding m rs = LetBinding m (makeRegs rs) + +{-| +Represents a collection of free registers, preserving their type +information as a heterogeneous list. + +@since 1.0.0.0 +-} data Regs (rs :: [Type]) where NoRegs :: Regs '[] FreeReg :: ΣVar r -> Regs rs -> Regs (r : rs) -deriving stock instance Show (Regs rs) -unsafeMakeRegs :: Set IΣVar -> Regs rs -unsafeMakeRegs = foldr (\σ rs -> unsafeCoerce (FreeReg (ΣVar σ) rs)) (unsafeCoerce NoRegs) +{-| +Converts a set of existential `ΣVar`s into an existential +heterogeneous list of free registers. + +@since 1.4.0.0 +-} +makeRegs :: Set SomeΣVar -> Some Regs +makeRegs = foldr (\(SomeΣVar σ) (Some rs) -> Some (FreeReg σ rs)) (Some NoRegs) 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 @@ -1,5 +1,17 @@ {-# LANGUAGE TupleSections, CPP #-} +{-| +Module : Parsley.Internal.Backend.Machine.LetRecBuilder +Description : Function for building recursive groups. +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +Exposes the `letRec` function, used to provide a recursive /group/ of bindings +for the top level of a parser. + +@since 1.0.0.0 +-} module Parsley.Internal.Backend.Machine.LetRecBuilder (letRec) where import Data.Dependent.Sum (DSum((:=>))) @@ -13,7 +25,8 @@ 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, qSubRoutine, Func) +import Parsley.Internal.Backend.Machine.Types (QSubroutine, qSubroutine, Func) + import Parsley.Internal.Common.Utils (Code) import Data.Dependent.Map as DMap (DMap, (!), map, toList, traverseWithKey) @@ -25,18 +38,27 @@ unTypeCode = unTypeQ #endif -letRec :: GCompare key => {-bindings-} DMap key (LetBinding o a) - -> {-nameof-} (forall x. key x -> String) - -> {-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 +{-| +Given a collection of bindings, generates a recursive binding group where each is allowed to +refer to every other. These are then in scope for the top-level parser. + +@since 1.0.0.0 +-} +letRec :: GCompare key + => {-bindings-} DMap key (LetBinding o a) -- ^ The bindings that should form part of the recursive group + -> {-nameof-} (forall x. key x -> String) -- ^ A function which can give a name to a key in the map + -> {-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)) + -- ^ How a binding - and their free registers - should be converted into code + -> {-expr-} (DMap key (QSubroutine s o a) -> Code b) + -- ^ How to produce the top-level binding given the compiled bindings, i.e. the @in@ for the @let@ + -> Code b letRec bindings nameOf genBinding expr = unsafeCodeCoerce $ do -- Make a bunch of names - names <- traverseWithKey (\k (LetBinding _ rs) -> Const . (, Some rs) <$> newName (nameOf k)) bindings + names <- traverseWithKey (\k (LetBinding _ rs) -> Const . (, rs) <$> newName (nameOf k)) bindings -- Wrap them up so that they are valid typed template haskell names let typedNames = DMap.map makeTypedName names -- Generate each binding providing them with the names - let makeDecl (k :=> LetBinding body frees) = + let makeDecl (k :=> LetBinding body (Some frees)) = do let Const (name, _) = names ! k func <- unTypeCode (genBinding k body frees typedNames) return (FunD name [Clause [] (NormalB func) []]) @@ -46,5 +68,5 @@ -- Construct the let expression 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 Regs) x -> QSubroutine s o a x + makeTypedName (Const (name, Some frees)) = qSubroutine (unsafeCodeCoerce (return (VarE name))) frees diff --git a/src/ghc/Parsley/Internal/Common/Fresh.hs b/src/ghc/Parsley/Internal/Common/Fresh.hs --- a/src/ghc/Parsley/Internal/Common/Fresh.hs +++ b/src/ghc/Parsley/Internal/Common/Fresh.hs @@ -49,7 +49,7 @@ instance Monad n => RunFreshT x n (FreshT x n) where runFreshT k init = do (x, _, max) <- unFreshT k init init - return $! (x, max) + return (x, max) runFresh :: RunFreshT x Identity m => m a -> x -> (a, x) runFresh mx = runIdentity . runFreshT mx @@ -83,7 +83,7 @@ liftA2 f (FreshT mx) (FreshT my) = FreshT (\cur max -> do (x, cur', max') <- mx cur max (y, cur'', max'') <- my cur' max' - return $! (f x y, cur'', max'')) + return (f x y, cur'', max'')) instance Monad m => Monad (FreshT x m) where {-# INLINE return #-} @@ -107,13 +107,13 @@ newVar = vFreshT (\cur m -> return (cur, cur, max m cur)) newScope scoped = vFreshT (\cur max -> do (x, _, max') <- unVFreshT scoped (succ cur) max - return $! (x, cur, max')) + return (x, cur, max')) instance (Monad m, Ord x, Enum x) => MonadFresh x (HFreshT x m) where newVar = hFreshT (\cur m -> return (cur, succ cur, max m cur)) newScope scoped = hFreshT (\cur max -> do (x, _, max') <- unHFreshT scoped cur max - return $! (x, cur, max')) + return (x, cur, max')) instance MonadIO m => MonadIO (FreshT x m) where liftIO = lift . liftIO instance MonadReader r m => MonadReader r (FreshT x m) where diff --git a/src/ghc/Parsley/Internal/Common/State.hs b/src/ghc/Parsley/Internal/Common/State.hs --- a/src/ghc/Parsley/Internal/Common/State.hs +++ b/src/ghc/Parsley/Internal/Common/State.hs @@ -53,7 +53,7 @@ {-# INLINE pure #-} pure x = StateT (flip ($ x)) {-# INLINE liftA2 #-} - liftA2 f (StateT mx) (StateT my) = StateT (\s k -> mx s (\x s' -> my s' (\y s'' -> k (f x y) s''))) + liftA2 f (StateT mx) (StateT my) = StateT (\s k -> mx s (\x s' -> my s' (k . f x))) instance Monad (StateT s m) where {-# INLINE return #-} diff --git a/src/ghc/Parsley/Internal/Common/Utils.hs b/src/ghc/Parsley/Internal/Common/Utils.hs --- a/src/ghc/Parsley/Internal/Common/Utils.hs +++ b/src/ghc/Parsley/Internal/Common/Utils.hs @@ -89,7 +89,7 @@ @since 0.1.0.0 -} (>*<) :: q (a -> b) -> q a -> q b - f >*< x = makeQ ((_val f) (_val x)) [||$$(_code f) $$(_code x)||] + f >*< x = makeQ (_val f (_val x)) [||$$(_code f) $$(_code x)||] infixl 9 >*< {-| @@ -112,5 +112,5 @@ instance Semigroup (Id a) where f <> g = Id $ unId f . unId g instance Monoid (Id a) where mempty = Id $ id -intercalateDiff :: (a -> a) -> [(a -> a)] -> a -> a +intercalateDiff :: (a -> a) -> [a -> a] -> a -> a intercalateDiff sep xs = unId $ intercalate (Id sep) (map Id xs) diff --git a/src/ghc/Parsley/Internal/Core/Defunc.hs b/src/ghc/Parsley/Internal/Core/Defunc.hs --- a/src/ghc/Parsley/Internal/Core/Defunc.hs +++ b/src/ghc/Parsley/Internal/Core/Defunc.hs @@ -121,7 +121,7 @@ pattern UNIT = LIFTED () ap :: Defunc (a -> b) -> Defunc a -> Defunc b -ap f x = APP_H f x +ap = APP_H -- TODO: This is deprecated in favour of Typeable as of parsley 2.0.0.0 lamTermBool :: Defunc (a -> Bool) -> Lam (a -> Bool) @@ -131,17 +131,17 @@ lamTerm :: forall a. Defunc a -> Lam a lamTerm ID = Abs id -lamTerm COMPOSE = Abs (\f -> Abs (\g -> Abs (\x -> App f (App g x)))) +lamTerm COMPOSE = Abs (\f -> Abs (\g -> Abs (App f . App g))) lamTerm FLIP = Abs (\f -> Abs (\x -> Abs (\y -> App (App f y) x))) lamTerm (APP_H f x) = App (lamTerm f) (lamTerm x) {-lamTerm (LIFTED b) | Just Refl <- eqT @a @Bool = case b of False -> F True -> T-} lamTerm (LIFTED x) = Var True [||x||] -lamTerm (EQ_H x) = Abs (\y -> App (App (Var True [||(==)||]) (lamTerm x)) y) +lamTerm (EQ_H x) = Abs (App (App (Var True [||(==)||]) (lamTerm x))) lamTerm CONS = Var True [||(:)||] lamTerm EMPTY = Var True [||[]||] -lamTerm CONST = Abs (\x -> Abs (\_ -> x)) +lamTerm CONST = Abs (Abs . const) lamTerm (BLACK x) = Var False (_code x) lamTerm (LAM_S f) = Abs (adaptLam f) lamTerm (IF_S c t e) = If (lamTerm c) (lamTerm t) (lamTerm e) diff --git a/src/ghc/Parsley/Internal/Core/Identifiers.hs b/src/ghc/Parsley/Internal/Core/Identifiers.hs --- a/src/ghc/Parsley/Internal/Core/Identifiers.hs +++ b/src/ghc/Parsley/Internal/Core/Identifiers.hs @@ -3,10 +3,11 @@ GeneralizedNewtypeDeriving #-} module Parsley.Internal.Core.Identifiers ( MVar(..), IMVar, - ΣVar(..), IΣVar, + ΣVar(..), IΣVar, SomeΣVar(..), getIΣVar ) where import Data.Array (Ix) +import Data.Function (on) import Data.GADT.Compare (GEq, GCompare, gcompare, geq, GOrdering(..)) import Data.Kind (Type) import Data.Typeable ((:~:)(Refl)) @@ -31,6 +32,14 @@ LT -> GLT EQ -> case geq σ1 σ2 of Just Refl -> GEQ GT -> GGT + +data SomeΣVar = forall r. SomeΣVar (ΣVar r) +instance Eq SomeΣVar where (==) = (==) `on` getIΣVar +instance Ord SomeΣVar where compare = compare `on` getIΣVar +instance Show SomeΣVar where show (SomeΣVar σ) = show σ + +getIΣVar :: SomeΣVar -> IΣVar +getIΣVar (SomeΣVar (ΣVar σ)) = σ instance GEq MVar where geq (MVar u) (MVar v) diff --git a/src/ghc/Parsley/Internal/Frontend/Compiler.hs b/src/ghc/Parsley/Internal/Frontend/Compiler.hs --- a/src/ghc/Parsley/Internal/Frontend/Compiler.hs +++ b/src/ghc/Parsley/Internal/Frontend/Compiler.hs @@ -2,9 +2,20 @@ {-# LANGUAGE AllowAmbiguousTypes, MagicHash, MultiParamTypeClasses, - MultiWayIf, RecursiveDo, UndecidableInstances #-} +{-| +Module : Parsley.Internal.Frontend.Compiler +Description : Compile and analyse a parser +License : BSD-3-Clause +Maintainer : Jamie Willis +Stability : experimental + +Exposes `compile` which is used to detect recursion, let-bindings and compile them +into another representation with a code generation function. + +@since 1.0.0.0 +-} module Parsley.Internal.Frontend.Compiler (compile) where import Prelude hiding (pred) @@ -24,7 +35,7 @@ import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName) import Numeric (showHex) import Parsley.Internal.Core.CombinatorAST (Combinator(..), ScopeRegister(..), Reg(..), Parser(..), traverseCombinator) -import Parsley.Internal.Core.Identifiers (IMVar, MVar(..), IΣVar, ΣVar(..)) +import Parsley.Internal.Core.Identifiers (IMVar, MVar(..), IΣVar, ΣVar(..), SomeΣVar) import Parsley.Internal.Common.Fresh (HFreshT, newVar, runFreshT) import Parsley.Internal.Common.Indexed (Fix(In), cata, cata', IFunctor(imap), (:+:)(..), (\/), Const1(..)) import Parsley.Internal.Common.State (State, get, gets, runState, execState, modify', MonadState) @@ -40,14 +51,24 @@ import qualified Data.Map as Map ((!)) import qualified Data.Set as Set (empty) +{-| +Given a user's parser, this will analyse it, extract bindings and then compile them with a given function +provided with the information that has been distilled about each binding. Returns all the prepared bindings +along with the top-level definition. + +@since 1.0.0.0 +-} {-# INLINEABLE compile #-} -compile :: forall compiled a. Trace => Parser a -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set IΣVar -> IMVar -> IΣVar -> compiled x) -> (compiled a, DMap MVar compiled) +compile :: forall compiled a. Trace + => Parser a -- ^ The parser to compile. + -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set SomeΣVar -> IMVar -> IΣVar -> compiled x) -- ^ How to generate a compiled value with the distilled information. + -> (compiled a, DMap MVar compiled) -- ^ The compiled top-level and all of the bindings. compile (Parser p) codeGen = trace ("COMPILING NEW PARSER WITH " ++ show (DMap.size μs') ++ " LET BINDINGS") (codeGen' Nothing p', DMap.mapWithKey (codeGen' . Just) μs') where (p', μs, maxV) = preprocess p (μs', frs, maxΣ) = dependencyAnalysis p' μs - freeRegs :: Maybe (MVar x) -> Set IΣVar + freeRegs :: Maybe (MVar x) -> Set SomeΣVar freeRegs = maybe Set.empty (\(MVar v) -> frs Map.! v) codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x diff --git a/src/ghc/Parsley/Internal/Frontend/Dependencies.hs b/src/ghc/Parsley/Internal/Frontend/Dependencies.hs --- a/src/ghc/Parsley/Internal/Frontend/Dependencies.hs +++ b/src/ghc/Parsley/Internal/Frontend/Dependencies.hs @@ -10,13 +10,12 @@ import Data.Dependent.Map (DMap) import Data.List (foldl', partition, sortOn) import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe) import Data.Set (Set, insert, (\\), union, notMember, empty) import Data.STRef (newSTRef, readSTRef, writeSTRef) import Parsley.Internal.Common.Indexed (Fix, cata, Const1(..), (:*:)(..), zipper) import Parsley.Internal.Common.State (State, MonadState, execState, modify') import Parsley.Internal.Core.CombinatorAST (Combinator(..), traverseCombinator) -import Parsley.Internal.Core.Identifiers (IMVar, MVar(..), IΣVar, ΣVar(..)) +import Parsley.Internal.Core.Identifiers (IMVar, MVar(..), IΣVar, ΣVar, SomeΣVar(..), getIΣVar) import qualified Data.Dependent.Map as DMap (foldrWithKey, filterWithKey) import qualified Data.Map.Strict as Map ((!), empty, insert, mapMaybeWithKey, findMax, elems, lookup, foldMapWithKey) @@ -27,7 +26,7 @@ -- TODO This actually should be in the backend... dead bindings and the topological ordering can be computed here -- but the register stuff should come after register optimisation and instruction peephole -dependencyAnalysis :: Fix Combinator a -> DMap MVar (Fix Combinator) -> (DMap MVar (Fix Combinator), Map IMVar (Set IΣVar), IΣVar) +dependencyAnalysis :: Fix Combinator a -> DMap MVar (Fix Combinator) -> (DMap MVar (Fix Combinator), Map IMVar (Set SomeΣVar), IΣVar) dependencyAnalysis toplevel μs = let -- Step 1: find roots of the toplevel roots = directDependencies toplevel @@ -55,7 +54,7 @@ in Just $ (uses \\ defs) `union` (subUses \\ subDefs) | otherwise = Nothing trueRegs = Map.mapMaybeWithKey addNewRegs usedRegisters - largestRegister = fromMaybe (-1) (Set.lookupMax (Map.foldMapWithKey (const id) definedRegisters)) + largestRegister = maybe (-1) getIΣVar (Set.lookupMax (Map.foldMapWithKey (const id) definedRegisters)) in (DMap.filterWithKey (\(MVar v) _ -> notMember v dead) μs, trueRegs, largestRegister) minMax :: Ord a => [a] -> (a, a) @@ -108,9 +107,9 @@ -- IMMEDIATE DEPENDENCY MAPS data DependencyMaps = DependencyMaps { - usedRegisters :: Map IMVar (Set IΣVar), -- Leave Lazy + usedRegisters :: Map IMVar (Set SomeΣVar), -- Leave Lazy immediateDependencies :: Map IMVar (Set IMVar), -- Could be Strict - definedRegisters :: Map IMVar (Set IΣVar) + definedRegisters :: Map IMVar (Set SomeΣVar) } buildDependencyMaps :: DMap MVar (Fix Combinator) -> DependencyMaps @@ -120,7 +119,7 @@ , immediateDependencies = Map.insert v ds immediateDependencies , definedRegisters = Map.insert v defs definedRegisters}) (DependencyMaps Map.empty Map.empty Map.empty) -freeRegistersAndDependencies :: IMVar -> Fix Combinator a -> (Set IΣVar, Set IΣVar, Set IMVar) +freeRegistersAndDependencies :: IMVar -> Fix Combinator a -> (Set SomeΣVar, Set SomeΣVar, Set IMVar) freeRegistersAndDependencies v p = let frsm :*: depsm = zipper freeRegistersAlg (dependenciesAlg (Just v)) p (frs, defs) = runFreeRegisters frsm @@ -145,8 +144,8 @@ dependsOn (MVar v) = modify' (insert v) -- FREE REGISTER ANALYSIS -newtype FreeRegisters a = FreeRegisters { doFreeRegisters :: State (Set IΣVar, Set IΣVar) () } -runFreeRegisters :: FreeRegisters a -> (Set IΣVar, Set IΣVar) +newtype FreeRegisters a = FreeRegisters { doFreeRegisters :: State (Set SomeΣVar, Set SomeΣVar) () } +runFreeRegisters :: FreeRegisters a -> (Set SomeΣVar, Set SomeΣVar) runFreeRegisters = flip execState (empty, empty) . doFreeRegisters {-# INLINE freeRegistersAlg #-} @@ -157,8 +156,8 @@ freeRegistersAlg Let{} = FreeRegisters $ do return () -- TODO This can be removed when Let doesn't have the body in it... freeRegistersAlg p = FreeRegisters $ do traverseCombinator (fmap Const1 . doFreeRegisters) p; return () -uses :: MonadState (Set IΣVar, vs) m => ΣVar a -> m () -uses (ΣVar σ) = modify' (first (insert σ)) --tell (singleton σ, mempty) +uses :: MonadState (Set SomeΣVar, vs) m => ΣVar a -> m () +uses σ = modify' (first (insert (SomeΣVar σ))) -defs :: MonadState (vs, Set IΣVar) m => ΣVar a -> m () -defs (ΣVar σ) = modify' (second (insert σ)) --tell (mempty, singleton σ) +defs :: MonadState (vs, Set SomeΣVar) m => ΣVar a -> m () +defs σ = modify' (second (insert (SomeΣVar σ))) diff --git a/src/ghc/Parsley/Internal/Frontend/Optimiser.hs b/src/ghc/Parsley/Internal/Frontend/Optimiser.hs --- a/src/ghc/Parsley/Internal/Frontend/Optimiser.hs +++ b/src/ghc/Parsley/Internal/Frontend/Optimiser.hs @@ -53,7 +53,7 @@ -- Definition of <* optimise (In (CONST :<$>: p) :<*>: q) = In (p :<*: q) -- Reassociation Law 1: (u *> v) <*> w = u *> (v <*> w) -optimise (In (u :*>: v) :<*>: w) = optimise (u :*>: (optimise (v :<*>: w))) +optimise (In (u :*>: v) :<*>: w) = optimise (u :*>: optimise (v :<*>: w)) -- Interchange Law: u <*> pure x = pure ($ x) <*> u optimise (u :<*>: In (Pure x)) = optimise (APP_H (FLIP_H ID) x :<$>: u) -- Right Absorption Law: (f <$> p) *> q = p *> q @@ -125,9 +125,9 @@ -- Interchange law: try (f <$> p) = f <$> try p optimise (Try (In (f :<$>: p))) = optimise (f :<$>: optimise (Try p)) -- pure Left law: branch (pure (Left x)) p q = p <*> pure x -optimise (Branch (In (Pure (l@(_val -> Left x)))) p _) = optimise (p :<*>: In (Pure (makeQ x qx))) where qx = [||case $$(_code l) of Left x -> x||] +optimise (Branch (In (Pure l@(_val -> Left x))) p _) = optimise (p :<*>: In (Pure (makeQ x qx))) where qx = [||case $$(_code l) of Left x -> x||] -- pure Right law: branch (pure (Right x)) p q = q <*> pure x -optimise (Branch (In (Pure (r@(_val -> Right x)))) _ q) = optimise (q :<*>: In (Pure (makeQ x qx))) where qx = [||case $$(_code r) of Right x -> x||] +optimise (Branch (In (Pure r@(_val -> Right x))) _ q) = optimise (q :<*>: In (Pure (makeQ x qx))) where qx = [||case $$(_code r) of Right x -> x||] -- Generalised Identity law: branch b (pure f) (pure g) = either f g <$> b optimise (Branch b (In (Pure f)) (In (Pure g))) = optimise (makeQ (either (_val f) (_val g)) [||either $$(_code f) $$(_code g)||] :<$>: b) -- Interchange law: branch (x *> y) p q = x *> branch y p q diff --git a/src/ghc/Parsley/Internal/Trace.hs b/src/ghc/Parsley/Internal/Trace.hs --- a/src/ghc/Parsley/Internal/Trace.hs +++ b/src/ghc/Parsley/Internal/Trace.hs @@ -13,8 +13,15 @@ -} module Parsley.Internal.Trace (Trace, trace, traceShow) where +{-| +Used to produce debug output within parsley. + +@since 0.1.0.0 +-} class Trace where + -- | Print a string to the console. trace :: String -> a -> a +-- | Print a value to the console. traceShow :: (Trace, Show a) => a -> a traceShow = show >>= trace