-cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
-cmmAvailableReloads g = env
- where env = runDFA availRegsLattice $
- do run_f_anal transfer (fact_bot availRegsLattice) g
- allFacts
- transfer :: FAnalysis M Last AvailRegs
- transfer = FComp "available-reloads analysis" first middle last exit
- exit _ = LastOutFacts []
- 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
-
-middleAvail :: M -> AvailRegs -> AvailRegs
-middleAvail (Spill _) = id
-middleAvail (Reload regs) = agen regs
-middleAvail (NotSpillOrReload m) = middle m
- where 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 :: LGraph M Last -> DFTx (LGraph M Last)
-insertLateReloads g = mapM_blocks insertM g
- where env = cmmAvailableReloads g
- avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
- insertM b = functionalDFTx "late reloads" (insert b)
- 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 fuel == 0 || isEmptyUniqSet used then (h, fuel)
- else (ZHead h (Reload used), fuel-1)
-
-
-_lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
-_lateReloadsWithoutFuel g = map_blocks insert g
- where env = cmmAvailableReloads g
- avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
- insert (Block id tail) = propagate (ZFirst id) (avail id) tail
- propagate h avail (ZTail m t) =
- propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t
- propagate h avail (ZLast l) =
- zipht (maybe_add_reload h avail l) (ZLast l)
- maybe_add_reload h avail node =
- let used = filterRegsUsed (elemAvail avail) node
- in if isEmptyUniqSet used then h
- else ZHead h (Reload used)
-
-
-removeDeadAssignmentsAndReloads :: BPass M Last DualLive
-removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
- where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
- exit = Nothing
- last = \_ _ -> Nothing
- middle = middleRemoveDeads
- first _ _ = Nothing
-
-middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
-middleRemoveDeads _ (Spill _) = Nothing
-middleRemoveDeads live (Reload s) =
- if sizeUniqSet worth_reloading < sizeUniqSet s then
- Just $ if isEmptyUniqSet worth_reloading then emptyGraph
- else graphOfMiddles [Reload worth_reloading]
- else
- Nothing
- where worth_reloading = intersectUniqSets s (in_regs live)
-middleRemoveDeads live (NotSpillOrReload m) = middle m
- where middle (MidAssign (CmmLocal reg') _)
- | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
- middle _ = Nothing
+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