X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectMonad.hs;h=b31d798c3e8517aba127f8eb0660ffe63be0627b;hb=c099327dd5765dfefccb01302ef8ea8369728cbf;hp=ed18f1f7a93d648ba9079832b5e31e81879a05eb;hpb=ea81010210486aa7b8b3ef36c65f794a33dbfefe;p=ghc-hetmet.git diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index ed18f1f..b31d798 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -3,7 +3,8 @@ module VectMonad ( VM, noV, tryV, maybeV, orElseV, fixV, localV, closedV, initV, - cloneName, newLocalVar, newTyVar, + cloneName, cloneId, + newExportedVar, newLocalVar, newDummyVar, newTyVar, Builtins(..), paDictTyCon, paDictDataCon, builtin, @@ -15,6 +16,8 @@ module VectMonad ( LocalEnv(..), readLEnv, setLEnv, updLEnv, + getBindName, inBind, + lookupVar, defGlobalVar, lookupTyCon, defTyCon, lookupDataCon, defDataCon, @@ -37,6 +40,7 @@ import Id import OccName import Name import NameEnv +import TysPrim ( intPrimTy ) import DsMonad import PrelNames @@ -47,6 +51,7 @@ import FamInstEnv import Panic import Outputable import FastString +import SrcLoc ( noSrcSpan ) import Control.Monad ( liftM ) @@ -66,6 +71,7 @@ data Builtins = Builtins { , lengthPAVar :: Var , replicatePAVar :: Var , emptyPAVar :: Var + , liftingContext :: Var } paDictTyCon :: Builtins -> TyCon @@ -89,6 +95,9 @@ initBuiltins replicatePAVar <- dsLookupGlobalId replicatePAName emptyPAVar <- dsLookupGlobalId emptyPAName + liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy) + newUnique + return $ Builtins { parrayTyCon = parrayTyCon , paClass = paClass @@ -100,12 +109,13 @@ initBuiltins , lengthPAVar = lengthPAVar , replicatePAVar = replicatePAVar , emptyPAVar = emptyPAVar + , liftingContext = liftingContext } data GlobalEnv = GlobalEnv { -- Mapping from global variables to their vectorised versions. -- - global_vars :: VarEnv CoreExpr + global_vars :: VarEnv Var -- Exported variables which have a vectorised version -- @@ -121,6 +131,10 @@ data GlobalEnv = GlobalEnv { -- , global_datacons :: NameEnv DataCon + -- Mapping from TyCons to their PA dfuns + -- + , global_pa_funs :: NameEnv Var + -- External package inst-env & home-package inst-env for class -- instances -- @@ -139,7 +153,7 @@ data LocalEnv = LocalEnv { -- Mapping from local variables to their vectorised and -- lifted versions -- - local_vars :: VarEnv (CoreExpr, CoreExpr) + local_vars :: VarEnv (Var, Var) -- In-scope type variables -- @@ -147,18 +161,22 @@ data LocalEnv = LocalEnv { -- Mapping from tyvars to their PA dictionaries , local_tyvar_pa :: VarEnv CoreExpr + + -- Local binding name + , local_bind_name :: FastString } initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> Builtins -> GlobalEnv initGlobalEnv info instEnvs famInstEnvs bi = GlobalEnv { - global_vars = mapVarEnv (Var . snd) $ vectInfoVar info + global_vars = mapVarEnv snd $ vectInfoVar info , global_exported_vars = emptyVarEnv , global_tycons = extendNameEnv (mapNameEnv snd (vectInfoTyCon info)) (tyConName funTyCon) (closureTyCon bi) , global_datacons = mapNameEnv snd $ vectInfoDataCon info + , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info , global_inst_env = instEnvs , global_fam_inst_env = famInstEnvs , global_bindings = [] @@ -175,6 +193,7 @@ emptyLocalEnv = LocalEnv { local_vars = emptyVarEnv , local_tyvars = [] , local_tyvar_pa = emptyVarEnv + , local_bind_name = FSLIT("fn") } -- FIXME @@ -184,6 +203,7 @@ updVectInfo env tyenv info vectInfoVar = global_exported_vars env , vectInfoTyCon = mk_env typeEnvTyCons global_tycons , vectInfoDataCon = mk_env typeEnvDataCons global_datacons + , vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs } where mk_env from_tyenv from_env = mkNameEnv [(name, (from,to)) @@ -206,6 +226,9 @@ instance Monad VM where noV :: VM a noV = VM $ \_ _ _ -> return No +traceNoV :: String -> SDoc -> VM a +traceNoV s d = pprTrace s d noV + tryV :: VM a -> VM (Maybe a) tryV (VM p) = VM $ \bi genv lenv -> do @@ -217,6 +240,9 @@ tryV (VM p) = VM $ \bi genv lenv -> maybeV :: VM (Maybe a) -> VM a maybeV p = maybe noV return =<< p +traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a +traceMaybeV s d p = maybe (traceNoV s d) return =<< p + orElseV :: VM a -> VM a -> VM a orElseV p q = maybe q return =<< tryV p @@ -235,7 +261,7 @@ localV p = do closedV :: VM a -> VM a closedV p = do env <- readLEnv id - setLEnv emptyLocalEnv + setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env }) x <- p setLEnv env return x @@ -270,6 +296,14 @@ getInstEnv = readGEnv global_inst_env getFamInstEnv :: VM FamInstEnvs getFamInstEnv = readGEnv global_fam_inst_env +getBindName :: VM FastString +getBindName = readLEnv local_bind_name + +inBind :: Id -> VM a -> VM a +inBind id p + = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) } + p + cloneName :: (OccName -> OccName) -> Name -> VM Name cloneName mk_occ name = liftM make (liftDs newUnique) where @@ -280,12 +314,33 @@ cloneName mk_occ name = liftM make (liftDs newUnique) (nameSrcSpan name) | otherwise = mkSystemName u occ_name +cloneId :: (OccName -> OccName) -> Id -> Type -> VM Id +cloneId mk_occ id ty + = do + name <- cloneName mk_occ (getName id) + let id' | isExportedId id = Id.mkExportedLocalId name ty + | otherwise = Id.mkLocalId name ty + return id' + +newExportedVar :: OccName -> Type -> VM Var +newExportedVar occ_name ty + = do + mod <- liftDs getModuleDs + u <- liftDs newUnique + + let name = mkExternalName u mod occ_name noSrcSpan + + return $ Id.mkExportedLocalId name ty + newLocalVar :: FastString -> Type -> VM Var newLocalVar fs ty = do u <- liftDs newUnique return $ mkSysLocal fs u ty +newDummyVar :: Type -> VM Var +newDummyVar = newLocalVar FSLIT("ds") + newTyVar :: FastString -> Kind -> VM Var newTyVar fs k = do @@ -294,21 +349,22 @@ newTyVar fs k defGlobalVar :: Var -> Var -> VM () defGlobalVar v v' = updGEnv $ \env -> - env { global_vars = extendVarEnv (global_vars env) v (Var v') + env { global_vars = extendVarEnv (global_vars env) v v' , global_exported_vars = upd (global_exported_vars env) } where upd env | isExportedId v = extendVarEnv env v (v, v') | otherwise = env -lookupVar :: Var -> VM (Scope CoreExpr (CoreExpr, CoreExpr)) +lookupVar :: Var -> VM (Scope Var (Var, Var)) lookupVar v = do r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v case r of Just e -> return (Local e) Nothing -> liftM Global - $ maybeV (readGEnv $ \env -> lookupVarEnv (global_vars env) v) + $ traceMaybeV "lookupVar" (ppr v) + (readGEnv $ \env -> lookupVarEnv (global_vars env) v) lookupTyCon :: TyCon -> VM (Maybe TyCon) lookupTyCon tc @@ -365,7 +421,7 @@ lookupInst cls tys where inst_tys' = [ty | Right ty <- inst_tys] noFlexiVar = all isRight inst_tys - _other -> noV + _other -> traceNoV "lookupInst" (ppr cls <+> ppr tys) } where isRight (Left _) = False