-- Mapping from tyvars to their PA dictionaries
, local_tyvar_pa :: VarEnv CoreExpr
+
+ -- Hoisted bindings
+ , local_bindings :: [(Var, CoreExpr)]
}
emptyLocalEnv = LocalEnv {
local_vars = emptyVarEnv
, local_tyvar_pa = emptyVarEnv
+ , local_bindings = []
}
-- FIXME
splitClosureTy,
mkPADictType, mkPArrayType,
paDictArgType, paDictOfType,
- lookupPArrayFamInst
+ lookupPArrayFamInst,
+ hoistExpr
) where
#include "HsVersions.h"
import VectMonad
import CoreSyn
+import CoreUtils
import Type
import TypeRep
import TyCon
import PrelNames
import Outputable
+import FastString
import Control.Monad ( liftM )
lookupPArrayFamInst :: Type -> VM (TyCon, [Type])
lookupPArrayFamInst ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
+hoistExpr :: FastString -> CoreExpr -> VM Var
+hoistExpr fs expr
+ = do
+ var <- newLocalVar fs (exprType expr)
+ updLEnv $ \env ->
+ env { local_bindings = (var, expr) : local_bindings env }
+ return var
+
let tyvars = filter isTyVar (varSetElems fvs)
info <- mkCEnvInfo fvs bndr body
(poly_vfn, poly_lfn) <- mkClosureFns info tyvars bndr body
+
+ vfn_var <- hoistExpr FSLIT("vfn") poly_vfn
+ lfn_var <- hoistExpr FSLIT("lfn") poly_lfn
+
let (venv, lenv) = mkClosureEnvs info lc
let env_ty = cenv_vty info
res_ty <- vectType (exprType $ deAnnotate body)
-- FIXME: move the functions to the top level
- mono_vfn <- applyToTypes poly_vfn (map TyVarTy tyvars)
- mono_lfn <- applyToTypes poly_lfn (map TyVarTy tyvars)
+ mono_vfn <- applyToTypes (Var vfn_var) (map TyVarTy tyvars)
+ mono_lfn <- applyToTypes (Var lfn_var) (map TyVarTy tyvars)
mk_clo <- builtin mkClosureVar
mk_cloP <- builtin mkClosurePVar