From 9ed003f9e3975c2505f02b1d2aea34e4a7c9d980 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Wed, 18 Apr 2007 23:13:56 +0000 Subject: [PATCH] Add NoSpecification to AST, to make passes simpler --- fco2/AST.hs | 3 +- fco2/GenerateC.hs | 28 ++++---- fco2/Parse.hs | 52 +++++++-------- fco2/ParseState.hs | 4 +- fco2/Pass.hs | 4 ++ fco2/SimplifyExprs.hs | 4 +- fco2/Unnest.hs | 116 +++++++++++++++------------------ fco2/testcases/expressions.occ | 7 +- 8 files changed, 109 insertions(+), 109 deletions(-) diff --git a/fco2/AST.hs b/fco2/AST.hs index 166e240..5af5b99 100644 --- a/fco2/AST.hs +++ b/fco2/AST.hs @@ -182,7 +182,8 @@ data AbbrevMode = deriving (Show, Eq, Typeable, Data) data Specification = - Specification Name SpecType + Specification Meta Name SpecType + | NoSpecification -- ^ A specification that's been removed by a pass. deriving (Show, Eq, Typeable, Data) data SpecType = diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index 21540f7..af8751c 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -685,7 +685,7 @@ CHAN OF INT c IS d: Channel *c = d; const int *ds_sizes = cs_sizes; -} introduceSpec :: A.Specification -> CGen () -introduceSpec (A.Specification n (A.Declaration m t)) +introduceSpec (A.Specification _ n (A.Declaration _ t)) = do genDeclaration t n case t of A.Array ds _ -> declareArraySizes ds (genName n) @@ -693,27 +693,27 @@ introduceSpec (A.Specification n (A.Declaration m t)) case declareInit t (genName n) (return ()) of Just p -> p Nothing -> return () -introduceSpec (A.Specification n (A.Is m am t v)) +introduceSpec (A.Specification _ n (A.Is _ am t v)) = do let (rhs, rhsSizes) = abbrevVariable am t v genDecl am t n tell [" = "] rhs tell [";\n"] rhsSizes n -introduceSpec (A.Specification n (A.IsExpr m am t e)) +introduceSpec (A.Specification _ n (A.IsExpr _ am t e)) = do let (rhs, rhsSizes) = abbrevExpression am t e genDecl am t n tell [" = "] rhs tell [";\n"] rhsSizes n -introduceSpec (A.Specification n (A.IsChannelArray m t cs)) +introduceSpec (A.Specification _ n (A.IsChannelArray _ t cs)) = do genDecl A.Abbrev t n tell [" = {"] sequence_ $ intersperse genComma (map genVariable cs) tell ["};\n"] ---introduceSpec (A.Specification n (A.DataType m t)) -introduceSpec (A.Specification n (A.DataTypeRecord _ b fs)) +--introduceSpec (A.Specification m n (A.DataType m t)) +introduceSpec (A.Specification _ n (A.DataTypeRecord _ b fs)) = do tell ["typedef struct {\n"] sequence_ [case t of _ -> @@ -726,8 +726,8 @@ introduceSpec (A.Specification n (A.DataTypeRecord _ b fs)) when b $ tell ["occam_struct_packed "] genName n tell [";\n"] -introduceSpec (A.Specification n (A.Protocol _ _)) = return () -introduceSpec (A.Specification n (A.ProtocolCase _ ts)) +introduceSpec (A.Specification _ n (A.Protocol _ _)) = return () +introduceSpec (A.Specification _ n (A.ProtocolCase _ ts)) = do tell ["typedef enum {\n"] sequence_ $ intersperse genComma [genName tag >> tell ["_"] >> genName n | (tag, _) <- ts] @@ -735,7 +735,7 @@ introduceSpec (A.Specification n (A.ProtocolCase _ ts)) tell ["} "] genName n tell [";\n"] -introduceSpec (A.Specification n (A.Proc m fs p)) +introduceSpec (A.Specification _ n (A.Proc _ fs p)) = do tell ["void "] genName n tell [" (Process *me"] @@ -743,13 +743,13 @@ introduceSpec (A.Specification n (A.Proc m fs p)) tell [") {\n"] genProcess p tell ["}\n"] -introduceSpec (A.Specification n (A.Function _ _ _ _)) = missing "introduceSpec function" ---introduceSpec (A.Specification n (A.Retypes m am t v)) ---introduceSpec (A.Specification n (A.RetypesExpr m am t e)) -introduceSpec (A.Specification n t) = missing $ "introduceSpec " ++ show t +introduceSpec (A.Specification _ n (A.Function _ _ _ _)) = missing "introduceSpec function" +--introduceSpec (A.Specification _ n (A.Retypes _ am t v)) +--introduceSpec (A.Specification _ n (A.RetypesExpr _ am t e)) +introduceSpec n = missing $ "introduceSpec " ++ show n removeSpec :: A.Specification -> CGen () -removeSpec (A.Specification n (A.Declaration m t)) +removeSpec (A.Specification _ n (A.Declaration _ t)) = case t of A.Array _ t' -> overArray (genName n) t (declareFree t' (genName n)) _ -> diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 16292ac..7830429 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -435,12 +435,12 @@ scopeOutRep :: A.Replicator -> OccParser () scopeOutRep (A.For m n b c) = scopeOut n scopeInSpec :: A.Specification -> OccParser A.Specification -scopeInSpec (A.Specification n st) +scopeInSpec (A.Specification m n st) = do n' <- scopeIn n st (abbrevModeOfSpec st) - return $ A.Specification n' st + return $ A.Specification m n' st scopeOutSpec :: A.Specification -> OccParser () -scopeOutSpec (A.Specification n st) = scopeOut n +scopeOutSpec (A.Specification _ n _) = scopeOut n scopeInFormal :: A.Formal -> OccParser A.Formal scopeInFormal (A.Formal am t n) @@ -817,12 +817,12 @@ replicator --{{{ specifications, declarations, allocations allocation :: OccParser [A.Specification] allocation - = do { m <- md; sPLACE; n <- variableName; sAT; e <- intExpr; sColon; eol; return [A.Specification n (A.Place m e)] } + = do { m <- md; sPLACE; n <- variableName; sAT; e <- intExpr; sColon; eol; return [A.Specification m n (A.Place m e)] } "allocation" specification :: OccParser [A.Specification] specification - = try (do { (ns, d) <- declaration; return [A.Specification n d | n <- ns] }) + = try (do { m <- md; (ns, d) <- declaration; return [A.Specification m n d | n <- ns] }) <|> try (do { a <- abbreviation; return [a] }) <|> do { d <- definition; return [d] } "specification" @@ -838,37 +838,37 @@ declaration abbreviation :: OccParser A.Specification abbreviation = do m <- md - (do { (n, v) <- tryVXV newVariableName sIS variable; sColon; eol; t <- pTypeOfVariable v; return $ A.Specification n $ A.Is m A.Abbrev t v } - <|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s v } + (do { (n, v) <- tryVXV newVariableName sIS variable; sColon; eol; t <- pTypeOfVariable v; return $ A.Specification m n $ A.Is m A.Abbrev t v } + <|> do { (s, n, v) <- try (do { s <- specifier; n <- newVariableName; sIS; v <- variable; return (s, n, v) }); sColon; eol; t <- pTypeOfVariable v; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s v } <|> do { sVAL ; - do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return $ A.Specification n $ A.IsExpr m A.ValAbbrev t e } - <|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return $ A.Specification n $ A.IsExpr m A.ValAbbrev s e } } - <|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c }) - <|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c }) - <|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification n $ A.Is m A.Abbrev t c }) - <|> try (do { s <- specifier; n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c }) - <|> try (do { s <- specifier; n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c }) - <|> try (do { s <- specifier; n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification n $ A.Is m A.Abbrev s c }) - <|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; return $ A.Specification n $ A.IsChannelArray m t cs }) - <|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; matchType s t; return $ A.Specification n $ A.IsChannelArray m s cs })) + do { (n, e) <- try (do { n <- newVariableName; sIS; e <- expression; return (n, e) }); sColon; eol; t <- pTypeOfExpression e; return $ A.Specification m n $ A.IsExpr m A.ValAbbrev t e } + <|> do { s <- specifier; n <- newVariableName; sIS; e <- expression; sColon; eol; t <- pTypeOfExpression e; matchType s t; return $ A.Specification m n $ A.IsExpr m A.ValAbbrev s e } } + <|> try (do { n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c }) + <|> try (do { n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c }) + <|> try (do { n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; return $ A.Specification m n $ A.Is m A.Abbrev t c }) + <|> try (do { s <- specifier; n <- newChannelName; sIS; c <- channel; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c }) + <|> try (do { s <- specifier; n <- newTimerName; sIS; c <- timer; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c }) + <|> try (do { s <- specifier; n <- newPortName; sIS; c <- port; sColon; eol; t <- pTypeOfVariable c; matchType s t; return $ A.Specification m n $ A.Is m A.Abbrev s c }) + <|> try (do { n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; return $ A.Specification m n $ A.IsChannelArray m t cs }) + <|> try (do { s <- specifier; n <- newChannelName; sIS; sLeft; cs <- sepBy1 channel sComma; sRight; sColon; eol; ts <- mapM pTypeOfVariable cs; t <- listType m ts; matchType s t; return $ A.Specification m n $ A.IsChannelArray m s cs })) "abbreviation" definition :: OccParser A.Specification definition = do { m <- md; sDATA; sTYPE; n <- newDataTypeName ; - do {sIS; t <- dataType; sColon; eol; return $ A.Specification n (A.DataType m t) } - <|> do { eol; indent; rec <- structuredType; outdent; sColon; eol; return $ A.Specification n rec } } + do {sIS; t <- dataType; sColon; eol; return $ A.Specification m n (A.DataType m t) } + <|> do { eol; indent; rec <- structuredType; outdent; sColon; eol; return $ A.Specification m n rec } } <|> do { m <- md; sPROTOCOL; n <- newProtocolName ; - do { sIS; p <- sequentialProtocol; sColon; eol; return $ A.Specification n $ A.Protocol m p } - <|> do { eol; indent; sCASE; eol; indent; ps <- many1 taggedProtocol; outdent; outdent; sColon; eol; return $ A.Specification n $ A.ProtocolCase m ps } } - <|> do { m <- md; sPROC; n <- newProcName; fs <- formalList; eol; indent; fs' <- scopeInFormals fs; p <- process; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification n $ A.Proc m fs' p } + do { sIS; p <- sequentialProtocol; sColon; eol; return $ A.Specification m n $ A.Protocol m p } + <|> do { eol; indent; sCASE; eol; indent; ps <- many1 taggedProtocol; outdent; outdent; sColon; eol; return $ A.Specification m n $ A.ProtocolCase m ps } } + <|> do { m <- md; sPROC; n <- newProcName; fs <- formalList; eol; indent; fs' <- scopeInFormals fs; p <- process; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification m n $ A.Proc m fs' p } <|> try (do { m <- md; rs <- sepBy1 dataType sComma; (n, fs) <- functionHeader ; - do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return $ A.Specification n $ A.Function m rs fs' (A.ValOf m (A.Skip m) el) } - <|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification n $ A.Function m rs fs' vp } }) + do { sIS; fs' <- scopeInFormals fs; el <- expressionList; scopeOutFormals fs'; sColon; eol; return $ A.Specification m n $ A.Function m rs fs' (A.ValOf m (A.Skip m) el) } + <|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification m n $ A.Function m rs fs' vp } }) <|> try (do { m <- md; s <- specifier; n <- newVariableName ; - sRETYPES <|> sRESHAPES; v <- variable; sColon; eol; return $ A.Specification n $ A.Retypes m A.Abbrev s v }) + sRETYPES <|> sRESHAPES; v <- variable; sColon; eol; return $ A.Specification m n $ A.Retypes m A.Abbrev s v }) <|> try (do { m <- md; sVAL; s <- specifier; n <- newVariableName ; - sRETYPES <|> sRESHAPES; e <- expression; sColon; eol; return $ A.Specification n $ A.RetypesExpr m A.ValAbbrev s e }) + sRETYPES <|> sRESHAPES; e <- expression; sColon; eol; return $ A.Specification m n $ A.RetypesExpr m A.ValAbbrev s e }) "definition" dataSpecifier :: OccParser A.Type diff --git a/fco2/ParseState.hs b/fco2/ParseState.hs index 6b81d43..e61d018 100644 --- a/fco2/ParseState.hs +++ b/fco2/ParseState.hs @@ -15,6 +15,7 @@ data ParseState = ParseState { psNameCounter :: Int, psNonceCounter :: Int, psPulledItems :: [A.Process -> A.Process], + psAdditionalArgs :: [(String, [A.Actual])], psMainName :: Maybe A.Name } deriving (Show, Data, Typeable) @@ -29,6 +30,7 @@ emptyState = ParseState { psNameCounter = 0, psNonceCounter = 0, psPulledItems = [], + psAdditionalArgs = [], psMainName = Nothing } @@ -76,7 +78,7 @@ defineNonce m s st nt am A.ndAbbrevMode = am } modify $ psDefineName n nd - return $ A.Specification n st + return $ A.Specification m n st -- | Generate and define a no-arg wrapper PROC around a process. makeNonceProc :: MonadState ParseState m => Meta -> A.Process -> m A.Specification diff --git a/fco2/Pass.hs b/fco2/Pass.hs index baccf81..0d7fa2b 100644 --- a/fco2/Pass.hs +++ b/fco2/Pass.hs @@ -2,6 +2,7 @@ module Pass where import Control.Monad.State +import System.IO import qualified AST as A import ParseState @@ -22,3 +23,6 @@ runPasses progress ((s, p):ps) ast ast'' <- runPasses progress ps ast' return ast'' +debug :: String -> PassM () +debug s = liftIO $ hPutStrLn stderr s + diff --git a/fco2/SimplifyExprs.hs b/fco2/SimplifyExprs.hs index 725f0cc..4889e6e 100644 --- a/fco2/SimplifyExprs.hs +++ b/fco2/SimplifyExprs.hs @@ -52,7 +52,7 @@ pullUp = doGeneric `extM` doProcess `extM` doExpression `extM` doActual pull t e = do -- FIXME Should get Meta from somewhere... let m = [] - spec@(A.Specification n _) <- makeNonceIsExpr "array_expr" m t e + spec@(A.Specification _ n _) <- makeNonceIsExpr "array_expr" m t e addPulled $ A.ProcSpec m spec return $ A.ExprVariable m (A.Variable m n) @@ -76,7 +76,7 @@ pullUp = doGeneric `extM` doProcess `extM` doExpression `extM` doActual where pull :: Meta -> A.AbbrevMode -> A.Type -> A.Variable -> PassM A.Variable pull m am t v - = do spec@(A.Specification n _) <- makeNonceIs "subscript_actual" m t am v + = do spec@(A.Specification _ n _) <- makeNonceIs "subscript_actual" m t am v addPulled $ A.ProcSpec m spec return $ A.Variable m n doActual a = doGeneric a diff --git a/fco2/Unnest.hs b/fco2/Unnest.hs index 34c7e1f..ca862e0 100644 --- a/fco2/Unnest.hs +++ b/fco2/Unnest.hs @@ -13,7 +13,11 @@ import Types import Pass unnest :: A.Process -> PassM A.Process -unnest p = parsToProcs p >>= removeFreeNames >>= removeNesting +unnest p + = parsToProcs p + >>= removeFreeNames + >>= removeNesting + >>= removeNoSpecs -- | Wrap the subprocesses of PARs in no-arg PROCs. parsToProcs :: Data t => t -> PassM t @@ -26,12 +30,12 @@ parsToProcs = doGeneric `extM` doProcess doProcess (A.Par m pm ps) = do ps' <- mapM parsToProcs ps procs <- mapM (makeNonceProc m) ps' - let calls = [A.ProcSpec m s (A.ProcCall m n []) | s@(A.Specification n _) <- procs] + let calls = [A.ProcSpec m s (A.ProcCall m n []) | s@(A.Specification m n _) <- procs] return $ A.Par m pm calls doProcess (A.ParRep m pm rep p) = do p' <- parsToProcs p rep' <- parsToProcs rep - s@(A.Specification n _) <- makeNonceProc m p' + s@(A.Specification _ n _) <- makeNonceProc m p' let call = A.ProcSpec m s (A.ProcCall m n []) return $ A.ParRep m pm rep' call doProcess p = doGeneric p @@ -45,7 +49,6 @@ freeNamesIn = doGeneric `extQ` doName `extQ` doProcess `extQ` doStructured `extQ doGeneric :: Data t => t -> NameMap doGeneric n = Map.unions $ gmapQ freeNamesIn n - -- FIXME This won't do the right thing with tags. doName :: A.Name -> NameMap doName n = Map.singleton (A.nameName n) n @@ -65,7 +68,7 @@ freeNamesIn = doGeneric `extQ` doName `extQ` doProcess `extQ` doStructured `extQ doValueProcess vp = doGeneric vp doSpec :: Data t => A.Specification -> t -> NameMap - doSpec (A.Specification n st) child + doSpec (A.Specification _ n st) child = Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child where fns = freeNamesIn st @@ -96,40 +99,14 @@ replaceNames map p = everywhere (mkT $ doName) p -- | Turn free names in PROCs into arguments. removeFreeNames :: Data t => t -> PassM t -removeFreeNames = doGeneric `extM` doProcess `extM` doStructured `extM` doValueProcess +removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess where doGeneric :: Data t => t -> PassM t doGeneric = gmapM removeFreeNames - doProcess :: A.Process -> PassM A.Process - doProcess (A.ProcSpec m spec p) - = do (spec', p') <- doSpec m spec p - return $ A.ProcSpec m spec' p' - doProcess p = doGeneric p - - doStructured :: A.Structured -> PassM A.Structured - doStructured (A.Spec m spec s) - = do (spec', s') <- doSpec m spec s - return $ A.Spec m spec' s' - doStructured s = doGeneric s - - doValueProcess :: A.ValueProcess -> PassM A.ValueProcess - doValueProcess (A.ValOfSpec m spec vp) - = do (spec', vp') <- doSpec m spec vp - return $ A.ValOfSpec m spec' vp' - doValueProcess vp = doGeneric vp - - addToCalls :: Data t => A.Name -> [A.Actual] -> t -> t - addToCalls matchN newAs = everywhere (mkT atcProc) - where - atcProc :: A.Process -> A.Process - atcProc p@(A.ProcCall m n as) - = if n == matchN then A.ProcCall m n (as ++ newAs) else p - atcProc p = p - - doSpec :: Data t => Meta -> A.Specification -> t -> PassM (A.Specification, t) - doSpec m spec child = case spec of - A.Specification n st@(A.Proc m fs p) -> + doSpecification :: A.Specification -> PassM A.Specification + doSpecification spec = case spec of + A.Specification m n st@(A.Proc _ fs p) -> do -- Figure out the free names let allFreeNames = Map.elems $ freeNamesIn st @@ -151,26 +128,34 @@ removeFreeNames = doGeneric `extM` doProcess `extM` doStructured `extM` doValueP in modify $ psDefineName nn (ond { A.ndName = A.nameName nn, A.ndAbbrevMode = am }) | (on, nn, am) <- zip3 freeNames newNames ams] - ps' <- get -- Add formals for each of the free names let newFs = [A.Formal am t n | (am, t, n) <- zip3 ams types newNames] p' <- removeFreeNames $ replaceNames (zip freeNames newNames) p let st' = A.Proc m (fs ++ newFs) p' - let spec' = A.Specification n st' + let spec' = A.Specification m n st' -- Update the definition of the proc let nameDef = fromJust $ psLookupName ps n modify $ psDefineName n (nameDef { A.ndType = st' }) - -- Add extra arguments to calls of this proc + -- Note that we should add extra arguments to calls of this proc + -- when we find them let newAs = [case am of A.Abbrev -> A.ActualVariable am t (A.Variable m n) _ -> A.ActualExpression t (A.ExprVariable m (A.Variable m n)) | (am, n, t) <- zip3 ams freeNames types] - child' <- removeFreeNames (addToCalls n newAs child) - return (spec', child') - _ -> - do spec' <- removeFreeNames spec - child' <- removeFreeNames child - return (spec', child') + case newAs of + [] -> return () + _ -> modify $ (\ps -> ps { psAdditionalArgs = (A.nameName n, newAs) : psAdditionalArgs ps }) + return spec' + _ -> doGeneric spec + + -- | Add the extra arguments we recorded when we saw the definition. + doProcess :: A.Process -> PassM A.Process + doProcess p@(A.ProcCall m n as) + = do st <- get + case lookup (A.nameName n) (psAdditionalArgs st) of + Just add -> doGeneric $ A.ProcCall m n (as ++ add) + Nothing -> doGeneric p + doProcess p = doGeneric p -- | Pull nested declarations to the top level. removeNesting :: A.Process -> PassM A.Process @@ -179,31 +164,18 @@ removeNesting p applyPulled p' where pullSpecs :: Data t => t -> PassM t - pullSpecs = doGeneric `extM` doProcess `extM` doStructured `extM` doValueProcess + pullSpecs = doGeneric `extM` doSpecification doGeneric :: Data t => t -> PassM t doGeneric = gmapM pullSpecs - doProcess :: A.Process -> PassM A.Process - doProcess orig@(A.ProcSpec m spec p) = doSpec orig m spec p - doProcess p = doGeneric p - - doStructured :: A.Structured -> PassM A.Structured - doStructured orig@(A.Spec m spec s) = doSpec orig m spec s - doStructured s = doGeneric s - - doValueProcess :: A.ValueProcess -> PassM A.ValueProcess - doValueProcess orig@(A.ValOfSpec m spec vp) = doSpec orig m spec vp - doValueProcess vp = doGeneric vp - - doSpec :: Data t => t -> Meta -> A.Specification -> t -> PassM t - doSpec orig m spec@(A.Specification _ st) child + doSpecification :: A.Specification -> PassM A.Specification + doSpecification spec@(A.Specification m _ st) = if canPull st then - do spec' <- pullSpecs spec + do spec' <- doGeneric spec addPulled $ A.ProcSpec m spec' - child' <- pullSpecs child - return child' - else doGeneric orig + return A.NoSpecification + else doGeneric spec canPull :: A.SpecType -> Bool canPull (A.Proc _ _ _) = True @@ -214,3 +186,21 @@ removeNesting p -- FIXME: Should pull up constant expressions too canPull _ = False +-- | Remove specifications that have been turned into NoSpecifications. +removeNoSpecs :: Data t => t -> PassM t +removeNoSpecs = doGeneric `extM` doProcess `extM` doStructured `extM` doValueProcess + where + doGeneric :: Data t => t -> PassM t + doGeneric n = gmapM removeNoSpecs n + + doProcess :: A.Process -> PassM A.Process + doProcess (A.ProcSpec _ A.NoSpecification p) = removeNoSpecs p + doProcess p = doGeneric p + + doStructured :: A.Structured -> PassM A.Structured + doStructured (A.Spec _ A.NoSpecification s) = removeNoSpecs s + doStructured s = doGeneric s + + doValueProcess :: A.ValueProcess -> PassM A.ValueProcess + doValueProcess (A.ValOfSpec _ A.NoSpecification vp) = removeNoSpecs vp + doValueProcess vp = doGeneric vp diff --git a/fco2/testcases/expressions.occ b/fco2/testcases/expressions.occ index 74616f9..2329d4e 100644 --- a/fco2/testcases/expressions.occ +++ b/fco2/testcases/expressions.occ @@ -3,9 +3,12 @@ PROC p (VAL INT x, y, INT z) : INT FUNCTION f (VAL INT x, y) + INT q: VALOF - SKIP - RESULT x + y + SEQ + q := x + q := q + y + RESULT q : PROC test.expressions ()