diff --git a/fco2/ParseState.hs b/fco2/ParseState.hs index c30d142..90ffa9a 100644 --- a/fco2/ParseState.hs +++ b/fco2/ParseState.hs @@ -32,7 +32,7 @@ data ParseState = ParseState { -- Set by passes psNonceCounter :: Int, psFunctionReturns :: [(String, [A.Type])], - psPulledItems :: [A.Structured -> A.Structured], + psPulledItems :: [[A.Structured -> A.Structured]], psAdditionalArgs :: [(String, [A.Actual])] } deriving (Show, Data, Typeable) @@ -69,6 +69,7 @@ emptyState = ParseState { class MonadState ParseState m => PSM m instance MonadState ParseState m => PSM m +--{{{ name definitions -- | Add the definition of a name. defineName :: PSM m => A.Name -> A.NameDef -> m () defineName n nd = modify $ (\ps -> ps { psNames = (A.nameName n, nd) : psNames ps }) @@ -80,32 +81,48 @@ lookupName n case lookup (A.nameName n) (psNames ps) of Just nd -> return nd Nothing -> die $ "cannot find name " ++ A.nameName n +--}}} +--{{{ warnings -- | Add a warning. addWarning :: PSM m => Meta -> String -> m () addWarning m s = modify (\ps -> ps { psWarnings = msg : psWarnings ps }) where msg = "Warning: " ++ show m ++ ": " ++ s +--}}} --- | Generate a throwaway unique name. -makeNonce :: PSM m => String -> m String -makeNonce s - = do ps <- get - let i = psNonceCounter ps - put ps { psNonceCounter = i + 1 } - return $ s ++ "_n" ++ show i +--{{{ pulled items +-- | Enter a pulled-items context. +pushPullContext :: PSM m => m () +pushPullContext = modify (\ps -> ps { psPulledItems = [] : psPulledItems ps }) + +-- | Leave a pulled-items context. +popPullContext :: PSM m => m () +popPullContext = modify (\ps -> ps { psPulledItems = tail $ psPulledItems ps }) -- | Add a pulled item to the collection. addPulled :: PSM m => (A.Structured -> A.Structured) -> m () -addPulled item = modify (\ps -> ps { psPulledItems = item : psPulledItems ps }) +addPulled item + = modify (\ps -> case psPulledItems ps of + (l:ls) -> ps { psPulledItems = (item:l):ls }) + +-- | Do we currently have any pulled items? +havePulled :: PSM m => m Bool +havePulled + = do ps <- get + case psPulledItems ps of + ([]:_) -> return False + _ -> return True -- | Apply pulled items to a Structured. applyPulled :: PSM m => A.Structured -> m A.Structured applyPulled ast = do ps <- get - let ast' = foldl (\p f -> f p) ast (psPulledItems ps) - put $ ps { psPulledItems = [] } - return ast' + case psPulledItems ps of + (l:ls) -> do put $ ps { psPulledItems = [] : ls } + return $ foldl (\p f -> f p) ast l +--}}} +--{{{ type contexts -- | Enter a type context. pushTypeContext :: PSM m => Maybe A.Type -> m () pushTypeContext t @@ -123,6 +140,16 @@ getTypeContext def case psTypeContext ps of (Just c):_ -> return c _ -> return def +--}}} + +--{{{ nonces +-- | Generate a throwaway unique name. +makeNonce :: PSM m => String -> m String +makeNonce s + = do ps <- get + let i = psNonceCounter ps + put ps { psNonceCounter = i + 1 } + return $ s ++ "_n" ++ show i -- | Generate and define a nonce specification. defineNonce :: PSM m => Meta -> String -> A.SpecType -> A.NameType -> A.AbbrevMode -> m A.Specification @@ -159,4 +186,4 @@ makeNonceIsExpr s m t e makeNonceVariable :: PSM m => String -> Meta -> A.Type -> A.NameType -> A.AbbrevMode -> m A.Specification makeNonceVariable s m t nt am = defineNonce m s (A.Declaration m t) nt am - +--}}} diff --git a/fco2/SimplifyExprs.hs b/fco2/SimplifyExprs.hs index aea1146..5b56fd5 100644 --- a/fco2/SimplifyExprs.hs +++ b/fco2/SimplifyExprs.hs @@ -75,27 +75,36 @@ removeAfter = doGeneric `extM` doExpression -- | Find things that need to be moved up to their enclosing Structured, and do -- so. --- FIXME We probably need to force there to be Structureds in some places -- or --- construct them if we get to a Process without finding one. pullUp :: Data t => t -> PassM t -pullUp = doGeneric `extM` doStructured `extM` doSpecification `extM` doExpression `extM` doVariable `extM` doExpressionList +pullUp = doGeneric `extM` doStructured `extM` doProcess `extM` doSpecification `extM` doExpression `extM` doVariable `extM` doExpressionList where doGeneric :: Data t => t -> PassM t doGeneric = gmapM pullUp - -- | When we encounter a process, create a new pulled items state, + -- | When we encounter a Structured, create a new pulled items state, -- recurse over it, then apply whatever pulled items we found to it. doStructured :: A.Structured -> PassM A.Structured doStructured s - = do -- Save the pulled items - origPulled <- liftM psPulledItems get - modify (\ps -> ps { psPulledItems = [] }) + = do pushPullContext -- Recurse over the body, then apply the pulled items to it s' <- doGeneric s >>= applyPulled -- ... and restore the original pulled items - modify (\ps -> ps { psPulledItems = origPulled }) + popPullContext return s' + -- | As with doStructured: when we find a process, create a new pulled items + -- context, and if we find any items apply them to it. + doProcess :: A.Process -> PassM A.Process + doProcess p + = do pushPullContext + p' <- doGeneric p + pulled <- havePulled + p'' <- if pulled + then liftM (A.Seq emptyMeta) $ applyPulled (A.OnlyP emptyMeta p') + else return p' + popPullContext + return p'' + -- | *Don't* pull anything that's already an abbreviation. doSpecification :: A.Specification -> PassM A.Specification doSpecification (A.Specification m n (A.Is m' am t v)) diff --git a/fco2/Unnest.hs b/fco2/Unnest.hs index d5910d5..fcc6bbf 100644 --- a/fco2/Unnest.hs +++ b/fco2/Unnest.hs @@ -144,8 +144,10 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess -- | Pull nested declarations to the top level. removeNesting :: A.Process -> PassM A.Process removeNesting p - = do p' <- pullSpecs p + = do pushPullContext + p' <- pullSpecs p s <- applyPulled $ A.OnlyP emptyMeta p' + popPullContext return $ A.Seq emptyMeta s where pullSpecs :: Data t => t -> PassM t @@ -158,9 +160,10 @@ removeNesting p doStructured s@(A.Spec m spec@(A.Specification _ n st) subS) = do isConst <- isConstantName n if isConst || canPull st then - do spec' <- doGeneric spec + do debug $ "removeNesting: pulling up " ++ show n + spec' <- doGeneric spec addPulled $ A.Spec m spec' - return subS + doStructured subS else doGeneric s doStructured s = doGeneric s