X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmProcPointZ.hs;h=c972ad59abbc1e76e67b5a531eeb2a1fac8c35cc;hb=8350c21760d8610b0b2f329095ffb80bb1bc20d9;hp=5ec65c5d0b1a1b7dbc2113fe1a863f082fc17a85;hpb=31a9d04804d9cacda35695c5397590516b964964;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 5ec65c5..c972ad5 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -5,32 +5,30 @@ module CmmProcPointZ ) where -import qualified Prelude as P import Prelude hiding (zip, unzip, last) import BlockId import CLabel import Cmm hiding (blockId) import CmmContFlowOpt -import CmmExpr import CmmInfo import CmmLiveZ import CmmTx import DFMonad -import FiniteMap -import List (sortBy) +import Data.List (sortBy) import Maybes import MkZipCfg import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ) -import Monad +import Control.Monad import Outputable -import Panic import UniqSet import UniqSupply import ZipCfg import ZipCfgCmmRep import ZipDataflow +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 @@ -130,18 +128,21 @@ forward = ForwardTransfers first middle last exit -- 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 :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet +-- Given the set of successors of calls (which must be proc-points) +-- figure ou the minimal set of necessary proc-points minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ()) procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status) +-- Once you know what the proc-points are, figure out +-- what proc-points each block is reachable from procPointAnalysis procPoints g = let addPP env id = extendBlockEnv env id ProcPoint initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints) @@ -329,7 +330,7 @@ add_CopyIns callPPs protos blocks = = case lookupBlockEnv protos id of Just (Protocol c fs _area) -> do LGraph _ blocks <- - lgraphOfAGraph (mkLabel id <*> copyInSlot c False fs <*> mkZTail t) + lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t) return (map snd $ blockEnvToList blocks) Nothing -> return [b] | otherwise = return [b] @@ -356,8 +357,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv if elemBlockSet succId procPoints then case lookupBlockEnv protos succId of Nothing -> z - Just (Protocol c fs _area) -> - insert z succId $ copyOutSlot c Jump fs + Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs else z insert z succId m = do (b, bmap) <- z @@ -400,9 +400,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap 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 + 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 emptyFM + procLabels <- foldM add_label Map.empty (filter (elemBlockEnv blocks) (blockSetToList procPoints)) -- For each procpoint, we need to know the SP offset on entry. -- If the procpoint is: @@ -435,7 +435,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap 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 + add_if_pp id rst = case Map.lookup id procLabels of Just x -> (id, x) : rst Nothing -> rst (jumpEnv, jumpBlocks) <- @@ -454,13 +454,20 @@ splitAtProcPoints entry_label callPPs procPoints procMap 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 g + CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g) else - CmmProc emptyContInfoTable lbl [] g - where lbl = expectJust "pp label" $ lookupFM procLabels bid + CmmProc emptyContInfoTable lbl [] (replacePPIds g) + where lbl = expectJust "pp label" $ Map.lookup bid procLabels to_proc (bid, g) = - CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] g - where lbl = expectJust "pp label" $ lookupFM procLabels bid + CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) 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 (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 -- 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)