X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise%2FMonad.hs;h=e2933cdc6bf433965301bb2997d0cdd3987258b2;hp=77b9b7fdf37dff2540dc66802e484a8b163776aa;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=37b0cb1147cadef4d68f3fc61faa3ec11ad47440 diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 77b9b7f..e2933cd 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -1,28 +1,28 @@ module Vectorise.Monad ( - module Vectorise.Monad.Base, - module Vectorise.Monad.Naming, - module Vectorise.Monad.Local, - module Vectorise.Monad.Global, - module Vectorise.Monad.InstEnv, - initV, - - -- * Builtins - liftBuiltinDs, - builtin, - builtins, - - -- * Variables - lookupVar, - maybeCantVectoriseVarM, - dumpVar, - addGlobalScalar, - - -- * Primitives - lookupPrimPArray, - lookupPrimMethod -) -where + module Vectorise.Monad.Base, + module Vectorise.Monad.Naming, + module Vectorise.Monad.Local, + module Vectorise.Monad.Global, + module Vectorise.Monad.InstEnv, + initV, + + -- * Builtins + liftBuiltinDs, + builtin, + builtins, + + -- * Variables + lookupVar, + maybeCantVectoriseVarM, + dumpVar, + addGlobalScalar, + + -- * Primitives + lookupPrimPArray, + lookupPrimMethod +) where + import Vectorise.Monad.Base import Vectorise.Monad.Naming import Vectorise.Monad.Local @@ -31,68 +31,75 @@ import Vectorise.Monad.InstEnv 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 - - new_info genv = updVectInfo genv (mg_types guts) info - + = 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 = modVectInfo 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. @@ -112,7 +119,7 @@ builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi)) -- Var ------------------------------------------------------------------------ -- | Lookup the vectorised and\/or lifted versions of this variable. --- If it's in the global environment we get the vectorised version. +-- If it's in the global environment we get the vectorised version. -- If it's in the local environment we get both the vectorised and lifted version. lookupVar :: Var -> VM (Scope Var (Var, Var)) lookupVar v @@ -132,21 +139,24 @@ maybeCantVectoriseVarM v p dumpVar :: Var -> a dumpVar var - | Just _ <- isClassOpId_maybe var - = cantVectorise "ClassOpId not vectorised:" (ppr var) + | Just _ <- isClassOpId_maybe var + = cantVectorise "ClassOpId not vectorised:" (ppr var) - | otherwise - = cantVectorise "Variable not vectorised:" (ppr var) + | otherwise + = cantVectorise "Variable not vectorised:" (ppr var) --- local scalars -------------------------------------------------------------- --- | Check if the variable is a locally defined scalar function +-- Global 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_scalar_vars = extendVarSet (global_scalar_vars env) var} + } + -- Primitives ----------------------------------------------------------------- + lookupPrimPArray :: TyCon -> VM (Maybe TyCon) lookupPrimPArray = liftBuiltinDs . primPArray