From a9192907a271905c4ec1a37b1737ce119ac48905 Mon Sep 17 00:00:00 2001 From: Roman Leshchinskiy Date: Sun, 18 Nov 2007 04:26:05 +0000 Subject: [PATCH] Add builtin var->var mapping to vectorisation --- compiler/vectorise/VectBuiltIn.hs | 10 ++++++++-- compiler/vectorise/VectMonad.hs | 10 ++++++++-- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs index 995d16f..a913467 100644 --- a/compiler/vectorise/VectBuiltIn.hs +++ b/compiler/vectorise/VectBuiltIn.hs @@ -7,7 +7,7 @@ module VectBuiltIn ( Builtins(..), sumTyCon, prodTyCon, combinePAVar, - initBuiltins, initBuiltinTyCons, initBuiltinDataCons, + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, initBuiltinPAs, initBuiltinPRs, initBuiltinBoxedTyCons, @@ -20,7 +20,7 @@ import DsMonad import IfaceEnv ( lookupOrig ) import Module ( Module ) -import DataCon ( DataCon, dataConName ) +import DataCon ( DataCon, dataConName, dataConWorkId ) import TyCon ( TyCon, tyConName, tyConDataCons ) import Var ( Var ) import Id ( mkSysLocal ) @@ -185,6 +185,12 @@ initBuiltins , liftingContext = liftingContext } +initBuiltinVars :: Builtins -> [(Var, Var)] +initBuiltinVars bi = [(v,v) | v <- map dataConWorkId defaultDataConWorkers] + +defaultDataConWorkers :: [DataCon] +defaultDataConWorkers = [trueDataCon, falseDataCon] + initBuiltinTyCons :: Builtins -> [(Name, TyCon)] initBuiltinTyCons bi = (tyConName funTyCon, closureTyCon bi) : [(tyConName tc, tc) | tc <- defaultTyCons] diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index d75cbab..5ef06ee 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -152,6 +152,10 @@ initGlobalEnv info instEnvs famInstEnvs , global_bindings = [] } +extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv +extendImportedVarsEnv ps genv + = genv { global_vars = extendVarEnvList (global_vars genv) ps } + setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv setFamInstEnv l_fam_inst genv = genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) } @@ -489,7 +493,8 @@ initV hsc_env guts info p go = do builtins <- initBuiltins - let builtin_tycons = initBuiltinTyCons builtins + let builtin_vars = initBuiltinVars builtins + builtin_tycons = initBuiltinTyCons builtins builtin_datacons = initBuiltinDataCons builtins builtin_pas <- initBuiltinPAs builtins builtin_prs <- initBuiltinPRs builtins @@ -499,7 +504,8 @@ initV hsc_env guts info p let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) instEnvs = (eps_inst_env eps, mg_inst_env guts) - let genv = extendTyConsEnv builtin_tycons + let genv = extendImportedVarsEnv builtin_vars + . extendTyConsEnv builtin_tycons . extendDataConsEnv builtin_datacons . extendPAFunsEnv builtin_pas . setPRFunsEnv builtin_prs -- 1.7.10.4