{-# 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.IntMap as IntMap
import qualified LinearScan.Interval as Interval
import qualified LinearScan.Lib as Lib
import qualified LinearScan.LiveSets as LiveSets
import qualified LinearScan.Resolve as Resolve
import qualified LinearScan.State as State
import qualified LinearScan.UsePos as UsePos
import qualified LinearScan.Eqtype as Eqtype
import qualified LinearScan.Fintype as Fintype
import qualified LinearScan.Seq as Seq
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

swapOpM :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> Blocks.PhysReg ->
           Blocks.PhysReg -> AssnState a3 ([] a2)
swapOpM maxReg oinfo sreg dreg =
  State.bind (\assn ->
    case Blocks.swapOp 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

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

varAllocs :: Prelude.Int -> Prelude.Int -> ([] Resolve.Allocation) ->
             Blocks.VarInfo -> [] ((,) Blocks.VarId PhysReg)
varAllocs maxReg opid allocs v =
  case Blocks.varId maxReg v of {
   Prelude.Left p -> [];
   Prelude.Right vid ->
    Prelude.map (\x -> (,) vid x)
      (Lib.catMaybes
        (Prelude.map (\i -> Resolve.intReg maxReg i)
          (Prelude.filter (\i ->
            let {int = Resolve.intVal maxReg i} in
            (Prelude.&&)
              (Eqtype.eq_op Ssrnat.nat_eqType
                (unsafeCoerce (Interval.ivar int)) (unsafeCoerce vid))
              ((Prelude.&&) ((Prelude.<=) (Interval.ibeg int) opid)
                (case Blocks.varKind maxReg v of {
                  UsePos.Input -> (Prelude.<=) opid (Interval.iend int);
                  _ -> (Prelude.<=) ((Prelude.succ) opid) (Interval.iend int)})))
            allocs)))}

generateMoves :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> ([]
                 Resolve.ResolvingMove) -> AssnState a3 ([] a2)
generateMoves maxReg oinfo moves =
  State.forFoldrM [] moves (\mv acc ->
    State.bind (\mops ->
      State.pure
        (case mops of {
          Prelude.Just ops -> (Prelude.++) ops acc;
          Prelude.Nothing -> acc}))
      (case mv of {
        Resolve.Move sreg dreg ->
         State.fmap (\x -> Prelude.Just x) (moveOpM maxReg oinfo sreg dreg);
        Resolve.Swap sreg dreg ->
         State.fmap (\x -> Prelude.Just x) (swapOpM maxReg oinfo sreg dreg);
        Resolve.Spill sreg vid ->
         State.fmap (\x -> Prelude.Just x)
           (saveOpM maxReg oinfo sreg (Prelude.Just vid));
        Resolve.Restore vid dreg ->
         State.fmap (\x -> Prelude.Just x)
           (restoreOpM maxReg oinfo (Prelude.Just vid) dreg);
        Resolve.Nop -> State.pure Prelude.Nothing}))

doAllocations :: Prelude.Int -> (Blocks.OpInfo a3 a1 a2) -> ([]
                 Resolve.Allocation) -> a1 -> AssnState a3 ([] a2)
doAllocations maxReg oinfo allocs op =
  State.bind (\assn ->
    let {opid = assnOpId assn} in
    let {vars = Blocks.opRefs maxReg oinfo op} in
    let {
     regs = State.concat (Prelude.map (varAllocs maxReg opid allocs) vars)}
    in
    let {ops = Blocks.applyAllocs maxReg oinfo op regs} in
    State.bind (\transitions ->
      State.bind (\x -> State.pure ((Prelude.++) ops transitions))
        (State.modify (\assn' -> Build_AssnStateInfo ((Prelude.succ)
          ((Prelude.succ) opid)) (assnBlockBeg assn') (assnBlockEnd assn')
          (assnAcc assn'))))
      (case (Prelude.&&) ((Prelude.<=) (assnBlockBeg assn) opid)
              ((Prelude.<=) ((Prelude.succ) opid) (assnBlockEnd assn)) of {
        Prelude.True ->
         generateMoves maxReg oinfo
           (Resolve.determineMoves maxReg
             (Resolve.resolvingMoves maxReg allocs opid ((Prelude.succ)
               ((Prelude.succ) opid))));
        Prelude.False -> State.pure []})) State.get

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
            (Prelude.map (Resolve.moveFromGraph maxReg)
              (Graph.topsort
                (Eqtype.sum_eqType (Fintype.ordinal_eqType maxReg)
                  Ssrnat.nat_eqType) gend))))
        (generateMoves maxReg oinfo
          (Prelude.map (Resolve.moveFromGraph maxReg)
            (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)) ->
               (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
    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'' ->
                  case opsb' of {
                   [] ->
                    State.pure
                      (Blocks.setBlockOps binfo blk opsb' opsm'' opse');
                   (:) b bs ->
                    case opse' of {
                     [] ->
                      State.pure
                        (Blocks.setBlockOps binfo blk opsb' opsm'' opse');
                     (:) e es ->
                      State.pure
                        (Blocks.setBlockOps binfo blk ((:) b [])
                          ((Prelude.++) bs
                            ((Prelude.++) opsm'' (Seq.belast e es))) ((:)
                          (Seq.last e es) []))}})
                  (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) -> ([] Resolve.Allocation) ->
                (IntMap.IntMap LiveSets.BlockLiveSets) -> (IntMap.IntMap
                Resolve.BlockMoves) -> ([] a1) -> a5 -> (,) ([] a2) a5
assignRegNum maxReg binfo oinfo allocs liveSets mappings blocks acc =
  case considerOps maxReg binfo oinfo (doAllocations maxReg oinfo allocs)
         liveSets mappings blocks (Build_AssnStateInfo ((Prelude.succ) 0)
         ((Prelude.succ) 0) ((Prelude.succ) 0) acc) of {
   (,) blocks' assn -> (,) blocks' (assnAcc assn)}