-mkClosureEnvs :: CEnvInfo -> CoreExpr -> (CoreExpr, CoreExpr)
-mkClosureEnvs info lc
- | [] <- vals
- = (Var unitDataConId, mkApps (Var $ dataConWrapId (cenv_repr_datacon info))
- [lc, Var unitDataConId])
-
- | [(vval, lval)] <- vals
- = (vval, lval)
-
- | otherwise
- = (mkCoreTup vvals, Var (dataConWrapId $ cenv_repr_datacon info)
- `mkTyApps` cenv_repr_tyargs info
- `mkApps` (lc : lvals))
-
- where
- vals = cenv_values info
- (vvals, lvals) = unzip vals
-
-mkClosureFns :: CEnvInfo -> [TyVar] -> Var -> CoreExprWithFVs
- -> VM (CoreExpr, CoreExpr)
-mkClosureFns info tyvars arg body
- = closedV
- . abstractOverTyVars tyvars
- $ \mk_tlams ->
- do
- (vfn, lfn) <- mkClosureMonoFns info arg body
- return (mk_tlams vfn, mk_tlams lfn)
-
-mkClosureMonoFns :: CEnvInfo -> Var -> CoreExprWithFVs -> VM (CoreExpr, CoreExpr)
-mkClosureMonoFns info arg body
- = do
- lc_bndr <- newLocalVar FSLIT("lc") intTy
- (varg : vbndrs, larg : lbndrs, (vbody, lbody))
- <- vectBndrsIn (arg : cenv_vars info)
- (vectExpr (Var lc_bndr) body)
-
- venv_bndr <- newLocalVar FSLIT("env") vty
- lenv_bndr <- newLocalVar FSLIT("env") lty
-
- let vcase = bind_venv (Var venv_bndr) vbody vbndrs
- lcase <- bind_lenv (Var lenv_bndr) lbody lc_bndr lbndrs
- return (mkLams [venv_bndr, varg] vcase, mkLams [lenv_bndr, larg] lcase)