-- GRIN-like backend for Yhc Core.
-- Heap-Points-To analysis.

-- No software was made available in connection to the original thesis.
-- See http://tinyurl.com/5cze2e (points to a Google Groups discussion).
-- This is a clean-room implementation based on the Thesis.

module Yhc.Core.GRIN.HeapPointsTo where

import Yhc.Core.GRIN.Type
import Yhc.Core.GRIN.SubstVars
import qualified Data.Map as M
import Data.List


-- The analysis itself. It runs over the whole GRIN program yielding the
-- heap map.

heapPointsTo :: GRIN -> HeapMap

heapPointsTo = M.unions . map funcHM . gFuncs

-- Run analysis over a single function. If a toplevel case is present,
-- heaps from each block are unioned and returned.

funcHM :: GFunc -> HeapMap

funcHM gf = 
  let gfn = gFuncName gf
      argmap = M.fromList $ zip (map HVar $ gFuncArgs gf) (map (\n -> [ArgOf gfn n]) [1 .. ])
      (csvar, blks) = case gFuncBody gf of
        [GBind (GEval a) cv, GCase _ cbrs] -> 
          let c = M.singleton (HVar $ unGVar cv) [EvalOf a]
              bs = map (blockHM gfn . snd) cbrs
          in  (c, bs)
        bl -> (M.empty, [blockHM gfn bl])
      rets = M.singleton (HFunc gfn) (nub $ concat $ map fst blks)
  in  M.unions (csvar : argmap : rets : map snd blks)

-- Run analysis over a block of bindings. Last element (should be GSimple ...) is recorded
-- as a return value.

blockHM :: GName -> GBlock -> ([PointsTo], HeapMap)

blockHM _ [] = ([HasValue GEmpty], M.empty)

blockHM fn bl = f M.empty fn bl where
  v2pt (GVal (GVar gv)) = EquivTo gv
  v2pt v = HasValue v
  f bmap fn [GSimple (GUnit rv)] = ([v2pt rv], bmap)
  f bmap fn [GCase _ cbrs] = (rvs, bmap') where
    bs = map (blockHM fn . snd) cbrs
    rvs = concat $ map fst bs
    bmap' = M.unions (bmap : map snd bs)
  f bmap fn (GBind sxpr bv' : es) = f bmap' fn es where
    bmap' = let bv = unGVar bv' in case sxpr of
      GUnit rv -> M.insert (HVar bv) [v2pt rv] bmap
      GStore rv -> M.insert (HVar bv) [v2pt rv] bmap
      GCall cn args -> M.unions [bmap, call, bnd] where
        call = M.singleton (HCall (fn, bv) $ map v2pt args) [CallTo cn]
        bnd  = M.singleton (HVar bv) [ReturnOf cn]
      GEval en -> M.insert (HVar bv) [EvalOf en] bmap
      GUpdate _ _ -> M.insert (HVar bv) [HasValue GEmpty] bmap
      GFetch xn t Nothing -> M.insert (HVar bv) [EquivToT xn t] bmap
      GFetch xn t (Just n) -> M.insert (HVar bv) [ElemOfT xn t n] bmap
      GApply gn gv -> M.insert (HVar bv) [Applied gn gv] bmap
      GInline ibl -> M.unions [bmap, imap, bnd] where
        (irvs, imap) = blockHM fn ibl
        rbnd = case irvs of
          [] -> error $ "blockHM  (" ++ fn ++ ") no return from inline"
          irvs -> irvs
        bnd = M.singleton (HVar bv) rbnd
  f bmap fn (_ : es) = f bmap fn es
  f bmap fn [] = ([], bmap)