X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmOpt.hs;h=69df4fbff14bab176a615c6c9e219de64ab1a570;hp=1c7e7e53cb09b907414b83894591537e4cca16e1;hb=7b5b3b0cab463e108a0132435a28ef19d17cb32b;hpb=50f5c8491bfcb6b891f772e2915443dbb5078e97

diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 1c7e7e5..69df4fb 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -37,6 +37,7 @@ import Data.Bits
 import Data.Word
 import Data.Int
 import Data.Maybe
+import Data.List
 
 import Compiler.Hoopl hiding (Unique)
 
@@ -57,11 +58,9 @@ cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
 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
@@ -70,41 +69,43 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
                 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)
@@ -160,11 +161,37 @@ cmmMiniInline blocks = map do_inline blocks
 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
   = 
@@ -176,6 +203,31 @@ cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg 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