- parrayTyCon <- dsLookupTyCon parrayTyConName
- paTyCon <- dsLookupTyCon paTyConName
- closureTyCon <- dsLookupTyCon closureTyConName
-
- mkClosureVar <- dsLookupGlobalId mkClosureName
- applyClosureVar <- dsLookupGlobalId applyClosureName
- mkClosurePVar <- dsLookupGlobalId mkClosurePName
- applyClosurePVar <- dsLookupGlobalId applyClosurePName
- closurePAVar <- dsLookupGlobalId closurePAName
- lengthPAVar <- dsLookupGlobalId lengthPAName
- replicatePAVar <- dsLookupGlobalId replicatePAName
-
- return $ Builtins {
- parrayTyCon = parrayTyCon
- , paTyCon = paTyCon
- , closureTyCon = closureTyCon
- , mkClosureVar = mkClosureVar
- , applyClosureVar = applyClosureVar
- , mkClosurePVar = mkClosurePVar
- , applyClosurePVar = applyClosurePVar
- , closurePAVar = closurePAVar
- , lengthPAVar = lengthPAVar
- , replicatePAVar = replicatePAVar
- }
-
-data VEnv = VEnv {
- -- Mapping from global variables to their vectorised versions.
- --
- vect_global_vars :: VarEnv CoreExpr
-
- -- Mapping from local variables to their vectorised and lifted
- -- versions.
- --
- , vect_local_vars :: VarEnv (CoreExpr, CoreExpr)
-
- -- Exported variables which have a vectorised version
- --
- , vect_exported_vars :: VarEnv (Var, Var)
-
- -- Mapping from TyCons to their vectorised versions.
- -- TyCons which do not have to be vectorised are mapped to
- -- themselves.
- --
- , vect_tycons :: NameEnv TyCon
-
- -- Mapping from TyCons to their PA dictionaries
- --
- , vect_tycon_pa :: NameEnv CoreExpr
-
- -- Mapping from tyvars to their PA dictionaries
- --
- , vect_tyvar_pa :: VarEnv CoreExpr
- }
-
-initVEnv :: VectInfo -> DsM VEnv
-initVEnv info
- = return $ VEnv {
- vect_global_vars = mapVarEnv (Var . snd) $ vectInfoCCVar info
- , vect_local_vars = emptyVarEnv
- , vect_exported_vars = emptyVarEnv
- , vect_tycons = mapNameEnv snd $ vectInfoCCTyCon info
- , vect_tycon_pa = emptyNameEnv
- , vect_tyvar_pa = emptyVarEnv
- }
-
--- FIXME
-updVectInfo :: VEnv -> ModGuts -> ModGuts
-updVectInfo env guts = guts { mg_vect_info = info' }
+ (types', fam_insts, pa_insts) <- vectTypeEnv (mg_types guts)
+
+ let insts = map painstInstance pa_insts
+ fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
+ inst_env' = extendInstEnvList (mg_inst_env guts) insts
+ updGEnv (setInstEnvs inst_env' fam_inst_env')
+
+ dicts <- mapM buildPADict pa_insts
+ binds' <- mapM vectTopBind (mg_binds guts)
+ return $ guts { mg_types = types'
+ , mg_binds = Rec (concat dicts) : binds'
+ , mg_inst_env = inst_env'
+ , mg_fam_inst_env = fam_inst_env'
+ , mg_insts = mg_insts guts ++ insts
+ , mg_fam_insts = mg_fam_insts guts ++ fam_insts
+ }
+
+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