diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 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: 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) diff --git a/src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs b/src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs --- a/src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs +++ b/src/ghc/Parsley/Internal/Frontend/Analysis/Dependencies.hs @@ -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 σ)))