diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index 6382bda..0ea675c 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -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"} diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index 6868515..e6c5354 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -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 + --}}} --}}} diff --git a/pass/Pass.hs b/pass/Pass.hs index b21818c..d9d9377 100644 --- a/pass/Pass.hs +++ b/pass/Pass.hs @@ -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 diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index 9fab435..f51894f 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -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 diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index e8249f6..feade04 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -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