-- GRIN-like backend for Yhc Core
-- Sharing and strictness analyses

module Yhc.Core.GRIN.Sharing where

import Yhc.Core.GRIN.HeapPointsTo
import Yhc.Core.GRIN.Type
import Yhc.Core.GRIN.FindType
import Yhc.Core.GRIN.SubstVars
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Either
import Data.Maybe
import Data.List

type SharingMap = M.Map GName [GName]

type RevShrMap = M.Map GName [GVal]

-- Given a sharing map, rename all involved variables so their names start with 's'.

renameShared :: SharingMap -> GRIN -> GRIN

renameShared sm g =
  let shvars = concat (M.keys sm : M.elems sm)
      rnvars = map n2s shvars
      rnmap = M.fromList $ zip shvars rnvars
  in  substGRIN rnmap g

-- Utility function: rename a node into shared node.

n2s ('n':v) = 's':v
n2s z = z

-- Obtain list of strict-on variables: dependencies of those evaluated 
-- at top-level of any function. Additionally, dependencies
-- are subset to those variables that are actual arguments to function
-- calls, not just to F-tags as dependency analysis returns the latter
-- as well.

strictOnVars :: HeapMap -> GRIN -> S.Set GVal

strictOnVars seed g =
  let toplev g = g {gFuncs = map f (gFuncs g)} where
        f gf | gFuncName gf `elem` evap= gf {gFuncBody = []}
        f gf = gf {gFuncBody = concat $ map ff (gFuncBody gf)}
        ff    (GBind (GInline bl) bv) = [GBind (GInline (concat $ map ff bl)) bv]
        ff ex@(GBind _ _) = [ex]
        ff    (GSimple (GInline bl)) = [GSimple (GInline (concat $ map ff bl))]
        ff ex@(GSimple _) = [ex]
        ff _ = []
      evap = ["GRIN;eval", "GRIN;apply"]
      tlg = toplev g
      hm = heapPointsTo g `M.union` seed
      hmt = heapPointsTo tlg `M.union` seed
      evalv = concat $ map cvar $ M.keys $ M.filter (== [CallTo "GRIN;eval"]) hmt
      cvar (HCall _ [EquivTo v]) = [v]
      cvar _ = []
      calls = S.fromList $ concat $ map avar $ M.keys $ M.filter iscall hm
      iscall [CallTo f] | f `elem` evap = False
      iscall [CallTo _] = True
      iscall _ = False
      avar (HCall _ args) = concat $ map unequiv args
      avar _ = []
      unequiv (EquivTo v) = [gVar v]
      unequiv _ = []
      unhvar (HVar v) = [gVar v]
      unhvar _ = []
      nwhnfs = S.fromList $ concat $ map unhvar $ M.keys $ M.filter isnwhnf hm
      isnwhnf [HasValue (GTagged ('F':'@':_) _)] = True
      isnwhnf [HasValue (GTag ('K':'@':_))] = True
      isnwhnf z = False
      nds = Deps {complete = M.empty, pending = M.empty, newdeps = evalv}
      deps = buildDeps hm nds
      alldeps = complete deps `M.union` pending deps
  in  M.fold S.union S.empty alldeps `S.intersection` calls `S.intersection` nwhnfs

-- Strictify GRIN by changing bindings of strict-on variables 

optStrict :: HeapMap -> GRIN -> (GRIN, Bool)

optStrict seed g =
  let sv = strictOnVars seed g
      mfun ex@(GBind (GStore (GTagged ('F':'@':fun) args)) bv) = tocall ex bv fun args
      mfun ex@(GBind (GUnit (GTagged ('F':'@':fun) args)) bv) = tocall ex bv fun args
      mfun ex@(GBind (GStore (GTag ('K':'@':fun))) bv) = tocall ex bv fun []
      mfun ex@(GBind (GUnit (GTag ('K':'@':fun))) bv) = tocall ex bv fun []
      mfun ex = ex
      tocall ex bv fun args | bv `S.member` sv = GBind (GCall fun (map GVal args)) bv
      tocall ex _ _ _ = ex
      mg f | gFuncName f `elem` ["GRIN;eval", "GRIN;apply"] = f
      mg f = f {gFuncBody = mapOverBlock mfun (gFuncBody f)}
  in  case S.null sv of
        True ->  (g, False)
        False -> (g {gFuncs = map mg (gFuncs g)}, True)