parsley-core 1.0.1.0 → 1.0.1.1

raw patch · 5 files changed

+78/−79 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• parsley-core.cabal +1/−1
• src/ghc/Parsley/Internal/Backend/CodeGenerator.hs +68/−76
• src/ghc/Parsley/Internal/Backend/InstructionAnalyser.hs +4/−1
• src/ghc/Parsley/Internal/Backend/Machine/Instructions.hs +1/−1

@@ -9,3 +9,7 @@  * Introduced `Lam` to the API and conversion functions for `Core.Defunc` * Extra type ascriptions added to generated code++## 1.0.1.1 -- 2021-06-27++* Added input factoring to `try p <|> q` and also forms with `f <$> try p <|> q` and `try p $> x <|> q`

@@ -5,7 +5,7 @@ --                   | +------- breaking internal API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.0.1.0+version:             1.0.1.1 synopsis:            A fast parser combinator library backed by Typed Template Haskell description:         This package contains the internals of the @parsley@ package.                      .

@@ -35,19 +35,17 @@     name = maybe "TOP LEVEL" show letBound     m = finalise (histo alg p)     alg :: PositionOps o => Combinator (Cofree Combinator (CodeGen o a)) x -> CodeGen o a x-    alg = peephole |> (\x -> CodeGen (direct (imap extract x)))+    alg = deep |> (\x -> CodeGen (shallow (imap extract x)))     finalise cg =       let m = runCodeGenStack (runCodeGen cg (In4 Ret)) μ0 0 σ0       in if isJust letBound then m else addCoins (coinsNeeded m) m -pattern (:<$>:) :: Core.Defunc (a -> b) -> k a -> Combinator (Cofree Combinator k) b-pattern f :<$>: p <- (_ :< Pure f) :<*>: (p :< _)+pattern (:<$>:) :: Core.Defunc (a -> b) -> Cofree Combinator k a -> Combinator (Cofree Combinator k) b+pattern f :<$>: p <- (_ :< Pure f) :<*>: p pattern (:$>:) :: Combinator (Cofree Combinator k) a -> Core.Defunc b -> Combinator (Cofree Combinator k) b pattern p :$>: x <- (_ :< p) :*>: (_ :< Pure x)-pattern LiftA2 :: Core.Defunc (a -> b -> c) -> k a -> k b -> Combinator (Cofree Combinator k) c-pattern LiftA2 f p q <- (_ :< ((_ :< Pure f) :<*>: (p :< _))) :<*>: (q :< _)---pattern TryOrElse ::  k a -> k a -> Combinator (Cofree Combinator k) a---pattern TryOrElse p q <- (_ :< Try (p :< _)) :<|>: (q :< _)+pattern TryOrElse ::  k a -> k a -> Combinator (Cofree Combinator k) a+pattern TryOrElse p q <- (_ :< Try (p :< _)) :<|>: (q :< _)  rollbackHandler :: Fix4 (Instr o) (o : xs) (Succ n) r a rollbackHandler = In4 (Seek (In4 Empt))@@ -55,72 +53,77 @@ parsecHandler :: PositionOps o => Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) (o : xs) (Succ n) r a parsecHandler k = In4 (Tell (In4 (Lift2 SAME (In4 (If k (In4 Empt)))))) -peephole :: PositionOps o => Combinator (Cofree Combinator (CodeGen o a)) x -> Maybe (CodeGen o a x)-peephole (f :<$>: p) = Just $ CodeGen $ \m -> runCodeGen p (In4 (Fmap (USER f) m))-peephole (LiftA2 f p q) = Just $ CodeGen $ \m ->-  do qc <- runCodeGen q (In4 (Lift2 (USER f) m))-     runCodeGen p qc-{-peephole (TryOrElse p q) = Just $ CodeGen $ \m -> -- FIXME!-  do (binder, φ) <- makeΦ m-     pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))-     fmap (binder . In4 . Catch pc . In4 . Seek) (freshΦ (runCodeGen q φ))-}-peephole ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ \m ->-  do (binder, φ) <- makeΦ m-     pc <- freshΦ (runCodeGen p (deadCommitOptimisation (In4 (Pop (In4 (Push (USER x) φ))))))-     fmap (binder . In4 . Catch pc . In4 . Seek) (freshΦ (runCodeGen q φ))-peephole (MetaCombinator RequiresCut (_ :< ((p :< _) :<|>: (q :< _)))) = Just $ CodeGen $ \m ->+altNoCutCompile :: CodeGen o a y -> CodeGen o a x+                -> (forall n xs r. Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) (o : xs) (Succ n) r a)+                -> (forall n xs r. Fix4 (Instr o) (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 =   do (binder, φ) <- makeΦ m-     pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))+     pc <- freshΦ (runCodeGen p (deadCommitOptimisation (post φ)))      qc <- freshΦ (runCodeGen q φ)-     return $! binder (In4 (Catch pc (parsecHandler qc)))-peephole (MetaCombinator RequiresCut (_ :< ChainPre (op :< _) (p :< _))) = Just $ CodeGen $ \m ->+     let np = coinsNeeded pc+     let nq = coinsNeeded qc+     let dp = np - min np nq+     let dq = nq - min np nq+     return $! binder (In4 (Catch (addCoins dp pc) (handler (addCoins dq qc))))++chainPreCompile :: PositionOps o => CodeGen o a (x -> x) -> CodeGen o a x+                -> (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)+chainPreCompile op p preOp preP m =   do μ <- askM      σ <- freshΣ      opc <- freshM (runCodeGen op (In4 (Fmap (USER (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))      pc <- freshM (runCodeGen p (In4 (App m)))-     return $! In4 (Push (USER ID) (In4 (_Make σ (In4 (Iter μ opc (parsecHandler (In4 (_Get σ (addCoins (coinsNeeded pc) pc)))))))))-peephole (MetaCombinator RequiresCut (_ :< ChainPost (p :< _) (op :< _))) = Just $ CodeGen $ \m ->+     return $! In4 (Push (USER ID) (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preP pc)))))))))++chainPostCompile :: PositionOps o => CodeGen o a x -> CodeGen o a (x -> x)+                 -> (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)+chainPostCompile p op preOp preM m =   do μ <- askM      σ <- freshΣ-     let nm = coinsNeeded m      opc <- freshM (runCodeGen op (In4 (_Modify σ (In4 (Jump μ)))))-     freshM (runCodeGen p (In4 (_Make σ (In4 (Iter μ opc (parsecHandler (In4 (_Get σ (addCoins nm m)))))))))-peephole (MetaCombinator Cut (_ :< ChainPre (op :< _) (p :< _))) = Just $ CodeGen $ \m ->-  do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (Fmap (USER (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))-     let nop = coinsNeeded opc-     pc <- freshM (runCodeGen p (In4 (App m)))-     return $! In4 (Push (USER ID) (In4 (_Make σ (In4 (Iter μ (addCoins nop opc) (parsecHandler (In4 (_Get σ (addCoins (coinsNeeded pc) pc)))))))))--- TODO: One more for fmap try-peephole _ = Nothing+     freshM (runCodeGen p (In4 (_Make σ (In4 (Iter μ (preOp opc) (parsecHandler (In4 (_Get σ (preM m))))))))) -direct :: PositionOps o => Combinator (CodeGen o a) x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)-direct (Pure x)      m = do return $! In4 (Push (USER x) m)-direct (Satisfy p)   m = do return $! In4 (Sat (USER p) m)-direct (pf :<*>: px) m = do pxc <- runCodeGen px (In4 (App m)); runCodeGen pf pxc-direct (p :*>: q)    m = do qc <- runCodeGen q m; runCodeGen p (In4 (Pop qc))-direct (p :<*: q)    m = do qc <- runCodeGen q (In4 (Pop m)); runCodeGen p qc-direct Empty         _ = do return $! In4 Empt-direct (p :<|>: q) m =+deep :: PositionOps o => Combinator (Cofree Combinator (CodeGen o a)) x -> Maybe (CodeGen o a x)+deep (f :<$>: (p :< _)) = Just $ CodeGen $ \m -> runCodeGen p (In4 (Fmap (USER f) m))+deep (TryOrElse p q) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) id+deep ((_ :< (Try (p :< _) :$>: x)) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) (In4 . Pop . In4 . Push (USER x))+deep ((_ :< (f :<$>: (_ :< Try (p :< _)))) :<|>: (q :< _)) = Just $ CodeGen $ altNoCutCompile p q (In4 . Seek) (In4 . Fmap (USER f))+deep (MetaCombinator RequiresCut (_ :< ((p :< _) :<|>: (q :< _)))) = Just $ CodeGen $ \m ->   do (binder, φ) <- makeΦ m      pc <- freshΦ (runCodeGen p (deadCommitOptimisation φ))      qc <- freshΦ (runCodeGen q φ)-     let np = coinsNeeded pc-     let nq = coinsNeeded qc-     let dp = np - min np nq-     let dq = nq - min np nq-     return $! binder (In4 (Catch (addCoins dp pc) (parsecHandler (addCoins dq qc))))-direct (Try p)       m = do fmap (In4 . flip Catch rollbackHandler) (runCodeGen p (deadCommitOptimisation m))-direct (LookAhead p) m =+     return $! binder (In4 (Catch pc (parsecHandler qc)))+deep (MetaCombinator RequiresCut (_ :< ChainPre (op :< _) (p :< _))) = Just $ CodeGen $ chainPreCompile op p id addCoinsNeeded+deep (MetaCombinator RequiresCut (_ :< ChainPost (p :< _) (op :< _))) = Just $ CodeGen $ chainPostCompile p op id addCoinsNeeded+deep (MetaCombinator Cut (_ :< ChainPre (op :< _) (p :< _))) = Just $ CodeGen $ chainPreCompile op p addCoinsNeeded addCoinsNeeded+deep _ = Nothing++addCoinsNeeded :: Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a+addCoinsNeeded = coinsNeeded >>= addCoins++shallow :: PositionOps o => Combinator (CodeGen o a) x -> Fix4 (Instr o) (x : xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a)+shallow (Pure x)      m = do return $! In4 (Push (USER x) m)+shallow (Satisfy p)   m = do return $! In4 (Sat (USER 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 (Try p)       m = do fmap (In4 . flip Catch rollbackHandler) (runCodeGen p (deadCommitOptimisation m))+shallow (LookAhead p) m =   do n <- fmap coinsNeeded (runCodeGen p (In4 Empt)) -- Dodgy hack, but oh well      fmap (In4 . Tell) (runCodeGen p (In4 (Swap (In4 (Seek (refundCoins n m))))))-direct (NotFollowedBy p) 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      return $! In4 (Catch (addCoins (max (np - nm) 0) (In4 (Tell pc))) (In4 (Seek (In4 (Push (USER UNIT) m)))))-direct (Branch b p q) 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 φ)))))@@ -128,32 +131,21 @@      let dp = max 0 (coinsNeeded pc - minc)      let dq = max 0 (coinsNeeded qc - minc)      fmap binder (runCodeGen b (In4 (Case (addCoins dp pc) (addCoins dq qc))))-direct (Match p fs qs def) m =+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 (max 0 . subtract minc . coinsNeeded >>= addCoins) (defc:qcs)      fmap binder (runCodeGen p (In4 (Choices (map USER fs) qcs' defc')))-direct (Let _ μ _) m = return $! tailCallOptimise μ m-direct (ChainPre op p) m =-  do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (Fmap (USER (FLIP_H COMPOSE)) (In4 (_Modify σ (In4 (Jump μ)))))))-     let nop = coinsNeeded opc-     pc <- freshM (runCodeGen p (In4 (App m)))-     return $! In4 (Push (USER ID) (In4 (_Make σ (In4 (Iter μ (addCoins nop opc) (parsecHandler (In4 (_Get σ pc))))))))-direct (ChainPost p op) m =-  do μ <- askM-     σ <- freshΣ-     opc <- freshM (runCodeGen op (In4 (_Modify σ (In4 (Jump μ)))))-     let nop = coinsNeeded opc-     freshM (runCodeGen p (In4 (_Make σ (In4 (Iter μ (addCoins nop opc) (parsecHandler (In4 (_Get σ m))))))))-direct (MakeRegister σ p q)   m = do qc <- runCodeGen q m; runCodeGen p (In4 (_Make σ qc))-direct (GetRegister σ)        m = do return $! In4 (_Get σ m)-direct (PutRegister σ p)      m = do runCodeGen p (In4 (_Put σ (In4 (Push (USER UNIT) m))))-direct (Debug name p)         m = do fmap (In4 . LogEnter name) (runCodeGen p (In4 (Commit (In4 (LogExit name m)))))-direct (MetaCombinator Cut p) m = do runCodeGen p (addCoins (coinsNeeded m) m)+shallow (Let _ μ _)            m = do return $! tailCallOptimise μ m+shallow (ChainPre op p)        m = do chainPreCompile op p addCoinsNeeded id m+shallow (ChainPost p op)       m = do chainPostCompile p op addCoinsNeeded id m+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))))+shallow (Debug name p)         m = do fmap (In4 . LogEnter name) (runCodeGen p (In4 (Commit (In4 (LogExit name m)))))+shallow (MetaCombinator Cut p) m = do runCodeGen p (addCoins (coinsNeeded m) 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 μ)@@ -181,9 +173,9 @@ makeΦ :: Fix4 (Instr o) (x ': xs) (Succ n) r a -> CodeGenStack (Fix4 (Instr o) xs (Succ n) r a -> Fix4 (Instr o) xs (Succ n) r a, Fix4 (Instr o) (x : xs) (Succ n) r a) makeΦ m | elidable m = return $! (id, m)   where-    -- This is double-φ optimisation:   If a φ-node points directly to another φ-node, then it can be elided+    -- This is double-φ optimisation:   If a φ-node points shallowly to another φ-node, then it can be elided     elidable (In4 (Join _)) = True-    -- This is terminal-φ optimisation: If a φ-node points directly to a terminal operation, then it can be elided+    -- This is terminal-φ optimisation: If a φ-node points shallowly to a terminal operation, then it can be elided     elidable (In4 Ret)      = True     elidable _              = False makeΦ m = let n = coinsNeeded m in fmap (\φ -> (In4 . MkJoin φ (addCoins n m), drainCoins n (In4 (Join φ)))) askΦ

@@ -16,9 +16,12 @@     algCatch (_, True) k = k     algCatch (k1, _) (k2, _) = (min k1 k2, False) +    -- 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 (Int, Bool)) xs n r a -> (Int, Bool)     alg Ret                                    = (0, False)-    alg (Push _ (Const4 k))                    = (fst k, 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))                     = (fst k + 1, snd k)

@@ -11,7 +11,7 @@ import Parsley.Internal.Backend.Machine.Defunc as Machine (Defunc(USER)) import Parsley.Internal.Core.Defunc            as Core    (Defunc(ID), pattern FLIP_H) -data Instr (o :: rep) (k :: [Type] -> Nat -> Type -> Type -> Type) (xs :: [Type]) (n :: Nat) (r :: Type) (a :: Type) where+data Instr (o :: Type) (k :: [Type] -> Nat -> Type -> Type -> Type) (xs :: [Type]) (n :: Nat) (r :: Type) (a :: Type) where   Ret       :: Instr o k '[x] n x a   Push      :: Machine.Defunc x -> k (x : xs) n r a -> Instr o k xs n r a   Pop       :: k xs n r a -> Instr o k (x : xs) n r a