From f64384c40b3db4fddb8fad5463da39464e52ab13 Mon Sep 17 00:00:00 2001 From: Roman Leshchinskiy Date: Fri, 31 Aug 2007 04:54:11 +0000 Subject: [PATCH] Remove NDP-related stuff from PrelNames We don't need fixed Names for NDP built-ins. Instead, we can look them up ourselves during VM initialisation. --- compiler/prelude/PrelNames.lhs | 69 ---------------------------- compiler/vectorise/VectBuiltIn.hs | 90 +++++++++++++++++++------------------ compiler/vectorise/VectMonad.hs | 2 +- compiler/vectorise/VectType.hs | 4 +- compiler/vectorise/VectUtils.hs | 45 +++---------------- compiler/vectorise/Vectorise.hs | 10 +++-- 6 files changed, 61 insertions(+), 159 deletions(-) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 2740d26..6c4a335 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -104,7 +104,6 @@ basicKnownKeyNames :: [Name] basicKnownKeyNames = genericTyConNames ++ typeableClassNames - ++ ndpNames ++ [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, runMainIOName, @@ -215,17 +214,6 @@ basicKnownKeyNames genericTyConNames :: [Name] genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] - -ndpNames :: [Name] -ndpNames = [ parrayTyConName, paTyConName, preprTyConName, prTyConName - , parrayIntPrimTyConName - , mkPRName - , closureTyConName - , mkClosureName, applyClosureName - , mkClosurePName, applyClosurePName - , replicatePAIntPrimName, upToPAIntPrimName - , lengthPAName, replicatePAName, emptyPAName, packPAName, - combinePAName ] \end{code} @@ -277,12 +265,6 @@ aRROW = mkBaseModule FSLIT("Control.Arrow") rANDOM = mkBaseModule FSLIT("System.Random") gLA_EXTS = mkBaseModule FSLIT("GHC.Exts") -nDP_PARRAY = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.PArray") -nDP_REPR = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Repr") -nDP_CLOSURE = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Closure") -nDP_PRIM = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Prim") -nDP_INSTANCES = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Instances") - mAIN = mkMainModule_ mAIN_NAME rOOT_MAIN = mkMainModule FSLIT(":Main") -- Root module for initialisation @@ -302,12 +284,6 @@ mkBaseModule m = mkModule basePackageId (mkModuleNameFS m) mkBaseModule_ :: ModuleName -> Module mkBaseModule_ m = mkModule basePackageId m -mkNDPModule :: FastString -> Module -mkNDPModule m = mkModule ndpPackageId (mkModuleNameFS m) - -mkNDPModule_ :: ModuleName -> Module -mkNDPModule_ m = mkModule ndpPackageId m - mkMainModule :: FastString -> Module mkMainModule m = mkModule mainPackageId (mkModuleNameFS m) @@ -694,28 +670,6 @@ marshalObjectName = varQual dOTNET FSLIT("marshalObject") marshalObjectIdKey marshalStringName = varQual dOTNET FSLIT("marshalString") marshalStringIdKey unmarshalStringName = varQual dOTNET FSLIT("unmarshalString") unmarshalStringIdKey checkDotnetResName = varQual dOTNET FSLIT("checkResult") checkDotnetResNameIdKey - --- NDP stuff -parrayTyConName = tcQual nDP_PARRAY FSLIT("PArray") parrayTyConKey -paTyConName = tcQual nDP_PARRAY FSLIT("PA") paTyConKey -preprTyConName = tcQual nDP_PARRAY FSLIT("PRepr") preprTyConKey -prTyConName = tcQual nDP_PARRAY FSLIT("PR") prTyConKey -parrayIntPrimTyConName = tcQual nDP_PRIM FSLIT("PArray_Int#") - parrayIntPrimTyConKey -mkPRName = varQual nDP_PARRAY FSLIT("mkPR") mkPRIdKey -replicatePAIntPrimName = varQual nDP_PRIM FSLIT("replicatePA_Int#") - replicatePAIntPrimIdKey -upToPAIntPrimName = varQual nDP_PRIM FSLIT("upToPA_Int#") upToPAIntPrimIdKey -lengthPAName = varQual nDP_PARRAY FSLIT("lengthPA") lengthPAIdKey -replicatePAName = varQual nDP_PARRAY FSLIT("replicatePA") replicatePAIdKey -emptyPAName = varQual nDP_PARRAY FSLIT("emptyPA") emptyPAIdKey -packPAName = varQual nDP_PARRAY FSLIT("packPA") packPAIdKey -combinePAName = varQual nDP_PARRAY FSLIT("combinePA") combinePAIdKey -closureTyConName = tcQual nDP_CLOSURE FSLIT(":->") closureTyConKey -mkClosureName = varQual nDP_CLOSURE FSLIT("mkClosure") mkClosureIdKey -applyClosureName = varQual nDP_CLOSURE FSLIT("$:") applyClosureIdKey -mkClosurePName = varQual nDP_CLOSURE FSLIT("mkClosureP") mkClosurePIdKey -applyClosurePName = varQual nDP_CLOSURE FSLIT("$:^") applyClosurePIdKey \end{code} %************************************************************************ @@ -895,14 +849,6 @@ opaqueTyConKey = mkPreludeTyConUnique 133 stringTyConKey = mkPreludeTyConUnique 134 -parrayTyConKey = mkPreludeTyConUnique 135 -closureTyConKey = mkPreludeTyConUnique 136 -paTyConKey = mkPreludeTyConUnique 137 -preprTyConKey = mkPreludeTyConUnique 138 -prTyConKey = mkPreludeTyConUnique 139 -parrayIntPrimTyConKey = mkPreludeTyConUnique 140 - - ---------------- Template Haskell ------------------- -- USES TyConUniques 100-129 ----------------------------------------------------- @@ -1082,21 +1028,6 @@ loopAIdKey = mkPreludeMiscIdUnique 124 fromStringClassOpKey = mkPreludeMiscIdUnique 125 --- Flattened parallel array functions -mkClosureIdKey = mkPreludeMiscIdUnique 126 -applyClosureIdKey = mkPreludeMiscIdUnique 127 -mkClosurePIdKey = mkPreludeMiscIdUnique 128 -applyClosurePIdKey = mkPreludeMiscIdUnique 129 -closurePAIdKey = mkPreludeMiscIdUnique 130 -lengthPAIdKey = mkPreludeMiscIdUnique 131 -replicatePAIdKey = mkPreludeMiscIdUnique 132 -emptyPAIdKey = mkPreludeMiscIdUnique 133 -packPAIdKey = mkPreludeMiscIdUnique 134 -combinePAIdKey = mkPreludeMiscIdUnique 135 -mkPRIdKey = mkPreludeMiscIdUnique 136 -replicatePAIntPrimIdKey = mkPreludeMiscIdUnique 137 -upToPAIntPrimIdKey = mkPreludeMiscIdUnique 138 - ---------------- Template Haskell ------------------- -- USES IdUniques 200-399 ----------------------------------------------------- diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs index 4f27b1e..05b1289 100644 --- a/compiler/vectorise/VectBuiltIn.hs +++ b/compiler/vectorise/VectBuiltIn.hs @@ -23,7 +23,8 @@ import TypeRep ( funTyCon ) import Type ( Type ) import TysPrim import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName ) -import PrelNames +import Module ( Module, mkModule, mkModuleNameFS ) +import PackageConfig ( ndpPackageId ) import BasicTypes ( Boxity(..) ) import FastString @@ -38,6 +39,15 @@ mAX_NDP_PROD = 3 mAX_NDP_SUM :: Int mAX_NDP_SUM = 3 +mkNDPModule :: FastString -> Module +mkNDPModule m = mkModule ndpPackageId (mkModuleNameFS m) + +nDP_PARRAY = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.PArray") +nDP_REPR = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Repr") +nDP_CLOSURE = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Closure") +nDP_PRIM = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Prim") +nDP_INSTANCES = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Instances") + data Builtins = Builtins { parrayTyCon :: TyCon , paTyCon :: TyCon @@ -80,33 +90,33 @@ prodTyCon n bi initBuiltins :: DsM Builtins initBuiltins = do - parrayTyCon <- dsLookupTyCon parrayTyConName - paTyCon <- dsLookupTyCon paTyConName + parrayTyCon <- externalTyCon nDP_PARRAY FSLIT("PArray") + paTyCon <- externalTyCon nDP_PARRAY FSLIT("PA") let [paDataCon] = tyConDataCons paTyCon - preprTyCon <- dsLookupTyCon preprTyConName - prTyCon <- dsLookupTyCon prTyConName + preprTyCon <- externalTyCon nDP_PARRAY FSLIT("PRepr") + prTyCon <- externalTyCon nDP_PARRAY FSLIT("PR") let [prDataCon] = tyConDataCons prTyCon - parrayIntPrimTyCon <- dsLookupTyCon parrayIntPrimTyConName - closureTyCon <- dsLookupTyCon closureTyConName + parrayIntPrimTyCon <- externalTyCon nDP_PRIM FSLIT("PArray_Int#") + closureTyCon <- externalTyCon nDP_CLOSURE FSLIT(":->") - voidTyCon <- lookupExternalTyCon nDP_REPR FSLIT("Void") - wrapTyCon <- lookupExternalTyCon nDP_REPR FSLIT("Wrap") - sum_tcs <- mapM (lookupExternalTyCon nDP_REPR) + voidTyCon <- externalTyCon nDP_REPR FSLIT("Void") + wrapTyCon <- externalTyCon nDP_REPR FSLIT("Wrap") + sum_tcs <- mapM (externalTyCon nDP_REPR) [mkFastString ("Sum" ++ show i) | i <- [2..mAX_NDP_SUM]] let sumTyCons = listArray (2, mAX_NDP_SUM) sum_tcs - voidVar <- lookupExternalVar nDP_REPR FSLIT("void") - mkPRVar <- dsLookupGlobalId mkPRName - mkClosureVar <- dsLookupGlobalId mkClosureName - applyClosureVar <- dsLookupGlobalId applyClosureName - mkClosurePVar <- dsLookupGlobalId mkClosurePName - applyClosurePVar <- dsLookupGlobalId applyClosurePName - replicatePAIntPrimVar <- dsLookupGlobalId replicatePAIntPrimName - upToPAIntPrimVar <- dsLookupGlobalId upToPAIntPrimName - lengthPAVar <- dsLookupGlobalId lengthPAName - replicatePAVar <- dsLookupGlobalId replicatePAName - emptyPAVar <- dsLookupGlobalId emptyPAName + voidVar <- externalVar nDP_REPR FSLIT("void") + mkPRVar <- externalVar nDP_PARRAY FSLIT("mkPR") + mkClosureVar <- externalVar nDP_CLOSURE FSLIT("mkClosure") + applyClosureVar <- externalVar nDP_CLOSURE FSLIT("$:") + mkClosurePVar <- externalVar nDP_CLOSURE FSLIT("mkClosureP") + applyClosurePVar <- externalVar nDP_CLOSURE FSLIT("$:^") + replicatePAIntPrimVar <- externalVar nDP_PRIM FSLIT("replicatePA_Int#") + upToPAIntPrimVar <- externalVar nDP_PRIM FSLIT("upToPA_Int#") + lengthPAVar <- externalVar nDP_PARRAY FSLIT("lengthPA") + replicatePAVar <- externalVar nDP_PARRAY FSLIT("replicatePA") + emptyPAVar <- externalVar nDP_PARRAY FSLIT("emptyPA") -- packPAVar <- dsLookupGlobalId packPAName -- combinePAVar <- dsLookupGlobalId combinePAName @@ -141,21 +151,13 @@ initBuiltins , liftingContext = liftingContext } -initBuiltinTyCons :: DsM [(Name, TyCon)] -initBuiltinTyCons - = do - vects <- sequence vs - return (zip origs vects) - where - (origs, vs) = unzip builtinTyCons - -builtinTyCons :: [(Name, DsM TyCon)] -builtinTyCons = [(tyConName funTyCon, dsLookupTyCon closureTyConName)] +initBuiltinTyCons :: Builtins -> [(Name, TyCon)] +initBuiltinTyCons bi = [(tyConName funTyCon, closureTyCon bi)] initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)] initBuiltinDicts ps = do - dicts <- zipWithM lookupExternalVar mods fss + dicts <- zipWithM externalVar mods fss return $ zip tcs dicts where (tcs, mods, fss) = unzip3 ps @@ -165,11 +167,11 @@ initBuiltinPAs = initBuiltinDicts . builtinPAs builtinPAs :: Builtins -> [(Name, Module, FastString)] builtinPAs bi = [ - mk closureTyConName nDP_CLOSURE FSLIT("dPA_Clo") - , mk (tyConName $ voidTyCon bi) nDP_REPR FSLIT("dPA_Void") - , mk unitTyConName nDP_INSTANCES FSLIT("dPA_Unit") + mk (tyConName $ closureTyCon bi) nDP_CLOSURE FSLIT("dPA_Clo") + , mk (tyConName $ voidTyCon bi) nDP_REPR FSLIT("dPA_Void") + , mk unitTyConName nDP_INSTANCES FSLIT("dPA_Unit") - , mk intTyConName nDP_INSTANCES FSLIT("dPA_Int") + , mk intTyConName nDP_INSTANCES FSLIT("dPA_Int") ] ++ tups where @@ -185,10 +187,10 @@ initBuiltinPRs = initBuiltinDicts . builtinPRs builtinPRs :: Builtins -> [(Name, Module, FastString)] builtinPRs bi = [ - mk (tyConName unitTyCon) nDP_REPR FSLIT("dPR_Unit") - , mk (tyConName $ voidTyCon bi) nDP_REPR FSLIT("dPR_Void") - , mk (tyConName $ wrapTyCon bi) nDP_REPR FSLIT("dPR_Wrap") - , mk closureTyConName nDP_CLOSURE FSLIT("dPR_Clo") + mk (tyConName unitTyCon) nDP_REPR FSLIT("dPR_Unit") + , mk (tyConName $ voidTyCon bi) nDP_REPR FSLIT("dPR_Void") + , mk (tyConName $ wrapTyCon bi) nDP_REPR FSLIT("dPR_Wrap") + , mk (tyConName $ closureTyCon bi) nDP_CLOSURE FSLIT("dPR_Clo") -- temporary , mk intTyConName nDP_INSTANCES FSLIT("dPR_Int") @@ -205,12 +207,12 @@ builtinPRs bi = mk_prod n = (tyConName $ prodTyCon n bi, nDP_REPR, mkFastString ("dPR_" ++ show n)) -lookupExternalVar :: Module -> FastString -> DsM Var -lookupExternalVar mod fs +externalVar :: Module -> FastString -> DsM Var +externalVar mod fs = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs) -lookupExternalTyCon :: Module -> FastString -> DsM TyCon -lookupExternalTyCon mod fs +externalTyCon :: Module -> FastString -> DsM TyCon +externalTyCon mod fs = dsLookupTyCon =<< lookupOrig mod (mkOccNameFS tcName fs) unitTyConName = tyConName unitTyCon diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index cf71a00..56aeb14 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -462,7 +462,7 @@ initV hsc_env guts info p go = do builtins <- initBuiltins - builtin_tycons <- initBuiltinTyCons + let builtin_tycons = initBuiltinTyCons builtins builtin_pas <- initBuiltinPAs builtins builtin_prs <- initBuiltinPRs builtins diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 77cb429..aa8e4f8 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -585,11 +585,11 @@ buildToArrPRepr repr vect_tc prepr_tc arr_tc $ mkConApp data_con [Var len_var, Var repr_var] to_prod repr_vars@(r : _) - (ProdRepr { prod_components = tys + (ProdRepr { prod_components = tys@(ty : _) , prod_arr_tycon = tycon , prod_arr_data_con = data_con }) = do - len <- lengthPA (Var r) + len <- lengthPA ty (Var r) return . wrapFamInstBody tycon tys . mkConApp data_con $ map Type tys ++ len : map Var repr_vars diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 1fb268f..42bcab3 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -2,7 +2,6 @@ module VectUtils ( collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg, collectAnnValBinders, mkDataConTag, mkDataConTagLit, - splitClosureTy, mkBuiltinCo, mkPADictType, mkPArrayType, mkPReprType, @@ -75,36 +74,6 @@ mkDataConTagLit con mkDataConTag :: DataCon -> CoreExpr mkDataConTag con = mkIntLitInt (dataConTag con - fIRST_TAG) -splitUnTy :: String -> Name -> Type -> Type -splitUnTy s name ty - | Just (tc, [ty']) <- splitTyConApp_maybe ty - , tyConName tc == name - = ty' - - | otherwise = pprPanic s (ppr ty) - -splitBinTy :: String -> Name -> Type -> (Type, Type) -splitBinTy s name ty - | Just (tc, [ty1, ty2]) <- splitTyConApp_maybe ty - , tyConName tc == name - = (ty1, ty2) - - | otherwise = pprPanic s (ppr ty) - -splitFixedTyConApp :: TyCon -> Type -> [Type] -splitFixedTyConApp tc ty - | Just (tc', tys) <- splitTyConApp_maybe ty - , tc == tc' - = tys - - | otherwise = pprPanic "splitFixedTyConApp" (ppr tc <+> ppr ty) - -splitClosureTy :: Type -> (Type, Type) -splitClosureTy = splitBinTy "splitClosureTy" closureTyConName - -splitPArrayTy :: Type -> Type -splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName - splitPrimTyCon :: Type -> Maybe TyCon splitPrimTyCon ty | Just (tycon, []) <- splitTyConApp_maybe ty @@ -267,10 +236,8 @@ mkPR ty dict <- paDictOfType ty return $ mkApps (Var fn) [Type ty, dict] -lengthPA :: CoreExpr -> VM CoreExpr -lengthPA x = liftM (`App` x) (paMethod pa_length ty) - where - ty = splitPArrayTy (exprType x) +lengthPA :: Type -> CoreExpr -> VM CoreExpr +lengthPA ty x = liftM (`App` x) (paMethod pa_length ty) replicatePA :: CoreExpr -> CoreExpr -> VM CoreExpr replicatePA len x = liftM (`mkApps` [len,x]) @@ -364,15 +331,13 @@ mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv], Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv]) -mkClosureApp :: VExpr -> VExpr -> VM VExpr -mkClosureApp (vclo, lclo) (varg, larg) +mkClosureApp :: Type -> Type -> VExpr -> VExpr -> VM VExpr +mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg) = do vapply <- builtin applyClosureVar lapply <- builtin applyClosurePVar return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg], Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [lclo, larg]) - where - (arg_ty, res_ty) = splitClosureTy (exprType vclo) buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr buildClosures tvs vars [] res_ty mk_body @@ -441,7 +406,7 @@ mkLiftEnv :: Var -> [Type] -> [Var] -> VM (CoreExpr, CoreExpr -> CoreExpr -> VM mkLiftEnv lc [ty] [v] = return (Var v, \env body -> do - len <- lengthPA (Var v) + len <- lengthPA ty (Var v) return . Let (NonRec v env) $ Case len lc (exprType body) [(DEFAULT, [], body)]) diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 85f4e46..ada4956 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -211,9 +211,13 @@ vectExpr e@(_, AnnApp _ arg) vectExpr (_, AnnApp fn arg) = do - fn' <- vectExpr fn - arg' <- vectExpr arg - mkClosureApp fn' arg' + arg_ty' <- vectType arg_ty + res_ty' <- vectType res_ty + fn' <- vectExpr fn + arg' <- vectExpr arg + mkClosureApp arg_ty' res_ty' fn' arg' + where + (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn vectExpr (_, AnnCase scrut bndr ty alts) | isAlgType scrut_ty -- 1.7.10.4