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 wherever needed
51 and will have to be sunk by a later forward transformation.
54 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
56 dualUnion :: DualLive -> DualLive -> DualLive
57 dualUnion (DualLive s r) (DualLive s' r') =
58 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
60 dualUnionList :: [DualLive] -> DualLive
61 dualUnionList ls = DualLive ss rs
62 where ss = unionManyUniqSets $ map on_stack ls
63 rs = unionManyUniqSets $ map in_regs ls
65 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
66 changeStack f live = live { on_stack = f (on_stack live) }
67 changeRegs f live = live { in_regs = f (in_regs live) }
70 dualLiveLattice :: DataflowLattice DualLive
71 dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
72 where empty = DualLive emptyRegSet emptyRegSet
73 add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
74 where (change1, stack) = add1 (on_stack old) (on_stack new)
75 (change2, regs) = add1 (in_regs old) (in_regs new)
76 add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
77 where join = unionUniqSets old new
79 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
80 dualLivenessWithInsertion procPoints g =
81 liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
82 (dualLiveTransfers (g_entry g) procPoints)
83 (insertSpillAndReloadRewrites g procPoints)
85 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
86 dualLiveness procPoints g =
87 liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
89 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
90 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
91 where first :: CmmNode C O -> DualLive -> DualLive
92 first (CmmEntry id) live = check live id $ -- live at procPoint => spill
93 if id /= entry && setMember id procPoints
94 then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
95 , in_regs = emptyRegSet }
97 where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
99 middle :: CmmNode O O -> DualLive -> DualLive
100 middle m = changeStack updSlots
102 where -- Reuse middle of liveness analysis from CmmLive
103 updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
105 updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
106 spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
108 reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
110 check (RegSlot (LocalReg _ ty), o, w) x
111 | o == w && w == widthInBytes (typeWidth ty) = x
112 check _ _ = panic "middleDualLiveness unsupported: slices"
113 last :: CmmNode O C -> FactBase DualLive -> DualLive
114 last l fb = case l of
115 CmmBranch id -> lkp id
116 l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
117 l@(CmmCall {cml_cont=Just k}) -> call l k
118 l@(CmmForeignCall {succ=k}) -> call l k
119 l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
120 l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
121 where empty = fact_bot dualLiveLattice
122 lkp id = empty `fromMaybe` lookupFact id fb
123 call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
125 gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
126 gen a live = foldRegsUsed extendRegSet live a
127 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
128 kill a live = foldRegsDefd deleteFromRegSet live a
130 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
131 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
132 -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
133 -- but GHC miscompiles it, see bug #4044.
134 where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
135 first e@(CmmEntry id) live = return $
136 if id /= (g_entry graph) && setMember id procPoints then
137 case map reload (uniqSetToList spill_regs) of
139 is -> Just $ mkFirst e <*> mkMiddles is
142 -- If we are splitting procedures, we need the LastForeignCall
143 -- to spill its results to the stack because they will only
144 -- be used by a separate procedure (so they can't stay in LocalRegs).
146 spill_regs = if splitting then in_regs live
147 else in_regs live `minusRegSet` defs
148 defs = case mapLookup id firstDefs of
150 Nothing -> emptyRegSet
151 -- A LastForeignCall may contain some definitions, which take place
152 -- on return from the function call. Therefore, we build a map (firstDefs)
153 -- from BlockId to the set of variables defined on return to the BlockId.
154 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
155 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
156 addLive b env = case lastNode b of
157 CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
159 add bid defs env = mapInsert bid defs'' env
160 where defs'' = case mapLookup bid env of
161 Just defs' -> timesRegSet defs defs'
164 middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
165 middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
166 middle m@(CmmAssign (CmmLocal reg) _) live = return $
167 if reg `elemRegSet` on_stack live then -- must spill
168 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
169 text "after"{-, ppr m-}]) $
170 Just $ mkMiddles $ [m, spill reg]
172 middle _ _ = return Nothing
174 nothing _ _ = return Nothing
176 regSlot :: LocalReg -> CmmExpr
177 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
179 spill, reload :: LocalReg -> CmmNode O O
180 spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
181 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
183 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
184 removeDeadAssignmentsAndReloads procPoints g =
185 liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
186 (dualLiveTransfers (g_entry g) procPoints)
188 where rewrites = deepBwdRw3 nothing middle nothing
189 -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
190 -- but GHC panics while compiling, see bug #4045.
191 middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
192 middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
193 -- XXX maybe this should be somewhere else...
194 middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph
195 middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
196 middle _ _ = return Nothing
198 nothing _ _ = return Nothing
200 ---------------------
203 ppr_regs :: String -> RegSet -> SDoc
204 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
205 where commafy xs = hsep $ punctuate comma xs
207 instance Outputable DualLive where
208 ppr (DualLive {in_regs = regs, on_stack = stack}) =
209 if isEmptyUniqSet regs && isEmptyUniqSet stack then
210 text "<nothing-live>"
212 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
213 else (ppr_regs "live in regs =" regs),
214 if isEmptyUniqSet stack then PP.empty
215 else (ppr_regs "live on stack =" stack)]
217 my_trace :: String -> SDoc -> a -> a
218 my_trace = if False then pprTrace else \_ _ a -> a
220 f4sep :: [SDoc] -> SDoc
222 f4sep (d:ds) = fsep (d : map (nest 4) ds)