-import FastString
-import Control.Monad ( liftM2 )
-
-vectorise :: HscEnv -> ModGuts -> IO ModGuts
-vectorise hsc_env guts
- | not (Opt_Vectorise `dopt` dflags) = return guts
- | otherwise
- = do
- showPass dflags "Vectorisation"
- eps <- hscEPS hsc_env
- let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
- Just guts' <- initDs hsc_env (mg_module guts)
- (mg_rdr_env guts)
- (mg_types guts)
- (vectoriseModule info guts)
- endPass dflags "Vectorisation" Opt_D_dump_vect (mg_binds guts')
- return guts'
- where
- dflags = hsc_dflags hsc_env
-
--- ----------------------------------------------------------------------------
--- Vectorisation monad
-
-data Builtins = Builtins {
- parrayTyCon :: TyCon
- , paTyCon :: TyCon
- , closureTyCon :: TyCon
- , mkClosureVar :: Var
- , applyClosureVar :: Var
- , mkClosurePVar :: Var
- , applyClosurePVar :: Var
- , closurePAVar :: Var
- , lengthPAVar :: Var
- , replicatePAVar :: Var
- }
-
-initBuiltins :: DsM Builtins
-initBuiltins
- = do
- 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' }
- where
- info' = info {
- vectInfoCCVar = vect_exported_vars env
- , vectInfoCCTyCon = tc_env
- }
-
- info = mg_vect_info guts
- tyenv = mg_types guts
-
- tc_env = mkNameEnv [(tc_name, (tc,tc')) | tc <- typeEnvTyCons tyenv
- , let tc_name = tyConName tc
- , Just tc' <- [lookupNameEnv (vect_tycons env) tc_name]]
-
-data VResult a = Yes VEnv a | No
-
-newtype VM a = VM { runVM :: Builtins -> VEnv -> DsM (VResult a) }
-
-instance Monad VM where
- return x = VM $ \bi env -> return (Yes env x)
- VM p >>= f = VM $ \bi env -> do
- r <- p bi env
- case r of
- Yes env' x -> runVM (f x) bi env'
- No -> return No