import Data.Word
import Data.Int
import Data.Maybe
+import Data.List
import Compiler.Hoopl hiding (Unique)
cmmEliminateDeadBlocks [] = []
cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
let -- Calculate what's reachable from what block
- -- We have to do a deep fold into CmmExpr because
- -- there may be a BlockId in the CmmBlock literal.
- reachableMap = foldl f emptyBlockMap blocks
- where f m (BasicBlock block_id stmts) = mapInsert block_id (reachableFrom stmts) m
- reachableFrom stmts = foldl stmt emptyBlockSet stmts
+ reachableMap = foldl' f emptyUFM blocks -- lazy in values
+ where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
+ reachableFrom stmts = foldl stmt [] stmts
where
stmt m CmmNop = m
stmt m (CmmComment _) = m
stmt m (CmmCall c _ as _ _) = f (actuals m as) c
where f m (CmmCallee e _) = expr m e
f m (CmmPrim _) = m
- stmt m (CmmBranch b) = setInsert b m
- stmt m (CmmCondBranch e b) = setInsert b (expr m e)
- stmt m (CmmSwitch e bs) = foldl (flip setInsert) (expr m e) (catMaybes bs)
+ stmt m (CmmBranch b) = b:m
+ stmt m (CmmCondBranch e b) = b:(expr m e)
+ stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
stmt m (CmmJump e as) = expr (actuals m as) e
stmt m (CmmReturn as) = actuals m as
- actuals m as = foldl (\m h -> expr m (hintlessCmm h)) m as
+ actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
+ -- We have to do a deep fold into CmmExpr because
+ -- there may be a BlockId in the CmmBlock literal.
expr m (CmmLit l) = lit m l
expr m (CmmLoad e _) = expr m e
expr m (CmmReg _) = m
- expr m (CmmMachOp _ es) = foldl expr m es
+ expr m (CmmMachOp _ es) = foldl' expr m es
expr m (CmmStackSlot _ _) = m
expr m (CmmRegOff _ _) = m
- lit m (CmmBlock b) = setInsert b m
+ lit m (CmmBlock b) = b:m
lit m _ = m
- -- Expand reachable set until you hit fixpoint
- initReachable = setSingleton base_id :: BlockSet
- expandReachable old_set new_set =
- if setSize new_set > setSize old_set
- then expandReachable new_set $ setFold
- (\x s -> maybe setEmpty id (mapLookup x reachableMap) `setUnion` s)
- new_set
- (setDifference new_set old_set)
- else new_set -- fixpoint achieved
- reachable = expandReachable setEmpty initReachable
+ -- go todo done
+ reachable = go [base_id] (setEmpty :: BlockSet)
+ where go [] m = m
+ go (x:xs) m
+ | setMember x m = go xs m
+ | otherwise = go (add ++ xs) (setInsert x m)
+ where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
+ (lookupUFM reachableMap x)
in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
-- -----------------------------------------------------------------------------
-- The mini-inliner
{-
-This pass inlines assignments to temporaries that are used just
-once. It works as follows:
+This pass inlines assignments to temporaries. Temporaries that are
+only used once are unconditionally inlined. Temporaries that are used
+two or more times are only inlined if they are assigned a literal. It
+works as follows:
- count uses of each temporary
- - for each temporary that occurs just once:
+ - for each temporary:
- attempt to push it forward to the statement that uses it
- only push forward past assignments to other temporaries
(assumes that temporaries are single-assignment)
cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
cmmMiniInlineStmts uses [] = []
cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
- -- not used at all: just discard this assignment
+ -- not used: just discard this assignment
| Nothing <- lookupUFM uses u
= cmmMiniInlineStmts uses stmts
- -- used once: try to inline at the use site
+ -- used (literal): try to inline at all the use sites
+ | Just n <- lookupUFM uses u, isLit expr
+ =
+#ifdef NCG_DEBUG
+ trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
+#endif
+ case lookForInlineLit u expr stmts of
+ (m, stmts')
+ | n == m -> cmmMiniInlineStmts (delFromUFM uses u) stmts'
+ | otherwise ->
+ stmt : cmmMiniInlineStmts (adjustUFM (\x -> x - m) uses u) stmts'
+
+ -- used (foldable to literal): try to inline at all the use sites
+ | Just n <- lookupUFM uses u,
+ CmmMachOp op es <- expr,
+ e@(CmmLit _) <- cmmMachOpFold op es
+ =
+#ifdef NCG_DEBUG
+ trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
+#endif
+ case lookForInlineLit u e stmts of
+ (m, stmts')
+ | n == m -> cmmMiniInlineStmts (delFromUFM uses u) stmts'
+ | otherwise ->
+ stmt : cmmMiniInlineStmts (adjustUFM (\x -> x - m) uses u) stmts'
+
+ -- used once (non-literal): try to inline at the use site
| Just 1 <- lookupUFM uses u,
Just stmts' <- lookForInline u expr stmts
=
cmmMiniInlineStmts uses (stmt:stmts)
= stmt : cmmMiniInlineStmts uses stmts
+-- | Takes a register, a 'CmmLit' expression assigned to that
+-- register, and a list of statements. Inlines the expression at all
+-- use sites of the register. Returns the number of substituations
+-- made and the, possibly modified, list of statements.
+lookForInlineLit :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt])
+lookForInlineLit _ _ [] = (0, [])
+lookForInlineLit u expr stmts@(stmt : rest)
+ | Just n <- lookupUFM (countUses stmt) u
+ = case lookForInlineLit u expr rest of
+ (m, stmts) -> let z = n + m
+ in z `seq` (z, inlineStmt u expr stmt : stmts)
+
+ | ok_to_skip
+ = case lookForInlineLit u expr rest of
+ (n, stmts) -> (n, stmt : stmts)
+
+ | otherwise
+ = (0, stmts)
+ where
+ -- We skip over assignments to registers, unless the register
+ -- being assigned to is the one we're inlining.
+ ok_to_skip = case stmt of
+ CmmAssign (CmmLocal r@(LocalReg u' _)) _ | u' == u -> False
+ _other -> True
+
lookForInline u expr stmts = lookForInline' u expr regset stmts
where regset = foldRegsUsed extendRegSet emptyRegSet expr
projects / ghc-hetmet.git / blobdiff