-- Optimization of fetches: some fetched fields may be equivalent to local variables.

module Yhc.Core.GRIN.OptFetch where

import Yhc.Core.GRIN.Type
import Yhc.Core.GRIN.FindType
import Yhc.Core.GRIN.HeapPointsTo
import Yhc.Core.GRIN.SubstVars
import Yhc.Core.GRIN.ElimDead
import Yhc.Core.GRIN.FlatInline

import Data.List
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Map as M

-- Using the value propagation map, remove unneeded bindings.

propVal :: HeapMap -> GRIN -> GRIN

propVal seed g =
  let hm = heapPointsTo g `M.union` seed
      eqm = buildEqv hm
      mfun ex@(GBind sx bv) = case S.toList $ M.findWithDefault S.empty (unGVar bv) eqm of
        [] -> ex
        [v@(GVal (GVar vv))] -> GBind (GUnit v) bv
        [gv] -> GBind (GStore gv) bv
        _ -> ex
      mfun z = z
      mg f = f {gFuncBody = mapOverBlock mfun (gFuncBody f)}
  in  case M.null eqm of
        True -> g
        False -> elimAllDeadBindings $ g {gFuncs = map mg (gFuncs g)}

-- Optimize fetches by tracing the source: if it is a tagged value,
-- replace fetch source with the proper field.

optFetch :: HeapMap -> GRIN -> GRIN

optFetch seed g =
  let hm = heapPointsTo g `M.union` seed
      mfun ex@(GBind (GFetch v t0 (Just n)) bv) = case M.lookup (HVar v) hm of
        Nothing -> ex
        Just [HasValue (GTag ('K':'@':_))] -> evalvar bv v t0 n
        Just [HasValue (GTagged ('F':'@':_) _)] -> evalvar bv v t0 n
        Just [HasValue (GTagged t1 flds)] | t0 == t1 && n <= length flds ->
          GBind (GUnit $ GVal $ flds !! (n - 1)) bv
        Just [EquivTo vn] -> mfun (GBind (GFetch vn t0 (Just n)) bv)
        _ -> ex
      mfun z = z
      evalvar bv v t0 n =
        let vv = unGVar bv ++ "'" ++ v
            cv = vv ++ "'1"
            rv = vv ++ "'2"
            call = GBind (GCall "GRIN;eval" [gVar v]) (gVar cv)
            ftch = GBind (GFetch cv t0 (Just n)) (gVar rv)
            ret  = GSimple (GUnit $ gVar rv)
        in  GBind (GInline [call, ftch, ret]) bv
      mg f = f {gFuncBody = mapOverBlock mfun (gFuncBody f)}
  in  flattenInline $ g {gFuncs = map mg (gFuncs g)}