-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+
module CmmProcPointZ
( minimalProcPointSet
, addProcPointProtocols
import UniqSet
import ZipCfg
import ZipCfgCmmRep
-import ZipDataflow
+import ZipDataflow0
-- Compute a minimal set of proc points for a control-flow graph.
where first ProcPoint id = ReachedBy $ unitUniqSet id
first x _ = x
middle x _ = x
- last _ (LastCall _ _ (Just id)) = LastOutFacts [(id, ProcPoint)]
+ last _ (LastCall _ (Just id)) = LastOutFacts [(id, ProcPoint)]
last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
- exit _ = LastOutFacts []
+ exit x = x
minimalProcPointSet :: CmmGraph -> ProcPointSet
minimalProcPointSet g = extendPPSet g (postorder_dfs g) entryPoint
-- redirect the call (cf 'newblock') and set the protocol if necessary
maybe_add_call block (protos, blocks) =
case goto_end $ unzip block of
- (h, LastOther (LastCall tgt args (Just k)))
+ (h, LastOther (LastCall tgt (Just k)))
| Just proto <- lookupBlockEnv protos k,
Just pee <- jumpsToProcPoint k
-> let newblock =
- zipht h (tailOfLast (LastCall tgt args (Just pee)))
+ zipht h (tailOfLast (LastCall tgt (Just pee)))
changed_blocks = insertBlock newblock blocks
unchanged_blocks = insertBlock block blocks
in case lookupBlockEnv protos pee of
let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
panic "jump out of graph"
in case t of
- ZTail (CopyIn {}) (ZLast (LastOther (LastBranch pee [])))
+ ZTail (CopyIn {}) (ZLast (LastOther (LastBranch pee)))
| elemBlockSet pee procPoints -> Just pee
_ -> Nothing
init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g
maybe_add_proto (Block id (ZTail (CopyIn c fs _srt) _)) env =
extendBlockEnv env id (Protocol c fs)
maybe_add_proto (Block id _) env | id == lg_entry g =
- extendBlockEnv env id (Protocol (Argument CmmCallConv) hinted_formals)
+ extendBlockEnv env id (Protocol stdArgConvention hinted_formals)
maybe_add_proto _ env = env
- hinted_formals = map (\x -> (x, NoHint)) formals
+ hinted_formals = map (\x -> CmmHinted x NoHint) formals
+ stdArgConvention = ConventionStandard CmmCallConv Arguments
-- | For now, following a suggestion by Ben Lippmeier, we pass all
-- live variables as arguments, hoping that a clever register
Nothing -> let live = lookupBlockEnv liveness id `orElse`
emptyRegSet -- XXX there's a bug lurking!
-- panic ("no liveness at block " ++ show id)
- formals = map (\x->(x,NoHint)) $ uniqSetToList live
- in extendBlockEnv protos id (Protocol Local formals)
+ formals = map (\x -> CmmHinted x NoHint) $ uniqSetToList live
+ in extendBlockEnv protos id (Protocol ConventionPrivate formals)
g' = g { lg_blocks = add_CopyIns protos' (lg_blocks g) }