From facf3d6c3a2eefb66ec0ecefb0e8b390ca59ac8c Mon Sep 17 00:00:00 2001 From: Roman Leshchinskiy Date: Fri, 31 Aug 2007 00:59:12 +0000 Subject: [PATCH] Fix vectorisation of nullary data constructors --- compiler/vectorise/VectBuiltIn.hs | 28 +++++++++++----- compiler/vectorise/VectMonad.hs | 2 +- compiler/vectorise/VectType.hs | 66 ++++++++++++++++++++++++++++++------- 3 files changed, 75 insertions(+), 21 deletions(-) diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs index 8f23687..35b446f 100644 --- a/compiler/vectorise/VectBuiltIn.hs +++ b/compiler/vectorise/VectBuiltIn.hs @@ -46,9 +46,11 @@ data Builtins = Builtins { , prTyCon :: TyCon , prDataCon :: DataCon , parrayIntPrimTyCon :: TyCon + , voidTyCon :: TyCon , wrapTyCon :: TyCon , sumTyCons :: Array Int TyCon , closureTyCon :: TyCon + , voidVar :: Var , mkPRVar :: Var , mkClosureVar :: Var , applyClosureVar :: Var @@ -71,8 +73,9 @@ sumTyCon n bi prodTyCon :: Int -> Builtins -> TyCon prodTyCon n bi + | n == 0 = voidTyCon bi | n == 1 = wrapTyCon bi - | n >= 0 && n <= mAX_NDP_PROD = tupleTyCon Boxed n + | n >= 2 && n <= mAX_NDP_PROD = tupleTyCon Boxed n | otherwise = pprPanic "prodTyCon" (ppr n) initBuiltins :: DsM Builtins @@ -87,12 +90,14 @@ initBuiltins parrayIntPrimTyCon <- dsLookupTyCon parrayIntPrimTyConName closureTyCon <- dsLookupTyCon closureTyConName + voidTyCon <- lookupExternalTyCon nDP_REPR FSLIT("Void") wrapTyCon <- lookupExternalTyCon nDP_REPR FSLIT("Wrap") sum_tcs <- mapM (lookupExternalTyCon 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 @@ -117,9 +122,11 @@ initBuiltins , prTyCon = prTyCon , prDataCon = prDataCon , parrayIntPrimTyCon = parrayIntPrimTyCon + , voidTyCon = voidTyCon , wrapTyCon = wrapTyCon , sumTyCons = sumTyCons , closureTyCon = closureTyCon + , voidVar = voidVar , mkPRVar = mkPRVar , mkClosureVar = mkClosureVar , applyClosureVar = applyClosureVar @@ -154,16 +161,18 @@ initBuiltinDicts ps where (tcs, mods, fss) = unzip3 ps -initBuiltinPAs = initBuiltinDicts builtinPAs +initBuiltinPAs = initBuiltinDicts . builtinPAs -builtinPAs :: [(Name, Module, FastString)] -builtinPAs = [ - mk closureTyConName nDP_CLOSURE FSLIT("dPA_Clo") - , mk unitTyConName nDP_INSTANCES FSLIT("dPA_Unit") +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 intTyConName nDP_INSTANCES FSLIT("dPA_Int") - ] - ++ tups + , mk intTyConName nDP_INSTANCES FSLIT("dPA_Int") + ] + ++ tups where mk name mod fs = (name, mod, fs) @@ -178,6 +187,7 @@ 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") diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index b60a67c..cf71a00 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -463,7 +463,7 @@ initV hsc_env guts info p do builtins <- initBuiltins builtin_tycons <- initBuiltinTyCons - builtin_pas <- initBuiltinPAs + builtin_pas <- initBuiltinPAs builtins builtin_prs <- initBuiltinPRs builtins eps <- ioToIOEnv $ hscEPS hsc_env diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 4ff1711..ca5f0c8 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -226,6 +226,20 @@ data Repr = ProdRepr { | IdRepr Type + | VoidRepr { + void_tycon :: TyCon + , void_bottom :: CoreExpr + } + +mkVoid :: VM Repr +mkVoid = do + tycon <- builtin voidTyCon + var <- builtin voidVar + return $ VoidRepr { + void_tycon = tycon + , void_bottom = Var var + } + mkProduct :: [Type] -> VM Repr mkProduct tys = do @@ -246,6 +260,7 @@ mkProduct tys arity = length tys mkSubProduct :: [Type] -> VM Repr +mkSubProduct [] = mkVoid mkSubProduct [ty] = return $ IdRepr ty mkSubProduct tys = mkProduct tys @@ -275,6 +290,7 @@ reprType (ProdRepr { prod_tycon = tycon, prod_components = tys }) reprType (SumRepr { sum_tycon = tycon, sum_components = reprs }) = mkTyConApp tycon (map reprType reprs) reprType (IdRepr ty) = ty +reprType (VoidRepr { void_tycon = tycon }) = mkTyConApp tycon [] arrReprType :: Repr -> VM Type arrReprType = mkPArrayType . reprType @@ -286,6 +302,7 @@ arrShapeTys (SumRepr {}) return [intPrimTy, mkTyConApp int_arr [], mkTyConApp int_arr []] arrShapeTys (ProdRepr {}) = return [intPrimTy] arrShapeTys (IdRepr _) = return [] +arrShapeTys (VoidRepr {}) = return [intPrimTy] arrShapeVars :: Repr -> VM [Var] arrShapeVars repr = mapM (newLocalVar FSLIT("sh")) =<< arrShapeTys repr @@ -298,22 +315,31 @@ replicateShape (SumRepr {}) len tag up <- builtin upToPAIntPrimVar return [len, Var rep `mkApps` [len, tag], Var up `App` len] replicateShape (IdRepr _) _ _ = return [] +replicateShape (VoidRepr {}) len _ = return [len] -arrReprElemTys :: Repr -> [[Type]] +arrReprElemTys :: Repr -> VM [[Type]] arrReprElemTys (SumRepr { sum_components = prods }) - = map arrProdElemTys prods + = mapM arrProdElemTys prods arrReprElemTys prod@(ProdRepr {}) - = [arrProdElemTys prod] -arrReprElemTys (IdRepr ty) = [[ty]] + = do + tys <- arrProdElemTys prod + return [tys] +arrReprElemTys (IdRepr ty) = return [[ty]] +arrReprElemTys (VoidRepr { void_tycon = tycon }) + = return [[mkTyConApp tycon []]] arrProdElemTys (ProdRepr { prod_components = [] }) - = [unitTy] + = do + void <- builtin voidTyCon + return [mkTyConApp void []] arrProdElemTys (ProdRepr { prod_components = tys }) - = tys -arrProdElemTys (IdRepr ty) = [ty] + = return tys +arrProdElemTys (IdRepr ty) = return [ty] +arrProdElemTys (VoidRepr { void_tycon = tycon }) + = return [mkTyConApp tycon []] arrReprTys :: Repr -> VM [[Type]] -arrReprTys = mapM (mapM mkPArrayType) . arrReprElemTys +arrReprTys repr = mapM (mapM mkPArrayType) =<< arrReprElemTys repr arrReprVars :: Repr -> VM [[Var]] arrReprVars repr @@ -376,6 +402,10 @@ buildToPRepr repr vect_tc prepr_tc _ var <- newLocalVar FSLIT("y") ty return ([var], Var var) + prod_alt (VoidRepr { void_bottom = bottom }) + = return ([], bottom) + + buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr buildFromPRepr repr vect_tc prepr_tc _ = do @@ -418,6 +448,9 @@ buildFromPRepr repr vect_tc prepr_tc _ from_prod (IdRepr _) con expr = return $ con `App` expr + from_prod (VoidRepr {}) con expr + = return con + buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr buildToArrPRepr repr vect_tc prepr_tc arr_tc = do @@ -483,8 +516,9 @@ buildToArrPRepr repr vect_tc prepr_tc arr_tc . mkConApp data_con $ map Type tys ++ len : map Var repr_vars - to_prod [var] (IdRepr ty) - = return (Var var) + to_prod [var] (IdRepr ty) = return (Var var) + to_prod [var] (VoidRepr {}) = return (Var var) + buildFromArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr buildFromArrPRepr repr vect_tc prepr_tc arr_tc @@ -571,7 +605,17 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc body = return $ Let (NonRec repr_var expr) body + from_prod (VoidRepr {}) + expr + shape_vars + [repr_var] + res_ty + body + = return $ Let (NonRec repr_var expr) body + buildPRDictRepr :: Repr -> VM CoreExpr +buildPRDictRepr (VoidRepr { void_tycon = tycon }) + = prDFunOfTyCon tycon buildPRDictRepr (IdRepr ty) = mkPR ty buildPRDictRepr (ProdRepr { prod_components = tys @@ -679,6 +723,7 @@ vectDataConWorkers :: Repr -> TyCon -> TyCon -> TyCon -> VM () vectDataConWorkers repr orig_tc vect_tc arr_tc = do + arr_tys <- arrReprElemTys repr bs <- sequence . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys $ zipWith4 mk_data_con (tyConDataCons vect_tc) @@ -694,7 +739,6 @@ vectDataConWorkers repr orig_tc vect_tc arr_tc res_ty = mkTyConApp vect_tc var_tys rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc - arr_tys = arrReprElemTys repr [arr_dc] = tyConDataCons arr_tc -- 1.7.10.4