Add NoSpecification to AST, to make passes simpler
This commit is contained in:
Adam Sampson
parent
4c6cda3226
commit
9ed003f9e3
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
_ ->
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
116
fco2/Unnest.hs
116
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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user