-- GRIN-like backend for Yhc Core.
-- Apply inlining.

module Yhc.Core.GRIN.OptApply where

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

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

-- Create a central apply function out of the heap map. Brute force approach:
-- for each existing P@n tag also create all P-tags with smaller n.

buildApply :: HeapMap -> GGM GFunc

buildApply hm = do
  [arg1, arg2] <- replicateM 2 newVar
  ftvar <- newGVar
  let fetch = GBind (GFetch arg1 "" (Just 0)) ftvar
      fkargs n = map (val2sval . gVar . ('a':) . show) [1 .. n]
      ptags = concat $ map ptag $ concat $ M.elems hm
      ptag (HasValue (GTagged ('P':'@':missfun) args)) = 
        let (miss, _:fun) = break (== ':') missfun
            mnarg = (read miss) :: Int
        in  dftags mnarg fun (length args)
      ptag _ = []
      dftags 0 _ _ = []
      dftags miss fun n =
        HasValue (GTagged ('P':'@': show miss ++ ":" ++ fun) (fkargs n)) : 
          dftags (miss - 1) fun (n + 1)
      tas = nub ptags
      pat (HasValue (GTagged tag@('P':'@':missfun) gsvs)) = do
        let (miss, _:fun) = break (== ':') missfun
            nfld = length gsvs
        rtvarp <- newGVar
        fldvars <- replicateM nfld newVar
        let flftchs = zipWith (\v n -> GBind (GFetch arg1 tag (Just n)) v) xxargs [1 .. ]
            xxargs = map gVar fldvars
            mnarg = (read miss) :: Int
            cot = case mnarg == 1 of
              True -> GStore $ GTagged ("F@" ++ fun) (map val2sval (xxargs ++ [gVar arg2]))
              False -> GStore $ GTagged ("P@" ++ show (mnarg - 1) ++ ":" ++ fun) 
                                        (map val2sval (xxargs ++ [gVar arg2]))
            cbr = flftchs ++ [GBind cot rtvarp, GSimple (GUnit rtvarp)]
        return (GPatTag tag, cbr)
  body <- case tas of
    [] -> return $ GSimple (GUnit GEmpty)
    _  -> mapM pat (sort tas) >>= return . GCase ftvar . sort . nub
  return $ GFunc 
    {gFuncName = "GRIN;apply"
    ,gFuncArgs = [arg1, arg2]
    ,gFuncBody = [fetch, body]}