hunk ./Language/GRIN/Pretty.hs 1
--- GRIN-like backend for Yhc Core
--- Pretty-printer for GRIN
-
-module Language.GRIN.Pretty (prettyPrint) where
-
-import Data.Maybe
-import Text.PrettyPrint.HughesPJ
-import Yhc.Core.BackEnd.GRIN
-
--- |Pretty-print a GRIN module in Haskell monadic style.
-
-prettyPrint :: GRIN -> String
-
-prettyPrint = render . prGRIN
-
--- Convert a whole GRIN module to Doc
-
-prGRIN g = vcat (map prFunc (gFuncs g))
-
-prFunc gf = vcat [hang (text (gFuncName gf) <+> 
-                        foldr (<+>) empty (map text (gFuncArgs gf)) <+>
-                        text "=") 2 (prBlock (gFuncBody gf)), text ""]
-
--- Convert a block of bindings
-
-prBlock [ex] = prExpr ex
-
-prBlock bl = text "do" <+> nest 2 (vcat (map prExpr bl))
-
--- Convert an expression
-
-prExpr (GBind se v) = prVal v <+> text "<-" <+> prSexpr se
-
-prExpr (GCase cv pats) = hang (text "case" <+> prVal cv <+> text "of") 2 (vcat (map prPat pats))
-
-prExpr (GSimple se) = prSexpr se
-
-prExpr (GNop) = text "NOP"
-
-prExpr (GError err) = hang (text "*ERROR*") 2 
-  (vcat $ [text "<<<<<<"] ++ map text (lines err) ++ [text ">>>>>>"])
-
--- Convert a value
-
-prVal (GVal sv) = prSval sv
-
-prVal (GTagged n vs) = lparen <> text n <+> hsep (map prSval vs) <> rparen
-
-prVal (GTag n) = text n
-
-prVal (GEmpty) = lparen <> rparen
-
--- Convert a simple expression
-
-prSexpr (GEval n) = text "eval" <+> text n
-
-prSexpr (GApply f v) = text "apply" <+> text f <+> prVal v
-
-prSexpr (GUnit uv) = text "return" <+> prVal uv
-
-prSexpr (GCall fn vs) = text fn <+> hsep (map prVal vs)
-
-prSexpr (GStore v) = text "store" <+> prVal v
-
-prSexpr (GFetch n "" mbi) = text "fetch" <+> text n <+> int (fromMaybe 0 mbi)
-
-prSexpr (GFetch n t mbi) = text "fetch" <+> text n <+> text ("/" ++ t ++ "/") <+> 
-                           int (fromMaybe 0 mbi)
-
-prSexpr (GUpdate n v) = text "update" <+> text n <+> prVal v
-
-prSexpr (GInline bl) = nest 2 (prBlock bl)
-
--- Convert a simple value
-
-prSval (GVar n) = text n
-
-prSval (GLitVal x) = prLit x
-
--- These three really should not occur in the pretty print
-
-prSval  GTInteger  = text "<integer>"
-prSval  GTChar     = text "<char>"
-prSval  GTDouble   = text "<double>"
-prSval  GTAny      = text "<any>"
-
--- Convert a case pattern
-
-prPat (GPatTag n, bl) = hang (text n <+> text "->") 2 (prBlock bl)
-
-prPat (GPatLit x, bl) = hang (prLit x <+> text "->") 2 (prBlock bl)
-
-prPat (GPatDefault, bl) = hang (text "_" <+> text "->") 2 (prBlock bl)
-
--- Convert a literal
-
-prLit (GInt i) = lparen <> integer i <+> text ":: Integer" <> rparen
-
-prLit (GFloat d) = lparen <> double d <+> text ":: Double" <> rparen
-
-prLit (GChar c) = text (show c)
-
-prLit (GString s) = text (show s)
-
rmfile ./Language/GRIN/Pretty.hs
rmdir ./Language/GRIN
hunk ./Yhc/Core/BackEnd/GRIN/ElimDead.hs 1
--- GRIN-like backend for Yhc Core.
--- Dead code elimination.
-
-module Yhc.Core.BackEnd.GRIN.ElimDead where
-
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.FindType
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.SubstVars
-
-import Data.List
-import qualified Data.Set as S
-import qualified Data.Map as M
-
--- Eliminate duplicate bindings. Scan each block from the beginning
--- accumuilating a set of used variables. If the current binding
--- binds to a variable already in the set, remove the binding.
-
-elimDupBindings :: GFunc -> GFunc
-
-elimDupBindings gf@(GFunc {gFuncBody = gb}) = gf {gFuncBody = f gb} where
-  seen = S.fromList (gFuncArgs gf)
-  f = filter (/= GNop) . snd . elimDB where
-    elimDB = elimWith seen
-    elimWith s = mapAccumL edbs s
-    edbs us   (GSimple (GInline ib)) =
-      let el = elimWith us ib
-          newblk = filter (/= GNop) $ snd el
-      in  (us, GSimple (GInline newblk))
-    edbs us   (GCase cv blks) =
-      let mblks = map (elimWith us . snd) blks
-          pats = map fst blks
-          newblks = map (filter (/= GNop) . snd) mblks
-          newcase = GCase cv (zip pats newblks)
-      in  (us, newcase)
-    edbs us   (GBind (GInline ib) bv) =
-      let el = elimWith us ib
-          newblk = filter (/= GNop) $ snd el
-          newset = S.insert (unGVar bv) us
-      in  case S.member (unGVar bv) us of
-            False -> (newset, GBind (GInline newblk) bv)
-            True  -> (us, GNop)
-    edbs us x@(GBind sx bv) =
-      let newset = S.insert (unGVar bv) us
-      in  case S.member (unGVar bv) us of
-            False -> (newset, x)
-            True  -> (us, GNop)
-    edbs us z = (us, z)
-
--- Eliminate dead bindings. Scan each block from bottom-up (from the end)
--- accumulating a set of used variables (that is, appearing within
--- a GSexpr inside GBind). If the current binding binds to a variable
--- that does not appear on this set, remove the binding as it will
--- not be used further down the code. This is a function-level optimization.
--- If a CASE is the last element of a block of bindings, the function collects
--- used variables from all its branches.
-
-
-elimDeadBindings :: GFunc -> GFunc
-
-elimDeadBindings gf@(GFunc {gFuncBody = gb}) = gf {gFuncBody = f gb} where
-  f = filter (/= GNop) . snd . elimDB where
-    elimDB = mapAccumR edbs S.empty
-    edbs us   (GSimple (GInline ib)) =
-      let el = elimDB ib
-          newblk = filter (/= GNop) $ snd el
-          newset = S.union us (fst el)
-      in  (newset, GSimple (GInline newblk))
-    edbs us x@(GSimple sx) = (S.union us (useVars sx), x)
-    edbs us   (GCase cv blks) = 
-      let mblks = map (elimDB . snd) blks
-          pats = map fst blks
-          newblks = map (filter (/= GNop) . snd) mblks
-          newset = S.unions (S.singleton (unGVar cv) : us : map fst mblks)
-          newcase = GCase cv (zip pats newblks)
-      in  (newset, newcase)
-    edbs us   (GBind (GInline ib) bv) = 
-      let el = elimDB ib
-          newblk = filter (/= GNop) $ snd el
-          newset = S.union us (fst el)
-      in  case S.member (unGVar bv) us of
-            True -> (newset, GBind (GInline newblk) bv)
-            False -> (us, GNop)
-    edbs us x@(GBind sx bv) = 
-      let newset = S.union us (useVars sx)
-      in  case S.member (unGVar bv) us of
-            True -> (newset, x)
-            False -> (us, GNop)
-    edbs us z = (us, z)
-
--- Apply elimDeadBindings to each finction in GRIN
-
-elimAllDeadBindings :: GRIN -> GRIN
-
-elimAllDeadBindings g =
-  g {gFuncs = map (elimDeadBindings . elimDupBindings) $ gFuncs g}
-
--- Eliminate dead functions by analyzing actual function calls.
--- This method may only be applied after all evals and apply's
--- are properly inlined. This leaves off standalone CAFs that
--- call themselves, but does this make any sense anyway?
-
-elimDeadCalls :: [GName] -> GRIN -> GRIN
-
-elimDeadCalls roots g =
-  let called = S.unions (S.fromList roots : (map getcalls $ gFuncs g))
-      getcalls gf = f S.empty (gFuncBody gf)
-      f cs [] = cs
-      f cs (b:bs) = f (ff b `S.union` cs) bs
-      ff (GCase _ cbrs) = S.unions $ map (f S.empty . snd) cbrs
-      ff (GSimple (GCall f ps)) = S.singleton f
-      ff (GSimple (GInline bl)) = f S.empty bl
-      ff (GBind (GCall f ps) bv) = S.singleton f
-      ff (GBind (GInline bl) bv) = f S.empty bl
-      ff _ = S.empty
-  in  g {gFuncs = filter (flip S.member called . gFuncName) (gFuncs g)}
-
--- Iteratively eliminate dead functions until number of functions in a GRIN
--- module stabilizes.
-
-iterElimDeadCalls :: [GName] -> GRIN -> GRIN
-
-iterElimDeadCalls roots g =
-  let g' = elimDeadCalls roots g
-      old = length (gFuncs g)
-      new = length (gFuncs g')
-  in  if new < old then iterElimDeadCalls roots g' else g'
-
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/ElimDead.hs
hunk ./Yhc/Core/BackEnd/GRIN/FindType.hs 1
--- GRIN-like backend for Yhc Core
--- Type analysis based on the heap map.
-
-module Yhc.Core.BackEnd.GRIN.FindType where
-
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.SubstVars
-import Control.Monad.State
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.Either
-import Data.Maybe
-import Data.List
-
-import Debug.Trace
-
-
--- Type analysis result type. It consists of the termination reason and whatever the analysis
--- stopped at.
-
-type TAResult = (TTerm, PointsTo)
-
--- Type analysis termination reason.
-
-data TTerm = TSucc           -- Success: result contains a concrete value
-           | TLoop           -- Loop: result refers to the variable looped on
-           | TNoEntry        -- Variable of function was not found in the heap map
-           | TDebug String
-           | TUser           -- User-defined predicate returned True
-           | TUnk            -- Type analysis cannot be continued with this destination
-           deriving (Eq, Ord, Show)
-
--- Consolidate literal values into "any" values such as any Integer value
--- becomes GTInteger.
-
-val2Type :: TAResult -> TAResult
-
-val2Type (t, HasValue (GVal (GLitVal (GInt _)))) = (t, HasValue $ GVal GTInteger)
-val2Type (t, HasValue (GVal (GLitVal (GChar _)))) = (t, HasValue $ GVal GTChar)
-val2Type (t, HasValue (GVal (GLitVal (GFloat _)))) = (t, HasValue $ GVal GTDouble)
-val2Type z = z
-
-
--- Type analysis. Look through the heap map trying to find all possible
--- values a variable can be given.
-
-runTA :: HeapMap -> Maybe (PointsTo -> Bool) -> GName -> [TAResult]
-
-runTA hm mbup gn = snd $ head $ filter ((== gn) . fst) $ runTAM hm mbup [gn]
-
-
-runTAold hm up gn = runTAWith hm up S.empty gn
-
-runTAWith :: HeapMap -> (PointsTo -> Bool) -> S.Set GName -> GName -> [TAResult]
-
-runTAWith hm up s gn = noempty $ nub $ map val2Type $ f s (JustVar gn) where
-  noempty l@[(TSucc, HasValue GEmpty)] = l
-  noempty z = filter (not . (== (TSucc, HasValue GEmpty))) z
-  spectag t1 (_, HasValue (GTagged t2 _)) = t1 == t2
-  spectag t1 (_, HasValue (GTag t2)) = t1 == t2
-  spectag _ _ = False
-  f vs pt | up pt = [(TUser, pt)]
-  f vs pt@(EquivToT gn t) = filter (spectag t) $ f vs (EquivTo gn)
-  f vs pt@(EquivTo gn) | gn `S.member` vs = [(TLoop, pt)]
-  f vs pt@(EquivTo gn) = case M.lookup (HVar gn) hm of
-    Nothing -> [(TNoEntry, pt)]
-    Just targ -> concat $ map (f (gn `S.insert` vs)) targ
-  f vs pt@(JustVar gn) | gn `S.member` vs = [(TLoop, pt)]
-  f vs pt@(JustVar gn) = case M.lookup (HVar gn) hm of
-    Nothing -> [(TNoEntry, pt)]
-    Just targ -> concat $ map (f (gn `S.insert` vs)) targ
-  f vs pt@(HasValue _) = [(TSucc, pt)]
-  f vs pt@(ReturnOf fn) = case M.lookup (HFunc fn) hm of
-    Nothing -> [(TNoEntry, pt)]
-    Just fnargs -> concat $ map (f vs) fnargs
-  f vs pt@(ArgOf gfn n) =
-    let calls = M.keys $ M.filter (== [CallTo gfn]) hm
-        ntharg nn (HCall (cfn, _) _) | cfn == gfn = Loop pt
-        ntharg nn (HCall _ pts) = if n > length pts then error (show pt) else pts !! (nn - 1)
-        targs = map (ntharg n) calls
-    in  case calls of
-          [] -> [(TNoEntry, pt)]
-          _  -> concat $ map (f (gfn `S.insert` vs)) (nub targs)
-  f vs pt@(ElemOf tv n) = f vs (ElemOfT tv "" n)
-  f vs pt@(ElemOfT tv t n) =
-    let flt = if null t then id else filter (spectag t)
-        ptta = flt $ runTAWith hm (const False) vs tv
-        ptpts = map snd $ filter ((== TSucc) . fst) ptta
-        onelem (HasValue (GTag t)) | n == 0 = f vs (HasValue (GTag t))
-        onelem (HasValue (GTag t)) | n > 0 = f vs (HasValue GEmpty)
-        onelem (HasValue (GTagged t _)) | n == 0 = f vs (HasValue (GTag t))
-        onelem (HasValue (GTagged t elems)) = 
-          let e = if n > length elems then Nothing else Just (elems !! (n - 1))
-          in  case e of
-                Nothing -> f vs (HasValue GEmpty)
-                Just (GVar v) -> f vs (EquivTo v)
-                Just (GLitVal l) -> f vs (HasValue (GVal (GLitVal l)))
-        onelem z = f vs z
-    in  case ptpts of
-          [] -> f vs (HasValue GEmpty)
-          _  -> concat $ map onelem ptpts
-  f vs pt@(EvalOf ev) =
-    let ptta = runTAWith hm (const False) vs ev
-        ptpts = map snd $ filter ((== TSucc) . fst) ptta
-        vs' = ev `S.insert` vs
-        evald (HasValue (GTagged ('F':'@':fun) _)) = f vs' (ReturnOf fun)
-        evald (HasValue (GTag ('K':'@':caf))) = f vs' (ReturnOf caf)
-        evald z = f vs' z
-    in  case ptpts of
-          [] -> [(TNoEntry, pt)]
-          _ -> concat $ map evald ptpts
-  f vs pt@(Applied an av) =
-    let ptta = runTAWith hm (const False) vs an
-        ptpts = map snd $ filter ((== TSucc) . fst) ptta
-        vs' = an `S.insert` vs
-    in  case ptpts of
-          [] -> [(TNoEntry, pt)]
-          _ -> concat $ map (appld vs' av) ptpts
-  f _ pt@(Loop ptl) = [(TLoop, ptl)]
-  f _ z = [(TUnk, z)]
-  appld vs av (HasValue (GTagged ('P':'@':missfun) gsvs)) =
-    let (miss, _:fun) = break (== ':') missfun
-        mnarg = (read miss) :: Int
-    in  case mnarg of
-          1 -> f vs (HasValue $ GTagged ("F@" ++ fun) (gsvs ++ [val2sval av]))
-          n -> f vs (HasValue $ GTagged ("P@" ++ show (n - 1) ++ ":" ++ fun) (gsvs ++ [val2sval av]))
-  appld vs av z = f vs z
-
-
--- Run a type analysis over a list of variables with memoization. This algorithm
--- is based on the State Monad, using two maps to hold intermediate results and avoid
--- repetitive analyses. Two maps are necessary since results of type analysis would be
--- different when a user predicate is involved (no predicate is same as const False).
-
-
-data STTA = STTA {
-  nopredmap :: M.Map GName [TAResult]
- ,upredmap :: M.Map GName [TAResult]
-}
-
-runTAM :: HeapMap -> Maybe (PointsTo -> Bool) -> [GName] -> [(GName, [TAResult])]
-
-runTAM hm mbup gns =
-  let whichmap mu = if isJust mu then upredmap else nopredmap
-      noempty l@[(TSucc, HasValue GEmpty)] = l
-      noempty z = filter (not . (== (TSucc, HasValue GEmpty))) z
-      spectag t1 (_, HasValue (GTagged t2 _)) = return (t1 == t2)
-      spectag t1 (_, HasValue (GTag t2)) = return (t1 == t2)
-      spectag _ _ = return False
-      oneTAM mu gn = oneTAMWith S.empty mu gn
-      oneTAMWith vs mu gn = do
-        vmap <- get >>= return . whichmap mu
-        let tas = M.lookup gn vmap
-        case tas of
-          Just tas' -> return tas'
-          Nothing -> do
-            tas' <- ta vs mu (JustVar gn) >>= return . noempty . nub . map val2Type
-            st <- get
-            let vmap = whichmap mu st
-                vmap' = M.insert gn tas' vmap
-                st' = if isJust mu then st {upredmap = vmap'} else st {nopredmap = vmap'}
-            put st'
-            return tas'
-      ta vs mu pt | isJust mu && fromJust mu pt = return [(TUser, pt)]
-      ta vs mu pt@(EquivToT gn t) = ta vs mu (EquivTo gn) >>= filterM (spectag t)
-      ta vs mu pt@(EquivTo gn) = ta vs mu (JustVar gn)
-      ta vs mu pt@(JustVar gn) = do
-        vmap <- get >>= return . whichmap mu
-        if gn `S.member` vs
-          then return [(TLoop, EquivTo gn)]
-          else do let tas = M.lookup gn vmap
-                  case tas of
-                    Just tas' -> return tas'
-                    Nothing -> do
-                      case M.lookup (HVar gn) hm of
-                        Nothing -> return [(TNoEntry, EquivTo gn)]
-                        Just targ -> mapM (ta (gn `S.insert` vs) mu) targ >>= return . concat . nub
-      ta vs mu pt@(HasValue _) = return [(TSucc, pt)]
-      ta vs mu pt@(ReturnOf fn) = case M.lookup (HFunc fn) hm of
-        Nothing -> return [(TNoEntry, pt)]
-        Just fnargs -> mapM (ta vs mu) fnargs >>= return . concat
-      ta vs mu pt@(ArgOf gfn n) = do
-        let calls = M.keys $ M.filter (== [CallTo gfn]) hm
-            ntharg nn (HCall (cfn, _) _) | cfn == gfn = Loop pt
-            ntharg nn (HCall _ pts) = if n > length pts then error (show pt) else pts !! (nn - 1)
-            targs = map (ntharg n) calls
-        case calls of
-          [] -> return [(TNoEntry, pt)]
-          _  -> mapM (ta (gfn `S.insert` vs) mu) targs >>= return . concat . nub
-      ta vs mu pt@(ElemOf tv n) = ta vs mu (ElemOfT tv "" n)
-      ta vs mu pt@(ElemOfT tv t n) = do
-        ptta <- oneTAMWith vs Nothing tv >>= if null t then return else filterM (spectag t)
-        let ptpts = map snd $ filter ((== TSucc) . fst) ptta
-            onelem (HasValue (GTag t)) | n == 0 = ta vs mu (HasValue (GTag t))
-            onelem (HasValue (GTag t)) | n > 0 = ta vs mu (HasValue GEmpty)
-            onelem (HasValue (GTagged t _)) | n == 0 = ta vs mu (HasValue (GTag t))
-            onelem (HasValue (GTagged t elems)) = do
-              let e = if n > length elems then Nothing else Just (elems !! (n - 1))
-              case e of
-                Nothing -> ta vs mu (HasValue GEmpty)
-                Just (GVar v) -> ta vs mu (EquivTo v)
-                Just (GLitVal l) -> ta vs mu (HasValue (GVal (GLitVal l)))
-            onelem z = ta vs mu z
-        case ptpts of
-          [] -> ta vs mu (HasValue GEmpty)
-          _  -> mapM onelem ptpts >>= return . concat
-      ta vs mu pt@(EvalOf ev) = do
-        ptta <- oneTAMWith vs Nothing ev
-        let ptpts = map snd $ filter ((== TSucc) . fst) ptta
-        st <- get
-        let vs' = ev `S.insert` vs
-        let evald (HasValue (GTagged ('F':'@':fun) _)) = ta vs' mu (ReturnOf fun)
-            evald (HasValue (GTag ('K':'@':caf))) = ta vs' mu (ReturnOf caf)
-            evald z = ta vs' mu z
-        case ptpts of
-          [] -> return [(TNoEntry, pt)]
-          _  -> mapM evald ptpts >>= return . concat
-      ta vs mu pt@(Applied an av) = do
-        ptta <- oneTAMWith vs Nothing an
-        let ptpts = map snd $ filter ((== TSucc) . fst) ptta
-        st <- get
-        let vs' = an `S.insert` vs
-        case ptpts of
-          [] -> return [(TNoEntry, pt)]
-          _  -> mapM (appld vs' mu av) ptpts >>= return . concat
-      ta _ _  pt@(Loop ptl) = return [(TLoop, ptl)]
-      ta _ _  z = return [(TUnk, z)]
-      appld vs mu av (HasValue (GTagged ('P':'@':missfun) gsvs)) = do
-        let (miss, _:fun) = break (== ':') missfun
-            mnarg = (read miss) :: Int
-        case mnarg of
-          1 -> ta vs mu (HasValue $ GTagged ("F@" ++ fun) (gsvs ++ [val2sval av]))
-          n -> ta vs mu (HasValue $ GTagged ("P@" ++ show (n - 1) ++ ":" ++ fun) 
-                          (gsvs ++ [val2sval av]))
-      appld vs mu av z = ta vs mu z
-  in  M.toList $ whichmap mbup $ execState (mapM_ (oneTAM mbup) gns) (STTA M.empty M.empty)
-
--- Type analysis statistics. Given a HeapMap, runs type analysis on each variable,
--- and returns counts for all termination results (except for TUser as the full
--- analysis is run). Results of the analysis are also returned.
-
-taStats :: HeapMap -> ([(GName, [TAResult])], M.Map TTerm Int)
-
-taStats hm =
-  let varonly (HVar v) = [v]
-      varonly _ = []
-      vars m = concat $ map varonly $ M.keys m
-      ta = map snd $ runTAM hm Nothing (vars hm)
-  in  (zip (vars hm) ta, fst $ mapAccumL stat M.empty $ concat ta) where
-        stat mp v@(term, vals) =
-          let prev = M.findWithDefault 0 term mp
-              upm = M.insert term (prev + 1) mp
-          in  (upm, v)
-
--- Infer calls from applications of P@1-tags. Find all applications first.
--- Then keep only those whose applying value is a P@1-tag. This results
--- in an additional HeapMap containing HCall entries with values taken
--- from tags and applied values. 
-
-inferCalls :: HeapMap -> HeapMap
-
-inferCalls hm =
-  let apred (Applied _ _) = True
-      apred _ = False
-      p1pred (HasValue (GTagged ('P':'@':'1':':':f) v)) = True
-      p1pred _ = False
-      pfpred (HasValue (GTagged ('F':'@':f) v)) = True
-      pfpred _ = False
-      ftags = filter pfpred $ concat $ M.elems hm
-      pfapp = zip (repeat "&") ftags
-      apvar (Applied a b) = (a, b)
-      taapp = filter apred $ concat $ M.elems hm
-      apvars = map (fst . apvar) taapp
-      apmap = M.fromList (map apvar taapp)
-      p1app = runTAM hm (Just p1pred) apvars
-      p1flt (v, pts) = zip (repeat v) (map snd $ filter ((== TUser) . fst) pts)
-      p1tags = concat $ map p1flt p1app
-      p1call (v, HasValue (GTagged ('P':'@':'1':':':fun) args)) = maybeToList $ do
-        vx <- M.lookup v apmap
-        return (HCall ("_infer-p_", '#':fun) (map (EquivTo . unVar) (args ++ [val2sval vx])), 
-                [CallTo fun])
-      p1call (_, HasValue (GTagged ('F':'@':fun) args)) =
-        [(HCall ("_infer-f_", '#':fun) (map (EquivTo . unVar) args), [CallTo fun])]
-  in  M.fromList $ concat $ map p1call (p1tags ++ pfapp)
-
-
--- Infer all possible calls: after inferring calls, append them to the initial
--- HeapMap, and try to infer again. Once there are no new calls inferred, return
--- the updated map. Also, the final map will be fixed wrt node sharing.
--- If there is a shared node (name starts with 's') mapped to a single
--- HasValue (GTagged F@xxx), return type for the thunked function will be traced,
--- and appended to the mapped value.
-
-
-inferAllCalls :: HeapMap -> HeapMap
-
-inferAllCalls hm =
-  let ic = inferCalls hm `M.difference` hm
-  in  case M.size ic of
-        0 -> fixSharing hm
-        _ -> inferAllCalls (hm `M.union` ic)
-
-
--- Fix a heap map wrt node sharing.
-
-fixSharing :: HeapMap -> HeapMap
-
-fixSharing hm = M.mapWithKey fs hm where
-  fs (HVar sv) v@[HasValue (GTagged ('F':'@':fun) _)] = if isShrNode sv 
-    then let funret = M.findWithDefault [] (HFunc fun) hm
-             addval = concat $ map fr2v funret
-             fr2v hv@(HasValue _) = [hv]
-             fr2v    (EquivTo ev) = map snd $ 
-                               filter ((==TSucc) . fst) $ runTA hm Nothing ev
-         in  nub $ v ++ addval
-    else v
-  fs x y = y
-
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/FindType.hs
hunk ./Yhc/Core/BackEnd/GRIN/FlatInline.hs 1
--- GRIN-like backend for Yhc Core.
--- Inline function calls and
--- flatten inline blocks where possible.
-
-module Yhc.Core.BackEnd.GRIN.FlatInline where
-
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.FindType
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.SubstVars
-import Yhc.Core.BackEnd.GRIN.ElimDead
-import Yhc.Core.BackEnd.GRIN.OptFetch
-import Yhc.Core.BackEnd.GRIN.OptCases
-
-import Data.List
-import qualified Data.Set as S
-import qualified Data.Map as M
-
-
--- Flatten inline blocks. The logic is:
---  
---  a <- do ...
---       b <- foo
---       return b
---  
---  is same as
---  ...
---  a <- foo
---
---  b is used only within the block being flattened.
-
-flattenInline :: GRIN -> GRIN
-
-flattenInline gr = gr {gFuncs = map f (gFuncs gr)} where
-  f gf = gf {gFuncBody = filter (/= GNop) (ff (gFuncBody gf))}
-  ff [] = []
-  ff (GBind (GInline [GSimple (GUnit (GVal (GVar newvar)))]) bv : bs) =
-    let oldvar = unGVar bv
-        submap = M.singleton oldvar newvar
-    in  ff (map (substGX submap) bs)
-  ff (GBind (GInline ib) bv : bs) = flatten (ff ib) bv ++ ff bs
-  ff (GCase cv cbrs : bs) = 
-    let pats = map fst cbrs
-        blks = map snd cbrs
-        blks' = map ff blks
-        b' = GCase cv (zip pats blks')
-    in  b' : ff bs
-  ff (b:bs) = b : ff bs
-
-flatten ib bv =
-  case reverse ib of
-    GSimple (GUnit iret) : GBind irsx iret' : ibrest | iret' == iret ->
-      reverse ibrest ++ [GBind irsx bv]
-    GSimple (GUnit t@(GTagged _ _)) : ibrest ->
-      reverse ibrest ++ [GBind (GStore t) bv]
-    _ -> [GBind (GInline ib) bv]
-
-
--- Determine if a function is inlineable and get the list of its
--- variables to substitute. Function should be neither a CAF nor
--- recursive. Recursive means explicitly calling itself; P- or F-tag
--- for itself is OK. If the function does not qualify, return an empty
--- list. Non-linear functions (containing case statements) are also excluded
--- because their blocks cannot be flattened (NB may be able to inline
--- tail calls)
-
-
-isInlineable :: GFunc -> S.Set GName
-
-isInlineable gf | null (gFuncArgs gf) = S.empty  -- CAF
-
-isInlineable gf = S.filter isNode $ 
-                  notrec $ 
-                  useVarBlk (S.fromList $ gFuncArgs gf) (gFuncBody gf) where
-  notrec l = if gFuncName gf `S.notMember` l then l else S.empty
-
-
--- Determine if a function is linear, that is, it does not contain
--- cases, inline blocks, and function calls (CAFs only). 
--- This would in most cases apply to dictionary building functions
--- and lift functions.
-
-isLinear :: GFunc -> S.Set GName
-
-isLinear gf = 
-  let bl = gFuncBody gf
-      narg = length $ gFuncArgs gf
-      pred (GCase _ _) = True
-      pred (GBind (GCall _ _) _) = narg == 0
-      pred (GBind (GInline _) _) = True
-      pred _ = False
-      notrec l = if gFuncName gf `S.notMember` l then l else S.empty
-  in  if any pred bl then S.empty
-      else S.filter isNode $ notrec $ useVarBlk (S.fromList $ gFuncArgs gf) bl
-
--- Inline qualifying functions. An explicit function call is replaced
--- with an inline block bound to the variable which was initially bound
--- to the call. All variables within the block will be renamed by prepending
--- the bound-to variable name, except for the function parameters
--- which will be substituted from the call. To be conservative, unaltered
--- versions of functions will be inlined (no infinite inlining).
-
-
-inlineCalls :: (GFunc -> S.Set GName) -> GRIN -> GRIN
-
-inlineCalls iqf g =
-  let oldfuncs = M.fromList $ zip (map gFuncName (gFuncs g)) (gFuncs g)
-      inl gf = gf {gFuncBody = ff (gFuncBody gf)} where
-        ff [] = []
-        ff (b:bs) = fff b : ff bs
-        fff (GCase cv cbrs) =
-          let pats = map fst cbrs
-              newbrs = map (ff . snd) cbrs
-          in  GCase cv (zip pats newbrs)
-        fff (GBind (GInline bl) gv) = GBind (GInline (ff bl)) gv
-        fff b@(GBind (GCall fn ps) gv) = case M.lookup fn oldfuncs of
-          Nothing -> b
-          Just fdf -> 
-            let q = S.toList (iqf fdf)
-                args = gFuncArgs fdf
-                (vargs, nodes) = partition (`elem` args) q
-                subarg = zip vargs (map unGVar ps)
-                subnod = zip nodes (map (inname gv) nodes)
-                submap = M.fromList (subarg ++ subnod)
-                inname gv n = if isShrNode n 
-                  then 's' : (unGVar gv ++ "@" ++ tail n)
-                  else if isNode n then unGVar gv ++ "@" ++ n
-                                   else n
-                inbody = map (substGX submap) (gFuncBody fdf)
-            in  case null q of
-                  True -> b
-                  False -> GBind (GInline inbody) gv
-        fff z = z
-  in  g {gFuncs = map inl (gFuncs g)}
-
--- Repeatedly inline calls with some cleanup.
-
-iterInlineCalls :: HeapMap -> (GFunc -> S.Set GName) -> [GName] -> GRIN -> GRIN
-
-iterInlineCalls seed iqf roots g = iter' 2 seed iqf roots g where
-  iter' n seed iqf roots g =
-    let step = iterElimDeadCalls roots .
-               elimAllDeadBindings .
-               flattenInline .
-               fixCasesAfter seed .
-               optFetch seed .
-               inlineCalls iqf
-        g' = step g
-        old = length (gFuncs g)
-        new = length (gFuncs g')
-    in  if new < old then iter' 2 seed iqf roots g'
-        else if n == 0 then g'
-                       else iter' (n - 1) seed iqf roots (flattenInline g')
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/FlatInline.hs
hunk ./Yhc/Core/BackEnd/GRIN/GGMonad.hs 1
--- GRIN-like backend for Yhc Core.
--- State monad for the converter from Yhc Core.
-
-module Yhc.Core.BackEnd.GRIN.GGMonad (
-   GG (..)
-  ,GGM
-  ,getCnt
-  ,pushFun
-  ,popFun
-  ,module Control.Monad.State) where
-
-import Data.Maybe
-import Yhc.Core.Extra
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Control.Monad
-import Control.Monad.State
-import Yhc.Core.BackEnd.GRIN.Type
-
-data GG = GG {
-   stateCnt :: Int                                -- counter to generate unique names
-  ,coreRef :: Core                                -- reference to core
-  ,coreAnno :: CoreAnnotations                    -- annotations for this core
-  ,currFun :: CoreFunc                            -- current function being compiled
-  ,funStack :: [CoreFunc]                         -- stack of functions (to make cf2gf recursive)
-  ,varMap :: M.Map (CoreFuncName, CoreVarName) GName -- map to rename variables from the program
-  ,funMap :: CoreFuncMap                          -- map of Core functions for faster lookup
-  ,liftSet :: S.Set GName                         -- set of prepared lifting functions
-  ,autoFuncs :: [GFunc]                           -- automatically created functions
-}
-
-getCnt :: GGM Int
-                
-getCnt = do     
-  c <- gets stateCnt
-  st <- get       
-  put st {stateCnt = c + 1}
-  return c
-
-pushFun :: CoreFunc -> GGM ()
-
-pushFun nf = do
-  stk <- gets funStack
-  cf <- gets currFun
-  let stk' = cf : stk
-  st <- get
-  put st {currFun = nf, funStack = stk'}
-  return ()
-
-popFun :: GGM ()
-
-popFun = do
-  (cf:stk) <- gets funStack
-  st <- get
-  put st {currFun = cf, funStack = stk}
-  return ()
-  
-
-type GGM a = State GG a
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/GGMonad.hs
hunk ./Yhc/Core/BackEnd/GRIN/HeapPointsTo.hs 1
--- 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.BackEnd.GRIN.HeapPointsTo where
-
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.SubstVars
-import qualified Data.Map as M
-import Data.List
-
--- The heap graph is represented by a Map. Each entry corresponds to a
--- variable or a function (the key). The values stored are connections
--- to other variables or functions, or, when certain attributes may be deduced
--- out of the connection, the attributes.
-
-type HeapMap = M.Map Heap [PointsTo]
-
--- Map entry key type.
-
-data Heap = HVar GName                      -- variable entry
-          | HFunc GName                     -- function entry
-          | HCall (GName, GName) [PointsTo] -- call (from, bound) with values
-          deriving (Eq, Ord, Show)
-
--- Map entry value type.
-
-data PointsTo = EvalOf GName                -- evaluates from a given variable
-              | ReturnOf GName              -- returned value from a function
-              | EquivTo GName               -- bound to another variable via `return'
-              | EquivToT GName GName        -- bound same with specific tag only
-              | JustVar GName               -- just a variable, used to start type analysis
-              | HasValue GVal               -- bound to a concrete value
-              | ArgOf GName Int             -- is a Nth argument of a function
-              | CallTo GName                -- call to function (HCall must be a key)
-              | ElemOf GName Int            -- Nth element of a variable (fetch)
-              | ElemOfT GName GName Int     -- Nth element of a variable (fetch), specific tag only
-              | Loop PointsTo               -- loop detected (usually a recursive function
-              | Applied GName GVal          -- result of an application of unknown function
-                                            -- either variables or concrete values are
-                                            -- recorded here. HFunc must be a key.
-              deriving (Eq, Ord, Show)
-
-
--- 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
-      GFetch xn _ Nothing -> M.insert (HVar bv) [EquivTo xn] bmap
-      GFetch xn _ (Just n) -> M.insert (HVar bv) [ElemOf xn 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 _ fn z = error $ "blockHM: (" ++ fn ++ ") " ++ show z
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/HeapPointsTo.hs
hunk ./Yhc/Core/BackEnd/GRIN/HeapSeed.hs 1
--- GRIN-like backend for Yhc Core.
--- Seed the Heap Map from Core annotations.
-
-module Yhc.Core.BackEnd.GRIN.HeapSeed where
-
-import Yhc.Core.Extra
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.SubstVars
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import qualified Data.Map as M
-import Data.List
-import Data.Char
-
-import Text.ParserCombinators.Parsec
-import Text.ParserCombinators.Parsec.Token
-import Text.ParserCombinators.Parsec.Language
-
--- Given a linked Yhc Core and Core Annotations, obtain a seed for the Heap Map. 
-
-coreHeapSeed :: Core -> CoreAnnotations -> HeapMap
-
-coreHeapSeed core anno =
-  let prims = filter isCorePrim (coreFuncs core)
-      psigs = map (getRetType . getTSIG . getTypeSig anno) prims
-      pnames = map coreFuncName prims
-  in  M.unions $ zipWith (tsig2pt core) pnames psigs
-
--- Obtain possible values from a type signature. Types normally expected
--- to be returned from primitives or passed from the execution platform
--- to Haskell code are supported, that is:
---
---  * Integral types (Integer, Float, Char): represented as generalized values
---  * Algebraic types with zero-ary constructors: represented as union of GTags
---  * Algebraic types with one constructor of any arity (e. g. tuples): represented
---      as single GTagged values with arguments converted
---  * List types with some special arrangements to reflect recursive structure of
---      the type
---
---  The rest (like Maybe or Either) will only have GTany as possible values of arguments.
-
-tsig2pt :: Core -> GName -> TSIG -> HeapMap
-
-tsig2pt core gn (Terr _) = M.empty
-
-tsig2pt core gn (Tvar _) = M.singleton (HFunc gn) [HasValue $ GVal GTAny]
-
-tsig2pt core gn (Tcon "Int" []) = M.singleton (HFunc gn) [HasValue $ GVal GTInteger]
-tsig2pt core gn (Tcon "Integer" []) = M.singleton (HFunc gn) [HasValue $ GVal GTInteger]
-tsig2pt core gn (Tcon "Float" []) = M.singleton (HFunc gn) [HasValue $ GVal GTDouble]
-tsig2pt core gn (Tcon "Double" []) = M.singleton (HFunc gn) [HasValue $ GVal GTDouble]
-tsig2pt core gn (Tcon "Char" []) = M.singleton (HFunc gn) [HasValue $ GVal GTChar]
-tsig2pt core gn (Tcon "String" []) = tsig2pt core gn (Tcon "Prelude;[]" [Tcon "Char" []])
-
-tsig2pt core gn (Tcon con args) = 
-  let cd = case coreDataMaybe core con of
-        Just ccd -> ccd
-        Nothing -> CoreData {
-          coreDataName = con
-         ,coreDataTypes = []
-         ,coreDataCtors = [CoreCtor {
-           coreCtorName = con
-          ,coreCtorFields = replicate (length args) ("*", Nothing)}]}
-      islist = con == "Prelude;[]" && nargs == 1
-      ctors = coreDataCtors cd
-      nctors = length ctors
-      nargs = length args
-      ctarity = length . coreCtorFields
-      maxarity = maximum (map ctarity ctors)
-      nargv = nargs + if islist then 1 else 0
-      argns = map ((\s -> "n'" ++ con ++ "'" ++ gn ++ "'" ++ s) . show) (take nargv [1 .. ])
-      argmap argn argt = fixmap argn $ tsig2pt core argn argt
-      fixmap n m = case M.lookup (HFunc n) m of
-        Nothing -> m
-        Just v -> M.delete (HFunc n) m `M.union` M.singleton (HVar n) v
-      argmaps = zipWith argmap argns args
-      subctor ctor = let tag = mkTagName $ coreCtorName ctor in case ctarity ctor of
-        0 -> HasValue $ GTag tag
-        n -> HasValue (GTagged tag (take n (map GVar argns)))
-      anyctor ctor = let tag = mkTagName $ coreCtorName ctor in case ctarity ctor of
-        0 -> HasValue $ GTag tag
-        n -> HasValue (GTagged tag (replicate n GTAny))
-      funmap = M.singleton (HFunc gn) (map subctor ctors)
-      anymap = M.singleton (HFunc gn) (map anyctor ctors)
-      retmap = M.singleton (HVar (head $ reverse argns))
-                           [ReturnOf gn]
-  in  case (nctors, maxarity, islist) of
-        (_, 0, False) -> funmap
-        (1, _, False) -> M.unions (funmap : argmaps)
-        (_, _, True)  -> M.unions (funmap : retmap : argmaps)
-        (_, _, _)     -> anymap
-
-
--- Obtain a return type from type signature.
-
-getRetType :: TSIG -> TSIG
-
-getRetType (Tapp f a) = getRetType a
-
-getRetType z = z
-
--- Given a Core function and annotations (possibly combined from several sources),
--- retrieve function's type signature if available. If annotation is not available,
--- return an empty string.
-
-getTypeSig :: CoreAnnotations -> CoreFunc -> String
-
-getTypeSig anno cf =
-  case getAnnotation cf "Type" anno of
-    Just (CoreTypeSig s) -> s
-    _ -> ""
-
--- A simple parser for Haskell type expressions.
--- Parsing is done in accordance with the following productions (Haskell report, 4.1.2):
---
--- type   ->  btype [-> type]           (function type)
--- btype  ->  [btype] atype             (type application)
--- atype  ->  gtycon
---        |   tyvar
---        |   ( type1 , ... , typek ) 	(tuple type, k>=2)
---        |   [ type ]                  (list type)
---        |   ( type )                  (parenthesised constructor)
--- gtycon ->  qtycon
---        |   ()                        (unit type)
---        |   []                        (list constructor)
---        |   (->)                      (function constructor)
---        |   (,{,})                    (tupling constructors) 
---
--- Since this parser is intended to only parse type signatures of primitives,
--- many of real Haskell type system features are not implemented here.
---
--- Type constructors (tags) are expested to start with a capital letter and contain any
--- non-whitespace characters. Type variables are expected to start with a lowercase letter
--- and contain any non-whitespace characters. Function type constructors (->) are treated as
--- separators.
-
--- Tokenizer
-
-rsrvd = [",", "->", "(", ")", "[", "]"]
-
-idLetter x = not (isSpace x) && x `notElem` concat rsrvd
-
-tok = makeTokenParser emptyDef {
-  identStart = upper <|> lower
- ,identLetter = satisfy idLetter
- ,reservedNames = rsrvd
-}
-
--- Datatype for type signature.
-
-data TSIG = Tcon String [TSIG]
-          | Tvar String
-          | Tapp TSIG TSIG
-          | Terr String
-          deriving (Show)
-
--- Run the parser
-
-getTSIG :: String -> TSIG
-
-getTSIG s = case parse parseTSIG "" s of
-  Left err -> Terr (show err)
-  Right ts -> ts
-
-parseTSIG :: Parser TSIG
-
-parseTSIG = do
-  t <- oneTSIG
-  ts <- many (symbol tok "->" >> parseTSIG)
-  case ts of
-    [] -> return t
-    (ts:_) -> return $ Tapp t ts
-
-oneTSIG :: Parser TSIG
-
-oneTSIG = var <|> con <|> fun <|> tuple <|> list
-
-var = try $ do
-  v <- lower
-  ar <- many $ satisfy idLetter
-  skipMany space
-  return $ Tvar (v:ar)
-
-con = try $ do
-  t <- tag
-  args <- many oneTSIG
-  return $ Tcon t args
-
-tag = do
-  t <- upper
-  ag <- many $ satisfy idLetter
-  skipMany space
-  return (t:ag)
-
-fun = try $ do
-  symbol tok "("
-  t <- parseTSIG
-  symbol tok ")"
-  return t
-
-tuple = try $ do
-  symbol tok "("
-  ts <- sepBy oneTSIG (symbol tok ",")
-  symbol tok ")"
-  case ts of
-    []  -> return $ Tcon "Prelude;()" []
-    [t] -> return t
-    tts -> return $ Tcon ("Prelude;(" ++ replicate (length tts - 1) ',' ++ ")") tts
-
-list = try $ do
-  symbol tok "[" 
-  t <- oneTSIG
-  symbol tok "]"
-  return $ Tcon "[]" [t]
rmfile ./Yhc/Core/BackEnd/GRIN/HeapSeed.hs
hunk ./Yhc/Core/BackEnd/GRIN/OptApply.hs 1
--- GRIN-like backend for Yhc Core.
--- Apply inlining.
-
-module Yhc.Core.BackEnd.GRIN.OptApply where
-
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.FindType
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.SubstVars
-
-import Data.List
-import Data.Maybe
-import qualified Data.Set as S
-import qualified Data.Map as M
-
-
--- Inline applies.
-
-inlineApply :: HeapMap -> GRIN -> GRIN
-
-inlineApply hm gr = gr {gFuncs = map f (gFuncs gr)} where
-  f gf = gf {gFuncBody = filter (/= GNop) (ff (gFuncBody gf))}
-  ff [] = []
-  ff (GCase cv cbrs : bs) = 
-    let pats = map fst cbrs
-        blks = map snd cbrs
-        blks' = map ff blks
-        b' = GCase cv (zip pats blks')
-    in  b' : ff bs
-  ff (GBind (GInline ib) bv : bs) = 
-    let ib' = ff ib
-        b' = GBind (GInline ib') bv
-    in  b' : ff bs
-  ff (b@(GBind (GApply an av) bv) : bs) =
-    let upred (HasValue (GTagged ('P':'@':_) _)) = True
-        upred _ = False
-        van = runTA hm (Just upred) an
-        caseok (TUser, _) = True
-        caseok _ = False
-        b' = if any caseok van
-          then GBind (GInline (iApply hm an van av)) bv
-          else b
-    in  b' : ff bs
-  ff (b:bs) = b : ff bs
-
--- Create an inline code block based on the applied-to variable's type analysis.
-
-iApply :: HeapMap -> GName -> [TAResult] -> GVal -> GBlock
-
-iApply hm an van av = 
-  let ftvar = gVar (an ++ "'ft")
-      rtvar = gVar (an ++ "'rt")
-      ccvar = gVar (an ++ "'cc")
-      fetch = GBind (GFetch an "" (Just 0)) ftvar
-      ecase = GCase ftvar (sort $ nub $ zipWith pat van [1 .. ])
-      pat (TUser, HasValue (GTagged tag@('P':'@':missfun) gsvs)) np =
-        let (miss, _:fun) = break (== ':') missfun
-            rtvarp = gVar (an ++ "'rt'" ++ show np)
-            nflds = [1 .. length gsvs]
-            fldvars = map (\n -> an ++ "'fl'" ++ show n) nflds
-            flftchs = zipWith (\v n -> GBind (GFetch an tag (Just n)) v) xxargs nflds
-            xxargs = map gVar fldvars
-            mnarg = (read miss) :: Int
-            cot = case mnarg == 1 of
-              True -> GStore $ GTagged ("F@" ++ fun) (map val2sval (xxargs ++ [av]))
-              False -> GStore $ GTagged ("P@" ++ show (mnarg - 1) ++ ":" ++ fun) 
-                                        (map val2sval (xxargs ++ [av]))
-            ptag = GPatTag tag
-            cbr = flftchs ++ [GBind cot rtvarp, GSimple (GUnit rtvarp)]
-        in  (ptag, cbr)
-      pat (_, _) _ = defbr
-      defbr = (GPatDefault, [GSimple (GUnit $ gVar an)])
-  in  [fetch, ecase]
-
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/OptApply.hs
hunk ./Yhc/Core/BackEnd/GRIN/OptCases.hs 1
--- GRIN-like backend for Yhc Core.
--- Optimization of case expressions.
-
-module Yhc.Core.BackEnd.GRIN.OptCases where
-
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.FindType
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.SubstVars
-
-import Data.List
-import qualified Data.Set as S
-import qualified Data.Map as M
-
--- Optimize case expressions such as if there is only one pattern
--- then replace it with the only branch. Heap map is not needed.
--- Since case may be only last elment of a block, look at it,
--- and if there is a case with only one pattern, append the pattern's
--- block to the enclosing block, otherwise leave as is.
-
-optCases :: GRIN -> GRIN
-
-optCases gr = gr {gFuncs = map f (gFuncs gr)} where
-  f gf = gf {gFuncBody = filter (/= GNop) (ff (gFuncBody gf))}
-  ff [] = []
-  ff (GBind (GInline ib) bv : bs) = 
-    let ib' = (ff . gg) ib
-        b' = GBind (GInline ib') bv
-    in  b' : (ff . gg) bs
-  ff (GCase cv cbrs : bs) = 
-    let pats = map fst cbrs
-        blks = map snd cbrs
-        blks' = map (ff . gg) blks
-        b' = GCase cv (zip pats blks')
-    in  b' : ff bs
-  ff (b:bs) = b : (ff . gg) bs
-  gg [] = []
-  gg blk =
-    let e:b = reverse blk
-    in  case e of
-          GCase _ [cbr] -> reverse b ++ snd cbr
-          _ -> blk  
-
--- After inlining of function calls, some case statements may have their number
--- of branches reduced. Analyze each case for types/values their case variable
--- may have, and delete unneeded branches.
-
-fixCasesAfter :: HeapMap -> GRIN -> GRIN
-
-fixCasesAfter seed g = optCases (g {gFuncs = map f (gFuncs g)}) where
-  hm = inferAllCalls (heapPointsTo g `M.union` seed)
-  f gf = gf {gFuncBody = filter (/= GNop) (ff (gFuncBody gf))}
-  ff [] = []
-  ff (GBind (GInline ib) bv : bs) =
-    let ib' = ff ib
-        b' = GBind (GInline ib') bv
-    in  b' : ff bs
-  ff (GCase cv cbrs : bs) =
-    let ta = runTA hm Nothing (unGVar cv)
-        cbrs' = filter (patInTA ta) cbrs
-        cbrs'' = if null cbrs' then cbrs else cbrs'
-        pats = map fst cbrs''
-        blks' = map (ff . snd) cbrs''
-        b' = GCase cv (zip pats blks')
-    in  b' : ff bs
-  ff (b:bs) = b : ff bs
-  
-
--- Check a pattern against type analysis results. Return True if it is covered.
--- An obvious (and the most desirable) case: only one result from type analysis,
--- and this is a tagged value.
-
-patInTA :: [TAResult] -> (GPat, GBlock) -> Bool
-
-patInTA [(TSucc, HasValue (GTag tc))] (GPatTag tp, _) = tc == tp
-patInTA [(TSucc, HasValue (GTag tc))] _ = False
-
-patInTA [(TSucc, v)] (GPatDefault, _) = genVal v
-patInTA [(TSucc, v)] (GPatLit _, _) = genVal v
-patInTA [(TSucc, v)] (GPatTag ('F':'@':_), _) = not (genVal v)
-patInTA [(TSucc, v)] (GPatTag ('K':'@':_), _) = not (genVal v)
-
-patInTA _ _ = True
-
--- Distinguish generalized values form concrete values
-
-genVal (HasValue (GTag _)) = False
-genVal (HasValue (GTagged _ _)) = False
-genVal _ = True
-
rmfile ./Yhc/Core/BackEnd/GRIN/OptCases.hs
hunk ./Yhc/Core/BackEnd/GRIN/OptEvals.hs 1
--- GRIN-like backend for Yhc Core.
--- Eval inlining/elimination.
-
-module Yhc.Core.BackEnd.GRIN.OptEvals where
-
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.FindType
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.SubstVars
-import Yhc.Core.BackEnd.GRIN.OptApply
-import Yhc.Core.BackEnd.GRIN.Sharing
-
-import Data.List
-import Data.Maybe
-import qualified Data.Set as S
-import qualified Data.Map as M
-
-
--- Inline evals. An eval is replaced with an inline code block bound to the same
--- variable an original eval was bound. The inline block contains a `fetch 0' operation
--- to extract a tag, and a case pattern. Match on F@-tags and K@-tags result in function
--- calls; the default pattern is just to pass the value along. Also, update operations
--- will be inserted selectively, if a shared node is evaluated, and branch tag matches
--- one of root tags.
-
-inlineEvals :: HeapMap -> GRIN -> GRIN
-
-inlineEvals hm gr = gr {gFuncs = map f (gFuncs gr)} where
-  rsm = revSharingMap hm $ sharingMap hm gr
-  f gf = gf {gFuncBody = filter (/= GNop) (ff (gFuncBody gf))}
-  ff [] = []
-  ff (GCase cv cbrs : bs) = 
-    let pats = map fst cbrs
-        blks = map snd cbrs
-        blks' = map ff blks
-        b' = GCase cv (zip pats blks')
-    in  b' : ff bs
-  ff (GBind (GInline ib) bv : bs) = 
-    let ib' = ff ib
-        b' = GBind (GInline ib') bv
-    in  b' : ff bs
-  ff (b@(GBind (GEval en) bv) : bs) =
-    let upred (HasValue _) = True
-        upred (EvalOf _) = True
-        upred (ReturnOf _) = True
-        upred _ = False
-        btags = M.findWithDefault [] en rsm
-        ven = runTA hm (Just upred) en
-        caseok (TUser, _) = True
-        caseok _ = False
-        b' = if any caseok ven
-          then GBind (GInline (iEval en ven btags)) bv
-          else b
-    in  b' : ff bs
-  ff (b:bs) = b : ff bs
-
--- Create an inline code block based on the evaluated variable's type analysis.
-
-iEval :: GName -> [TAResult] -> [GVal] -> GBlock
-
-iEval en ven btags =
-  let ftvar = gVar (en ++ "'ft")
-      rtvar = gVar (en ++ "'rt")
-      fetch = GBind (GFetch en "" (Just 0)) ftvar
-      sametag (p1, _) (p2, _) = p1 == p2
-      ecase = GCase ftvar (sort $ nubBy sametag $ zipWith pat ven [1 .. ])
-      pat (TUser, HasValue (GTag t@('K':'@':caf))) np =
-        let rtvarp = gVar (en ++ "'rt'" ++ show np) 
-        in  (GPatTag t, [GBind (GCall caf []) rtvarp, GSimple (GUnit rtvarp)])
-      pat (TUser, HasValue (GTagged t@('F':'@':fun) gvs)) np =
-        let nargs = length gvs
-            rtvarp = gVar (en ++ "'rt'" ++ show np)
-            base = np * (length ven)
-            argvs = map (gVar . ((en ++ "'a") ++)) $ map show (take nargs [base .. ])
-            aftch = zipWith (\a b -> GBind (GFetch en t (Just a)) b) [1 .. ] argvs
-            update = if (GTag t) `elem` btags
-              then [GSimple (GUpdate en rtvarp)]
-              else []
-            fcall = [GBind (GCall fun argvs) rtvarp]
-            fret = [GSimple (GUnit rtvarp)]
-        in  (GPatTag t, concat [aftch, fcall, update, fret])
-      pat (_, _) _ = defbr
-      defbr = (GPatDefault, [GSimple (GUnit $ gVar en)])
-  in  [fetch, ecase]
-
-
--- Iteratively inline evals and apply's until number of TNoEntry's in the heap map
--- stabilizes. The first argument is a "seed" map containing information that cannot
--- be obtained from type analysis such as return types of primitives.
-
-iterInlineEA :: HeapMap -> GRIN -> GRIN
-
-iterInlineEA seed g =
-  let hm = inferAllCalls (heapPointsTo g `M.union` seed)
-      g' = (inlineApply hm . inlineEvals hm) g
-      noentry m = fromMaybe 0 $ M.lookup TNoEntry $ snd $ taStats m
-      hm' = inferAllCalls (heapPointsTo g' `M.union` seed)
-      old = noentry hm
-      new = noentry hm'
-  in  if new < old then iterInlineEA ((M.unionWith (++) hm' hm) `M.difference` hm) g else g'
-
-
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/OptEvals.hs
hunk ./Yhc/Core/BackEnd/GRIN/OptFetch.hs 1
--- Optimization of fetches: some fetched fields may be equivalent to local variables.
-
-module Yhc.Core.BackEnd.GRIN.OptFetch where
-
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.FindType
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.SubstVars
-import Yhc.Core.BackEnd.GRIN.ElimDead
-
-import Data.List
-import Data.Maybe
-import qualified Data.Set as S
-import qualified Data.Map as M
-
--- Walk over the function's code, starting with an empty equivalence map.
--- Make a list of seen variables.
--- If a call is encountered, run type analysis to see if actual atruments
--- are equivalent to one of the variables seen. If it is,
--- then add the equivalence to the map. Later, perform global substitution
--- over the whole program. Although this transformation does not analyze
--- fetches directly, it helps reduce their number. The first argument may
--- contain "seed" e. g. return types of primitive functions that cannot be 
--- obtained directly from the heap analysis
-
-optFetch :: HeapMap -> GRIN -> GRIN
-
-optFetch seed g = 
-  let hm = inferAllCalls (heapPointsTo g `M.union` seed)
-      eqm = eqMap hm g
-  in case M.null eqm of
-    True -> g
-    False -> optFetch seed (substGRIN eqm (elimAllDeadBindings g))
-
-eqMap hm gr =
-  let eqmap = M.unions (map eqm $ gFuncs gr)
-      eqm gf = ff M.empty (S.fromList $ gFuncArgs gf) (gFuncBody gf)
-      ff em vs [] = em
-      ff em vs (b:bs) = let (em', vs') = fff em vs b in ff em' vs' bs
-      fff em vs (GCase _ cbrs) = (M.unions $ map (ff em vs . snd) cbrs, vs)
-      fff em vs (GBind sx vb) = (em `M.union` ffff vs sx, (unGVar vb) `S.insert` vs)
-      fff em vs (GSimple sx) = (em `M.union` ffff vs sx, vs)
-      fff em vs _ = (em, vs)
-      upred (EquivTo _) = True
-      upred _ = False
-      uneqv (EquivTo s) = s
-      uneqv _ = ""
-      ta vs gn =
-        let gnta = map snd $ filter ((== TUser) . fst) $ runTA hm (Just upred) gn
-        in  case gnta of
-              [eqv] -> let u = uneqv eqv in case u `S.member` vs of
-                         True -> [(gn, u)]
-                         False -> []
-              _ -> []
-      ffff vs (GInline bl) = ff M.empty vs bl
-      ffff vs (GCall _ ps) = M.fromList $ concat $ map (ta vs . unGVar) ps
-      ffff vs (GStore (GTagged _ fs)) = M.fromList $ concat $ map (ta vs . unVar) fs
-      ffff _ _ = M.empty
-  in  M.filterWithKey (/=) eqmap
-
rmfile ./Yhc/Core/BackEnd/GRIN/OptFetch.hs
hunk ./Yhc/Core/BackEnd/GRIN/Sharing.hs 1
--- GRIN-like backend for Yhc Core
--- Sharing analysis
-
-module Yhc.Core.BackEnd.GRIN.Sharing where
-
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.FindType
-import Yhc.Core.BackEnd.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]
-
--- Build a sharing map. Given a heap map, the function produces a map of
--- of node names to list of names where the key is a reducible expression's root name,
--- and the value is one(s) that point to it. If an expression is pointed to
--- by more than one variable, it is shared.
-
-sharingMap :: HeapMap -> GRIN -> SharingMap
-
-sharingMap hm g =
-  let evals = nub $ concat $ map evalonly $ concat $
-              M.elems $ M.filter (any (not . null . evalonly)) hm
-      evalonly (EvalOf s) = [s]
-      evalonly _ = []
-      thunkonly (HasValue (GTagged ('F':'@':_) _)) = True
-      thunkonly _ = False
-      unhvar (HVar s) = [s]
-      unhvar _ = []
-      unequiv (TUser, EquivTo v) = [v]
-      unequiv _ = []
-      xtas = runTAM hm Nothing evals
-      apthunks = map fst $ filter (any (thunkonly . snd) . snd) xtas
-      thunks = concat $ map unhvar $ M.keys $ M.filter (any thunkonly) hm
-      thunkset = S.fromList (thunks ++ apthunks)
-      upred (EquivTo s) = s `S.member` thunkset
-      upred _ = False
-      eqmap = concat $ map (\(a, b) -> zip (repeat a) (concat $ map unequiv b)) $ 
-                 filter (any ((==TUser) . fst) . snd) $ runTAM hm (Just upred) evals
-      mkmap m [] = m
-      mkmap m ((v, k):kvs) = M.insertWith (++) k [v] (mkmap m kvs)
-  in  M.filter ((>1) . length) $ mkmap M.empty eqmap
-
--- Given a sharing map, produce a reverse sharing map, that is, every updateable
--- node maps to its roots' type tags. Keys in the reverse sharing map are
--- renamed to match nodes in the renamed GRIN.
-
-revSharingMap :: HeapMap -> SharingMap -> RevShrMap
-
-revSharingMap hm sm = M.foldWithKey rsm M.empty sm where
-  rsm r vs m =
-    let nvs = map n2s vs
-        rts = head $ map unhv $ M.findWithDefault [HasValue GEmpty] (HVar r) hm
-        unhv (HasValue (GTag t)) = GTag t
-        unhv (HasValue (GTagged t _)) = GTag t
-        unhv z = GEmpty
-        pairs = zip nvs (repeat rts)
-        mkmap mm [] = mm
-        mkmap mm ((k, v):kvs) = M.insertWith (++) k [v] (mkmap m kvs)
-    in  M.map nub $ mkmap m pairs
-
-
-
--- 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
-
rmfile ./Yhc/Core/BackEnd/GRIN/Sharing.hs
hunk ./Yhc/Core/BackEnd/GRIN/SubstVars.hs 1
--- GRIN-like backend for Yhc Core.
--- Global variable name substitutions.
-
-module Yhc.Core.BackEnd.GRIN.SubstVars where
-
-import Yhc.Core.BackEnd.GRIN.Type
-
-import Data.List
-import qualified Data.Set as S
-import qualified Data.Map as M
-
--- Naming conventions: regular nodes start with 'n', shared nodes start with 's',
--- data constructor tags start with 'C@', thunk tags start with 'F@', partial
--- application tags start with 'P@'.
-
-mkTagName s = 'C':'@':s
-
-isRegNode ('n':_) = True
-isRegNode _ = False
-
-isShrNode ('s':_) = True
-isShrNode _ = False
-
-isNode x = isRegNode x || isShrNode x
-
-isCtorTag ('C':'@':_) = True
-isCtorTag _ = False
-
-isThunkTag ('F':'@':_) = True
-isThunkTag _ = False
-
-isPapTag ('P':'@':_) = True
-isPapTag _ = False
-
-
--- Operations over variable names
-
-gVar = GVal . GVar
-
-unGVar (GVal (GVar v)) = v
-unGVar z = "#"
-
-unVar (GVar v) = v
-unVar _ = "%"
-
-val2sval (GVal s) = s
-val2sval z = error $ "not a sval: " ++ show z
-
-
--- Substitute variable(s). Given a map of substitution,
--- if a variable occurs in a simple expression, replace it.
-
-substGRIN :: M.Map GName GName -> GRIN -> GRIN
-
-substGRIN sm (g@GRIN {gFuncs = gfs}) = g {gFuncs = map (substFunc sm) gfs}
-
-substFunc :: M.Map GName GName -> GFunc -> GFunc
-
-substFunc sm (gf@GFunc {gFuncArgs = as, gFuncBody = gb}) = 
-  gf {gFuncArgs = map (substGN sm) as, gFuncBody = map (substGX sm) gb}
-
-substGX :: M.Map GName GName -> GExpr -> GExpr
-
-substGX sm (GBind sx bv) = GBind (substSX sm sx) (substGV sm bv)
-substGX sm (GSimple sx) = GSimple (substSX sm sx)
-substGX sm (GCase cv cbrs) = 
-  let pats = map fst cbrs
-      blks = map snd cbrs
-      pats' = map (substPT sm) pats
-      blks' = map (map (substGX sm)) blks
-  in  GCase (substGV sm cv) (zip pats' blks') 
-                                              
-substGX sm gx = gx
-
-substPT :: M.Map GName GName -> GPat -> GPat
-
-substPT sm (GPatTag gn) = GPatTag (substGN sm gn)
-substPT sm pt = pt
-
-substSX :: M.Map GName GName -> GSexpr -> GSexpr
-
-substSX sm (GUnit gv) = GUnit (substGV sm gv)
-substSX sm (GCall gn gvs) = GCall (substGN sm gn) (map (substGV sm) gvs)
-substSX sm (GStore gv) = GStore (substGV sm gv)
-substSX sm (GEval gn) = GEval (substGN sm gn)
-substSX sm (GApply gn gv) = GApply (substGN sm gn) (substGV sm gv)
-substSX sm (GFetch gn tag mbi) = GFetch (substGN sm gn) (substGN sm tag) mbi
-substSX sm (GUpdate gn gv) = GUpdate (substGN sm gn) (substGV sm gv)
-substSX sm (GInline bl) = GInline (map (substGX sm) bl)
-
-substGV :: M.Map GName GName -> GVal -> GVal
-
-substGV sm (GTagged gn svs) = GTagged (substGN sm gn) (map (substSV sm) svs)
-substGV sm (GTag gn) = GTag (substGN sm gn)
-substGV sm (GVal sv) = GVal (substSV sm sv)
-substGV sm gv = gv
-
-substSV :: M.Map GName GName -> GSval -> GSval
-substSV sm (GVar gn) = GVar (substGN sm gn)
-substSV sm sv = sv
-
-substGN :: M.Map GName GName -> GName -> GName
-
-substGN sm gn = M.findWithDefault gn gn sm
-
--- A helper function to find out which variables are used by a simple expression.
-
-useVars :: GSexpr -> S.Set GName
-
-useVars (GUnit gv) = case gv of
-  (GVal (GVar _)) -> S.singleton (unGVar gv)
-  (GTagged gn gvs) -> S.fromList $ map unVar gvs
-  _               -> S.empty
-useVars (GCall gn gvs) = S.fromList (gn : map unGVar gvs)
-useVars (GStore gv) = case gv of
-  (GVal (GVar _)) -> S.singleton (unGVar gv)
-  (GTagged gn gvs) -> S.fromList (gn : map unVar gvs)
-  (GTag gn) -> S.singleton gn
-  _               -> S.empty
-useVars (GEval gn) = S.singleton gn
-useVars (GApply gn gv) = S.fromList [gn, unGVar gv]
-useVars (GFetch gn _ _) = S.singleton gn
-useVars (GUpdate gn gv) = S.fromList [gn, unGVar gv]
-useVars (GInline bl) = useVarBlk S.empty bl
-
--- A helper function to find out which variables are used by a block.
-
-varUseBlock :: GBlock -> S.Set GName
-
-varUseBlock bl = useVarBlk S.empty bl
-
-useVarBlk uv [] = uv
-useVarBlk uv (b:bs) = case b of
-  GCase cv cbrs ->
-    let uv' = S.unions (S.singleton (unGVar cv) : map (useVarBlk S.empty . snd) cbrs)
-    in  useVarBlk (uv `S.union` uv') bs
-  GSimple sx -> useVarBlk (uv `S.union` useVars sx) bs
-  GBind sx bv ->
-    let uv' = S.unions [uv, S.singleton (unGVar bv), useVars sx]
-    in  useVarBlk uv' bs
-
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/SubstVars.hs
hunk ./Yhc/Core/BackEnd/GRIN/TransCore.hs 1
--- GRIN-like backend for Yhc Core.
--- Translation from Yhc Core to GRIN.
-
-module Yhc.Core.BackEnd.GRIN.TransCore  where
-
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.GGMonad
-import Yhc.Core.BackEnd.GRIN.SubstVars
-import Yhc.Core.BackEnd.GRIN.HeapSeed
-import Yhc.Core.BackEnd.GRIN.Validation
-import Yhc.Core.Extra
-import Data.Maybe
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-import Debug.Trace
-
--- An older, all-at-once conversion algorithm: used when roots are not available.
-
-c2g core canno = 
-  let env = GG {stateCnt = 1
-               ,currFun = CoreFunc {coreFuncName = ""
-                                   ,coreFuncArgs = []
-                                   ,coreFuncBody = CoreLit (CoreInt 0)}
-               ,funStack = []
-               ,coreRef = core
-               ,varMap = M.empty
-               ,funMap = toCoreFuncMap core
-               ,liftSet = S.empty
-               ,autoFuncs = []
-               ,coreAnno = canno}
-  in  flip evalState env $ do
-        core <- gets coreRef
-        gfuncs <- mapM cf2gf (coreFuncs core)
-        auto <- gets autoFuncs
-        return $ GRIN (concat gfuncs ++ auto)
-
--- |Translate a linked Yhc Core to GRIN incrementally. Start with roots specified,
--- validate the GRIN obtained. If there are missing functions (missReturns in validation
--- results), translate these functions. Repeat until missReturns is empty.
-
-core2GRIN :: [CoreFuncName] -> Core -> CoreAnnotations -> (GRIN, GValid)
-
-core2GRIN [] c a = 
-  let g = c2g c a 
-      s = coreHeapSeed c a
-      v = validateGRIN s g
-  in (g, v)
-  
-core2GRIN roots core canno =      
-  let env = GG {stateCnt = 1
-               ,currFun = CoreFunc {coreFuncName = ""
-                                   ,coreFuncArgs = []
-                                   ,coreFuncBody = CoreLit (CoreInt 0)}
-               ,funStack = []
-               ,coreRef = core
-               ,varMap = M.empty
-               ,funMap = toCoreFuncMap core
-               ,liftSet = S.empty
-               ,autoFuncs = []
-               ,coreAnno = canno}
-      seed = coreHeapSeed core canno
-      c2ii gprev rgns = do
-        cmap <- gets funMap
-        let cfuns = M.elems $ M.filter (flip elem (trace (show rgns) rgns) . coreFuncName) cmap
-        gfuns <- mapM cf2gf cfuns >>= return . concat
-        auto <- gets autoFuncs
-        let newfuns = gprev ++ gfuns
-            grin = GRIN (newfuns ++ auto)
-            val = validateGRIN seed grin
-        case val of
-              GValid -> return (grin, val)
-              GInvalid {missReturns = mgns} -> 
-                if mgns /= rgns then c2ii newfuns mgns
-                                else return (grin, val)
-  in  flip evalState env $ c2ii [] roots 
-         
-
--- Translate a single function.
-
-cf2gf :: CoreFunc -> GGM [GFunc]
-
-cf2gf cf@CoreFunc {} = do
-  core <- gets coreRef
-  st <- get
-  pushFun (trace ("cf2gf: " ++ coreFuncName cf) cf)
-  args <- mapM mapVarName (coreFuncArgs cf)
-  gb <- schR (coreFuncBody cf)
-  let gf = [GFunc {
-      gFuncName = coreFuncName cf
-     ,gFuncArgs = args
-     ,gFuncBody = gb}]
-  popFun
-  return gf
-
-cf2gf _ = return []
-
--- Translate a function body into a block of bindings.
-
--- Three "schemes" as described in the paper.
-
--- The "R" scheme to translate whe whole function body.
--- Translates the top-level expression, binds it to a variable
--- and finishes with return of that variable evaluated.
-
-schR :: CoreExpr -> GGM GBlock
-
-schR (CoreLet lts ex) = do
-  ltexs <- mapM oneLet lts
-  r <- schR ex
-  return $ concat ltexs ++ r
-
-schR (CoreCase e cpxs) = do
-  (ev, ex) <- schE e
-  pats <- mapM (schP (unGVar ev)) cpxs
-  return $ ex ++ [GCase ev pats]
-
-schR ex = do
-  (rv, exc) <- schE ex
-  let excr = reverse exc
-  case head excr of
-    GBind (GUnit r) _ -> return $ reverse (GSimple (GUnit r) : tail excr)
-    _                 -> return $ exc ++ [GSimple (GUnit rv)]
-
--- The "C" scheme to translate an expression.
--- Returns a pair of the variable where result is bound,
--- and the block of bindings.
-
-schC :: CoreExpr -> GGM (GVal, GBlock)
-
-schC (CoreCase e cpxs) = do
-  nv <- newGVar
-  (ev, ex) <- schE e
-  pats <- mapM (schP (unGVar ev)) cpxs
-  let gbnd = GBind (GInline [GCase ev pats]) nv
-  return (nv, ex ++ [gbnd])
-
-
--- Special case: fetch a numbered element (n) from a node (v)
--- n is expected to be a constant and is not evaluated.
-
-schC (CoreApp (CoreFun "SEL_ELEM") [t, v, (CoreLit (CoreInt n))]) =
-  schC (CoreApp (CoreFun "SEL_ELEM") [t, v, (CoreLit (CoreInteger $ fromIntegral n))])
-
-schC (CoreApp (CoreFun "SEL_ELEM") [_, v, (CoreLit (CoreInteger n))]) = do
-  (GVal (GVar fv), fblk) <- schE v
-  nv <- newGVar
-  let fbnd = GBind (GFetch fv "" (Just $ fromIntegral n)) nv
-  return (nv, fblk ++ [fbnd])
-
--- Special case: strict application. Evaluate the argument first, then
--- apply the function to it.
-
--- General application.
-
-schC ap@(CoreApp ex args) = do
-  ai <- getAppInfo ap
-  nv <- newGVar
-  xargs <- mapM schC args
-  let blks = concat $ map snd xargs
-      apply f x = GApply (unGVar f) x
-  case (appType ai, appSat ai) of
-    (AppPrim, EQ) -> do                           -- saturated application of a primitive
-      plift <- mkLift ai                          -- autocreate a lifting function
-      let ftag = GTagged ("F@" ++ plift) (map (val2sval . fst) xargs)
-          gbnd = GBind (GStore ftag) nv
-      return (nv, blks ++ [gbnd])
-    (AppFunc, EQ) -> do                           -- saturated application of a function
-      let (CoreFun f) = appOf ai
-          ftag = case length args of
-            0 -> GTag ("K@" ++ f)
-            _ -> GTagged ("F@" ++ f) (map (val2sval . fst) xargs)
-          gbnd = GBind (GStore ftag) nv
-      return (nv, blks ++ [gbnd])
-    (aptype, LT) | aptype `elem` [AppCon, AppPrim] -> do -- partial application of a ctor/primitive
-      plift <- mkLift ai                          -- autocreate a lifting function
-      let missarg = appArity ai - appNargs ai
-          ftag = GTagged ("P@" ++ show missarg ++ ":" ++ plift) (map (val2sval . fst) xargs)
-          gbnd = GBind (GStore ftag) nv
-      return (nv, blks ++ [gbnd])
-    (AppFunc, LT) -> do                           -- partial application of a function
-      let (CoreFun f) = appOf ai
-          missarg = appArity ai - appNargs ai
-          ftag = GTagged ("P@" ++ show missarg ++ ":" ++ f) (map (val2sval . fst) xargs)
-          gbnd = GBind (GStore ftag) nv
-      return (nv, blks ++ [gbnd])
-    (aptype, GT) | aptype `elem` [AppFunc, AppPrim] -> do -- oversaturated application, known function
-      let (fargs, extra) = splitAt (appArity ai) args
-      schC (CoreApp (CoreApp (appOf ai) fargs) extra)
-    (AppUnk, GT) -> do                            -- oversaturated application, unknown function
-      (av, blk) <- schC (appOf ai)
-      bvs <- replicateM (length xargs) newGVar
-      chain <- mkChain apply (av : map fst xargs) (tail bvs ++ [nv]) []
-      return (nv, blk ++ blks ++ chain)
-    (AppUnk, EQ) -> schC (appOf ai)               -- unnecessarily nested
-    (AppCon, EQ) -> do                            -- saturated application of a constructor
-      let (CoreCon c) = appOf ai
-          ctag = GTagged (mkTagName c) (map (val2sval . fst) xargs)
-          gbnd = GBind (GStore ctag) nv
-      return (nv, blks ++ [gbnd])
-    (x, y) -> return (gVar "_", [GError $ "schC ap " ++ show x ++ " " ++ show y ++ " " ++ showRaw ap])
-
-
--- Function encodes as a partial application unless it is a CAF itself;
--- in the latter case it is stored as a special tag.
-
-schC (CoreFun f) = do
-  cmap <- gets funMap
-  let mbcf = coreFuncMapMaybe cmap f
-  case mbcf of
-    Nothing -> return (gVar "_", [GError $ "undefined function " ++ f])
-    Just cf | coreFuncArity cf > 0 ->               -- partial application
-      schC (CoreApp (CoreFun f) [])
-    _ -> do                                         -- CAF
-      nv <- newVar >>= return . gVar
-      let ktag = GTag ("K@" ++ f)
-      return (nv, [GBind (GStore ktag) nv])
-
-
--- Single constructor encodes as its tag alone
-
-schC (CoreCon c) = do
-  let ftag = GTag (mkTagName c)
-  nv <- newVar >>= return . gVar
-  return (nv, [GBind (GStore ftag) nv])
-
-schC (CoreLit (CoreInteger i)) = do
-  let lit = GLitVal (GInt i)
-      ntag = GVal lit
-  nv <- newVar >>= return . gVar
-  let gbnd = GBind (GStore ntag) nv
-  return (nv, [gbnd])
-
-schC (CoreLit (CoreInt i)) = schC (CoreLit (CoreInteger $ fromIntegral i))
-
-schC (CoreLit (CoreDouble d)) = do
-  let lit = GLitVal (GFloat d)
-      ntag = GVal lit
-  nv <- newVar >>= return . gVar
-  let gbnd = GBind (GStore ntag) nv
-  return (nv, [gbnd])
-  
-schC (CoreLit (CoreFloat f)) = schC (CoreLit (CoreDouble $ realToFrac f))
-
-schC l@(CoreLit (CoreChr c)) = do
-  let lit = lit2lit l
-      ntag = GVal lit
-  nv <- newVar >>= return . gVar
-  let gbnd = GBind (GStore ntag) nv
-  return (nv, [gbnd])
-
-schC l@(CoreLit (CoreStr s)) = do
-  let lit = lit2lit l
-      ntag = GVal lit
-  nv <- newVar >>= return . gVar
-  let gbnd = GBind (GStore ntag) nv
-  return (nv, [gbnd])
-
-schC (CoreVar v) = do
-  nv <- mapVarName v >>= return . gVar
-  return (nv, [])
-  
-
-schC z = return (gVar "_", [GError $ show z])
-
--- The "E" scheme to translate expressions in strict context.
-
-schE :: CoreExpr -> GGM (GVal, GBlock)
-
-schE (CoreCase e cpxs) = schC (CoreCase e cpxs)
-
--- Special case of the SEL_ELEM primitive: same as schC
-
-schE ap@(CoreApp (CoreFun "SEL_ELEM") _) = schC ap
-
--- General application of a function. If saturated, evaluate all arguments,
--- and call the function.
-
-schE ap@(CoreApp ex args) = do
-  ai <- getAppInfo ap
-  nv <- newGVar
-  let argeval = case (appType ai, appSat ai) of
-        (AppPrim, EQ) -> schE                    -- saturated app of primitive: evaluate args
-        (_, _) -> schC                           -- just store them in other cases
-  xargs <- mapM argeval args
-  let blks = concat $ map snd xargs
-      apply f x = GApply (unGVar f) x
-  case (appType ai, appSat ai) of
-    (aptype, EQ) | aptype `elem` [AppFunc, AppPrim] -> do -- saturated application of a function
-      let (CoreFun f) = appOf ai                          -- or a primitive
-      case f of
-        "STRICT_APP" -> do                        -- special primitive to apply argument strictly
-          let [a1, a2] = map fst xargs
-              gbnd = GBind (apply a1 a2) nv
-          env <- newGVar
-          let ebnd = GBind (GEval $ unGVar nv) env
-          return (env, blks ++ [gbnd, ebnd])
-        _ -> do
-          let gbnd = GBind (GCall f (map fst xargs)) nv
-          return (nv, blks ++ [gbnd])
-    (aptype, LT) | aptype `elem` [AppCon, AppPrim] -> 
-      schC ap                                     -- partial application of a ctor/primitive
-    (AppFunc, LT) -> do                           -- partial application of a function
-      let (CoreFun f) = appOf ai
-          missarg = appArity ai - appNargs ai
-          ftag = GTagged ("P@" ++ show missarg ++ ":" ++ f) (map (val2sval . fst) xargs)
-          gbnd = GBind (GUnit ftag) nv
-      return (nv, blks ++ [gbnd])
-    (aptype, GT) | aptype `elem` [AppFunc, AppPrim] -> do -- oversaturated application, known function
-      let (fargs, extra) = splitAt (appArity ai) args
-      schE (CoreApp (CoreApp (appOf ai) fargs) extra)
-    (AppUnk, GT) -> do                            -- oversaturated application, unknown function
-      (av, blk) <- schE (appOf ai)
-      bvs <- replicateM (length xargs) newGVar
-      chain <- mkChain apply (av : map fst xargs) (tail bvs ++ [nv]) []
-      env <- newGVar
-      let ebnd = GBind (GEval $ unGVar nv) env
-      return (env, blk ++ blks ++ chain ++ [ebnd])
-    (AppUnk, EQ) -> schE (appOf ai)               -- unnecessarily nested
-    (AppCon, EQ) -> do                            -- saturated application of a constructor
-      let (CoreCon c) = appOf ai
-          ctag = GTagged (mkTagName c) (map (val2sval . fst) xargs)
-          gbnd = GBind (GUnit ctag) nv
-      return (nv, blks ++ [gbnd])
-    (x, y) -> return (gVar "_", [GError $ "schC ap " ++ show x ++ " " ++ show y ++ " " ++ showRaw ap])
-
-schE (CoreCon c) = do
-  let ftag = GTag (mkTagName c)
-  nv <- newGVar
-  return (nv, [GBind (GUnit ftag) nv])
-
-schE ex = do
-  (v, b) <- schC ex
-  case v of
-    GVal (GVar ev) -> do
-      evprim <- newGVar
-      let ebnd = GBind (GEval ev) evprim
-      return (evprim, b ++ [ebnd])
-    _ -> return (v, b)
-
--- The "P" scheme to translate case patterns.
-
-schP :: GName -> (CorePat, CoreExpr) -> GGM (GPat, GBlock)
-
-schP _ (PatDefault, ex) = do
-  cex <- schR ex
-  return (GPatDefault, cex)
-
-schP _ (PatLit l, ex) = do
-  let (GLitVal p) = lit2lit (CoreLit l)
-  cex <- schR ex
-  return (GPatLit p, cex)
-
-schP cv (PatCon con args, ex) = do
-  flds <- mapM mapVarName args
-  cex <- schR ex
-  let tag = mkTagName con
-      ftchs = zipWith3 (\a b c -> GBind (GFetch a tag (Just b)) c) 
-                       (repeat cv) [1 .. ] 
-                       (map gVar flds)
-      p = GPatTag tag
-  return (p, ftchs ++ cex)
-
--- Create a lifting function for partially applied primitive or a constructor.
--- A lifting function can be applied partially while a primitive or a constructor
--- cannot. For a primitive, all its arguments will be evaluated once the function
--- is called. Name of the new function will be returned. The function is added to the
--- autocreated functions list.
-
-mkLift :: AppInfo -> GGM GName
-
-mkLift ai' = do
-  let ai | (appType ai') `notElem` [AppPrim, AppCon] = error "mkLift: need a ctor or prim app"
-         | appSat ai' == GT = error "mkLift: need a partial or saturated app"
-         | otherwise = ai'
-      fname = case appOf ai of
-        CoreFun f -> f
-        CoreCon c -> c
-  lset <- gets liftSet
-  cnt <- getCnt
-  let lname = "l@" ++ fname ++ show cnt
-  if lname `S.member` lset
-    then return lname
-    else do
-      let lset' = S.insert lname lset
-      st0 <- get
-      put (st0 {liftSet = lset'})
-      let fargs = take (appArity ai) (map (('_':) . show) [1 .. ])
-          lift = CoreFunc {
-             coreFuncName = lname
-            ,coreFuncArgs = fargs
-            ,coreFuncBody = CoreApp (appOf ai) (map CoreVar fargs)}
-      gfun <- cf2gf lift
-      st <- get
-      put (st {autoFuncs = autoFuncs st ++ gfun})
-      return lname
-
--- Gather information about an application of a known function,
--- unknown function, or a constructor. Crashes if a function
--- or a primitive is not defined.
-
-getAppInfo :: CoreExpr -> GGM AppInfo
-
-getAppInfo (CoreApp ex args) = do
-  core <- gets coreRef
-  cmap <- gets funMap
-  let (atype, arity) = case ex of
-        CoreFun f -> case fromJust (coreFuncMapMaybe cmap f) of
-          cf@CoreFunc {} -> (AppFunc, coreFuncArity cf)
-          cp@CorePrim {} -> (AppPrim, coreFuncArity cp)
-        CoreCon c -> let ct = coreCtor core c
-                     in  (AppCon, length $ coreCtorFields ct)
-        _ -> (AppUnk, 0)
-      nargs = length args
-  return $ AppInfo {
-    appSat = compare nargs arity 
-   ,appType = atype
-   ,appOf = ex
-   ,appArity = arity
-   ,appNargs = nargs
-   ,appArgs = args}
-
-getAppInfo z = error $ "getAppInfo: not an application: " ++ show z
-
--- Short-hand functions
-
-oneLet (v, e) = do
-  (lv, ex) <- schC e
-  nv <- mapVarName v >>= return . gVar
-  let bnd = GBind (GUnit lv) nv
-  return $ ex ++ [bnd]
-
-lit2lit :: CoreExpr -> GSval
-
-lit2lit (CoreLit (CoreInteger i)) = GLitVal (GInt i)
-lit2lit (CoreLit (CoreInt i)) = GLitVal (GInt $ fromIntegral i)
-lit2lit (CoreLit (CoreChr c)) = GLitVal (GChar c)
-lit2lit (CoreLit (CoreStr s)) = GLitVal (GString s)
-lit2lit (CoreLit (CoreDouble d)) = GLitVal (GFloat d)
-lit2lit (CoreLit (CoreFloat d)) = GLitVal (GFloat $ realToFrac d)
-
--- Make a chain of F-nodes or apply calls for oversaturated applications.
-
-mkChain :: (GVal -> GVal -> GSexpr) -> [GVal] -> [GVal] -> [GExpr] -> GGM [GExpr]
-
-mkChain f [e] [] exs = return exs
-
-mkChain f (e:e':es) (b:bs) exs = do
-  bb <- newGVar
-  mkChain f (b:es) bs (exs ++ [GBind (GEval $ unGVar e) bb, GBind (f bb e') b])
-
--- Create a new variable name by using a unique numbers generator.
-
-newVar = do
-  c <- getCnt
-  return $ "n" ++ show c
-
-newGVar = newVar >>= return . gVar
-
--- Obtain or add a variable name mapping.
-
-mapVarName vn = do
-  mp <- gets varMap
-  cf <- gets currFun >>= return . coreFuncName
-  case M.lookup (cf, vn) mp of
-    Just mn -> return mn
-    Nothing -> do
-      nv <- newVar
-      let mp' = M.insert (cf, vn) nv mp
-      st <- get
-      put st {varMap = mp'}
-      return nv
-      
-   
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/TransCore.hs
hunk ./Yhc/Core/BackEnd/GRIN/Type.hs 1
--- GRIN-like backend for Yhc Core.
--- GRIN internal representation based loosely on the
--- PhD Thesis by Urban Boquist, http://www.cs.chalmers.se/~boquist/phd/phd.ps
-
-module Yhc.Core.BackEnd.GRIN.Type where
-
-import Yhc.Core.Type
-import Yhc.Core.Show
-
--- Toplevel constructor for the whole program.
-
-data GRIN = GRIN {
-  gFuncs :: [GFunc]} deriving (Show)
-
-type GName = String
-
--- A single function is defined with its name, arguments, and body.
-
-data GFunc = GFunc {
-  gFuncName :: GName
- ,gFuncArgs :: [GName]
- ,gFuncBody :: GBlock} deriving (Show)
-
--- A block of GRIN expressions (sequence) is a list. Case statements
--- have a block for each pattern.
-
-type GBlock = [GExpr]
-
--- An expression has several variants shown below. Sequencing of
--- expressions is their order in the list.
-
-data GExpr =
-     GBind GSexpr GVal            -- simple expression whose result is bound to a name
-   | GCase GVal [(GPat, GBlock)]  -- case with multiple patterns
-   | GSimple GSexpr               -- (usually) final operation in a block
-   | GError String                -- only to be used to signal internal error
-   | GNop                         -- used to indicate an element to be further removed.
-   deriving (Ord, Eq, Show)
-
--- Simple expressions (primitive operations). GEval is an abstraction which
--- may or may not disappear depending on the concrete backend.
-
-data GSexpr =
-     GUnit GVal                     -- return a value
-   | GCall GName [GVal]             -- function/primitive call
-   | GStore GVal                    -- store a value
-   | GEval GName                    -- evaluate a previously stored value
-   | GApply GName GVal              -- apply a value to a partial application
-   | GFetch GName GName (Maybe Int) -- load a whole value or a numbered field of it (2nd GName
-                                    -- annotates the tag from which fetch is done)
-   | GUpdate GName GVal             -- overwrite a heap node (usually, a result of evaluation)
-   | GInline GBlock                 -- inlined code
-   deriving (Ord, Eq, Show)
-
--- Values.
-
-data GVal =
-     GTagged GName [GSval]        -- tagged value (constructor application)
-   | GTag GName                   -- a tag itself
-   | GEmpty                       -- an empty value, ()
-   | GVal GSval                   -- a simple value
-   deriving (Ord, Eq, Show)
-
--- Simple values, also covers types returned by some primitives
-
-data GSval =
-     GVar GName                   -- a named variable
-   | GLitVal GLit                 -- a literal value
-   | GTInteger                    -- any Integer
-   | GTChar                       -- any Char
-   | GTDouble                     -- any Double
-   | GTAny                        -- anything (undesirable, but can appear in heap seeds)
-   deriving (Ord, Eq, Show)
-
--- Literals
-
-data GLit =
-     GChar Char                   -- character literal
-   | GInt  Integer                -- integer literal
-   | GFloat Double                -- floating point literal
-   | GString String               -- string literal
-   deriving (Eq, Ord, Show)
-
--- Case patterns.
-
-data GPat =
-     GPatTag GName                -- match on tag alone
-   | GPatLit GLit                 -- match on a literal
-   | GPatDefault                  -- when none matches
-   deriving (Eq, Show)
-
--- Order patterns so that default pattern always goes last.
-
-instance Ord GPat where
-  compare GPatDefault GPatDefault = EQ
-  compare GPatDefault _ = GT
-  compare _ GPatDefault = LT
-  compare (GPatLit _) (GPatTag _) = GT
-  compare (GPatTag _) (GPatLit _) = LT
-  compare (GPatTag a) (GPatTag b) = compare a b
-  compare (GPatLit a) (GPatLit b) = compare a b
-
--- Internal types used to gather information about function applications.
-
-data AppType = AppFunc | AppPrim | AppCon | AppUnk deriving (Eq, Show)
-
-data AppInfo = AppInfo {
-   appSat :: Ordering             -- LT for under-, EQ for saturated, GT for over-
-  ,appType :: AppType             -- application of what
-  ,appOf :: CoreExpr              -- first argument of CoreApp
-  ,appArity :: Int                -- arity of a function or constructor; 1 for unknown
-  ,appNargs :: Int                -- number of arguments in the application
-  ,appArgs :: [CoreExpr]          -- arguments as Core expressions
-} deriving (Show)
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/Type.hs
hunk ./Yhc/Core/BackEnd/GRIN/Validation.hs 1
--- GRIN-like backend for Yhc Core
--- Validation framework.
-
-module Yhc.Core.BackEnd.GRIN.Validation where
-
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo
-import Yhc.Core.BackEnd.GRIN.FindType
-import Yhc.Core.BackEnd.GRIN.Type
-import Yhc.Core.BackEnd.GRIN.SubstVars
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.Either
-import Data.Maybe
-import Data.List
-
-
-import Debug.Trace
-
--- Validate generated GRIN. Validity criteria are:
---  * There should be no variables with TNoEntry result
---    of type analysis. These will be reported separately:
---    ReturnOf, and ArgOf. The rest are derivative of these two.
--- Normally, there should be no missing calls after dead code elimination.
--- However if a functionwas in the list of roots and was not removed,
--- it may be in the list of missing calls.
-
-data GValid =
-     GValid                                -- GRIN is OK
-   | GInvalid {missCalls :: [GName]        -- report missing calls and returns
-             ,missReturns :: [GName]}
-  deriving (Show)
-
--- The first argument is a heap map seed, the second is the GRIN to validate.
-
-validateGRIN :: HeapMap -> GRIN -> GValid
-
-validateGRIN s g = snd $ validateGRIN2 s g
-
--- The same, but the "full" map is returned.
-
-validateGRIN2 :: HeapMap -> GRIN -> (HeapMap, GValid)
-
-validateGRIN2 seed g =
-  let hm = inferAllCalls (heapPointsTo g `M.union` seed)
-      varonly (HVar v) = [v]
-      varonly _ = []
-      vars m = concat $ map varonly $ M.keys m
-      needvar (EquivTo _) = False
-      needvar (EquivToT _ _) = False
-      needvar (HasValue _) = False
-      needvar (ElemOf _ _) = False
-      needvar (ElemOfT _ _ _) = False
-      needvar _ = True
-      hm' = M.filter (any needvar) hm
-      ta = concat $ map snd $ runTAM hm Nothing (vars hm')
-      mr (TNoEntry, ReturnOf f) = [f]
-      mr _ = []
-      mc (TNoEntry, ArgOf f _) = [f]
-      mc _ = []
-      cmiss = nub $ concat $ map mc $ ta
-      rmiss = nub $ concat $ map mr $ ta
-  in  case (null cmiss, null rmiss) of
-        (True, True) -> (hm, GValid)
-        _ -> (hm, GInvalid {missCalls = cmiss, missReturns = rmiss})
-
-
-
rmfile ./Yhc/Core/BackEnd/GRIN/Validation.hs
rmdir ./Yhc/Core/BackEnd/GRIN
hunk ./Yhc/Core/BackEnd/GRIN.hs 1
--- GRIN-like backend for Yhc Core.
--- Top-level module.
-
-module Yhc.Core.BackEnd.GRIN (module X) where
-
-import Yhc.Core.BackEnd.GRIN.Type as X
-import Yhc.Core.BackEnd.GRIN.TransCore as X
-import Yhc.Core.BackEnd.GRIN.OptEvals as X
-import Yhc.Core.BackEnd.GRIN.OptApply as X
-import Yhc.Core.BackEnd.GRIN.OptCases as X
-import Yhc.Core.BackEnd.GRIN.HeapPointsTo as X
-import Yhc.Core.BackEnd.GRIN.FindType as X
-import Yhc.Core.BackEnd.GRIN.ElimDead as X
-import Yhc.Core.BackEnd.GRIN.SubstVars as X
-import Yhc.Core.BackEnd.GRIN.Validation as X
-import Yhc.Core.BackEnd.GRIN.FlatInline as X
-import Yhc.Core.BackEnd.GRIN.OptFetch as X
-import Yhc.Core.BackEnd.GRIN.Sharing as X
-import Yhc.Core.BackEnd.GRIN.HeapSeed as X
-
-
-
rmfile ./Yhc/Core/BackEnd/GRIN.hs
hunk ./yc2erl.cabal 32
-        Yhc.Core.BackEnd.GRIN,   Language.GRIN.Pretty
hunk ./yc2erl.cabal 40
-        Language.Edoc.Xml2Hs.Haskell,      Language.Edoc.Xml2Hs.TyParser,
-        Yhc.Core.BackEnd.GRIN.Type,        Yhc.Core.BackEnd.GRIN.TransCore,
-        Yhc.Core.BackEnd.GRIN.GGMonad,     Yhc.Core.BackEnd.GRIN.ElimDead,
-        Yhc.Core.BackEnd.GRIN.HeapPointsTo,Yhc.Core.BackEnd.GRIN.FindType,
-        Yhc.Core.BackEnd.GRIN.OptEvals,    Yhc.Core.BackEnd.GRIN.SubstVars
-        Yhc.Core.BackEnd.GRIN.OptApply,    Yhc.Core.BackEnd.GRIN.OptCases
-        Yhc.Core.BackEnd.GRIN.Validation,  Yhc.Core.BackEnd.GRIN.FlatInline
-        Yhc.Core.BackEnd.GRIN.OptFetch,    Yhc.Core.BackEnd.GRIN.Sharing
-        Yhc.Core.BackEnd.GRIN.HeapSeed
+        Language.Edoc.Xml2Hs.Haskell,      Language.Edoc.Xml2Hs.TyParser