diff --git a/common/ShowCode.hs b/common/ShowCode.hs index 9dcbeb8..2c42c97 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -241,6 +241,8 @@ instance ShowOccam A.Type where showOccamM A.Any = tell ["ANY"] showOccamM (A.Timer _) = tell ["TIMER"] showOccamM A.Time = tell ["TIME"] + showOccamM A.Infer = tell ["inferred type"] + showOccamM A.Barrier = tell ["BARRIER"] showOccamM (A.UnknownVarType _ en) = do tell ["(inferred type for: "] either showName (tell . (:[]) . show) en diff --git a/pass/Pass.hs b/pass/Pass.hs index 7e3ec41..dc6a621 100644 --- a/pass/Pass.hs +++ b/pass/Pass.hs @@ -56,8 +56,10 @@ instance Warn PassM where -- against AST fragments of other types as well. type PassType t = t -> PassM t -type PassOnOps ops - = (PolyplateM t ops () PassM, PolyplateM t () ops PassM) => Pass t +type PassOnOpsM m ops + = (PolyplateM t ops () m, PolyplateM t () ops m) => Pass t + +type PassOnOps ops = PassOnOpsM PassM ops type CheckOnOps ops = (PolyplateSpine t ops () (PassM ())) => Pass t diff --git a/pass/Traversal.hs b/pass/Traversal.hs index f7ed0bb..68eac0e 100644 --- a/pass/Traversal.hs +++ b/pass/Traversal.hs @@ -19,7 +19,7 @@ with this program. If not, see . -- | Traversal strategies over the AST and other data types. This is now mainly -- a collection of extra Tock-specific utilities that go on top of Polyplate module Traversal ( - TransformM, Transform, TransformStructured, TransformStructured' + TransformM, Transform, TransformStructured, TransformStructured', TransformStructuredM' , CheckM, Check , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct , ExtOpQS, extOpQS @@ -205,3 +205,7 @@ type TransformStructured ops type TransformStructured' ops = (PolyplateM (A.Structured t) () ops PassM ,PolyplateM (A.Structured t) ops () PassM , Data t) => Transform (A.Structured t) + +type TransformStructuredM' m ops + = (PolyplateM (A.Structured t) () ops m + ,PolyplateM (A.Structured t) ops () m , Data t) => A.Structured t -> m (A.Structured t) diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index 80a692e..db8b844 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -20,7 +20,8 @@ with this program. If not, see . module SimplifyProcs (simplifyProcs, fixLowReplicators) where import Control.Monad.State -import Data.Generics +import Data.Generics (Data) +import Data.Maybe import qualified Data.Set as Set import qualified AST as A @@ -42,18 +43,23 @@ simplifyProcs = , flattenAssign ] +type ForkM = StateT [A.Name] PassM +type ForkOps = ExtOpM ForkM (ExtOpMS ForkM BaseOp) A.Process + -- | Add an extra barrier parameter to every PROC for FORKING -addForkNames :: Pass +addForkNames :: PassOnOpsM ForkM ForkOps addForkNames = occamOnlyPass "Add FORK labels" [] [] (flip evalStateT [] . recurse) where - ops = baseOp `extOpS` doStructured `extOp` doProcess + ops :: ForkOps + ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess - recurse, descend :: Data a => a -> StateT [A.Name] PassM a - recurse = makeRecurse ops - descend = makeDescend ops + recurse :: RecurseM ForkM ForkOps + recurse = makeRecurseM ops + descend :: DescendM ForkM ForkOps + descend = makeDescendM ops - doProcess :: A.Process -> StateT [A.Name] PassM A.Process + doProcess :: A.Process -> ForkM A.Process doProcess (A.Fork m Nothing p) = do (f:_) <- get p' <- recurse p @@ -67,7 +73,7 @@ addForkNames = occamOnlyPass "Add FORK labels" [] [] _ -> return $ A.ProcCall m n (A.ActualVariable (A.Variable m f) : as) doProcess p = descend p - doStructured :: Data a => A.Structured a -> StateT [A.Name] PassM (A.Structured a) + doStructured :: TransformStructuredM' ForkM ForkOps doStructured (A.Spec m spec@(A.Specification _ n (A.Forking _)) scope) = do modify (n:) scope' <- recurse scope diff --git a/transformations/SimplifyTypes.hs b/transformations/SimplifyTypes.hs index 42c9a90..3008311 100644 --- a/transformations/SimplifyTypes.hs +++ b/transformations/SimplifyTypes.hs @@ -46,9 +46,15 @@ resolveNamedTypes (Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.processTypesChecked]) [Prop.typesResolvedInAST, Prop.typesResolvedInState] - (\t -> do get >>= resolve >>= put - resolve t) + (\t -> do get >>= resolve >>= flatten >>= put + resolve t >>= flatten) where resolve :: PassTypeOn A.Type - resolve = applyTopDownM (underlyingType emptyMeta) + resolve = applyTopDownM (resolveUserType emptyMeta) + flatten :: PassTypeOn A.Type + flatten = applyBottomUpM doType + where + doType :: Transform A.Type + doType (A.Array dsA (A.Array dsB t)) = return $ A.Array (dsA++dsB) t + doType t = return t