Added forgotten ./compiler/cmm/CmmLive.hs

1 files changed, 211 insertions, 0 deletions

diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
new file mode 100644
index 0000000000..0a4eb67ae3
--- /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 _) = []