module LinearScan.Assign where
import Debug.Trace (trace, traceShow)
import qualified Prelude
import qualified Data.IntMap
import qualified Data.IntSet
import qualified Data.List
import qualified Data.Ord
import qualified Data.Functor.Identity
import qualified LinearScan.Utils
import qualified LinearScan.Blocks as Blocks
import qualified LinearScan.Graph as Graph
import qualified LinearScan.IntMap as IntMap
import qualified LinearScan.Interval as Interval
import qualified LinearScan.LiveSets as LiveSets
import qualified LinearScan.Resolve as Resolve
import qualified LinearScan.ScanState as ScanState
import qualified LinearScan.State as State
import qualified LinearScan.Eqtype as Eqtype
import qualified LinearScan.Fintype as Fintype
import qualified LinearScan.Ssrnat as Ssrnat
#ifdef __GLASGOW_HASKELL__
import qualified GHC.Base as GHC.Base
unsafeCoerce = GHC.Base.unsafeCoerce#
#else
import qualified LinearScan.IOExts as IOExts
unsafeCoerce = IOExts.unsafeCoerce
#endif
type PhysReg = Prelude.Int
data AssnStateInfo accType =
Build_AssnStateInfo Blocks.OpId Blocks.OpId Blocks.OpId accType
assnOpId :: (AssnStateInfo a1) -> Blocks.OpId
assnOpId a =
case a of {
Build_AssnStateInfo assnOpId0 assnBlockBeg0 assnBlockEnd0 assnAcc0 ->
assnOpId0}
assnBlockBeg :: (AssnStateInfo a1) -> Blocks.OpId
assnBlockBeg a =
case a of {
Build_AssnStateInfo assnOpId0 assnBlockBeg0 assnBlockEnd0 assnAcc0 ->
assnBlockBeg0}
assnBlockEnd :: (AssnStateInfo a1) -> Blocks.OpId
assnBlockEnd a =
case a of {
Build_AssnStateInfo assnOpId0 assnBlockBeg0 assnBlockEnd0 assnAcc0 ->
assnBlockEnd0}
assnAcc :: (AssnStateInfo a1) -> a1
assnAcc a =
case a of {
Build_AssnStateInfo assnOpId0 assnBlockBeg0 assnBlockEnd0 assnAcc0 ->
assnAcc0}
type AssnState accType a = State.State (AssnStateInfo accType) a
moveOpM :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> Blocks.PhysReg ->
Blocks.PhysReg -> AssnState a3 ([] a2)
moveOpM maxReg oinfo sreg dreg =
State.bind (\assn ->
case Blocks.moveOp maxReg oinfo sreg dreg (assnAcc assn) of {
(,) mop acc' ->
State.bind (\x -> State.pure mop)
(State.put (Build_AssnStateInfo (assnOpId assn) (assnBlockBeg assn)
(assnBlockEnd assn) acc'))}) State.get
saveOpM :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> Blocks.PhysReg ->
(Prelude.Maybe Blocks.VarId) -> AssnState a3 ([] a2)
saveOpM maxReg oinfo vid reg =
State.bind (\assn ->
case Blocks.saveOp maxReg oinfo vid reg (assnAcc assn) of {
(,) sop acc' ->
State.bind (\x -> State.pure sop)
(State.put (Build_AssnStateInfo (assnOpId assn) (assnBlockBeg assn)
(assnBlockEnd assn) acc'))}) State.get
restoreOpM :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> (Prelude.Maybe
Blocks.VarId) -> Blocks.PhysReg -> AssnState a3 ([] a2)
restoreOpM maxReg oinfo vid reg =
State.bind (\assn ->
case Blocks.restoreOp maxReg oinfo vid reg (assnAcc assn) of {
(,) rop acc' ->
State.bind (\x -> State.pure rop)
(State.put (Build_AssnStateInfo (assnOpId assn) (assnBlockBeg assn)
(assnBlockEnd assn) acc'))}) State.get
pairM :: (AssnState a1 a2) -> (AssnState a1 a3) -> AssnState a1 ((,) a2 a3)
pairM x y =
State.bind (\x' -> State.bind (\y' -> State.pure ((,) x' y')) y) x
savesAndRestores :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> Blocks.OpId ->
Blocks.VarInfo -> Blocks.PhysReg -> Interval.IntervalDesc
-> IntMap.IntSet -> AssnState a3 ((,) ([] a2) ([] a2))
savesAndRestores maxReg oinfo opid v reg int outs =
case Blocks.varId maxReg v of {
Prelude.Left p -> State.pure ((,) [] []);
Prelude.Right vid ->
State.bind (\assn ->
let {knd = Blocks.varKind maxReg v} in
let {
atBoundary = (Prelude.||)
((Prelude.&&)
(Eqtype.eq_op Blocks.coq_VarKind_eqType
(unsafeCoerce knd) (unsafeCoerce Blocks.Input))
(Eqtype.eq_op Ssrnat.nat_eqType
(unsafeCoerce (assnBlockBeg assn))
(unsafeCoerce opid)))
((Prelude.&&)
(Eqtype.eq_op Blocks.coq_VarKind_eqType
(unsafeCoerce knd) (unsafeCoerce Blocks.Output))
(Eqtype.eq_op Ssrnat.nat_eqType
(unsafeCoerce ((Prelude.succ) ((Prelude.succ)
opid))) (unsafeCoerce (assnBlockEnd assn))))}
in
let {
isFirst = Eqtype.eq_op (Eqtype.option_eqType Ssrnat.nat_eqType)
(unsafeCoerce (Interval.firstUsePos int))
(unsafeCoerce (Prelude.Just opid))}
in
let {
isLast = Eqtype.eq_op
(Eqtype.option_eqType
(Eqtype.sig_eqType Ssrnat.nat_eqType
(unsafeCoerce Ssrnat.odd)))
(unsafeCoerce (Interval.nextUseAfter int opid))
(unsafeCoerce Prelude.Nothing)}
in
let {save = saveOpM maxReg oinfo reg (Prelude.Just vid)} in
let {
msave = case atBoundary of {
Prelude.True -> State.pure [];
Prelude.False -> save}}
in
let {restore = restoreOpM maxReg oinfo (Prelude.Just vid) reg} in
let {
mrestore = case atBoundary of {
Prelude.True -> State.pure [];
Prelude.False -> restore}}
in
case knd of {
Blocks.Input ->
case Interval.iknd int of {
Interval.Whole -> State.pure ((,) [] []);
Interval.LeftMost ->
case isLast of {
Prelude.True -> pairM (State.pure []) save;
Prelude.False -> State.pure ((,) [] [])};
Interval.Middle ->
case isFirst of {
Prelude.True ->
case isLast of {
Prelude.True -> pairM mrestore save;
Prelude.False -> pairM mrestore (State.pure [])};
Prelude.False ->
case isLast of {
Prelude.True -> pairM (State.pure []) save;
Prelude.False -> State.pure ((,) [] [])}};
Interval.RightMost ->
case isFirst of {
Prelude.True -> pairM mrestore (State.pure []);
Prelude.False -> State.pure ((,) [] [])}};
Blocks.Temp -> State.pure ((,) [] []);
Blocks.Output ->
case Interval.iknd int of {
Interval.LeftMost ->
case isLast of {
Prelude.True -> pairM (State.pure []) msave;
Prelude.False -> State.pure ((,) [] [])};
Interval.Middle ->
case isLast of {
Prelude.True -> pairM (State.pure []) msave;
Prelude.False -> State.pure ((,) [] [])};
_ -> State.pure ((,) [] [])}}) State.get}
collectAllocs :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> Prelude.Int ->
IntMap.IntSet -> ([] ((,) Interval.IntervalDesc PhysReg)) ->
((,) ((,) ([] ((,) Blocks.VarId PhysReg)) ([] a2)) ([] a2))
-> Blocks.VarInfo -> State.State (AssnStateInfo a3)
((,) ((,) ([] ((,) Blocks.VarId PhysReg)) ([] a2)) ([] a2))
collectAllocs maxReg oinfo opid outs ints acc v =
case Blocks.varId maxReg v of {
Prelude.Left p -> State.pure acc;
Prelude.Right vid ->
let {
v_ints = Prelude.filter (\x ->
ScanState.isWithin (Prelude.fst x) vid opid) ints}
in
State.forFoldM acc v_ints (\acc' x ->
case x of {
(,) int reg ->
case acc' of {
(,) p saves' ->
case p of {
(,) allocs' restores' ->
State.bind (\res ->
case res of {
(,) rs ss ->
State.pure ((,) ((,) ((:) ((,) vid reg) allocs')
((Prelude.++) rs restores')) ((Prelude.++) ss saves'))})
(savesAndRestores maxReg oinfo opid v reg int outs)}}})}
doAllocations :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> ([]
((,) Interval.IntervalDesc PhysReg)) -> IntMap.IntSet -> a1
-> AssnState a3 ([] a2)
doAllocations maxReg oinfo ints outs op =
State.bind (\assn ->
let {opid = assnOpId assn} in
let {vars = Blocks.opRefs maxReg oinfo op} in
State.bind (\res ->
case res of {
(,) y saves ->
case y of {
(,) allocs restores ->
let {op' = Blocks.applyAllocs maxReg oinfo op allocs} in
State.bind (\x ->
State.pure ((Prelude.++) restores ((Prelude.++) op' saves)))
(State.modify (\assn' -> Build_AssnStateInfo ((Prelude.succ)
((Prelude.succ) opid)) (assnBlockBeg assn')
(assnBlockEnd assn') (assnAcc assn')))}})
(State.forFoldM ((,) ((,) [] []) []) vars
(collectAllocs maxReg oinfo opid outs ints))) State.get
generateMoves :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> ([]
((,) (Prelude.Maybe (Prelude.Either PhysReg Prelude.Int))
(Prelude.Maybe (Prelude.Either PhysReg Prelude.Int)))) ->
AssnState a3 ([] a2)
generateMoves maxReg oinfo moves =
State.forFoldM [] moves (\acc mv ->
State.bind (\mops ->
State.pure
(case mops of {
Prelude.Just ops -> (Prelude.++) ops acc;
Prelude.Nothing -> acc}))
(case mv of {
(,) o o0 ->
case o of {
Prelude.Just s ->
case s of {
Prelude.Left sreg ->
case o0 of {
Prelude.Just s0 ->
case s0 of {
Prelude.Left dreg ->
State.fmap (\x -> Prelude.Just x)
(moveOpM maxReg oinfo sreg dreg);
Prelude.Right vid ->
State.fmap (\x -> Prelude.Just x)
(saveOpM maxReg oinfo sreg (Prelude.Just vid))};
Prelude.Nothing ->
State.fmap (\x -> Prelude.Just x)
(saveOpM maxReg oinfo sreg Prelude.Nothing)};
Prelude.Right vid ->
case o0 of {
Prelude.Just s0 ->
case s0 of {
Prelude.Left dreg ->
State.fmap (\x -> Prelude.Just x)
(restoreOpM maxReg oinfo (Prelude.Just vid) dreg);
Prelude.Right n -> State.pure Prelude.Nothing};
Prelude.Nothing -> State.pure Prelude.Nothing}};
Prelude.Nothing ->
case o0 of {
Prelude.Just s ->
case s of {
Prelude.Left dreg ->
State.fmap (\x -> Prelude.Just x)
(restoreOpM maxReg oinfo Prelude.Nothing dreg);
Prelude.Right n -> State.pure Prelude.Nothing};
Prelude.Nothing -> State.pure Prelude.Nothing}}}))
resolveMappings :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> Prelude.Int ->
([] a2) -> (IntMap.IntMap ((,) Graph.Graph Graph.Graph))
-> AssnState a3 ([] a2)
resolveMappings maxReg oinfo bid opsm mappings =
case IntMap.coq_IntMap_lookup bid mappings of {
Prelude.Just graphs ->
case graphs of {
(,) gbeg gend ->
State.bind (\bmoves ->
let {opsm' = (Prelude.++) bmoves opsm} in
State.bind (\emoves ->
let {opsm'' = (Prelude.++) opsm' emoves} in State.pure opsm'')
(generateMoves maxReg oinfo
(unsafeCoerce
(Graph.topsort
(Eqtype.sum_eqType (Fintype.ordinal_eqType maxReg)
Ssrnat.nat_eqType) gend))))
(generateMoves maxReg oinfo
(unsafeCoerce
(Graph.topsort
(Eqtype.sum_eqType (Fintype.ordinal_eqType maxReg)
Ssrnat.nat_eqType) gbeg)))};
Prelude.Nothing -> State.pure opsm}
considerOps :: Prelude.Int -> (Blocks.BlockInfo a1 a2 a3 a4) ->
(Blocks.OpInfo a5 a3 a4) -> (IntMap.IntSet -> a3 -> AssnState
a5 ([] a4)) -> (IntMap.IntMap LiveSets.BlockLiveSets) ->
(IntMap.IntMap ((,) Graph.Graph Graph.Graph)) -> ([] a1) ->
State.State (AssnStateInfo a5) ([] a2)
considerOps maxReg binfo oinfo f liveSets mappings =
State.mapM (\blk ->
let {ops = Blocks.blockOps binfo blk} in
let {bid = Blocks.blockId binfo blk} in
let {
outs = case IntMap.coq_IntMap_lookup bid liveSets of {
Prelude.Just ls -> LiveSets.blockLiveOut ls;
Prelude.Nothing -> IntMap.emptyIntSet}}
in
case ops of {
(,) p opse ->
case p of {
(,) opsb opsm ->
State.bind (\x ->
State.bind (\opsb' ->
State.bind (\opsm' ->
State.bind (\opse' ->
State.bind (\opsm'' ->
State.pure
(Blocks.setBlockOps binfo blk opsb' opsm'' opse'))
(resolveMappings maxReg oinfo bid opsm' mappings))
(State.concatMapM (f outs) opse))
(State.concatMapM (f outs) opsm))
(State.concatMapM (f outs) opsb))
(State.modify (\assn -> Build_AssnStateInfo (assnOpId assn)
((Prelude.+) (assnOpId assn)
(Ssrnat.double (Data.List.length opsb)))
((Prelude.+) (assnOpId assn)
(Ssrnat.double
((Prelude.+) (Data.List.length opsb) (Data.List.length opsm))))
(assnAcc assn)))}})
assignRegNum :: Prelude.Int -> (Blocks.BlockInfo a1 a2 a3 a4) ->
(Blocks.OpInfo a5 a3 a4) -> ScanState.ScanStateDesc ->
(IntMap.IntMap LiveSets.BlockLiveSets) -> (IntMap.IntMap
Resolve.BlockMoves) -> ([] a1) -> a5 -> (,) ([] a2) a5
assignRegNum maxReg binfo oinfo sd liveSets mappings blocks acc =
case considerOps maxReg binfo oinfo
(doAllocations maxReg oinfo
(Prelude.map (\x -> (,)
(Interval.getIntervalDesc
(
(LinearScan.Utils.nth (ScanState.nextInterval maxReg sd)
(ScanState.intervals maxReg sd) (Prelude.fst x))))
(Prelude.snd x))
((Prelude.++) (ScanState.handled maxReg sd)
((Prelude.++) (ScanState.active maxReg sd)
(ScanState.inactive maxReg sd))))) liveSets mappings blocks
(Build_AssnStateInfo ((Prelude.succ) 0) ((Prelude.succ) 0)
((Prelude.succ) 0) acc) of {
(,) blocks' assn -> (,) blocks' (assnAcc assn)}