From 3de1c72b6fdc52cd9c1938f21b8d284cc3cdbbc9 Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Mon, 21 May 2007 18:25:17 +0000 Subject: [PATCH] Added forgotten ./compiler/cmm/CmmLive.hs --- compiler/cmm/CmmLive.hs | 211 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 211 insertions(+) create mode 100644 compiler/cmm/CmmLive.hs diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs new file mode 100644 index 0000000..0a4eb67 --- /dev/null +++ b/compiler/cmm/CmmLive.hs @@ -0,0 +1,211 @@ +module CmmLive ( + CmmLive, BlockEntryLiveness, + cmmLiveness + ) where + +import Cmm +import Dataflow + +import Maybes +import Panic +import UniqFM +import UniqSet + +import Data.List + +----------------------------------------------------------------------------- +-- Calculating what variables are live on entry to a basic block +----------------------------------------------------------------------------- + +-- The variables live on entry to a block +type CmmLive = UniqSet LocalReg + +-- A mapping from block labels to the variables live on entry +type BlockEntryLiveness = BlockEnv CmmLive + +----------------------------------------------------------------------------- +-- cmmLiveness and helpers +----------------------------------------------------------------------------- +cmmLiveness :: [CmmBasicBlock] -> BlockEntryLiveness +cmmLiveness blocks = + fixedpoint (cmmBlockDependants sources) + (cmmBlockUpdate blocks') + (map blockId blocks) + (listToUFM [(blockId b, emptyUniqSet) | b <- blocks]) + where + sources = cmmBlockSources blocks + blocks' = cmmBlockNames blocks + +{- +-- For debugging, annotate each block with a comment indicating +-- the calculated live variables +cmmLivenessComment :: + BlockEnv (UniqSet LocalReg) -> CmmBasicBlock -> CmmBasicBlock +cmmLivenessComment live (BasicBlock ident stmts) = + BasicBlock ident stmts' where + stmts' = (CmmComment $ mkFastString $ showSDoc $ ppr $ live'):stmts + live' = map CmmLocal $ uniqSetToList $ lookupWithDefaultUFM live emptyUniqSet ident +-} + + +-------------------------------- +-- cmmBlockSources +-- +-- Calculates a table of blocks +-- that might need updating after +-- a given block is updated +-------------------------------- +cmmBlockSources :: [CmmBasicBlock] -> BlockEnv (UniqSet BlockId) +cmmBlockSources blocks = foldr aux emptyUFM blocks + where + aux :: CmmBasicBlock + -> BlockEnv (UniqSet BlockId) + -> BlockEnv (UniqSet BlockId) + aux block sourcesUFM = + foldUniqSet (add_source_edges $ blockId block) + sourcesUFM + (branch_targets $ blockStmts block) + + add_source_edges :: BlockId -> BlockId + -> BlockEnv (UniqSet BlockId) + -> BlockEnv (UniqSet BlockId) + add_source_edges source target ufm = + addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm target source + + branch_targets :: [CmmStmt] -> UniqSet BlockId + branch_targets stmts = + mkUniqSet $ concatMap target stmts where + target (CmmBranch ident) = [ident] + target (CmmCondBranch _ ident) = [ident] + target (CmmSwitch _ blocks) = mapMaybe id blocks + target _ = [] + +-------------------------------- +-- cmmBlockNames +-- +-- Calculates a table that maps +-- block names to the list +-- of statements inside them +-------------------------------- +cmmBlockNames :: [CmmBasicBlock] -> BlockEnv [CmmStmt] +cmmBlockNames blocks = listToUFM $ map block_name blocks where + block_name b = (blockId b, blockStmts b) + +-------------------------------- +-- cmmBlockDependants +-- +-- Given the table calculated +-- by cmmBlockSources created, +-- list all blocks that depend +-- on the result of a particular +-- block. +-------------------------------- +cmmBlockDependants :: BlockEnv (UniqSet BlockId) -> BlockId -> [BlockId] +cmmBlockDependants sources ident = + uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident + +-------------------------------- +-- cmmBlockUpdate +-- +-- Given the table from +-- cmmBlockNames and a block +-- that was updated, calculate +-- an updated BlockEntryLiveness +-------------------------------- +cmmBlockUpdate :: + BlockEnv [CmmStmt] + -> BlockId + -> Maybe BlockId + -> BlockEntryLiveness + -> Maybe BlockEntryLiveness +cmmBlockUpdate blocks node _ state = + if (sizeUniqSet old_live) == (sizeUniqSet new_live) + then Nothing + else Just $ addToUFM state node new_live + where + new_live = cmmStmtListLive state block + old_live = lookupWithDefaultUFM state missing_live node + block = lookupWithDefaultUFM blocks missing_block node + missing_live = panic "unknown block id during liveness analysis" + missing_block = panic "unknown block id during liveness analysis" + +----------------------------------------------------------------------------- +-- CmmBlockLive, cmmStmtListLive and helpers +----------------------------------------------------------------------------- + +-- Calculate the live registers for a local block (list of statements) + +cmmStmtListLive :: BlockEntryLiveness -> [CmmStmt] -> CmmLive +cmmStmtListLive other_live stmts = + foldr ((.) . (cmmStmtLive other_live)) id stmts emptyUniqSet + +----------------------------------------------------------------------------- +-- This code is written in the style of a state monad, +-- but since Control.Monad.State is not in the core +-- we can't use it in GHC, so we'll fake one here. +-- We don't need a return value so well leave it out. +-- Thus 'bind' reduces to function composition. + +type CmmLivenessTransformer = CmmLive -> CmmLive + +-- Helpers for the "Monad" +addLive, addKilled :: CmmLive -> CmmLivenessTransformer +addLive new_live live = live `unionUniqSets` new_live +addKilled new_killed live = live `minusUniqSet` new_killed + +-------------------------------- +-- Liveness of a CmmStmt +-------------------------------- +cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer +cmmStmtLive _ (CmmNop) = id +cmmStmtLive _ (CmmComment _) = id +cmmStmtLive _ (CmmAssign reg expr) = + cmmExprLive expr . reg_liveness where + reg_liveness = + case reg of + (CmmLocal reg') -> addKilled $ unitUniqSet reg' + (CmmGlobal _) -> id +cmmStmtLive _ (CmmStore expr1 expr2) = + cmmExprLive expr2 . cmmExprLive expr1 +cmmStmtLive _ (CmmCall target results arguments _) = + target_liveness . + foldr ((.) . cmmExprLive) id (map fst arguments) . + addKilled (mkUniqSet $ only_local_regs results) where + only_local_regs [] = [] + only_local_regs ((CmmGlobal _,_):args) = only_local_regs args + only_local_regs ((CmmLocal r,_):args) = r:only_local_regs args + target_liveness = + case target of + (CmmForeignCall target _) -> cmmExprLive target + (CmmPrim _) -> id +cmmStmtLive other_live (CmmBranch target) = + addLive (lookupWithDefaultUFM other_live emptyUniqSet target) +cmmStmtLive other_live (CmmCondBranch expr target) = + cmmExprLive expr . + addLive (lookupWithDefaultUFM other_live emptyUniqSet target) +cmmStmtLive other_live (CmmSwitch expr targets) = + cmmExprLive expr . + (foldr ((.) . (addLive . + lookupWithDefaultUFM other_live emptyUniqSet)) + id + (mapCatMaybes id targets)) +cmmStmtLive _ (CmmJump expr params) = + const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet) +cmmStmtLive _ (CmmReturn params) = + const (foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet) + +-------------------------------- +-- Liveness of a CmmExpr +-------------------------------- +cmmExprLive :: CmmExpr -> CmmLivenessTransformer +cmmExprLive expr = addLive (mkUniqSet $ expr_liveness expr) where + expr_liveness :: CmmExpr -> [LocalReg] + expr_liveness (CmmLit _) = [] + expr_liveness (CmmLoad expr _) = expr_liveness expr + expr_liveness (CmmReg reg) = reg_liveness reg + expr_liveness (CmmMachOp _ exprs) = concatMap expr_liveness exprs + expr_liveness (CmmRegOff reg _) = reg_liveness reg + + reg_liveness :: CmmReg -> [LocalReg] + reg_liveness (CmmLocal reg) = [reg] + reg_liveness (CmmGlobal _) = [] -- 1.7.10.4