X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmProcPoint.hs;h=fbe979b9abe6472b9eebdefccbdc3ba6e9b26a58;hp=451a15343b5529e2eee081c5d01f0e1737a88bfd;hb=cbd7463c986d54422de15cb3b56184de116ef7ba;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4 diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 451a153..fbe979b 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -1,127 +1,562 @@ -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details +{-# LANGUAGE GADTs, DisambiguateRecordFields #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module CmmProcPoint ( - calculateProcPoints - ) where +module CmmProcPoint + ( ProcPointSet, Status(..) + , callProcPoints, minimalProcPointSet + , addProcPointProtocols, splitAtProcPoints, procPointAnalysis + ) +where -#include "HsVersions.h" +import Prelude hiding (last, unzip, succ, zip) +import BlockId +import CLabel import Cmm -import CmmBrokenBlock -import Dataflow - +import CmmDecl +import CmmExpr +import CmmContFlowOpt +import CmmInfo +import CmmLive +import Constants +import Data.List (sortBy) +import Maybes +import MkGraph +import Control.Monad +import OptimizationFuel +import Outputable import UniqSet -import UniqFM -import Panic - --- Determine the proc points for a set of basic blocks. --- --- A proc point is any basic block that must start a new function. --- The entry block of the original function is a proc point. --- The continuation of a function call is also a proc point. --- The third kind of proc point arises when there is a joint point --- in the control flow. Suppose we have code like the following: --- --- if (...) { ...; call foo(); ...} --- else { ...; call bar(); ...} --- x = y; --- --- That last statement "x = y" must be a proc point because --- it can be reached by blocks owned by different proc points --- (the two branches of the conditional). --- --- We calculate these proc points by starting with the minimal set --- and finding blocks that are reachable from more proc points than --- one of their parents. (This ensures we don't choose a block --- simply beause it is reachable from another block that is reachable --- from multiple proc points.) These new blocks are added to the --- set of proc points and the process is repeated until there --- are no more proc points to be found. - -calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId -calculateProcPoints blocks = - calculateProcPoints' init_proc_points blocks - where - init_proc_points = mkUniqSet $ - map brokenBlockId $ - filter always_proc_point blocks - always_proc_point BrokenBlock { - brokenBlockEntry = FunctionEntry _ _ _ } = True - always_proc_point BrokenBlock { - brokenBlockEntry = ContinuationEntry _ _ _ } = True - always_proc_point _ = False - -calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId -calculateProcPoints' old_proc_points blocks = - if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points - then old_proc_points - else calculateProcPoints' new_proc_points blocks - where - blocks_ufm :: BlockEnv BrokenBlock - blocks_ufm = blocksToBlockEnv blocks - - owners = calculateOwnership blocks_ufm old_proc_points blocks - new_proc_points = - unionManyUniqSets - (old_proc_points: - map (calculateNewProcPoints owners) blocks) - -calculateNewProcPoints :: BlockEnv (UniqSet BlockId) - -> BrokenBlock - -> UniqSet BlockId -calculateNewProcPoints owners block = - unionManyUniqSets (map (maybe_proc_point parent_id) child_ids) - where - parent_id = brokenBlockId block - child_ids = brokenBlockTargets block - maybe_proc_point parent_id child_id = - if needs_proc_point - then unitUniqSet child_id - else emptyUniqSet - where - parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id - child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id - needs_proc_point = - -- only if parent isn't dead - (not $ isEmptyUniqSet parent_owners) && - -- and only if child has more owners than parent - (not $ isEmptyUniqSet $ - child_owners `minusUniqSet` parent_owners) - -calculateOwnership :: BlockEnv BrokenBlock - -> UniqSet BlockId - -> [BrokenBlock] - -> BlockEnv (UniqSet BlockId) -calculateOwnership blocks_ufm proc_points blocks = - fixedpoint dependants update (map brokenBlockId blocks) emptyUFM - where - dependants :: BlockId -> [BlockId] - dependants ident = - brokenBlockTargets $ lookupWithDefaultUFM - blocks_ufm unknown_block ident - - update :: BlockId - -> Maybe BlockId - -> BlockEnv (UniqSet BlockId) - -> Maybe (BlockEnv (UniqSet BlockId)) - update ident cause owners = - case (cause, ident `elementOfUniqSet` proc_points) of - (Nothing, True) -> - Just $ addToUFM owners ident (unitUniqSet ident) - (Nothing, False) -> Nothing - (Just cause', True) -> Nothing - (Just cause', False) -> - if (sizeUniqSet old) == (sizeUniqSet new) - then Nothing - else Just $ addToUFM owners ident new - where - old = lookupWithDefaultUFM owners emptyUniqSet ident - new = old `unionUniqSets` - lookupWithDefaultUFM owners emptyUniqSet cause' - - unknown_block = panic "unknown BlockId in calculateOwnership" +import UniqSupply + +import Compiler.Hoopl + +import qualified Data.Map as Map + +-- Compute a minimal set of proc points for a control-flow graph. + +-- Determine a protocol for each proc point (which live variables will +-- be passed as arguments and which will be on the stack). + +{- +A proc point is a basic block that, after CPS transformation, will +start a new function. The entry block of the original function is a +proc point, as is the continuation of each function call. +A third kind of proc point arises if we want to avoid copying code. +Suppose we have code like the following: + + f() { + if (...) { ..1..; call foo(); ..2..} + else { ..3..; call bar(); ..4..} + x = y + z; + return x; + } + +The statement 'x = y + z' can be reached from two different proc +points: the continuations of foo() and bar(). We would prefer not to +put a copy in each continuation; instead we would like 'x = y + z' to +be the start of a new procedure to which the continuations can jump: + + f_cps () { + if (...) { ..1..; push k_foo; jump foo_cps(); } + else { ..3..; push k_bar; jump bar_cps(); } + } + k_foo() { ..2..; jump k_join(y, z); } + k_bar() { ..4..; jump k_join(y, z); } + k_join(y, z) { x = y + z; return x; } + +You might think then that a criterion to make a node a proc point is +that it is directly reached by two distinct proc points. (Note +[Direct reachability].) But this criterion is a bit too simple; for +example, 'return x' is also reached by two proc points, yet there is +no point in pulling it out of k_join. A good criterion would be to +say that a node should be made a proc point if it is reached by a set +of proc points that is different than its immediate dominator. NR +believes this criterion can be shown to produce a minimum set of proc +points, and given a dominator tree, the proc points can be chosen in +time linear in the number of blocks. Lacking a dominator analysis, +however, we turn instead to an iterative solution, starting with no +proc points and adding them according to these rules: + + 1. The entry block is a proc point. + 2. The continuation of a call is a proc point. + 3. A node is a proc point if it is directly reached by more proc + points than one of its predecessors. + +Because we don't understand the problem very well, we apply rule 3 at +most once per iteration, then recompute the reachability information. +(See Note [No simple dataflow].) The choice of the new proc point is +arbitrary, and I don't know if the choice affects the final solution, +so I don't know if the number of proc points chosen is the +minimum---but the set will be minimal. +-} + +type ProcPointSet = BlockSet + +data Status + = ReachedBy ProcPointSet -- set of proc points that directly reach the block + | ProcPoint -- this block is itself a proc point + +instance Outputable Status where + ppr (ReachedBy ps) + | setNull ps = text "" + | otherwise = text "reached by" <+> + (hsep $ punctuate comma $ map ppr $ setElems ps) + ppr ProcPoint = text "" + +lattice :: DataflowLattice Status +lattice = DataflowLattice "direct proc-point reachability" unreached add_to + where unreached = ReachedBy setEmpty + add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint) + add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint) -- because of previous case + add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) = + let union = setUnion p' p + in if setSize union > setSize p then (SomeChange, ReachedBy union) + else (NoChange, ReachedBy p) +-------------------------------------------------- +-- transfer equations + +forward :: FwdTransfer CmmNode Status +forward = mkFTransfer3 first middle ((mkFactBase lattice . ) . last) + where first :: CmmNode C O -> Status -> Status + first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id + first _ x = x + + middle _ x = x + + last :: CmmNode O C -> Status -> [(Label, Status)] + last (CmmCall {cml_cont = Just k}) _ = [(k, ProcPoint)] + last (CmmForeignCall {succ = k}) _ = [(k, ProcPoint)] + last l x = map (\id -> (id, x)) (successors l) + +-- It is worth distinguishing two sets of proc points: +-- those that are induced by calls in the original graph +-- and those that are introduced because they're reachable from multiple proc points. +callProcPoints :: CmmGraph -> ProcPointSet +callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g + where add :: CmmBlock -> BlockSet -> BlockSet + add b set = case lastNode b of + CmmCall {cml_cont = Just k} -> setInsert k set + CmmForeignCall {succ=k} -> setInsert k set + _ -> set + +minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet +-- Given the set of successors of calls (which must be proc-points) +-- figure out the minimal set of necessary proc-points +minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints + +procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status) +-- Once you know what the proc-points are, figure out +-- what proc-points each block is reachable from +procPointAnalysis procPoints g = + liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward + where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints] + +extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet +extendPPSet g blocks procPoints = + do env <- procPointAnalysis procPoints g + let add block pps = let id = entryLabel block + in case mapLookup id env of + Just ProcPoint -> setInsert id pps + _ -> pps + procPoints' = foldGraphBlocks add setEmpty g + newPoints = mapMaybe ppSuccessor blocks + newPoint = listToMaybe newPoints + ppSuccessor b = + let nreached id = case mapLookup id env `orElse` + pprPanic "no ppt" (ppr id <+> ppr b) of + ProcPoint -> 1 + ReachedBy ps -> setSize ps + block_procpoints = nreached (entryLabel b) + -- | Looking for a successor of b that is reached by + -- more proc points than b and is not already a proc + -- point. If found, it can become a proc point. + newId succ_id = not (setMember succ_id procPoints') && + nreached succ_id > block_procpoints + in listToMaybe $ filter newId $ successors b +{- + case newPoints of + [] -> return procPoints' + pps -> extendPPSet g blocks + (foldl extendBlockSet procPoints' pps) +-} + case newPoint of Just id -> + if setMember id procPoints' then panic "added old proc pt" + else extendPPSet g blocks (setInsert id procPoints') + Nothing -> return procPoints' + + +------------------------------------------------------------------------ +-- Computing Proc-Point Protocols -- +------------------------------------------------------------------------ + +{- + +There is one major trick, discovered by Michael Adams, which is that +we want to choose protocols in a way that enables us to optimize away +some continuations. The optimization is very much like branch-chain +elimination, except that it involves passing results as well as +control. The idea is that if a call's continuation k does nothing but +CopyIn its results and then goto proc point P, the call's continuation +may be changed to P, *provided* P's protocol is identical to the +protocol for the CopyIn. We choose protocols to make this so. + +Here's an explanatory example; we begin with the source code (lines +separate basic blocks): + + ..1..; + x, y = g(); + goto P; + ------- + P: ..2..; + +Zipperization converts this code as follows: + + ..1..; + call g() returns to k; + ------- + k: CopyIn(x, y); + goto P; + ------- + P: ..2..; + +What we'd like to do is assign P the same CopyIn protocol as k, so we +can eliminate k: + + ..1..; + call g() returns to P; + ------- + P: CopyIn(x, y); ..2..; + +Of course, P may be the target of more than one continuation, and +different continuations may have different protocols. Michael Adams +implemented a voting mechanism, but he thinks a simple greedy +algorithm would be just as good, so that's what we do. + +-} + +data Protocol = Protocol Convention CmmFormals Area + deriving Eq +instance Outputable Protocol where + ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a + +-- | Function 'optimize_calls' chooses protocols only for those proc +-- points that are relevant to the optimization explained above. +-- The others are assigned by 'add_unassigned', which is not yet clever. + +addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelUniqSM CmmGraph +addProcPointProtocols callPPs procPoints g = + do liveness <- cmmLiveness g + (protos, g') <- optimize_calls liveness g + blocks'' <- add_CopyOuts protos procPoints g' + return $ ofBlockMap (g_entry g) blocks'' + where optimize_calls liveness g = -- see Note [Separate Adams optimization] + do let (protos, blocks') = + foldGraphBlocks maybe_add_call (mapEmpty, mapEmpty) g + protos' = add_unassigned liveness procPoints protos + let g' = ofBlockMap (g_entry g) (add_CopyIns callPPs protos' blocks') + return (protos', removeUnreachableBlocks g') + maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock) + -> (BlockEnv Protocol, BlockEnv CmmBlock) + -- ^ If the block is a call whose continuation goes to a proc point + -- whose protocol either matches the continuation's or is not yet set, + -- redirect the call (cf 'newblock') and set the protocol if necessary + maybe_add_call block (protos, blocks) = + case lastNode block of + CmmCall tgt (Just k) args res s + | Just proto <- mapLookup k protos, + Just pee <- branchesToProcPoint k + -> let newblock = replaceLastNode block (CmmCall tgt (Just pee) + args res s) + changed_blocks = insertBlock newblock blocks + unchanged_blocks = insertBlock block blocks + in case mapLookup pee protos of + Nothing -> (mapInsert pee proto protos, changed_blocks) + Just proto' -> + if proto == proto' then (protos, changed_blocks) + else (protos, unchanged_blocks) + _ -> (protos, insertBlock block blocks) + + branchesToProcPoint :: BlockId -> Maybe BlockId + -- ^ Tells whether the named block is just a branch to a proc point + branchesToProcPoint id = + let block = mapLookup id (toBlockMap g) `orElse` + panic "branch out of graph" + in case blockToNodeList block of +-- MS: There is an ugly bug in ghc-6.10, which rejects following valid code. +-- After trying several tricks, the NOINLINE on getItOut worked. Uffff. +#if __GLASGOW_HASKELL__ >= 612 + (_, [], JustC (CmmBranch pee)) | setMember pee procPoints -> Just pee + _ -> Nothing +#else + (_, [], exit) | CmmBranch pee <- getItOut exit + , setMember pee procPoints -> Just pee + _ -> Nothing + where {-# NOINLINE getItOut #-} + getItOut :: MaybeC C a -> a + getItOut (JustC a) = a +#endif + +-- | For now, following a suggestion by Ben Lippmeier, we pass all +-- live variables as arguments, hoping that a clever register +-- allocator might help. + +add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol -> + BlockEnv Protocol +add_unassigned = pass_live_vars_as_args + +pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet -> + BlockEnv Protocol -> BlockEnv Protocol +pass_live_vars_as_args _liveness procPoints protos = protos' + where protos' = setFold addLiveVars protos procPoints + addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol + addLiveVars id protos = + case mapLookup id protos of + Just _ -> protos + Nothing -> let live = emptyRegSet + --lookupBlockEnv _liveness id `orElse` + --panic ("no liveness at block " ++ show id) + formals = uniqSetToList live + prot = Protocol Private formals $ CallArea $ Young id + in mapInsert id prot protos + + +-- | Add copy-in instructions to each proc point that did not arise from a call +-- instruction. (Proc-points that arise from calls already have their copy-in instructions.) + +add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock +add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks + where maybe_insert_CopyIns block blocks + | not $ setMember bid callPPs + , Just (Protocol c fs _area) <- mapLookup bid protos + = let nodes = copyInSlot c fs + (h, m, l) = blockToNodeList block + in insertBlock (blockOfNodeList (h, nodes ++ m, l)) blocks + | otherwise = insertBlock block blocks + where bid = entryLabel block + + +-- | Add a CopyOut node before each procpoint. +-- If the predecessor is a call, then the copy outs should already be done by the callee. +-- Note: If we need to add copy-out instructions, they may require stack space, +-- so we accumulate a map from the successors to the necessary stack space, +-- then update the successors after we have finished inserting the copy-outs. + +add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph -> + FuelUniqSM (BlockEnv CmmBlock) +add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) g + where mb_copy_out :: CmmBlock -> FuelUniqSM (BlockEnv CmmBlock) -> + FuelUniqSM (BlockEnv CmmBlock) + mb_copy_out b z | entryLabel b == g_entry g = skip b z + mb_copy_out b z = + case lastNode b of + CmmCall {} -> skip b z -- copy out done by callee + CmmForeignCall {} -> skip b z -- copy out done by callee + _ -> copy_out b z + copy_out b z = foldr trySucc init (successors b) >>= finish + where init = (\bmap -> (b, bmap)) `liftM` z + trySucc succId z = + if setMember succId procPoints then + case mapLookup succId protos of + Nothing -> z + Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs + else z + insert z succId m = + do (b, bmap) <- z + (b, bs) <- insertBetween b m succId + -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do + return $ (b, foldl (flip insertBlock) bmap bs) + finish (b, bmap) = return $ insertBlock b bmap + skip b bs = insertBlock b `liftM` bs + +-- At this point, we have found a set of procpoints, each of which should be +-- the entry point of a procedure. +-- Now, we create the procedure for each proc point, +-- which requires that we: +-- 1. build a map from proc points to the blocks reachable from the proc point +-- 2. turn each branch to a proc point into a jump +-- 3. turn calls and returns into jumps +-- 4. build info tables for the procedures -- and update the info table for +-- the SRTs in the entry procedure as well. +-- Input invariant: A block should only be reachable from a single ProcPoint. +-- ToDo: use the _ret naming convention that the old code generator +-- used. -- EZY +splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> + CmmTop -> FuelUniqSM [CmmTop] +splitAtProcPoints entry_label callPPs procPoints procMap + (CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) + top_l g@(CmmGraph {g_entry=entry})) = + do -- Build a map from procpoints to the blocks they reach + let addBlock b graphEnv = + case mapLookup bid procMap of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case setElems set of + [] -> graphEnv + [id] -> add graphEnv id bid b + _ -> panic "Each block should be reachable from only one ProcPoint" + Nothing -> pprPanic "block not reached by a proc point?" (ppr bid) + where bid = entryLabel b + add graphEnv procId bid b = mapInsert procId graph' graphEnv + where graph = mapLookup procId graphEnv `orElse` mapEmpty + graph' = mapInsert bid b graph + graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g + -- Build a map from proc point BlockId to labels for their new procedures + -- Due to common blockification, we may overestimate the set of procpoints. + let add_label map pp = return $ Map.insert pp lbl map + where lbl = if pp == entry then entry_label else blockLbl pp + procLabels <- foldM add_label Map.empty + (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + -- For each procpoint, we need to know the SP offset on entry. + -- If the procpoint is: + -- - continuation of a call, the SP offset is in the call + -- - otherwise, 0 (and left out of the spEntryMap) + let add_sp_off :: CmmBlock -> BlockEnv CmmStackInfo -> BlockEnv CmmStackInfo + add_sp_off b env = + case lastNode b of + CmmCall {cml_cont = Just succ, cml_ret_args = off, cml_ret_off = updfr_off} -> + mapInsert succ (StackInfo { arg_space = off, updfr_space = Just updfr_off}) env + CmmForeignCall {succ = succ, updfr = updfr_off} -> + mapInsert succ (StackInfo { arg_space = wORD_SIZE, updfr_space = Just updfr_off}) env + _ -> env + spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry stack_info emptyBlockMap) g + getStackInfo id = mapLookup id spEntryMap `orElse` StackInfo {arg_space = 0, updfr_space = Nothing} + -- In each new graph, add blocks jumping off to the new procedures, + -- and replace branches to procpoints with branches to the jump-off blocks + let add_jump_block (env, bs) (pp, l) = + do bid <- liftM mkBlockId getUniqueM + let b = blockOfNodeList (JustC (CmmEntry bid), [], JustC jump) + StackInfo {arg_space = argSpace, updfr_space = off} = getStackInfo pp + jump = CmmCall (CmmLit (CmmLabel l')) Nothing argSpace 0 + (off `orElse` 0) -- Jump's shouldn't need the offset... + l' = if setMember pp callPPs then entryLblToInfoLbl l else l + return (mapInsert pp bid env, b : bs) + add_jumps (newGraphEnv) (ppId, blockEnv) = + do let needed_jumps = -- find which procpoints we currently branch to + mapFold add_if_branch_to_pp [] blockEnv + add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] + add_if_branch_to_pp block rst = + case lastNode block of + CmmBranch id -> add_if_pp id rst + CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst) + CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl) + _ -> rst + add_if_pp id rst = case Map.lookup id procLabels of + Just x -> (id, x) : rst + Nothing -> rst + (jumpEnv, jumpBlocks) <- + foldM add_jump_block (mapEmpty, []) needed_jumps + -- update the entry block + let b = expectJust "block in env" $ mapLookup ppId blockEnv + off = getStackInfo ppId + blockEnv' = mapInsert ppId b blockEnv + -- replace branches to procpoints with branches to jumps + blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' + -- add the jump blocks to the graph + blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks + let g' = (off, ofBlockMap ppId blockEnv''') + -- pprTrace "g' pre jumps" (ppr g') $ do + return (mapInsert ppId g' newGraphEnv) + graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv + let to_proc (bid, (stack_info, g)) | setMember bid callPPs = + if bid == entry then + CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) + top_l (replacePPIds g) + else + CmmProc (TopInfo {info_tbl=emptyContInfoTable, stack_info=stack_info}) + lbl (replacePPIds g) + where lbl = expectJust "pp label" $ Map.lookup bid procLabels + to_proc (bid, (stack_info, g)) = + CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info}) + lbl (replacePPIds g) + where lbl = expectJust "pp label" $ Map.lookup bid procLabels + -- References to procpoint IDs can now be replaced with the infotable's label + replacePPIds g = mapGraphNodes (id, mapExp repl, mapExp repl) g + where repl e@(CmmLit (CmmBlock bid)) = + case Map.lookup bid procLabels of + Just l -> CmmLit (CmmLabel (entryLblToInfoLbl l)) + Nothing -> e + repl e = e + -- The C back end expects to see return continuations before the call sites. + -- Here, we sort them in reverse order -- it gets reversed later. + let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g) + add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map) + sort_fn (bid, _) (bid', _) = + compare (expectJust "block_order" $ mapLookup bid block_order) + (expectJust "block_order" $ mapLookup bid' block_order) + procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv + return -- pprTrace "procLabels" (ppr procLabels) + -- pprTrace "splitting graphs" (ppr procs) + procs +splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] + +---------------------------------------------------------------- + +{- +Note [Direct reachability] + +Block B is directly reachable from proc point P iff control can flow +from P to B without passing through an intervening proc point. +-} + +---------------------------------------------------------------- + +{- +Note [No simple dataflow] + +Sadly, it seems impossible to compute the proc points using a single +dataflow pass. One might attempt to use this simple lattice: + + data Location = Unknown + | InProc BlockId -- node is in procedure headed by the named proc point + | ProcPoint -- node is itself a proc point + +At a join, a node in two different blocks becomes a proc point. +The difficulty is that the change of information during iterative +computation may promote a node prematurely. Here's a program that +illustrates the difficulty: + + f () { + entry: + .... + L1: + if (...) { ... } + else { ... } + + L2: if (...) { g(); goto L1; } + return x + y; + } + +The only proc-point needed (besides the entry) is L1. But in an +iterative analysis, consider what happens to L2. On the first pass +through, it rises from Unknown to 'InProc entry', but when L1 is +promoted to a proc point (because it's the successor of g()), L1's +successors will be promoted to 'InProc L1'. The problem hits when the +new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'. +The join operation makes it a proc point when in fact it needn't be, +because its immediate dominator L1 is already a proc point and there +are no other proc points that directly reach L2. +-} + + + +{- Note [Separate Adams optimization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It may be worthwhile to attempt the Adams optimization by rewriting +the graph before the assignment of proc-point protocols. Here are a +couple of rules: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: // no CopyIn node here L: CopyIn c ress; + + +And when c == c' and ress == ress', this also: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: CopyIn c' ress' L: CopyIn c' ress' ; + +In both cases the goal is to eliminate k. +-}