projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Implement regslot inlining, document soundness concerns.
[ghc-hetmet.git] / compiler / cmm / CmmSpillReload.hs
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index 4e2dd38..a4bedb0 100644 (file)
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE GADTs,NoMonoLocalBinds #-}
+{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts #-}
 -- Norman likes local bindings
 -- If this module lives on I'd like to get rid of this flag in due course
 
 -- Norman likes local bindings
 -- If this module lives on I'd like to get rid of this flag in due course
 
-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 #if __GLASGOW_HASKELL__ >= 701
 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
 #if __GLASGOW_HASKELL__ >= 701
 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
@@ -14,9 +14,6 @@ module CmmSpillReload
   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   , dualLivenessWithInsertion
 
   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   , dualLivenessWithInsertion
 
-  , availRegsLattice
-  , cmmAvailableReloads
-  , insertLateReloads
   , removeDeadAssignmentsAndReloads
   )
 where
   , removeDeadAssignmentsAndReloads
   )
 where
@@ -32,7 +29,7 @@ import Outputable hiding (empty)
 import qualified Outputable as PP
 import UniqSet
 
 import qualified Outputable as PP
 import UniqSet
 
-import Compiler.Hoopl
+import Compiler.Hoopl hiding (Unique)
 import Data.Maybe
 import Prelude hiding (succ, zip)
 
 import Data.Maybe
 import Prelude hiding (succ, zip)
 
@@ -50,8 +47,15 @@ A variable can be expected to be live in a register, live on the
 stack, or both.  This analysis ensures that spills and reloads are
 inserted as needed to make sure that every live variable needed
 after a call is available on the stack.  Spills are pushed back to
 stack, or both.  This analysis ensures that spills and reloads are
 inserted as needed to make sure that every live variable needed
 after a call is available on the stack.  Spills are pushed back to
-their reaching definitions, but reloads are dropped wherever needed
-and will have to be sunk by a later forward transformation.
+their reaching definitions, but reloads are dropped immediately after
+we return from a call and will have to be sunk by a later forward
+transformation.
+
+Note that we offer no guarantees about the consistency of the value
+in memory and the value in the register, except that they are
+equal across calls/procpoints.  If the variable is changed, this
+mapping breaks: but as the original value of the register may still
+be useful in a different context, the memory location is not updated.
 -}
 
 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
 -}
 
 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
@@ -100,11 +104,11 @@ dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
             where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
 
           middle :: CmmNode O O -> DualLive -> DualLive
             where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
 
           middle :: CmmNode O O -> DualLive -> DualLive
-          middle m live = changeStack updSlots $ changeRegs (xferLiveMiddle m) (changeRegs regs_in live)
-            where xferLiveMiddle = case getBTransfer3 xferLive of (_, middle, _) -> middle
-                 regs_in :: RegSet -> RegSet
-                  regs_in live = case m of CmmUnsafeForeignCall {} -> emptyRegSet
-                                           _ -> live
+          middle m = changeStack updSlots
+                   . changeRegs  updRegs
+            where -- Reuse middle of liveness analysis from CmmLive
+                  updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
+
                   updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
                   spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
                   spill  live _ = live
                   updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
                   spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
                   spill  live _ = live
@@ -172,107 +176,14 @@ insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
                                                text "after"{-, ppr m-}]) $
                    Just $ mkMiddles $ [m, spill reg]
               else Nothing
                                                text "after"{-, ppr m-}]) $
                    Just $ mkMiddles $ [m, spill reg]
               else Nothing
-          middle m@(CmmUnsafeForeignCall _ fs _) live = return $
-            case map spill  (filter (flip elemRegSet (on_stack live)) fs) ++
-                 map reload (uniqSetToList (kill fs (in_regs live))) of
-              []      -> Nothing
-              reloads -> Just $ mkMiddles (m : reloads)
           middle _ _ = return Nothing
 
           nothing _ _ = return Nothing
 
           middle _ _ = return Nothing
 
           nothing _ _ = return Nothing
 
-regSlot :: LocalReg -> CmmExpr
-regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
-
 spill, reload :: LocalReg -> CmmNode O O
 spill  r = CmmStore  (regSlot r) (CmmReg $ CmmLocal r)
 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 
 spill, reload :: LocalReg -> CmmNode O O
 spill  r = CmmStore  (regSlot r) (CmmReg $ CmmLocal r)
 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 
-----------------------------------------------------------------
---- sinking reloads
-
--- The idea is to compute at each point the set of registers such that
--- on every path to the point, the register is defined by a Reload
--- instruction.  Then, if a use appears at such a point, we can safely
--- insert a Reload right before the use.  Finally, we can eliminate
--- the early reloads along with other dead assignments.
-
-data AvailRegs = UniverseMinus RegSet
-               | AvailRegs     RegSet
-
-
-availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add
-    where empty = UniverseMinus emptyRegSet
-          -- | compute in the Tx monad to track whether anything has changed
-          add _ (OldFact old) (NewFact new) =
-            if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
-            where join = interAvail new old
-
-
-interAvail :: AvailRegs -> AvailRegs -> AvailRegs
-interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
-interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
-interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
-interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
-
-smallerAvail :: AvailRegs -> AvailRegs -> Bool
-smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
-smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
-smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
-smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
-
-extendAvail :: AvailRegs -> LocalReg -> AvailRegs
-extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
-extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
-
-delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-delFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
-
-elemAvail :: AvailRegs -> LocalReg -> Bool
-elemAvail (UniverseMinus s) r = not $ elemRegSet r s
-elemAvail (AvailRegs     s) r = elemRegSet r s
-
-cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
-cmmAvailableReloads g =
-  liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
-                              analFwd availRegsLattice availReloadsTransfer
-
-availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
-availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
-
-middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
-middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
-               | l `isStackSlotOf` r = extendAvail avail r
-middleAvail (CmmAssign lhs _)        avail = foldRegsDefd delFromAvail avail lhs
-middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
-               | l `isStackSlotOf` r = avail
-middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
-middleAvail (CmmStore {})            avail = avail
-middleAvail (CmmUnsafeForeignCall {}) _    = AvailRegs emptyRegSet
-middleAvail (CmmComment {})          avail = avail
-
-lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
-lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
-lastAvail (CmmForeignCall {succ=k})  _ = [(k, AvailRegs emptyRegSet)]
-lastAvail l avail = map (\id -> (id, avail)) $ successors l
-
-insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
-insertLateReloads g =
-  liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
-                              analRewFwd availRegsLattice availReloadsTransfer rewrites
-  where rewrites = mkFRewrite3 first middle last
-        first _ _ = return Nothing
-        middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
-        last   l avail = return $ maybe_reload_before avail l (mkLast l)
-        maybe_reload_before avail node tail =
-            let used = filterRegsUsed (elemAvail avail) node
-            in  if isEmptyUniqSet used then Nothing
-                                       else Just $ reloadTail used tail
-        reloadTail regset t = foldl rel t $ uniqSetToList regset
-          where rel t r = mkMiddle (reload r) <*> t
-
 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
 removeDeadAssignmentsAndReloads procPoints g =
    liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
 removeDeadAssignmentsAndReloads procPoints g =
    liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
@@ -283,11 +194,13 @@ removeDeadAssignmentsAndReloads procPoints g =
          -- but GHC panics while compiling, see bug #4045.
          middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
          middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
          -- but GHC panics while compiling, see bug #4045.
          middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
          middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
+         -- XXX maybe this should be somewhere else...
+         middle (CmmAssign lhs (CmmReg rhs))   _ | lhs == rhs = return $ Just emptyGraph
+         middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
          middle _ _ = return Nothing
 
          nothing _ _ = return Nothing
 
          middle _ _ = return Nothing
 
          nothing _ _ = return Nothing
 
-
 ---------------------
 -- prettyprinting
 
 ---------------------
 -- prettyprinting
 
@@ -305,12 +218,6 @@ instance Outputable DualLive where
                          if isEmptyUniqSet stack then PP.empty
                          else (ppr_regs "live on stack =" stack)]
 
                          if isEmptyUniqSet stack then PP.empty
                          else (ppr_regs "live on stack =" stack)]
 
-instance Outputable AvailRegs where
-  ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
-                          else ppr_regs "available = all but" s
-  ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
-                          else ppr_regs "available = " s
-
 my_trace :: String -> SDoc -> a -> a
 my_trace = if False then pprTrace else \_ _ a -> a
 
 my_trace :: String -> SDoc -> a -> a
 my_trace = if False then pprTrace else \_ _ a -> a
 
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)