- middle (MidForeignCall _ _ fs _) =
- 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 _ = Nothing
-
--- Generating spill and reload code
-regSlot :: LocalReg -> CmmExpr
-regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
-
-spill, reload :: LocalReg -> Middle
-spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r)
-reload r = MidAssign (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 False
- 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)
-
-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
-
-type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
-
-cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs)
-cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
- where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
- avail_reloads_transfer empty g
- empty = fact_bot availRegsLattice
-
-avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
-avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id
-
-middleAvail :: Middle -> AvailRegs -> AvailRegs
-middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail
- | l `isStackSlotOf` r = extendAvail avail r
-middleAvail (MidAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
-middleAvail (MidStore l (CmmReg (CmmLocal r))) avail
- | l `isStackSlotOf` r = avail
-middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
-middleAvail (MidStore {}) avail = avail
-middleAvail (MidForeignCall {}) _ = AvailRegs emptyRegSet
-middleAvail (MidComment {}) avail = avail
-
-lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs
-lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)]
-lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l
-
-type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
-
-availRewrites :: ForwardRewrites Middle Last AvailRegs
-availRewrites = ForwardRewrites first middle last exit
- where first _ _ = Nothing
- middle m avail = maybe_reload_before avail m (mkMiddle m)
- last l avail = maybe_reload_before avail l (mkLast l)
- exit _ = Nothing
- 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
-
-
-insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
- where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
- availRegsLattice avail_reloads_transfer availRewrites bot g
- bot = fact_bot availRegsLattice
-
-removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) =
- liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
- where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
- dualLiveLattice (dualLiveTransfers entry procPoints)
- rewrites (fact_bot dualLiveLattice) g
- rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing
- nothing _ _ = Nothing
-
-middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
-middleRemoveDeads (MidAssign (CmmLocal reg') _) live
- | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
-middleRemoveDeads _ _ = Nothing
-
-
+ 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
+removeDeadAssignmentsAndReloads procPoints g =
+ liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
+ (dualLiveTransfers (g_entry g) procPoints)
+ rewrites
+ where rewrites = deepBwdRw3 nothing middle nothing
+ -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
+ -- 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
projects / ghc-hetmet.git / blobdiff