-module CmmLive (
- CmmLive, BlockEntryLiveness,
- cmmLiveness,
- cmmFormalsToLiveLocals
- ) where
-
-#include "HsVersions.h"
-
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+
+module CmmLive
+ ( CmmLive
+ , cmmLiveness
+ , liveLattice
+ , noLiveOnEntry, xferLive
+ )
+where
+
+import BlockId
import Cmm
-import Dataflow
+import CmmExpr
+import Control.Monad
+import OptimizationFuel
+import PprCmmExpr ()
+import Compiler.Hoopl
import Maybes
-import Panic
-import UniqFM
+import Outputable
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
+-- | The variables live on entry to a block
+type CmmLive = RegSet
- 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 _ = []
+-- | The dataflow lattice
+liveLattice :: DataflowLattice CmmLive
+liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
+ where add _ (OldFact old) (NewFact new) = case unionUniqSets old new of
+ join -> (changeIf $ sizeUniqSet join > sizeUniqSet old, join)
---------------------------------
--- 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"
+-- | A mapping from block labels to the variables live on entry
+type BlockEntryLiveness = BlockEnv CmmLive
-----------------------------------------------------------------------------
--- 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
-
+-- | Calculated liveness info for a CmmGraph
-----------------------------------------------------------------------------
--- 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
---------------------------------
-cmmFormalsToLiveLocals :: CmmFormals -> [LocalReg]
-cmmFormalsToLiveLocals [] = []
-cmmFormalsToLiveLocals ((CmmGlobal _,_):args) = cmmFormalsToLiveLocals args
-cmmFormalsToLiveLocals ((CmmLocal r,_):args) = r:cmmFormalsToLiveLocals args
-
-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 $ cmmFormalsToLiveLocals results) where
- 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 _) = []
+cmmLiveness :: CmmGraph -> FuelUniqSM BlockEntryLiveness
+cmmLiveness graph =
+ liftM check $ liftM snd $ dataflowPassBwd graph [] $ analBwd liveLattice xferLive
+ where entry = g_entry graph
+ check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
+
+gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
+gen_kill a = gen a . kill a
+
+-- | On entry to the procedure, there had better not be any LocalReg's live-in.
+noLiveOnEntry :: BlockId -> CmmLive -> a -> a
+noLiveOnEntry bid in_fact x =
+ if isEmptyUniqSet in_fact then x
+ else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
+
+-- | The transfer equations use the traditional 'gen' and 'kill'
+-- notations, which should be familiar from the dragon book.
+gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
+gen a live = foldRegsUsed extendRegSet live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd delOneFromUniqSet live a
+
+-- Testing!
+xferLive :: BwdTransfer CmmNode CmmLive
+xferLive = mkBTransfer3 fst mid lst
+ where fst _ f = f
+ mid :: CmmNode O O -> CmmLive -> CmmLive
+ mid n f = gen_kill n f
+ lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
+ lst n f = gen_kill n $ case n of CmmCall {} -> emptyRegSet
+ CmmForeignCall {} -> emptyRegSet
+ _ -> joinOutFacts liveLattice n f
projects / ghc-hetmet.git / blobdiff