diff options
Diffstat (limited to 'compiler/cmm/CmmOpt.hs')
| -rw-r--r-- | compiler/cmm/CmmOpt.hs | 269 |
1 files changed, 0 insertions, 269 deletions
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 0df24a6a66..32afa1d078 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -7,8 +7,6 @@ ----------------------------------------------------------------------------- module CmmOpt ( - cmmEliminateDeadBlocks, - cmmMiniInline, cmmMachOpFold, cmmMachOpFoldM, cmmLoopifyForC, @@ -17,282 +15,15 @@ module CmmOpt ( #include "HsVersions.h" import OldCmm -import OldPprCmm -import CmmNode (wrapRecExp) -import CmmUtils import DynFlags import CLabel -import UniqFM -import Unique -import Util import FastTypes import Outputable import Platform -import BlockId import Data.Bits import Data.Maybe -import Data.List - --- ----------------------------------------------------------------------------- --- Eliminates dead blocks - -{- -We repeatedly expand the set of reachable blocks until we hit a -fixpoint, and then prune any blocks that were not in this set. This is -actually a required optimization, as dead blocks can cause problems -for invariants in the linear register allocator (and possibly other -places.) --} - --- Deep fold over statements could probably be abstracted out, but it --- might not be worth the effort since OldCmm is moribund -cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock] -cmmEliminateDeadBlocks [] = [] -cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = - let -- Calculate what's reachable from what block - 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 (CmmAssign _ e) = expr m e - stmt m (CmmStore e1 e2) = expr (expr m e1) e2 - stmt m (CmmCall c _ as _) = f (actuals m as) c - where f m (CmmCallee e _) = expr m e - f m (CmmPrim _ Nothing) = m - f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts - 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 _) = expr m e - stmt m (CmmReturn) = m - 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 (CmmStackSlot _ _) = m - expr m (CmmRegOff _ _) = m - lit m (CmmBlock b) = b:m - lit m _ = m - -- 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. 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: - - 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) - - if we reach the statement that uses it, inline the rhs - and delete the original assignment. - -[N.B. In the Quick C-- compiler, this optimization is achieved by a - combination of two dataflow passes: forward substitution (peephole - optimization) and dead-assignment elimination. ---NR] - -Possible generalisations: here is an example from factorial - -Fac_zdwfac_entry: - cmG: - _smi = R2; - if (_smi != 0) goto cmK; - R1 = R3; - jump I64[Sp]; - cmK: - _smn = _smi * R3; - R2 = _smi + (-1); - R3 = _smn; - jump Fac_zdwfac_info; - -We want to inline _smi and _smn. To inline _smn: - - - we must be able to push forward past assignments to global regs. - We can do this if the rhs of the assignment we are pushing - forward doesn't refer to the global reg being assigned to; easy - to test. - -To inline _smi: - - - It is a trivial replacement, reg for reg, but it occurs more than - once. - - We can inline trivial assignments even if the temporary occurs - more than once, as long as we don't eliminate the original assignment - (this doesn't help much on its own). - - We need to be able to propagate the assignment forward through jumps; - if we did this, we would find that it can be inlined safely in all - its occurrences. --} - -countUses :: UserOfLocalRegs a => a -> UniqFM Int -countUses a = foldRegsUsed (\m r -> addToUFM_C (+) m r 1) emptyUFM a - -cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock] -cmmMiniInline dflags blocks = map do_inline blocks - where do_inline (BasicBlock id stmts) - = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts) - -cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt] -cmmMiniInlineStmts _ _ [] = [] -cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) - -- not used: just discard this assignment - | 0 <- lookupWithDefaultUFM uses 0 u - = cmmMiniInlineStmts dflags uses stmts - - -- used (foldable to small thing): try to inline at all the use sites - | Just n <- lookupUFM uses u, - e <- wrapRecExp foldExp expr, - isTiny e - = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ - case lookForInlineMany u e stmts of - (m, stmts') - | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' - | otherwise -> - stmt : cmmMiniInlineStmts dflags (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 - = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ - cmmMiniInlineStmts dflags uses stmts' - where - isTiny (CmmLit _) = True - isTiny (CmmReg (CmmGlobal _)) = True - -- not CmmLocal: that might invalidate the usage analysis results - isTiny _ = False - - foldExp (CmmMachOp op args) = cmmMachOpFold dflags op args - foldExp e = e - - ncgDebugTrace str x = if ncgDebugIsOn then trace str x else x - -cmmMiniInlineStmts platform uses (stmt:stmts) - = stmt : cmmMiniInlineStmts platform 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. -lookForInlineMany :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt]) -lookForInlineMany u expr stmts = lookForInlineMany' u expr regset stmts - where regset = foldRegsUsed extendRegSet emptyRegSet expr - -lookForInlineMany' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> (Int, [CmmStmt]) -lookForInlineMany' _ _ _ [] = (0, []) -lookForInlineMany' u expr regset stmts@(stmt : rest) - | Just n <- lookupUFM (countUses stmt) u, okToInline expr stmt - = let stmt' = inlineStmt u expr stmt in - if okToSkip stmt' u expr regset - then case lookForInlineMany' u expr regset rest of - (m, stmts) -> let z = n + m - in z `seq` (z, stmt' : stmts) - else (n, stmt' : rest) - - | okToSkip stmt u expr regset - = case lookForInlineMany' u expr regset rest of - (n, stmts) -> (n, stmt : stmts) - - | otherwise - = (0, stmts) - - -lookForInline :: Unique -> CmmExpr -> [CmmStmt] -> Maybe [CmmStmt] -lookForInline u expr stmts = lookForInline' u expr regset stmts - where regset = foldRegsUsed extendRegSet emptyRegSet expr - -lookForInline' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> Maybe [CmmStmt] -lookForInline' _ _ _ [] = panic "lookForInline' []" -lookForInline' u expr regset (stmt : rest) - | Just 1 <- lookupUFM (countUses stmt) u, okToInline expr stmt - = Just (inlineStmt u expr stmt : rest) - - | okToSkip stmt u expr regset - = case lookForInline' u expr regset rest of - Nothing -> Nothing - Just stmts -> Just (stmt:stmts) - - | otherwise - = Nothing - - --- we don't inline into CmmCall if the expression refers to global --- registers. This is a HACK to avoid global registers clashing with --- C argument-passing registers, really the back-end ought to be able --- to handle it properly, but currently neither PprC nor the NCG can --- do it. See also CgForeignCall:load_args_into_temps. -okToInline :: CmmExpr -> CmmStmt -> Bool -okToInline expr CmmCall{} = hasNoGlobalRegs expr -okToInline _ _ = True - --- Expressions aren't side-effecting. Temporaries may or may not --- be single-assignment depending on the source (the old code --- generator creates single-assignment code, but hand-written Cmm --- and Cmm from the new code generator is not single-assignment.) --- So we do an extra check to make sure that the register being --- changed is not one we were relying on. I don't know how much of a --- performance hit this is (we have to create a regset for every --- instruction.) -- EZY -okToSkip :: CmmStmt -> Unique -> CmmExpr -> RegSet -> Bool -okToSkip stmt u expr regset - = case stmt of - CmmNop -> True - CmmComment{} -> True - CmmAssign (CmmLocal r@(LocalReg u' _)) _rhs | u' /= u && not (r `elemRegSet` regset) -> True - CmmAssign g@(CmmGlobal _) _rhs -> not (g `regUsedIn` expr) - CmmStore _ _ -> not_a_load expr - _other -> False - where - not_a_load (CmmMachOp _ args) = all not_a_load args - not_a_load (CmmLoad _ _) = False - not_a_load _ = True - -inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt -inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e) -inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2) -inlineStmt u a (CmmCall target regs es ret) - = CmmCall (infn target) regs es' ret - where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv - infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts) - es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] -inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d -inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d -inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live -inlineStmt _ _ other_stmt = other_stmt - -inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr -inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _))) - | u == u' = a - | otherwise = e -inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off) - | u == u' = CmmMachOp (MO_Add width) [a, CmmLit (CmmInt (fromIntegral off) width)] - | otherwise = e - where - width = typeWidth rep -inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep -inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es) -inlineExpr _ _ other_expr = other_expr -- ----------------------------------------------------------------------------- -- MachOp constant folder |