EvalInline.hs

module Grin.EvalInline(createEvalApply) where

import Control.Monad.Identity
import Data.List hiding(union)
import qualified Data.Set as Set

import GenUtil
import Grin.Grin
import Grin.Noodle
import StringTable.Atom
import Support.CanType(getType)
import Support.FreeVars(freeVars)
import Util.Once
import Util.SetLike
import Util.UniqueMonad()

{-
data UpdateType =
    NoUpdate                  -- ^ no update is performed
    | TrailingUpdate          -- ^ an update is placed after the whole evaluation
    | HoistedUpdate Val
    | SwitchingUpdate [Atom]

mapExp f (b :-> e) = b :-> f e

-- create an eval suitable for inlining.
createEval :: UpdateType -> TyEnv -> [Tag] -> Lam
createEval shared  te ts'
    | null cs = p1 :-> Error "Empty Eval" TyNode
    | all tagIsWHNF [ t | t <- ts , tagIsTag t] = p1 :-> Fetch p1
    | NoUpdate <- shared, [t] <- ts = p1 :-> Fetch p1 :>>= f t
    | TrailingUpdate <- shared, [ot] <- ofts = p1 :->
        Fetch p1 :>>= n2 :->
        Case n2 (mapExp (:>>= n3 :-> Update p1 n3 :>>= unit :-> Return n3) (f ot):map f whnfts)
    | TrailingUpdate <- shared = p1 :->
        Fetch p1 :>>= n2 :->
        Case n2 cs :>>= n3 :->
        Update p1 n3 :>>= unit :->
        Return n3
    | HoistedUpdate (NodeC t [v]) <- shared = p1 :->
        Fetch p1 :>>= n2 :->
        Case n2 cs :>>= v :->
        Return (NodeC t [v])
    | HoistedUpdate (NodeC t vs) <- shared = p1 :->
        Fetch p1 :>>= n2 :->
        Case n2 cs :>>= Tup vs :->
        Return (NodeC t vs)
    | NoUpdate <- shared = p1 :->
        Fetch p1 :>>= n2 :->
        Case n2 cs
    | SwitchingUpdate sts <- shared, [ot] <- ofts = p1 :->
        Fetch p1 :>>= n2 :->
        Case n2 (mapExp (:>>= sup p1 sts) (f ot):map f whnfts)
    | SwitchingUpdate sts <- shared = let
            lf = createEval NoUpdate te ts
--            cu t | tagIsTag t && tagIsWHNF t = return ans where
--                (ts,_) = runIdentity $ findArgsType te t
--                vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]
--                ans = NodeC t vs :-> Update p1 (NodeC t vs)
--            cu t = error $ "not updatable:" ++ show t
        in (p1 :-> (Return p1 :>>= lf) :>>= sup p1 sts) --  n3 :-> Case n3 (concatMap cu sts) :>>= unit :-> Return n3)
    where
    ts = sortUnder toPackedString ts'
    sup p sts = let
            cu t | tagIsTag t && tagIsWHNF t = return ans where
                (ts,_) = runIdentity $ findArgsType te t
                vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]
                ans = NodeC t vs :-> Update p1 (NodeC t vs)
            cu t = error $ "not updatable:" ++ show t
        in (n3 :-> Case n3 (concatMap cu sts) :>>= unit :-> Return n3)
    cs = [f t | t <- ts, tagIsTag t, isGood t ]
    isGood t | tagIsWHNF t, HoistedUpdate (NodeC t' _) <- shared, t /= t' = False
    isGood _ = True
    (whnfts,ofts) = partition tagIsWHNF (filter tagIsTag ts)
    g t vs
        | tagIsWHNF t, HoistedUpdate (NodeC t' [v]) <- shared  = case vs of
            [x] -> Return x
            _ -> error "createEval: bad thing"
        | tagIsWHNF t, HoistedUpdate (NodeC t' vars) <- shared  = Return (Tup vs)
        | tagIsWHNF t = Return (NodeC t vs)
        | 'F':fn <- fromAtom t  = ap ('f':fn) vs
        | 'B':fn <- fromAtom t  = ap ('b':fn) vs
        | otherwise = Error ("Bad Tag: " ++ fromAtom t) TyNode
    f t = (NodeC t vs :-> g t vs ) where
        (ts,_) = runIdentity $ findArgsType te t
        vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]
    ap n vs
    --    | shared =  App (toAtom $ n) vs :>>= n3 :-> Update p1 n3 :>>= unit :-> Return n3
        | HoistedUpdate udp@(NodeC t []) <- shared = App fname vs ty :>>= n3 :-> Update p1 udp
        | HoistedUpdate udp@(NodeC t [v]) <- shared = App fname vs ty :>>= n3 :-> Return n3 :>>= udp :-> (Update p1 udp :>>= unit :-> Return v)
        | HoistedUpdate udp@(NodeC t vars) <- shared = App fname vs ty :>>= n3 :-> (Return n3 :>>= udp :-> (Update p1 udp) :>>= unit :-> Return (Tup vars))
        | otherwise = App fname vs ty
     where
        fname = toAtom n
        Just (_,ty) = findArgsType te fname
 -}
createApply :: Ty -> [Ty] -> TyEnv -> [Tag] -> Lam
createApply argType retType te ts'
    | null cs && argType == TyUnit = [n1] :-> Error ("Empty Apply:" ++ show ts)  retType
    | null cs = [n1,a2] :-> Error ("Empty Apply:" ++ show ts)  retType
    | argType == TyUnit = [n1] :-> Case n1 cs
    | otherwise = [n1,a2] :-> Case n1 cs
    where
    ts = sortBy atomCompare ts'
    a2 = Var v2 argType
    cs = [ f t | t <- ts, tagGood t]
    tagGood t | Just TyTy { tyThunk = TyPApp mt w } <- findTyTy te t =
         (Just argType == mt || (argType == TyUnit && Nothing == mt)) && (fmap snd $ findArgsType te w) == Just retType
    tagGood _ = False
--    tagGood t | Just (n,fn) <- tagUnfunction t, n > 0 = let
--        ptag = argType == ts !! (length ts - n)
--        rtag = retType == TyNode || (n == 1 && rt == retType)
--        (ts,rt) = runIdentity $ findArgsType te fn
--        in rtag && ptag
    f t = ([NodeC t vs] :-> g ) where
        (ts,_) = runIdentity $ findArgsType te t
        vs = [ Var v ty |  v <- [v3 .. ] | ty <- ts]
        Just (n,fn) = tagUnfunction t
        a2s = if argType == TyUnit then [] else [a2]
        g | n == 1 =  App fn (vs ++ a2s) ty
          | n > 1 = dstore (NodeC (partialTag fn (n - 1)) (vs ++ a2s))
          | otherwise = error "createApply"
         where
            Just (_,ty) = findArgsType te fn

dstore x = BaseOp (StoreNode True) [x]

{-# NOINLINE createEvalApply #-}
createEvalApply :: Grin -> IO Grin
createEvalApply grin = do
    let --eval = (funcEval,Tup [earg] :-> ebody) where
        --    earg :-> ebody  =  createEval TrailingUpdate (grinTypeEnv grin) tags
        tags = Set.toList $ ftags `Set.union` plads
        ftags = freeVars (map (lamExp . snd) $ grinFuncs grin)
        plads = Set.fromList $ concatMap mplad (Set.toList ftags)
        mplad t | Just (n,tag) <- tagUnfunction t, n > 1 = t:mplad (partialTag tag (n - 1))
        mplad t = [t]
    appMap <- newOnceMap
    let f (ls :-> exp) = do
            exp' <- g exp
            return $ ls :-> exp'
        g (BaseOp (Apply ty) [fun]) = do
            fn' <- runOnceMap appMap (TyUnit,ty) $ do
                u <- newUniq
                return (toAtom $ "bapply_" ++ show u)
            return (App fn' [fun] ty)
        g (BaseOp (Apply ty) [fun,arg]) = do
            fn' <- runOnceMap appMap (getType arg,ty) $ do
                u <- newUniq
                return (toAtom $ "bapply_" ++ show u)
            return (App fn' [fun,arg] ty)
        g x = mapExpExp g x
    funcs <- mapMsnd f (grinFuncs grin)
    as <- onceMapToList appMap
    let (apps,ntyenv) = unzip $ map cf as
        cf ((targ,tret),name) | targ == TyUnit = ((name,appBody),(name,tyTy { tySlots = [TyNode],tyReturn = tret })) where
            appBody = createApply targ tret (grinTypeEnv grin) tags
        cf ((targ,tret),name) = ((name,appBody),(name,tyTy { tySlots = [TyNode,targ],tyReturn = tret })) where
            appBody = createApply targ tret (grinTypeEnv grin) tags
        TyEnv tyEnv = grinTypeEnv grin
        appTyEnv = fromList ntyenv
    return $ setGrinFunctions (apps ++ funcs) grin { grinTypeEnv = TyEnv (tyEnv `union` appTyEnv) }