diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`). diff --git a/parsley-core.cabal b/parsley-core.cabal --- a/parsley-core.cabal +++ b/parsley-core.cabal @@ -5,7 +5,7 @@ -- | +------- breaking internal API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.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. . diff --git a/src/ghc/Parsley/Internal/Backend/Analysis.hs b/src/ghc/Parsley/Internal/Backend/Analysis.hs --- a/src/ghc/Parsley/Internal/Backend/Analysis.hs +++ b/src/ghc/Parsley/Internal/Backend/Analysis.hs @@ -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) diff --git a/src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs b/src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs --- a/src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs +++ b/src/ghc/Parsley/Internal/Backend/Analysis/Coins.hs @@ -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) diff --git a/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs b/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs --- a/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +++ b/src/ghc/Parsley/Internal/Backend/CodeGenerator.hs @@ -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))))))) diff --git a/src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs b/src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs --- a/src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +++ b/src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs @@ -317,7 +317,7 @@ prefetchChar check = In4 . MetaInstr (PrefetchChar check) {-| -Smart-constructor around `PrefetchChar`. +Smart-constructor around `BlockCoins`. @since 1.6.0.0 -} diff --git a/src/ghc/Parsley/Internal/Core/CombinatorAST.hs b/src/ghc/Parsley/Internal/Core/CombinatorAST.hs --- a/src/ghc/Parsley/Internal/Core/CombinatorAST.hs +++ b/src/ghc/Parsley/Internal/Core/CombinatorAST.hs @@ -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 . "]"