{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{- For Hugs, use the option -F"cpp -P -traditional" -}

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.Interval as Interval
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



--unsafeCoerce :: a -> b
#ifdef __GLASGOW_HASKELL__
import qualified GHC.Base as GHC.Base
unsafeCoerce = GHC.Base.unsafeCoerce#
#else
-- HUGS
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
                    -> AssnState a3 ((,) ([] a2) ([] a2))
savesAndRestores maxReg oinfo opid v reg int =
  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
      case atBoundary of {
       Prelude.True -> State.pure ((,) [] []);
       Prelude.False ->
        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 {restore = restoreOpM maxReg oinfo (Prelude.Just vid) reg} 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 restore save;
               Prelude.False -> pairM restore (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 restore (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 []) save;
             Prelude.False -> State.pure ((,) [] [])};
           Interval.Middle ->
            case isLast of {
             Prelude.True -> pairM (State.pure []) save;
             Prelude.False -> State.pure ((,) [] [])};
           _ -> State.pure ((,) [] [])}}}) State.get}

collectAllocs :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> Prelude.Int ->
                 ([] ((,) Interval.IntervalDesc PhysReg)) -> ((,)
                 ((,) ([] ((,) Blocks.VarId PhysReg)) ([] a2)) ([] a2)) ->
                 Blocks.VarInfo -> State.State (AssnStateInfo a3)
                 ((,) ((,) ([] ((,) Blocks.VarId PhysReg)) ([] a2)) ([] a2))
collectAllocs maxReg oinfo opid 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)}}})}

doAllocations :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> ([]
                 ((,) Interval.IntervalDesc PhysReg)) -> a1 -> AssnState 
                 a3 ([] a2)
doAllocations maxReg oinfo ints 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 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) -> (Data.IntMap.IntMap
                   ((,) Graph.Graph Graph.Graph)) -> AssnState a3 ([] a2)
resolveMappings maxReg oinfo bid opsm mappings =
  case Data.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) -> (a3 -> AssnState a5 ([] a4)) ->
               (Data.IntMap.IntMap ((,) Graph.Graph Graph.Graph)) -> ([] 
               a1) -> State.State (AssnStateInfo a5) ([] a2)
considerOps maxReg binfo oinfo f mappings =
  State.mapM (\blk ->
    let {ops = Blocks.blockOps binfo blk} in
    case ops of {
     (,) p opse ->
      case p of {
       (,) opsb opsm ->
        State.bind (\x ->
          State.bind (\opsb' ->
            State.bind (\opsm' ->
              State.bind (\opse' ->
                let {bid = Blocks.blockId binfo blk} in
                State.bind (\opsm'' ->
                  State.pure
                    (Blocks.setBlockOps binfo blk opsb' opsm'' opse'))
                  (resolveMappings maxReg oinfo bid opsm' mappings))
                (State.concatMapM f opse)) (State.concatMapM f opsm))
            (State.concatMapM f 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 ->
                (Data.IntMap.IntMap Resolve.BlockMoves) -> ([] a1) -> a5 ->
                (,) ([] a2) a5
assignRegNum maxReg binfo oinfo sd 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))))) mappings blocks
         (Build_AssnStateInfo ((Prelude.succ) 0) ((Prelude.succ) 0)
         ((Prelude.succ) 0) acc) of {
   (,) blocks' assn -> (,) blocks' (assnAcc assn)}