parsley-core 2.2.0.1 → 2.3.0.0
raw patch · 48 files changed
+1576/−1439 lines, 48 filesdep +sybdep ~basedep ~hashabledep ~text
Dependencies added: syb
Dependency ranges changed: base, hashable, text
Files
- ChangeLog.md +14/−0
- parsley-core.cabal +8/−6
- src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs +8/−7
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/BindingOps.hs +25/−24
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs +10/−9
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs +101/−79
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs +211/−199
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputRep.hs +151/−83
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs +70/−61
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Base.hs +4/−4
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs +51/−44
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input.hs +20/−25
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input/Offset.hs +25/−19
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input/Pos.hs +1/−1
- src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Statics.hs +20/−13
- src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs +6/−5
- src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs +10/−8
- src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs +35/−37
- src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputOps.hs +10/−66
- src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputRep.hs +3/−18
- src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs +18/−15
- src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types/State.hs +22/−15
- src/ghc/Parsley/Internal.hs +10/−3
- src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs +51/−42
- src/ghc/Parsley/Internal/Backend/Analysis/Inliner.hs +6/−5
- src/ghc/Parsley/Internal/Backend/Analysis/Relevancy.hs +0/−1
- src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +46/−77
- src/ghc/Parsley/Internal/Backend/Machine/Identifiers.hs +1/−2
- src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +51/−68
- src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs +2/−2
- src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs +11/−10
- src/ghc/Parsley/Internal/Backend/Machine/THUtils.hs +0/−59
- src/ghc/Parsley/Internal/Backend/Machine/Types/Coins.hs +32/−50
- src/ghc/Parsley/Internal/Common/THUtils.hs +63/−0
- src/ghc/Parsley/Internal/Common/Utils.hs +1/−1
- src/ghc/Parsley/Internal/Core/CharPred.hs +12/−28
- src/ghc/Parsley/Internal/Core/CombinatorAST.hs +5/−14
- src/ghc/Parsley/Internal/Core/Defunc.hs +3/−2
- src/ghc/Parsley/Internal/Core/Identifiers.hs +1/−2
- src/ghc/Parsley/Internal/Core/InputTypes.hs +2/−0
- src/ghc/Parsley/Internal/Core/Lam.hs +46/−28
- src/ghc/Parsley/Internal/Frontend/Analysis/Cut.hs +106/−102
- src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs +3/−3
- src/ghc/Parsley/Internal/Frontend/Analysis/Inliner.hs +27/−15
- src/ghc/Parsley/Internal/Frontend/Compiler.hs +18/−15
- src/ghc/Parsley/Internal/Frontend/Optimiser.hs +145/−137
- src/ghc/Parsley/Internal/Opt.hs +51/−0
- test/Regression/Issue27.hs +60/−35
ChangeLog.md view
@@ -1,5 +1,19 @@ # Revision history for `parsley-core` +## 2.3.0.0 -- 2023-08-20++* Added internal support for optimisation flags, not exposed into public facing API yet.+ - These are threaded through many places and functions via an implicit parameter.+* Deprecated `Text16`, since it is flawed with UTF-8.+* Distinguished between static and dynamic input representations (`DynRep` vs `StaRep`).+* Improved static binding of input changing the signature of `eval`.+* Reworked input consumption and fixed several bugs.+* Moved to an `uncons` model, adjusted several of the `InputOps`.+* Removed `array`-backed `String` implementation.+* Stored `Offset` in the rewind queue, not `Input`.+* Unpacking and unboxing of internal structures, improving compile-time performance?+* Removed `Jump` instruction, it's not needed.+ ## 2.2.0.1 -- 2023-04-26 * Improved the free register analysis by reimplementing in terms of lambda-lifting algorithms.
parsley-core.cabal view
@@ -5,7 +5,7 @@ -- | +------- breaking internal API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 2.2.0.1+version: 2.3.0.0 synopsis: A fast parser combinator library backed by Typed Template Haskell description: This package contains the internals of the @parsley@ package. .@@ -41,12 +41,14 @@ exposed-modules: Parsley.Internal, Parsley.Internal.Trace, Parsley.Internal.Verbose,+ Parsley.Internal.Opt, Parsley.Internal.Common, Parsley.Internal.Common.Fresh, Parsley.Internal.Common.Indexed, Parsley.Internal.Common.QueueLike, Parsley.Internal.Common.State,+ Parsley.Internal.Common.THUtils, Parsley.Internal.Common.Utils, Parsley.Internal.Common.Vec, @@ -94,7 +96,6 @@ Parsley.Internal.Backend.Machine.InputRep, Parsley.Internal.Backend.Machine.Instructions, Parsley.Internal.Backend.Machine.Ops,- Parsley.Internal.Backend.Machine.THUtils, Parsley.Internal.Backend.Machine.Types, Parsley.Internal.Backend.Machine.Types.Coins,@@ -128,10 +129,10 @@ NoStarIsType --- ghc >= 8.6 && < 9.2,- build-depends: base >= 4.10 && < 4.17,+-- ghc >= 8.6 && < 9.8,+ build-depends: base >= 4.10 && < 4.19, mtl >= 2.2.1 && < 2.3,- hashable >= 1.2.7.0 && < 1.4,+ hashable >= 1.2.7.0 && < 1.5, unordered-containers >= 0.2.13 && < 0.3, array >= 0.5.2 && < 0.6, ghc-prim >= 0.5.3 && < 1,@@ -140,10 +141,11 @@ dependent-map >= 0.4.0 && < 0.5, dependent-sum >= 0.7.1 && < 0.8, pretty-terminal >= 0.1.0 && < 0.2,- text >= 1.2.3 && < 1.3,+ text >= 1.2.3 && < 2.1, -- Not sure about this one, 0.11.0.0 introduced a type synonym for PS, so it _should_ work bytestring >= 0.10.8 && < 0.12, rangeset >= 0.0.1 && < 0.2,+ syb >= 0.1 && < 0.8, build-tool-depends: cpphs:cpphs >= 1.18.8 && < 1.21 hs-source-dirs: src/ghc if impl(ghc >= 8.10)
src/ghc-8.10+/Parsley/Internal/Backend/Machine.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ImplicitParams, PatternSynonyms #-}+{-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed {-| Module : Parsley.Internal.Backend.Machine Description : The implementation of the low level parsing machinery is found here@@ -22,17 +24,18 @@ import Data.Text (Text) import Parsley.Internal.Backend.Machine.Defunc (user) import Parsley.Internal.Backend.Machine.Identifiers-import Parsley.Internal.Backend.Machine.InputOps (InputPrep(..))+import Parsley.Internal.Backend.Machine.InputOps (InputPrep, prepare) import Parsley.Internal.Backend.Machine.Instructions import Parsley.Internal.Backend.Machine.LetBindings (LetBinding, makeLetBinding, newMeta) import Parsley.Internal.Backend.Machine.Ops (Ops)-import Parsley.Internal.Backend.Machine.Types.Coins (Coins(..), zero, minCoins, maxCoins, plus, plus1, minus, plusNotReclaim)+import Parsley.Internal.Backend.Machine.Types.Coins (Coins(..), minCoins, plus1, minus, pattern Zero, items) import Parsley.Internal.Common.Utils (Code) import Parsley.Internal.Core.InputTypes import Parsley.Internal.Trace (Trace) import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Parsley.Internal.Backend.Machine.Eval as Eval (eval)+import qualified Parsley.Internal.Opt as Opt {-| This function is exposed to parsley itself and is used to generate the Haskell code@@ -40,8 +43,8 @@ @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+eval :: forall input a. (Input input, Trace, ?flags :: Opt.Flags) => Code input -> (LetBinding input a a, DMap MVar (LetBinding input a)) -> Code (Maybe a)+eval input (toplevel, bindings) = prepare input (Eval.eval toplevel bindings) {-| This class is exposed to parsley itself and is used to denote which types may be@@ -50,13 +53,11 @@ @since 0.1.0.0 -} class (InputPrep input, Ops input) => Input input-instance Input [Char]+instance Input String instance Input (UArray Int Char) instance Input Text16 instance Input ByteString instance Input CharList instance Input Text---instance Input CacheText instance Input Lazy.ByteString---instance Input Lazy.ByteString instance Input Stream
src/ghc-8.10+/Parsley/Internal/Backend/Machine/BindingOps.hs view
@@ -1,7 +1,9 @@ {-# OPTIONS_GHC -Wno-monomorphism-restriction #-}+{-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed {-# LANGUAGE AllowAmbiguousTypes, CPP, MagicHash,+ TypeApplications, UnboxedTuples #-} {-| Module : Parsley.Internal.Backend.Machine.BindingOps@@ -27,7 +29,7 @@ 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.InputRep (DynRep) import Parsley.Internal.Backend.Machine.Types.Base (Handler#, Pos) import Parsley.Internal.Backend.Machine.Types.Dynamics (DynSubroutine, DynCont, DynHandler) import Parsley.Internal.Backend.Machine.Types.Input (Input#(..))@@ -38,7 +40,7 @@ import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString) #define inputInstances(derivation) \-derivation([Char]) \+derivation(String) \ derivation((UArray Int Char)) \ derivation(Text16) \ derivation(ByteString) \@@ -62,14 +64,13 @@ -> (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 (pos :: Pos) (o# :: Rep _o) = \- $$(h (Input# [||o#||] [||pos||])) \- in $$(k [||handler||]) \- ||]; \+#define deriveHandlerOps(_o) \+instance HandlerOps _o where \+{ \+ bindHandler# h k = [|| \+ let handler (pos :: Pos) (o# :: DynRep _o) = $$(h (Input# [||o#||] [||pos||])) \+ in $$(k [||handler||]) \+ ||]; \ }; inputInstances(deriveHandlerOps) @@ -92,7 +93,7 @@ instance JoinBuilder _o where \ { \ setupJoinPoint# binding k = \- [|| let join x (pos :: Pos) !(o# :: Rep _o) = \+ [|| let join x (pos :: Pos) !(o# :: DynRep _o) = \ $$(binding [||x||] (Input# [||o#||] [||pos||])) in $$(k [||join||]) ||] \ }; inputInstances(deriveJoinBuilder)@@ -110,8 +111,8 @@ @since 1.4.0.0 -}- bindIterHandler# :: (Input# o -> StaHandler# s o a) -- ^ The iter handler to bind- -> (Code (Pos -> Rep o -> Handler# s o a) -> Code b) -- ^ The continuation that accepts the bound handler+ bindIterHandler# :: (Input# o -> StaHandler# s o a) -- ^ The iter handler to bind+ -> (Code (Pos -> DynRep o -> Handler# s o a) -> Code b) -- ^ The continuation that accepts the bound handler -> Code b {-|@@ -119,9 +120,9 @@ @since 1.4.0.0 -}- bindIter# :: Input# o -- ^ Initial offset for the loop.- -> (Code (Pos -> Rep o -> ST s (Maybe a)) -> Input# o -> Code (ST s (Maybe a))) -- ^ The code for the loop given self-call and offset.- -> Code (ST s (Maybe a)) -- ^ Code of the executing loop.+ bindIter# :: Input# o -- ^ Initial offset for the loop.+ -> (Code (Pos -> DynRep o -> ST s (Maybe a)) -> Input# o -> Code (ST s (Maybe a))) -- ^ The code for the loop given self-call and offset.+ -> Code (ST s (Maybe a)) -- ^ Code of the executing loop. {-| Creates a binding for a regular let-bound parser.@@ -135,16 +136,16 @@ instance RecBuilder _o where \ { \ bindIterHandler# h k = [|| \- let handler (posc :: Pos) (c# :: Rep _o) (poso :: Pos) (o# :: Rep _o) = \+ let handler (posc :: Pos) (c# :: DynRep _o) (poso :: Pos) (o# :: DynRep _o) = \ $$(h (Input# [||c#||] [||posc||]) (Input# [||o#||] [||poso||])) in $$(k [||handler||]) \ ||]; \ bindIter# inp l = [|| \- let loop (pos :: Pos) !(o# :: Rep _o) = $$(l [||loop||] (Input# [||o#||] [||pos||])) \+ let loop (pos :: Pos) !(o# :: DynRep _o) = $$(l [||loop||] (Input# [||o#||] [||pos||])) \ in loop $$(pos# inp) $$(off# inp) \ ||]; \ bindRec# binding = \ {- The idea here is to try and reduce the number of times registers have to be passed around -} \- [|| let self ret h (pos :: Pos) !(o# :: Rep _o) = \+ [|| let self ret h (pos :: Pos) !(o# :: DynRep _o) = \ $$(binding [||self||] [||ret||] [||h||] (Input# [||o#||] [||pos||])) in self ||] \ }; inputInstances(deriveRecBuilder)@@ -172,10 +173,10 @@ -} dynCont# :: StaCont# s o a x -> DynCont s o a x -#define deriveMarshalOps(_o) \-instance MarshalOps _o where \-{ \- dynHandler# sh = [||\ (pos :: Pos) (o# :: Rep _o) -> $$(sh (Input# [||o#||] [||pos||])) ||]; \- dynCont# sk = [||\ x (pos :: Pos) (o# :: Rep _o) -> $$(sk [||x||] (Input# [||o#||] [||pos||])) ||]; \+#define deriveMarshalOps(_o) \+instance MarshalOps _o where \+{ \+ dynHandler# sh = [||\ (pos :: Pos) (o# :: DynRep _o) -> $$(sh (Input# [||o#||] [||pos||])) ||]; \+ dynCont# sk = [||\ x (pos :: Pos) (o# :: DynRep _o) -> $$(sk [||x||] (Input# [||o#||] [||pos||])) ||]; \ }; inputInstances(deriveMarshalOps)
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Defunc.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSynonyms, StandaloneKindSignatures, TypeApplications, ViewPatterns #-}+{-# LANGUAGE ImplicitParams, PatternSynonyms, StandaloneKindSignatures, TypeApplications, ViewPatterns #-} {-| Module : Parsley.Internal.Backend.Machine.Defunc Description : Machine-level defunctionalisation@@ -27,6 +27,8 @@ import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm) import qualified Parsley.Internal.Core.Lam as Lam (Lam(..)) +import qualified Parsley.Internal.Opt as Opt+ {-| Machine level defunctionalisation, for terms that can only be introduced by the code generator, and that do not require value level representations.@@ -70,7 +72,7 @@ @since 1.3.0.0 -}-ap :: Defunc (a -> b) -> Defunc a -> Defunc b+ap :: (?flags :: Opt.Flags) => Defunc (a -> b) -> Defunc a -> Defunc b ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x)) {-|@@ -78,7 +80,7 @@ @since 1.3.0.0 -}-ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c+ap2 :: (?flags :: Opt.Flags) => Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c ap2 f x = ap (ap f x) {-|@@ -86,10 +88,10 @@ @since 1.3.0.0 -}-_if :: Defunc Bool -> Code a -> Code a -> Code a+_if :: (?flags :: Opt.Flags) => 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)) -unliftDefunc :: Defunc a -> Lam a+unliftDefunc :: (?flags :: Opt.Flags) => Defunc a -> Lam a unliftDefunc (LAM x) = x unliftDefunc x = Lam.Var False (genDefunc x) @@ -98,7 +100,7 @@ @since 1.0.0.0 -}-genDefunc :: Defunc a -> Code a+genDefunc :: (?flags :: Opt.Flags) => Defunc a -> Code a genDefunc (LAM x) = normaliseGen x genDefunc BOTTOM = [||undefined||] genDefunc INPUT{} = error "Cannot materialise an input in the regular way"@@ -108,7 +110,7 @@ @since 1.1.0.0 -}-pattern NormLam :: Lam a -> Defunc a+pattern NormLam :: (?flags :: Opt.Flags) => Lam a -> Defunc a pattern NormLam t <- LAM (normalise -> t) {-|@@ -117,7 +119,7 @@ @since 1.1.0.0 -}-pattern FREEVAR :: Code a -> Defunc a+pattern FREEVAR :: (?flags :: Opt.Flags) => Code a -> Defunc a pattern FREEVAR v <- NormLam (Lam.Var True v) where FREEVAR v = LAM (Lam.Var True v)@@ -125,5 +127,4 @@ instance Show (Defunc a) where show (LAM x) = show x show BOTTOM = "[[irrelevant]]"- show (FREEVAR _) = "x" show (INPUT inp) = "input " ++ show (off inp)
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Eval.hs view
@@ -21,59 +21,60 @@ import Data.Dependent.Map (DMap) import Data.Functor ((<&>)) import Data.Void (Void)-import Control.Monad (forM, liftM2, liftM3, when)-import Control.Monad.Reader (ask, asks, reader, local)+import Control.Monad (forM, liftM2, liftM3)+import Control.Monad.Reader (Reader, ask, asks, reader, local) import Control.Monad.ST (runST) import Parsley.Internal.Backend.Machine.Defunc (Defunc(INPUT, LAM), pattern FREEVAR, genDefunc, ap, ap2, _if) import Parsley.Internal.Backend.Machine.Identifiers (MVar(..), ΦVar, ΣVar)-import Parsley.Internal.Backend.Machine.InputOps (InputDependant, InputOps(InputOps))-import Parsley.Internal.Backend.Machine.InputRep (Rep)+import Parsley.Internal.Backend.Machine.InputOps (InputOps, DynOps)+import Parsley.Internal.Backend.Machine.InputRep (StaRep) import Parsley.Internal.Backend.Machine.Instructions (Instr(..), MetaInstr(..), Access(..), Handler(..), PosSelector(..)) import Parsley.Internal.Backend.Machine.LetBindings (LetBinding(body)) import Parsley.Internal.Backend.Machine.LetRecBuilder (letRec) import Parsley.Internal.Backend.Machine.Ops-import Parsley.Internal.Backend.Machine.Types (MachineMonad, Machine(..), run)+import Parsley.Internal.Backend.Machine.Types (MachineMonad, Machine(..), run, qSubroutine) import Parsley.Internal.Backend.Machine.PosOps (initPos) import Parsley.Internal.Backend.Machine.Types.Context-import Parsley.Internal.Backend.Machine.Types.Coins (willConsume, int)-import Parsley.Internal.Backend.Machine.Types.Input (Input(off), mkInput, forcePos, updatePos)+import Parsley.Internal.Backend.Machine.Types.Coins (Coins(knownPreds, willConsume, willCache), one, minus)+import Parsley.Internal.Backend.Machine.Types.Input (Input(off), mkInput, forcePos, updatePos, updateOffset)+import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset(offset), unsafeDeepestKnown) import Parsley.Internal.Backend.Machine.Types.State (Γ(..), OpStack(..)) import Parsley.Internal.Common (Fix4, cata4, One, Code, Vec(..), Nat(..))-import Parsley.Internal.Core.CharPred (CharPred, lamTerm, optimisePredGiven)+import Parsley.Internal.Core.CharPred (CharPred(UserPred), pattern Item, lamTerm, optimisePredGiven) import Parsley.Internal.Trace (Trace(trace)) import System.Console.Pretty (color, Color(Green)) import qualified Debug.Trace (trace)+import qualified Parsley.Internal.Opt as Opt+import Parsley.Internal.Opt (Flags(leadCharFactoring)) {-| 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.+eval :: forall o a. (Trace, Ops o, ?ops :: InputOps (StaRep o), ?flags :: Opt.Flags)+ => LetBinding o a a -- ^ The binding to be generated. -> DMap MVar (LetBinding o a) -- ^ The map of all other required bindings.+ -> StaRep o -> Code (Maybe a) -- ^ The code for this parser.-eval input binding fs = trace "EVALUATING TOP LEVEL" [|| runST $- do let !(# next, more, offset #) = $$input- $$(let ?ops = InputOps [||more||] [||next||]- in letRec fs+eval binding fs offset = trace "EVALUATING TOP LEVEL" [||+ runST $$(letRec fs nameLet (\μ exp rs names -> buildRec μ rs (emptyCtx names) (readyMachine exp))- (run (readyMachine (body binding)) (Γ Empty halt (mkInput [||offset||] initPos) (VCons fatal VNil)) . nextUnique . emptyCtx))+ qSubroutine+ (run (readyMachine (body binding)) (Γ Empty halt (mkInput offset initPos) (VCons fatal VNil)) . nextUnique . emptyCtx)) ||] where nameLet :: MVar x -> String nameLet (MVar i) = "sub" ++ show i -readyMachine :: (?ops :: InputOps (Rep o), Ops o, Trace) => Fix4 (Instr o) xs n r a -> Machine s o xs n r a+readyMachine :: (?ops :: InputOps (StaRep o), Ops o, Trace, ?flags :: Opt.Flags) => Fix4 (Instr o) xs n r a -> Machine s o xs n r a readyMachine = cata4 (Machine . alg) where- alg :: (?ops :: InputOps (Rep o), Ops o) => Instr o (Machine s o) xs n r a -> MachineMonad s o xs n r a+ alg :: (?ops :: InputOps (StaRep o), Ops o, ?flags :: Opt.Flags) => Instr o (Machine s o) xs n r a -> MachineMonad s o xs n r a alg Ret = evalRet alg (Call μ k) = evalCall μ k- alg (Jump μ) = evalJump μ alg (Push x k) = evalPush x k alg (Pop k) = evalPop k alg (Lift2 f k) = evalLift2 f k@@ -98,56 +99,45 @@ alg (LogExit name k) = evalLogExit name k alg (MetaInstr m k) = evalMeta m k -evalRet :: MachineMonad s o (x : xs) n x a+evalRet :: (DynOps o, ?flags :: Opt.Flags) => MachineMonad s o (x : xs) n x a 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 :: forall s o a x xs n r. (MarshalOps o, DynOps o, ?flags :: Opt.Flags) => MVar x -> Machine s o (x : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a evalCall μ (Machine k) = freshUnique $ \u -> liftM2 (callCC u) (askSub μ) k -evalJump :: forall s o a x n. MarshalOps o => MVar x -> MachineMonad s o '[] (Succ n) x a-evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation @o sub retCont input handlers- evalPush :: Defunc x -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a evalPush x (Machine k) = k <&> \m γ -> m (γ {operands = Op x (operands γ)}) evalPop :: Machine s o xs n r a -> MachineMonad s o (x : xs) n r a evalPop (Machine k) = k <&> \m γ -> m (γ {operands = let Op _ xs = operands γ in xs}) -evalLift2 :: Defunc (x -> y -> z) -> Machine s o (z : xs) n r a -> MachineMonad s o (y : x : xs) n r a+evalLift2 :: (?flags :: Opt.Flags) => 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 :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps (Rep o), Trace) => CharPred -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a-evalSat p k@(Machine k') = do+evalSat :: forall s o xs n r a. (?ops :: InputOps (StaRep o), DynOps o, Trace, ?flags :: Opt.Flags) => CharPred -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a+evalSat p mk = do bankrupt <- asks isBankrupt hasChange <- asks hasCoin- if | bankrupt -> emitCheckAndFetch 1 k- | hasChange -> local spendCoin (satFetch k)- | otherwise -> trace "I have a piggy :)" $- local breakPiggy $- do check <- asks (emitCheckAndFetch . coins)- check (Machine (local spendCoin k'))+ if | bankrupt -> withLengthCheckAndCoins (one p) satFetch+ | hasChange -> satFetch+ | otherwise -> trace "I have a piggy :)" $ state breakPiggy $ \coins -> withLengthCheckAndCoins coins satFetch where- satFetch :: Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a- satFetch mk = reader $ \ctx γ ->- readChar ctx p (fetch (input γ)) $ \c staOldPred staPosPred input' ctx' ->+ satFetch :: MachineMonad s o xs (Succ n) r a+ satFetch = reader $ \ctx γ ->+ readChar (spendCoin ctx) p (fetch (off (input γ))) $ \c staOldPred staPosPred offset' ctx' -> let staPredC' = optimisePredGiven p staOldPred- in sat (ap (LAM (lamTerm staPredC'))) c (continue mk γ (updatePos input' c staPosPred) ctx')+ in sat (ap (LAM (lamTerm staPredC'))) c (continue mk γ (updatePos (updateOffset offset' (input γ)) c staPosPred) ctx') (raise γ) - emitCheckAndFetch :: Int -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a- emitCheckAndFetch n mk = do- sat <- satFetch mk- return $ \γ -> emitLengthCheck n (sat γ) (raise γ) (off (input γ))- continue mk γ input' ctx v = run mk (γ {input = input', operands = Op v (operands γ)}) ctx -evalEmpt :: MachineMonad s o xs (Succ n) r a+evalEmpt :: (DynOps o, ?flags :: Opt.Flags) => MachineMonad s o xs (Succ n) r a evalEmpt = return $! raise 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 :: (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 :: (PositionOps (StaRep o), HandlerOps o, DynOps 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 gh (Machine h) -> liftM2 (\mk mh γ -> bindAlwaysHandler γ gh (buildHandler γ mh u) mk) k h@@ -160,14 +150,14 @@ evalSeek :: Machine s o xs n r a -> MachineMonad s o (o : xs) n r a evalSeek (Machine k) = k <&> \mk γ -> let Op (INPUT input) xs = operands γ in mk (γ {operands = xs, input = input}) -evalCase :: Machine s o (x : xs) n r a -> Machine s o (y : xs) n r a -> MachineMonad s o (Either x y : xs) n r a+evalCase :: (?flags :: Opt.Flags) => Machine s o (x : xs) n r a -> Machine s o (y : xs) n r a -> MachineMonad s o (Either x y : xs) n r a evalCase (Machine p) (Machine q) = liftM2 (\mp mq γ -> let Op e xs = operands γ in [||case $$(genDefunc e) of Left x -> $$(mp (γ {operands = Op (FREEVAR [||x||]) xs})) Right y -> $$(mq (γ {operands = Op (FREEVAR [||y||]) xs}))||]) p q -evalChoices :: [Defunc (x -> Bool)] -> [Machine s o xs n r a] -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a+evalChoices :: (?flags :: Opt.Flags) => [Defunc (x -> Bool)] -> [Machine s o xs n r a] -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a evalChoices fs ks (Machine def) = liftM2 (\mdef mks γ -> let Op x xs = operands γ in go x fs mks mdef (γ {operands = xs})) def (forM ks getMachine)@@ -175,82 +165,114 @@ go x (f:fs) (mk:mks) def γ = _if (ap f x) (mk γ) (go x fs mks def γ) go _ _ _ def γ = def γ -evalIter :: (RecBuilder o, PositionOps (Rep o), HandlerOps o)+evalIter :: (RecBuilder o, PositionOps (StaRep o), HandlerOps o, DynOps 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 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 gh (Machine h) ->- liftM2 (\mh ctx γ -> bindIterAlways ctx μ l gh (buildHandler γ mh u1) (input γ) u2) h ask- Same gyes (Machine yes) gno (Machine no) ->- liftM3 (\myes mno ctx γ -> bindIterSame ctx μ l gyes (buildIterYesHandler γ myes u1) gno (buildHandler γ mno u1) (input γ) u2) yes no ask+ local voidCoins $ -- We must not allow factored input to pass through to iterative handlers, they have rolling inputs+ case h of+ Always gh (Machine h) ->+ liftM2 (\mh ctx γ -> bindIterAlways ctx μ l gh (buildHandler γ mh u1) (input γ) u2) h ask+ Same gyes (Machine yes) gno (Machine no) ->+ liftM3 (\myes mno ctx γ -> bindIterSame ctx μ l gyes (buildIterYesHandler γ myes u1) gno (buildHandler γ mno u1) (input γ) u2) yes no ask -evalJoin :: ΦVar x -> MachineMonad s o (x : xs) n r a+evalJoin :: (DynOps o, ?flags :: Opt.Flags) => ΦVar x -> MachineMonad s o (x : xs) n r a evalJoin φ = askΦ φ <&> resume -evalMkJoin :: JoinBuilder o => ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a+evalMkJoin :: (DynOps o, ?flags :: Opt.Flags) => JoinBuilder o => ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a evalMkJoin = setupJoinPoint evalSwap :: Machine s o (x : y : xs) n r a -> MachineMonad s o (y : x : xs) n r a evalSwap (Machine k) = k <&> \mk γ -> mk (γ {operands = let Op y (Op x xs) = operands γ in Op x (Op y xs)}) -evalDup :: Machine s o (x : x : xs) n r a -> MachineMonad s o (x : xs) n r a+evalDup :: (?flags :: Opt.Flags) => Machine s o (x : x : xs) n r a -> MachineMonad s o (x : xs) n r a evalDup (Machine k) = k <&> \mk γ -> let Op x xs = operands γ 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 :: (?flags :: Opt.Flags) => ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a evalMake σ a k = reader $ \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 :: (?flags :: Opt.Flags) => ΣVar x -> Access -> Machine s o (x : xs) n r a -> MachineMonad s o xs n r a evalGet σ a k = reader $ \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 :: (?flags :: Opt.Flags) => ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a evalPut σ a k = reader $ \ctx γ -> let Op x xs = operands γ in writeΣ σ a x (run k (γ {operands = xs})) ctx -evalSelectPos :: PosSelector -> Machine s o (Int : xs) n r a -> MachineMonad s o xs n r a+evalSelectPos :: (?flags :: Opt.Flags) => PosSelector -> Machine s o (Int : xs) n r a -> MachineMonad s o xs n r a evalSelectPos sel (Machine k) = k <&> \m γ -> forcePos (input γ) sel $ \component input' -> m (γ {operands = Op (FREEVAR component) (operands γ), input = input'}) -evalLogEnter :: (?ops :: InputOps (Rep o), LogHandler o, HandlerOps o)+evalLogEnter :: (?ops :: InputOps (StaRep o), LogHandler o, HandlerOps o, ?flags :: Opt.Flags) => String -> Machine s o xs (Succ (Succ n)) r a -> MachineMonad s o xs (Succ n) r a evalLogEnter name (Machine mk) = freshUnique $ \u -> liftM2 (\k ctx γ -> [|| Debug.Trace.trace $$(preludeString name '>' γ ctx "") $$(bindAlwaysHandler γ True (logHandler name ctx γ u) k)||]) (local debugUp mk) ask -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 :: (?ops :: InputOps (StaRep o), PositionOps (StaRep o), LogOps (StaRep o), DynOps 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 (Rep o)) => MetaInstr n -> Machine s o xs n r a -> MachineMonad s o xs n r a+evalMeta :: (?ops :: InputOps (StaRep o), DynOps o, ?flags :: Opt.Flags) => MetaInstr n -> Machine s o xs n r a -> MachineMonad s o xs n r a+evalMeta _ (Machine k) | not (Opt.lengthCheckFactoring ?flags) = k evalMeta (AddCoins coins) (Machine k) =- do requiresPiggy <- asks hasCoin- if requiresPiggy then local (storePiggy coins) k- else local (giveCoins coins) k <&> \mk γ -> emitLengthCheck (willConsume coins) (mk γ) (raise γ) (off (input γ))-evalMeta (RefundCoins coins) (Machine k) = local (refundCoins coins) k+ -- when there are coins available, this cannot be discharged, and will wait until the current amounts+ -- are exhausted. Because it might have been the case that lookahead was performed to refund, the+ -- over-imbursement cannot be done in advance, and is instead done here, deducting the net-worth+ -- of the coin count to ensure that only enough to make up the change is put in the piggy-banks+ do net <- asks netWorth+ let requiresPiggy = net /= 0+ if requiresPiggy then local (storePiggy (coins `minus` net)) k+ else withLengthCheckAndCoins coins k+evalMeta (RefundCoins coins) (Machine k)+ | Opt.reclaimInput ?flags = local (refundCoins coins) k+ | otherwise = local (giveCoins coins) k -- No interaction with input reclamation here! evalMeta (DrainCoins coins) (Machine k) =- -- If there are enough coins left to cover the cost, no length check is required- -- Otherwise, the full length check is required (partial doesn't work until the right offset is reached)- liftM2 (\canAfford mk γ -> if canAfford then mk γ else emitLengthCheck (willConsume coins) (mk γ) (raise γ) (off (input γ)))- (asks (canAfford (willConsume coins)))+ liftM3 drain+ (asks isBankrupt)+ (asks (canAfford coins)) k-evalMeta (GiveBursary coins) (Machine k) = local (giveCoins coins) k-evalMeta (PrefetchChar check) k =- do bankrupt <- asks isBankrupt- when (not bankrupt && check) (error "must be bankrupt to generate a prefetch check")- mkCheck check (reader $ \ctx γ -> prefetch (input γ) ctx (run k γ)) where- mkCheck True k = local (giveCoins (int 1)) k <&> \mk γ -> emitLengthCheck 1 (mk γ) (raise γ) (off (input γ))- mkCheck False k = k- prefetch o ctx k = fetch o (\c o' -> k (addChar c o' ctx))-evalMeta BlockCoins (Machine k) = k+ -- there are enough coins to pay in full+ drain _ Nothing mk γ = mk γ+ drain bankrupt ~(Just m) mk γ+ -- full length check required+ | bankrupt = emitLengthCheck coins 0 Nothing (\off _ -> withUpdatedOffset mk γ off) (raise γ) (off (input γ)) offset+ -- can be partially paid from last known deepest offset+ | otherwise = emitLengthCheck (m + 1) 0 Nothing (\off _ -> withUpdatedOffset mk γ off) (raise γ) (off (input γ)) unsafeDeepestKnown+evalMeta (GiveBursary coins) (Machine k) = local (giveCoins coins) k+evalMeta BlockCoins{} (Machine k) = k++withUpdatedOffset :: (Γ s o xs n r a -> t) -> Γ s o xs n r a -> Offset o -> t+withUpdatedOffset k γ off = k (γ { input = updateOffset off (input γ)})++withLengthCheckAndCoins :: (?ops::InputOps (StaRep o), DynOps o, ?flags :: Opt.Flags) => Coins -> MachineMonad s o xs (Succ n) r a -> MachineMonad s o xs (Succ n) r a+withLengthCheckAndCoins coins k = reader $ \ctx γ ->+ -- it seems like _specific_ prefetching must not move out of the scope of a handler that rolls back (like try)+ -- It does work, however, if exactly one character is considered (see take 1 below) and then n-1 Items, which cannot fail+ let prefetch ((c, offset'), pred) k = k . addChar pred c offset'+ remainder deepest ctx = withUpdatedOffset (flip (run (Machine k)) (giveCoins (willConsume coins) ctx)) γ deepest+ staPred = knownPreds coins >>= onlyStatic+ preds = maybe id (:) staPred (repeat Item) -- these are fed in to ensure the right checked pred is accounted for+ headCheck = staPred <&> \pred c good -> sat (ap (LAM (lamTerm pred))) c (const good) (raise γ)+ good deepest cached = foldr prefetch (remainder deepest) (zip cached preds) ctx+ in emitLengthCheck (willConsume coins) (willCache coins) headCheck good (raise γ) (off (input γ)) offset+ -- this is needed because a cached predicate cannot be compared for equality if it's user-pred, and it'll duplicate!+ where onlyStatic UserPred{} = Nothing+ onlyStatic p | leadCharFactoring ?flags = Just p+ onlyStatic _ = Nothing++state :: (r -> (a, r)) -> (a -> Reader r b) -> Reader r b+state f k = do+ (x, r) <- asks f+ local (const r) (k x)
src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputOps.hs view
@@ -1,9 +1,15 @@ {-# OPTIONS_HADDOCK show-extensions #-}-{-# LANGUAGE CPP,+{-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed+{-# LANGUAGE AllowAmbiguousTypes,+ CPP,+ ConstraintKinds,+ FunctionalDependencies, ImplicitParams, MagicHash,+ RecordWildCards, TypeApplications, UnboxedTuples #-}+{-# LANGUAGE InstanceSigs #-} {-| Module : Parsley.Internal.Backend.Machine.InputOps Description : Primitive operations for working with input.@@ -17,63 +23,45 @@ @since 1.0.0.0 -} module Parsley.Internal.Backend.Machine.InputOps (- InputPrep(..), PositionOps(..), LogOps(..),- InputOps(..), more, next,+ InputPrep, PositionOps(..), LogOps(..), DynOps, asDyn, asSta,+ InputOps, next, check, uncons, #if __GLASGOW_HASKELL__ <= 900- word8ToWord#, word16ToWord#,+ word8ToWord#, #endif- InputDependant+ prepare ) where -import Data.Array.Base (UArray(..), listArray)+import Data.Array.Base (UArray(..){-, listArray-}) import Data.ByteString.Internal (ByteString(..))-import Data.Text.Array (aBA{-, empty-}) import Data.Text.Internal (Text(..))-import Data.Text.Unsafe (iter, Iter(..){-, iter_, reverseIter_-})+import Data.Text.Unsafe (iter, Iter(..)) import GHC.Exts (Int(..), Char(..), TYPE, Int#) import GHC.ForeignPtr (ForeignPtr(..))-import GHC.Prim (indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#), (-#))+import GHC.Prim (indexWideCharArray#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (-#)) #if __GLASGOW_HASKELL__ > 900-import GHC.Prim (word16ToWord#, word8ToWord#)+import GHC.Prim (word8ToWord#) #else import GHC.Prim (Word#) #endif-import Parsley.Internal.Backend.Machine.InputRep (Stream(..), CharList(..), Text16(..), Rep, UnpackedLazyByteString,- offWith, emptyUnpackedLazyByteString, intSame, intLess,- offsetText, offWithSame, offWithShiftRight, dropStream,- textShiftRight, textShiftLeft, byteStringShiftRight,- byteStringShiftLeft, max#)+import Parsley.Internal.Backend.Machine.InputRep (Stream(..), CharList(..), Text16(..), DynRep, StaRep, UnpackedLazyByteString,+ StaText(..), PartialStaText(..), staText, PartialStaOffWith(..), staOffWith,+ PartialStaOffset(..), dynOffset,+ emptyUnpackedLazyByteString, intSame, intLess, intAdd, intSubNonNeg,+ offWithShiftRight, dropStream,+ textShiftRight, textShiftLeft, byteStringShiftRight, offsetText,+ byteStringShiftLeft, byteStringNext) import Parsley.Internal.Common.Utils (Code) import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))---import qualified Data.Text as Text (length, index) - #if __GLASGOW_HASKELL__ <= 900 {-# INLINE word8ToWord# #-} word8ToWord# :: Word# -> Word# word8ToWord# x = x--{-# INLINE word16ToWord# #-}-word16ToWord# :: Word# -> Word#-word16ToWord# x = x #endif -{- 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- #)+prepare :: InputPrep input => Code input -> ((?ops :: InputOps (StaRep input)) => StaRep input -> Code r) -> Code r+prepare qinput k = _prepare qinput (\_ops -> let ?ops = _ops in k) {- Typeclasses -} {-|@@ -90,7 +78,7 @@ @since 1.0.0.0 -}- prepare :: rep ~ Rep input => Code input -> Code (InputDependant rep)+ _prepare :: starep ~ StaRep input => Code input -> (InputOps starep -> starep -> Code r) -> Code r {-| Defines operations for manipulating offsets for regular use. These are not@@ -99,64 +87,88 @@ @since 1.0.0.0 -}-class PositionOps (rep :: TYPE r) where+class PositionOps rep 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+ same :: rep -> 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`.+type DynOps o = DynOps_ (DynRep o) (StaRep o) - @since 1.0.0.0- -}- shiftRight :: Code rep -> Code Int# -> Code rep+asDyn :: forall input. DynOps input => StaRep input -> Code (DynRep input)+asDyn = _asDyn +asSta :: forall input. DynOps input => Code (DynRep input) -> StaRep input+asSta = _asSta++class DynOps_ (dynrep :: TYPE r) starep | dynrep -> starep, starep -> dynrep where+ _asDyn :: starep -> Code dynrep+ _asSta :: Code dynrep -> starep+ {-| Defines operation used for debugging operations. @since 1.0.0.0 -}-class LogOps (rep :: TYPE r) where+class LogOps rep 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+ shiftLeft :: rep -> Int -> (rep -> Code a) -> Code a {-|+ 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 2.3.0.0+ -}+ shiftRight :: rep -> Int -> (rep -> Code a) -> Code a++ {-| Converts the represention of the input into an @Int@. @since 1.0.0.0 -}- offToInt :: Code rep -> Code Int+ offToInt :: rep -> Code Int {-| This is a psuedo-typeclass, which depends directly on the values obtained from-`InputDependant`. Because this instance must depend on local information, it is+`prepare`. Because this instance may 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)- }-{-|-Wraps around `InputOps` and `_more`.--Queries the input to see if another character may be consumed.+data InputOps rep = InputOps { _next :: !(forall a. rep -> (Code Char -> rep -> Code a) -> Code a) -- ^ Read the next character (without checking existence)+ , _uncons :: !(forall a. rep -> (Code Char -> rep -> Code a) -> Code a -> Code a) -- ^ Read the next character, may check existence+ , _ensureN :: !(forall a. Int -> rep -> (rep -> Code a) -> Code a -> Code a) -- ^ Ensure that n characters exist+ , _ensureNIsFast :: !Bool -- ^ _ensureN is O(1) and not O(n)+ } -@since 1.4.0.0--}-more :: forall r (rep :: TYPE r). (?ops :: InputOps rep) => Code rep -> Code Bool-more qo# = [|| $$(_more ?ops) $$(qo#) ||]+checkImpl :: forall rep a. Bool -- ^ is the ensureN argument O(1)?+ -> (Int -> rep -> (rep -> Code a) -> Code a -> Code a) -- ^ ensures there are n characters available+ -> (rep -> (Code Char -> rep -> Code a) -> Code a -> Code a) -- ^ reads the next character if available+ -> (Int -> Int -> rep -> Maybe (Code Char -> Code a -> Code a) -> (rep -> [(Code Char, rep)] -> Code a) -> Code a -> Code a)+checkImpl fastEnsureN ensureN uncons n m qi headCheck good bad+ | fastEnsureN, n /= 0 = ensureN n qi (go n m qi id headCheck . Just) bad+ | otherwise = go n m qi id headCheck Nothing+ where+ go :: Int -> Int -> rep -> ([(Code Char, rep)] -> [(Code Char, rep)]) -> Maybe (Code Char -> Code a -> Code a) -> Maybe rep -> Code a+ go 0 _ qi dcs _ _ = good qi (dcs [])+ -- Here, we want no more cached characters, so just verify the remaining with shiftRight+ go n 0 qi dcs _ Nothing = ensureN n qi (\qi' -> good qi' (dcs [])) bad+ -- We've already fastEnsured all the characters, so just feed forward the furthest to fill non-cached+ go _ 0 _ dcs _ (Just furthest) = good furthest (dcs [])+ -- Cached character wanted, so read it+ go n m qi dcs headCheck furthest = flip (uncons qi) bad $ \c qi' ->+ maybe id ($ c) headCheck $ -- if there is a headCheck available, perform it here DON'T pass it on+ go (n - 1) (m - 1) qi' (dcs . ((c, qi') :)) Nothing furthest {-| Wraps around `InputOps` and `_next`.@@ -167,176 +179,176 @@ @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'||]) ||]+next :: forall rep a. (?ops :: InputOps rep) => rep -> (Code Char -> rep -> Code a) -> Code a+next = _next ?ops -{- INSTANCES -}--- InputPrep Instances-instance InputPrep [Char] where- prepare input = prepare @(UArray Int Char) [||listArray (0, length $$input-1) $$input||]+uncons :: forall rep a. (?ops :: InputOps rep) => rep -> (Code Char -> rep -> Code a) -> Code a -> Code a+uncons = _uncons ?ops -instance InputPrep (UArray Int Char) where- prepare qinput = [||- let !(UArray _ _ (I# size#) input#) = $$qinput- next i# = (# C# (indexWideCharArray# input# i#), i# +# 1# #)- in (# next, \qi -> $$(intLess [||qi||] [||size#||]), 0# #)- ||]+check :: forall rep a. (?ops :: InputOps rep) => Int -> Int -> rep -> Maybe (Code Char -> Code a -> Code a) -> (rep -> [(Code Char, rep)] -> Code a) -> Code a -> Code a+check = checkImpl (_ensureNIsFast ?ops)+ (_ensureN ?ops)+ uncons -instance InputPrep Text16 where- prepare qinput = [||- let Text16 (Text arr (I# off#) (I# size#)) = $$qinput- arr# = aBA arr- next i# = (# C# (chr# (word2Int# (word16ToWord# (indexWord16Array# arr# i#)))), i# +# 1# #)- in (# next, \qi -> $$(intLess [||qi||] [||size#||]), off# #)- ||]+{- INSTANCES -}+-- InputPrep Instances+instance InputPrep String where+ _prepare qinput k =+ k (InputOps (\pocs k -> staOffWith pocs $ \po qcs -> [|| let c:cs' = $$qcs in $$(k [||c||] (StaOW (intAdd po 1) [||cs'||])) ||])+ (\pocs good bad -> staOffWith pocs $ \po qcs -> [||+ case $$qcs of+ c : cs' -> $$(good [||c||] (StaOW (intAdd po 1) [||cs'||]))+ [] -> $$bad+ ||])+ (\n pocs good bad -> staOffWith pocs $ \qo qcs -> let (qo', qcs') = offWithShiftRight [||drop||] qo qcs (n - 1) in [||+ case $$qcs' of+ [] -> $$bad+ cs -> $$(good (StaOW qo' [||cs||]))+ ||])+ False)+ (StaOW (_asSta [||0#||]) qinput) instance InputPrep ByteString where- prepare qinput = [||+ _prepare qinput k = [|| let PS (ForeignPtr addr# final) (I# off#) (I# size#) = $$qinput next i# = case readWord8OffAddr# (addr# `plusAddr#` i#) 0# realWorld# of (# s', x #) -> case touch# final s' of- _ -> (# C# (chr# (word2Int# (word8ToWord# x))), i# +# 1# #)- in (# next, \qi -> $$(intLess [||qi||] [||size#||]), off# #)- ||]--instance InputPrep CharList where- prepare qinput = [||- let CharList input = $$qinput- next :: (# Int#, [Char] #) -> (# Char, (# Int#, [Char] #) #)- next (# i#, c:cs #) = (# c, (# i# +# 1#, cs #) #)- more :: (# Int#, [Char] #) -> Bool- more (# _, [] #) = False- more _ = True- in (# next, more, $$(offWith [||input||]) #)+ !_ -> chr# (word2Int# (word8ToWord# x))+ in $$(k (InputOps (\qi k -> [|| let !c# = next $$(dynOffset qi) in $$(k [||C# c#||] (intAdd qi 1)) ||])+ (\qi k _ -> [|| let !c# = next $$(dynOffset qi) in $$(k [||C# c#||] (intAdd qi 1)) ||]) -- always guarded by fastEnsureN+ (\n qi k -> intLess (dynOffset (intAdd qi (n - 1))) [||size#||] (k qi))+ True)+ (_asSta [||off#||])) ||] instance InputPrep Text where- prepare qinput = [||- let next t@(Text arr off unconsumed) = let !(Iter c d) = iter t 0 in (# c, Text arr (off + d) (unconsumed - d) #)- more (Text _ _ unconsumed) = unconsumed > 0- in (# next, more, $$qinput #)+ _prepare qinput k =+ k (InputOps (\pt k -> staText pt $ \t@StaText{..} -> [||+ let !(Iter c d) = iter $$origText 0+ !unconsumed' = $$unconsumedText - d+ !off' = $$offText + d+ in $$(k [||c||] (StaT $ t {origText = [||Text $$arrText off' unconsumed'||],+ offText = [||off'||],+ unconsumedText = [||unconsumed'||]})) ||])+ (\pt good bad -> staText pt $ \t@StaText{..} -> [||+ if $$unconsumedText > 0 then+ let !(Iter c d) = iter $$origText 0+ !unconsumed' = $$unconsumedText - d+ !off' = $$offText + d+ in $$(good [||c||] (StaT $ t {origText = [||Text $$arrText off' unconsumed'||],+ offText = [||off'||],+ unconsumedText = [||unconsumed'||]}))+ else $$bad+ ||])+ (\(I# n) pt good bad -> staText pt $ \StaText{..} -> [|| -- could be improved, I guess?+ case $$(textShiftRight origText (n -# 1#)) of+ Text _ _ 0 -> $$bad+ t@(Text _ off unconsumed) -> $$(good (StaT $ StaText [||t||] arrText [||off||] [||unconsumed||]))+ ||])+ False)+ (DynT qinput)++--instance InputPrep String where _prepare input = _prepare @(UArray Int Char) [||listArray (0, length $$input-1) $$input||]+instance InputPrep (UArray Int Char) where+ _prepare qinput k = [||+ let !(UArray _ _ (I# size#) input#) = $$qinput+ in $$(k (InputOps (\qi k -> k [||C# (indexWideCharArray# input# $$(dynOffset qi))||] (intAdd qi 1))+ (\qi k _ -> k [||C# (indexWideCharArray# input# $$(dynOffset qi))||] (intAdd qi 1)) -- always guarded by fastEnsureN+ (\n qi k -> intLess (dynOffset (intAdd qi (n - 1))) [||size#||] (k qi))+ True)+ (_asSta [||0#||])) ||] instance InputPrep Lazy.ByteString where- prepare qinput = [||- let next (# i#, addr#, final, off#, size#, cs #) =- case readWord8OffAddr# addr# off# realWorld# of- (# s', x #) -> case touch# final s' of- _ -> (# C# (chr# (word2Int# (word8ToWord# x))),- if I# size# /= 1 then (# i# +# 1#, addr#, final, off# +# 1#, size# -# 1#, cs #)- else case cs of- Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' ->- (# i# +# 1#, addr'#, final', off'#, size'#, cs' #)- Lazy.Empty -> $$(emptyUnpackedLazyByteString [||i# +# 1#||])- #)- more :: UnpackedLazyByteString -> Bool- more (# _, _, _, _, 0#, _ #) = False- more (# _, _, _, _, _, _ #) = True-- initial :: UnpackedLazyByteString+ _prepare qinput k = [||+ let initial :: UnpackedLazyByteString initial = case $$qinput of Lazy.Chunk (PS (ForeignPtr addr# final) (I# off#) (I# size#)) cs -> (# 0#, addr#, final, off#, size#, cs #) Lazy.Empty -> $$(emptyUnpackedLazyByteString [||0#||])- in (# next, more, initial #)+ in $$(k (InputOps (\qi k -> [|| let !(# c, qi' #) = byteStringNext $$qi in $$(k [||c||] [||qi'||]) ||])+ (\qi good bad -> [||+ case $$qi of+ (# _, _, _, _, 0#, _ #) -> $$bad+ bs ->+ let !(# c, qi' #) = byteStringNext bs in $$(good [||c||] [||qi'||])+ ||])+ (\(I# n) qi good bad -> [||+ case $$(byteStringShiftRight qi (n -# 1#)) of+ (# _, _, _, _, 0#, _ #) -> $$bad+ bs -> $$(good [||bs||])+ ||])+ False)+ [||initial||]) ||] instance InputPrep Stream where- prepare qinput = [||- let next (# o#, c :> cs #) = (# c, (# o# +# 1#, cs #) #)- in (# next, \_ -> True, $$(offWith qinput) #)- ||]+ _prepare qinput k =+ k (InputOps (\pocs k -> staOffWith pocs $ \po qcs -> [|| let c :> cs' = $$qcs in $$(k [||c||] (StaOW (intAdd po 1) [||cs'||])) ||])+ (\pocs k _ -> staOffWith pocs $ \po qcs -> [|| let c :> cs' = $$qcs in $$(k [||c||] (StaOW (intAdd po 1) [||cs'||])) ||])+ (\n pocs good _ -> staOffWith pocs $ \qo qcs -> good (uncurry StaOW $ offWithShiftRight [||dropStream||] qo qcs (n - 1)))+ True)+ (StaOW (_asSta [||0#||]) qinput) -shiftRightInt :: Code Int# -> Code Int# -> Code Int#-shiftRightInt qo# qi# = [||$$(qo#) +# $$(qi#)||] --- PositionOps Instances-instance PositionOps Int# where- same = intSame- shiftRight = shiftRightInt--instance PositionOps (# Int#, [Char] #) where- same = offWithSame- shiftRight qo# qi# = offWithShiftRight [||drop||] 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#))||]+instance InputPrep Text16 where _prepare qinput = _prepare @Text [|| let Text16 t = $$qinput in t ||]+instance InputPrep CharList where _prepare qinput = _prepare @String [|| let CharList cs = $$qinput in cs ||] -instance PositionOps UnpackedLazyByteString where+-- PositionOps Instances+instance PositionOps PartialStaOffset where same po (StaO qo' n) = intSame (dynOffset (intAdd po (negate n))) qo'+instance PositionOps (PartialStaOffWith ts) where+ same pocs1 pocs2 = staOffWith pocs1 $ \po _ -> staOffWith pocs2 $ \po' _ -> same po po'+--instance PositionOps (Code Int#, Code Stream) where same = offWithSame+instance PositionOps PartialStaText where+ same pt1 pt2 = staText pt1 $ \qt1 -> staText pt2 $ \qt2 -> [||$$(offText qt1) == $$(offText qt2)||]+instance PositionOps (Code UnpackedLazyByteString) where same qx# qy# = [|| case $$(qx#) of (# i#, _, _, _, _, _ #) -> case $$(qy#) of (# j#, _, _, _, _, _ #) -> $$(intSame [||i#||] [||j#||]) ||]- shiftRight qo# qi# = [||byteStringShiftRight $$(qo#) $$(qi#)||] --- LogOps Instances-instance LogOps Int# where- shiftLeft qo# qi# = [||max# ($$(qo#) -# $$(qi#)) 0#||]- offToInt qi# = [||I# $$(qi#)||]+-- DynOps Instances+instance DynOps_ Int# PartialStaOffset where+ _asDyn = dynOffset+ _asSta = flip StaO 0 -instance LogOps (# Int#, ts #) where- shiftLeft qo# _ = qo#- offToInt qo# = [||case $$(qo#) of (# i#, _ #) -> I# i#||]+instance DynOps_ (# Int#, ts #) (PartialStaOffWith ts) where+ _asDyn (StaOW qo qcs) = [||(# $$(dynOffset qo), $$qcs #)||]+ _asDyn (DynOW qocs) = qocs+ _asSta = DynOW -instance LogOps Text where- shiftLeft qo qi# = [||textShiftLeft $$qo (I# $$(qi#))||]- offToInt qo = [||case $$qo of Text _ off _ -> div off 2||]+instance DynOps_ Text PartialStaText where+ _asDyn (StaT t) = origText t+ _asDyn (DynT t) = t+ _asSta = DynT -instance LogOps UnpackedLazyByteString where- shiftLeft qo# qi# = [||byteStringShiftLeft $$(qo#) $$(qi#)||]- offToInt qo# = [||case $$(qo#) of (# i#, _, _, _, _, _ #) -> I# i# ||]+instance DynOps_ UnpackedLazyByteString (Code UnpackedLazyByteString) where+ _asDyn = id+ _asSta = id -{- Old Instances -}-{-instance Input CacheText (Text, Stream) where- prepare qinput = [||- let (CacheText input) = $$qinput- next (t@(Text arr off unconsumed), _) = let !(Iter c d) = iter t 0 in (# c, (Text arr (off+d) (unconsumed-d), nomore) #)- more (Text _ _ unconsumed, _) = unconsumed > 0- same (Text _ i _, _) (Text _ j _, _) = i == j- (Text arr off unconsumed, _) << i = go i off unconsumed- where- go 0 off' unconsumed' = (Text arr off' unconsumed', nomore)- go n off' unconsumed'- | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)- | otherwise = (Text arr off' unconsumed', nomore)- (Text arr off unconsumed, _) >> i = go i off unconsumed- where- go 0 off' unconsumed' = (Text arr off' unconsumed', nomore)- go n off' unconsumed'- | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)- | otherwise = (Text arr off' unconsumed', nomore)- toInt (Text arr off unconsumed, _) = div off 2- box (# text, cache #) = (text, cache)- unbox (text, cache) = (# text, cache #)- newCRef (Text _ i _, _) = newSTRefU i- readCRef ref = fmap (\i -> (Text empty i 0, nomore)) (readSTRefU ref)- writeCRef ref (Text _ i _, _) = writeSTRefU ref i- in PreparedInput next more same (input, nomore) box unbox newCRef readCRef writeCRef s(<<) (>>) toInt- ||]+-- LogOps Instances+instance LogOps PartialStaOffset where+ shiftLeft po n k = k (intSubNonNeg po n)+ shiftRight po n k = k (intAdd po n)+ offToInt pi = [||I# $$(dynOffset pi)||] -instance Input Lazy.ByteString (OffWith Lazy.ByteString) where- prepare qinput = [||- let next (OffWith i (Lazy.Chunk (PS ptr@(ForeignPtr addr# final) off@(I# off#) size) cs)) =- case readWord8OffAddr# addr# off# realWorld# of- (# s', x #) -> case touch# final s' of- _ -> (# C# (chr# (word2Int# x)), OffWith (i+1) (if size == 1 then cs- else Lazy.Chunk (PS ptr (off+1) (size-1)) cs) #)- more (OffWith _ Lazy.Empty) = False- more _ = True- ow@(OffWith _ (Lazy.Empty)) << _ = ow- OffWith o (Lazy.Chunk (PS ptr off size) cs) << i =- let d = min off i- in OffWith (o - d) (Lazy.Chunk (PS ptr (off - d) (size + d)) cs)- ow@(OffWith _ Lazy.Empty) >> _ = ow- OffWith o (Lazy.Chunk (PS ptr off size) cs) >> i- | i < size = OffWith (o + i) (Lazy.Chunk (PS ptr (off + i) (size - i)) cs)- | otherwise = OffWith (o + size) cs >> (i - size)- readCRef ref = fmap (\i -> OffWith i Lazy.Empty) (readSTRefU ref)- in PreparedInput next more offWithSame (offWith $$qinput) offWithBox offWithUnbox offWithNewORef readCRef offWithWriteORef (<<) (>>) offWithToInt- ||]-}+instance LogOps (PartialStaOffWith String) where+ shiftLeft pocs _ k = k pocs+ shiftRight pocs n k = staOffWith pocs $ \qo qcs -> k (uncurry StaOW $ offWithShiftRight [||drop||] qo qcs n)+ offToInt pocs = staOffWith pocs $ \qo _ -> [||I# $$(dynOffset qo)||]++instance LogOps (PartialStaOffWith Stream) where+ shiftLeft pocs _ k = k pocs+ shiftRight pocs n k = staOffWith pocs $ \qo qcs -> k (uncurry StaOW $ offWithShiftRight [||dropStream||] qo qcs n)+ offToInt pocs = staOffWith pocs $ \qo _ -> [||I# $$(dynOffset qo)||]++instance LogOps PartialStaText where+ shiftLeft pt (I# qi#) k = staText pt $ \StaText{..} -> k (DynT (textShiftLeft origText qi#))+ shiftRight pt (I# n#) k = staText pt $ \StaText{..} -> k (DynT (textShiftRight origText n#))+ offToInt = offsetText++instance LogOps (Code UnpackedLazyByteString) where+ shiftLeft qo# (I# qi#) k = k (byteStringShiftLeft qo# qi#)+ shiftRight qo# (I# qi#) k = k (byteStringShiftRight qo# qi#)+ offToInt qo# = [||case $$(qo#) of (# i#, _, _, _, _, _ #) -> I# i# ||]
src/ghc-8.10+/Parsley/Internal/Backend/Machine/InputRep.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK show-extensions #-}+{-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed {-# LANGUAGE CPP, MagicHash, TypeFamilies,@@ -21,25 +22,27 @@ -} module Parsley.Internal.Backend.Machine.InputRep ( -- * Representation Type-Families- Rep, RepKind,+ DynRep, StaRep, RepKind, -- * @Int#@ Operations- intSame, intLess, min#, max#,+ PartialStaOffset(..), dynOffset,+ intSame, intLess, intAdd, intSubNonNeg, min#, max#, -- * @Offwith@ Operations- OffWith, offWith, offWithSame, offWithShiftRight,- --OffWithStreamAnd(..),+ OffWith, offWithShiftRight,+ PartialStaOffWith(..), staOffWith, -- * @LazyByteString@ Operations UnpackedLazyByteString, emptyUnpackedLazyByteString,+ byteStringShiftRight, byteStringShiftLeft, -- * @Stream@ Operations dropStream, -- * @Text@ Operations- offsetText,+ StaText(..), PartialStaText(..), staText, offsetText, textShiftRight, textShiftLeft, -- * Crucial Exposed Functions {- | These functions must be exposed, since they can appear in the generated code. -}- textShiftRight, textShiftLeft,- byteStringShiftRight, byteStringShiftLeft,+ byteStringNext,+ textShiftRight#, textShiftLeft#, byteStringShiftRight#, byteStringShiftLeft#, -- * Re-exports module Parsley.Internal.Core.InputTypes ) where@@ -49,17 +52,29 @@ import Data.Kind (Type) import Data.Text.Internal (Text(..)) import Data.Text.Unsafe (iter_, reverseIter_)-import GHC.Exts (Int(..), TYPE, RuntimeRep(..), (==#), (<#), (+#), (-#), isTrue#)+import GHC.Exts (Int(..), Char(..), TYPE, RuntimeRep(..), (==#), (<#), (+#), (-#), isTrue#) #if __GLASGOW_HASKELL__ > 900 import GHC.Exts (LiftedRep) #endif import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents)-import GHC.Prim (Int#, Addr#, nullAddr#)+import GHC.Prim (Int#, Addr#, nullAddr#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#)+#if __GLASGOW_HASKELL__ > 900+import GHC.Prim (word8ToWord#)+#else+import GHC.Prim (Word#)+#endif import Parsley.Internal.Common.Utils (Code) import Parsley.Internal.Core.InputTypes (Text16(..), CharList(..), Stream(..)) import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString(..))+import qualified Data.Text.Array as Text (Array) +#if __GLASGOW_HASKELL__ <= 900+{-# INLINE word8ToWord# #-}+word8ToWord# :: Word# -> Word#+word8ToWord# x = x+#endif+ {- Representation Types -} {-| This allows types like @String@ and @Stream@ to be manipulated@@ -70,8 +85,12 @@ -} type OffWith ts = (# Int#, ts #) ---data OffWithStreamAnd ts = OffWithStreamAnd {-# UNPACK #-} !Int !Stream ts+data PartialStaOffWith ts = StaOW !PartialStaOffset !(Code ts) | DynOW !(Code (OffWith ts)) +staOffWith :: PartialStaOffWith ts -> (PartialStaOffset -> Code ts -> Code a) -> Code a+staOffWith (StaOW po qts) k = k po qts+staOffWith (DynOW qots) k = [|| let !(# o, cs #) = $$qots in $$(k (StaO [||o||] 0) [||cs||]) ||]+ {-| This type unpacks /lazy/ `Lazy.ByteString`s for efficiency. @@ -86,14 +105,30 @@ Lazy.ByteString #) -{-|-Initialises an `OffWith` type, with a starting offset of @0@.+data PartialStaText = StaT {-# UNPACK #-} !StaText | DynT !(Code Text) -@since 1.0.0.0--}-offWith :: Code ts -> Code (OffWith ts)-offWith qts = [||(# 0#, $$qts #)||]+staText :: PartialStaText -> (StaText -> Code a) -> Code a+staText (StaT t) k = k t+staText (DynT qt) k = [||+ let !t@(Text arr off unconsumed) = $$qt+ in $$(k (StaText [||t||] [||arr||] [||off||] [||unconsumed||]))+ ||] +data StaText = StaText {+ origText :: !(Code Text),+ arrText :: !(Code Text.Array),+ offText :: !(Code Int),+ unconsumedText :: !(Code Int)+}++data PartialStaOffset = StaO !(Code Int#) {-# UNPACK #-} !Int++dynOffset :: PartialStaOffset -> Code Int#+dynOffset (StaO qi 0) = qi+dynOffset (StaO qi n)+ | n > 0 = let !(I# n#) = n in [||$$qi +# n#||]+ | otherwise = let !(I# m#) = negate n in [||$$qi -# m#||]+ {-| Initialises an `UnpackedLazyByteString` with a specified offset. This offset varies as each lazy chunk is consumed.@@ -113,16 +148,14 @@ -} type RepKind :: Type -> RuntimeRep type family RepKind input where- RepKind [Char] = IntRep+ RepKind String = 'TupleRep '[IntRep, LiftedRep] RepKind (UArray Int Char) = IntRep- RepKind Text16 = IntRep+ RepKind Text16 = LiftedRep RepKind ByteString = IntRep RepKind Text = LiftedRep RepKind Lazy.ByteString = 'TupleRep '[IntRep, AddrRep, LiftedRep, IntRep, IntRep, LiftedRep] RepKind CharList = 'TupleRep '[IntRep, LiftedRep] RepKind Stream = 'TupleRep '[IntRep, LiftedRep]- --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@@ -131,19 +164,27 @@ @since 1.0.0.0 -}-type Rep :: forall (rep :: Type) -> TYPE (RepKind rep)-type family Rep input where- Rep [Char] = Int#- Rep (UArray Int Char) = Int#- Rep Text16 = Int#- Rep ByteString = Int#- Rep Text = Text- Rep Lazy.ByteString = UnpackedLazyByteString- Rep CharList = (# Int#, String #)- Rep Stream = (# Int#, Stream #)- --Rep (OffWithStreamAnd ts) = (# Int#, Stream, ts #)- --Rep (Text, Stream) = (# Text, Stream #)+type DynRep :: forall (rep :: Type) -> TYPE (RepKind rep)+type family DynRep input where+ DynRep String = (# Int#, String #)+ DynRep (UArray Int Char) = Int#+ DynRep Text16 = Text+ DynRep ByteString = Int#+ DynRep Text = Text+ DynRep Lazy.ByteString = UnpackedLazyByteString+ DynRep CharList = (# Int#, String #)+ DynRep Stream = (# Int#, Stream #) +type family StaRep input where+ StaRep String = PartialStaOffWith String+ StaRep (UArray Int Char) = PartialStaOffset+ StaRep Text16 = PartialStaText+ StaRep ByteString = PartialStaOffset+ StaRep Text = PartialStaText+ StaRep Lazy.ByteString = Code UnpackedLazyByteString --TODO: could refine+ StaRep CharList = PartialStaOffWith String+ StaRep Stream = PartialStaOffWith Stream+ {- Generic Representation Operations -} {-| Verifies that two `Int#`s are equal.@@ -156,31 +197,31 @@ {-| Is the first argument is less than the second? -@since 1.0.0.0+@since 2.3.0.0 -}-intLess :: Code Int# -> Code Int# -> Code Bool-intLess qi# qj# = [||isTrue# ($$(qi#) <# $$(qj#))||]+intLess :: Code Int# -> Code Int# -> Code a -> Code a -> Code a+intLess qi# qj# yes no = [||+ case $$(qi#) <# $$(qj#) of+ 1# -> $$yes+ 0# -> $$no+ ||] -{-|-Extracts the offset from `Text`.+intAdd :: PartialStaOffset -> Int -> PartialStaOffset+intAdd (StaO qo n) i = StaO qo (n + i) -@since 1.0.0.0--}-offsetText :: Code Text -> Code Int-offsetText qt = [||case $$qt of Text _ off _ -> off||]+intSubNonNeg :: PartialStaOffset -> Int -> PartialStaOffset+intSubNonNeg (StaO qo n) i+ | n >= i = StaO qo (n - i)+ | otherwise = let !(I# m#) = negate (n - i) in StaO [||max# ($$qo -# m#) 0#||] 0 {-|-Compares the bundled offsets of two `OffWith`s are equal: does not-need to inspect the corresponding input.+Extracts the offset from `Text`. @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#||])- ||]+-- FIXME: not accurate? this can be slow without consequence+offsetText :: PartialStaText -> Code Int+offsetText pt = staText pt offText {-| Shifts an `OffWith` to the right, taking care to also drop tokens from the@@ -188,19 +229,12 @@ @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 #)- ||]--{-offWithStreamAnd :: ts -> OffWithStreamAnd ts-offWithStreamAnd ts = OffWithStreamAnd 0 nomore ts--offWithStreamAndToInt :: OffWithStreamAnd ts -> Int-offWithStreamAndToInt (OffWithStreamAnd i _ _) = i-}+offWithShiftRight :: Code (Int -> ts -> ts) -- ^ A @drop@ function for underlying input.+ -> PartialStaOffset -> Code ts -- ^ The `OffWith` to shift.+ -> Int -- ^ How much to shift by.+ -> (PartialStaOffset, Code ts)+offWithShiftRight _ po qts 0 = (intAdd po 0, qts)+offWithShiftRight drop po qts n = (intAdd po n, [|| $$drop n $$qts ||]) {-| Drops tokens off of a `Stream`.@@ -214,53 +248,85 @@ {-| Drops tokens off of `Text`. -@since 1.0.0.0+@since 2.3.0.0 -}-textShiftRight :: Text -> Int -> Text-textShiftRight (Text arr off unconsumed) i = go i off unconsumed+textShiftRight :: Code Text -> Int# -> Code Text+textShiftRight t 0# = t+textShiftRight t n = [||textShiftRight# $$t n||]++{-# INLINABLE textShiftRight# #-}+textShiftRight# :: Text -> Int# -> Text+textShiftRight# (Text arr off unconsumed) i = go i arr off unconsumed where- go 0 off' unconsumed' = Text arr off' unconsumed'- go n off' unconsumed'- | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0- in go (n - 1) (off' + d) (unconsumed' - d)- | otherwise = Text arr off' unconsumed'+ go 0# !arr !off !unconsumed = Text arr off unconsumed+ go n !arr !off !unconsumed+ | unconsumed > 0 = let !d = iter_ (Text arr off unconsumed) 0+ in go (n -# 1#) arr (off + d) (unconsumed - d)+ | otherwise = Text arr off 0 {-| Rewinds input consumption on `Text` where the input is still available (i.e. in the same chunk). -@since 1.0.0.0+@since 2.3.0.0 -}-textShiftLeft :: Text -> Int -> Text-textShiftLeft (Text arr off unconsumed) i = go i off unconsumed+textShiftLeft :: Code Text -> Int# -> Code Text+textShiftLeft t 0# = t+textShiftLeft t n = [||textShiftLeft# $$t n||]++textShiftLeft# :: Text -> Int# -> Text+textShiftLeft# (Text arr off unconsumed) i = go i off unconsumed where- go 0 off' unconsumed' = Text arr off' unconsumed'+ go 0# off' unconsumed' = Text arr off' unconsumed' go n off' unconsumed'- | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n - 1) (off' + d) (unconsumed' - d)- | otherwise = Text arr off' unconsumed'+ | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n -# 1#) (off' + d) (unconsumed' - d)+ | otherwise = Text arr 0 unconsumed' {-# INLINE emptyUnpackedLazyByteString' #-} emptyUnpackedLazyByteString' :: Int# -> UnpackedLazyByteString emptyUnpackedLazyByteString' i# = (# i#, nullAddr#, error "nullForeignPtr", 0#, 0#, Lazy.Empty #) +{-# INLINABLE byteStringNext #-}+byteStringNext :: UnpackedLazyByteString -> (# Char, UnpackedLazyByteString #)+byteStringNext (# i#, addr#, final, off#, size#, cs #) =+ case readWord8OffAddr# addr# off# realWorld# of+ (# s', x #) -> case touch# final s' of+ _ -> (# C# (chr# (word2Int# (word8ToWord# x))),+ if I# size# /= 1 then (# i# +# 1#, addr#, final, off# +# 1#, size# -# 1#, cs #)+ else case cs of+ Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' ->+ (# i# +# 1#, addr'#, final', off'#, size'#, cs' #)+ Lazy.Empty -> emptyUnpackedLazyByteString' (i# +# 1#)+ #)+ {-| Drops tokens off of a lazy `Lazy.ByteString`. -@since 1.0.0.0+@since 2.3.0.0 -}-byteStringShiftRight :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString-byteStringShiftRight (# i#, addr#, final, off#, size#, cs #) j#+byteStringShiftRight :: Code UnpackedLazyByteString -> Int# -> Code UnpackedLazyByteString+byteStringShiftRight t 0# = t+byteStringShiftRight t n = [||byteStringShiftRight# $$t n||]++{-# INLINABLE byteStringShiftRight# #-}+byteStringShiftRight# :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString+byteStringShiftRight# (# i#, addr#, final, off#, size#, cs #) j# | isTrue# (j# <# size#) = (# i# +# j#, addr#, final, off# +# j#, size# -# j#, cs #) | otherwise = case cs of- Lazy.Chunk (PS (ForeignPtr addr'# final') (I# off'#) (I# size'#)) cs' -> byteStringShiftRight (# i# +# size#, addr'#, final', off'#, size'#, cs' #) (j# -# size#)+ 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+@since 2.3.0.0 -}-byteStringShiftLeft :: UnpackedLazyByteString -> Int# -> UnpackedLazyByteString-byteStringShiftLeft (# i#, addr#, final, off#, size#, cs #) j# =+byteStringShiftLeft :: Code UnpackedLazyByteString -> Int# -> Code UnpackedLazyByteString+byteStringShiftLeft t 0# = t+byteStringShiftLeft t n = [||byteStringShiftLeft# $$t n||]++{-# INLINABLE byteStringShiftLeft# #-}+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 #) @@ -269,6 +335,7 @@ @since 1.0.0.0 -}+{-# INLINABLE min# #-} min# :: Int# -> Int# -> Int# min# i# j# = case i# <# j# of 0# -> j#@@ -279,6 +346,7 @@ @since 1.0.0.0 -}+{-# INLINABLE max# #-} max# :: Int# -> Int# -> Int# max# i# j# = case i# <# j# of 0# -> i#
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Ops.hs view
@@ -63,30 +63,31 @@ import Control.Monad (liftM2) import Control.Monad.Reader (ask, local) import Control.Monad.ST (ST)+import Data.List (mapAccumL) 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(INPUT), 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.InputOps (PositionOps(..), LogOps(..), InputOps, DynOps, next, uncons, check, asDyn, asSta)+import Parsley.Internal.Backend.Machine.InputRep (StaRep) import Parsley.Internal.Backend.Machine.Instructions (Access(..)) import Parsley.Internal.Backend.Machine.LetBindings (Regs(..), Metadata(failureInputCharacteristic, successInputCharacteristic))-import Parsley.Internal.Backend.Machine.THUtils (eta) 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.Input (Input(..), Input#(..), toInput, fromInput, consume, chooseInput)+import Parsley.Internal.Backend.Machine.Types.Input (Input(..), Input#(..), toInput, fromInput, chooseInput)+import Parsley.Internal.Backend.Machine.Types.Input.Offset (moveOne) import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic) import Parsley.Internal.Backend.Machine.Types.State (Γ(..), OpStack(..)) import Parsley.Internal.Backend.Machine.Types.Statics import Parsley.Internal.Common (One, Code, Vec(..), Nat(..))+import Parsley.Internal.Common.THUtils (eta) import System.Console.Pretty (color, Color(Green, White, Red, Blue)) -import Parsley.Internal.Backend.Machine.Types.Input.Offset as Offset (Offset(..))+import Parsley.Internal.Backend.Machine.Types.Input.Offset as Offset (Offset(..), updateDeepestKnown)+import qualified Parsley.Internal.Opt as Opt {- General Operations -} {-|@@ -95,7 +96,7 @@ @since 1.0.0.0 -}-dup :: Defunc x -> (Defunc x -> Code r) -> Code r+dup :: (?flags :: Opt.Flags) => Defunc x -> (Defunc x -> Code r) -> Code r dup (FREEVAR x) k = k (FREEVAR x) dup (INPUT o) k = k (INPUT o) dup x k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]@@ -120,7 +121,8 @@ @since 2.1.0.0 -}-sat :: (Defunc Char -> Defunc Bool) -- ^ Predicate to test the character with.+sat :: (?flags :: Opt.Flags)+ => (Defunc Char -> Defunc Bool) -- ^ Predicate to test the character with. -> Code Char -- ^ The character to test against. -> (Defunc Char -> Code b) -- ^ Code to execute on success. -> Code b -- ^ Code to execute on failure.@@ -132,28 +134,29 @@ @since 1.8.0.0 -}-fetch :: (?ops :: InputOps (Rep o))- => Input o -> (Code Char -> Input o -> Code b) -> Code b-fetch input k = next (offset (off input)) $ \c offset' -> k c (consume offset' input)+fetch :: (?ops :: InputOps (StaRep o))+ => Offset o -> (Code Char -> Offset o -> Code b) -> Code b+fetch input k = next (offset input) $ \c offset' -> k c (moveOne input offset') {-| 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+@since 2.3.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.+emitLengthCheck :: (?ops :: InputOps (StaRep o))+ => Int -- ^ The number of required characters \(n\).+ -> Int -- ^ The number of characters to prefetch \(m\).+ -> Maybe (Code Char -> Code a -> Code a) -- ^ An optional check for the head character.+ -> (Offset o -> [(Code Char, Offset o)] -> 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.+ -> (Offset o -> StaRep o) -> 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 ||]+emitLengthCheck n m headCheck good bad input sel = check n m (sel input) headCheck good' bad+ where good' deepestKnown = let input' = updateDeepestKnown deepestKnown input in good input' . feed input'+ feed input' = snd . mapAccumL (\off (c, rep) -> let off' = moveOne off rep in (off', (c, off'))) input' {- Register Operations -} {-|@@ -163,7 +166,7 @@ @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Σ :: (?flags :: Opt.Flags) => Σ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)@@ -176,7 +179,7 @@ @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Σ :: (?flags :: Opt.Flags) => Σ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)@@ -189,7 +192,7 @@ @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Σ :: (?flags :: Opt.Flags) => Σ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@@ -214,7 +217,7 @@ @since 1.0.0.0 -}-raise :: Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))+raise :: (DynOps o, ?flags :: Opt.Flags) => Γ s o xs (Succ n) r a -> Code (ST s (Maybe a)) raise γ = let VCons h _ = handlers γ in staHandlerEval h (input γ) -- Handler preparation@@ -226,7 +229,8 @@ @since 1.2.0.0 -}-buildHandler :: Γ s o xs n r a -- ^ State to execute the handler with.+buildHandler :: DynOps o+ => Γ 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@@ -251,7 +255,8 @@ @since 2.1.0.0 -}-buildIterYesHandler :: Γ s o xs n r a+buildIterYesHandler :: DynOps o+ => Γ s o xs n r a -> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> Word -> StaHandler s o a@@ -282,7 +287,7 @@ @since 2.1.0.0 -}-bindSameHandler :: forall s o xs n r a b. (HandlerOps o, PositionOps (Rep o))+bindSameHandler :: forall s o xs n r a b. (HandlerOps o, PositionOps (StaRep o), DynOps o) => Γ s o xs n r a -- ^ The state from which to capture the offset. -> Bool -- ^ Is a binding required for the matching handler? -> StaYesHandler s o a -- ^ The handler that handles matching input.@@ -293,7 +298,7 @@ bindSameHandler γ yesNeeded yes noNeeded no k = bindYesInline# yesNeeded (yes (input γ)) $ \qyes -> bindHandlerInline# noNeeded (staHandler# (no (input γ))) $ \qno ->- let handler inp = [||if $$(same (offset (off (input γ))) (off# inp)) then $$qyes else $$(staHandler# qno inp)||]+ let handler inp = [||if $$(same (offset (off (input γ))) (asSta @o (off# inp))) then $$qyes else $$(staHandler# qno inp)||] in bindHandlerInline# @o True handler $ \qhandler -> k (γ {handlers = VCons (augmentHandlerFull (input γ) qhandler qyes qno) (handlers γ)}) @@ -317,7 +322,7 @@ @since 1.2.0.0 -} noreturn :: StaCont s o a Void-noreturn = mkStaCont $ \_ _ -> [||error "Return is not permitted here"||]+noreturn = mkStaCont $ error "Return is not permitted here" {-| Executes a given continuation (which may be a return continuation or a@@ -325,7 +330,7 @@ @since 1.2.0.0 -}-resume :: StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))+resume :: (DynOps o, ?flags :: Opt.Flags) => 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) (fromInput (input γ)) {-|@@ -335,7 +340,7 @@ @since 1.8.0.0 -}-callWithContinuation :: MarshalOps o+callWithContinuation :: (MarshalOps o, DynOps o) => StaSubroutine s o a x -- ^ The subroutine @sub@ that will be called. -> StaCont s o a x -- ^ The return continuation for the subroutine. -> Input o -- ^ The input to feed to @sub@.@@ -350,7 +355,8 @@ @since 1.8.0.0 -}-suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -- ^ The partial parser to turn into a return continuation.+suspend :: (?flags :: Opt.Flags)+ => (Γ 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. -> (Input# o -> Input o) -- ^ Function used to generate the offset -> StaCont s o a x@@ -362,7 +368,7 @@ @since 1.5.0.0 -}-callCC :: forall s o xs n r a x. MarshalOps o+callCC :: forall s o xs n r a x. (MarshalOps o, DynOps o, ?flags :: Opt.Flags) => Word -- -> StaSubroutine s o a x -- ^ The subroutine @sub@ that will be called. -> (Γ s o (x : xs) (Succ n) r a -> Code (ST s (Maybe a))) -- ^ The return continuation to generate@@ -380,7 +386,7 @@ @since 1.4.0.0 -}-setupJoinPoint :: forall s o xs n r a x. JoinBuilder o+setupJoinPoint :: forall s o xs n r a x. (JoinBuilder o, DynOps o, ?flags :: Opt.Flags) => Φ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.@@ -401,7 +407,7 @@ @since 1.8.0.0 -}-bindIterAlways :: forall s o a. RecBuilder o+bindIterAlways :: forall s o a. (RecBuilder o, DynOps 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.@@ -423,7 +429,7 @@ @since 2.1.0.0 -}-bindIterSame :: forall s o a. (RecBuilder o, HandlerOps o, PositionOps (Rep o))+bindIterSame :: forall s o a. (RecBuilder o, HandlerOps o, PositionOps (StaRep o), DynOps 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.@@ -437,7 +443,7 @@ bindIterSame ctx μ l neededYes yes neededNo no inp u = bindHandlerInline# @o neededYes (staHandler# yes) $ \qyes -> bindIterHandlerInline# neededNo (staHandler# . no . toInput u) $ \qno ->- let handler inpc inpo = [||if $$(same (off# inpc) (off# inpo)) then $$(staHandler# qyes inpc) else $$(staHandler# (qno inpc) inpo)||]+ let handler inpc inpo = [||if $$(same (asSta @o (off# inpc)) (asSta @o (off# inpo))) then $$(staHandler# qyes inpc) else $$(staHandler# (qno inpc) inpo)||] in bindIterHandlerInline# @o True handler $ \qhandler -> bindIter# @o (fromInput inp) $ \qloop inp# -> let off = toInput u inp#@@ -453,7 +459,7 @@ @since 1.5.0.0 -}-buildRec :: forall rs s o a r. RecBuilder o+buildRec :: forall rs s o a r. (RecBuilder o, DynOps 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@@ -517,7 +523,7 @@ @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 :: (?ops :: InputOps (StaRep o), LogHandler o, ?flags :: Opt.Flags) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Word -> StaHandlerBuilder s o a logHandler name ctx γ u _ = let VCons h _ = handlers γ in fromStaHandler# $ \inp# -> let inp = toInput u inp# in [|| trace $$(preludeString name '<' (γ {input = inp}) ctx (color Red " Fail")) $$(staHandlerEval h inp) ||]@@ -528,30 +534,32 @@ @since 1.2.0.0 -}-preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), LogHandler o)+preludeString :: forall s o xs n r a. (?ops :: InputOps (StaRep 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 "^"] ||]+preludeString name dir γ ctx ends =+ shiftLeft offset 5 $ \start ->+ shiftRight offset 5 $ \end ->+ let indent = replicate (debugLevel ctx * 2) ' '+ inputTrace = [|| let replace '\n' = color Green "↙"+ replace ' ' = color White "·"+ replace c = return c+ go i# = $$(uncons (asSta @o [||i#||]) (\qc qi' -> [||+ if $$(same (asSta @o [||i#||]) end) then []+ else replace $$qc ++ go $$(asDyn @o qi') ||])+ [||color Red "•"||])+ in go $$(asDyn @o start) ||]+ prelude = [|| concat [indent, dir : name, dir : " (", show $$(offToInt offset), "): "] ||]+ caretSpace = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]+ in [|| concat [$$prelude, $$inputTrace, ends, '\n' : $$caretSpace, color Blue "^"] ||] where- offset = Offset.offset (off (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)) ' ' ||]+ offset = Offset.offset (off (input γ)) + {- Convenience Types -} {-| A convience bundle of all of the type class constraints.@@ -562,9 +570,10 @@ ( HandlerOps o , JoinBuilder o , RecBuilder o- , PositionOps (Rep o)+ , PositionOps (StaRep o) , MarshalOps o- , LogOps (Rep o)+ , LogOps (StaRep o)+ , DynOps o ) {-|@@ -572,7 +581,7 @@ @since 1.0.0.0 -}-type LogHandler o = (PositionOps (Rep o), LogOps (Rep o))+type LogHandler o = (PositionOps (StaRep o), LogOps (StaRep o), DynOps o) {-| A `StaHandler` that has not yet captured its offset.
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Base.hs view
@@ -22,7 +22,7 @@ import Data.STRef (STRef) import Data.Kind (Type) import GHC.Prim (Word#)-import Parsley.Internal.Backend.Machine.InputRep (Rep)+import Parsley.Internal.Backend.Machine.InputRep (DynRep) #include "MachDeps.h" #if WORD_SIZE_IN_BITS < 64@@ -49,7 +49,7 @@ @since 1.4.0.0 -} type Handler# s o a = Pos -- ^ The current position- -> Rep o -- ^ The current input on failure+ -> DynRep o -- ^ The current input on failure -> ST s (Maybe a) {-|@@ -60,7 +60,7 @@ -} type Cont# s o a x = x -- ^ The value to be returned to the caller -> Pos -- ^ The current position- -> Rep o -- ^ The new input after the call is executed+ -> DynRep o -- ^ The new input after the call is executed -> ST s (Maybe a) {-|@@ -72,7 +72,7 @@ type Subroutine# s o a x = Cont# s o a x -- ^ What to do when this parser returns -> Handler# s o a -- ^ How to handle failure within the call -> Pos -- ^ The current position- -> Rep o -- ^ The input on entry to the call+ -> DynRep o -- ^ The input on entry to the call -> ST s (Maybe a) {-|
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Context.hs view
@@ -52,23 +52,23 @@ -- ** Modifiers storePiggy, breakPiggy, spendCoin, giveCoins, refundCoins, voidCoins, -- ** Getters- coins, hasCoin, isBankrupt, canAfford,+ coins, hasCoin, isBankrupt, canAfford, netWorth, -- ** Input Reclamation addChar, readChar ) where import Control.Exception (Exception, throw)-import Control.Monad (liftM2, (<=<))+import Control.Monad ((<=<)) import Control.Monad.Reader (asks, local, MonadReader) import Data.STRef (STRef) import Data.Dependent.Map (DMap)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isNothing) 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.Coins (Coins, willConsume, canReclaim)+import Parsley.Internal.Backend.Machine.Types.Coins (Coins(Coins, willConsume)) import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynSubroutine)-import Parsley.Internal.Backend.Machine.Types.Input (Input)+import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset) import Parsley.Internal.Backend.Machine.Types.Statics (QSubroutine(..), StaFunc, StaSubroutine, StaCont) import Parsley.Internal.Common (Queue, enqueue, dequeue, poke, Code, RewindQueue) import Parsley.Internal.Core.CharPred (CharPred, pattern Item, andPred)@@ -85,14 +85,15 @@ @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 :: {-# UNPACK #-} !Int -- ^ Approximate depth of debug combinator.- , coins :: {-# UNPACK #-} !Int -- ^ Number of tokens free to consume without length check.- , offsetUniq :: {-# UNPACK #-} !Word -- ^ Next unique offset identifier.- , piggies :: !(Queue Coins) -- ^ Queue of future length check credit.- , knownChars :: !(RewindQueue (Code Char, CharPred, Input o)) -- ^ Characters that can be reclaimed on backtrack.+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 :: {-# UNPACK #-} !Int -- ^ Approximate depth of debug combinator.+ , coins :: {-# UNPACK #-} !Int -- ^ Number of tokens free to consume without length check.+ , offsetUniq :: {-# UNPACK #-} !Word -- ^ Next unique offset identifier.+ , piggies :: !(Queue Coins) -- ^ Queue of future length check credit.+ , netWorth :: {-# UNPACK #-} !Int -- ^ The sum of the coins and piggies+ , knownChars :: !(RewindQueue (Code Char, CharPred, Offset o)) -- ^ Characters that can be reclaimed on backtrack. } {-|@@ -110,7 +111,7 @@ @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 Queue.empty+emptyCtx μs = Ctx μs DMap.empty DMap.empty 0 0 0 Queue.empty 0 Queue.empty -- Subroutines {- $sub-doc@@ -347,7 +348,8 @@ @since 1.5.0.0 -} storePiggy :: Coins -> Ctx s o a -> Ctx s o a-storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx)}+storePiggy (Coins 0 _ _) ctx = ctx+storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx), netWorth = netWorth ctx + willConsume coins} {-| Break the next piggy-bank in the queue, and fill the coins in return.@@ -356,8 +358,10 @@ @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 = willConsume coins, piggies = piggies'}+breakPiggy :: Ctx s o a -> (Coins, Ctx s o a)+breakPiggy ctx =+ let (coins, piggies') = dequeue (piggies ctx)+ in (coins, ctx {piggies = piggies', netWorth = netWorth ctx - willConsume coins}) {-| Does the context have coins available?@@ -365,7 +369,7 @@ @since 1.0.0.0 -} hasCoin :: Ctx s o a -> Bool-hasCoin = canAfford 1+hasCoin = isNothing . canAfford 1 {-| Is it the case that there are no coins /and/ no piggy-banks remaining?@@ -373,7 +377,7 @@ @since 1.0.0.0 -} isBankrupt :: Ctx s o a -> Bool-isBankrupt = liftM2 (&&) (not . hasCoin) (Queue.null . piggies)+isBankrupt = (== 0) . netWorth--liftM2 (&&) (not . hasCoin) (Queue.null . piggies) {-| Spend a single coin, used when a token is consumed.@@ -381,25 +385,24 @@ @since 1.0.0.0 -} spendCoin :: Ctx s o a -> Ctx s o a-spendCoin ctx = ctx {coins = coins ctx - 1}+spendCoin ctx = ctx {coins = coins ctx - 1, netWorth = netWorth ctx - 1} {-| Adds coins into the current supply. @since 1.5.0.0 -}-giveCoins :: Coins -> Ctx s o a -> Ctx s o a-giveCoins c ctx = ctx {coins = coins ctx + willConsume c}+giveCoins :: Int -> Ctx s o a -> Ctx s o a+giveCoins c ctx = ctx {coins = coins ctx + c, netWorth = netWorth ctx + c} {-| Adds coins into the current supply. @since 1.5.0.0 -}-refundCoins :: Coins -> Ctx s o a -> Ctx s o a-refundCoins c ctx = ctx { coins = coins ctx + willConsume c- , knownChars = Queue.rewind (canReclaim c) (knownChars ctx)- }+refundCoins :: Int -> Ctx s o a -> Ctx s o a+refundCoins c ctx =+ giveCoins c ctx { knownChars = Queue.rewind c (knownChars ctx) } {-| Removes all coins and piggy-banks, such that @isBankrupt == True@.@@ -407,7 +410,7 @@ @since 1.0.0.0 -} voidCoins :: Ctx s o a -> Ctx s o a-voidCoins ctx = ctx {coins = 0, piggies = Queue.empty, knownChars = Queue.empty}+voidCoins ctx = ctx {coins = 0, piggies = Queue.empty, knownChars = Queue.empty, netWorth = 0} {-| Asks if the current coin total can afford a charge of \(n\) characters.@@ -417,17 +420,20 @@ @since 1.5.0.0 -}-canAfford :: Int -> Ctx s o a -> Bool-canAfford n = (>= n) . coins+--canAfford :: Int -> Ctx s o a -> Bool+--canAfford n = (>= n) . coins +canAfford :: Int -> Ctx s o a -> Maybe Int+canAfford n ctx = if coins ctx >= n then Nothing else Just (n - coins ctx)+ {-| Caches a known character and the next offset into the context so that it can be retrieved later. @since 1.5.0.0 -}-addChar :: Code Char -> Input o -> Ctx s o a -> Ctx s o a-addChar c o ctx = ctx { knownChars = enqueue (c, Item, o) (knownChars ctx) }+addChar :: CharPred -> Code Char -> Offset o -> Ctx s o a -> Ctx s o a+addChar p c o ctx = ctx { knownChars = enqueue (c, p, o) (knownChars ctx) } {-| Reads a character from the context's retrieval queue if one exists.@@ -436,23 +442,24 @@ @since 2.1.0.0 -}-readChar :: Ctx s o a -- ^ The original context.- -> CharPred -- ^ The predicate that this character will be tested against- -> ((Code Char -> Input o -> Code b) -> Code b) -- ^ The fallback source of input.- -> (Code Char -> CharPred -> CharPred -> Input o -> Ctx s o a -> Code b) -- ^ The continuation that needs the read characters and updated context.+readChar :: Ctx s o a -- ^ The original context.+ -> CharPred -- ^ The predicate that this character will be tested against+ -> ((Code Char -> Offset o -> Code b) -> Code b) -- ^ The fallback source of input.+ -> (Code Char -> CharPred -> CharPred -> Offset o -> Ctx s o a -> Code b) -- ^ The continuation that needs the read characters and updated context. -> Code b readChar ctx pred fallback k- | reclaimable = unsafeReadChar ctx k- | otherwise = fallback $ \c o -> unsafeReadChar (addChar c o ctx) k+ | reclaimable = unsafeReadChar ctx+ | otherwise = fallback $ \c o -> unsafeReadChar (addChar Item c o ctx) where reclaimable = not (Queue.null (knownChars ctx))- unsafeReadChar ctx k = let -- combine the old information with the new information, refining the predicate- -- This works for notFollowedBy at the /moment/ because the predicate does not cross the handler boundary...- -- Perhaps any that cross handler boundaries should be complemented if that ever happens.- updateChar (c, p, o) = (c, andPred p pred, o)- ((_, pOld, _), q) = poke updateChar (knownChars ctx)- ((c, p, o), q') = dequeue q- in k c pOld p o (ctx { knownChars = q' })+ unsafeReadChar ctx = let -- combine the old information with the new information, refining the predicate+ -- This works for notFollowedBy at the /moment/ because the predicate does not cross the handler boundary...+ -- Perhaps any that cross handler boundaries should be complemented if that ever happens.+ optimisePred (c, oldPred, o) = (c, andPred oldPred pred, o)+ -- this is a poke to put the optimised pred into the rewind queue+ ((_, oldPred, _), q) = poke optimisePred (knownChars ctx)+ ((c, optPred, o), q') = dequeue q+ in k c oldPred optPred o (ctx { knownChars = q' }) -- Exceptions newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE UnboxedTuples, MagicHash, RecordWildCards #-}+{-# LANGUAGE UnboxedTuples, MagicHash, RecordWildCards, TypeApplications #-} {-| Module : Parsley.Internal.Backend.Machine.Types.Input Description : Packaging of offsets and positions.@@ -14,13 +14,13 @@ module Parsley.Internal.Backend.Machine.Types.Input ( Input(off), Input#(..), mkInput, fromInput, toInput,- consume,- forcePos, updatePos,+ forcePos, updatePos, updateOffset, chooseInput ) where -import Parsley.Internal.Backend.Machine.InputRep (Rep)-import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset(offset), mkOffset, moveOne, moveN)+import Parsley.Internal.Backend.Machine.InputRep (StaRep, DynRep)+import Parsley.Internal.Backend.Machine.InputOps (DynOps, asSta, asDyn)+import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset(offset), mkOffset, moveN) import Parsley.Internal.Backend.Machine.Types.Input.Pos (StaPos, DynPos, toDynPos, fromDynPos, fromStaPos, force, update) import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic(..)) import Parsley.Internal.Common.Utils (Code)@@ -35,9 +35,9 @@ -} data Input o = Input { -- | The offset contained within the input- off :: !(Offset o),+ off :: {-# UNPACK #-} !(Offset o), -- | The position contained within the input- pos :: !StaPos+ pos :: {-# UNPACK #-} !StaPos } {-|@@ -46,7 +46,7 @@ @since 1.8.0.0 -} data Input# o = Input# {- off# :: !(Code (Rep o)),+ off# :: !(Code (DynRep o)), pos# :: !DynPos } @@ -55,7 +55,7 @@ @since 2.1.0.0 -}-mkInput :: Code (Rep o) -> (Word, Word) -> Input o+mkInput :: StaRep o -> (Word, Word) -> Input o mkInput off = Input (mkOffset off 0) . fromStaPos {-|@@ -63,26 +63,19 @@ @since 1.8.0.0 -}-fromInput :: Input o -> Input# o-fromInput Input{..} = Input# (offset off) (toDynPos pos)+fromInput :: forall o. DynOps o => Input o -> Input# o+fromInput Input{..} = Input# (asDyn @o (offset off)) (toDynPos pos) {-| Given a unique identifier, forms a plainly annotated static combination of position and offset. @since 1.8.0.0 -}-toInput :: Word -> Input# o -> Input o-toInput u Input#{..} = Input (mkOffset off# u) (fromDynPos pos#)--{-|-Register that a character has been consumed on this input, incorporating the new dynamic offset.+toInput :: forall o. DynOps o => Word -> Input# o -> Input o+toInput u Input#{..} = Input (mkOffset (asSta @o off#) u) (fromDynPos pos#) -@since 2.1.0.0--}-consume :: Code (Rep o) -> Input o -> Input o-consume offset' input = input {- off = moveOne (off input) offset'- }+updateOffset :: Offset o -> Input o -> Input o+updateOffset off inp = inp { off = off } {-| Collapse the position stored inside the input applying all updates to it. Once this has been completed,@@ -110,9 +103,11 @@ @since 2.1.0.0 -} -- TODO: In future, we could adjust InputCharacteristic to provide information about the static behaviours of the positions too...-chooseInput :: InputCharacteristic -> Word -> Input o -> Input# o -> Input o-chooseInput (AlwaysConsumes n) _ inp inp# = inp { off = moveN n (off inp) (off# inp#), pos = fromDynPos (pos# inp#) }+chooseInput :: forall o. DynOps o => InputCharacteristic -> Word -> Input o -> Input# o -> Input o+chooseInput (AlwaysConsumes (Just n)) _ inp inp# = inp { off = moveN n (off inp) (asSta @o (off# inp#)), pos = fromDynPos (pos# inp#) } -- Technically, in this case, we know the whole input is unchanged. This essentially ignores the continuation arguments -- hopefully GHC could optimise this better? chooseInput NeverConsumes _ inp _inp# = inp -- { off = (off inp) {offset = off# inp# }, pos = pos# inp# }-chooseInput MayConsume u _inp inp# = toInput u inp#+-- This is safer right now, since we never need information about input greater than another+chooseInput (AlwaysConsumes Nothing) u _inp inp# = toInput u inp#+chooseInput MayConsume u _inp inp# = toInput u inp#
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input/Offset.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DerivingStrategies, UnboxedTuples #-}+{-# LANGUAGE DerivingStrategies, GeneralisedNewtypeDeriving, UnboxedTuples #-} {-| Module : Parsley.Internal.Backend.Machine.Types.Input.Offset Description : Statically refined offsets.@@ -13,11 +13,11 @@ @since 1.8.0.0 -} module Parsley.Internal.Backend.Machine.Types.Input.Offset (- Offset, mkOffset, offset, moveOne, moveN, same,+ Offset, mkOffset, offset, moveOne, moveN, same, updateDeepestKnown, unsafeDeepestKnown ) where -import Parsley.Internal.Backend.Machine.InputRep (Rep)-import Parsley.Internal.Common.Utils (Code)+import Parsley.Internal.Backend.Machine.InputRep (StaRep)+import Data.Maybe (fromJust) {-| Augments a regular @'Code' ('Rep' o)@ with information about its origins and@@ -29,15 +29,15 @@ -} data Offset o = Offset { -- | The underlying code that represents the current offset into the input.- offset :: Code (Rep o),+ offset :: !(StaRep o),+ deepestKnownChar :: !(Maybe (StaRep o)), -- | The unique identifier that determines where this offset originated from.- unique :: Word,+ unique :: {-# UNPACK #-} !Word, -- | The amount of input that has been consumed on this offset since it was born.- moved :: Amount+ moved :: {-# UNPACK #-} !Amount } -data Amount = Amount Word {- ^ The multiplicity. -} Word {- ^ The additive offset. -}- deriving stock Eq+newtype Amount = Amount Word {- ^ The additive offset. -} deriving newtype (Eq, Num, Show) {-| Given two `Offset`s, this determines whether or not they represent the same@@ -57,8 +57,8 @@ @since 1.4.0.0 -}-moveOne :: Offset o -> Code (Rep o) -> Offset o-moveOne = moveN (Just 1)+moveOne :: Offset o -> StaRep o -> Offset o+moveOne = moveN 1 {-| Updates an `Offset` with its new underlying representation of a real@@ -67,12 +67,8 @@ @since 1.5.0.0 -}-moveN :: Maybe Word -> Offset o -> Code (Rep o) -> Offset o-moveN n off o = off { offset = o, moved = moved off `add` toAmount n }- where- toAmount :: Maybe Word -> Amount- toAmount Nothing = Amount 1 0- toAmount (Just n) = Amount 0 n+moveN :: Word -> Offset o -> StaRep o -> Offset o+moveN n off o = off { offset = o, moved = moved off + Amount n } {-| Makes a fresh `Offset` that has not had any input consumed off of it@@ -80,9 +76,16 @@ @since 1.4.0.0 -}-mkOffset :: Code (Rep o) -> Word -> Offset o-mkOffset offset unique = Offset offset unique (Amount 0 0)+mkOffset :: StaRep o -> Word -> Offset o+mkOffset offset unique = Offset offset Nothing unique 0 +updateDeepestKnown :: StaRep o -> Offset o -> Offset o+updateDeepestKnown known offset = offset { deepestKnownChar = Just known }++unsafeDeepestKnown :: Offset o -> StaRep o+unsafeDeepestKnown = fromJust . deepestKnownChar++{- add :: Amount -> Amount -> Amount add a1@(Amount n i) a2@(Amount m j) -- If the multiplicites don't match then this is _even_ more unknowable@@ -91,10 +94,13 @@ | n /= 0, m /= 0 = error ("adding " ++ show a1 ++ " and " ++ show a2 ++ " makes no sense?") -- If one of the multiplicites is 0 then the offset can be added | otherwise = Amount (max n m) (i + j)+-} -- Instances instance Show (Offset o) where show o = show (unique o) ++ "+" ++ show (moved o) +{- instance Show Amount where show (Amount n m) = show n ++ "*n+" ++ show m+-}
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Input/Pos.hs view
@@ -112,7 +112,7 @@ -- Data -- TODO: This could be more fine-grained, for instance a partially static position.-data Pos = Static {-# UNPACK #-} !Word {-# UNPACK #-} !Word | Dynamic DynPos+data Pos = Static {-# UNPACK #-} !Word {-# UNPACK #-} !Word | Dynamic !DynPos data Alignment = Unknown | Unaligned {-# UNPACK #-} !Word
src/ghc-8.10+/Parsley/Internal/Backend/Machine/Types/Statics.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes,+ ImplicitParams, MagicHash, RecordWildCards, TypeApplications,@@ -51,12 +52,15 @@ import Data.Kind (Type) import Data.Maybe (fromMaybe) import Parsley.Internal.Backend.Machine.LetBindings (Regs(..), Metadata, newMeta)+import Parsley.Internal.Backend.Machine.InputOps (DynOps) import Parsley.Internal.Backend.Machine.Types.Dynamics (DynCont, DynHandler, DynFunc) import Parsley.Internal.Backend.Machine.Types.Input (Input(..), Input#(..), fromInput) import Parsley.Internal.Backend.Machine.Types.Input.Offset (Offset, same) import Parsley.Internal.Backend.Machine.Types.InputCharacteristic (InputCharacteristic(..)) import Parsley.Internal.Common.Utils (Code) +import qualified Parsley.Internal.Opt as Opt+ -- Handlers {-| This represents the translation of `Parsley.Internal.Backend.Machine.Types.Base.Handler#`@@ -81,8 +85,8 @@ @since 1.7.0.0 -}- staHandler# :: StaHandler# s o a,- dynOrigin :: Maybe (DynHandler s o a)+ staHandler# :: !(StaHandler# s o a),+ dynOrigin :: !(Maybe (DynHandler s o a)) } dynHandler :: (StaHandler# s o a -> DynHandler s o a) -> StaHandler s o a -> DynHandler s o a@@ -181,10 +185,12 @@ @since 1.7.0.0 -}-staHandlerEval :: AugmentedStaHandler s o a -> Input o -> Code (ST s (Maybe a))+staHandlerEval :: (DynOps o, ?flags :: Opt.Flags) => AugmentedStaHandler s o a -> Input o -> Code (ST s (Maybe a)) staHandlerEval (AugmentedStaHandler (Just c) sh) inp- | Just True <- same c (off inp) = maybe (staHandler# (unknown sh)) const (yesSame sh) (fromInput inp)- | Just False <- same c (off inp) = staHandler# (fromMaybe (unknown sh) (notSame sh)) (fromInput inp)+ | Opt.deduceFailPath ?flags+ , Just True <- same c (off inp) = maybe (staHandler# (unknown sh)) const (yesSame sh) (fromInput inp)+ | Opt.deduceFailPath ?flags+ , Just False <- same c (off inp) = staHandler# (fromMaybe (unknown sh) (notSame sh)) (fromInput inp) staHandlerEval (AugmentedStaHandler _ sh) inp = staHandler# (unknown sh) (fromInput inp) {-|@@ -226,11 +232,11 @@ -} data StaHandlerCase s (o :: Type) a = StaHandlerCase { -- | The static function representing this handler when offsets are incomparable.- unknown :: StaHandler s o a,+ unknown :: {-# UNPACK #-} !(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))),+ 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)+ notSame :: !(Maybe (StaHandler s o a)) } mkUnknown :: StaHandler s o a -> StaHandlerCase s o a@@ -255,7 +261,8 @@ @since 1.4.0.0 -}-data StaCont s o a x = StaCont (StaCont# s o a x) (Maybe (DynCont s o a x))+-- leave this lazy or it'll expode+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@@ -265,7 +272,7 @@ @since 1.4.0.0 -}-mkStaContDyn :: DynCont s o a x -> StaCont s o a x+mkStaContDyn :: forall o s a x. DynCont s o a x -> StaCont s o a x mkStaContDyn dk = StaCont (\x inp -> [|| $$dk $$x $$(pos# inp) $$(off# inp) ||]) (Just dk) {-|@@ -305,9 +312,9 @@ -} data StaSubroutine s o a x = StaSubroutine { -- | Extracts the underlying subroutine.- staSubroutine# :: StaSubroutine# s o a x,+ staSubroutine# :: !(StaSubroutine# s o a x), -- | Extracts the metadata from a subroutine.- meta :: Metadata+ meta :: {-# UNPACK #-} !Metadata } {-|@@ -342,7 +349,7 @@ @since 1.4.0.0 -}-data QSubroutine s o a x = forall rs. QSubroutine (StaFunc rs s o a x) (Regs rs)+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
src/ghc-8.6+/Parsley/Internal/Backend/Machine.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ImplicitParams, PatternSynonyms #-}+{-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed {-| Module : Parsley.Internal.Backend.Machine Description : The implementation of the low level parsing machinery is found here@@ -27,25 +29,24 @@ import Parsley.Internal.Backend.Machine.Instructions import Parsley.Internal.Backend.Machine.LetBindings (LetBinding, makeLetBinding, newMeta) import Parsley.Internal.Backend.Machine.Ops (Ops)-import Parsley.Internal.Backend.Machine.Types.Coins (Coins(..), zero, minCoins, maxCoins, plus, plus1, minus, plusNotReclaim)+import Parsley.Internal.Backend.Machine.Types.Coins (Coins(..), minCoins, plus1, minus, pattern Zero, items) import Parsley.Internal.Common.Utils (Code) import Parsley.Internal.Core.InputTypes import Parsley.Internal.Trace (Trace) import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Parsley.Internal.Backend.Machine.Eval as Eval (eval)+import qualified Parsley.Internal.Opt as Opt -eval :: forall input a. (Input input, Trace) => Code input -> (LetBinding (Rep input) a a, DMap MVar (LetBinding (Rep input) a)) -> Code (Maybe a)+eval :: forall input a. (Input input, Trace, ?flags :: Opt.Flags) => Code input -> (LetBinding (Rep input) a a, DMap MVar (LetBinding (Rep input) a)) -> Code (Maybe a) eval input (toplevel, bindings) = Eval.eval (prepare input) toplevel bindings class (InputPrep input, Ops (Rep input)) => Input input-instance Input [Char]+instance Input String instance Input (UArray Int Char) instance Input Text16 instance Input ByteString instance Input CharList instance Input Text---instance Input CacheText instance Input Lazy.ByteString---instance Input Lazy.ByteString instance Input Stream
src/ghc-8.6+/Parsley/Internal/Backend/Machine/Defunc.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE ImplicitParams, PatternSynonyms, ViewPatterns #-} module Parsley.Internal.Backend.Machine.Defunc (module Parsley.Internal.Backend.Machine.Defunc) where import Parsley.Internal.Backend.Machine.InputOps (PositionOps(same))@@ -8,6 +8,8 @@ import qualified Parsley.Internal.Core.Defunc as Core (Defunc, lamTerm) import qualified Parsley.Internal.Core.Lam as Lam (Lam(..)) +import qualified Parsley.Internal.Opt as Opt+ data Defunc a where LAM :: Lam a -> Defunc a BOTTOM :: Defunc a@@ -17,30 +19,30 @@ user :: Core.Defunc a -> Defunc a user = LAM . Core.lamTerm -ap :: Defunc (a -> b) -> Defunc a -> Defunc b+ap :: (?flags :: Opt.Flags) => Defunc (a -> b) -> Defunc a -> Defunc b ap f x = LAM (Lam.App (unliftDefunc f) (unliftDefunc x)) -ap2 :: Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c+ap2 :: (?flags :: Opt.Flags) => Defunc (a -> b -> c) -> Defunc a -> Defunc b -> Defunc c ap2 SAME (INPUT o1 _) (INPUT o2 _) = LAM (Lam.Var False [|| $$same $$o1 $$o2 ||]) ap2 f x y = ap (ap f x) y -_if :: Defunc Bool -> Code a -> Code a -> Code a+_if :: (?flags :: Opt.Flags) => 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)) -unliftDefunc :: Defunc a -> Lam a+unliftDefunc :: (?flags :: Opt.Flags) => Defunc a -> Lam a unliftDefunc (LAM x) = x unliftDefunc x = Lam.Var False (genDefunc x) -genDefunc :: Defunc a -> Code a+genDefunc :: (?flags :: Opt.Flags) => Defunc a -> Code a genDefunc (LAM x) = normaliseGen x genDefunc BOTTOM = [||undefined||] genDefunc INPUT{} = error "Cannot materialise an input in the regular way" genDefunc SAME = same -pattern NormLam :: Lam a -> Defunc a+pattern NormLam :: (?flags :: Opt.Flags) => Lam a -> Defunc a pattern NormLam t <- LAM (normalise -> t) -pattern FREEVAR :: Code a -> Defunc a+pattern FREEVAR :: (?flags :: Opt.Flags) => Code a -> Defunc a pattern FREEVAR v <- NormLam (Lam.Var True v) where FREEVAR v = LAM (Lam.Var True v)
src/ghc-8.6+/Parsley/Internal/Backend/Machine/Eval.hs view
@@ -29,27 +29,28 @@ import qualified Debug.Trace (trace) import qualified Parsley.Internal.Backend.Machine.Instructions as Instructions (Handler(..))+import qualified Parsley.Internal.Opt as Opt -eval :: forall o a. (Trace, Ops o) => Code (InputDependant o) -> LetBinding o a a -> DMap MVar (LetBinding o a) -> Code (Maybe a)+eval :: forall o a. (Trace, Ops o, ?flags :: Opt.Flags) => Code (InputDependant o) -> LetBinding o a a -> DMap MVar (LetBinding o a) -> Code (Maybe a) eval input binding 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 _meta -> buildRec μ rs (emptyCtx names) (readyMachine exp))- (run (readyMachine (body binding)) (Γ Empty (halt @o) [||offset||] ([||1||], [||1||]) (VCons (fatal @o) VNil)) . emptyCtx))+ qSubroutine+ (run (readyMachine (body binding)) (Γ Empty (halt @o) [||offset||] Nothing ([||1||], [||1||]) (VCons (fatal @o) VNil)) . emptyCtx)) ||] where nameLet :: MVar x -> String nameLet (MVar i) = "sub" ++ show i -readyMachine :: (?ops :: InputOps o, Ops o, Trace) => Fix4 (Instr o) xs n r a -> Machine s o xs n r a+readyMachine :: (?ops :: InputOps o, Ops o, Trace, ?flags :: Opt.Flags) => Fix4 (Instr o) xs n r a -> Machine s o xs n r a readyMachine = cata4 (Machine . alg) where- alg :: (?ops :: InputOps o, Ops o) => Instr o (Machine s o) xs n r a -> MachineMonad s o xs n r a+ alg :: (?ops :: InputOps o, Ops o, ?flags :: Opt.Flags) => Instr o (Machine s o) xs n r a -> MachineMonad s o xs n r a alg Ret = evalRet alg (Call μ k) = evalCall μ k- alg (Jump μ) = evalJump μ alg (Push x k) = evalPush x k alg (Pop k) = evalPop k alg (Lift2 f k) = evalLift2 f k@@ -74,25 +75,22 @@ alg (LogExit name k) = evalLogExit name k alg (MetaInstr m k) = evalMeta m k -evalRet :: ContOps o => MachineMonad s o (x : xs) n x a+evalRet :: (?flags :: Opt.Flags) => ContOps o => MachineMonad s o (x : xs) n x a evalRet = return $! retCont >>= resume -evalCall :: ContOps o => MVar x -> Machine s o (x : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a+evalCall :: (?flags :: Opt.Flags) => ContOps 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 sub (suspend mk γ) input pos handlers) k (askSub μ) -evalJump :: ContOps o => MVar x -> MachineMonad s o '[] (Succ n) x a-evalJump μ = askSub μ <&> \sub Γ{..} -> callWithContinuation sub retCont input pos 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 γ)}) evalPop :: Machine s o xs n r a -> MachineMonad s o (x : xs) n r a evalPop (Machine k) = k <&> \m γ -> m (γ {operands = let Op _ xs = operands γ in xs}) -evalLift2 :: Defunc (x -> y -> z) -> Machine s o (z : xs) n r a -> MachineMonad s o (y : x : xs) n r a+evalLift2 :: (?flags :: Opt.Flags) => 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 o, PositionOps o, BoxOps o, HandlerOps o, Trace) => CharPred -> Machine s o (Char : xs) (Succ n) r a -> MachineMonad s o xs (Succ n) r a+evalSat :: (?flags :: Opt.Flags) => (?ops :: InputOps o, PositionOps o, BoxOps o, HandlerOps o, Trace) => CharPred -> 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@@ -113,7 +111,7 @@ 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 :: (?flags :: Opt.Flags) => 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 (@@ -127,14 +125,14 @@ evalSeek :: Machine s o xs n r a -> MachineMonad s o (o : xs) n r a evalSeek (Machine k) = k <&> \mk γ -> let Op (INPUT input pos) xs = operands γ in mk (γ {operands = xs, input = input, pos = pos}) -evalCase :: Machine s o (x : xs) n r a -> Machine s o (y : xs) n r a -> MachineMonad s o (Either x y : xs) n r a+evalCase :: (?flags :: Opt.Flags) => Machine s o (x : xs) n r a -> Machine s o (y : xs) n r a -> MachineMonad s o (Either x y : xs) n r a evalCase (Machine p) (Machine q) = liftM2 (\mp mq γ -> let Op e xs = operands γ in [||case $$(genDefunc e) of Left x -> $$(mp (γ {operands = Op (FREEVAR [||x||]) xs})) Right y -> $$(mq (γ {operands = Op (FREEVAR [||y||]) xs}))||]) p q -evalChoices :: [Defunc (x -> Bool)] -> [Machine s o xs n r a] -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a+evalChoices :: (?flags :: Opt.Flags) => [Defunc (x -> Bool)] -> [Machine s o xs n r a] -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a evalChoices fs ks (Machine def) = liftM2 (\mdef mks γ -> let Op x xs = operands γ in go x fs mks mdef (γ {operands = xs})) def (forM ks getMachine)@@ -145,36 +143,36 @@ evalIter :: (RecBuilder o, ReturnOps o, HandlerOps o) => MVar Void -> Machine s o '[] One Void a -> Machine s o (o : xs) n r a -> MachineMonad s o xs n r a-evalIter μ l (Machine h) = liftM2 (\mh ctx γ -> buildIter ctx μ l (buildHandler γ mh) (input γ) (pos γ)) h ask+evalIter μ l (Machine h) = liftM2 (\mh ctx γ -> buildIter ctx μ l (buildHandler γ mh) (input γ) (pos γ)) (local voidCoins h) ask -evalJoin :: ContOps o => ΦVar x -> MachineMonad s o (x : xs) n r a+evalJoin :: (?flags :: Opt.Flags) => ContOps o => ΦVar x -> MachineMonad s o (x : xs) n r a evalJoin φ = askΦ φ <&> resume -evalMkJoin :: JoinBuilder o => ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a+evalMkJoin :: (?flags :: Opt.Flags) => JoinBuilder o => ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a evalMkJoin = setupJoinPoint evalSwap :: Machine s o (x : y : xs) n r a -> MachineMonad s o (y : x : xs) n r a evalSwap (Machine k) = k <&> \mk γ -> mk (γ {operands = let Op y (Op x xs) = operands γ in Op x (Op y xs)}) -evalDup :: Machine s o (x : x : xs) n r a -> MachineMonad s o (x : xs) n r a+evalDup :: (?flags :: Opt.Flags) => Machine s o (x : x : xs) n r a -> MachineMonad s o (x : xs) n r a evalDup (Machine k) = k <&> \mk γ -> let Op x xs = operands γ 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 :: (?flags :: Opt.Flags) => ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a 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 :: (?flags :: Opt.Flags) => Σ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 -evalPut :: ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a+evalPut :: (?flags :: Opt.Flags) => ΣVar x -> Access -> Machine s o xs n r a -> MachineMonad s o (x : xs) n r a evalPut σ a k = asks $ \ctx γ -> let Op x xs = operands γ in writeΣ σ a x (run k (γ {operands = xs})) ctx -evalSelectPos :: PosSelector -> Machine s o (Int : xs) n r a -> MachineMonad s o xs n r a+evalSelectPos :: (?flags :: Opt.Flags) => PosSelector -> Machine s o (Int : xs) n r a -> MachineMonad s o xs n r a evalSelectPos Line (Machine k) = k <&> \m γ -> m (γ {operands = Op (FREEVAR (fst (pos γ))) (operands γ)}) evalSelectPos Col (Machine k) = k <&> \m γ -> m (γ {operands = Op (FREEVAR (snd (pos γ))) (operands γ)}) @@ -190,23 +188,23 @@ (local debugDown mk) ask -evalMeta :: (?ops :: InputOps o, PositionOps o, BoxOps o, HandlerOps o) => MetaInstr n -> Machine s o xs n r a -> MachineMonad s o xs n r a+evalMeta :: (?ops :: InputOps o, PositionOps o, BoxOps o, HandlerOps o, ?flags :: Opt.Flags) => MetaInstr n -> Machine s o xs n r a -> MachineMonad s o xs n r a+evalMeta _ (Machine k) | not (Opt.lengthCheckFactoring ?flags) = k evalMeta (AddCoins coins') (Machine k) =- do requiresPiggy <- asks hasCoin+ do --requiresPiggy <- asks hasCoin+ net <- asks netWorth+ let requiresPiggy = net /= 0 let coins = willConsume coins'- if requiresPiggy then local (storePiggy coins) k+ if requiresPiggy then local (storePiggy (coins - net)) k else local (giveCoins coins) k <&> \mk γ -> emitLengthCheck coins mk (raise γ) γ-evalMeta (RefundCoins coins) (Machine k) = local (giveCoins (willConsume coins)) k+evalMeta (RefundCoins coins) (Machine k) = local (giveCoins coins) k+-- FIXME: this can be done better, like the 8.10 version evalMeta (DrainCoins coins) (Machine k) = -- If there are enough coins left to cover the cost, no length check is required -- Otherwise, the full length check is required (partial doesn't work until the right offset is reached)- liftM2 (\canAfford mk γ -> if canAfford then mk γ else emitLengthCheck (willConsume coins) mk (raise γ) γ)- (asks (canAfford (willConsume coins)))- k-evalMeta (GiveBursary coins) (Machine k) = local (giveCoins (willConsume coins)) k-evalMeta (PrefetchChar check) (Machine k) =- do requiresPiggy <- asks hasCoin- if | not check -> k- | requiresPiggy -> local (storePiggy 1) k- | otherwise -> local (giveCoins 1) k <&> \mk γ -> emitLengthCheck 1 mk (raise γ) γ-evalMeta BlockCoins (Machine k) = k+ liftM2 drain (asks (canAfford coins)) k+ where+ drain Nothing mk γ = mk γ+ drain _ mk γ = emitLengthCheck coins mk (raise γ) γ+evalMeta (GiveBursary coins) (Machine k) = local (giveCoins coins) k+evalMeta BlockCoins{} (Machine k) = k
src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputOps.hs view
@@ -2,6 +2,7 @@ MagicHash, TypeApplications, UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed module Parsley.Internal.Backend.Machine.InputOps ( InputPrep(..), PositionOps(..), BoxOps(..), LogOps(..), InputOps(..), more, next,@@ -10,18 +11,16 @@ import Data.Array.Base (UArray(..), listArray) import Data.ByteString.Internal (ByteString(..))-import Data.Text.Array (aBA{-, empty-}) import Data.Text.Internal (Text(..))-import Data.Text.Unsafe (iter, Iter(..){-, iter_, reverseIter_-})+import Data.Text.Unsafe (iter, Iter(..)) import GHC.Exts (Int(..), Char(..)) import GHC.ForeignPtr (ForeignPtr(..))-import GHC.Prim (indexWideCharArray#, indexWord16Array#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#))+import GHC.Prim (indexWideCharArray#, readWord8OffAddr#, word2Int#, chr#, touch#, realWorld#, plusAddr#, (+#)) import Parsley.Internal.Backend.Machine.InputRep import Parsley.Internal.Common.Utils (Code) 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) data InputDependant rep = InputDependant {-next-} (rep -> (# Char, rep #)) {-more-} (rep -> Bool)@@ -53,8 +52,8 @@ {- INSTANCES -} -- InputPrep Instances-instance InputPrep [Char] where- prepare input = prepare @(UArray Int Char) [||listArray (0, length $$input-1) $$input||]+--instance InputPrep [Char] where+-- prepare input = prepare @(UArray Int Char) [||listArray (0, length $$input-1) $$input||] instance InputPrep (UArray Int Char) where prepare qinput = [||@@ -63,13 +62,8 @@ in InputDependant next (< size) 0 ||] -instance InputPrep Text16 where- prepare qinput = [||- let Text16 (Text arr off size) = $$qinput- arr# = aBA arr- next (I# i#) = (# C# (chr# (word2Int# (indexWord16Array# arr# i#))), I# (i# +# 1#) #)- in InputDependant next (< size) off- ||]+instance InputPrep Text16 where prepare qinput = prepare @Text [|| let Text16 t = $$qinput in t ||]+instance InputPrep CharList where prepare qinput = prepare @String [|| let CharList cs = $$qinput in cs ||] instance InputPrep ByteString where prepare qinput = [||@@ -81,13 +75,12 @@ in InputDependant next (< size) off ||] -instance InputPrep CharList where+instance InputPrep String where prepare qinput = [||- let CharList input = $$qinput- next (OffWith i (c:cs)) = (# c, OffWith (i+1) cs #)+ let next (OffWith i (c:cs)) = (# c, OffWith (i+1) cs #) more (OffWith _ []) = False more _ = True- in InputDependant next more ($$offWith input)+ in InputDependant next more ($$offWith $$qinput) ||] instance InputPrep Text where@@ -176,52 +169,3 @@ instance LogOps UnpackedLazyByteString where shiftLeft = [||byteStringShiftLeft||] offToInt = [||\(UnpackedLazyByteString i _ _ _ _ _) -> i||]--{- Old Instances -}-{-instance Input CacheText (Text, Stream) where- prepare qinput = [||- let (CacheText input) = $$qinput- next (t@(Text arr off unconsumed), _) = let !(Iter c d) = iter t 0 in (# c, (Text arr (off+d) (unconsumed-d), nomore) #)- more (Text _ _ unconsumed, _) = unconsumed > 0- same (Text _ i _, _) (Text _ j _, _) = i == j- (Text arr off unconsumed, _) << i = go i off unconsumed- where- go 0 off' unconsumed' = (Text arr off' unconsumed', nomore)- go n off' unconsumed'- | off' > 0 = let !d = reverseIter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)- | otherwise = (Text arr off' unconsumed', nomore)- (Text arr off unconsumed, _) >> i = go i off unconsumed- where- go 0 off' unconsumed' = (Text arr off' unconsumed', nomore)- go n off' unconsumed'- | unconsumed' > 0 = let !d = iter_ (Text arr off' unconsumed') 0 in go (n-1) (off'+d) (unconsumed'-d)- | otherwise = (Text arr off' unconsumed', nomore)- toInt (Text arr off unconsumed, _) = div off 2- box (# text, cache #) = (text, cache)- unbox (text, cache) = (# text, cache #)- newCRef (Text _ i _, _) = newSTRefU i- readCRef ref = fmap (\i -> (Text empty i 0, nomore)) (readSTRefU ref)- writeCRef ref (Text _ i _, _) = writeSTRefU ref i- in PreparedInput next more same (input, nomore) box unbox newCRef readCRef writeCRef s(<<) (>>) toInt- ||]--instance Input Lazy.ByteString (OffWith Lazy.ByteString) where- prepare qinput = [||- let next (OffWith i (Lazy.Chunk (PS ptr@(ForeignPtr addr# final) off@(I# off#) size) cs)) =- case readWord8OffAddr# addr# off# realWorld# of- (# s', x #) -> case touch# final s' of- _ -> (# C# (chr# (word2Int# x)), OffWith (i+1) (if size == 1 then cs- else Lazy.Chunk (PS ptr (off+1) (size-1)) cs) #)- more (OffWith _ Lazy.Empty) = False- more _ = True- ow@(OffWith _ (Lazy.Empty)) << _ = ow- OffWith o (Lazy.Chunk (PS ptr off size) cs) << i =- let d = min off i- in OffWith (o - d) (Lazy.Chunk (PS ptr (off - d) (size + d)) cs)- ow@(OffWith _ Lazy.Empty) >> _ = ow- OffWith o (Lazy.Chunk (PS ptr off size) cs) >> i- | i < size = OffWith (o + i) (Lazy.Chunk (PS ptr (off + i) (size - i)) cs)- | otherwise = OffWith (o + size) cs >> (i - size)- readCRef ref = fmap (\i -> OffWith i Lazy.Empty) (readSTRefU ref)- in PreparedInput next more offWithSame (offWith $$qinput) offWithBox offWithUnbox offWithNewORef readCRef offWithWriteORef (<<) (>>) offWithToInt- ||]-}
src/ghc-8.6+/Parsley/Internal/Backend/Machine/InputRep.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE MagicHash, TypeFamilyDependencies, UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-deprecations #-} --FIXME: remove when Text16 is removed module Parsley.Internal.Backend.Machine.InputRep ( Unboxed, Rep, OffWith(..), offWith, offWithSame, offWithShiftRight,@@ -50,15 +51,13 @@ {- Representation Mappings -} -- When a new input type is added here, it needs an Input instance in Parsley.Backend.Machine type family Rep input where- Rep [Char] = Int+ Rep [Char] = OffWith String Rep (UArray Int Char) = Int- Rep Text16 = Int+ Rep Text16 = Text Rep ByteString = Int Rep CharList = OffWith String Rep Text = Text- --Rep CacheText = (Text, Stream) Rep Lazy.ByteString = UnpackedLazyByteString- --Rep Lazy.ByteString = OffWith Lazy.ByteString Rep Stream = OffWith Stream type family RepKind rep where@@ -67,7 +66,6 @@ RepKind UnpackedLazyByteString = 'TupleRep '[IntRep, AddrRep, LiftedRep, IntRep, IntRep, LiftedRep] RepKind (OffWith _) = 'TupleRep '[IntRep, LiftedRep] RepKind (OffWithStreamAnd _) = 'TupleRep '[IntRep, LiftedRep, LiftedRep]- RepKind (Text, Stream) = 'TupleRep '[LiftedRep, LiftedRep] type family Unboxed rep = (urep :: TYPE (RepKind rep)) | urep -> rep where Unboxed Int = Int#@@ -75,7 +73,6 @@ Unboxed UnpackedLazyByteString = (# Int#, Addr#, ForeignPtrContents, Int#, Int#, Lazy.ByteString #) Unboxed (OffWith ts) = (# Int#, ts #) Unboxed (OffWithStreamAnd ts) = (# Int#, Stream, ts #)- Unboxed (Text, Stream) = (# Text, Stream #) {- Generic Representation Operations -} offWithSame :: Code (OffWith ts -> OffWith ts -> Bool)@@ -83,18 +80,6 @@ offWithShiftRight :: Code (Int -> ts -> ts) -> Code (OffWith ts -> Int -> OffWith ts) offWithShiftRight drop = [||\(OffWith o ts) i -> OffWith (o + i) ($$drop i ts)||]--{-offWithStreamAnd :: ts -> OffWithStreamAnd ts-offWithStreamAnd ts = OffWithStreamAnd 0 nomore ts--offWithStreamAndBox :: (# Int#, Stream, ts #) -> OffWithStreamAnd ts-offWithStreamAndBox (# i#, ss, ts #) = OffWithStreamAnd (I# i#) ss ts--offWithStreamAndUnbox :: OffWithStreamAnd ts -> (# Int#, Stream, ts #)-offWithStreamAndUnbox (OffWithStreamAnd (I# i#) ss ts) = (# i#, ss, ts #)--offWithStreamAndToInt :: OffWithStreamAnd ts -> Int-offWithStreamAndToInt (OffWithStreamAnd i _ _) = i-} dropStream :: Int -> Stream -> Stream dropStream 0 cs = cs
src/ghc-8.6+/Parsley/Internal/Backend/Machine/Ops.hs view
@@ -31,6 +31,8 @@ import Parsley.Internal.Core.CharPred (CharPred, lamTerm) import System.Console.Pretty (color, Color(Green, White, Red, Blue)) +import qualified Parsley.Internal.Opt as Opt+ #define inputInstances(derivation) \ derivation(Int) \ derivation((OffWith [Char])) \@@ -49,7 +51,7 @@ updatePos (qline, qcol) qc k = [|| case updatePos# $$qline $$qcol $$qc of (# line', col' #) -> $$(k ([||line'||], [||col'||])) ||] {- Input Operations -}-sat :: (?ops :: InputOps o) => CharPred -> (Γ 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 :: (?ops :: InputOps o, ?flags :: Opt.Flags) => CharPred -> (Γ 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 updatePos pos c $ \pos' -> _if (ap (LAM (lamTerm p)) v)@@ -58,13 +60,14 @@ emitLengthCheck :: (?ops :: InputOps 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 1 good bad γ = [|| if $$more $$(input γ) then $$(good (γ { deepestKnownChar = Just (input γ)})) else $$bad ||] emitLengthCheck n good bad γ = [||- if $$more ($$shiftRight $$(input γ) (n - 1)) then $$(good γ)+ let lookAheadInput = $$shiftRight $$(input γ) (n - 1) in+ if $$more lookAheadInput then $$(good (γ { deepestKnownChar = Just [||lookAheadInput||]})) else $$bad ||] {- General Operations -}-dup :: Defunc x -> (Defunc x -> Code r) -> Code r+dup :: (?flags :: Opt.Flags) => Defunc x -> (Defunc x -> Code r) -> Code r dup (FREEVAR x) k = k (FREEVAR x) dup (INPUT o pos) k = k (INPUT o pos) dup x k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]@@ -74,21 +77,21 @@ returnST = return @(ST s) {- 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Σ :: (?flags :: Opt.Flags) => Σ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 newΣ σ Hard x k ctx = dup x $ \dupx -> [|| do ref <- newSTRef $$(genDefunc dupx) $$(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Σ :: (?flags :: Opt.Flags) => Σ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 writeΣ σ Hard x k ctx = let ref = concreteΣ σ ctx in dup x $ \dupx -> [|| do writeSTRef $$ref $$(genDefunc dupx) $$(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Σ :: (?flags :: Opt.Flags) => Σ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 readΣ σ Hard k ctx = let ref = concreteΣ σ ctx in [|| do x <- readSTRef $$ref@@ -117,7 +120,7 @@ { \ buildHandler γ h c pos = [||\(o# :: Unboxed _o) !(line :: Int) !(col :: Int) -> \ $$(h (γ {operands = Op (INPUT c pos) (operands γ), \- input = [||$$box o#||], pos = ([||line||], [||col||])}))||]; \+ input = [||$$box o#||], deepestKnownChar = Nothing, pos = ([||line||], [||col||])}))||]; \ fatal = [||\(!_) !_ !_ -> returnST Nothing ||]; \ raise γ = let VCons h _ = handlers γ \ in [|| $$h ($$unbox $$(input γ)) $$(fst (pos γ)) $$(snd (pos γ)) ||]; \@@ -126,8 +129,8 @@ {- Control Flow Operations -} 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))+ suspend :: (?flags :: Opt.Flags) => (Γ 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 :: (?flags :: Opt.Flags) => 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 -> (Code Int, Code Int) -> Vec (Succ n) (Code (Handler s o a)) -> Code (ST s (Maybe a)) class ReturnOps o where@@ -138,7 +141,7 @@ instance ContOps _o where \ { \ suspend m γ = [|| \x (!o#) !l !c -> $$(m (γ {operands = Op (FREEVAR [||x||]) (operands γ), \- input = [||$$box o#||], pos = ([||l||], [||c||])})) ||]; \+ input = [||$$box o#||], deepestKnownChar = Nothing, pos = ([||l||], [||c||])})) ||]; \ resume k γ = let Op x _ = operands γ in [|| $$k $$(genDefunc x) ($$unbox $$(input γ)) $$(fst (pos γ)) $$(snd (pos γ)) ||]; \ callWithContinuation sub ret input (ql, qc) (VCons h _) = [||$$sub $$ret ($$unbox $$input) $$ql $$qc $! $$h||]; \ };@@ -154,7 +157,7 @@ {- Builder Operations -} class BoxOps o => 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+ setupJoinPoint :: (?flags :: Opt.Flags) => ΦVar x -> Machine s o (x : xs) n r a -> Machine s o xs n r a -> MachineMonad s o xs n r a class BoxOps o => RecBuilder o where buildIter :: ReturnOps o@@ -172,7 +175,7 @@ setupJoinPoint φ (Machine k) mx = \ liftM2 (\mk ctx γ -> [|| \ let join x !(o# :: Unboxed _o) !(line :: Int) !(col :: Int) = \- $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||$$box o#||], pos = ([||line||], [||col||])})) \+ $$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||$$box o#||], deepestKnownChar = Nothing, pos = ([||line||], [||col||])})) \ in $$(run mx γ (insertΦ φ [||join||] ctx)) \ ||]) (local voidCoins k) ask; \ };@@ -185,13 +188,13 @@ let handler !o# !line !col = $$(h [||$$bx o#||] ([||line||], [||col||])); \ loop !o# !line !col = \ $$(run l \- (Γ Empty (noreturn @_o) [||$$bx o#||] ([||line||], [||col||]) (VCons [||handler o# line col||] VNil)) \+ (Γ Empty (noreturn @_o) [||$$bx o#||] Nothing ([||line||], [||col||]) (VCons [||handler o# line col||] VNil)) \ (voidCoins (insertSub μ [||\_ (!o#) !line !col _ -> loop o# line col||] ctx))) \ in loop ($$unbox $$o) $$line $$col \ ||]; \ buildRec _ rs ctx k = let bx = box in takeFreeRegisters rs ctx (\ctx -> \ [|| \(!ret) (!o#) !line !col h -> \- $$(run k (Γ Empty [||ret||] [||$$bx o#||] ([||line||], [||col||]) (VCons [||h||] VNil)) ctx) ||]); \+ $$(run k (Γ Empty [||ret||] [||$$bx o#||] Nothing ([||line||], [||col||]) (VCons [||h||] VNil)) ctx) ||]); \ }; inputInstances(deriveRecBuilder)
src/ghc-8.6+/Parsley/Internal/Backend/Machine/Types/State.hs view
@@ -11,18 +11,18 @@ insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, concreteΣ, cachedΣ, qSubroutine, askSub, askΦ, debugUp, debugDown, debugLevel,- storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins,+ storePiggy, breakPiggy, spendCoin, giveCoins, voidCoins, coins, netWorth, hasCoin, isBankrupt, canAfford ) where import Control.Exception (Exception, throw)-import Control.Monad (liftM2, (<=<))+import Control.Monad ((<=<)) 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 Data.Maybe (fromMaybe, isNothing) 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)@@ -30,7 +30,7 @@ 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)+import qualified Parsley.Internal.Common.Queue as Queue (empty) type HandlerStack n s o a = Vec n (Code (Handler s o a)) type Handler s o a = Unboxed o -> Int -> Int -> ST s (Maybe a)@@ -63,6 +63,7 @@ data Γ s o xs n r a = Γ { operands :: OpStack xs , retCont :: Code (Cont s o a r) , input :: Code o+ , deepestKnownChar :: Maybe (Code o) , pos :: (Code Int, Code Int) , handlers :: HandlerStack n s o a } @@ -71,10 +72,11 @@ , σs :: DMap ΣVar (Reg s) , debugLevel :: Int , coins :: Int- , piggies :: Queue Int }+ , piggies :: Queue Int+ , netWorth :: Int } emptyCtx :: DMap MVar (QSubroutine s o a) -> Ctx s o a-emptyCtx μs = Ctx μs DMap.empty DMap.empty 0 0 Queue.empty+emptyCtx μs = Ctx μs DMap.empty DMap.empty 0 0 Queue.empty 0 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)}@@ -122,28 +124,33 @@ -- Piggy bank functions storePiggy :: Int -> Ctx s o a -> Ctx s o a-storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx)}+storePiggy 0 ctx = ctx+storePiggy coins ctx = ctx {piggies = enqueue coins (piggies ctx), netWorth = netWorth ctx + coins} breakPiggy :: Ctx s o a -> Ctx s o a-breakPiggy ctx = let (coins, piggies') = dequeue (piggies ctx) in ctx {coins = coins, piggies = piggies'}+breakPiggy ctx =+ let (coins, piggies') = dequeue (piggies ctx)+ in ctx {coins = coins, piggies = piggies', netWorth = netWorth ctx - coins} hasCoin :: Ctx s o a -> Bool-hasCoin = canAfford 1+hasCoin = isNothing . canAfford 1 isBankrupt :: Ctx s o a -> Bool-isBankrupt = liftM2 (&&) (not . hasCoin) (Queue.null . piggies)+isBankrupt = (== 0) . netWorth spendCoin :: Ctx s o a -> Ctx s o a-spendCoin ctx = ctx {coins = coins ctx - 1}+spendCoin ctx = ctx {coins = coins ctx - 1, netWorth = netWorth ctx - 1} giveCoins :: Int -> Ctx s o a -> Ctx s o a-giveCoins c ctx = ctx {coins = coins ctx + c}+giveCoins c ctx = ctx {coins = coins ctx + c, netWorth = netWorth ctx + c} voidCoins :: Ctx s o a -> Ctx s o a-voidCoins ctx = ctx {coins = 0, piggies = Queue.empty}+voidCoins ctx = ctx {coins = 0, piggies = Queue.empty, netWorth = 0} -canAfford :: Int -> Ctx s o a -> Bool-canAfford n = (>= n) . coins+canAfford :: Int -> Ctx s o a -> Maybe Int+canAfford n ctx+ | coins ctx >= n = Nothing+ | otherwise = Just (n - coins ctx) newtype MissingDependency = MissingDependency IMVar deriving anyclass Exception newtype OutOfScopeRegister = OutOfScopeRegister IΣVar deriving anyclass Exception
src/ghc/Parsley/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ImplicitParams, PatternSynonyms #-} {-| Module : Parsley.Internal Description : The gateway into the internals: here be monsters!@@ -17,7 +17,7 @@ module THUtils, module Trace, module Backend,- parse+ parse, parseWithOpts ) where import Parsley.Internal.Backend (codeGen, eval)@@ -40,5 +40,12 @@ import Parsley.Internal.Common.Utils as THUtils (Quapplicative(..), WQ, Code, makeQ) import Parsley.Internal.Trace as Trace (Trace(trace)) +import qualified Parsley.Internal.Opt as Opt+ parse :: (Trace, Input input) => Parser a -> Code (input -> Maybe a)-parse p = [||\input -> $$(eval [||input||] (compile (try p) codeGen))||]+parse = parseWithOpts Opt.fast++parseWithOpts :: (Trace, Input input) => Opt.Flags -> Parser a -> Code (input -> Maybe a)+parseWithOpts _flags p =+ let ?flags = _flags+ in [||\input -> $$(eval [||input||] (compile (try p) codeGen))||]
src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} {-| Module : Parsley.Internal.Backend.Analysis.Coins Description : Coins analysis.@@ -15,7 +16,7 @@ module Parsley.Internal.Backend.Analysis.Coins (coinsNeeded, reclaimable) where import Data.Bifunctor (first)-import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..), Handler(..), Coins, plus1, minCoins, maxCoins, zero, minus, plusNotReclaim, willConsume)+import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..), Handler(..), Coins, plus1, minCoins, pattern Zero, minus, items) import Parsley.Internal.Common.Indexed (cata4, Fix4, Const4(..)) {-|@@ -34,51 +35,59 @@ reclaimable :: Fix4 (Instr o) xs n r a -> Coins reclaimable = fst . getConst4 . cata4 (Const4 . alg False) -bilift2 :: (a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z)-bilift2 f g (x1, y1) (x2, y2) = (f x1 x2, g y1 y2)- algCatch :: (Coins, Bool) -> (Coins, Bool) -> (Coins, Bool)-algCatch k (_, True) = k-algCatch (_, True) k = k+-- if either of the two halves have an empty, then skip it+algCatch k (Zero, True) = k+algCatch (Zero, True) k = k+-- take the smaller of the two branches algCatch (k1, _) (k2, _) = (minCoins k1 k2, False) +algHandler :: Handler o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)+algHandler (Same _ yes _ no) = algCatch (getConst4 yes) (getConst4 no)+algHandler (Always _ k) = getConst4 k+ -- Bool represents if an empty is found in a branch (of a Catch) -- This helps to get rid of `min` being used for `Try` where min is always 0 -- (The input is needed to /succeed/, so if one branch is doomed to fail it doesn't care about coins) alg :: Bool -> Instr o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)-alg _ Ret = (zero, False)-alg _ (Push _ k) = getConst4 k -- was const False on the second parameter, I think that's probably right but a bit presumptive-alg _ (Pop k) = getConst4 k-alg _ (Lift2 _ k) = getConst4 k-alg _ (Sat _ (Const4 k)) = first plus1 k-alg _ (Call _ (Const4 k)) = first (const zero) k-alg _ (Jump _) = (zero, False)-alg _ Empt = (zero, True)-alg _ (Commit k) = getConst4 k-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 _ _ h) = first (const zero) (algHandler h)-alg _ (Join _) = (zero, False)-alg _ (MkJoin _ (Const4 b) (Const4 k)) = bilift2 (flip plusNotReclaim . willConsume) (||) b k-alg _ (Swap k) = getConst4 k-alg _ (Dup k) = getConst4 k-alg _ (Make _ _ k) = getConst4 k-alg _ (Get _ _ k) = getConst4 k-alg _ (Put _ _ (Const4 k)) = first (const zero) k-alg _ (SelectPos _ k) = getConst4 k-alg _ (LogEnter _ k) = getConst4 k-alg _ (LogExit _ k) = getConst4 k-alg _ (MetaInstr (AddCoins _) (Const4 k)) = k-alg _ (MetaInstr (RefundCoins n) (Const4 k)) = first (maxCoins zero . (`minus` n)) k -- These were refunded, so deduct-alg _ (MetaInstr (DrainCoins n) _) = (n, False) -- Used to be `second (const False) k`, but these should be additive?-alg _ (MetaInstr (GiveBursary n) _) = (n, False) -- We know that `n` is the required for `k`-alg _ (MetaInstr (PrefetchChar _) (Const4 k)) = k-alg True (MetaInstr BlockCoins (Const4 k)) = first (const zero) k-alg False (MetaInstr BlockCoins (Const4 k)) = k--algHandler :: Handler o (Const4 (Coins, Bool)) xs n r a -> (Coins, Bool)-algHandler (Same _ yes _ no) = algCatch (getConst4 yes) (getConst4 no)-algHandler (Always _ k) = getConst4 k+-- All of these move control flow to somewhere else, and this means that there can be no factoring of+-- input across them, return or not: the properties of the foreign call are not known.+alg _ Ret = (Zero, False)+alg _ Call{} = (Zero, False)+alg _ Iter{} = (Zero, False)+alg _ Join{} = (Zero, False) -- this is zero because a DrainCoins is generated just in front!+alg _ Empt = (Zero, True)+-- all of these instructions have no effect on the coins of their continuation, and are just transitive+alg _ (Push _ (Const4 k)) = k+alg _ (Pop (Const4 k)) = k+alg _ (Lift2 _ (Const4 k)) = k+alg _ (Commit (Const4 k)) = k+alg _ (Tell (Const4 k)) = k+alg _ (Seek (Const4 k)) = k+alg _ (MkJoin _ _ (Const4 k)) = k+alg _ (Swap (Const4 k)) = k+alg _ (Dup (Const4 k)) = k+alg _ (Make _ _ (Const4 k)) = k+alg _ (Get _ _ (Const4 k)) = k+alg _ (SelectPos _ (Const4 k)) = k+alg _ (LogEnter _ (Const4 k)) = k+alg _ (LogExit _ (Const4 k)) = k+alg _ (MetaInstr (AddCoins _) (Const4 k)) = k+-- cannot allow factoring through a put, because it could stop it from executing+-- but this is done in code gen via a Block, which can be disabled+alg _ (Put _ _ (Const4 k)) = k+-- reading a character obviously contributes a single coin to the total along with its predicate+alg _ (Sat p (Const4 k)) = first (plus1 p) k+alg _ (Catch k h) = algCatch (getConst4 k) (algHandler h)+alg _ (Case p q) = algCatch (getConst4 p) (getConst4 q)+alg _ (Choices _ ks def) = foldr (algCatch . getConst4) (getConst4 def) ks+-- as these coins are refunded in `k`, they should be deducted from the required coins for `k`+alg _ (MetaInstr (RefundCoins n) (Const4 k)) = first (`minus` n) k -- TODO: minus could actually keep the predicate knowledge for intersection?+-- we want these propagated out so that they commute across a factored boundary+alg _ (MetaInstr (DrainCoins n) _) = (items n, False)+-- no point in propagating forward, these are at the front of a binding+alg _ (MetaInstr (GiveBursary _) _) = (Zero, False)+-- this is the instruction that actions a cut by blocking all coins from traversing it+-- however, this can be disabled when processing a lookahead, unless its strong+alg False (MetaInstr (BlockCoins False) (Const4 k)) = k+alg _ (MetaInstr BlockCoins{} (Const4 k)) = first (const Zero) k
src/ghc/Parsley/Internal/Backend/Analysis/Inliner.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImplicitParams #-} {-| Module : Parsley.Internal.Backend.Analysis.Inliner Description : Determines whether a machine should be inlined.@@ -16,8 +17,7 @@ import Parsley.Internal.Backend.Machine (Instr(..), Handler(..), Access(Hard, Soft)) import Parsley.Internal.Common.Indexed (cata4, Fix4, Nat) -inlineThreshold :: Rational-inlineThreshold = 13 % 10+import qualified Parsley.Internal.Opt as Opt {-| Provides a conservative estimate on whether or not each of the elements of the stack on@@ -25,8 +25,10 @@ @since 1.7.0.0 -}-shouldInline :: Fix4 (Instr o) xs n r a -> Bool-shouldInline = (< inlineThreshold) . getWeight . cata4 (InlineWeight . alg)+shouldInline :: (?flags :: Opt.Flags) => Fix4 (Instr o) xs n r a -> Bool+shouldInline+ | Just thresh <- Opt.secondaryInlineThreshold ?flags = (<= thresh) . getWeight . cata4 (InlineWeight . alg)+ | otherwise = const False newtype InlineWeight xs (n :: Nat) r a = InlineWeight { getWeight :: Rational } @@ -37,7 +39,6 @@ alg (Lift2 _ k) = 1 % 5 + getWeight k alg (Sat _ k) = 1 + getWeight k alg (Call _ k) = 2 % 3 + getWeight k-alg (Jump _) = 0 alg Empt = 0 alg (Commit k) = 0 + getWeight k alg (Catch k h) = (if handlerInlined h then 0 else 1 % 4) + getWeight k + algHandler h
src/ghc/Parsley/Internal/Backend/Analysis/Relevancy.hs view
@@ -52,7 +52,6 @@ alg (Lift2 _ k) (SSucc n) = let VCons rel xs = getStack k n in VCons rel (VCons rel xs) alg (Sat _ k) n = let VCons _ xs = getStack k (SSucc n) in xs alg (Call _ k) n = let VCons _ xs = getStack k (SSucc n) in xs-alg (Jump _) _ = VNil alg Empt n = replicateVec n False alg (Commit k) n = getStack k n alg (Catch k _) n = getStack k n
src/ghc/Parsley/Internal/Backend/CodeGenerator.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ImplicitParams, PatternSynonyms #-} {-| Module : Parsley.Internal.Backend.CodeGenerator Description : Translation of Combinator AST into Machine@@ -17,9 +17,8 @@ import Data.Set (Set, elems) import Control.Monad.Trans (lift) import Parsley.Internal.Backend.Machine (user, LetBinding, makeLetBinding, newMeta, Instr(..), Handler(..),- _Fmap, _App, _Get, _Put, _Make,+ _Fmap, _App, _Get, _Put, _Make, _Jump, addCoins, refundCoins, drainCoins, giveBursary, blockCoins,- minus, minCoins, maxCoins, zero, IMVar, IΦVar, MVar(..), ΦVar(..), SomeΣVar) import Parsley.Internal.Backend.Analysis (coinsNeeded, shouldInline, reclaimable) import Parsley.Internal.Common.Fresh (VFreshT, VFresh, evalFreshT, evalFresh, construct, MonadFresh(..), mapVFreshT)@@ -30,6 +29,8 @@ import Parsley.Internal.Core.Defunc as Core (Defunc) +import qualified Parsley.Internal.Opt as Opt+ type CodeGenStack a = VFreshT IΦVar (VFresh IMVar) a runCodeGenStack :: CodeGenStack a -> IMVar -> IΦVar -> a runCodeGenStack m μ0 φ0 = evalFresh (evalFreshT m φ0) μ0@@ -43,7 +44,7 @@ @since 1.0.0.0 -} {-# INLINEABLE codeGen #-}-codeGen :: Trace+codeGen :: (Trace, ?flags :: Opt.Flags) => 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.@@ -52,12 +53,12 @@ codeGen letBound p rs μ0 = trace ("GENERATING " ++ name ++ ": " ++ show p ++ "\nMACHINE: " ++ show (elems rs) ++ " => " ++ show m) $ makeLetBinding m rs newMeta where name = maybe "TOP LEVEL" show letBound+ --addCoinsTop = maybe addCoinsNeeded (const id) letBound m = finalise (histo alg p) alg :: Combinator (Cofree Combinator (CodeGen o a)) x -> CodeGen o a x alg = deep |> (\x -> CodeGen (shallow (imap extract x)))- -- It is never safe to add coins to the top of a binding- -- This is because we don't know the characteristics of the caller (even the top-level!)- finalise cg = runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0+ -- add coins is safe here because if a cut is present it will only factor 1 coin+ finalise cg = addCoinsNeeded (runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0) pattern (:<$>:) :: Core.Defunc (a -> b) -> Cofree Combinator k a -> Combinator (Cofree Combinator k) b pattern f :<$>: p <- (_ :< Pure f) :<*>: p@@ -71,99 +72,76 @@ rollbackHandler :: Handler o (Fix4 (Instr o)) (o : xs) (Succ n) r a rollbackHandler = Always False (In4 (Seek (In4 Empt))) -parsecHandler :: Fix4 (Instr o) xs (Succ n) r a -> Handler o (Fix4 (Instr o)) (o : xs) (Succ n) r a+parsecHandler :: (?flags :: Opt.Flags) => Fix4 (Instr o) xs (Succ n) r a -> Handler o (Fix4 (Instr o)) (o : xs) (Succ n) r a parsecHandler k = Same (not (shouldInline k)) k False (In4 Empt) -recoverHandler :: Fix4 (Instr o) xs n r a -> Handler o (Fix4 (Instr o)) (o : xs) n r a+recoverHandler :: (?flags :: Opt.Flags) => Fix4 (Instr o) xs n r a -> Handler o (Fix4 (Instr o)) (o : xs) n r a recoverHandler = Always . not . shouldInline <*> In4 . Seek -altNoCutCompile :: Trace => CodeGen o a y -> CodeGen o a x- -> (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 =+altCompile :: (Trace, ?flags :: Opt.Flags) => CodeGen o a y -> CodeGen o a x+ -> (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)+altCompile p q handler post m = do (binder, φ) <- makeΦ m pc <- freshΦ (runCodeGen p (deadCommitOptimisation (post φ))) qc <- freshΦ (runCodeGen q φ)- let np = coinsNeeded pc- let nq = coinsNeeded qc- let dp = np `minus` minCoins np nq- let dq = nq `minus` minCoins np nq- return $! binder (In4 (Catch (addCoins dp pc) (handler (addCoins dq qc))))--loopCompile :: CodeGen o a () -> 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)-loopCompile body exit prebody preExit m =- do μ <- askM- bodyc <- freshM (runCodeGen body (In4 (Pop (In4 (Jump μ)))))- exitc <- freshM (runCodeGen exit m)- return $! In4 (Iter μ (prebody bodyc) (parsecHandler (preExit exitc)))+ -- the shared coins are not factored out of the branches, because this is done by the AddCoins evaluation+ return $! binder (In4 (Catch (addCoinsNeeded pc) (handler (addCoinsNeeded qc)))) -deep :: Trace => Combinator (Cofree Combinator (CodeGen o a)) x -> Maybe (CodeGen o a x)+deep :: (Trace, ?flags :: Opt.Flags) => 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 recoverHandler id-deep ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q recoverHandler (In4 . Pop . In4 . Push (user x))-deep ((_ :< (f :<$>: (_ :< Try (p :< _)))) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q recoverHandler (In4 . _Fmap (user f))-deep (MetaCombinator RequiresCut (_ :< ((p :< _) :<|>: (q :< _)))) = Just $ CodeGen $ \m ->- do (binder, φ) <- makeΦ m- pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))- qc <- freshΦ (runCodeGen q φ)- return $! binder (In4 (Catch pc (parsecHandler qc)))-deep (MetaCombinator RequiresCut (_ :< Loop (body :< _) (exit :< _))) = Just $ CodeGen $ loopCompile body exit id addCoinsNeeded-deep (MetaCombinator Cut (_ :< Loop (body :< _) (exit :< _))) = Just $ CodeGen $ loopCompile body exit addCoinsNeeded addCoinsNeeded+deep (TryOrElse p q) = Just $ CodeGen $ altCompile p q recoverHandler id+deep ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ altCompile p q recoverHandler (In4 . Pop . In4 . Push (user x))+deep ((_ :< (f :<$>: (_ :< Try (p :< _)))) :<|>: (q :< _)) = Just $ CodeGen $ altCompile p q recoverHandler (In4 . _Fmap (user f)) deep _ = Nothing addCoinsNeeded :: Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a addCoinsNeeded = coinsNeeded >>= addCoins -shallow :: Trace => Combinator (CodeGen o a) x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)+shallow :: (Trace, ?flags :: Opt.Flags) => 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 p m) shallow (pf :<*>: px) m = do pxc <- runCodeGen px (In4 (_App m)); runCodeGen pf pxc shallow (p :*>: q) m = do qc <- runCodeGen q m; runCodeGen p (In4 (Pop qc)) shallow (p :<*: q) m = do qc <- runCodeGen q (In4 (Pop m)); runCodeGen p qc shallow Empty _ = do return $! In4 Empt-shallow (p :<|>: q) m = do altNoCutCompile p q parsecHandler id m+shallow (p :<|>: q) m = do altCompile p q parsecHandler id m shallow (Try p) m = do fmap (In4 . flip Catch rollbackHandler) (runCodeGen p (deadCommitOptimisation m)) shallow (LookAhead p) m =- do n <- fmap reclaimable (runCodeGen p (In4 Ret)) -- Dodgy hack, but oh well+ do n <- fmap reclaimable (runCodeGen p (In4 Ret)) -- dodgy hack, but oh well+ -- always refund the input consumed during a lookahead, so it can be reused (lookahead is handlerless) fmap (In4 . Tell) (runCodeGen p (In4 (Swap (In4 (Seek (refundCoins n m)))))) shallow (NotFollowedBy p) m = do pc <- runCodeGen p (In4 (Pop (In4 (Seek (In4 (Commit (In4 Empt)))))))- let np = coinsNeeded pc- let nm = coinsNeeded m- -- The minus here is used because the shared coins are propagated out front, neat.- return $! In4 (Catch (addCoins (maxCoins (np `minus` nm) zero) (In4 (Tell pc))) (Always (not (shouldInline m)) (In4 (Seek (In4 (Push (user UNIT) m))))))+ -- it should never be the case that factored input can commute out of the lookahead+ return $! In4 (Catch (blockCoins True (addCoinsNeeded (In4 (Tell pc)))) (Always (not (shouldInline m)) (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 φ))))) qc <- freshΦ (runCodeGen q (In4 (Swap (In4 (_App φ)))))- let minc = coinsNeeded (In4 (Case pc qc))- let dp = maxCoins zero (coinsNeeded pc `minus` minc)- let dq = maxCoins zero (coinsNeeded qc `minus` minc)- fmap binder (runCodeGen b (In4 (Case (addCoins dp pc) (addCoins dq qc))))+ -- the shared coins are not factored out of the branches, because this is done by the AddCoins evaluation+ fmap binder (runCodeGen b (In4 (Case (addCoinsNeeded pc) (addCoinsNeeded qc)))) shallow (Match p fs qs def) m = do (binder, φ) <- makeΦ m qcs <- traverse (\q -> freshΦ (runCodeGen q φ)) qs defc <- freshΦ (runCodeGen def φ)- let minc = coinsNeeded (In4 (Choices (map user fs) qcs defc))- let defc':qcs' = map (maxCoins zero . (`minus` minc) . coinsNeeded >>= addCoins) (defc:qcs)+ let defc':qcs' = map addCoinsNeeded (defc:qcs) fmap binder (runCodeGen p (In4 (Choices (map user fs) qcs' defc')))-shallow (Let _ μ) m = do return $! tailCallOptimise μ m-shallow (Loop body exit) m = do loopCompile body exit addCoinsNeeded id m+shallow (Let μ) m = do return $! In4 (Call μ m)+shallow (Loop body exit) m =+ do μ <- askM+ bodyc <- freshM (runCodeGen body (In4 (Pop (In4 (_Jump μ)))))+ exitc <- freshM (runCodeGen exit m)+ return $! In4 (Iter μ (addCoinsNeeded bodyc) (parsecHandler (addCoinsNeeded exitc))) shallow (MakeRegister σ p q) m = do qc <- runCodeGen q m; runCodeGen p (In4 (_Make σ qc)) shallow (GetRegister σ) m = do return $! In4 (_Get σ m)-shallow (PutRegister σ p) m = do runCodeGen p (In4 (_Put σ (In4 (Push (user UNIT) m))))+-- seems effective: blocks upstream coins from commuting down, but allows them to self factor+shallow (PutRegister σ p) m = do runCodeGen p (In4 (_Put σ (In4 (Push (user UNIT) (blockCoins False m))))) shallow (Position sel) m = do return $! In4 (SelectPos sel m) shallow (Debug name p) m = do fmap (In4 . LogEnter name) (runCodeGen p (In4 (Commit (In4 (LogExit name m)))))-shallow (MetaCombinator Cut p) m = do blockCoins <$> runCodeGen p (addCoins (coinsNeeded m) m)-shallow (MetaCombinator CutImmune p) m = do addCoins . coinsNeeded <$> runCodeGen p (In4 Ret) <*> runCodeGen p m--tailCallOptimise :: MVar x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-tailCallOptimise μ (In4 Ret) = In4 (Jump μ)-tailCallOptimise μ k = In4 (Call μ k)+-- make sure to issue the fence after `p` is generated, to allow for a (safe) single character factor+shallow (MetaCombinator Cut p) m = do runCodeGen p (blockCoins False (addCoinsNeeded m)) -- Thanks to the optimisation applied to the K stack, commit is deadcode before Ret -- However, I'm not yet sure about the interactions with try yet...@@ -184,18 +162,9 @@ freshΦ :: CodeGenStack a -> CodeGenStack a freshΦ = newScope -makeΦ :: Trace => 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 | shouldInline m = trace ("eliding " ++ show 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- elidable (In4 (Join _)) = True- elidable (In4 (Pop (In4 (Join _)))) = True- -- This is terminal-φ optimisation: If a φ-node points shallowly to a terminal operation, then it can be elided- elidable (In4 Ret) = True- elidable (In4 (Pop (In4 Ret))) = True- -- This is a form of double-φ optimisation: If a φ-node points shallowly to a jump, then it can be elided and the jump used instead- -- Note that this should NOT be done for non-tail calls, as they may generate a large continuation- elidable (In4 (Pop (In4 (Jump _)))) = True- elidable _ = False-}-makeΦ m = let n = coinsNeeded m in fmap (\φ -> (In4 . MkJoin φ (giveBursary n m), drainCoins n (In4 (Join φ)))) askΦ+makeΦ :: (Trace, ?flags :: Opt.Flags) => 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+ | shouldInline m = trace ("eliding " ++ show m) $ return (id, m)+ | Opt.factorAheadOfJoins ?flags = fmap (\φ -> (In4 . MkJoin φ (giveBursary n m), drainCoins n (In4 (Join φ)))) askΦ+ | otherwise = fmap (\φ -> (In4 . MkJoin φ (addCoins n m), In4 (Join φ))) askΦ+ where n = coinsNeeded m
src/ghc/Parsley/Internal/Backend/Machine/Identifiers.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# LANGUAGE DerivingStrategies,- GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies, GeneralisedNewtypeDeriving #-} {-| Module : Parsley.Internal.Backend.Machine.Identifiers Description : Machine specific identifiers
src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs view
@@ -22,9 +22,9 @@ Access(..), MetaInstr(..), -- * Smart Instructions- _App, _Fmap, _Modify, _Make, _Put, _Get,+ _App, _Fmap, _Modify, _Make, _Put, _Get, _Jump, -- * Smart Meta-Instructions- addCoins, refundCoins, drainCoins, giveBursary, prefetchChar, blockCoins,+ addCoins, refundCoins, drainCoins, giveBursary, blockCoins, -- * Re-exports PosSelector(..) ) where@@ -32,7 +32,7 @@ import Data.Kind (Type) import Data.Void (Void) import Parsley.Internal.Backend.Machine.Identifiers (MVar, ΦVar, ΣVar)-import Parsley.Internal.Backend.Machine.Types.Coins (Coins(Coins))+import Parsley.Internal.Backend.Machine.Types.Coins (Coins(willConsume)) import Parsley.Internal.Common (IFunctor4, Fix4(In4), Const4(..), imap4, cata4, Nat(..), One, intercalateDiff) import Parsley.Internal.Core.CombinatorAST (PosSelector(..)) import Parsley.Internal.Core.CharPred (CharPred)@@ -40,6 +40,8 @@ import Parsley.Internal.Backend.Machine.Defunc as Machine (Defunc, user) import Parsley.Internal.Core.Defunc as Core (Defunc(ID), pattern FLIP_H) +import qualified Parsley.Internal.Backend.Machine.Types.Coins as Coins (pattern Zero)+ {-| This represents the instructions of the machine, in CPS form as an indexed functor. @@ -84,10 +86,6 @@ 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 -}@@ -249,35 +247,29 @@ This always happens for free, and is added straight to the coins. @since 1.5.0.0 -}- RefundCoins :: Coins -> MetaInstr n+ 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.5.0.0 -}- DrainCoins :: Coins -> MetaInstr (Succ n)+ DrainCoins :: 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. Unlike `RefundCoins` this cannot reclaim input, nor is is subtractive in the analysis. @since 1.5.0.0 -}- GiveBursary :: Coins -> MetaInstr n- {-| Fetches a character to read in advance. This is used to factor out a common token from alternatives.- The boolean argument represents whether or not the read is covered by a factored length check, or- requires its own.-- @since 1.5.0.0 -}- PrefetchChar :: Bool -> MetaInstr (Succ n)+ GiveBursary :: Int -> MetaInstr n {-| True meta instruction: does /nothing/ except for reset coin count during coin analysis. @since 1.6.0.0 -}- BlockCoins :: MetaInstr n+ BlockCoins :: Bool -> MetaInstr n mkCoin :: (Coins -> MetaInstr n) -> Coins -> Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a-mkCoin _ (Coins 0 0) = id+mkCoin _ Coins.Zero = id mkCoin meta n = In4 . MetaInstr (meta n) {-|@@ -286,8 +278,7 @@ @since 1.5.0.0 -} addCoins :: Coins -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-addCoins (Coins 1 1) = id-addCoins coins = mkCoin AddCoins coins+addCoins = mkCoin AddCoins {-| Smart-constuctor around `RefundCoins`.@@ -295,7 +286,7 @@ @since 1.5.0.0 -} refundCoins :: Coins -> Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a-refundCoins = mkCoin RefundCoins+refundCoins = mkCoin (RefundCoins . willConsume) {-| Smart-constuctor around `DrainCoins`.@@ -303,7 +294,7 @@ @since 1.5.0.0 -} drainCoins :: Coins -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-drainCoins = mkCoin DrainCoins+drainCoins = mkCoin (DrainCoins . willConsume) {-| Smart-constuctor around `RefundCoins`.@@ -311,23 +302,15 @@ @since 1.5.0.0 -} giveBursary :: Coins -> Fix4 (Instr o) xs n r a -> Fix4 (Instr o) xs n r a-giveBursary = mkCoin GiveBursary--{-|-Smart-constructor around `PrefetchChar`.--@since 1.5.0.0--}-prefetchChar :: Bool -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-prefetchChar check = In4 . MetaInstr (PrefetchChar check)+giveBursary = mkCoin (GiveBursary . willConsume) {-| Smart-constructor around `BlockCoins`. @since 1.6.0.0 -}-blockCoins :: Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a-blockCoins = In4 . MetaInstr BlockCoins+blockCoins :: Bool -> Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a+blockCoins strong = In4 . MetaInstr (BlockCoins strong) {-| Applies a value on the top of the stack to a function on the second-most top of the stack.@@ -377,6 +360,9 @@ _Get :: ΣVar x -> k (x : xs) n r a -> Instr o k xs n r a _Get σ = Get σ Hard +_Jump :: MVar x -> Instr o (Fix4 (Instr o)) '[] (Succ n) x a+_Jump = flip Call (In4 Ret)+ -- Instances instance IFunctor4 (Instr o) where imap4 _ Ret = Ret@@ -385,7 +371,6 @@ imap4 f (Lift2 g k) = Lift2 g (f k) imap4 f (Sat g k) = Sat g (f k) imap4 f (Call μ k) = Call μ (f k)- imap4 _ (Jump μ) = Jump μ imap4 _ Empt = Empt imap4 f (Commit k) = Commit (f k) imap4 f (Catch p h) = Catch (f p) (imap4 f h)@@ -414,43 +399,41 @@ show = ($ "") . getConst4 . cata4 (Const4 . alg) where alg :: forall xs n r a. Instr o (Const4 (String -> String)) xs n r a -> String -> String- alg Ret = "Ret"- alg (Call μ k) = "(Call " . shows μ . " " . getConst4 k . ")"- alg (Jump μ) = "(Jump " . shows μ . ")"- alg (Push x k) = "(Push " . shows x . " " . getConst4 k . ")"- alg (Pop k) = "(Pop " . getConst4 k . ")"- alg (Lift2 f k) = "(Lift2 " . shows f . " " . getConst4 k . ")"- 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 . " " . 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 . " " . shows h . "}"- alg (Join φ) = shows φ- alg (MkJoin φ p k) = "(let " . shows φ . " = " . getConst4 p . " in " . getConst4 k . ")"- alg (Swap k) = "(Swap " . getConst4 k . ")"- alg (Dup k) = "(Dup " . getConst4 k . ")"- alg (Make σ a k) = "(Make " . shows σ . " " . shows a . " " . getConst4 k . ")"- alg (Get σ a k) = "(Get " . shows σ . " " . shows a . " " . getConst4 k . ")"- alg (Put σ a k) = "(Put " . shows σ . " " . shows a . " " . getConst4 k . ")"- alg (SelectPos Line k) = "(Line " . getConst4 k . ")"- alg (SelectPos Col k) = "(Col " . getConst4 k . ")"- alg (LogEnter _ k) = getConst4 k- alg (LogExit _ k) = getConst4 k- alg (MetaInstr BlockCoins k) = getConst4 k- alg (MetaInstr m k) = "[" . shows m . "] " . getConst4 k+ alg Ret = "Ret"+ alg (Call μ k) = "(Call " . shows μ . " " . getConst4 k . ")"+ alg (Push x k) = "(Push " . shows x . " " . getConst4 k . ")"+ alg (Pop k) = "(Pop " . getConst4 k . ")"+ alg (Lift2 f k) = "(Lift2 " . shows f . " " . getConst4 k . ")"+ 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 . " " . 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 . " " . shows h . "}"+ alg (Join φ) = shows φ+ alg (MkJoin φ p k) = "(let " . shows φ . " = " . getConst4 p . " in " . getConst4 k . ")"+ alg (Swap k) = "(Swap " . getConst4 k . ")"+ alg (Dup k) = "(Dup " . getConst4 k . ")"+ alg (Make σ a k) = "(Make " . shows σ . " " . shows a . " " . getConst4 k . ")"+ alg (Get σ a k) = "(Get " . shows σ . " " . shows a . " " . getConst4 k . ")"+ alg (Put σ a k) = "(Put " . shows σ . " " . shows a . " " . getConst4 k . ")"+ alg (SelectPos Line k) = "(Line " . getConst4 k . ")"+ alg (SelectPos Col k) = "(Col " . getConst4 k . ")"+ alg (LogEnter _ k) = getConst4 k+ alg (LogExit _ k) = getConst4 k+ alg (MetaInstr BlockCoins{} 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"- show (RefundCoins n) = "Refund " ++ show n ++ " coins"- show (DrainCoins n) = "Using " ++ show n ++ " coins"- show (GiveBursary n) = "Bursary of " ++ show n ++ " coins"- show (PrefetchChar b) = "Prefetch character " ++ (if b then "with" else "without") ++ " length-check"- show BlockCoins = ""+ show (AddCoins n) = "Add " ++ show n ++ " coins"+ show (RefundCoins n) = "Refund " ++ show n ++ " coins"+ show (DrainCoins n) = "Using " ++ show n ++ " coins"+ show (GiveBursary n) = "Bursary of " ++ show n ++ " coins"+ show BlockCoins{} = ""
src/ghc/Parsley/Internal/Backend/Machine/LetBindings.hs view
@@ -67,13 +67,13 @@ @since 1.5.0.0 -}- successInputCharacteristic :: InputCharacteristic,+ successInputCharacteristic :: !InputCharacteristic, {- | Characterises the way that a binding consumes input on failure. @since 1.5.0.0 -}- failureInputCharacteristic :: InputCharacteristic+ failureInputCharacteristic :: !InputCharacteristic } {-|
src/ghc/Parsley/Internal/Backend/Machine/LetRecBuilder.hs view
@@ -20,9 +20,9 @@ import Language.Haskell.TH (newName, Name) import Language.Haskell.TH.Syntax (Exp(VarE, LetE), Dec(FunD), Clause(Clause), Body(NormalB)) import Parsley.Internal.Backend.Machine.LetBindings (LetBinding(..), Metadata, Binding, Regs)-import Parsley.Internal.Backend.Machine.THUtils (unsafeCodeCoerce, unTypeCode)-import Parsley.Internal.Backend.Machine.Types (QSubroutine, qSubroutine, Func)+import Parsley.Internal.Backend.Machine.Types (Func) import Parsley.Internal.Common.Utils (Code)+import Parsley.Internal.Common.THUtils (unsafeCodeCoerce, unTypeCode) import Data.Dependent.Map as DMap (DMap, (!), map, toList, traverseWithKey) @@ -32,15 +32,16 @@ @since 1.5.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) -> Metadata -> Code (Func rs s o a x))+letRec :: forall key binding s o a b. 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 (binding s o a) -> Metadata -> Code (Func rs s o a x))+ -> {-wrapBinding-} (forall x rs. Code (Func rs s o a x) -> Regs rs -> Metadata -> binding 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)+ -> {-expr-} (DMap key (binding 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 $+letRec bindings nameOf genBinding wrapBinding expr = unsafeCodeCoerce $ do -- Make a bunch of names names <- traverseWithKey (\k (LetBinding _ rs meta) -> Const . (, rs, meta) <$> newName (nameOf k)) bindings -- Wrap them up so that they are valid typed template haskell names@@ -56,5 +57,5 @@ -- Construct the let expression return (LetE decls exp) where- makeTypedName :: Const (Name, Some Regs, Metadata) x -> QSubroutine s o a x- makeTypedName (Const (name, Some frees, meta)) = qSubroutine (unsafeCodeCoerce (return (VarE name))) frees meta+ makeTypedName :: Const (Name, Some Regs, Metadata) x -> binding s o a x+ makeTypedName (Const (name, Some frees, meta)) = wrapBinding (unsafeCodeCoerce (return (VarE name))) frees meta
− src/ghc/Parsley/Internal/Backend/Machine/THUtils.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE CPP #-}-{-|-Module : Parsley.Internal.Backend.Machine.THUtils-Description : Functions for low-level template haskell manipulation-License : BSD-3-Clause-Maintainer : Jamie Willis-Stability : experimental--This module contains some Template Haskell related functions for manipulating-template haskell as a lower, combinator-based, level.--@since 1.7.0.0--}-module Parsley.Internal.Backend.Machine.THUtils (eta, unsafeCodeCoerce, unTypeCode) where--import GHC.Types (TYPE)-import Control.Arrow (first)-import Language.Haskell.TH.Syntax ( Exp(AppE, LamE, VarE), Pat(VarP, BangP, SigP)-#if __GLASGOW_HASKELL__ < 900- , Q, unTypeQ, unsafeTExpCoerce-#else- , unTypeCode, unsafeCodeCoerce-#endif- )-import Parsley.Internal.Common.Utils (Code)--{-|-Given a function (of arbitrarily many arguments, but it must at /least/ have 1), eta-reduces-it to remove redundant arguments.--@since 1.7.0.0--}-eta :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). Code (a -> b) -> Code (a -> b)-eta = unsafeCodeCoerce . fmap checkEtaMulti . unTypeCode- where- -- \ x -> f x = f- checkEta (VarP x) (AppE qf (VarE x')) | x == x' = (Nothing, qf)- -- \ (x :: t) -> f x = f- checkEta (SigP (VarP x) _) (AppE qf (VarE x')) | x == x' = (Nothing, qf)- -- \ (! x) -> f x = f- checkEta (BangP (VarP x)) (AppE qf (VarE x')) | x == x' = (Nothing, qf)- -- \ (! x :: t) -> f x = f- checkEta (BangP (SigP (VarP x) _)) (AppE qf (VarE x')) | x == x' = (Nothing, qf)- -- \ x -> body = \ x -> body- checkEta qarg qbody = (Just qarg, qbody)-- checkEtaMulti (LamE args body) = uncurry LamE $- foldr (\arg (args, body) -> first (maybe args (: args)) (checkEta arg body))- ([], body)- args- checkEtaMulti qf = qf--#if __GLASGOW_HASKELL__ < 900-unsafeCodeCoerce :: Q Exp -> Code a-unsafeCodeCoerce = unsafeTExpCoerce--unTypeCode :: Code a -> Q Exp-unTypeCode = unTypeQ-#endif
src/ghc/Parsley/Internal/Backend/Machine/Types/Coins.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingStrategies, PatternSynonyms #-} {-| Module : Parsley.Internal.Backend.Machine.Types.Coins Description : Meta-data associated with input consumption optimisations.@@ -14,12 +14,14 @@ -} module Parsley.Internal.Backend.Machine.Types.Coins ( Coins(..),- int, zero,- minCoins, maxCoins,- plus1, plus, minus,- plusNotReclaim,+ minCoins,+ plus1, minus, canReclaim,+ pattern Zero, one, items ) where +import Control.Applicative (liftA2)+import Parsley.Internal.Core.CharPred (CharPred, mergePreds)+ {-| Packages together the known input that can be consumed after a length-check with the number of characters that can be rewound on a lookahead backtrack.@@ -28,74 +30,54 @@ -} data Coins = Coins { -- | The number of tokens we know must be consumed along the path to succeed.- willConsume :: Int,- -- | The number of tokens we can reclaim if the parser backtracks.- canReclaim :: Int+ willConsume :: {-# UNPACK #-} !Int,+ willCache :: {-# UNPACK #-} !Int,+ knownPreds :: !(Maybe CharPred) } deriving stock Show -{-|-Makes a `Coins` value with equal quantities of coins and characters.--@since 1.5.0.0--}-int :: Int -> Coins-int n = Coins n n+canReclaim :: Coins -> Int+canReclaim = willConsume {-| Makes a `Coins` value of 0. @since 1.5.0.0 -}-zero :: Coins-zero = int 0+pattern Zero :: Coins+pattern Zero = Coins 0 0 Nothing -zipCoins :: (Int -> Int -> Int) -> Coins -> Coins -> Coins-zipCoins f (Coins k1 r1) (Coins k2 r2) = Coins (f k1 k2) (f r1 r2)+one :: CharPred -> Coins+one p = Coins 1 1 (Just p) -{-|-Takes the pairwise min of two `Coins` values.+items :: Int -> Coins+items n = Coins n 0 Nothing -@since 1.5.0.0--}-minCoins :: Coins -> Coins -> Coins-minCoins = zipCoins min+zipCoins :: (Int -> Int -> Int) -> (Int -> Int -> Int) -> (Maybe CharPred -> Maybe CharPred -> Maybe CharPred) -> Coins -> Coins -> Coins+zipCoins f g h (Coins k1 c1 cs1) (Coins k2 c2 cs2) = Coins k' c' cs'+ where+ k' = f k1 k2+ c' = g c1 c2+ cs' = h cs1 cs2 {-|-Takes the pairwise max of two `Coins` values.+Takes the pairwise min of two `Coins` values. @since 1.5.0.0 -}-maxCoins :: Coins -> Coins -> Coins-maxCoins = zipCoins max+minCoins :: Coins -> Coins -> Coins+minCoins = zipCoins min min (liftA2 mergePreds) {-| Adds 1 to all the `Coins` values. @since 1.5.0.0 -}-plus1 :: Coins -> Coins-plus1 = plus (Coins 1 1)+plus1 :: CharPred -> Coins -> Coins+plus1 p = zipCoins (+) (+) const (one p) {-|-Performs the pairwise addition of two `Coins` values.- @since 1.5.0.0 -}-plus :: Coins -> Coins -> Coins-plus = zipCoins (+)--{-|-Performs the pairwise subtraction of two `Coins` values.--@since 1.5.0.0--}-minus :: Coins -> Coins -> Coins-minus = zipCoins (-)--{-|-A verson of plus where the reclaim value remains constant.--@since 1.5.0.0--}-plusNotReclaim :: Coins -> Int -> Coins-plusNotReclaim (Coins k r) n = Coins (k + n) r+minus :: Coins -> Int -> Coins+minus c 0 = c+minus (Coins n c _) m = Coins (max (n - m) 0) (max (c - m) 0) Nothing
+ src/ghc/Parsley/Internal/Common/THUtils.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+{-|+Module : Parsley.Internal.Common.THUtils+Description : Functions for low-level template haskell manipulation+License : BSD-3-Clause+Maintainer : Jamie Willis+Stability : experimental++This module contains some Template Haskell related functions for manipulating+template haskell as a lower, combinator-based, level.++@since 2.3.0.0+-}+module Parsley.Internal.Common.THUtils (eta, unsafeCodeCoerce, unTypeCode) where++import Data.Generics (everything, mkQ)+import Control.Arrow (first)+import Language.Haskell.TH.Syntax ( Exp(AppE, LamE, VarE), Pat(VarP, BangP, SigP)+#if __GLASGOW_HASKELL__ < 900+ , Q, unTypeQ, unsafeTExpCoerce+#else+ , unTypeCode, unsafeCodeCoerce+#endif+ )+import Parsley.Internal.Common.Utils (Code)++{-|+Given a function (of arbitrarily many arguments, but it must at /least/ have 1), eta-reduces+it to remove redundant arguments.++@since 2.3.0.0+-}+eta :: Code a -> Code a+eta = unsafeCodeCoerce . fmap checkEtaMulti . unTypeCode+ where+ -- \ x -> x = id+ checkEta (VarP x) (VarE x') | x == x' = (Nothing, VarE 'id)+ -- \ x -> f x = f+ checkEta (VarP x) (AppE qf (VarE x')) | x == x', checkOccurrence x qf = (Nothing, qf)+ -- \ (x :: t) -> f x = f+ checkEta (SigP (VarP x) _) (AppE qf (VarE x')) | x == x', checkOccurrence x qf = (Nothing, qf)+ -- \ (! x) -> f x = f+ checkEta (BangP (VarP x)) (AppE qf (VarE x')) | x == x', checkOccurrence x qf = (Nothing, qf)+ -- \ (! x :: t) -> f x = f+ checkEta (BangP (SigP (VarP x) _)) (AppE qf (VarE x')) | x == x', checkOccurrence x qf = (Nothing, qf)+ -- \ x -> body = \ x -> body+ checkEta qarg qbody = (Just qarg, qbody)++ checkOccurrence x body = everything (&&) (mkQ True (/= x)) body++ checkEtaMulti (LamE args body) = uncurry LamE $+ foldr (\arg (args, body) -> first (maybe args (: args)) (checkEta arg body))+ ([], body)+ args+ checkEtaMulti qf = qf++#if __GLASGOW_HASKELL__ < 900+unsafeCodeCoerce :: Q Exp -> Code a+unsafeCodeCoerce = unsafeTExpCoerce++unTypeCode :: Code a -> Q Exp+unTypeCode = unTypeQ+#endif
src/ghc/Parsley/Internal/Common/Utils.hs view
@@ -110,7 +110,7 @@ newtype Id a = Id {unId :: a -> a} instance Semigroup (Id a) where f <> g = Id $ unId f . unId g-instance Monoid (Id a) where mempty = Id $ id+instance Monoid (Id a) where mempty = Id id intercalateDiff :: (a -> a) -> [a -> a] -> a -> a intercalateDiff sep xs = unId $ intercalate (Id sep) (map Id xs)
src/ghc/Parsley/Internal/Core/CharPred.hs view
@@ -13,15 +13,15 @@ -} module Parsley.Internal.Core.CharPred ( CharPred(..), pattern Item, pattern Specific,- apply, andPred, orPred, diffPred, optimisePredGiven,+ apply, andPred, orPred, diffPred, optimisePredGiven, mergePreds, members, nonMembers, lamTerm ) where import Prelude hiding (null) -import Data.RangeSet (RangeSet, elems, unelems, fromRanges, full, member, fold, null, union, extractSingle, singleton, intersection, difference, isSubsetOf, sizeRanges)-import Parsley.Internal.Core.Lam (Lam(Abs, App, Var, T, F, If))+import Data.RangeSet (RangeSet, elems, unelems, fromRanges, full, member, fold, null, union, extractSingle, singleton, intersection, difference, isSubsetOf, sizeRanges, complement)+import Parsley.Internal.Core.Lam (Lam(Abs, App, Var, T, F, If), andLam, notLam, orLam) {-| Represents @Char -> Bool@ functions, potentially in a more inspectable way.@@ -100,6 +100,12 @@ inter = intersection given pred optimisePredGiven p _ = p +mergePreds :: CharPred -> CharPred -> CharPred+mergePreds (Ranges p1) (Ranges p2)+ | isSubsetOf p1 p2 = Ranges p2+ | isSubsetOf p2 p1 = Ranges p1+mergePreds _ _ = Item+ {-| Merges two predicates by creating one which only returns true when a character is in either of the original predicates.@@ -150,6 +156,7 @@ lamTerm (UserPred _ t) = t lamTerm Item = Abs (const T) lamTerm (Ranges (null -> True)) = Abs (const F)+lamTerm (Ranges (extractSingle . complement -> Just c)) = App (Var True [||(/=)||]) (Var True [||c||]) lamTerm (Ranges rngs) = Abs $ \c -> fold (conv c) F rngs@@ -157,46 +164,23 @@ conv c l u lb rb -- | l == u = eq c (Var True [||l||]) `or` (lb `or` rb) -- | otherwise = (lte (Var True [||l||]) c `and` lte c (Var True [||u||])) `or` (lb `or` rb)- | l == u = eq c (Var True [||l||]) `or` if' (lt c (Var True [||l||])) lb rb+ | l == u = eq c (Var True [||l||]) `or` If (lt c (Var True [||l||])) lb rb -- the left can be omitted here | l == minBound = lte c (Var True [||u||]) `or` rb -- the right can be omitted here | u == maxBound = lte (Var True [||l||]) c `or` lb- | otherwise = if' (lte (Var True [||l||]) c) (lte c (Var True [||u||]) `or` rb) lb+ | otherwise = If (lte (Var True [||l||]) c) (lte c (Var True [||u||]) `or` rb) lb or = orLam- and = andLam lte :: Lam Char -> Lam Char -> Lam Bool lte = App . App (Var True [||(<=)||]) lt :: Lam Char -> Lam Char -> Lam Bool lt = App . App (Var True [||(<)||]) eq :: Lam Char -> Lam Char -> Lam Bool eq = App . App (Var True [||(==)||])- if' x y F = and x y- if' c x y = If c x y instance Show CharPred where show (UserPred _ f) = show f show Item = "const True" show (Specific c) = concat ["(== ", show c, ")"] show (Ranges rngs) = "elem " ++ show rngs---andLam :: Lam Bool -> Lam Bool -> Lam Bool-andLam T y = y-andLam x T = x-andLam F _ = F-andLam _ F = F-andLam x y = App (App (Var True [||(&&)||]) x) y--orLam :: Lam Bool -> Lam Bool -> Lam Bool-orLam T _ = T-orLam _ T = T-orLam F y = y-orLam y F = y-orLam x y = App (App (Var True [||(||)||]) x) y--notLam :: Lam Bool -> Lam Bool-notLam T = F-notLam F = T-notLam x = App (Var True [||not||]) x
src/ghc/Parsley/Internal/Core/CombinatorAST.hs view
@@ -25,7 +25,7 @@ Empty :: Combinator k a Try :: k a -> Combinator k a LookAhead :: k a -> Combinator k a- Let :: Bool -> MVar a -> Combinator k a+ Let :: MVar a -> Combinator k a NotFollowedBy :: k a -> Combinator k () Branch :: k (Either a b) -> k (a -> c) -> k (b -> c) -> Combinator k c Match :: k a -> [Defunc (a -> Bool)] -> [k b] -> k b -> Combinator k b@@ -56,12 +56,6 @@ data MetaCombinator where -- | After this combinator exits, a cut has happened Cut :: MetaCombinator- -- | This combinator requires a cut from below to respect parsec semantics- RequiresCut :: MetaCombinator- -- | This combinator denotes that within its scope, cut semantics are not enforced- --- -- @since 1.6.0.0- CutImmune :: MetaCombinator -- Instances instance IFunctor Combinator where@@ -74,7 +68,7 @@ imap _ Empty = Empty imap f (Try p) = Try (f p) imap f (LookAhead p) = LookAhead (f p)- imap _ (Let r v) = Let r v+ imap _ (Let v) = Let v imap f (NotFollowedBy p) = NotFollowedBy (f p) imap f (Branch b p q) = Branch (f b) (f p) (f q) imap f (Match p fs qs d) = Match (f p) fs (map f qs) (f d)@@ -98,8 +92,7 @@ alg Empty = "empty" alg (Try (Const1 p)) = "try (". p . ")" alg (LookAhead (Const1 p)) = "lookAhead (" . p . ")"- alg (Let False v) = "let-bound " . shows v- alg (Let True v) = "rec " . shows v+ alg (Let v) = "let-bound " . shows v alg (NotFollowedBy (Const1 p)) = "notFollowedBy (" . p . ")" alg (Branch (Const1 b) (Const1 p) (Const1 q)) = "branch (" . b . ") (" . p . ") (" . q . ")" alg (Match (Const1 p) fs qs (Const1 def)) = "match (" . p . ") " . shows fs . " [" . intercalateDiff ", " (map getConst1 qs) . "] (" . def . ")"@@ -116,9 +109,7 @@ imap f (ScopeRegister p g) = ScopeRegister (f p) (f . g) instance Show MetaCombinator where- show Cut = "coins after"- show RequiresCut = "requires cut"- show CutImmune = "immune to cuts"+ show Cut = "cut point" {-# INLINE traverseCombinator #-} traverseCombinator :: Applicative m => (forall a. f a -> m (k a)) -> Combinator f a -> m (Combinator k a)@@ -140,5 +131,5 @@ traverseCombinator expose (Debug name p) = Debug name <$> expose p traverseCombinator _ (Pure x) = pure (Pure x) traverseCombinator _ (Satisfy f) = pure (Satisfy f)-traverseCombinator _ (Let r v) = pure (Let r v)+traverseCombinator _ (Let v) = pure (Let v) traverseCombinator expose (MetaCombinator m p) = MetaCombinator m <$> expose p
src/ghc/Parsley/Internal/Core/Defunc.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSynonyms, TypeApplications #-}+{-# LANGUAGE ImplicitParams, PatternSynonyms, TypeApplications #-} {-| Module : Parsley.Internal.Core.Defunc Description : Combinator-level defunctionalisation@@ -25,6 +25,7 @@ import Parsley.Internal.Core.Lam (normaliseGen, Lam(..)) import qualified Parsley.Internal.Core.CharPred as CharPred (lamTerm)+import qualified Parsley.Internal.Opt as Opt (Flags(termNormalisation), none) {-| This datatype is useful for providing an /inspectable/ representation of common Haskell functions.@@ -112,7 +113,7 @@ _val (LET_S x f) = let y = _val x in _val (f (makeQ y undefined)) _val (RANGES True rngs) = \c -> any (\(l, u) -> l <= c || c <= u) rngs _val (RANGES False rngs) = \c -> all (\(l, u) -> l >= c || c >= u) rngs- _code = normaliseGen . lamTerm+ _code = let ?flags = Opt.none { Opt.termNormalisation = True } in normaliseGen . lamTerm (>*<) = APP_H {-|
src/ghc/Parsley/Internal/Core/Identifiers.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wno-incomplete-patterns #-}-{-# LANGUAGE DerivingStrategies,- GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies, GeneralisedNewtypeDeriving #-} {-| Module : Parsley.Internal.Backend.Machine.Identifiers Description : frontend specific identifiers.
src/ghc/Parsley/Internal/Core/InputTypes.hs view
@@ -21,6 +21,7 @@ @since 0.1.0.0 -}+{-# DEPRECATED Text16 "Text16 is not legal with the UTF-8 encoding of Text, use Text instead" #-} newtype Text16 = Text16 Text --newtype CacheText = CacheText Text@@ -31,6 +32,7 @@ @since 0.1.0.0 -}+{-# DEPRECATED CharList "CharList is no longer necessary, use String directly instead" #-} newtype CharList = CharList String {-|
src/ghc/Parsley/Internal/Core/Lam.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImplicitParams #-} {-| Module : Parsley.Internal.Core.Lam Description : Generic defunctionalised abstraction.@@ -13,10 +14,13 @@ @since 1.0.1.0 -}-module Parsley.Internal.Core.Lam (normaliseGen, normalise, Lam(..)) where+module Parsley.Internal.Core.Lam (normaliseGen, normalise, Lam(..), andLam, orLam, notLam) where -import Parsley.Internal.Common.Utils (Code)+import Parsley.Internal.Common.Utils (Code)+import Parsley.Internal.Common.THUtils (eta) +import qualified Parsley.Internal.Opt as Opt+ {-| Defunctionalised lambda calculus in HOAS form. Supports basic inspection of values, but not functions.@@ -39,29 +43,37 @@ -- | Value representing false. F :: Lam Bool +andLam :: Lam Bool -> Lam Bool -> Lam Bool+andLam x y = If x y F++orLam :: Lam Bool -> Lam Bool -> Lam Bool+orLam x = If x T++notLam :: Lam Bool -> Lam Bool+notLam x = If x F T+ {-| Optimises a `Lam` expression, reducing it until the outmost lambda, let, or if statement. @since 1.0.1.0 -}-normalise :: Lam a -> Lam a-normalise x = if normal x then x else reduce x+normalise :: (?flags :: Opt.Flags) => Lam a -> Lam a+normalise x = if normal x || not (Opt.termNormalisation ?flags) then x else reduce x where reduce :: Lam a -> Lam a- reduce (App (Abs f) x) = case f x of- x | normal x -> x- x -> reduce x+ reduce (App (Abs f) x) = normalise (f x) reduce (App f x) = case reduce f of- f@(Abs _) -> reduce (App f x)- f -> App f x- reduce (If c x y) = case reduce c of- T -> x- F -> y- c -> If c x y+ f@Abs{} -> reduce (App f x)+ f -> App f x+ reduce (If T t _) = normalise t+ reduce (If F _ f) = normalise f+ reduce (If _ T T) = T+ reduce (If _ F F) = F+ reduce (If c T F) = normalise c+ -- one of them must be not in normal form+ reduce (If c t f) = normalise (If (normalise c) (normalise t) (normalise f)) -- Reduction rule found courtesy of David Davies, forever immortalised- reduce (Let v@(Var True _) f) = case f v of- x | normal x -> x- x -> reduce x+ reduce (Let v@(Var True _) f) = normalise (f v) reduce x = x normal :: Lam a -> Bool@@ -69,20 +81,26 @@ normal (App f _) = normal f normal (If T _ _) = False normal (If F _ _) = False- normal (If x _ _) = normal x+ normal (If _ T T) = False+ normal (If _ F F) = False+ normal (If _ T F) = False+ normal (If c t f) = normal c && normal t && normal f normal (Let (Var True _) _) = False normal _ = True -generate :: Lam a -> Code a-generate (Abs f) = [||\x -> $$(normaliseGen (f (Var True [||x||])))||]+generate :: (?flags :: Opt.Flags) => Lam a -> Code a+generate (Abs f) = [|| \x -> $$(normaliseGen (f (Var True [||x||]))) ||] -- f has already been reduced, since we only expose `normaliseGen`-generate (App f x) = [||$$(generate f) $$(normaliseGen x)||]+generate (App f x) = [|| $$(generate f) $$(normaliseGen x) ||] generate (Var _ x) = x--- c has already been reduced, since we only expose `normaliseGen`-generate (If c t e) = [||if $$(generate c) then $$(normaliseGen t) else $$(normaliseGen e)||]-generate (Let b i) = [||let x = $$(normaliseGen b) in $$(normaliseGen (i (Var True [||x||])))||]-generate T = [||True||]-generate F = [||False||]+-- all parts are reduced+generate (If c T e) = [|| $$(generate c) || $$(generate e) ||]+generate (If c t F) = [|| $$(generate c) && $$(generate t) ||]+generate (If c F T) = [|| not $$(generate c) ||]+generate (If c t e) = [|| if $$(generate c) then $$(generate t) else $$(generate e) ||]+generate (Let b i) = [|| let x = $$(normaliseGen b) in $$(normaliseGen (i (Var True [||x||]))) ||]+generate T = [|| True ||]+generate F = [|| False ||] {-| Generates Haskell code that represents a `Lam` value, but normalising it first to ensure the@@ -90,11 +108,11 @@ @since 1.0.1.0 -}-normaliseGen :: Lam a -> Code a-normaliseGen = generate . normalise+normaliseGen :: (?flags :: Opt.Flags) => Lam a -> Code a+normaliseGen = eta . generate . normalise instance Show (Lam a) where- show = show' . normalise+ show = let ?flags = Opt.none { Opt.termNormalisation = True } in show' . normalise show' :: Lam a -> String show' (Abs f) = concat ["(\\x -> ", show (f (Var True undefined)), ")"]
src/ghc/Parsley/Internal/Frontend/Analysis/Cut.hs view
@@ -15,10 +15,11 @@ -} module Parsley.Internal.Frontend.Analysis.Cut (cutAnalysis) where -import Data.Coerce (coerce)-import Data.Kind (Type)-import Parsley.Internal.Common.Indexed (Fix(..), zygo, (:*:)(..), ifst)+import Parsley.Internal.Common.Indexed (Fix(..), zygo, (:*:)(..)) import Parsley.Internal.Core.CombinatorAST (Combinator(..), MetaCombinator(..))+import Data.Bifunctor (first)+import Data.Coerce (coerce)+import Data.Kind (Type) {-| Annotate a tree with its cut-points. We assume a cut for let-bound parsers.@@ -26,121 +27,124 @@ @since 1.5.0.0 -} cutAnalysis :: Fix Combinator a -> Fix Combinator a-cutAnalysis = fst . ($ True) . doCut . zygo (CutAnalysis . cutAlg) compliance+cutAnalysis = fst . ($ False) . doCut . zygo (CutAnalysis . cutAlg) guardednessAlg -data Compliance (k :: Type) = DomComp | NonComp | Comp | FullPure deriving stock (Show, Eq) newtype CutAnalysis a = CutAnalysis { doCut :: Bool -> (Fix Combinator a, Bool) }+-- TODO: UnguardedEffects should track a set of registers+data Guardedness (a :: Type) = Guarded | UnguardedEffect | NoEffect deriving stock Eq -seqCompliance :: Compliance a -> Compliance b -> Compliance c-seqCompliance c FullPure = coerce c-seqCompliance FullPure c = coerce c-seqCompliance Comp _ = Comp-seqCompliance _ _ = NonComp+guardednessAlg :: Combinator Guardedness a -> Guardedness a+guardednessAlg Pure{} = NoEffect+guardednessAlg Satisfy{} = Guarded+guardednessAlg Empty = NoEffect+-- We don't know anything about the binding, so must assume the worst (TODO: could just raise for free-regs)+guardednessAlg Let{} = UnguardedEffect+guardednessAlg (Try p) = p+guardednessAlg (p :<|>: q) = altGuardedness p q+guardednessAlg (l :<*>: r) = seqGuardedness l r+guardednessAlg (l :<*: r) = seqGuardedness l r+guardednessAlg (l :*>: r) = seqGuardedness l r+-- lookahead rolls back input and so is not a reliable guard, but it can be unguarded+guardednessAlg (LookAhead UnguardedEffect) = UnguardedEffect+guardednessAlg LookAhead{} = NoEffect+guardednessAlg (NotFollowedBy UnguardedEffect) = UnguardedEffect+guardednessAlg NotFollowedBy{} = NoEffect+guardednessAlg (Debug _ p) = p+guardednessAlg (Loop UnguardedEffect _) = UnguardedEffect+guardednessAlg (Loop _ exit) = exit+guardednessAlg (Branch b p q) = seqGuardedness b (altGuardedness p q)+guardednessAlg (Match p _ qs def) = seqGuardedness p (foldr altGuardedness def qs)+-- TODO: removes unguardedness of corresponding register in r+guardednessAlg (MakeRegister _ l r) = seqGuardedness l r+guardednessAlg GetRegister{} = NoEffect+guardednessAlg PutRegister{} = UnguardedEffect+guardednessAlg Position{} = NoEffect+guardednessAlg (MetaCombinator _ p) = p -caseCompliance :: Compliance a -> Compliance b -> Compliance c-caseCompliance c FullPure = coerce c-caseCompliance FullPure c = coerce c-caseCompliance c1 c2 | c1 == coerce c2 = coerce c1-caseCompliance _ _ = NonComp+seqGuardedness :: Guardedness a -> Guardedness b -> Guardedness c+seqGuardedness Guarded _ = Guarded+seqGuardedness UnguardedEffect _ = UnguardedEffect+seqGuardedness NoEffect guardedness = coerce guardedness -{-# INLINE compliance #-}-compliance :: Combinator Compliance a -> Compliance a-compliance (Pure _) = FullPure-compliance (Satisfy _) = NonComp-compliance Empty = FullPure-compliance Let{} = DomComp-compliance (Try _) = DomComp-compliance (NonComp :<|>: FullPure) = Comp-compliance (_ :<|>: _) = NonComp-compliance (l :<*>: r) = seqCompliance l r-compliance (l :<*: r) = seqCompliance l r-compliance (l :*>: r) = seqCompliance l r-compliance (LookAhead c) = c -- Lookahead will consume input on failure, so its compliance matches that which is beneath it-compliance (NotFollowedBy _) = FullPure-compliance (Debug _ c) = c-compliance (Loop NonComp exit) = seqCompliance Comp exit-compliance (Loop _ exit) = seqCompliance NonComp exit-compliance (Branch b p q) = seqCompliance b (caseCompliance p q)-compliance (Match p _ qs def) = seqCompliance p (foldr1 caseCompliance (def:qs))-compliance (MakeRegister _ l r) = seqCompliance l r-compliance (GetRegister _) = FullPure-compliance (Position _) = FullPure-compliance (PutRegister _ c) = coerce c-compliance (MetaCombinator _ c) = c+-- Unguarded effects conservatively dominate, otherwise both must be guarded to be guarded+altGuardedness :: Guardedness a -> Guardedness b -> Guardedness c+altGuardedness Guarded Guarded = Guarded+altGuardedness UnguardedEffect _ = UnguardedEffect+altGuardedness _ UnguardedEffect = UnguardedEffect+altGuardedness _ _ = NoEffect -cutAlg :: Combinator (CutAnalysis :*: Compliance) a -> Bool -> (Fix Combinator a, Bool)+cutAlg :: Combinator (CutAnalysis :*: Guardedness) a -> Bool -> (Fix Combinator a, Bool) cutAlg (Pure x) _ = (In (Pure x), False)-cutAlg (Satisfy f) cut = (mkCut cut (In (Satisfy f)), True)+-- if a cut is required, a `Satsify` is responsible for providing it but otherwise always handles+-- the cut: this is useful for allowing a `Try` to deal with a cut+cutAlg (Satisfy f) backtracks = (mkCut (not backtracks) (In (Satisfy f)), True) cutAlg Empty _ = (In Empty, False)-cutAlg (Let r μ) cut = (mkCut (not cut) (In (Let r μ)), False) -- If there is no cut, we generate a piggy for the continuation-cutAlg (Try p) cut = (In (Try (mkImmune cut (fst (doCut (ifst p) False)))), False)--- Special case of below, but we know immunity is useless within `q`-cutAlg ((p :*: NonComp) :<|>: (q :*: FullPure)) _ = (requiresCut (In (fst (doCut p True) :<|>: fst (doCut q False))), False)--- both branches have to handle a cut, if `p` fails having consumed input that satisfies a cut--- but if it doesn't, then `q` will need to handle the cut instead. When `q` has no cut to handle,--- then that means it is immune to cuts, which is handy!-cutAlg ((p :*: NonComp) :<|>: q) cut =- let (p', handled) = doCut p True- (q', handled') = doCut (ifst q) cut- in (requiresCut (In (p' :<|>: mkImmune (not cut) q')), handled && handled')--- Why cut in both branches? Good question--- The point here is that, even though `p` doesn't require a cut, this will enable an immunity--- allowing for internal factoring of input. However, if we are not under a cut requirement, we'd--- like this input to be factored out further.-cutAlg (p :<|>: q) cut =- let (p', handled) = doCut (ifst p) cut- (q', handled') = doCut (ifst q) cut- in (In (p' :<|>: q'), handled && handled')-cutAlg (l :<*>: r) cut = seqCutAlg (:<*>:) cut (ifst l) (ifst r)-cutAlg (l :<*: r) cut = seqCutAlg (:<*:) cut (ifst l) (ifst r)-cutAlg (l :*>: r) cut = seqCutAlg (:*>:) cut (ifst l) (ifst r)-cutAlg (LookAhead p) cut = rewrap LookAhead cut (ifst p)-cutAlg (NotFollowedBy p) _ = False <$ rewrap NotFollowedBy False (ifst p)-cutAlg (Debug msg p) cut = rewrap (Debug msg) cut (ifst p)-cutAlg (Loop (body :*: NonComp) exit) _ =- let (body', _) = doCut body True- (exit', handled) = doCut (ifst exit) False- -- the loop could terminate having read no `body`s, so only `exit` can decide if its handled.- in (requiresCut (In (Loop body' exit')), handled)-cutAlg (Loop body exit) cut =- let (body', _) = doCut (ifst body) False- (exit', handled) = doCut (ifst exit) cut- in (mkCut (not cut) (In (Loop body' exit')), handled)-cutAlg (Branch b p q) cut =- let (b', handled) = doCut (ifst b) cut- (p', handled') = doCut (ifst p) (cut && not handled)- (q', handled'') = doCut (ifst q) (cut && not handled)- in (In (Branch b' p' q'), handled || (handled' && handled''))-cutAlg (Match p f qs def) cut =- let (p', handled) = doCut (ifst p) cut- (def', handled') = doCut (ifst def) (cut && not handled)- (qs', handled'') = foldr (\q -> biliftA2 (:) (&&) (doCut (ifst q) (cut && not handled))) ([], handled') qs- in (In (Match p' f qs' def'), handled || handled'')-cutAlg (MakeRegister σ l r) cut = seqCutAlg (MakeRegister σ) cut (ifst l) (ifst r)+-- all bindings must assume no backtracking, but bindings may be entirely pure+-- this means they cannot satisfy a cut themselves: basically they behave like option(item)+-- analysis could be done to prevent this though!+cutAlg (Let μ) _ = (In (Let μ), False)+-- obviously does not demand cuts for its children, however success of p may cause a cut+-- for the whole try - just as long as `p` itself cuts+cutAlg (Try (p :*: _)) backtracks =+ let (p', cuts) = doCut p True+ in (mkCut (cuts && not backtracks) (In (Try p')), cuts)+-- cannot pass `backtracks` directly to `p` because it prevents a cut being issued on the <|>+-- this has an effect if it causes an illegal backtrack that is effectful:+-- put r0 False *> try (string("abc") <|> put r0 True) <|> get+-- the problem is with non-consuming right branches: if the right branch+-- is guaranteed to consume input, then there will be a shared input factored+-- out, even if it is just one -- this means that the first input read of+-- the <|> is guarded: even if there is internal factoring, it cannot backtrack+-- to the right branch if it didn't enter the branch to begin with or didn't discharge+-- the length-check (by failing on the free read). (we are talking about factoring solely on the p here fyi)+--+-- So, how to fix? well, only allowing this if the right-hand branch is guarded by input consumption that we know will be factored+cutAlg ((p :*: _) :<|>: (q :*: guardedness)) backtracks =+ let (p', pcuts) = doCut p (backtracks && guardedness == Guarded)+ (q', qcuts) = doCut q backtracks+ in (In (p' :<|>: q'), pcuts && qcuts)+cutAlg ((l :*: _) :<*>: (r :*: _)) backtracks = seqCutAlg (:<*>:) backtracks l r+cutAlg ((l :*: _) :<*: (r :*: _)) backtracks = seqCutAlg (:<*:) backtracks l r+cutAlg ((l :*: _) :*>: (r :*: _)) backtracks = seqCutAlg (:*>:) backtracks l r+-- it may seems like a lookahead gaurantees the existence of some input, so can satisfy a cut+-- but this is not the case, because the consumed cutting character is rolled back: this means+-- the cut is only guaranteed to occur for a weaker predicate in whatever follows+cutAlg (LookAhead (p :*: _)) backtracks = False <$ rewrap LookAhead backtracks p+-- this can never satisfy a cut, because its unknown how or if it does so+cutAlg (NotFollowedBy (p :*: _)) _ = False <$ rewrap NotFollowedBy True p+cutAlg (Debug msg (p :*: _)) backtracks = rewrap (Debug msg) backtracks p+cutAlg (Loop (body :*: _) (exit :*: _)) backtracks =+ -- cannot pull same trick with guardedness, because input cannot factor out of a loop!+ let (body', _) = doCut body False+ in rewrap (Loop body') backtracks exit+cutAlg (Branch (b :*: _) (p :*: _) (q :*: _)) backtracks =+ let (b', bcuts) = doCut b backtracks+ (p', pcuts) = doCut p (backtracks || bcuts)+ (q', qcuts) = doCut q (backtracks || bcuts)+ in (In (Branch b' p' q'), bcuts || (pcuts && qcuts))+cutAlg (Match (p :*: _) f qs (def :*: _)) backtracks =+ let (p', pcuts) = doCut p backtracks+ (def', defcuts) = doCut def (backtracks || pcuts)+ (qs', allcut) = foldr (\(q :*: _) -> biliftA2 (:) (&&) (doCut q (backtracks || pcuts))) ([], defcuts) qs+ in (In (Match p' f qs' def'), pcuts || allcut)+cutAlg (MakeRegister σ (l :*: _) (r :*: _)) backtracks = seqCutAlg (MakeRegister σ) backtracks l r cutAlg (GetRegister σ) _ = (In (GetRegister σ), False)-cutAlg (PutRegister σ p) cut = rewrap (PutRegister σ) cut (ifst p)+cutAlg (PutRegister σ (p :*: _)) backtracks = rewrap (PutRegister σ) backtracks p cutAlg (Position sel) _ = (In (Position sel), False)-cutAlg (MetaCombinator m p) cut = rewrap (MetaCombinator m) cut (ifst p)+cutAlg (MetaCombinator m (p :*: _)) backtracks = rewrap (MetaCombinator m) backtracks p +seqCutAlg :: (Fix Combinator a -> Fix Combinator b -> Combinator (Fix Combinator) c) -> Bool -> CutAnalysis a -> CutAnalysis b -> (Fix Combinator c, Bool)+seqCutAlg con backtracks l r =+ let (l', lcuts) = doCut l backtracks+ (r', rcuts) = doCut r (backtracks || lcuts)+ in (In (con l' r'), lcuts || rcuts)+ mkCut :: Bool -> Fix Combinator a -> Fix Combinator a mkCut True = In . MetaCombinator Cut mkCut False = id -mkImmune :: Bool -> Fix Combinator a -> Fix Combinator a-mkImmune True = In . MetaCombinator CutImmune-mkImmune False = id--requiresCut :: Fix Combinator a -> Fix Combinator a-requiresCut = In . MetaCombinator RequiresCut--seqCutAlg :: (Fix Combinator a -> Fix Combinator b -> Combinator (Fix Combinator) c) -> Bool -> CutAnalysis a -> CutAnalysis b -> (Fix Combinator c, Bool)-seqCutAlg con cut l r =- let (l', handled) = doCut l cut- (r', handled') = doCut r (cut && not handled)- in (In (con l' r'), handled || handled')- rewrap :: (Fix Combinator a -> Combinator (Fix Combinator) b) -> Bool -> CutAnalysis a -> (Fix Combinator b, Bool)-rewrap con cut p = let (p', handled) = doCut p cut in (In (con p'), handled)+rewrap con backtracks p = first (In . con) (doCut p backtracks) biliftA2 :: (a -> b -> c) -> (x -> y -> z) -> (a, x) -> (b, y) -> (c, z) biliftA2 f g (x1, y1) (x2, y2) = (f x1 x2, g y1 y2)
src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs view
@@ -164,9 +164,9 @@ {-# INLINE dependenciesAlg #-} dependenciesAlg :: Maybe IMVar -> Combinator Dependencies a -> Dependencies a-dependenciesAlg (Just v) (Let _ μ@(MVar u)) = Dependencies $ do unless (u == v) (dependsOn μ)-dependenciesAlg Nothing (Let _ μ) = Dependencies $ do dependsOn μ-dependenciesAlg _ p = Dependencies $ do traverseCombinator (fmap Const1 . doDependencies) p; return ()+dependenciesAlg (Just v) (Let μ@(MVar u)) = Dependencies $ do unless (u == v) (dependsOn μ)+dependenciesAlg Nothing (Let μ) = Dependencies $ do dependsOn μ+dependenciesAlg _ p = Dependencies $ do traverseCombinator (fmap Const1 . doDependencies) p; return () dependsOn :: MonadState (Set IMVar) m => MVar a -> m () dependsOn (MVar v) = modify' (Set.insert v)
src/ghc/Parsley/Internal/Frontend/Analysis/Inliner.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ImplicitParams #-} {-| Module : Parsley.Internal.Frontend.Analysis.Inliner Description : Decides whether to inline a let-bound parser.@@ -16,42 +17,53 @@ import Parsley.Internal.Core.CombinatorAST (Combinator(..)) import Parsley.Internal.Core.Identifiers (MVar) -inlineThreshold :: Rational-inlineThreshold = 13 % 10+import qualified Parsley.Internal.Opt as Opt {-| Annotate a tree with its cut-points. We assume a cut for let-bound parsers. @since 1.7.0.0 -}-inliner :: Bool -> MVar a -> Fix Combinator a -> Fix Combinator a-inliner recu _ body | not recu, shouldInline body = body-inliner recu μ _ = In (Let recu μ)+inliner :: (?flags :: Opt.Flags) => Maybe Int -> MVar a -> Fix Combinator a -> Fix Combinator a+inliner occs _ body+ | Just n <- occs+ , Just thresh <- Opt.primaryInlineThreshold ?flags+ , shouldInline n thresh body = body+inliner _ μ _ = In (Let μ) -shouldInline :: Fix Combinator a -> Bool-shouldInline = (< inlineThreshold) . getWeight . cata (InlineWeight . alg)+shouldInline :: Int -> Rational -> Fix Combinator a -> Bool+shouldInline occs inlineThreshold = (<= inlineThreshold) . (* toRational occs) . subtract callCost . getWeight . cata (InlineWeight . alg) newtype InlineWeight a = InlineWeight { getWeight :: Rational } +callCost :: Rational+callCost = 1 % 3++handlerCost :: Rational+handlerCost = 1 % 4++registerCost :: Rational+registerCost = 1 % 3+ -- Ideally these should mirror those in the backend inliner, how can we unify them? alg :: Combinator InlineWeight a -> Rational alg (Pure _) = 0 alg (Satisfy _) = 1 alg Empty = 0-alg Let{} = 2 % 3+alg Let{} = callCost alg (Try p) = getWeight p-alg (l :<|>: r) = 1 % 4 + 2 % 5 + getWeight l + getWeight r+alg (l :<|>: r) = handlerCost + 1 % 5 + getWeight l + getWeight r alg (l :<*>: r) = 1 % 5 + getWeight l + getWeight r alg (l :<*: r) = getWeight l + getWeight r alg (l :*>: r) = getWeight l + getWeight r alg (LookAhead c) = getWeight c-alg (NotFollowedBy p) = 1 % 4 + getWeight p-alg (Debug _ c) = 2 % 4 + getWeight c-alg (Loop body exit) = 2 % 3 + getWeight body + getWeight exit+alg (NotFollowedBy p) = handlerCost + getWeight p+alg (Debug _ c) = getWeight c+alg (Loop body exit) = handlerCost + callCost + 2 % 3 + getWeight body + getWeight exit alg (Branch b p q) = 1 % 3 + 2 % 5 + getWeight b + getWeight p + getWeight q alg (Match p _ qs def) = fromIntegral (length qs + 1) % 3 + sum (map getWeight qs) + getWeight def + getWeight p-alg (MakeRegister _ l r) = 1 % 3 + getWeight l + getWeight r-alg (GetRegister _) = 1 % 3-alg (PutRegister _ c) = 1 % 3 + getWeight c+alg (MakeRegister _ l r) = registerCost + getWeight l + getWeight r+alg (GetRegister _) = registerCost+alg (PutRegister _ c) = registerCost + getWeight c alg (Position _) = 1 % 5 alg (MetaCombinator _ c) = getWeight c
src/ghc/Parsley/Internal/Frontend/Compiler.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-hpc #-} {-# LANGUAGE AllowAmbiguousTypes,+ ImplicitParams, MagicHash, MultiParamTypeClasses, UndecidableInstances #-}@@ -26,7 +27,7 @@ import Data.Kind (Type) import Data.Set (Set) import Control.Arrow (first, second)-import Control.Monad (void, when)+import Control.Monad (void, when, guard) import Control.Monad.Reader (ReaderT, runReaderT, local, ask, MonadReader) import GHC.Exts (Int(..), unsafeCoerce#) import GHC.Prim (StableName#)@@ -42,11 +43,12 @@ import Parsley.Internal.Trace (Trace(trace)) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Dependent.Map as DMap ((!), empty, insert, mapWithKey, size)-import qualified Data.HashMap.Strict as HashMap (lookup, insert, empty, insertWith, foldrWithKey, (!))-import qualified Data.HashSet as HashSet (member, insert, empty)-import qualified Data.Map as Map ((!))-import qualified Data.Set as Set (empty)+import qualified Data.Dependent.Map as DMap ((!), empty, insert, mapWithKey, size)+import qualified Data.HashMap.Strict as HashMap (member, lookup, insert, empty, insertWith, (!), filter)+import qualified Data.HashSet as HashSet (member, insert, empty)+import qualified Data.Map as Map ((!))+import qualified Data.Set as Set (empty)+import qualified Parsley.Internal.Opt as Opt {-| Given a user's parser, this will analyse it, extract bindings and then compile them with a given function@@ -56,7 +58,7 @@ @since 1.0.0.0 -} {-# INLINEABLE compile #-}-compile :: forall compiled a. Trace+compile :: forall compiled a. (Trace, ?flags :: Opt.Flags) => Parser a -- ^ The parser to compile. -> (forall x. Maybe (MVar x) -> Fix Combinator x -> Set SomeΣVar -> IMVar -> 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.@@ -71,7 +73,7 @@ codeGen' :: Maybe (MVar x) -> Fix Combinator x -> compiled x codeGen' letBound p = codeGen letBound (analyse emptyFlags p) (freeRegs letBound) (maxV + 1) -preprocess :: Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)+preprocess :: (?flags :: Opt.Flags) => Fix (Combinator :+: ScopeRegister) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar) preprocess p = let q = tagParser p (lets, recs) = findLets q@@ -94,13 +96,13 @@ type LetFinderCtx = HashSet ParserName newtype LetFinder a = LetFinder { doLetFinder :: ReaderT LetFinderCtx (State LetFinderState) () } -findLets :: Fix (Tag ParserName Combinator) a -> (HashSet ParserName, HashSet ParserName)+findLets :: Fix (Tag ParserName Combinator) a -> (HashMap ParserName Int, HashSet ParserName) findLets p = (lets, recs) where state = LetFinderState HashMap.empty HashSet.empty ctx = HashSet.empty LetFinderState preds recs = execState (runReaderT (doLetFinder (cata findLetsAlg p)) ctx) state- lets = HashMap.foldrWithKey (\k n ls -> if n > 1 then HashSet.insert k ls else ls) HashSet.empty preds+ lets = HashMap.filter (> 1) preds findLetsAlg :: Tag ParserName Combinator LetFinder a -> LetFinder a findLetsAlg p = LetFinder $ do@@ -118,7 +120,7 @@ , DMap MVar (Fix Combinator))) (Fix Combinator a) }-letInsertion :: HashSet ParserName -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar)+letInsertion :: (?flags :: Opt.Flags) => HashMap ParserName Int -> HashSet ParserName -> Fix (Tag ParserName Combinator) a -> (Fix Combinator a, DMap MVar (Fix Combinator), IMVar) letInsertion lets recs p = (p', μs, μMax) where m = cata alg p@@ -128,20 +130,21 @@ let name = tag p let q = tagged p (vs, μs) <- get- let bound = HashSet.member name lets+ let bound = HashMap.member name lets let recu = HashSet.member name recs+ let occs = guard (not recu) *> HashMap.lookup name lets if bound || recu then case HashMap.lookup name vs of- Just v -> let μ = MVar v in return $! inliner recu μ (μs DMap.! μ)+ Just v -> let μ = MVar v in return $! inliner occs μ (μs DMap.! μ) Nothing -> do v <- newVar let μ = MVar v modify' (first (HashMap.insert name v)) q' <- doLetInserter (postprocess q) modify' (second (DMap.insert μ q'))- return $! inliner recu μ q'+ return $! inliner occs μ q' else do doLetInserter (postprocess q) -postprocess :: Combinator LetInserter a -> LetInserter a+postprocess :: (?flags :: Opt.Flags) => Combinator LetInserter a -> LetInserter a postprocess = LetInserter . fmap optimise . traverseCombinator doLetInserter modifyPreds :: MonadState LetFinderState m => (HashMap ParserName Int -> HashMap ParserName Int) -> m ()
src/ghc/Parsley/Internal/Frontend/Optimiser.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase,+{-# LANGUAGE ImplicitParams,+ LambdaCase, PatternSynonyms, ViewPatterns #-} {-|@@ -19,6 +20,8 @@ import Parsley.Internal.Core.CombinatorAST (Combinator(..)) import Parsley.Internal.Core.Defunc (Defunc(..), pattern FLIP_H, pattern COMPOSE_H, pattern FLIP_CONST, pattern UNIT) +import qualified Parsley.Internal.Opt as Opt+ pattern (:<$>:) :: Defunc (a -> b) -> Fix Combinator a -> Combinator (Fix Combinator) b pattern f :<$>: p = In (Pure f) :<*>: p pattern (:$>:) :: Fix Combinator a -> Defunc b -> Combinator (Fix Combinator) b@@ -32,140 +35,145 @@ @since 1.0.0.0 -}-optimise :: Combinator (Fix Combinator) a -> Fix Combinator a--- DESTRUCTIVE OPTIMISATION--- Right Absorption Law: empty <*> u = empty-optimise (In Empty :<*>: _) = In Empty--- Failure Weakening Law: u <*> empty = u *> empty-optimise (u :<*>: In Empty) = optimise (u :*>: In Empty)--- Right Absorption Law: empty *> u = empty-optimise (In Empty :*>: _) = In Empty--- Right Absorption Law: empty <* u = empty-optimise (In Empty :<*: _) = In Empty--- Failure Weakening Law: u <* empty = u *> empty-optimise (u :<*: In Empty) = optimise (u :*>: In Empty)--- Branch Absorption Law: branch empty p q = empty-optimise (Branch (In Empty) _ _) = In Empty--- Branch Weakening Law: branch b empty empty = b *> empty-optimise (Branch b (In Empty) (In Empty)) = optimise (b :*>: In Empty)--- Match Absorption Law: match _ empty _ def = def-optimise (Match (In Empty) _ _ def) = def--- Match Weakening Law: match _ p (const empty) empty = p *> empty-optimise (Match p _ qs (In Empty))- | all (\case {In Empty -> True; _ -> False}) qs = optimise (p :*>: In Empty)--- APPLICATIVE OPTIMISATION--- Identity Law: id <$> u = u-optimise (ID :<$>: u) = u--- Flip const optimisation: flip const <$> u = u *> pure id-optimise (FLIP_CONST :<$>: u) = optimise (u :*>: In (Pure ID))--- Homomorphism Law: pure f <*> pure x = pure (f x)-optimise (f :<$>: In (Pure x)) = In (Pure (APP_H f x))--- NOTE: This is basically a shortcut, it can be caught by the Composition Law and Homomorphism law--- Functor Composition Law: f <$> (g <$> p) = (f . g) <$> p-optimise (f :<$>: In (g :<$>: p)) = optimise (COMPOSE_H f g :<$>: p)--- Composition Law: u <*> (v <*> w) = (.) <$> u <*> v <*> w-optimise (u :<*>: In (v :<*>: w)) = optimise (optimise (optimise (COMPOSE :<$>: u) :<*>: v) :<*>: w)--- Definition of *>-optimise (In (FLIP_CONST :<$>: p) :<*>: q) = In (p :*>: q)--- 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))--- 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-optimise (In (_ :<$>: p) :*>: q) = In (p :*>: q)--- Left Absorption Law: p <* (f <$> q) = p <* q-optimise (p :<*: (In (_ :<$>: q))) = In (p :<*: q)--- Reassociation Law 2: u <*> (v <* w) = (u <*> v) <* w-optimise (u :<*>: In (v :<*: w)) = optimise (optimise (u :<*>: v) :<*: w)--- Reassociation Law 3: u <*> (v $> x) = (u <*> pure x) <* v-optimise (u :<*>: In (v :$>: x)) = optimise (optimise (u :<*>: In (Pure x)) :<*: v)--- ALTERNATIVE OPTIMISATION--- Left Catch Law: pure x <|> u = pure x-optimise (p@(In (Pure _)) :<|>: _) = p--- Left Neutral Law: empty <|> u = u-optimise (In Empty :<|>: u) = u--- Right Neutral Law: u <|> empty = u-optimise (u :<|>: In Empty) = u--- Associativity Law: (u <|> v) <|> w = u <|> (v <|> w)-optimise (In (u :<|>: v) :<|>: w) = In (u :<|>: optimise (v :<|>: w))--- SEQUENCING OPTIMISATION--- Identity law: pure x *> u = u-optimise (In (Pure _) :*>: u) = u--- Identity law: (u $> x) *> v = u *> v-optimise (In (u :$>: _) :*>: v) = In (u :*>: v)--- Associativity Law: u *> (v *> w) = (u *> v) *> w-optimise (u :*>: In (v :*>: w)) = optimise (optimise (u :*>: v) :*>: w)--- Identity law: u <* pure x = u-optimise (u :<*: In (Pure _)) = u--- Identity law: u <* (v $> x) = u <* v-optimise (u :<*: In (v :$>: _)) = optimise (u :<*: v)--- Commutativity Law: x <$ u = u $> x-optimise (x :<$: u) = optimise (u :$>: x)--- Associativity Law (u <* v) <* w = u <* (v <* w)-optimise (In (u :<*: v) :<*: w) = optimise (u :<*: optimise (v :<*: w))--- Pure lookahead: lookAhead (pure x) = pure x-optimise (LookAhead p@(In (Pure _))) = p--- Dead lookahead: lookAhead empty = empty-optimise (LookAhead p@(In Empty)) = p--- Pure negative-lookahead: notFollowedBy (pure x) = empty-optimise (NotFollowedBy (In (Pure _))) = In Empty--- Dead negative-lookahead: notFollowedBy empty = unit-optimise (NotFollowedBy (In Empty)) = In (Pure UNIT)--- Double Negation Law: notFollowedBy . notFollowedBy = lookAhead . try . void-optimise (NotFollowedBy (In (NotFollowedBy p))) = optimise (LookAhead (In (In (Try p) :*>: In (Pure UNIT))))--- Zero Consumption Law: notFollowedBy (try p) = notFollowedBy p-optimise (NotFollowedBy (In (Try p))) = optimise (NotFollowedBy p)--- Idempotence Law: lookAhead . lookAhead = lookAhead-optimise (LookAhead (In (LookAhead p))) = In (LookAhead p)--- Right Identity Law: notFollowedBy . lookAhead = notFollowedBy-optimise (NotFollowedBy (In (LookAhead p))) = optimise (NotFollowedBy p)--- Left Identity Law: lookAhead . notFollowedBy = notFollowedBy-optimise (LookAhead (In (NotFollowedBy p))) = In (NotFollowedBy p)--- Transparency Law: notFollowedBy (try p <|> q) = notFollowedBy p *> notFollowedBy q-optimise (NotFollowedBy (In (In (Try p) :<|>: q))) = optimise (optimise (NotFollowedBy p) :*>: optimise (NotFollowedBy q))--- Distributivity Law: lookAhead p <|> lookAhead q = lookAhead (try p <|> q)-optimise (In (LookAhead p) :<|>: In (LookAhead q)) = optimise (LookAhead (optimise (In (Try p) :<|>: q)))--- Interchange Law: lookAhead (p $> x) = lookAhead p $> x-optimise (LookAhead (In (p :$>: x))) = optimise (optimise (LookAhead p) :$>: x)--- Interchange law: lookAhead (f <$> p) = f <$> lookAhead p-optimise (LookAhead (In (f :<$>: p))) = optimise (f :<$>: optimise (LookAhead p))--- Absorption Law: p <*> notFollowedBy q = (p <*> unit) <* notFollowedBy q-optimise (p :<*>: In (NotFollowedBy q)) = optimise (optimise (p :<*>: In (Pure UNIT)) :<*: In (NotFollowedBy q))--- Idempotence Law: notFollowedBy (p $> x) = notFollowedBy p-optimise (NotFollowedBy (In (p :$>: _))) = optimise (NotFollowedBy p)--- Idempotence Law: notFollowedBy (f <$> p) = notFollowedBy p-optimise (NotFollowedBy (In (_ :<$>: p))) = optimise (NotFollowedBy p)--- Interchange Law: try (p $> x) = try p $> x-optimise (Try (In (p :$>: x))) = optimise (optimise (Try p) :$>: x)--- 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||]--- 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||]--- 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-optimise (Branch (In (x :*>: y)) p q) = optimise (x :*>: optimise (Branch y p q))--- Negated Branch law: branch b p empty = branch (swapEither <$> b) empty p-optimise (Branch b p (In Empty)) = In (Branch (In (In (Pure (makeQ (either Right Left) [||either Right Left||])) :<*>: b)) (In Empty) p)--- Branch Fusion law: branch (branch b empty (pure f)) empty k = branch (g <$> b) empty k where g is a monad transforming (>>= f)-optimise (Branch (In (Branch b (In Empty) (In (Pure f)))) (In Empty) k) = optimise (Branch (optimise (In (Pure (makeQ g qg)) :<*>: b)) (In Empty) k)+optimise :: (?flags :: Opt.Flags) => Combinator (Fix Combinator) a -> Fix Combinator a+optimise+ | Opt.lawBasedOptimisations ?flags = opt+ | otherwise = In where- g (Left _) = Left ()- g (Right x) = case _val f x of- Left _ -> Left ()- Right x -> Right x- qg = [||\case Left _ -> Left ()- Right x -> case $$(_code f) x of- Left _ -> Left ()- Right y -> Right y||]--- Distributivity Law: f <$> branch b p q = branch b ((f .) <$> p) ((f .) <$> q)-optimise (f :<$>: In (Branch b p q)) = optimise (Branch b (optimise (APP_H COMPOSE f :<$>: p)) (optimise (APP_H COMPOSE f :<$>: q)))--- pure Match law: match vs (pure x) f def = if elem x vs then f x else def-optimise (Match (In (Pure x)) fs qs def) = foldr (\(f, q) k -> if _val f (_val x) then q else k) def (zip fs qs)--- Distributivity Law: f <$> match vs p g def = match vs p ((f <$>) . g) (f <$> def)-optimise (f :<$>: (In (Match p fs qs def))) = In (Match p fs (map (optimise . (f :<$>:)) qs) (optimise (f :<$>: def)))-optimise p = In p+ opt :: Combinator (Fix Combinator) a -> Fix Combinator a+ -- DESTRUCTIVE OPTIMISATION+ -- Right Absorption Law: empty <*> u = empty+ opt (In Empty :<*>: _) = In Empty+ -- Failure Weakening Law: u <*> empty = u *> empty+ opt (u :<*>: In Empty) = opt (u :*>: In Empty)+ -- Right Absorption Law: empty *> u = empty+ opt (In Empty :*>: _) = In Empty+ -- Right Absorption Law: empty <* u = empty+ opt (In Empty :<*: _) = In Empty+ -- Failure Weakening Law: u <* empty = u *> empty+ opt (u :<*: In Empty) = opt (u :*>: In Empty)+ -- Branch Absorption Law: branch empty p q = empty+ opt (Branch (In Empty) _ _) = In Empty+ -- Branch Weakening Law: branch b empty empty = b *> empty+ opt (Branch b (In Empty) (In Empty)) = opt (b :*>: In Empty)+ -- Match Absorption Law: match _ empty _ def = def+ opt (Match (In Empty) _ _ def) = def+ -- Match Weakening Law: match _ p (const empty) empty = p *> empty+ opt (Match p _ qs (In Empty))+ | all (\case {In Empty -> True; _ -> False}) qs = opt (p :*>: In Empty)+ -- APPLICATIVE OPTIMISATION+ -- Identity Law: id <$> u = u+ opt (ID :<$>: u) = u+ -- Flip const optimisation: flip const <$> u = u *> pure id+ opt (FLIP_CONST :<$>: u) = opt (u :*>: In (Pure ID))+ -- Homomorphism Law: pure f <*> pure x = pure (f x)+ opt (f :<$>: In (Pure x)) = In (Pure (APP_H f x))+ -- NOTE: This is basically a shortcut, it can be caught by the Composition Law and Homomorphism law+ -- Functor Composition Law: f <$> (g <$> p) = (f . g) <$> p+ opt (f :<$>: In (g :<$>: p)) = opt (COMPOSE_H f g :<$>: p)+ -- Composition Law: u <*> (v <*> w) = (.) <$> u <*> v <*> w+ opt (u :<*>: In (v :<*>: w)) = opt (opt (opt (COMPOSE :<$>: u) :<*>: v) :<*>: w)+ -- Definition of *>+ opt (In (FLIP_CONST :<$>: p) :<*>: q) = In (p :*>: q)+ -- Definition of <*+ opt (In (CONST :<$>: p) :<*>: q) = In (p :<*: q)+ -- Reassociation Law 1: (u *> v) <*> w = u *> (v <*> w)+ opt (In (u :*>: v) :<*>: w) = opt (u :*>: opt (v :<*>: w))+ -- Interchange Law: u <*> pure x = pure ($ x) <*> u+ opt (u :<*>: In (Pure x)) = opt (APP_H (FLIP_H ID) x :<$>: u)+ -- Right Absorption Law: (f <$> p) *> q = p *> q+ opt (In (_ :<$>: p) :*>: q) = In (p :*>: q)+ -- Left Absorption Law: p <* (f <$> q) = p <* q+ opt (p :<*: (In (_ :<$>: q))) = In (p :<*: q)+ -- Reassociation Law 2: u <*> (v <* w) = (u <*> v) <* w+ opt (u :<*>: In (v :<*: w)) = opt (opt (u :<*>: v) :<*: w)+ -- Reassociation Law 3: u <*> (v $> x) = (u <*> pure x) <* v+ opt (u :<*>: In (v :$>: x)) = opt (opt (u :<*>: In (Pure x)) :<*: v)+ -- ALTERNATIVE OPTIMISATION+ -- Left Catch Law: pure x <|> u = pure x+ opt (p@(In (Pure _)) :<|>: _) = p+ -- Left Neutral Law: empty <|> u = u+ opt (In Empty :<|>: u) = u+ -- Right Neutral Law: u <|> empty = u+ opt (u :<|>: In Empty) = u+ -- Associativity Law: (u <|> v) <|> w = u <|> (v <|> w)+ opt (In (u :<|>: v) :<|>: w) = In (u :<|>: opt (v :<|>: w))+ -- SEQUENCING OPTIMISATION+ -- Identity law: pure x *> u = u+ opt (In (Pure _) :*>: u) = u+ -- Identity law: (u $> x) *> v = u *> v+ opt (In (u :$>: _) :*>: v) = In (u :*>: v)+ -- Associativity Law: u *> (v *> w) = (u *> v) *> w+ opt (u :*>: In (v :*>: w)) = opt (opt (u :*>: v) :*>: w)+ -- Identity law: u <* pure x = u+ opt (u :<*: In (Pure _)) = u+ -- Identity law: u <* (v $> x) = u <* v+ opt (u :<*: In (v :$>: _)) = opt (u :<*: v)+ -- Commutativity Law: x <$ u = u $> x+ opt (x :<$: u) = opt (u :$>: x)+ -- Associativity Law (u <* v) <* w = u <* (v <* w)+ opt (In (u :<*: v) :<*: w) = opt (u :<*: opt (v :<*: w))+ -- Pure lookahead: lookAhead (pure x) = pure x+ opt (LookAhead p@(In (Pure _))) = p+ -- Dead lookahead: lookAhead empty = empty+ opt (LookAhead p@(In Empty)) = p+ -- Pure negative-lookahead: notFollowedBy (pure x) = empty+ opt (NotFollowedBy (In (Pure _))) = In Empty+ -- Dead negative-lookahead: notFollowedBy empty = unit+ opt (NotFollowedBy (In Empty)) = In (Pure UNIT)+ -- Double Negation Law: notFollowedBy . notFollowedBy = lookAhead . try . void+ opt (NotFollowedBy (In (NotFollowedBy p))) = opt (LookAhead (In (In (Try p) :*>: In (Pure UNIT))))+ -- Zero Consumption Law: notFollowedBy (try p) = notFollowedBy p+ opt (NotFollowedBy (In (Try p))) = opt (NotFollowedBy p)+ -- Idempotence Law: lookAhead . lookAhead = lookAhead+ opt (LookAhead (In (LookAhead p))) = In (LookAhead p)+ -- Right Identity Law: notFollowedBy . lookAhead = notFollowedBy+ opt (NotFollowedBy (In (LookAhead p))) = opt (NotFollowedBy p)+ -- Left Identity Law: lookAhead . notFollowedBy = notFollowedBy+ opt (LookAhead (In (NotFollowedBy p))) = In (NotFollowedBy p)+ -- Transparency Law: notFollowedBy (try p <|> q) = notFollowedBy p *> notFollowedBy q+ opt (NotFollowedBy (In (In (Try p) :<|>: q))) = opt (opt (NotFollowedBy p) :*>: opt (NotFollowedBy q))+ -- Distributivity Law: lookAhead p <|> lookAhead q = lookAhead (try p <|> q)+ opt (In (LookAhead p) :<|>: In (LookAhead q)) = opt (LookAhead (opt (In (Try p) :<|>: q)))+ -- Interchange Law: lookAhead (p $> x) = lookAhead p $> x+ opt (LookAhead (In (p :$>: x))) = opt (opt (LookAhead p) :$>: x)+ -- Interchange law: lookAhead (f <$> p) = f <$> lookAhead p+ opt (LookAhead (In (f :<$>: p))) = opt (f :<$>: opt (LookAhead p))+ -- Absorption Law: p <*> notFollowedBy q = (p <*> unit) <* notFollowedBy q+ opt (p :<*>: In (NotFollowedBy q)) = opt (opt (p :<*>: In (Pure UNIT)) :<*: In (NotFollowedBy q))+ -- Idempotence Law: notFollowedBy (p $> x) = notFollowedBy p+ opt (NotFollowedBy (In (p :$>: _))) = opt (NotFollowedBy p)+ -- Idempotence Law: notFollowedBy (f <$> p) = notFollowedBy p+ opt (NotFollowedBy (In (_ :<$>: p))) = opt (NotFollowedBy p)+ -- Interchange Law: try (p $> x) = try p $> x+ opt (Try (In (p :$>: x))) = opt (opt (Try p) :$>: x)+ -- Interchange law: try (f <$> p) = f <$> try p+ opt (Try (In (f :<$>: p))) = opt (f :<$>: opt (Try p))+ -- pure Left law: branch (pure (Left x)) p q = p <*> pure x+ opt (Branch (In (Pure l@(_val -> Left x))) p _) = opt (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+ opt (Branch (In (Pure r@(_val -> Right x))) _ q) = opt (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+ opt (Branch b (In (Pure f)) (In (Pure g))) = opt (makeQ (either (_val f) (_val g)) [||either $$(_code f) $$(_code g)||] :<$>: b)+ -- Interchange law: branch (x *> y) p q = x *> branch y p q+ opt (Branch (In (x :*>: y)) p q) = opt (x :*>: opt (Branch y p q))+ -- Negated Branch law: branch b p empty = branch (swapEither <$> b) empty p+ opt (Branch b p (In Empty)) = In (Branch (In (In (Pure (makeQ (either Right Left) [||either Right Left||])) :<*>: b)) (In Empty) p)+ -- Branch Fusion law: branch (branch b empty (pure f)) empty k = branch (g <$> b) empty k where g is a monad transforming (>>= f)+ opt (Branch (In (Branch b (In Empty) (In (Pure f)))) (In Empty) k) = opt (Branch (opt (In (Pure (makeQ g qg)) :<*>: b)) (In Empty) k)+ where+ g (Left _) = Left ()+ g (Right x) = case _val f x of+ Left _ -> Left ()+ Right x -> Right x+ qg = [||\case Left _ -> Left ()+ Right x -> case $$(_code f) x of+ Left _ -> Left ()+ Right y -> Right y||]+ -- Distributivity Law: f <$> branch b p q = branch b ((f .) <$> p) ((f .) <$> q)+ opt (f :<$>: In (Branch b p q)) = opt (Branch b (opt (APP_H COMPOSE f :<$>: p)) (opt (APP_H COMPOSE f :<$>: q)))+ -- pure Match law: match vs (pure x) f def = if elem x vs then f x else def+ opt (Match (In (Pure x)) fs qs def) = foldr (\(f, q) k -> if _val f (_val x) then q else k) def (zip fs qs)+ -- Distributivity Law: f <$> match vs p g def = match vs p ((f <$>) . g) (f <$> def)+ opt (f :<$>: (In (Match p fs qs def))) = In (Match p fs (map (opt . (f :<$>:)) qs) (opt (f :<$>: def)))+ opt p = In p
+ src/ghc/Parsley/Internal/Opt.hs view
@@ -0,0 +1,51 @@+module Parsley.Internal.Opt (module Parsley.Internal.Opt) where++import Data.Ratio ((%))++on, off :: Bool+on = True+off = False++defaultPrimaryInlineThreshold :: Maybe Rational+defaultPrimaryInlineThreshold = Just $ 13 % 10 * {- Occurrence Bias -} 3++defaultSecondaryInlineThreshold :: Maybe Rational+defaultSecondaryInlineThreshold = Just $ 13 % 10++data Flags = Flags { lawBasedOptimisations :: !Bool+ , termNormalisation :: !Bool+ , primaryInlineThreshold :: !(Maybe Rational)+ , secondaryInlineThreshold :: !(Maybe Rational)+ -- TODO: merge these together+ , lengthCheckFactoring :: !Bool+ , leadCharFactoring :: !Bool+ , factorAheadOfJoins :: !Bool+ , reclaimInput :: !Bool+ , deduceFailPath :: !Bool+ --, closeFreeRegisters :: !Bool+ }++none, fast, full :: Flags+none = Flags { lawBasedOptimisations = off+ , termNormalisation = off+ , primaryInlineThreshold = Just 0+ , secondaryInlineThreshold = Just 0+ , lengthCheckFactoring = off+ , leadCharFactoring = off+ , factorAheadOfJoins = off+ , reclaimInput = off+ , deduceFailPath = off+ --, closeFreeRegisters = off+ }+fast = full --{ }+full = Flags { lawBasedOptimisations = on+ , termNormalisation = on+ , primaryInlineThreshold = defaultPrimaryInlineThreshold+ , secondaryInlineThreshold = defaultSecondaryInlineThreshold+ , lengthCheckFactoring = on+ , leadCharFactoring = on+ , factorAheadOfJoins = on+ , reclaimInput = on+ , deduceFailPath = on+ --, closeFreeRegisters = on+ }
test/Regression/Issue27.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, MultiParamTypeClasses #-}+{-# LANGUAGE GADTs, ImplicitParams, MultiParamTypeClasses #-} module Regression.Issue27 where import Prelude hiding (pure, (*>))@@ -16,6 +16,7 @@ import Parsley.Internal.Frontend.Analysis.Cut (cutAnalysis) import qualified Data.Set as Set (empty)+import qualified Parsley.Internal.Opt as Opt import Parsley.Internal.Verbose --instance {-# INCOHERENT #-} Trace where trace = const id@@ -29,31 +30,7 @@ toAST = cata (In \/ undefined) . unParser codeGen' :: Fix Combinator a -> Binding o a a-codeGen' p = body (codeGen Nothing p Set.empty 0)--ex1_p :: Fix Combinator String-ex1_p = toAST $ try $ string "123" <|> string "45"--ex2_p :: Fix Combinator String-ex2_p = toAST $ try $ try (string "123") <|> string "45"--ex3_p :: Fix Combinator String-ex3_p = toAST $ string "123" <|> string "45"--ex4_p :: Fix Combinator String-ex4_p = toAST $ try (string "123") <|> try (string "45")--ex5_p :: Fix Combinator String-ex5_p = toAST $ (string "a" <|> pure (LIFTED "")) *> string "1234"--ex6_p :: Fix Combinator String-ex6_p = toAST $ (string "abc" <|> string "def") *> string "123"--ex7_p :: Fix Combinator String-ex7_p = toAST $ (string "abc" <|> string "123") *> string "..." <|> string "def"--ex8_p :: Fix Combinator String-ex8_p = toAST $ (try (string "abc") <|> string "ade") *> string "..." <|> string "def"+codeGen' p = let ?flags = Opt.fast in body (codeGen Nothing p Set.empty 0) leadingCoinsUnderCatch :: Fix4 (Instr o) xs n r a -> Maybe Int leadingCoinsUnderCatch (In4 (Catch (In4 (MetaInstr (AddCoins c) _)) _)) = Just (willConsume c)@@ -63,42 +40,90 @@ leadingCoins (In4 (MetaInstr (AddCoins c) _)) = Just (willConsume c) leadingCoins _ = Nothing +{- Example 1 -}+desc1 = "under outmost try max 1 coins should be factored without inner try"++ex1_p :: Fix Combinator String+ex1_p = toAST $ try $ string "123" <|> string "45"+ test1 :: Assertion test1 = let coins = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex1_p)) in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins +{- Example 2 -}+desc2 = "under outermost try 2 coins should be factored with inner try"++ex2_p :: Fix Combinator String+ex2_p = toAST $ try $ try (string "123") <|> string "45"+ test2 :: Assertion-test2 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex2_p)) @?= Just 2+test2 = leadingCoins (codeGen' (cutAnalysis ex2_p)) @?= Just 2 +{- Example 3 -}+desc3 = "max 1 coins should be factored without try"++ex3_p :: Fix Combinator String+ex3_p = toAST $ string "123" <|> string "45"+ test3 :: Assertion test3 = let coins = leadingCoins (codeGen' (cutAnalysis ex3_p)) in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins +{- Example 4 -}+desc4 = "max 1 coins should be factored with no outer-most try"++ex4_p :: Fix Combinator String+ex4_p = toAST $ try (string "123") <|> try (string "45")+ test4 :: Assertion test4 = let coins = leadingCoins (codeGen' (cutAnalysis ex4_p)) in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins +{- Example 5 -}+desc5 = ""++ex5_p :: Fix Combinator String+ex5_p = toAST $ (string "a" <|> pure (LIFTED "")) *> string "1234"+ test5 :: Assertion test5 = let coins = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex5_p)) in (coins `elem` [Just 1, Nothing]) @? "expected 0 or 1 leading coins, got " ++ show coins +{- Example 6 -}+desc6 = ""++ex6_p :: Fix Combinator String+ex6_p = toAST $ (string "abc" <|> string "def") *> string "123"+ test6 :: Assertion test6 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex6_p)) @?= Nothing +{- Example 7 -}+desc7 = ""++ex7_p :: Fix Combinator String+ex7_p = toAST $ (string "abc" <|> string "123") *> string "..." <|> string "def"+ test7 :: Assertion test7 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex7_p)) @?= Nothing +{- Example 8 -}+desc8 = ""++ex8_p :: Fix Combinator String+ex8_p = toAST $ (try (string "abc") <|> string "ade") *> string "..." <|> string "def"+ test8 :: Assertion test8 = leadingCoinsUnderCatch (codeGen' (cutAnalysis ex8_p)) @?= Nothing tests :: TestTree tests = testGroup "#27 Input checks in `Frontend` and `Backend` are not properly respecting cuts"- [ testCase "under try max 1 coins should be factored without try" test1- , testCase "under try 2 coins should be factored with try" test2- , testCase "max 1 coins should be factored without try" test3- , testCase "max 1 coins should be factored with try" test4- --, testCase "" test5- --, testCase "" test6- --, testCase "" test7- --, testCase "" test8+ [ testCase desc1 test1+ , testCase desc2 test2+ --, testCase desc3 test3+ --, testCase desc4 test4+ , testCase desc5 test5+ , testCase desc6 test6+ , testCase desc7 test7+ , testCase desc8 test8 ]