- where reloads = in_regs live
-
-
-middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
-middleInsertSpillsAndReloads _ (Spill _) = Nothing
-middleInsertSpillsAndReloads _ (Reload _) = Nothing
-middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
- where middle (MidAssign (CmmLocal reg) _) =
- if reg `elemRegSet` on_stack live then -- must spill
- my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
- text "after", ppr m]) $
- Just $ graphOfMiddles [m, Spill $ mkRegSet [reg]]
- else
- Nothing
- middle (CopyIn _ formals _) =
- -- only 'formals' can be in regs at this point
- let regs' = kill formals (in_regs live) -- live in regs; must reload
- is_stack_var r = elemRegSet r (on_stack live)
- needs_spilling = filterRegsUsed is_stack_var formals
- -- a formal that is expected on the stack; must spill
- in if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
- Nothing
- else
- let code = if isEmptyUniqSet regs' then []
- else Reload regs' : []
- code' = if isEmptyUniqSet needs_spilling then code
- else Spill needs_spilling : code
- in
- my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
- ppr (Reload regs' :: M),
- ppr (Spill needs_spilling :: M),
- text "after", ppr m]) $
- Just $ graphOfMiddles (m : code')
- middle _ = Nothing
-
--- | For conversion back to vanilla C--
-
-elimSpillAndReload :: StackSlotMap -> LGraph M l -> FuelMonad (StackSlotMap, LGraph Middle l)
-elimSpillAndReload slots g = fold_blocks block (return (slots, [])) g >>= toGraph
- where toGraph (slots, l) = return (slots, of_block_list (lg_entry g) l)
- block (Block id t) z =
- do (slots, blocks) <- z
- (slots, t) <- tail t slots
- return (slots, Block id t : blocks)
- tail (ZLast l) slots = return (slots, ZLast l)
- tail (ZTail m t) slots =
- do (slots, t) <- tail t slots
- middle m t slots
- middle (Spill regs) t slots = foldUniqSet spill (return (slots, t)) regs
- middle (Reload regs) t slots = foldUniqSet reload (return (slots, t)) regs
- middle (NotSpillOrReload m) t slots = return (slots, ZTail m t)
- move f r z = do let reg = CmmLocal r
- (slots, t) <- z
- (slots, slot) <- getSlot slots reg
- return (slots, ZTail (f (CmmStack slot) reg) t)
- spill = move (\ slot reg -> MidAssign slot (CmmReg reg))
- reload = move (\ slot reg -> MidAssign reg (CmmReg slot))
-
-
-----------------------------------------------------------------
---- 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 False
- -- last True <==> debugging on
- where empty = UniverseMinus emptyRegSet
- -- | compute in the Tx monad to track whether anything has changed
- add new old =
- let join = interAvail new old in
- if join `smallerAvail` old then aTx join else noTx join
-
-
-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)
-
-deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-deleteFromAvail (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
-
-type CmmAvail = BlockEnv AvailRegs
-type AvailFix = FuelMonad (ForwardFixedPoint M Last AvailRegs ())
-
-cmmAvailableReloads :: Graph M Last -> FuelMonad CmmAvail
-cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
- where res = zdfSolveFrom emptyBlockEnv "available reloads" availRegsLattice
- avail_reloads_transfer empty g
- empty = (fact_bot availRegsLattice)
-
-avail_reloads_transfer :: ForwardTransfers M Last AvailRegs
-avail_reloads_transfer = ForwardTransfers first middle last id
- where first avail _ = avail
- middle = flip middleAvail
- last = lastAvail
-
--- | The transfer equations use the traditional 'gen' and 'kill'
--- notations, which should be familiar from the dragon book.
-agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
-agen a live = foldRegsUsed extendAvail live a
-akill a live = foldRegsUsed deleteFromAvail live a
-
--- Note: you can't sink the reload past a use.
-middleAvail :: M -> AvailRegs -> AvailRegs
-middleAvail (Spill _) = id
-middleAvail (Reload regs) = agen regs
-middleAvail (NotSpillOrReload m) = middle m
- where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
- middle' (MidComment {}) = id
- middle' (MidAssign lhs _expr) = akill lhs
- middle' (MidStore {}) = id
- middle' (MidUnsafeCall _tgt ress _args) = akill ress
- middle' (MidAddToContext {}) = id
- middle' (CopyIn _ formals _) = akill formals
- middle' (CopyOut {}) = id
-
-lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
-lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
-lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
-
-insertLateReloads :: Graph M Last -> FuelMonad (Graph M Last)
-insertLateReloads g =
- do env <- cmmAvailableReloads g
- g <- lGraphOfGraph g
- liftM graphOfLGraph $ mapM_blocks (insertM env) g
- where insertM env b = fuelConsumingPass "late reloads" (insert b)
- where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
- insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
- propagate h avail (ZTail m t) fuel =
- let (h', fuel') = maybe_add_reload h avail m fuel in
- propagate (ZHead h' m) (middleAvail m avail) t fuel'
- propagate h avail (ZLast l) fuel =
- let (h', fuel') = maybe_add_reload h avail l fuel in
- (zipht h' (ZLast l), fuel')
- maybe_add_reload h avail node fuel =
- let used = filterRegsUsed (elemAvail avail) node
- in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
- then (h,fuel)
- else (ZHead h (Reload used), oneLessFuel fuel)
-
-type LateReloadFix = FuelMonad (ForwardFixedPoint M Last AvailRegs (Graph M Last))
-
-insertLateReloads' :: (Graph M Last) -> FuelMonad (Graph M Last)
-insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
- where res = zdfRewriteFrom RewriteShallow emptyBlockEnv "insert late reloads"
- availRegsLattice avail_reloads_transfer rewrites bot g
- bot = fact_bot availRegsLattice
- rewrites = ForwardRewrites first middle last exit
- first _ _ = Nothing
- middle :: AvailRegs -> M -> Maybe (Graph M Last)
- last :: AvailRegs -> Last -> Maybe (Graph M Last)
- middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
- last avail l = maybe_reload_before avail l (ZLast (LastOther l))
- exit _ = Nothing
- maybe_reload_before avail node tail =
- let used = filterRegsUsed (elemAvail avail) node
- in if isEmptyUniqSet used then Nothing
- else Just $ graphOfZTail $ ZTail (Reload used) tail
-
-removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
+ where
+ -- If we are splitting procedures, we need the LastForeignCall
+ -- to spill its results to the stack because they will only
+ -- be used by a separate procedure (so they can't stay in LocalRegs).
+ splitting = True
+ spill_regs = if splitting then in_regs live
+ else in_regs live `minusRegSet` defs
+ defs = case mapLookup id firstDefs of
+ Just defs -> defs
+ Nothing -> emptyRegSet
+ -- A LastForeignCall may contain some definitions, which take place
+ -- on return from the function call. Therefore, we build a map (firstDefs)
+ -- from BlockId to the set of variables defined on return to the BlockId.
+ firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
+ addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
+ addLive b env = case lastNode b of
+ CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
+ _ -> env
+ add bid defs env = mapInsert bid defs'' env
+ where defs'' = case mapLookup bid env of
+ Just defs' -> timesRegSet defs defs'
+ Nothing -> defs
+
+ middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
+ middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
+ middle m@(CmmAssign (CmmLocal reg) _) live = return $
+ if reg `elemRegSet` on_stack live then -- must spill
+ my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
+ text "after"{-, ppr m-}]) $
+ Just $ mkMiddles $ [m, spill reg]
+ else Nothing
+ middle _ _ = return Nothing
+
+ nothing _ _ = return Nothing
+
+spill, reload :: LocalReg -> CmmNode O O
+spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
+reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
+
+removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph