X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmSpillReload.hs;h=2dcfb027a39861679b9e5594872bf061bf29ac86;hp=4679ecf356edf09dec832c599a1626915dc494fd;hb=f537dd87c4a07526e2b1fc1bd1c125d652833641;hpb=080dabd4d6a18926d9c040ae4712b1891a4bbf2d

diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index 4679ecf..2dcfb02 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -25,6 +25,7 @@ import Cmm
 import CmmExpr
 import CmmLive
 import OptimizationFuel
+import StgCmmUtils
 
 import Control.Monad
 import Outputable hiding (empty)
@@ -495,20 +496,44 @@ middleAssignment (Plain n@(CmmStore lhs rhs)) assign
 -}
 
 -- Assumption: Unsafe foreign calls don't clobber memory
+-- Since foreign calls clobber caller saved registers, we need
+-- invalidate any assignments that reference those global registers.
+-- This is kind of expensive. (One way to optimize this might be to
+-- store extra information about expressions that allow this and other
+-- checks to be done cheaply.)
 middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign
-    = foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n
+    = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
+    where deleteCallerSaves m = foldUFM_Directly f m m
+          f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
+          f _ _ m = m
+          g (CmmReg (CmmGlobal r)) _      | callerSaves r = True
+          g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True
+          g _ b = b
 
 middleAssignment (Plain (CmmComment {})) assign
     = assign
 
 -- Assumptions:
+--  * Writes using Hp do not overlap with any other memory locations
+--    (An important invariant being relied on here is that we only ever
+--    use Hp to allocate values on the heap, which appears to be the
+--    case given hpReg usage, and that our heap writing code doesn't
+--    do anything stupid like overlapping writes.)
 --  * Stack slots do not overlap with any other memory locations
---  * Non stack-slot stores always conflict with each other.  (This is
---    not always the case; we could probably do something special for Hp)
 --  * Stack slots for different areas do not overlap
 --  * Stack slots within the same area and different offsets may
 --    overlap; we need to do a size check (see 'overlaps').
-clobbers :: (CmmExpr, CmmExpr) -> (Unique, CmmExpr) -> Bool
+--  * Register slots only overlap with themselves.  (But this shouldn't
+--    happen in practice, because we'll fail to inline a reload across
+--    the next spill.)
+--  * Non stack-slot stores always conflict with each other.  (This is
+--    not always the case; we could probably do something special for Hp)
+clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
+         -> (Unique,  CmmExpr) -- (register, expression) that may be clobbered
+         -> Bool
+clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
+clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
+-- ToDo: Also catch MachOp case
 clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
     | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
 clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
@@ -523,6 +548,9 @@ clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
           containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
           containsStackSlot (CmmStackSlot{}) = True
           containsStackSlot _ = False
+clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
+    where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
+          f _ = False
 clobbers _ (_, e) = f e
     where f (CmmLoad (CmmStackSlot _ _) _) = False
           f (CmmLoad{}) = True -- conservative
@@ -572,16 +600,18 @@ assignmentRewrite = mkFRewrite3 first middle last
                                 Nothing -> (i, l)
         rewrite _ (False, []) _ _ = Nothing
         -- Note [CmmCall Inline Hack]
-        -- ToDo: Conservative hack: don't do any inlining on CmmCalls, since
-        -- the code produced here tends to be unproblematic and I need
-        -- to write lint passes to ensure that we don't put anything in
-        -- the arguments that could be construed as a global register by
+        -- Conservative hack: don't do any inlining on what will
+        -- be translated into an OldCmm CmmCalls, since the code
+        -- produced here tends to be unproblematic and I need to write
+        -- lint passes to ensure that we don't put anything in the
+        -- arguments that could be construed as a global register by
         -- some later translation pass.  (For example, slots will turn
-        -- into dereferences of Sp).  This is the same hack in spirit as
-        -- was in cmm/CmmOpt.hs.  Fix this up to only bug out if certain
-        -- CmmExprs are involved.
-        -- ToDo: We miss an opportunity here, where all possible
-        -- inlinings should instead be sunk.
+        -- into dereferences of Sp).  See [Register parameter passing].
+        -- ToDo: Fix this up to only bug out if all inlines were for
+        -- CmmExprs with global registers (we can't use the
+        -- straightforward mapExpDeep call, in this case.) ToDo: We miss
+        -- an opportunity here, where all possible inlinings should
+        -- instead be sunk.
         rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack]
         rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n))
 
@@ -614,6 +644,7 @@ assignmentRewrite = mkFRewrite3 first middle last
         inlinable :: CmmNode e x -> Bool
         inlinable (CmmCall{}) = False
         inlinable (CmmForeignCall{}) = False
+        inlinable (CmmUnsafeForeignCall{}) = False
         inlinable _ = True
 
 rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph