module Vectorise.Utils.Hoisting (
	Inline(..),
	addInlineArity,
	inlineMe,
	
	hoistBinding,
	hoistExpr,
	hoistVExpr,
	hoistPolyVExpr,
	takeHoisted
)
where
import Vectorise.Monad
import Vectorise.Env
import Vectorise.Vect
import Vectorise.Utils.Poly

import CoreSyn
import CoreUtils
import CoreUnfold
import Type
import Var
import Id
import BasicTypes( Arity )
import FastString
import Control.Monad


-- Inline ---------------------------------------------------------------------
-- | Records whether we should inline a particular binding.
data Inline 
        = Inline Arity
        | DontInline

-- | Add to the arity contained within an `Inline`, if any.
addInlineArity :: Inline -> Int -> Inline
addInlineArity (Inline m) n = Inline (m+n)
addInlineArity DontInline _ = DontInline

-- | Says to always inline a binding.
inlineMe :: Inline
inlineMe = Inline 0


-- Hoising --------------------------------------------------------------------
hoistBinding :: Var -> CoreExpr -> VM ()
hoistBinding v e = updGEnv $ \env ->
  env { global_bindings = (v,e) : global_bindings env }


hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var
hoistExpr fs expr inl
  = do
      var <- mk_inline `liftM` newLocalVar fs (exprType expr)
      hoistBinding var expr
      return var
  where
    mk_inline var = case inl of
                      Inline arity -> var `setIdUnfolding`
                                      mkInlineUnfolding (Just arity) expr
                      DontInline   -> var


hoistVExpr :: VExpr -> Inline -> VM VVar
hoistVExpr (ve, le) inl
  = do
      fs <- getBindName
      vv <- hoistExpr ('v' `consFS` fs) ve inl
      lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
      return (vv, lv)


hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr
hoistPolyVExpr tvs inline p
  = do
      inline' <- liftM (addInlineArity inline) (polyArity tvs)
      expr <- closedV . polyAbstract tvs $ \args ->
              liftM (mapVect (mkLams $ tvs ++ args)) p
      fn   <- hoistVExpr expr inline'
      polyVApply (vVar fn) (mkTyVarTys tvs)


takeHoisted :: VM [(Var, CoreExpr)]
takeHoisted
  = do
      env <- readGEnv id
      setGEnv $ env { global_bindings = [] }
      return $ global_bindings env