parsley-core 2.2.0.0 → 2.2.0.1
raw patch · 3 files changed
+200/−193 lines, 3 files
Files
- ChangeLog.md +109/−105
- parsley-core.cabal +2/−2
- src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs +89/−86
ChangeLog.md view
@@ -1,61 +1,90 @@ # Revision history for `parsley-core` -## 1.0.0.0 -- 2021-06-12+## 2.2.0.1 -- 2023-04-26 -* First version. Released on an unsuspecting world.-* Core factored out of the main `parsley` package+* Improved the free register analysis by reimplementing in terms of lambda-lifting algorithms. -## 1.0.1.0 -- 2021-06-26+## 2.2.0.0 -- 2022-08-03 -* Introduced `Lam` to the API and conversion functions for `Core.Defunc`-* Extra type ascriptions added to generated code+* Removed `RangeSet`, as this now resides in `rangeset`. -## 1.0.1.1 -- 2021-06-27+## 2.1.0.1 -- 2022-06-01 -* Added input factoring to `try p <|> q` and also forms with `f <$> try p <|> q` and `try p $> x <|> q`+* Added normalisation rule for lets in `Lam`.+* Added GHC 9.2 support. -## 1.1.0.0 -- 2021-07-01+## 2.1.0.0 -- 2022-01-12 -* Switched both backends to make use of `Lam` instead of `Core.Defunc`, reducing burden on GHC-* Added duplication avoidance optimisation when value to be duplicated is `Lam.Var True`+* Added `RangeSet` datastructure.+* Added `Pos` module for static manipulation of position information.+* Added `CharPred` as a specialised defunctionalisation of `Char -> Bool` functions.+* Moved `InputCharacteristic` to its own module.+* Use `CharPred` for `Sat` and `Satisfy`.+* Simplified the interface for `Ops.sat`.+* Simplified `buildYesHandler` and allowed it to capture a statically annotated offset.+* Introduced `buildIterYesHandler` which can capture static offet.+* Changed types of `bindSameHandler` and `bindIterSame`.+* Added `StaYesHandler` type to `Ops`.+* Renamed `updatePos` to `updatePosQ`.+* Added many methods for manipulating positions to `PosOps`.+* Made `initPos` fully static.+* Changed the type of `readChar`.+* Hid some internals of `Input`.+* Exposed some new methods for `Input`.+* Added `INPUT` to 8.6+ backend for `Defunc`.+* Added a `poke` method to `QueueLike`.+* Added a `charPred` converter to `Defunc`. -## 1.2.0.0 -- 2021-07-01+## 2.0.0.0 -- 2021-11-24 -* For GHC 8.10+, leveraged the static structure of functions:- * Handlers are now static functions, reducing the beta-reduction required by GHC, `fatal` now generates better code- * Return continuations are also static functions, reducing beta-reduction required by GHC, `halt` generates better code- * Recursive calls are also static functions, removing a lot of junk with the conversion from iterators to recursion-* Registers are now bound once for recursive parsers, which close over their free-registers-* Strictness has been updated to reflect the reduced burden on GHC to optimise: now strictness is for performance, and- not to coax GHC to optimise at the cost of performance-* Removed the "bad" binding for `Sat`, handlers are always bound on creation, so the binding is basically meaningless-* Performance on 8.10+ is anywhere from 10-20% faster than 1.1.0.0+* Removed `compile`, `eval`, `codeGen` from the API.+* Removed `chainPre` and `chainPost` from the API.+* Added `Typeable` constraint to `LIFTED`.+* Removed `lamTermBool` and `userBool` from the API: `Typeable` subsumes them.+* Added `RANGES` to the `Defunc` API. -## 1.2.0.1 -- 2021-07-03+## 1.8.0.0 -- 2021-11-13 -* Added Jump-Elision optimisation to the code generator.+* Reversed order of arguments on `Subroutine#`, offset comes last.+* Added `Pos` type, and threaded it through+* Added `Input o` and `Input# o`, which package an `Offset o` or `Code (Rep o)` with `Pos` information.+* Added cabal flag to control the packed or unpacked representation of positions+* Added `PosSelector`+* Added `line` and `col` to primitives and `Position` to Combinator AST, as well as `SelectPos` to instructions.+* Changed `OFFSET` to `INPUT` in `Defunc` -## 1.3.0.0 -- 2021-07-03+## 1.7.2.0 -- 2021-10-31 -* Improved the `Lam` reduction algorithm-* Preliminary support for `if true` reduction from `item` and `const True`-* Introduced `_if` and `ap` in `Machine.Defunc`, removed `genDefunc1`+* 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`). -## 1.4.0.0 -- 2021-07-22-NOTE: The API exposed to `parsley` has changed, however, the changed types match up-and the underlying types are not exposed. This means that `parsley` cannot write-the type down to begin with, so the API change does not _actually_ result in any-backward incompatiblity _unless_ the `Parsley.Internal.*` modules are imported:-this meets requirements for internal major change.+## 1.7.1.1 -- 2021-10-30 -* Removed an `unsafeCoerce` from register creation, using more existentials.-* Changed `CharList`'s `more` check to test for `[]` and not length (faster!)-* Added static information to offset in the machine-* Leveraged static information to refine handlers at compile time, offering up- to 20% performance improvement-* Code restructuring and refactoring-* Added copious amounts of documentation+* Improved eta-reduction to handle multiple arguments.+* Added eta-reduction to constructed return continutations. +## 1.7.1.0 -- 2021-10-29++* Moved `parse` into core API, this will reduce the area of incompatibility.+* Added `loop` combinator.++## 1.7.0.0 -- 2021-10-28++* Added fields to the handlers to signify if they should generate a binding or not.+* Added two `Inliner` modules to handle inlining in front- and back-ends.+* Removed field from `Let` which contains the body, it was a wart.+* Refactored the internal representation of static handlers, making them more uniform.+* Added basic eta-reduction capabilities to the low-level generators: this can be improved and expanded!+* Renamed `buildIterAlways` and `buildIterSame` to `bindIterAlways` and `bindIterSame`.+* Renamed `StaHandler` to `AugmentedStaHandler`.++## 1.6.0.0 -- 2021-08-13+Fix for issue #27++* Added `BlockCoins` instruction and `CutImmune` node.+* Changed how cut compliance is determined, and stopped some incorrect factoring.+* Removed unneeded flags for analysis.+ ## 1.5.0.0 -- 2021-08-12 Infrastructure for improved handler analysis: @@ -90,83 +119,58 @@ * Added auxilliary information parameter to `sat`. * Added `fetch` and broke it out of `sat`. -## 1.6.0.0 -- 2021-08-13-Fix for issue #27--* Added `BlockCoins` instruction and `CutImmune` node.-* Changed how cut compliance is determined, and stopped some incorrect factoring.-* Removed unneeded flags for analysis.--## 1.7.0.0 -- 2021-10-28--* Added fields to the handlers to signify if they should generate a binding or not.-* Added two `Inliner` modules to handle inlining in front- and back-ends.-* Removed field from `Let` which contains the body, it was a wart.-* Refactored the internal representation of static handlers, making them more uniform.-* Added basic eta-reduction capabilities to the low-level generators: this can be improved and expanded!-* Renamed `buildIterAlways` and `buildIterSame` to `bindIterAlways` and `bindIterSame`.-* Renamed `StaHandler` to `AugmentedStaHandler`.--## 1.7.1.0 -- 2021-10-29+## 1.4.0.0 -- 2021-07-22+NOTE: The API exposed to `parsley` has changed, however, the changed types match up+and the underlying types are not exposed. This means that `parsley` cannot write+the type down to begin with, so the API change does not _actually_ result in any+backward incompatiblity _unless_ the `Parsley.Internal.*` modules are imported:+this meets requirements for internal major change. -* Moved `parse` into core API, this will reduce the area of incompatibility.-* Added `loop` combinator.+* Removed an `unsafeCoerce` from register creation, using more existentials.+* Changed `CharList`'s `more` check to test for `[]` and not length (faster!)+* Added static information to offset in the machine+* Leveraged static information to refine handlers at compile time, offering up+ to 20% performance improvement+* Code restructuring and refactoring+* Added copious amounts of documentation -## 1.7.1.1 -- 2021-10-30+## 1.3.0.0 -- 2021-07-03 -* Improved eta-reduction to handle multiple arguments.-* Added eta-reduction to constructed return continutations.+* Improved the `Lam` reduction algorithm+* Preliminary support for `if true` reduction from `item` and `const True`+* Introduced `_if` and `ap` in `Machine.Defunc`, removed `genDefunc1` -## 1.7.2.0 -- 2021-10-31+## 1.2.0.1 -- 2021-07-03 -* 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`).+* Added Jump-Elision optimisation to the code generator. -## 1.8.0.0 -- 2021-11-13+## 1.2.0.0 -- 2021-07-01 -* Reversed order of arguments on `Subroutine#`, offset comes last.-* Added `Pos` type, and threaded it through-* Added `Input o` and `Input# o`, which package an `Offset o` or `Code (Rep o)` with `Pos` information.-* Added cabal flag to control the packed or unpacked representation of positions-* Added `PosSelector`-* Added `line` and `col` to primitives and `Position` to Combinator AST, as well as `SelectPos` to instructions.-* Changed `OFFSET` to `INPUT` in `Defunc`+* For GHC 8.10+, leveraged the static structure of functions:+ * Handlers are now static functions, reducing the beta-reduction required by GHC, `fatal` now generates better code+ * Return continuations are also static functions, reducing beta-reduction required by GHC, `halt` generates better code+ * Recursive calls are also static functions, removing a lot of junk with the conversion from iterators to recursion+* Registers are now bound once for recursive parsers, which close over their free-registers+* Strictness has been updated to reflect the reduced burden on GHC to optimise: now strictness is for performance, and+ not to coax GHC to optimise at the cost of performance+* Removed the "bad" binding for `Sat`, handlers are always bound on creation, so the binding is basically meaningless+* Performance on 8.10+ is anywhere from 10-20% faster than 1.1.0.0 -## 2.0.0.0 -- 2021-11-24+## 1.1.0.0 -- 2021-07-01 -* Removed `compile`, `eval`, `codeGen` from the API.-* Removed `chainPre` and `chainPost` from the API.-* Added `Typeable` constraint to `LIFTED`.-* Removed `lamTermBool` and `userBool` from the API: `Typeable` subsumes them.-* Added `RANGES` to the `Defunc` API.+* Switched both backends to make use of `Lam` instead of `Core.Defunc`, reducing burden on GHC+* Added duplication avoidance optimisation when value to be duplicated is `Lam.Var True` -## 2.1.0.0 -- 2022-01-12+## 1.0.1.1 -- 2021-06-27 -* Added `RangeSet` datastructure.-* Added `Pos` module for static manipulation of position information.-* Added `CharPred` as a specialised defunctionalisation of `Char -> Bool` functions.-* Moved `InputCharacteristic` to its own module.-* Use `CharPred` for `Sat` and `Satisfy`.-* Simplified the interface for `Ops.sat`.-* Simplified `buildYesHandler` and allowed it to capture a statically annotated offset.-* Introduced `buildIterYesHandler` which can capture static offet.-* Changed types of `bindSameHandler` and `bindIterSame`.-* Added `StaYesHandler` type to `Ops`.-* Renamed `updatePos` to `updatePosQ`.-* Added many methods for manipulating positions to `PosOps`.-* Made `initPos` fully static.-* Changed the type of `readChar`.-* Hid some internals of `Input`.-* Exposed some new methods for `Input`.-* Added `INPUT` to 8.6+ backend for `Defunc`.-* Added a `poke` method to `QueueLike`.-* Added a `charPred` converter to `Defunc`.+* Added input factoring to `try p <|> q` and also forms with `f <$> try p <|> q` and `try p $> x <|> q` -## 2.1.0.1 -- 2022-06-01+## 1.0.1.0 -- 2021-06-26 -* Added normalisation rule for lets in `Lam`.-* Added GHC 9.2 support.+* Introduced `Lam` to the API and conversion functions for `Core.Defunc`+* Extra type ascriptions added to generated code -## 2.2.0.0 -- 2022-08-03+## 1.0.0.0 -- 2021-06-12 -* Removed `RangeSet`, as this now resides in `rangeset`.+* First version. Released on an unsuspecting world.+* Core factored out of the main `parsley` package
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.0+version: 2.2.0.1 synopsis: A fast parser combinator library backed by Typed Template Haskell description: This package contains the internals of the @parsley@ package. .@@ -143,7 +143,7 @@ text >= 1.2.3 && < 1.3, -- 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.1+ rangeset >= 0.0.1 && < 0.2, build-tool-depends: cpphs:cpphs >= 1.18.8 && < 1.21 hs-source-dirs: src/ghc if impl(ghc >= 8.10)
src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs view
@@ -14,27 +14,32 @@ -} module Parsley.Internal.Frontend.Analysis.Dependencies (dependencyAnalysis) where -import Control.Arrow (first, second) import Control.Monad (unless, forM_)-import Data.Array (Array, (!), listArray)-import Data.Array.MArray (readArray, writeArray, newArray)-import Data.Array.ST (runSTUArray)-import Data.Array.Unboxed (assocs)+import Control.Monad.ST (ST)+import Data.Array (Array)+import Data.Array.MArray (readArray, writeArray, newArray, newArray_)+import Data.Array.ST (STArray, runSTUArray, runSTArray)+import Data.Array.Unboxed (UArray)+import Data.Bifunctor (first, second) import Data.Dependent.Map (DMap)-import Data.List (foldl', partition, sortOn)+import Data.Foldable (foldl') import Data.Map.Strict (Map)-import Data.Set (Set, insert, (\\), union, notMember, empty)+import Data.Set (Set) import Data.STRef (newSTRef, readSTRef, writeSTRef) import Parsley.Internal.Common.Indexed (Fix, cata, Const1(..), (:*:)(..), zipper) import Parsley.Internal.Common.State (State, MonadState, execState, modify') import Parsley.Internal.Core.CombinatorAST (Combinator(..), traverseCombinator) import Parsley.Internal.Core.Identifiers (IMVar, MVar(..), ΣVar, SomeΣVar(..)) -import qualified Data.Dependent.Map as DMap (foldrWithKey, filterWithKey)-import qualified Data.Map.Strict as Map ((!), empty, insert, mapMaybeWithKey, findMax, elems, lookup)-import qualified Data.Set as Set (elems, empty, insert)+import qualified Data.Dependent.Map as DMap (foldrWithKey, filterWithKey)+import qualified Data.Map.Strict as Map ((!), empty, insert, findMax, elems, maxView, fromList, fromDistinctAscList)+import qualified Data.Set as Set (toList, insert, union, unions, member, notMember, empty, (\\), fromDistinctAscList, size)+import qualified Data.Array as Array ((!), listArray, bounds, indices)+import qualified Data.Array.Unboxed as UArray ((!), assocs)+import qualified Data.List as List (partition) type Graph = Array IMVar [IMVar]+type PQueue k a = Map k a {-| Given a top-level parser and a collection of its let-bound subjects performs the following tasks:@@ -57,103 +62,102 @@ roots = directDependencies toplevel -- Step 2: build immediate dependencies DependencyMaps{..} = buildDependencyMaps μs- -- Step 3: find the largest name- n = fst (Map.findMax immediateDependencies)- -- Step 4: Build a dependency graph- graph = buildGraph n immediateDependencies- -- Step 5: construct the seen set (dfnum)- -- Step 6: dfs from toplevel (via roots) all with same seen set- -- Step 7: elems of seen set with dfnum 0 are dead, otherwise they are collected into a list in descending order- (topo, dead) = topoOrdering roots n graph- -- Step 8: perform a dfs on each of the topo, with a new seen set for each,- -- building the flattened dependency map. If the current focus has- -- already been computed, add all its deps to the seen set and skip.- -- The end seen set becomes out flattened deps.- trueDeps = flattenDependencies topo (minMax topo) graph- -- Step 8: Compute the new registers, and remove dead ones- addNewRegs v uses- | notMember v dead = let deps = trueDeps Map.! v- defs = definedRegisters Map.! v- subUses = foldMap (usedRegisters Map.!) deps- subDefs = foldMap (definedRegisters Map.!) deps- in Just $ (uses \\ defs) `union` (subUses \\ subDefs)- | otherwise = Nothing- trueRegs = Map.mapMaybeWithKey addNewRegs usedRegisters- in (DMap.filterWithKey (\(MVar v) _ -> notMember v dead) μs, trueRegs)+ -- Step 3: Build a call graph+ callees = buildGraph immediateDependencies+ -- Step 4: traverse the call graph, finding unreachable nodes and establishing a topological dfnum for each node+ (dfnums, lives, dead) = topoOrdering roots callees+ -- Step 5: reverse the call graph to make a callers graph+ callers = invertGraph callers dead+ -- Step 6: iterate over the live registers, and propagate the free registers until fix-point+ regs = propagateRegs lives dfnums usedRegisters definedRegisters callees callers+ in (DMap.filterWithKey (\(MVar v) _ -> Set.notMember v dead) μs, regs) -minMax :: Ord a => [a] -> (a, a)-minMax [] = error "cannot find minimum or maximum of empty list"-minMax (x:xs) = foldl' (\(small, big) x -> (min small x, max big x)) (x, x) xs+buildGraph :: Map IMVar (Set IMVar) -> Graph+buildGraph deps = Array.listArray (0, fst (Map.findMax deps)) (map Set.toList (Map.elems deps)) -buildGraph :: IMVar -> Map IMVar (Set IMVar) -> Graph-buildGraph n = listArray (0, n) . map Set.elems . Map.elems+invertGraph :: Graph -> Set IMVar -> Graph+invertGraph g unreachable = runSTArray $ do+ g' <- newArray (Array.bounds g) []+ forM_ (Array.indices g) $ \n ->+ unless (Set.member n unreachable) $+ forM_ (g Array.! n) $ \s -> do+ preds <- readArray g' s+ writeArray g' s (n : preds)+ return g' -topoOrdering :: Set IMVar -> IMVar -> Graph -> ([IMVar], Set IMVar)-topoOrdering roots n graph =- let dfnums = runSTUArray $ do- dfnums <- newArray (0, n) (0 :: Int)+type DFNum = Int+topoOrdering :: Set IMVar -> Graph -> (UArray IMVar DFNum, [IMVar], Set IMVar)+topoOrdering roots graph =+ let dfnums :: UArray IMVar DFNum+ dfnums = runSTUArray $ do+ dfnums <- newArray (Array.bounds graph) 0 nextDfnum <- newSTRef 1- let hasSeen v = (/= 0) <$> readArray dfnums v- let setSeen v = do dfnum <- readSTRef nextDfnum- writeArray dfnums v dfnum- writeSTRef nextDfnum (dfnum + 1)- forM_ roots (dfs hasSeen setSeen graph)+ let dfs v = do seen <- (/= 0) <$> readArray dfnums v+ unless seen $+ do dfnum <- readSTRef nextDfnum+ writeArray dfnums v dfnum+ writeSTRef nextDfnum (dfnum + 1)+ forM_ (graph Array.! v) dfs+ -- Assign a DFNum to each IMVar+ forM_ roots dfs return dfnums- (lives, deads) = partition ((/= 0) . snd) (assocs dfnums)- in (reverseMap fst (sortOn snd lives), foldl' (\ds v0 -> Set.insert (fst v0) ds) Set.empty deads)--reverseMap :: (a -> b) -> [a] -> [b]-reverseMap f = foldl' (\xs x -> f x : xs) []+ -- if something still has dfnum 0, it was not visited, and is dead+ lives, deads :: [(IMVar, DFNum)]+ (lives, deads) = List.partition ((/= 0) . snd) (UArray.assocs dfnums)+ -- The DFNums are unique+ in (dfnums, map fst lives, Set.fromDistinctAscList (map fst deads)) -flattenDependencies :: [IMVar] -> (IMVar, IMVar) -> Graph -> Map IMVar (Set IMVar)-flattenDependencies topo range graph = foldl' reachable Map.empty topo+propagateRegs :: [IMVar] -> UArray IMVar DFNum -> Map IMVar (Set SomeΣVar) -> Map IMVar (Set SomeΣVar) -> Graph -> Graph -> Map IMVar (Set SomeΣVar)+propagateRegs reachables dfnums uses defs callees callers = toMap $ runSTArray $+ do freeRegs <- newArray_ (Array.bounds callees)+ forM_ reachables $ \v -> writeArray freeRegs v ((uses Map.! v) Set.\\ (defs Map.! v))+ let worklist = Map.fromList (map (\v -> (dfnums UArray.! v, v)) reachables)+ maybe (return ()) (unfoldM_ (uncurry (propagate freeRegs))) (Map.maxView worklist)+ return freeRegs where- reachable :: Map IMVar (Set IMVar) -> IMVar -> Map IMVar (Set IMVar)- reachable deps root =- let seen = runSTUArray $ do- seen <- newArray range False- let setSeen v = writeArray seen v True- let seenOrSkip v = case Map.lookup v deps of- Nothing -> readArray seen v- Just ds -> setSeen v >> forM_ ds setSeen >> return True- dfs seenOrSkip setSeen graph root- return seen- ds = foldl' (\ds (v, b) -> if b then Set.insert v ds else ds) Set.empty (assocs seen)- in Map.insert root ds deps+ propagate :: STArray s IMVar (Set SomeΣVar) -> IMVar -> PQueue DFNum IMVar -> ST s (Maybe (IMVar, PQueue DFNum IMVar))+ propagate freeRegs v work = do+ !frees <- readArray freeRegs v+ !freesCallees <- Set.unions <$> traverse (readArray freeRegs) (callees Array.! v)+ let !frees' = frees `Set.union` (freesCallees Set.\\ (defs Map.! v))+ if Set.size frees /= Set.size frees' then do+ writeArray freeRegs v frees'+ return (Map.maxView (addWork (callers Array.! v) work))+ else return (Map.maxView work) -dfs :: Monad m => (IMVar -> m Bool) -> (IMVar -> m ()) -> Graph -> IMVar -> m ()-dfs hasSeen setSeen graph = go- where- go v = do seen <- hasSeen v- unless seen $- do setSeen v- forM_ (graph ! v) go+ addWork :: [IMVar] -> PQueue DFNum IMVar -> PQueue DFNum IMVar+ addWork vs work = foldl' (flip (\v -> Map.insert (dfnums UArray.! v) v)) work vs + unfoldM_ :: Monad m => (s -> m (Maybe s)) -> s -> m ()+ unfoldM_ f s = f s >>= mapM_ (unfoldM_ f)++ toMap arr = Map.fromDistinctAscList (map (\v -> (v, arr Array.! v)) reachables)+ -- IMMEDIATE DEPENDENCY MAPS data DependencyMaps = DependencyMaps {- usedRegisters :: Map IMVar (Set SomeΣVar), -- Leave Lazy- immediateDependencies :: Map IMVar (Set IMVar), -- Could be Strict- definedRegisters :: Map IMVar (Set SomeΣVar)+ usedRegisters :: !(Map IMVar (Set SomeΣVar)), -- Leave Lazy+ immediateDependencies :: !(Map IMVar (Set IMVar)), -- Could be Strict+ definedRegisters :: !(Map IMVar (Set SomeΣVar)) } buildDependencyMaps :: DMap MVar (Fix Combinator) -> DependencyMaps buildDependencyMaps = DMap.foldrWithKey (\(MVar v) p deps@DependencyMaps{..} ->- let (frs, defs, ds) = freeRegistersAndDependencies v p- in deps { usedRegisters = Map.insert v frs usedRegisters+ let (uses, defs, ds) = freeRegistersAndDependencies v p+ in deps { usedRegisters = Map.insert v uses usedRegisters , immediateDependencies = Map.insert v ds immediateDependencies , definedRegisters = Map.insert v defs definedRegisters}) (DependencyMaps Map.empty Map.empty Map.empty) freeRegistersAndDependencies :: IMVar -> Fix Combinator a -> (Set SomeΣVar, Set SomeΣVar, Set IMVar) freeRegistersAndDependencies v p = let frsm :*: depsm = zipper freeRegistersAlg (dependenciesAlg (Just v)) p- (frs, defs) = runFreeRegisters frsm+ (uses, defs) = runFreeRegisters frsm ds = runDependencies depsm- in (frs, defs, ds)+ in (uses, defs, ds) -- DEPENDENCY ANALYSIS newtype Dependencies a = Dependencies { doDependencies :: State (Set IMVar) () } runDependencies :: Dependencies a -> Set IMVar-runDependencies = flip execState empty. doDependencies+runDependencies = flip execState Set.empty . doDependencies directDependencies :: Fix Combinator a -> Set IMVar directDependencies = runDependencies . cata (dependenciesAlg Nothing)@@ -165,23 +169,22 @@ dependenciesAlg _ p = Dependencies $ do traverseCombinator (fmap Const1 . doDependencies) p; return () dependsOn :: MonadState (Set IMVar) m => MVar a -> m ()-dependsOn (MVar v) = modify' (insert v)+dependsOn (MVar v) = modify' (Set.insert v) -- FREE REGISTER ANALYSIS newtype FreeRegisters a = FreeRegisters { doFreeRegisters :: State (Set SomeΣVar, Set SomeΣVar) () } runFreeRegisters :: FreeRegisters a -> (Set SomeΣVar, Set SomeΣVar)-runFreeRegisters = flip execState (empty, empty) . doFreeRegisters+runFreeRegisters = flip execState (Set.empty, Set.empty) . doFreeRegisters {-# INLINE freeRegistersAlg #-} freeRegistersAlg :: Combinator FreeRegisters a -> FreeRegisters a freeRegistersAlg (GetRegister σ) = FreeRegisters $ do uses σ freeRegistersAlg (PutRegister σ p) = FreeRegisters $ do uses σ; doFreeRegisters p freeRegistersAlg (MakeRegister σ p q) = FreeRegisters $ do defs σ; doFreeRegisters p; doFreeRegisters q-freeRegistersAlg Let{} = FreeRegisters $ do return () -- TODO This can be removed when Let doesn't have the body in it... freeRegistersAlg p = FreeRegisters $ do traverseCombinator (fmap Const1 . doFreeRegisters) p; return () uses :: MonadState (Set SomeΣVar, vs) m => ΣVar a -> m ()-uses σ = modify' (first (insert (SomeΣVar σ)))+uses σ = modify' (first (Set.insert (SomeΣVar σ))) defs :: MonadState (vs, Set SomeΣVar) m => ΣVar a -> m ()-defs σ = modify' (second (insert (SomeΣVar σ)))+defs σ = modify' (second (Set.insert (SomeΣVar σ)))