diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index 812459b..38de331 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -41,7 +41,7 @@ import Types import Utils -- | Occam-specific frontend passes. -occamPasses :: [Pass] +occamPasses :: [Pass A.AST] occamPasses = [ occamOnlyPass "Dummy occam pass" [] (Prop.agg_namesDone ++ [Prop.mainTagged]) return , addDirections @@ -105,11 +105,11 @@ writeIncFile = occamOnlyPass "Write .inc file" [] [] doubleStars cs = concat [if c == '*' then "**" else [c] | c <- cs] -- | Fixed the types of array constructors according to the replicator count -fixConstructorTypes :: Pass +fixConstructorTypes :: PassOn A.Expression fixConstructorTypes = occamOnlyPass "Fix the types of array constructors" [Prop.constantsFolded] [Prop.arrayConstructorTypesDone] - (applyDepthM doExpression) + (applyBottomUpM doExpression) where doExpression :: A.Expression -> PassM A.Expression doExpression (A.Literal m prevT lit@(A.ArrayListLiteral _ expr)) @@ -144,11 +144,11 @@ fixConstructorTypes = occamOnlyPass "Fix the types of array constructors" doExpression e = return e -- | Handle ambiguities in the occam syntax that the parser can't resolve. -resolveAmbiguities :: Pass +resolveAmbiguities :: PassOn A.ExpressionList resolveAmbiguities = occamOnlyPass "Resolve ambiguities" [Prop.inferredTypesRecorded] [Prop.ambiguitiesResolved] - (applyDepthM doExpressionList) + (applyBottomUpM doExpressionList) where doExpressionList :: Transform A.ExpressionList -- A single function call inside an ExpressionList is actually a @@ -160,11 +160,11 @@ resolveAmbiguities = occamOnlyPass "Resolve ambiguities" doExpressionList e = return e -- | Fold constant expressions. -foldConstants :: Pass +foldConstants :: PassOn2 A.Expression A.Specification foldConstants = occamOnlyPass "Fold constants" [Prop.inferredTypesRecorded] [Prop.constantsFolded] - (applyDepthM2 doExpression doSpecification) + (applyBottomUpM2 doExpression doSpecification) where -- Try to fold all expressions we encounter. Since we've recursed into the -- expression first, this'll also fold subexpressions of non-constant @@ -191,11 +191,11 @@ foldConstants = occamOnlyPass "Fold constants" return s -- | Check that things that must be constant are. -checkConstants :: Pass +checkConstants :: PassOn2 A.Dimension A.Option checkConstants = occamOnlyPass "Check mandatory constants" [Prop.constantsFolded, Prop.arrayConstructorTypesDone] [Prop.constantsChecked] - recurse + (applyDepthM2 doDimension doOption) where ops = baseOp `extOp` doType `extOp` doOption diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index a24591f..4f8b12a 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -636,29 +636,42 @@ inferAllocMobile _ _ e = return e --{{{ inferTypes +-- I can't put this in the where clause of inferTypes, so it has to be out +-- here. It should be the type of ops inside the inferTypes function below. +type InferTypeOps + = BaseOp + `ExtOpMP` A.Expression + `ExtOpMP` A.Dimension + `ExtOpMP` A.Subscript + `ExtOpMP` A.ArrayConstr + `ExtOpMP` A.Replicator + `ExtOpMP` A.Alternative + `ExtOpMP` A.InputMode + `ExtOpMP` A.Specification + `ExtOpMP` A.Process + `ExtOpMP` A.Variable + -- | Infer types. -inferTypes :: Pass +inferTypes :: Pass A.AST inferTypes = occamOnlyPass "Infer types" [] [Prop.inferredTypesRecorded] recurse where - ops :: Ops ops = baseOp `extOp` doExpression `extOp` doDimension `extOp` doSubscript + `extOp` doArrayConstr `extOp` doReplicator `extOp` doAlternative - `extOpS` doStructured + `extOp` doInputMode + `extOp` doSpecification `extOp` doProcess `extOp` doVariable - `extOp` doVariant - recurse :: Recurse - recurse = makeRecurse ops - descend :: Descend - descend = makeDescend ops + descend :: DescendM PassM InferTypeOps + descend = makeDescendM ops doExpression :: Transform A.Expression doExpression outer @@ -753,19 +766,8 @@ inferTypes = occamOnlyPass "Infer types" where direct = error "Cannot direct channels passed to FUNCTIONs" - opsMatch (opA, _, tsA) (opB, _, tsB) = (opA == opB) && (tsA `typesEqForOp` tsB) - - typesEqForOp :: [A.Type] -> [A.Type] -> Bool - typesEqForOp tsA tsB = (length tsA == length tsB) && (and $ zipWith typeEqForOp tsA tsB) - - typeEqForOp :: A.Type -> A.Type -> Bool - typeEqForOp (A.Array ds t) (A.Array ds' t') - = (length ds == length ds') && typeEqForOp t t' - typeEqForOp t t' = t == t' - - doActuals :: Data a => Meta -> A.Name -> [A.Formal] -> (Meta -> A.Direction -> Transform a) - -> Transform [a] - doActuals m n fs applyDir as + doActuals :: Data a => Meta -> A.Name -> [A.Formal] -> Transform [a] + doActuals m n fs as = do checkActualCount m n fs as sequence [doActual m applyDir t a | (A.Formal _ t _, a) <- zip fs as] @@ -1254,20 +1256,27 @@ inferTypes = occamOnlyPass "Infer types" -- | Check the AST for type consistency. -- This is actually a series of smaller passes that check particular types -- inside the AST, but it doesn't really make sense to split it up. -checkTypes :: Pass +checkTypes :: + (PolyplateSpine t (OneOpQ (PassM ()) A.Variable) () (PassM ()) + ,PolyplateSpine t (OneOpQ (PassM ()) A.Expression) () (PassM ()) + ,PolyplateSpine t (OneOpQ (PassM ()) A.SpecType) () (PassM ()) + ,PolyplateSpine t (OneOpQ (PassM ()) A.Process) () (PassM ()) + ) => Pass t checkTypes = occamOnlyPass "Check types" [Prop.inferredTypesRecorded, Prop.ambiguitiesResolved] [Prop.expressionTypesChecked, Prop.processTypesChecked, Prop.functionTypesChecked, Prop.retypesChecked] - ( checkVariables >.> - checkExpressions >.> - checkSpecTypes >.> - checkProcesses + (\x -> do + checkVariables x + checkExpressions x + checkSpecTypes x + checkProcesses x + return x ) --{{{ checkVariables -checkVariables :: PassType +checkVariables :: PlainCheckOn A.Variable checkVariables = checkDepthM doVariable where doVariable :: Check A.Variable @@ -1297,7 +1306,7 @@ checkVariables = checkDepthM doVariable --}}} --{{{ checkExpressions -checkExpressions :: PassType +checkExpressions :: PlainCheckOn A.Expression checkExpressions = checkDepthM doExpression where doExpression :: Check A.Expression @@ -1349,7 +1358,7 @@ checkExpressions = checkDepthM doExpression --}}} --{{{ checkSpecTypes -checkSpecTypes :: PassType +checkSpecTypes :: PlainCheckOn A.SpecType checkSpecTypes = checkDepthM doSpecType where doSpecType :: Check A.SpecType @@ -1470,7 +1479,7 @@ checkSpecTypes = checkDepthM doSpecType --}}} --{{{ checkProcesses -checkProcesses :: PassType +checkProcesses :: PlainCheckOn A.Process checkProcesses = checkDepthM doProcess where doProcess :: Check A.Process