parsley-core 1.7.1.1 → 1.7.2.0
raw patch · 7 files changed
+67/−60 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Parsley.Internal.Backend.Analysis: reclaimable :: Fix4 (Instr o) xs n r a -> Coins
+ Parsley.Internal.Backend.Analysis.Coins: reclaimable :: Fix4 (Instr o) xs n r a -> Coins
Files
- ChangeLog.md +5/−0
- parsley-core.cabal +1/−1
- src/ghc/Parsley/Internal/Backend/Analysis.hs +3/−2
- src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs +42/−41
- src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +2/−2
- src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +1/−1
- src/ghc/Parsley/Internal/Core/CombinatorAST.hs +13/−13
ChangeLog.md view
@@ -116,3 +116,8 @@ * Improved eta-reduction to handle multiple arguments. * Added eta-reduction to constructed return continutations.++## 1.7.2.0 -- 2021-10-31++* Added `reclaimable` to backend analysis, this allows `lookAhead` to calculate reclaim ignoring `BlockCoins`+* Fixed small bug in coin analysis that meant that `lookAhead` always contributes `0` coins (`min 0` vs `max 0`).
parsley-core.cabal view
@@ -5,7 +5,7 @@ -- | +------- breaking internal API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 1.7.1.1+version: 1.7.2.0 synopsis: A fast parser combinator library backed by Typed Template Haskell description: This package contains the internals of the @parsley@ package. .
src/ghc/Parsley/Internal/Backend/Analysis.hs view
@@ -13,10 +13,11 @@ module Parsley.Internal.Backend.Analysis ( coinsNeeded, shouldInline,- relevancy+ relevancy,+ reclaimable ) where -import Parsley.Internal.Backend.Analysis.Coins (coinsNeeded)+import Parsley.Internal.Backend.Analysis.Coins (coinsNeeded, reclaimable) import Parsley.Internal.Backend.Analysis.Inliner (shouldInline) import Parsley.Internal.Backend.Analysis.Relevancy (relevancy)
src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs view
@@ -12,9 +12,10 @@ @since 1.5.0.0 -}-module Parsley.Internal.Backend.Analysis.Coins (coinsNeeded) where+module Parsley.Internal.Backend.Analysis.Coins (coinsNeeded, reclaimable) where -import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..), Handler(..), Coins, plus1, minCoins, zero, minus, plusNotReclaim, willConsume)+import Data.Bifunctor (first)+import Parsley.Internal.Backend.Machine (Instr(..), MetaInstr(..), Handler(..), Coins, plus1, minCoins, maxCoins, zero, minus, plusNotReclaim, willConsume) import Parsley.Internal.Common.Indexed (cata4, Fix4, Const4(..)) {-|@@ -23,16 +24,15 @@ @since 1.5.0.0 -} coinsNeeded :: Fix4 (Instr o) xs n r a -> Coins-coinsNeeded = fst . getConst4 . cata4 (Const4 . alg)--first :: (a -> b) -> (a, x) -> (b, x)-first = flip bimap id+coinsNeeded = fst . getConst4 . cata4 (Const4 . alg True) ---second :: (a -> b) -> (x, a) -> (x, b)---second = bimap id+{-|+Calculate the number of tokens can be reclaimed by a lookAhead -bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)-bimap = curry (bilift2 ($) ($))+@since 1.7.2.0+-}+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)@@ -45,37 +45,38 @@ -- 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 :: 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 _ _ 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 (minCoins 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 (MetaInstr BlockCoins (Const4 k)) = first (const zero) k+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 _ _ 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)
src/ghc/Parsley/Internal/Backend/CodeGenerator.hs view
@@ -21,7 +21,7 @@ addCoins, refundCoins, drainCoins, giveBursary, blockCoins, minus, minCoins, maxCoins, zero, IMVar, IΦVar, MVar(..), ΦVar(..), SomeΣVar)-import Parsley.Internal.Backend.Analysis (coinsNeeded, shouldInline)+import Parsley.Internal.Backend.Analysis (coinsNeeded, shouldInline, reclaimable) import Parsley.Internal.Common.Fresh (VFreshT, VFresh, evalFreshT, evalFresh, construct, MonadFresh(..), mapVFreshT) import Parsley.Internal.Common.Indexed (Fix, Fix4(In4), Cofree(..), Nat(..), imap, histo, extract, (|>)) import Parsley.Internal.Core.CombinatorAST (Combinator(..), MetaCombinator(..))@@ -126,7 +126,7 @@ shallow (p :<|>: q) m = do altNoCutCompile 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 coinsNeeded (runCodeGen p (In4 Ret)) -- Dodgy hack, but oh well+ do n <- fmap reclaimable (runCodeGen p (In4 Ret)) -- Dodgy hack, but oh well 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)))))))
src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs view
@@ -317,7 +317,7 @@ prefetchChar check = In4 . MetaInstr (PrefetchChar check) {-|-Smart-constructor around `PrefetchChar`.+Smart-constructor around `BlockCoins`. @since 1.6.0.0 -}
src/ghc/Parsley/Internal/Core/CombinatorAST.hs view
@@ -82,24 +82,24 @@ instance Show (Fix Combinator a) where show = ($ "") . getConst1 . cata (Const1 . alg) where- alg (Pure x) = "(pure " . shows x . ")"- alg (Satisfy f) = "(satisfy " . shows f . ")"+ alg (Pure x) = "pure " . shows x+ alg (Satisfy f) = "satisfy " . shows f alg (Const1 pf :<*>: Const1 px) = "(" . pf . " <*> " . px . ")" alg (Const1 p :*>: Const1 q) = "(" . p . " *> " . q . ")" alg (Const1 p :<*: Const1 q) = "(" . p . " <* " . q . ")" alg (Const1 p :<|>: Const1 q) = "(" . p . " <|> " . q . ")" 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 (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 . ")"- alg (Loop (Const1 body) (Const1 exit)) = "(loop " . body . " " . exit . ")"- alg (MakeRegister σ (Const1 p) (Const1 q)) = "(make " . shows σ . " " . p . " " . q . ")"- alg (GetRegister σ) = "(get " . shows σ . ")"- alg (PutRegister σ (Const1 p)) = "(put " . shows σ . " " . p . ")"+ 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 (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 . ")"+ alg (Loop (Const1 body) (Const1 exit)) = "loop (" . body . ") (" . exit . ")"+ alg (MakeRegister σ (Const1 p) (Const1 q)) = "make " . shows σ . " (" . p . ") (" . q . ")"+ alg (GetRegister σ) = "get " . shows σ+ alg (PutRegister σ (Const1 p)) = "put " . shows σ . " (" . p . ")" alg (Debug _ (Const1 p)) = p alg (MetaCombinator m (Const1 p)) = p . " [" . shows m . "]"