1 {-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts #-}
2 -- Norman likes local bindings
3 -- If this module lives on I'd like to get rid of this flag in due course
5 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
6 #if __GLASGOW_HASKELL__ >= 701
7 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
8 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
13 , dualLiveLattice, dualLiveTransfers, dualLiveness
14 --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
15 , dualLivenessWithInsertion
17 , removeDeadAssignmentsAndReloads
25 import OptimizationFuel
28 import Outputable hiding (empty)
29 import qualified Outputable as PP
32 import Compiler.Hoopl hiding (Unique)
34 import Prelude hiding (succ, zip)
36 {- Note [Overview of spill/reload]
37 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
38 The point of this module is to insert spills and reloads to
39 establish the invariant that at a call (or at any proc point with
40 an established protocol) all live variables not expected in
41 registers are sitting on the stack. We use a backward analysis to
42 insert spills and reloads. It should be followed by a
43 forward transformation to sink reloads as deeply as possible, so as
44 to reduce register pressure.
46 A variable can be expected to be live in a register, live on the
47 stack, or both. This analysis ensures that spills and reloads are
48 inserted as needed to make sure that every live variable needed
49 after a call is available on the stack. Spills are pushed back to
50 their reaching definitions, but reloads are dropped immediately after
51 we return from a call and will have to be sunk by a later forward
54 Note that we offer no guarantees about the consistency of the value
55 in memory and the value in the register, except that they are
56 equal across calls/procpoints. If the variable is changed, this
57 mapping breaks: but as the original value of the register may still
58 be useful in a different context, the memory location is not updated.
61 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
63 dualUnion :: DualLive -> DualLive -> DualLive
64 dualUnion (DualLive s r) (DualLive s' r') =
65 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
67 dualUnionList :: [DualLive] -> DualLive
68 dualUnionList ls = DualLive ss rs
69 where ss = unionManyUniqSets $ map on_stack ls
70 rs = unionManyUniqSets $ map in_regs ls
72 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
73 changeStack f live = live { on_stack = f (on_stack live) }
74 changeRegs f live = live { in_regs = f (in_regs live) }
77 dualLiveLattice :: DataflowLattice DualLive
78 dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
79 where empty = DualLive emptyRegSet emptyRegSet
80 add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
81 where (change1, stack) = add1 (on_stack old) (on_stack new)
82 (change2, regs) = add1 (in_regs old) (in_regs new)
83 add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
84 where join = unionUniqSets old new
86 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
87 dualLivenessWithInsertion procPoints g =
88 liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
89 (dualLiveTransfers (g_entry g) procPoints)
90 (insertSpillAndReloadRewrites g procPoints)
92 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
93 dualLiveness procPoints g =
94 liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
96 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
97 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
98 where first :: CmmNode C O -> DualLive -> DualLive
99 first (CmmEntry id) live = check live id $ -- live at procPoint => spill
100 if id /= entry && setMember id procPoints
101 then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
102 , in_regs = emptyRegSet }
104 where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
106 middle :: CmmNode O O -> DualLive -> DualLive
107 middle m = changeStack updSlots
109 where -- Reuse middle of liveness analysis from CmmLive
110 updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
112 updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
113 spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
115 reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
117 check (RegSlot (LocalReg _ ty), o, w) x
118 | o == w && w == widthInBytes (typeWidth ty) = x
119 check _ _ = panic "middleDualLiveness unsupported: slices"
120 last :: CmmNode O C -> FactBase DualLive -> DualLive
121 last l fb = case l of
122 CmmBranch id -> lkp id
123 l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
124 l@(CmmCall {cml_cont=Just k}) -> call l k
125 l@(CmmForeignCall {succ=k}) -> call l k
126 l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
127 l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
128 where empty = fact_bot dualLiveLattice
129 lkp id = empty `fromMaybe` lookupFact id fb
130 call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
132 gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
133 gen a live = foldRegsUsed extendRegSet live a
134 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
135 kill a live = foldRegsDefd deleteFromRegSet live a
137 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
138 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
139 -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
140 -- but GHC miscompiles it, see bug #4044.
141 where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
142 first e@(CmmEntry id) live = return $
143 if id /= (g_entry graph) && setMember id procPoints then
144 case map reload (uniqSetToList spill_regs) of
146 is -> Just $ mkFirst e <*> mkMiddles is
149 -- If we are splitting procedures, we need the LastForeignCall
150 -- to spill its results to the stack because they will only
151 -- be used by a separate procedure (so they can't stay in LocalRegs).
153 spill_regs = if splitting then in_regs live
154 else in_regs live `minusRegSet` defs
155 defs = case mapLookup id firstDefs of
157 Nothing -> emptyRegSet
158 -- A LastForeignCall may contain some definitions, which take place
159 -- on return from the function call. Therefore, we build a map (firstDefs)
160 -- from BlockId to the set of variables defined on return to the BlockId.
161 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
162 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
163 addLive b env = case lastNode b of
164 CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
166 add bid defs env = mapInsert bid defs'' env
167 where defs'' = case mapLookup bid env of
168 Just defs' -> timesRegSet defs defs'
171 middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
172 middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
173 middle m@(CmmAssign (CmmLocal reg) _) live = return $
174 if reg `elemRegSet` on_stack live then -- must spill
175 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
176 text "after"{-, ppr m-}]) $
177 Just $ mkMiddles $ [m, spill reg]
179 middle _ _ = return Nothing
181 nothing _ _ = return Nothing
183 spill, reload :: LocalReg -> CmmNode O O
184 spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
185 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
187 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
188 removeDeadAssignmentsAndReloads procPoints g =
189 liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
190 (dualLiveTransfers (g_entry g) procPoints)
192 where rewrites = deepBwdRw3 nothing middle nothing
193 -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
194 -- but GHC panics while compiling, see bug #4045.
195 middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
196 middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
197 -- XXX maybe this should be somewhere else...
198 middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph
199 middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
200 middle _ _ = return Nothing
202 nothing _ _ = return Nothing
204 ---------------------
207 ppr_regs :: String -> RegSet -> SDoc
208 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
209 where commafy xs = hsep $ punctuate comma xs
211 instance Outputable DualLive where
212 ppr (DualLive {in_regs = regs, on_stack = stack}) =
213 if isEmptyUniqSet regs && isEmptyUniqSet stack then
214 text "<nothing-live>"
216 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
217 else (ppr_regs "live in regs =" regs),
218 if isEmptyUniqSet stack then PP.empty
219 else (ppr_regs "live on stack =" stack)]
221 my_trace :: String -> SDoc -> a -> a
222 my_trace = if False then pprTrace else \_ _ a -> a
224 f4sep :: [SDoc] -> SDoc
226 f4sep (d:ds) = fsep (d : map (nest 4) ds)