X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmProcPointZ.hs;h=6cc5a769a3917bda82e70ddf244739acb06c7ab8;hp=279c730d4615c3a2535cd7b3979148680d101e48;hb=25628e2771424cae1b3366322e8ce6f8a85440f9;hpb=8b7eaa404043294bd4cb4a0322ac1f7115bad6a0 diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 279c730..6cc5a76 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -1,28 +1,36 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} + module CmmProcPointZ - ( minimalProcPointSet + ( callProcPoints, minimalProcPointSet , addProcPointProtocols + , splitAtProcPoints ) where -import Prelude hiding (zip, unzip) +import Prelude hiding (zip, unzip, last) -import ClosureInfo +import CLabel +--import ClosureInfo import Cmm hiding (blockId) import CmmExpr import CmmContFlowOpt import CmmLiveZ import CmmTx import DFMonad +import FiniteMap import ForeignCall -- used in protocol for the entry point import MachOp (MachHint(NoHint)) import Maybes +import MkZipCfgCmm hiding (CmmBlock, CmmGraph) +import Monad +import Name import Outputable import Panic +import StackSlot 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. @@ -111,48 +119,66 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals -------------------------------------------------- -- transfer equations -forward :: FAnalysis Middle Last Status -forward = FComp "proc-point reachability" first middle last exit +forward :: ForwardTransfers Middle Last Status +forward = ForwardTransfers 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 _ (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 - 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 entryPoint g + where entryPoint = unitUniqSet (lg_entry g) + 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 PPFix +procPointAnalysis procPoints g = + let addPP env id = extendBlockEnv env id ProcPoint + initProcPoints = foldl addPP emptyBlockEnv (uniqSetToList procPoints) + in runDFM lattice $ -- init with old facts and solve + return $ (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 id > my_nreached - in listToMaybe $ filter newId $ succs b + do res <- procPointAnalysis procPoints g + env <- liftM zdfFpFacts res + 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 + 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 + 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' + + ------------------------------------------------------------------------ @@ -204,21 +230,28 @@ algorithm would be just as good, so that's what we do. -} -data Protocol = Protocol Convention CmmHintFormals +data Protocol = Protocol Convention CmmFormals StackArea 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 -> CmmFormals -> CmmGraph -> CmmGraph -addProcPointProtocols procPoints formals g = - snd $ add_unassigned procPoints $ optimize_calls g - where optimize_calls g = -- see Note [Separate Adams optimization] +addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmFormalsWithoutKinds -> + CmmGraph -> FuelMonad CmmGraph +addProcPointProtocols callPPs procPoints formals g = + do liveness <- cmmLivenessZ g + (protos, g') <- return $ 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] 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') + protos' = add_unassigned liveness procPoints protos + g' = LGraph (lg_entry g) $ add_CopyIns callPPs protos' blocks' + in (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 +259,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))) | Just proto <- lookupBlockEnv protos k, - Just pee <- jumpsToProcPoint 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 @@ -243,63 +276,174 @@ addProcPointProtocols procPoints formals g = 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` + let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse` panic "jump out of graph" in case t of - ZTail (CopyOut {}) (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 :: 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) + extendBlockEnv env id (Protocol c fs $ toArea id fs) + maybe_add_proto (Block id _) env | id == lg_entry g = + extendBlockEnv env id (Protocol stdArgConvention hfs $ toArea id hfs) maybe_add_proto _ env = env - hinted_formals = map (\x -> (x, NoHint)) formals + toArea id fs = mkStackArea id fs $ Just fs + hfs = map (\x -> CmmKinded 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 -- 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' = foldUniqSet addLiveVars protos procPoints addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol addLiveVars id protos = case lookupBlockEnv protos id of - Just _ -> protos + 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) } + panic ("no liveness at block " ++ show id) + formals = map (\x -> CmmKinded x NoHint) $ uniqSetToList live + prot = Protocol ConventionPrivate formals $ + mkStackArea id formals $ Just formals + in extendBlockEnv protos id prot --- | Add a CopyIn node to each block that has a protocol but lacks the --- appropriate CopyIn node. +-- | 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 :: 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) = +add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock +add_CopyIns callPPs protos = mapUFM maybe_insert_CopyIns + where maybe_insert_CopyIns :: CmmBlock -> CmmBlock + maybe_insert_CopyIns b@(Block id t) | not $ elementOfUniqSet id callPPs = case lookupBlockEnv protos id of Nothing -> b - Just (Protocol c fs) -> + Just (Protocol c fs area) -> 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) + --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) + $ foldr ZTail t (copyIn c area fs) + maybe_insert_CopyIns b = b + +-- | Add a CopyOut node before each procpoint. +-- If the predecessor is a call, then the CopyOut should already exist (in the callee). + +add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph -> + FuelMonad (BlockEnv CmmBlock) +add_CopyOuts protos procPoints g = fold_blocks maybe_insert_CopyOut (return emptyBlockEnv) g + where maybe_insert_CopyOut :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) -> + FuelMonad (BlockEnv CmmBlock) + maybe_insert_CopyOut b@(Block bid _) blocks = + case last $ unzip b of + LastOther (LastCall _ _) -> -- skip calls (copy out done by callee) + blocks >>= (\bmap -> return $ extendBlockEnv bmap bid b) + _ -> maybe_insert_CopyOut' b blocks + maybe_insert_CopyOut' b blocks = fold_succs trySucc b init >>= finish + where init = blocks >>= (\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 $ copyOut c area $ map fetch fs + -- CopyOut c $ map fetch fs + else z + fetch k = k {kindlessCmm = CmmReg $ CmmLocal $ kindlessCmm k} + insert z succId m = + do (b, bmap) <- z + (b, bs) <- insertBetween b m succId + return $ (b, foldl (flip insertBlock) bmap bs) + finish (b@(Block bid _), bmap) = return $ extendBlockEnv bmap bid b + + +-- Input invariant: A block should only be reachable from a single ProcPoint. +-- If you want to duplicate blocks, do it before this gets called. +splitAtProcPoints :: CmmFormalsWithoutKinds -> CLabel -> ProcPointSet -> + CmmGraph -> FuelMonad [CmmGraph] +splitAtProcPoints formals entry_label procPoints g@(LGraph entry _) = + do let layout = layout_stack formals g + pprTrace "stack layout" (ppr layout) $ return () + res <- procPointAnalysis procPoints g + procMap <- liftM zdfFpFacts res + let addBlock b@(Block bid _) graphEnv = + case lookupBlockEnv procMap bid of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case uniqSetToList set of + [] -> graphEnv + [id] -> add graphEnv id bid b + _ -> panic "Each block should be reachable from only one ProcPoint" + Nothing -> panic "block not reached by a proc point?" + 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 + let add_label map pp = clabel pp >>= (\l -> return $ (pp, l) : map) + clabel procPoint = if procPoint == entry then return entry_label + else getUniqueM >>= return . to_label + to_label u = mkEntryLabel (mkFCallName u "procpoint") + procLabels <- foldM add_label [] (uniqSetToList procPoints) + -- 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 (LastJump $ CmmLit $ CmmLabel l))) + return $ (extendBlockEnv env pp bid, b : bs) + add_jumps newGraphEnv (guniq, blockEnv) = + do (jumpEnv, jumpBlocks) <- foldM add_jump_block (emptyBlockEnv, []) procLabels + let ppId = mkBlockId guniq + LGraph _ blockEnv' = replaceLabelsZ jumpEnv $ LGraph ppId blockEnv + blockEnv'' = foldl (flip insertBlock) blockEnv' jumpBlocks + return $ extendBlockEnv newGraphEnv ppId $ + runTx cmmCfgOptsZ $ LGraph ppId blockEnv'' + _ <- return $ replaceLabelsZ + graphEnv <- foldM add_jumps emptyBlockEnv $ ufmToList graphEnv + return $ pprTrace "procLabels" (ppr procLabels) $ + pprTrace "splitting graphs" (ppr graphEnv) $ [g] + +------------------------------------------------------------------------ +-- Stack Layout (completely bogus for now) -- +------------------------------------------------------------------------ + +-- At some point, we'll do stack layout properly. +-- But for now, we can move forward on generating code by just producing +-- a brain dead layout, giving a separate slot to every variable, +-- and (incorrectly) assuming that all parameters are passed on the stack. + +-- For now, variables are placed at explicit offsets from a virtual +-- frame pointer. +-- We may want to use abstract stack slots at some point. +data Placement = VFPMinus Int + +instance Outputable Placement where + ppr (VFPMinus k) = text "VFP - " <> int k + +-- Build a map from registers to stack locations. +-- Return that map along with the offset to the end of the block +-- containing local registers. +layout_stack ::CmmFormalsWithoutKinds -> CmmGraph -> + (Int, FiniteMap LocalReg Placement, FiniteMap LocalReg Placement) +layout_stack formals g = (ix', incomingMap, localMap) + where (ix, incomingMap) = foldl (flip place) (1, emptyFM) formals -- IGNORES CC'S + -- 1 leaves space for the return infotable + (ix', localMap) = foldUniqSet place (ix, emptyFM) regs + place r (ix, map) = (ix', addToFM map r $ VFPMinus ix') where ix' = ix + 1 + regs = fold_blocks (fold_fwd_block (\_ y -> y) add addL) emptyRegSet g + add x y = foldRegsDefd extendRegSet y x + addL (LastOther l) z = add l z + addL LastExit z = z --- XXX also need to add the relevant CopyOut nodes!!! ----------------------------------------------------------------