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