diff options
Diffstat (limited to 'compiler/cmm')
| -rw-r--r-- | compiler/cmm/CmmProcPoint.hs | 230 |
1 files changed, 25 insertions, 205 deletions
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 15f8affb8e..a719eece3c 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -199,183 +199,6 @@ extendPPSet platform g blocks 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 [CmmFormal] 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 - (_, [], JustC (CmmBranch pee)) | setMember pee procPoints -> Just pee - _ -> Nothing - --- | 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 = regSetToList 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, b) = blockSplitHead block - block' = blockJoinHead h (blockFromList nodes `blockAppend` b) - in insertBlock block' 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, @@ -410,9 +233,11 @@ splitAtProcPoints entry_label callPPs procPoints procMap graph' = mapInsert bid b graph graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g + -- Build a map from proc point BlockId to pairs of: -- * Labels for their new procedures - -- * Labels for the info tables of their new procedures (only if the proc point is a callPP) + -- * Labels for the info tables of their new procedures (only if + -- the proc point is a callPP) -- Due to common blockification, we may overestimate the set of procpoints. let add_label map pp = Map.insert pp lbls map where lbls | pp == entry = (entry_label, Just entry_info_lbl) @@ -421,30 +246,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap entry_info_lbl = cit_lbl info_tbl procLabels = foldl 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... + let b = blockJoin (CmmEntry bid) emptyBlock jump + jump = CmmCall (CmmLit (CmmLabel l)) Nothing 0 0 0 return (mapInsert pp bid env, b : bs) - add_jumps (newGraphEnv) (ppId, blockEnv) = + + 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)] @@ -461,17 +271,16 @@ splitAtProcPoints entry_label callPPs procPoints procMap 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''') + let g' = 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)) = case expectJust "pp label" $ Map.lookup bid procLabels of + let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of (lbl, Just info_lbl) | bid == entry -> CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) @@ -482,15 +291,22 @@ splitAtProcPoints entry_label callPPs procPoints procMap (lbl, Nothing) -> CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info}) lbl (replacePPIds g) - -- References to procpoint IDs can now be replaced with the infotable's label - replacePPIds g = mapGraphNodes (id, mapExp repl, mapExp repl) g + where + stack_info = panic "No StackInfo" + + -- References to procpoint IDs can now be replaced with the + -- infotable's label + replacePPIds g = {-# SCC "replacePPIds" #-} + mapGraphNodes (id, mapExp repl, mapExp repl) g where repl e@(CmmLit (CmmBlock bid)) = case Map.lookup bid procLabels of Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) _ -> 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. + + -- 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', _) = @@ -506,8 +322,12 @@ splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a -- recursive lookup, see comment below. replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph -replaceBranches env g = mapGraphNodes (id, id, last) g +replaceBranches env cmmg + = {-# SCC "replaceBranches" #-} + ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg where + f block = replaceLastNode block $ last (lastNode block) + last :: CmmNode O C -> CmmNode O C last (CmmBranch id) = CmmBranch (lookup id) last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi) |