suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Changed freeNamesIn to use PolyplateM rather than PolyplateSpine

Browse Source 
This sliced the time on part of tocktest to 5% of the previous time, which rather suggests that I should do away with PolyplateSpine.
This commit is contained in:
Neil Brown 2009-04-11 17:53:33 +00:00
parent c8b724d2be
commit 8f943c9ac1
1 changed files with 31 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
transformations/Unnest.hs
View File

@ -45,46 +45,52 @@ unnest =
] ]
type NameMap = Map.Map String A.Name type NameMap = Map.Map String A.Name
type FreeNameOps = ExtOpQ NameMap (ExtOpQ NameMap (ExtOpQS NameMap BaseOp) A.Name) A.SpecType
type FreeNameM = State (Map.Map String A.Name)
type FreeNameOps = ExtOpM FreeNameM (ExtOpMS FreeNameM (ExtOpM FreeNameM BaseOp A.Name)) A.SpecType
-- | Get the set of free names within a block of code. -- | Get the set of free names within a block of code.
freeNamesIn :: PolyplateSpine t FreeNameOps () NameMap => t -> NameMap freeNamesIn :: PolyplateM t FreeNameOps () FreeNameM => t -> NameMap
freeNamesIn = flattenTree . recurse freeNamesIn = flip execState Map.empty . recurse
where where
flattenTree :: Tree (Maybe NameMap) -> NameMap flattenTree :: Tree (Maybe NameMap) -> NameMap
flattenTree = foldl Map.union Map.empty . catMaybes . flatten flattenTree = foldl Map.union Map.empty . catMaybes . flatten
ops :: FreeNameOps ops :: FreeNameOps
ops = baseOp `extOpQS` (ops, doStructured) `extOpQ` doName `extOpQ` doSpecType ops = baseOp `extOpM` doName `extOpMS` (ops, doStructured) `extOpM` doSpecType
recurse :: PolyplateSpine t FreeNameOps () NameMap => t -> Tree (Maybe NameMap) recurse :: PolyplateM t FreeNameOps () FreeNameM => t -> FreeNameM t
recurse = transformSpine ops () recurse = transformM ops ()
descend :: PolyplateSpine t () FreeNameOps NameMap => t -> Tree (Maybe NameMap) descend :: PolyplateM t () FreeNameOps FreeNameM => t -> FreeNameM t
descend = transformSpine () ops descend = transformM () ops
ignore :: t -> NameMap ignore :: t -> NameMap
ignore s = Map.empty ignore s = Map.empty
doName :: A.Name -> NameMap doName :: A.Name -> FreeNameM A.Name
doName n = Map.singleton (A.nameName n) n doName n = modify (Map.insert (A.nameName n) n) >> return n
doStructured :: (Data a, PolyplateSpine (A.Structured a) () FreeNameOps NameMap doStructured :: (Data a, PolyplateM (A.Structured a) () FreeNameOps FreeNameM
, PolyplateSpine (A.Structured a) FreeNameOps () NameMap) , PolyplateM (A.Structured a) FreeNameOps () FreeNameM
=> A.Structured a -> NameMap )
doStructured (A.Spec _ spec s) = doSpec spec s => A.Structured a -> FreeNameM (A.Structured a)
doStructured s = flattenTree $ descend s doStructured x@(A.Spec _ spec s) = doSpec spec s >> return x
doStructured s = descend s
doSpec :: (PolyplateSpine t () FreeNameOps NameMap doSpec :: (PolyplateM t () FreeNameOps FreeNameM
,PolyplateSpine t FreeNameOps () NameMap) => A.Specification -> t -> NameMap ,PolyplateM t FreeNameOps () FreeNameM) => A.Specification -> t -> FreeNameM ()
doSpec (A.Specification _ n st) child doSpec (A.Specification _ n st) child
= Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child = modify (Map.union $ Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child)
where where
fns = freeNamesIn st fns = freeNamesIn st
doSpecType :: A.SpecType -> NameMap doSpecType :: A.SpecType -> FreeNameM A.SpecType
doSpecType (A.Proc _ _ fs p) = Map.difference (freeNamesIn p) (freeNamesIn fs) doSpecType x@(A.Proc _ _ fs p) = modify (Map.union $ Map.difference (freeNamesIn p) (freeNamesIn fs))
doSpecType (A.Function _ _ _ fs vp) = Map.difference (freeNamesIn vp) (freeNamesIn fs) >> return x
doSpecType st = flattenTree $ descend st doSpecType x@(A.Function _ _ _ fs vp) = modify (Map.union $ Map.difference (freeNamesIn vp) (freeNamesIn fs))
>> return x
doSpecType st = descend st
-- | Replace names. -- | Replace names.
-- --
@ -125,8 +131,7 @@ removeFreeNames = pass "Convert free names to arguments"
(applyBottomUpM2 doSpecification doProcess) (applyBottomUpM2 doSpecification doProcess)
where where
doSpecification :: A.Specification -> PassM A.Specification doSpecification :: A.Specification -> PassM A.Specification
doSpecification spec = case spec of doSpecification (A.Specification m n st@(A.Proc mp sm fs (Just p))) =
A.Specification m n st@(A.Proc mp sm fs p) ->
do -- If this is the top-level process, we shouldn't add new args -- do -- If this is the top-level process, we shouldn't add new args --
-- we know it's not going to be moved by removeNesting, so anything -- we know it's not going to be moved by removeNesting, so anything
-- that it had in scope originally will still be in scope. -- that it had in scope originally will still be in scope.
@ -153,7 +158,7 @@ removeFreeNames = pass "Convert free names to arguments"
-- Add formals for each of the free names -- Add formals for each of the free names
let newFs = [A.Formal am t n | (am, t, n) <- zip3 ams types newNames] let newFs = [A.Formal am t n | (am, t, n) <- zip3 ams types newNames]
st' <- replaceNames (zip freeNames newNames) p >>* A.Proc mp sm (fs ++ newFs) st' <- replaceNames (zip freeNames newNames) p >>* (A.Proc mp sm (fs ++ newFs) . Just)
let spec' = A.Specification m n st' let spec' = A.Specification m n st'
-- Update the definition of the proc -- Update the definition of the proc
@ -171,7 +176,7 @@ removeFreeNames = pass "Convert free names to arguments"
modify $ (\ps -> ps { csAdditionalArgs = Map.insert (A.nameName n) newAs (csAdditionalArgs ps) }) modify $ (\ps -> ps { csAdditionalArgs = Map.insert (A.nameName n) newAs (csAdditionalArgs ps) })
return spec' return spec'
_ -> return spec doSpecification spec = return spec
-- | Return whether a 'Name' could be considered a free name. -- | Return whether a 'Name' could be considered a free name.
-- --