From fe5405d4b97a521e32899f6dc2153c556723ca62 Mon Sep 17 00:00:00 2001 From: Roman Leshchinskiy Date: Tue, 7 Aug 2007 05:10:52 +0000 Subject: [PATCH] PA is now an explicit record instead of a typeclass --- compiler/prelude/PrelNames.lhs | 7 +++---- compiler/vectorise/VectMonad.hs | 35 ++++++++++++++++------------------- compiler/vectorise/VectType.hs | 27 ++++++++++----------------- compiler/vectorise/VectUtils.hs | 20 +++++++++++++++----- compiler/vectorise/Vectorise.hs | 17 +++++++---------- 5 files changed, 51 insertions(+), 55 deletions(-) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index c09d73d..5bbd994 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -217,7 +217,7 @@ genericTyConNames :: [Name] genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] ndpNames :: [Name] -ndpNames = [ parrayTyConName, paClassName, closureTyConName +ndpNames = [ parrayTyConName, paTyConName, closureTyConName , mkClosureName, applyClosureName , mkClosurePName, applyClosurePName , lengthPAName, replicatePAName, emptyPAName ] @@ -691,7 +691,7 @@ checkDotnetResName = varQual dOTNET FSLIT("checkResult") checkDotnetResNam -- NDP stuff parrayTyConName = tcQual nDP_PARRAY FSLIT("PArray") parrayTyConKey -paClassName = clsQual nDP_PARRAY FSLIT("PA") paClassKey +paTyConName = tcQual nDP_PARRAY FSLIT("PA") paTyConKey lengthPAName = methName nDP_PARRAY FSLIT("lengthPA") lengthPAClassOpKey replicatePAName = methName nDP_PARRAY FSLIT("replicatePA") replicatePAClassOpKey emptyPAName = varQual nDP_PARRAY FSLIT("emptyPA") emptyPAClassOpKey @@ -769,8 +769,6 @@ randomClassKey = mkPreludeClassUnique 31 randomGenClassKey = mkPreludeClassUnique 32 isStringClassKey = mkPreludeClassUnique 33 - -paClassKey = mkPreludeClassUnique 34 \end{code} %************************************************************************ @@ -883,6 +881,7 @@ stringTyConKey = mkPreludeTyConUnique 134 parrayTyConKey = mkPreludeTyConUnique 135 closureTyConKey = mkPreludeTyConUnique 136 +paTyConKey = mkPreludeTyConUnique 137 ---------------- Template Haskell ------------------- diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index 6da501f..b7e4b89 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -6,11 +6,11 @@ module VectMonad ( cloneName, cloneId, newExportedVar, newLocalVar, newDummyVar, newTyVar, - Builtins(..), paDictTyCon, paDictDataCon, + Builtins(..), builtin, GlobalEnv(..), - setInstEnvs, + setFamInstEnv, readGEnv, setGEnv, updGEnv, LocalEnv(..), @@ -24,14 +24,13 @@ module VectMonad ( lookupTyConPA, defTyConPA, defTyConRdrPAs, lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars, - lookupInst, lookupFamInst + {-lookupInst,-} lookupFamInst ) where #include "HsVersions.h" import HscTypes import CoreSyn -import Class import TyCon import DataCon import Type @@ -64,7 +63,8 @@ data Scope a b = Global a | Local b data Builtins = Builtins { parrayTyCon :: TyCon - , paClass :: Class + , paTyCon :: TyCon + , paDataCon :: DataCon , closureTyCon :: TyCon , mkClosureVar :: Var , applyClosureVar :: Var @@ -76,17 +76,12 @@ data Builtins = Builtins { , liftingContext :: Var } -paDictTyCon :: Builtins -> TyCon -paDictTyCon = classTyCon . paClass - -paDictDataCon :: Builtins -> DataCon -paDictDataCon = classDataCon . paClass - initBuiltins :: DsM Builtins initBuiltins = do parrayTyCon <- dsLookupTyCon parrayTyConName - paClass <- dsLookupClass paClassName + paTyCon <- dsLookupTyCon paTyConName + let paDataCon = case tyConDataCons paTyCon of [dc] -> dc closureTyCon <- dsLookupTyCon closureTyConName mkClosureVar <- dsLookupGlobalId mkClosureName @@ -102,7 +97,8 @@ initBuiltins return $ Builtins { parrayTyCon = parrayTyCon - , paClass = paClass + , paTyCon = paTyCon + , paDataCon = paDataCon , closureTyCon = closureTyCon , mkClosureVar = mkClosureVar , applyClosureVar = applyClosureVar @@ -190,12 +186,11 @@ initGlobalEnv info instEnvs famInstEnvs bi rdr_env , global_rdr_env = rdr_env } -setInstEnvs :: InstEnv -> FamInstEnv -> GlobalEnv -> GlobalEnv -setInstEnvs l_inst l_fam_inst genv - | (g_inst, _) <- global_inst_env genv - , (g_fam_inst, _) <- global_fam_inst_env genv - = genv { global_inst_env = (g_inst, l_inst) - , global_fam_inst_env = (g_fam_inst, l_fam_inst) } +setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv +setFamInstEnv l_fam_inst genv + = genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) } + where + (g_fam_inst, _) = global_fam_inst_env genv emptyLocalEnv = LocalEnv { local_vars = emptyVarEnv @@ -450,6 +445,7 @@ localTyVars = readLEnv (reverse . local_tyvars) -- instances head (i.e., no flexi vars); for details for what this means, -- see the docs at InstEnv.lookupInstEnv. -- +{- lookupInst :: Class -> [Type] -> VM (DFunId, [Type]) lookupInst cls tys = do { instEnv <- getInstEnv @@ -466,6 +462,7 @@ lookupInst cls tys where isRight (Left _) = False isRight (Right _) = True +-} -- Look up the representation tycon of a family instance. -- diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 2c38bce..896139f 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -1,5 +1,5 @@ module VectType ( vectTyCon, vectType, vectTypeEnv, - PAInstance, painstInstance, buildPADict, + PAInstance, buildPADict, vectDataConWorkers ) where @@ -78,13 +78,13 @@ vectType ty = pprPanic "vectType:" (ppr ty) type TyConGroup = ([TyCon], UniqSet TyCon) data PAInstance = PAInstance { - painstInstance :: Instance + painstDFun :: Var , painstOrigTyCon :: TyCon , painstVectTyCon :: TyCon , painstArrTyCon :: TyCon } -vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [PAInstance]) +vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst]) vectTypeEnv env = do cs <- readGEnv $ mk_map . global_tycons @@ -107,7 +107,7 @@ vectTypeEnv env ++ [ADataCon dc | tc <- all_new_tcs , dc <- tyConDataCons tc]) - return (new_env, map mkLocalFamInst parr_tcs, pa_insts) + return (new_env, map mkLocalFamInst parr_tcs) where tycons = typeEnvTyCons env groups = tyConGroups tycons @@ -362,26 +362,19 @@ buildPArrayDataCon orig_name vect_tc repr_tc buildPAInstance :: TyCon -> TyCon -> TyCon -> VM PAInstance buildPAInstance orig_tc vect_tc arr_tc = do - pa <- builtin paClass - let inst_ty = mkForAllTys tvs - . (mkFunTys $ mkPredTys [ClassP pa [ty] | ty <- arg_tys]) - $ mkPredTy (ClassP pa [mkTyConApp vect_tc arg_tys]) - - dfun <- newExportedVar (mkPADFunOcc $ getOccName vect_tc) inst_ty + dfun_ty <- paDFunType vect_tc + dfun <- newExportedVar (mkPADFunOcc $ getOccName vect_tc) dfun_ty return $ PAInstance { - painstInstance = mkLocalInstance dfun NoOverlap + painstDFun = dfun , painstOrigTyCon = orig_tc , painstVectTyCon = vect_tc , painstArrTyCon = arr_tc } - where - tvs = tyConTyVars arr_tc - arg_tys = mkTyVarTys tvs buildPADict :: PAInstance -> VM [(Var, CoreExpr)] buildPADict (PAInstance { - painstInstance = inst + painstDFun = dfun , painstVectTyCon = vect_tc , painstArrTyCon = arr_tc }) = polyAbstract (tyConTyVars arr_tc) $ \abstract -> @@ -390,10 +383,10 @@ buildPADict (PAInstance { meth_binds <- mapM (mk_method shape) paMethods let meth_exprs = map (Var . fst) meth_binds - pa_dc <- builtin paDictDataCon + pa_dc <- builtin paDataCon let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs) body = Let (Rec meth_binds) dict - return [(instanceDFunId inst, mkInlineMe $ abstract body)] + return [(dfun, mkInlineMe $ abstract body)] where tvs = tyConTyVars arr_tc arg_tys = mkTyVarTys tvs diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index b3c110e..27dd330 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -3,7 +3,7 @@ module VectUtils ( collectAnnValBinders, splitClosureTy, mkPADictType, mkPArrayType, - paDictArgType, paDictOfType, + paDictArgType, paDictOfType, paDFunType, paMethod, lengthPA, replicatePA, emptyPA, liftPA, polyAbstract, polyApply, polyVApply, lookupPArrayFamInst, @@ -97,7 +97,7 @@ mkClosureTypes arg_tys res_ty mkPADictType :: Type -> VM Type mkPADictType ty = do - tc <- builtin paDictTyCon + tc <- builtin paTyCon return $ TyConApp tc [ty] mkPArrayType :: Type -> VM Type @@ -140,11 +140,21 @@ paDictOfTyApp (TyVarTy tv) ty_args paDFunApply dfun ty_args paDictOfTyApp (TyConApp tc _) ty_args = do - pa_class <- builtin paClass - (dfun, ty_args') <- lookupInst pa_class [TyConApp tc ty_args] - paDFunApply (Var dfun) ty_args' + dfun <- maybeV (lookupTyConPA tc) + paDFunApply (Var dfun) ty_args paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty) +paDFunType :: TyCon -> VM Type +paDFunType tc + = do + margs <- mapM paDictArgType tvs + res <- mkPADictType (mkTyConApp tc arg_tys) + return . mkForAllTys tvs + $ mkFunTys [arg | Just arg <- margs] res + where + tvs = tyConTyVars tc + arg_tys = mkTyVarTys tvs + paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr paDFunApply dfun tys = do diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index bb5aa0d..39c6a23 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -69,21 +69,18 @@ vectModule :: ModGuts -> VM ModGuts vectModule guts = do defTyConRdrPAs builtin_PAs - (types', fam_insts, pa_insts) <- vectTypeEnv (mg_types guts) + (types', fam_insts) <- vectTypeEnv (mg_types guts) - let insts = map painstInstance pa_insts - fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts - inst_env' = extendInstEnvList (mg_inst_env guts) insts - updGEnv (setInstEnvs inst_env' fam_inst_env') + let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts + updGEnv (setFamInstEnv fam_inst_env') - dicts <- mapM buildPADict pa_insts - workers <- mapM vectDataConWorkers pa_insts + -- dicts <- mapM buildPADict pa_insts + -- workers <- mapM vectDataConWorkers pa_insts binds' <- mapM vectTopBind (mg_binds guts) return $ guts { mg_types = types' - , mg_binds = Rec (concat workers ++ concat dicts) : binds' - , mg_inst_env = inst_env' + , mg_binds = -- Rec (concat workers ++ concat dicts) : + binds' , mg_fam_inst_env = fam_inst_env' - , mg_insts = mg_insts guts ++ insts , mg_fam_insts = mg_fam_insts guts ++ fam_insts } -- 1.7.10.4