module CmmProcPointZ
( ProcPointSet, Status(..)
, callProcPoints, minimalProcPointSet
, addProcPointProtocols, splitAtProcPoints, procPointAnalysis
)
where
import Prelude hiding (zip, unzip, last)
import BlockId
import CLabel
import Cmm hiding (blockId)
import CmmContFlowOpt
import CmmInfo
import CmmLiveZ
import CmmTx
import DFMonad
import Data.List (sortBy)
import Maybes
import MkZipCfg
import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)
import Control.Monad
import Outputable
import UniqSet
import UniqSupply
import ZipCfg
import ZipCfgCmmRep
import ZipDataflow
import qualified Data.Map as Map
type ProcPointSet = BlockSet
data Status
= ReachedBy ProcPointSet
| ProcPoint
instance Outputable Status where
ppr (ReachedBy ps)
| isEmptyBlockSet ps = text "<not-reached>"
| otherwise = text "reached by" <+>
(hsep $ punctuate comma $ map ppr $ blockSetToList ps)
ppr ProcPoint = text "<procpt>"
lattice :: DataflowLattice Status
lattice = DataflowLattice "direct proc-point reachability" unreached add_to False
where unreached = ReachedBy emptyBlockSet
add_to _ ProcPoint = noTx ProcPoint
add_to ProcPoint _ = aTx ProcPoint
add_to (ReachedBy p) (ReachedBy p') =
let union = unionBlockSets p p'
in if sizeBlockSet union > sizeBlockSet p' then
aTx (ReachedBy union)
else
noTx (ReachedBy p')
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
callProcPoints :: CmmGraph -> 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 :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet
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 =
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
newId succ_id = not (elemBlockSet succ_id procPoints') &&
nreached succ_id > block_procpoints
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'
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
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 =
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)
maybe_add_call block (protos, blocks) =
case goto_end $ unzip block of
(h, LastOther (LastCall tgt (Just k) args res s))
| Just proto <- lookupBlockEnv protos k,
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
Nothing -> (extendBlockEnv protos pee proto,changed_blocks)
Just proto' ->
if proto == proto' then (protos, changed_blocks)
else (protos, unchanged_blocks)
_ -> (protos, insertBlock block blocks)
branchesToProcPoint :: BlockId -> Maybe BlockId
branchesToProcPoint id =
let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
panic "branch out of graph"
in case t of
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 _ env = env
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' = foldBlockSet addLiveVars protos procPoints
addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
addLiveVars id protos =
case lookupBlockEnv protos id of
Just _ -> protos
Nothing -> let live = emptyRegSet
formals = uniqSetToList live
prot = Protocol Private formals $ CallArea $ Young id
in extendBlockEnv protos id prot
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_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 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
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))
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
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
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 (elemBlockEnv blocks) (blockSetToList procPoints))
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)
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 =
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 Map.lookup id procLabels of
Just x -> (id, x) : rst
Nothing -> rst
(jumpEnv, jumpBlocks) <-
foldM add_jump_block (emptyBlockEnv, []) needed_jumps
let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId
off = getStackInfo ppId
blockEnv' = extendBlockEnv blockEnv ppId b
LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv'
blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
let g' = (off, LGraph ppId blockEnv''')
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" $ Map.lookup bid procLabels
to_proc (bid, g) =
CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)
where lbl = expectJust "pp label" $ Map.lookup bid procLabels
replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast 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
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
procs
splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]