+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)
+removeDeadAssignmentsAndReloads procPoints g =
+ liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
+ where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
+ dualLiveLattice (dualLiveTransfers procPoints)
+ rewrites (fact_bot dualLiveLattice) g
+ rewrites = BackwardRewrites first middle last exit
+ 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
+
+
+
+---------------------
+-- register usage
+
+instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
+ foldRegsUsed f z (Spill regs) = foldRegsUsed f z regs
+ foldRegsUsed _f z (Reload _) = z
+ foldRegsUsed f z (NotSpillOrReload m) = foldRegsUsed f z m
+