-- * Primitives
lookupPrimPArray,
lookupPrimMethod
-)
-where
+) where
+
import Vectorise.Monad.Base
import Vectorise.Monad.Naming
import Vectorise.Monad.Local
import Vectorise.Builtins
import Vectorise.Env
-import HscTypes hiding ( MonadThings(..) )
+import HscTypes hiding ( MonadThings(..) )
+import DynFlags
import MonadUtils (liftIO)
-import Module
import TyCon
import Var
import VarEnv
import Id
import DsMonad
import Outputable
+import FastString
+
import Control.Monad
import VarSet
-- | Run a vectorisation computation.
-initV :: PackageId
- -> HscEnv
- -> ModGuts
- -> VectInfo
- -> VM a
- -> IO (Maybe (VectInfo, a))
-
-initV pkg hsc_env guts info p
- = do
- -- XXX: ignores error messages and warnings, check that this is
- -- indeed ok (the use of "Just r" suggests so)
- (_,Just r) <- initDs hsc_env (mg_module guts)
- (mg_rdr_env guts)
- (mg_types guts)
- go
- return r
+--
+initV :: HscEnv
+ -> ModGuts
+ -> VectInfo
+ -> VM a
+ -> IO (Maybe (VectInfo, a))
+initV hsc_env guts info thing_inside
+ = do { (_, Just r) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go
+ ; return r
+ }
where
go
- = do
- builtins <- initBuiltins pkg
- builtin_vars <- initBuiltinVars builtins
- builtin_tycons <- initBuiltinTyCons builtins
- let builtin_datacons = initBuiltinDataCons builtins
- builtin_boxed <- initBuiltinBoxedTyCons builtins
- builtin_scalars <- initBuiltinScalars builtins
-
- eps <- liftIO $ hscEPS hsc_env
- let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
- instEnvs = (eps_inst_env eps, mg_inst_env guts)
-
- builtin_prs <- initBuiltinPRs builtins instEnvs
- builtin_pas <- initBuiltinPAs builtins instEnvs
-
- let genv = extendImportedVarsEnv builtin_vars
- . extendScalars builtin_scalars
- . extendTyConsEnv builtin_tycons
- . extendDataConsEnv builtin_datacons
- . extendPAFunsEnv builtin_pas
- . setPRFunsEnv builtin_prs
- . setBoxedTyConsEnv builtin_boxed
- $ initGlobalEnv info instEnvs famInstEnvs
-
- r <- runVM p builtins genv emptyLocalEnv
- case r of
- Yes genv _ x -> return $ Just (new_info genv, x)
- No -> return Nothing
+ = do { -- pick a DPH backend
+ ; dflags <- getDOptsDs
+ ; case dphPackageMaybe dflags of
+ Nothing -> failWithDs $ ptext selectBackendErr
+ Just pkg -> do {
+
+ -- set up tables of builtin entities
+ ; let compilingDPH = dphBackend dflags == DPHThis -- FIXME: temporary kludge support
+ ; builtins <- initBuiltins pkg
+ ; builtin_vars <- initBuiltinVars compilingDPH builtins
+ ; builtin_tycons <- initBuiltinTyCons builtins
+ ; let builtin_datacons = initBuiltinDataCons builtins
+ ; builtin_boxed <- initBuiltinBoxedTyCons builtins
+ ; builtin_scalars <- initBuiltinScalars compilingDPH builtins
+
+ -- set up class and type family envrionments
+ ; eps <- liftIO $ hscEPS hsc_env
+ ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
+ instEnvs = (eps_inst_env eps, mg_inst_env guts)
+ ; builtin_prs <- initBuiltinPRs builtins instEnvs
+ ; builtin_pas <- initBuiltinPAs builtins instEnvs
+
+ -- construct the initial global environment
+ ; let genv = extendImportedVarsEnv builtin_vars
+ . extendScalars builtin_scalars
+ . extendTyConsEnv builtin_tycons
+ . extendDataConsEnv builtin_datacons
+ . extendPAFunsEnv builtin_pas
+ . setPRFunsEnv builtin_prs
+ . setBoxedTyConsEnv builtin_boxed
+ $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
+
+ -- perform vectorisation
+ ; r <- runVM thing_inside builtins genv emptyLocalEnv
+ ; case r of
+ Yes genv _ x -> return $ Just (new_info genv, x)
+ No -> return Nothing
+ } }
new_info genv = updVectInfo genv (mg_types guts) info
+ selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
-- Builtins -------------------------------------------------------------------
-- | Lift a desugaring computation using the `Builtins` into the vectorisation monad.
| otherwise
= cantVectorise "Variable not vectorised:" (ppr var)
--- local scalars --------------------------------------------------------------
--- | Check if the variable is a locally defined scalar function
+-- local scalars --------------------------------------------------------------
addGlobalScalar :: Var -> VM ()
addGlobalScalar var
- = updGEnv $ \env -> pprTrace "addGLobalScalar" (ppr var) env{global_scalars = extendVarSet (global_scalars env) var}
+ = do { traceVt "addGlobalScalar" (ppr var)
+ ; updGEnv $ \env -> env{global_scalars = extendVarSet (global_scalars env) var}
+ }
deleteGlobalScalar :: Var -> VM ()
deleteGlobalScalar var
- = updGEnv $ \env -> pprTrace "deleteGLobalScalar" (ppr var) env{global_scalars = delVarSet (global_scalars env) var}
+ = do { traceVt "deleteGlobalScalar" (ppr var)
+ ; updGEnv $ \env -> env{global_scalars = delVarSet (global_scalars env) var}
+ }
-- Primitives -----------------------------------------------------------------