X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmProcPointZ.hs;h=b477f4c2336071341fe51b4835df5639ad0da982;hp=c5d71773604fccb1d51d848d83d04121540784db;hb=d436c70d43fb905c63220040168295e473f4b90a;hpb=8acda75bd98763ac5643a2152960102a4d98122b diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index c5d7177..b477f4c 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -1,28 +1,33 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} module CmmProcPointZ - ( minimalProcPointSet - , addProcPointProtocols + ( ProcPointSet, Status(..) + , callProcPoints, minimalProcPointSet + , addProcPointProtocols, splitAtProcPoints, procPointAnalysis ) where -import Prelude hiding (zip, unzip) +import Prelude hiding (zip, unzip, last) -import ClosureInfo +import BlockId +import CLabel import Cmm hiding (blockId) -import CmmExpr import CmmContFlowOpt +import CmmExpr +import CmmInfo import CmmLiveZ import CmmTx import DFMonad -import ForeignCall -- used in protocol for the entry point -import MachOp (MachHint(NoHint)) +import FiniteMap +import List (sortBy) import Maybes +import MkZipCfg +import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ) +import Monad import Outputable import Panic -import UniqFM import UniqSet +import UniqSupply import ZipCfg -import ZipCfgCmm +import ZipCfgCmmRep import ZipDataflow -- Compute a minimal set of proc points for a control-flow graph. @@ -59,7 +64,7 @@ be the start of a new procedure to which the continuations can jump: 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 two simple; for +[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 @@ -91,9 +96,9 @@ data Status instance Outputable Status where ppr (ReachedBy ps) - | isEmptyUniqSet ps = text "" + | isEmptyBlockSet ps = text "" | otherwise = text "reached by" <+> - (hsep $ punctuate comma $ map ppr $ uniqSetToList ps) + (hsep $ punctuate comma $ map ppr $ blockSetToList ps) ppr ProcPoint = text "" @@ -103,57 +108,79 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals add_to _ ProcPoint = noTx ProcPoint add_to ProcPoint _ = aTx ProcPoint -- aTx because of previous case again add_to (ReachedBy p) (ReachedBy p') = - let union = unionUniqSets p p' - in if sizeUniqSet union > sizeUniqSet p' then + let union = unionBlockSets p p' + in if sizeBlockSet union > sizeBlockSet p' then aTx (ReachedBy union) else noTx (ReachedBy p') -------------------------------------------------- -- transfer equations -forward :: FAnalysis Middle Last Status -forward = FComp "proc-point reachability" first middle last exit - where first ProcPoint id = ReachedBy $ unitUniqSet id - first x _ = x - middle x _ = x - last _ (LastCall _ _ (Just id)) = LastOutFacts [(id, ProcPoint)] - last x l = LastOutFacts $ map (\id -> (id, x)) (succs l) - exit _ = LastOutFacts [] +forward :: ForwardTransfers Middle Last Status +forward = ForwardTransfers first middle last exit + where first id ProcPoint = ReachedBy $ unitBlockSet id + first _ x = x + middle _ x = x + last (LastCall _ (Just id) _ _ _) _ = LastOutFacts [(id, ProcPoint)] + last l x = LastOutFacts $ map (\id -> (id, x)) (succs l) + exit x = x -minimalProcPointSet :: CmmGraph -> ProcPointSet -minimalProcPointSet g = extendPPSet g (postorder_dfs g) entryPoint - where entryPoint = unitUniqSet (gr_entry g) - -extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> ProcPointSet +-- 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 +minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet + +callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g + where add b set = case last $ unzip b of + LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k + _ -> set + +minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints + +type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ()) + +procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status) +procPointAnalysis procPoints g = + let addPP env id = extendBlockEnv env id ProcPoint + initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints) + in liftM zdfFpFacts $ + (zdfSolveFrom initProcPoints "proc-point reachability" lattice + forward (fact_bot lattice) $ graphOfLGraph g :: PPFix) + +extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelMonad ProcPointSet extendPPSet g blocks procPoints = - case newPoint of Just id -> - if elemBlockSet id procPoints' then panic "added old proc pt" - else extendPPSet g blocks (extendBlockSet procPoints' id) - Nothing -> procPoints' - where env = runDFA lattice $ - do refine_f_anal forward g set_init_points - allFacts - set_init_points = mapM_ (\id -> setFact id ProcPoint) - (uniqSetToList procPoints) - procPoints' = fold_blocks add emptyBlockSet g - add block pps = let id = blockId block - in case lookupBlockEnv env id of - Just ProcPoint -> extendBlockSet pps id - _ -> pps - - newPoint = listToMaybe (mapMaybe ppSuccessor blocks) - ppSuccessor b@(Block id _) = - let nreached id = case lookupBlockEnv env id `orElse` panic "no ppt" of - ProcPoint -> 1 - ReachedBy ps -> sizeUniqSet ps - my_nreached = nreached id - -- | 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 (elemBlockSet succ_id procPoints') && - nreached succ_id > my_nreached - in listToMaybe $ filter newId $ succs b - + do env <- procPointAnalysis procPoints g + let add block pps = let id = blockId block + in case lookupBlockEnv env id of + Just ProcPoint -> extendBlockSet pps id + _ -> pps + procPoints' = fold_blocks add emptyBlockSet g + newPoints = mapMaybe ppSuccessor blocks + newPoint = listToMaybe newPoints + ppSuccessor b@(Block bid _) = + let nreached id = case lookupBlockEnv env id `orElse` + pprPanic "no ppt" (ppr id <+> ppr b) of + ProcPoint -> 1 + ReachedBy ps -> sizeBlockSet ps + block_procpoints = nreached bid + -- | 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 (elemBlockSet succ_id procPoints') && + nreached succ_id > block_procpoints + in listToMaybe $ filter newId $ succs b +{- + case newPoints of + [] -> return procPoints' + pps -> extendPPSet g blocks + (foldl extendBlockSet procPoints' pps) +-} + case newPoint of Just id -> + if elemBlockSet id procPoints' then panic "added old proc pt" + else extendPPSet g blocks (extendBlockSet procPoints' id) + Nothing -> return procPoints' + ------------------------------------------------------------------------ -- Computing Proc-Point Protocols -- @@ -204,21 +231,29 @@ algorithm would be just as good, so that's what we do. -} -data Protocol = Protocol Convention CmmFormals +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 -> CmmFormalsWithoutKinds -> CmmGraph -> CmmGraph -addProcPointProtocols procPoints formals g = - snd $ add_unassigned procPoints $ optimize_calls g - where optimize_calls g = -- see Note [Separate Adams optimization] - let (protos, blocks') = - fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g - g' = LGraph (gr_entry g) (add_CopyIns protos blocks') - in (protos, runTx removeUnreachableBlocksZ g') +addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph +addProcPointProtocols callPPs procPoints g = + do liveness <- cmmLivenessZ g + (protos, g') <- optimize_calls liveness g + blocks'' <- add_CopyOuts protos procPoints g' + return $ LGraph (lg_entry g) blocks'' + where optimize_calls liveness g = -- see Note [Separate Adams optimization] + do let (protos, blocks') = + fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g + protos' = add_unassigned liveness procPoints protos + blocks <- add_CopyIns callPPs protos' blocks' + let g' = LGraph (lg_entry g) (mkBlockEnv (map withKey (concat blocks))) + withKey b@(Block bid _) = (bid, b) + return (protos', runTx removeUnreachableBlocksZ 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 @@ -226,11 +261,11 @@ addProcPointProtocols procPoints formals g = -- 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) args res s)) | Just proto <- lookupBlockEnv protos k, - Just pee <- jumpsToProcPoint k - -> let newblock = - zipht h (tailOfLast (LastCall tgt args (Just pee))) + Just pee <- branchesToProcPoint k + -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) + args res s)) changed_blocks = insertBlock newblock blocks unchanged_blocks = insertBlock block blocks in case lookupBlockEnv protos pee of @@ -240,66 +275,209 @@ addProcPointProtocols procPoints formals g = else (protos, unchanged_blocks) _ -> (protos, insertBlock block blocks) - jumpsToProcPoint :: BlockId -> Maybe BlockId - -- ^ Tells whether the named block is just a jump to a proc point - jumpsToProcPoint id = - let (Block _ t) = lookupBlockEnv (gr_blocks g) id `orElse` - panic "jump out of graph" + branchesToProcPoint :: BlockId -> Maybe BlockId + -- ^ Tells whether the named block is just a branch to a proc point + branchesToProcPoint id = + let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse` + panic "branch out of graph" in case t of - ZTail (CopyIn {}) (ZLast (LastOther (LastBranch pee []))) + ZLast (LastOther (LastBranch pee)) | elemBlockSet pee procPoints -> Just pee _ -> Nothing init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol - maybe_add_proto (Block id (ZTail (CopyIn c fs _srt) _)) env = - extendBlockEnv env id (Protocol c fs) - maybe_add_proto (Block id _) env | id == gr_entry g = - extendBlockEnv env id (Protocol (Argument CmmCallConv) hinted_formals) + --maybe_add_proto (Block id (ZTail (CopyIn c _ fs _srt) _)) env = + -- extendBlockEnv env id (Protocol c fs $ toArea id fs) maybe_add_proto _ env = env - hinted_formals = map (\x -> (x, NoHint)) formals + -- JD: Is this proto stuff even necessary, now that we have + -- common blockification? -- | 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 - :: ProcPointSet -> (BlockEnv Protocol, CmmGraph) -> (BlockEnv Protocol, CmmGraph) +add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol -> + BlockEnv Protocol add_unassigned = pass_live_vars_as_args -pass_live_vars_as_args - :: ProcPointSet -> (BlockEnv Protocol, CmmGraph) -> (BlockEnv Protocol, CmmGraph) -pass_live_vars_as_args procPoints (protos, g) = (protos', g') - where liveness = cmmLivenessZ g - protos' = foldUniqSet addLiveVars protos procPoints +pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet -> + BlockEnv Protocol -> BlockEnv Protocol +pass_live_vars_as_args _liveness procPoints protos = protos' + where protos' = foldBlockSet addLiveVars protos procPoints addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol addLiveVars id protos = case lookupBlockEnv protos id of - Just _ -> protos - 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) - g' = g { gr_blocks = add_CopyIns protos' (gr_blocks g) } - - --- | Add a CopyIn node to each block that has a protocol but lacks the --- appropriate CopyIn node. - -add_CopyIns :: BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock -add_CopyIns protos = mapUFM (maybe_insert_CopyIn protos) - where maybe_insert_CopyIn :: BlockEnv Protocol -> CmmBlock -> CmmBlock - maybe_insert_CopyIn protos b@(Block id t) = - case lookupBlockEnv protos id of - Nothing -> b - Just (Protocol c fs) -> - case t of - ZTail (CopyIn c' fs' _) _ -> - if c == c' && fs == fs' then b - else panic ("mismatched protocols for block " ++ show id) - _ -> Block id (ZTail (CopyIn c fs NoC_SRT) t) - --- XXX also need to add the relevant CopyOut nodes!!! + 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 extendBlockEnv protos id prot + + +-- | 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 -> + FuelMonad [[CmmBlock]] +add_CopyIns callPPs protos blocks = + liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks) + where maybe_insert_CopyIns (_, b@(Block id t)) + | not $ elemBlockSet id callPPs + = case lookupBlockEnv protos id of + Just (Protocol c fs _area) -> + do LGraph _ blocks <- + lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t) + return (map snd $ blockEnvToList blocks) + Nothing -> return [b] + | otherwise = return [b] + +-- | 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 -> + FuelMonad (BlockEnv CmmBlock) +add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv) g + where mb_copy_out :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) -> + FuelMonad (BlockEnv CmmBlock) + mb_copy_out b@(Block bid _) z | bid == lg_entry g = skip b z + mb_copy_out b z = + case last $ unzip b of + LastOther (LastCall _ _ _ _ _) -> skip b z -- copy out done by callee + _ -> copy_out b z + copy_out b z = fold_succs trySucc b init >>= finish + where init = z >>= (\bmap -> return (b, bmap)) + trySucc succId z = + if elemBlockSet succId procPoints then + case lookupBlockEnv protos succId 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@(Block bid _), bmap) = + return $ (extendBlockEnv bmap bid b) + skip b@(Block bid _) bs = + bs >>= (\bmap -> return (extendBlockEnv bmap bid b)) + +-- 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. +splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> + CmmTopZ -> FuelMonad [CmmTopZ] +splitAtProcPoints entry_label callPPs procPoints procMap + (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args + (stackInfo, g@(LGraph entry blocks))) = + do -- Build a map from procpoints to the blocks they reach + let addBlock b@(Block bid _) graphEnv = + case lookupBlockEnv procMap bid of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case blockSetToList 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) + add graphEnv procId bid b = extendBlockEnv graphEnv procId graph' + where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv + graph' = extendBlockEnv graph bid b + graphEnv <- return $ fold_blocks addBlock emptyBlockEnv 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 $ addToFM map pp lbl + where lbl = if pp == entry then entry_label else blockLbl pp + procLabels <- foldM add_label emptyFM + (filter (elemBlockEnv blocks) (blockSetToList 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 -- no overflow for passing those variables + let add_sp_off b env = + case last (unzip b) of + LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off, + cml_ret_off = updfr_off}) -> + extendBlockEnv env succ (off, updfr_off) + _ -> env + spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, stackInfo)]) g + getStackInfo id = lookupBlockEnv spEntryMap id `orElse` (0, 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 = Block bid (ZLast (LastOther jump)) + (argSpace, _) = getStackInfo pp + jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace 0 Nothing + l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l + return (extendBlockEnv env pp bid, b : bs) + add_jumps (newGraphEnv) (ppId, blockEnv) = + do let needed_jumps = -- find which procpoints we currently branch to + foldBlockEnv' add_if_branch_to_pp [] blockEnv + add_if_branch_to_pp block rst = + case last (unzip block) of + LastOther (LastBranch id) -> add_if_pp id rst + LastOther (LastCondBranch _ ti fi) -> + add_if_pp ti (add_if_pp fi rst) + LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl) + _ -> rst + add_if_pp id rst = case lookupFM procLabels id of + Just x -> (id, x) : rst + Nothing -> rst + (jumpEnv, jumpBlocks) <- + foldM add_jump_block (emptyBlockEnv, []) needed_jumps + -- update the entry block + let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId + off = getStackInfo ppId + blockEnv' = extendBlockEnv blockEnv ppId b + -- replace branches to procpoints with branches to jumps + LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv' + -- add the jump blocks to the graph + blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks + let g' = (off, LGraph ppId blockEnv''') + -- pprTrace "g' pre jumps" (ppr g') $ do + return (extendBlockEnv newGraphEnv ppId g') + graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv + let to_proc (bid, g) | elemBlockSet bid callPPs = + if bid == entry then + CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g) + else + CmmProc emptyContInfoTable lbl [] (replacePPIds g) + where lbl = expectJust "pp label" $ lookupFM procLabels bid + to_proc (bid, g) = + CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g) + where lbl = expectJust "pp label" $ lookupFM procLabels bid + -- References to procpoint IDs can now be replaced with the infotable's label + replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g) + where repl e@(CmmLit (CmmBlock bid)) = + case lookupFM procLabels bid 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, emptyBlockEnv) (postorder_dfs g) + add_block_num (i, map) (Block bid _) = (i+1, extendBlockEnv map bid i) + sort_fn (bid, _) (bid', _) = + compare (expectJust "block_order" $ lookupBlockEnv block_order bid) + (expectJust "block_order" $ lookupBlockEnv block_order bid') + procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv + return -- pprTrace "procLabels" (ppr procLabels) + -- pprTrace "splitting graphs" (ppr procs) + procs +splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] ----------------------------------------------------------------