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

Make applyToOnly more general, and use it in more places.

Browse Source 
This simplifies several bits of code that are doing things with Structureds.
This commit is contained in:
Adam Sampson 2008-05-25 22:36:54 +00:00
parent 6debf9292f
commit a7877ecd68
5 changed files with 70 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
backends/BackendPasses.hs
View File

@ -50,7 +50,7 @@ transformWaitFor = applyDepthM doAlt
where
doAlt :: A.Process -> PassM A.Process
doAlt a@(A.Alt m pri s)
= do (s',(specs,code)) <- runStateT (applyToOnly doWaitFor s) ([],[])
= do (s',(specs,code)) <- runStateT (transformOnly doWaitFor s) ([],[])
if (null specs && null code)
then return a
else return $ A.Seq m $ foldr addSpec (A.Several m (code ++ [A.Only m $ A.Alt m pri s'])) specs
@ -59,8 +59,8 @@ transformWaitFor = applyDepthM doAlt
addSpec :: Data a => (A.Structured a -> A.Structured a) -> A.Structured a -> A.Structured a
addSpec spec inner = spec inner
doWaitFor :: A.Alternative -> StateT ([A.Structured A.Process -> A.Structured A.Process], [A.Structured A.Process]) PassM A.Alternative
doWaitFor a@(A.Alternative m cond tim (A.InputTimerFor m' e) p)
doWaitFor :: Meta -> A.Alternative -> StateT ([A.Structured A.Process -> A.Structured A.Process], [A.Structured A.Process]) PassM (A.Structured A.Alternative)
doWaitFor m'' a@(A.Alternative m cond tim (A.InputTimerFor m' e) p)
= do (specs, init) <- get
id <- lift $ makeNonce "waitFor"
let n = (A.Name m A.VariableName id)
@ -69,9 +69,9 @@ transformWaitFor = applyDepthM doAlt
init ++ [A.Only m $ A.Input m tim
(A.InputTimerRead m (A.InVariable m var)),
A.Only m $ A.Assign m [var] $ A.ExpressionList m [A.Dyadic m A.Plus (A.ExprVariable m var) e]])
return $ A.Alternative m cond tim (A.InputTimerAfter m' (A.ExprVariable m' var)) p
return $ A.Only m'' $ A.Alternative m cond tim (A.InputTimerAfter m' (A.ExprVariable m' var)) p
doWaitFor a = return a
doWaitFor m a = return $ A.Only m a
append_sizes :: A.Name -> A.Name
append_sizes n = n {A.nameName = A.nameName n ++ "_sizes"}

41
frontends/OccamTypes.hs
View File

@ -516,29 +516,15 @@ checkNamesDistinct m ns
dupes :: [A.Name]
dupes = nub (ns \\ nub ns)
-- | Check a 'Replicator'.
checkReplicator :: Check A.Replicator
checkReplicator (A.For _ _ start count)
= do checkExpressionInt start
checkExpressionInt count
checkReplicator (A.ForEach _ _ e)
= do t <- astTypeOf e
checkSequence (findMeta e) t
-- | Check a 'Structured', applying the given check to each item found inside
-- it. This assumes that processes and specifications will be checked
-- elsewhere.
checkStructured :: Data t => Check t -> Check (A.Structured t)
checkStructured doInner (A.Rep _ rep s)
= checkReplicator rep >> checkStructured doInner s
checkStructured doInner (A.Spec _ spec s)
= checkStructured doInner s
checkStructured doInner (A.ProcThen _ p s)
= checkStructured doInner s
checkStructured doInner (A.Only _ i)
= doInner i
checkStructured doInner (A.Several _ ss)
= mapM_ (checkStructured doInner) ss
checkStructured doInner s = transformOnly checkInner s >> return ()
where
checkInner m v
= do doInner v
return $ A.Only m v
--}}}
--{{{ retyping checks
@ -1018,7 +1004,8 @@ checkTypes t =
checkVariables t >>=
checkExpressions >>=
checkSpecTypes >>=
checkProcesses
checkProcesses >>=
checkReplicators
--{{{ checkVariables
@ -1305,6 +1292,20 @@ checkProcesses = checkDepthM doProcess
A.Any -> checkCommunicable (findMeta e) t
_ -> checkType (findMeta e) wantT t
--}}}
--{{{ checkReplicators
checkReplicators :: PassType
checkReplicators = checkDepthM doReplicator
where
doReplicator :: Check A.Replicator
doReplicator (A.For _ _ start count)
= do checkExpressionInt start
checkExpressionInt count
doReplicator (A.ForEach _ _ e)
= do t <- astTypeOf e
checkSequence (findMeta e) t
--}}}
--}}}

17
pass/Pass.hs
View File

@ -31,6 +31,7 @@ import System.IO
import qualified AST as A
import CompState
import Errors
import Metadata
import PrettyShow
import TreeUtils
import Utils
@ -155,12 +156,16 @@ debugAST p
veryDebug $ pshow ps
veryDebug $ "}}}"
applyToOnly :: (Monad m, Data a) => (a -> m a) -> A.Structured a -> m (A.Structured a)
applyToOnly f (A.Rep m r s) = applyToOnly f s >>* A.Rep m r
applyToOnly f (A.Spec m sp s) = applyToOnly f s >>* A.Spec m sp
applyToOnly f (A.ProcThen m p s) = applyToOnly f s >>* A.ProcThen m p
applyToOnly f (A.Several m ss) = mapM (applyToOnly f) ss >>* A.Several m
applyToOnly f (A.Only m o) = f o >>* A.Only m
-- | Transform the 'A.Only' items in a 'A.Structured'.
-- This can be used to convert one kind of 'A.Structured' into another.
transformOnly :: (Monad m, Data a, Data b) =>
(Meta -> a -> m (A.Structured b))
-> A.Structured a -> m (A.Structured b)
transformOnly f (A.Rep m r s) = transformOnly f s >>* A.Rep m r
transformOnly f (A.Spec m sp s) = transformOnly f s >>* A.Spec m sp
transformOnly f (A.ProcThen m p s) = transformOnly f s >>* A.ProcThen m p
transformOnly f (A.Several m ss) = mapM (transformOnly f) ss >>* A.Several m
transformOnly f (A.Only m o) = f m o
excludeConstr :: (Data a, CSMR m) => [Constr] -> a -> m a
excludeConstr cons x

77
transformations/SimplifyComms.hs
View File

@ -145,58 +145,35 @@ transformInputCase = applyDepthM doProcess
return (A.Alt m pri s')
doProcess p = return p
-- Can't easily use generics here as we're switching from one type of Structured to another
-- Convert Structured Variant into the equivalent Structured Option.
doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
-- These entries all just burrow deeper into the structured:
doStructuredV v (A.ProcThen m p s)
= do s' <- doStructuredV v s
return (A.ProcThen m p s')
doStructuredV v (A.Spec m sp st)
= do st' <- doStructuredV v st
return (A.Spec m sp st')
doStructuredV v (A.Several m ss)
= do ss' <- mapM (doStructuredV v) ss
return (A.Several m ss')
doStructuredV v (A.Rep m rep s)
= do s' <- doStructuredV v s
return (A.Rep m rep s')
-- Transform variant options:
doStructuredV chanVar (A.Only m (A.Variant m' n iis p))
= do (Right items) <- protocolItems chanVar
let (Just idx) = elemIndex n (fst $ unzip items)
return $ A.Only m $ A.Option m' [makeConstant m' idx] $
if (length iis == 0)
then p
else A.Seq m' $ A.Several m'
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis),
A.Only (findMeta p) p]
doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
-- TODO use generics instead of this boilerplate
doStructuredA (A.ProcThen m p s)
= do s' <- doStructuredA s
return (A.ProcThen m p s')
doStructuredA (A.Spec m sp st)
= do st' <- doStructuredA st
return (A.Spec m sp st')
doStructuredA (A.Several m ss)
= do ss' <- mapM doStructuredA ss
return (A.Several m ss')
doStructuredA (A.Rep m rep s)
= do s' <- doStructuredA s
return (A.Rep m rep s')
doStructuredV chanVar = transformOnly transform
where
transform m (A.Variant m' n iis p)
= do (Right items) <- protocolItems chanVar
let (Just idx) = elemIndex n (fst $ unzip items)
return $ A.Only m $ A.Option m' [makeConstant m' idx] $
if length iis == 0
then p
else A.Seq m' $ A.Several m'
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis),
A.Only (findMeta p) p]
-- Transform alt guards.
doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
doStructuredA = transformOnly doAlternative
where
-- The processes that are the body of input-case guards are always
-- skip, so we can discard them.
doAlternative m (A.Alternative m' e v (A.InputCase m'' s) _)
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original
s' <- doStructuredV v s
return $ A.Spec m' spec $ A.Only m $
A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
-- Leave other guards untouched.
doAlternative m a = return $ A.Only m a
-- Transform alt guards:
-- The processes that are the body of input-case guards are always skip, so we can discard them:
doStructuredA (A.Only m (A.Alternative m' e v (A.InputCase m'' s) _))
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.VariableName A.Original
s' <- doStructuredV v s
return $ A.Spec m' spec $ A.Only m $
A.Alternative m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
-- Leave other guards (and parts of Structured) untouched:
doStructuredA s = return s
transformProtocolInput :: PassType
transformProtocolInput = applyDepthM2 doProcess doAlternative
where

21
transformations/SimplifyProcs.hs
View File

@ -50,21 +50,12 @@ parsToProcs = applyDepthM doProcess
-- FIXME This should be generic and in Pass.
doStructured :: A.Structured A.Process -> PassM (A.Structured A.Process)
doStructured (A.Rep m r s)
= do s' <- doStructured s
return $ A.Rep m r s'
doStructured (A.Spec m spec s)
= do s' <- doStructured s
return $ A.Spec m spec s'
doStructured (A.ProcThen m p s)
= do s' <- doStructured s
return $ A.ProcThen m p s'
doStructured (A.Only m p)
= do s@(A.Specification _ n _) <- makeNonceProc m p
modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) })
return $ A.Spec m s (A.Only m (A.ProcCall m n []))
doStructured (A.Several m ss)
= liftM (A.Several m) $ mapM doStructured ss
doStructured = transformOnly wrapProcess
where
wrapProcess m p
= do s@(A.Specification _ n _) <- makeNonceProc m p
modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) })
return $ A.Spec m s (A.Only m (A.ProcCall m n []))
-- | Turn parallel assignment into multiple single assignments through temporaries.
removeParAssign :: PassType