import Var
import VarEnv
import VarSet
-import Name ( mkSysTvName )
+import Name ( mkSysTvName, getName )
import NameEnv
import Id
import MkId ( unwrapFamInstScrut )
+import OccName
import DsMonad hiding (mapAndUnzipM)
import DsUtils ( mkCoreTup, mkCoreTupTy )
dflags = hsc_dflags hsc_env
vectModule :: ModGuts -> VM ModGuts
-vectModule guts = return guts
+vectModule guts
+ = do
+ binds' <- mapM vectTopBind (mg_binds guts)
+ return $ guts { mg_binds = binds' }
+
+vectTopBind :: CoreBind -> VM CoreBind
+vectTopBind b@(NonRec var expr)
+ = do
+ var' <- vectTopBinder var
+ expr' <- vectTopRhs expr
+ hs <- takeHoisted
+ return . Rec $ (var, expr) : (var', expr') : hs
+ `orElseV`
+ return b
+
+vectTopBind b@(Rec bs)
+ = do
+ vars' <- mapM vectTopBinder vars
+ exprs' <- mapM vectTopRhs exprs
+ hs <- takeHoisted
+ return . Rec $ bs ++ zip vars' exprs' ++ hs
+ `orElseV`
+ return b
+ where
+ (vars, exprs) = unzip bs
+
+vectTopBinder :: Var -> VM Var
+vectTopBinder var
+ = do
+ vty <- liftM (mkForAllTys tyvars) $ vectType mono_ty
+ name <- cloneName mkVectOcc (getName var)
+ let var' | isExportedId var = Id.mkExportedLocalId name vty
+ | otherwise = Id.mkLocalId name vty
+ defGlobalVar var var'
+ return var'
+ where
+ (tyvars, mono_ty) = splitForAllTys (idType var)
+
+vectTopRhs :: CoreExpr -> VM CoreExpr
+vectTopRhs = liftM fst . closedV . vectPolyExpr (panic "Empty lifting context") . freeVars
-- ----------------------------------------------------------------------------
-- Bindings
(arg_ty, res_ty) = splitClosureTy fn_ty
vectVar :: CoreExpr -> Var -> VM (CoreExpr, CoreExpr)
-vectVar lc v = local v `orElseV` global v
- where
- local v = maybeV (readLEnv $ \env -> lookupVarEnv (local_vars env) v)
- global v = do
- vexpr <- maybeV (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
- lexpr <- replicateP vexpr lc
- return (vexpr, lexpr)
+vectVar lc v
+ = do
+ r <- lookupVar v
+ case r of
+ Local es -> return es
+ Global vexpr -> do
+ lexpr <- replicateP vexpr lc
+ return (vexpr, lexpr)
vectPolyVar :: CoreExpr -> Var -> [Type] -> VM (CoreExpr, CoreExpr)
vectPolyVar lc v tys
= do
- r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
+ r <- lookupVar v
case r of
- Just (vexpr, lexpr) -> liftM2 (,) (mk_app vexpr) (mk_app lexpr)
- Nothing ->
- do
- poly <- maybeV (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
- vexpr <- mk_app poly
- lexpr <- replicateP vexpr lc
- return (vexpr, lexpr)
+ Local (vexpr, lexpr) -> liftM2 (,) (mk_app vexpr) (mk_app lexpr)
+ Global poly -> do
+ vexpr <- mk_app poly
+ lexpr <- replicateP vexpr lc
+ return (vexpr, lexpr)
where
mk_app e = applyToTypes e =<< mapM vectType tys
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