From: Roman Leshchinskiy Date: Mon, 13 Jul 2009 04:42:12 +0000 (+0000) Subject: Separate length from data in DPH arrays X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3736e30f683990ee94055b60905cce208a467e8b;p=ghc-hetmet.git Separate length from data in DPH arrays --- diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index e54c858..6f5267d 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -57,7 +57,7 @@ module OccName ( mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPArrayTyConOcc, mkPArrayDataConOcc, + mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc, @@ -529,7 +529,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPArrayTyConOcc, mkPArrayDataConOcc, mkPReprTyConOcc, mkPADFunOcc + mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc :: OccName -> OccName -- These derived variables have a prefix that no Haskell value could have @@ -568,8 +568,8 @@ mkVectOcc = mk_simple_deriv varName "$v_" mkVectTyConOcc = mk_simple_deriv tcName ":V_" mkVectDataConOcc = mk_simple_deriv dataName ":VD_" mkVectIsoOcc = mk_simple_deriv varName "$VI_" -mkPArrayTyConOcc = mk_simple_deriv tcName ":VP_" -mkPArrayDataConOcc = mk_simple_deriv dataName ":VPD_" +mkPDataTyConOcc = mk_simple_deriv tcName ":VP_" +mkPDataDataConOcc = mk_simple_deriv dataName ":VPD_" mkPReprTyConOcc = mk_simple_deriv tcName ":VR_" mkPADFunOcc = mk_simple_deriv varName "$PA_" diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs index 4fe7e9e..16b23ab 100644 --- a/compiler/vectorise/VectBuiltIn.hs +++ b/compiler/vectorise/VectBuiltIn.hs @@ -1,6 +1,7 @@ module VectBuiltIn ( - Builtins(..), sumTyCon, prodTyCon, - combinePAVar, scalarZip, closureCtrFun, + Builtins(..), sumTyCon, prodTyCon, prodDataCon, + selTy, selReplicate, selPick, selElements, + combinePDVar, scalarZip, closureCtrFun, initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, initBuiltinPAs, initBuiltinPRs, initBuiltinBoxedTyCons, initBuiltinScalars, @@ -15,6 +16,7 @@ import Module import DataCon ( DataCon, dataConName, dataConWorkId ) import TyCon ( TyCon, tyConName, tyConDataCons ) import Class ( Class ) +import CoreSyn ( CoreExpr, Expr(..) ) import Var ( Var ) import Id ( mkSysLocal ) import Name ( Name, getOccString ) @@ -44,7 +46,7 @@ mAX_DPH_PROD :: Int mAX_DPH_PROD = 5 mAX_DPH_SUM :: Int -mAX_DPH_SUM = 3 +mAX_DPH_SUM = 2 mAX_DPH_COMBINE :: Int mAX_DPH_COMBINE = 2 @@ -60,6 +62,7 @@ data Modules = Modules { , dph_Instances :: Module , dph_Combinators :: Module , dph_Scalar :: Module + , dph_Selector :: Module , dph_Prelude_PArr :: Module , dph_Prelude_Int :: Module , dph_Prelude_Word8 :: Module @@ -77,6 +80,7 @@ dph_Modules pkg = Modules { , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances") , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators") , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar") + , dph_Selector = mk (fsLit "Data.Array.Parallel.Lifted.Selector") , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr") , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int") @@ -92,42 +96,61 @@ dph_Modules pkg = Modules { data Builtins = Builtins { dphModules :: Modules , parrayTyCon :: TyCon + , parrayDataCon :: DataCon + , pdataTyCon :: TyCon , paTyCon :: TyCon , paDataCon :: DataCon , preprTyCon :: TyCon , prTyCon :: TyCon , prDataCon :: DataCon - , intPrimArrayTy :: Type , voidTyCon :: TyCon , wrapTyCon :: TyCon - , enumerationTyCon :: TyCon + , selTys :: Array Int Type + , selReplicates :: Array Int CoreExpr + , selPicks :: Array Int CoreExpr + , selEls :: Array (Int, Int) CoreExpr , sumTyCons :: Array Int TyCon , closureTyCon :: TyCon , voidVar :: Var + , pvoidVar :: Var + , punitVar :: Var , mkPRVar :: Var - , mkClosureVar :: Var - , applyClosureVar :: Var - , mkClosurePVar :: Var - , applyClosurePVar :: Var - , replicatePAIntPrimVar :: Var - , upToPAIntPrimVar :: Var - , selectPAIntPrimVar :: Var - , truesPABoolPrimVar :: Var - , lengthPAVar :: Var - , replicatePAVar :: Var - , emptyPAVar :: Var - , packPAVar :: Var - , combinePAVars :: Array Int Var + , closureVar :: Var + , applyVar :: Var + , liftedClosureVar :: Var + , liftedApplyVar :: Var + , replicatePDVar :: Var + , emptyPDVar :: Var + , packPDVar :: Var + , combinePDVars :: Array Int Var , scalarClass :: Class , scalarZips :: Array Int Var , closureCtrFuns :: Array Int Var , liftingContext :: Var } +indexBuiltin :: (Ix i, Outputable i) => String -> (Builtins -> Array i a) + -> i -> Builtins -> a +indexBuiltin fn f i bi + | inRange (bounds xs) i = xs ! i + | otherwise = pprPanic fn (ppr i) + where + xs = f bi + +selTy :: Int -> Builtins -> Type +selTy = indexBuiltin "selTy" selTys + +selReplicate :: Int -> Builtins -> CoreExpr +selReplicate = indexBuiltin "selReplicate" selReplicates + +selPick :: Int -> Builtins -> CoreExpr +selPick = indexBuiltin "selPick" selPicks + +selElements :: Int -> Int -> Builtins -> CoreExpr +selElements i j = indexBuiltin "selElements" selEls (i,j) + sumTyCon :: Int -> Builtins -> TyCon -sumTyCon n bi - | n >= 2 && n <= mAX_DPH_SUM = sumTyCons bi ! n - | otherwise = pprPanic "sumTyCon" (ppr n) +sumTyCon = indexBuiltin "sumTyCon" sumTyCons prodTyCon :: Int -> Builtins -> TyCon prodTyCon n bi @@ -135,72 +158,77 @@ prodTyCon n bi | n >= 0 && n <= mAX_DPH_PROD = tupleTyCon Boxed n | otherwise = pprPanic "prodTyCon" (ppr n) -combinePAVar :: Int -> Builtins -> Var -combinePAVar n bi - | n >= 2 && n <= mAX_DPH_COMBINE = combinePAVars bi ! n - | otherwise = pprPanic "combinePAVar" (ppr n) +prodDataCon :: Int -> Builtins -> DataCon +prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of + [con] -> con + +combinePDVar :: Int -> Builtins -> Var +combinePDVar = indexBuiltin "combinePDVar" combinePDVars scalarZip :: Int -> Builtins -> Var -scalarZip n bi - | n >= 1 && n <= mAX_DPH_SCALAR_ARGS = scalarZips bi ! n - | otherwise = pprPanic "scalarZip" (ppr n) +scalarZip = indexBuiltin "scalarZip" scalarZips closureCtrFun :: Int -> Builtins -> Var -closureCtrFun n bi - | n >= 1 && n <= mAX_DPH_SCALAR_ARGS = closureCtrFuns bi ! n - | otherwise = pprPanic "closureCtrFun" (ppr n) +closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns initBuiltins :: PackageId -> DsM Builtins initBuiltins pkg = do parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray") + let [parrayDataCon] = tyConDataCons parrayTyCon + pdataTyCon <- externalTyCon dph_PArray (fsLit "PData") paTyCon <- externalTyCon dph_PArray (fsLit "PA") let [paDataCon] = tyConDataCons paTyCon preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr") prTyCon <- externalTyCon dph_PArray (fsLit "PR") let [prDataCon] = tyConDataCons prTyCon - intPrimArrayTy <- externalType dph_Unboxed (fsLit "PArray_Int#") closureTyCon <- externalTyCon dph_Closure (fsLit ":->") voidTyCon <- externalTyCon dph_Repr (fsLit "Void") wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap") - enumerationTyCon <- externalTyCon dph_Repr (fsLit "Enumeration") - sum_tcs <- mapM (externalTyCon dph_Repr) - [mkFastString ("Sum" ++ show i) | i <- [2..mAX_DPH_SUM]] - - let sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs + sel_tys <- mapM (externalType dph_Selector) + (numbered "Sel" 2 mAX_DPH_SUM) + sel_replicates <- mapM (externalFun dph_Selector) + (numbered "replicate" 2 mAX_DPH_SUM) + sel_picks <- mapM (externalFun dph_Selector) + (numbered "pick" 2 mAX_DPH_SUM) + sel_els <- mapM mk_elements + [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] + sum_tcs <- mapM (externalTyCon dph_Repr) + (numbered "Sum" 2 mAX_DPH_SUM) + + let selTys = listArray (2, mAX_DPH_SUM) sel_tys + selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates + selPicks = listArray (2, mAX_DPH_SUM) sel_picks + selEls = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els + sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs voidVar <- externalVar dph_Repr (fsLit "void") + pvoidVar <- externalVar dph_Repr (fsLit "pvoid") + punitVar <- externalVar dph_Repr (fsLit "punit") mkPRVar <- externalVar dph_PArray (fsLit "mkPR") - mkClosureVar <- externalVar dph_Closure (fsLit "mkClosure") - applyClosureVar <- externalVar dph_Closure (fsLit "$:") - mkClosurePVar <- externalVar dph_Closure (fsLit "mkClosureP") - applyClosurePVar <- externalVar dph_Closure (fsLit "$:^") - replicatePAIntPrimVar <- externalVar dph_Unboxed (fsLit "replicatePA_Int#") - upToPAIntPrimVar <- externalVar dph_Unboxed (fsLit "upToPA_Int#") - selectPAIntPrimVar <- externalVar dph_Unboxed (fsLit "selectPA_Int#") - truesPABoolPrimVar <- externalVar dph_Unboxed (fsLit "truesPA_Bool#") - lengthPAVar <- externalVar dph_PArray (fsLit "lengthPA#") - replicatePAVar <- externalVar dph_PArray (fsLit "replicatePA#") - emptyPAVar <- externalVar dph_PArray (fsLit "emptyPA") - packPAVar <- externalVar dph_PArray (fsLit "packPA#") + closureVar <- externalVar dph_Closure (fsLit "closure") + applyVar <- externalVar dph_Closure (fsLit "$:") + liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") + liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") + replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD") + emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD") + packPDVar <- externalVar dph_PArray (fsLit "packPD") combines <- mapM (externalVar dph_PArray) - [mkFastString ("combine" ++ show i ++ "PA#") + [mkFastString ("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]] - let combinePAVars = listArray (2, mAX_DPH_COMBINE) combines + let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines scalarClass <- externalClass dph_Scalar (fsLit "Scalar") scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") scalar_zips <- mapM (externalVar dph_Scalar) - [mkFastString ("scalar_zipWith" ++ show i) - | i <- [3 .. mAX_DPH_SCALAR_ARGS]] + (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips) closures <- mapM (externalVar dph_Closure) - [mkFastString ("closure" ++ show i) - | i <- [1 .. mAX_DPH_SCALAR_ARGS]] + (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) @@ -209,32 +237,33 @@ initBuiltins pkg return $ Builtins { dphModules = modules , parrayTyCon = parrayTyCon + , parrayDataCon = parrayDataCon + , pdataTyCon = pdataTyCon , paTyCon = paTyCon , paDataCon = paDataCon , preprTyCon = preprTyCon , prTyCon = prTyCon , prDataCon = prDataCon - , intPrimArrayTy = intPrimArrayTy , voidTyCon = voidTyCon , wrapTyCon = wrapTyCon - , enumerationTyCon = enumerationTyCon + , selTys = selTys + , selReplicates = selReplicates + , selPicks = selPicks + , selEls = selEls , sumTyCons = sumTyCons , closureTyCon = closureTyCon , voidVar = voidVar + , pvoidVar = pvoidVar + , punitVar = punitVar , mkPRVar = mkPRVar - , mkClosureVar = mkClosureVar - , applyClosureVar = applyClosureVar - , mkClosurePVar = mkClosurePVar - , applyClosurePVar = applyClosurePVar - , replicatePAIntPrimVar = replicatePAIntPrimVar - , upToPAIntPrimVar = upToPAIntPrimVar - , selectPAIntPrimVar = selectPAIntPrimVar - , truesPABoolPrimVar = truesPABoolPrimVar - , lengthPAVar = lengthPAVar - , replicatePAVar = replicatePAVar - , emptyPAVar = emptyPAVar - , packPAVar = packPAVar - , combinePAVars = combinePAVars + , closureVar = closureVar + , applyVar = applyVar + , liftedClosureVar = liftedClosureVar + , liftedApplyVar = liftedApplyVar + , replicatePDVar = replicatePDVar + , emptyPDVar = emptyPDVar + , packPDVar = packPDVar + , combinePDVars = combinePDVars , scalarClass = scalarClass , scalarZips = scalarZips , closureCtrFuns = closureCtrFuns @@ -245,11 +274,22 @@ initBuiltins pkg dph_PArray = dph_PArray , dph_Repr = dph_Repr , dph_Closure = dph_Closure + , dph_Selector = dph_Selector , dph_Unboxed = dph_Unboxed , dph_Scalar = dph_Scalar }) = dph_Modules pkg + numbered :: String -> Int -> Int -> [FastString] + numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]] + + mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr) + mk_elements (i,j) + = do + v <- externalVar dph_Selector + $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#") + return ((i,j), Var v) + initBuiltinVars :: Builtins -> DsM [(Var, Var)] initBuiltinVars (Builtins { dphModules = mods }) @@ -302,7 +342,7 @@ preludeVars (Modules { dph_Combinators = dph_Combinators , mk' dph_Prelude_Int "mod" "modV" , mk' dph_Prelude_Int "sqrt" "sqrtV" , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA" - , mk' dph_Prelude_Int "upToP" "upToPA" + -- , mk' dph_Prelude_Int "upToP" "upToPA" ] ++ vars_Ord dph_Prelude_Int ++ vars_Num dph_Prelude_Int @@ -456,7 +496,6 @@ builtinPRs bi@(Builtins { dphModules = mods }) = mk (tyConName unitTyCon) (dph_Repr mods) (fsLit "dPR_Unit") , mk (tyConName $ voidTyCon bi) (dph_Repr mods) (fsLit "dPR_Void") , mk (tyConName $ wrapTyCon bi) (dph_Repr mods) (fsLit "dPR_Wrap") - , mk (tyConName $ enumerationTyCon bi) (dph_Repr mods) (fsLit "dPR_Enumeration") , mk (tyConName $ closureTyCon bi) (dph_Closure mods) (fsLit "dPR_Clo") -- temporary @@ -572,6 +611,12 @@ externalVar :: Module -> FastString -> DsM Var externalVar mod fs = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs) +externalFun :: Module -> FastString -> DsM CoreExpr +externalFun mod fs + = do + var <- externalVar mod fs + return $ Var var + externalTyCon :: Module -> FastString -> DsM TyCon externalTyCon mod fs = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs) diff --git a/compiler/vectorise/VectCore.hs b/compiler/vectorise/VectCore.hs index 6be1542..50e7847 100644 --- a/compiler/vectorise/VectCore.hs +++ b/compiler/vectorise/VectCore.hs @@ -4,11 +4,13 @@ module VectCore ( vectorised, lifted, mapVect, + vVarType, + vNonRec, vRec, vVar, vType, vNote, vLet, vLams, vLamsWithoutLC, vVarApps, - vCaseDEFAULT, vCaseProd, vInlineMe + vCaseDEFAULT, vInlineMe ) where #include "HsVersions.h" @@ -38,6 +40,9 @@ mapVect f (x,y) = (f x, f y) zipWithVect :: (a -> b -> c) -> Vect a -> Vect b -> Vect c zipWithVect f (x1,y1) (x2,y2) = (f x1 x2, f y1 y2) +vVarType :: VVar -> Type +vVarType = varType . vectorised + vVar :: VVar -> VExpr vVar = mapVect Var @@ -81,17 +86,6 @@ vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody) where mkDEFAULT e = [(DEFAULT, [], e)] -vCaseProd :: VExpr -> Type -> Type - -> DataCon -> DataCon -> [Var] -> [VVar] -> VExpr -> VExpr -vCaseProd (vscrut, lscrut) vty lty vdc ldc sh_bndrs bndrs - (vbody,lbody) - = (mkWildCase vscrut (exprType vscrut) vty - [(DataAlt vdc, vbndrs, vbody)], - mkWildCase lscrut (exprType lscrut) lty - [(DataAlt ldc, sh_bndrs ++ lbndrs, lbody)]) - where - (vbndrs, lbndrs) = unzip bndrs - vInlineMe :: VExpr -> VExpr vInlineMe (vexpr, lexpr) = (mkInlineMe vexpr, mkInlineMe lexpr) diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs index d0b05ac..b731576 100644 --- a/compiler/vectorise/VectMonad.hs +++ b/compiler/vectorise/VectMonad.hs @@ -7,10 +7,11 @@ module VectMonad ( initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM, liftDs, cloneName, cloneId, cloneVar, - newExportedVar, newLocalVar, newDummyVar, newTyVar, + newExportedVar, newLocalVar, newLocalVars, newDummyVar, newTyVar, - Builtins(..), sumTyCon, prodTyCon, - combinePAVar, scalarZip, closureCtrFun, + Builtins(..), sumTyCon, prodTyCon, prodDataCon, + selTy, selReplicate, selPick, selElements, + combinePDVar, scalarZip, closureCtrFun, builtin, builtins, GlobalEnv(..), @@ -374,6 +375,9 @@ newLocalVar fs ty u <- liftDs newUnique return $ mkSysLocal fs u ty +newLocalVars :: FastString -> [Type] -> VM [Var] +newLocalVars fs = mapM (newLocalVar fs) + newDummyVar :: Type -> VM Var newDummyVar = newLocalVar (fsLit "vv") diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 9952121..0a104e3 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -1,6 +1,5 @@ - module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv, - mkRepr, arrShapeTys, arrShapeVars, arrSelector, + -- arrSumArity, pdataCompTys, pdataCompVars, buildPADict, fromVect ) where @@ -37,6 +36,7 @@ import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices ) import Outputable import FastString +import MonadUtils ( mapAndUnzip3M ) import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM ) import Data.List ( inits, tails, zipWith4, zipWith5 ) @@ -59,7 +59,7 @@ vectAndLiftType ty mdicts <- mapM paDictArgType tyvars let dicts = [dict | Just dict <- mdicts] vmono_ty <- vectType mono_ty - lmono_ty <- mkPArrayType vmono_ty + lmono_ty <- mkPDataType vmono_ty return (abstractType tyvars dicts vmono_ty, abstractType tyvars dicts lmono_ty) where @@ -119,26 +119,26 @@ vectTypeEnv env new_tcs <- vectTyConDecls conv_tcs let orig_tcs = keep_tcs ++ conv_tcs - vect_tcs = keep_tcs ++ new_tcs + vect_tcs = keep_tcs ++ new_tcs - repr_tcs <- zipWithM buildPReprTyCon orig_tcs vect_tcs - parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs - dfuns <- mapM mkPADFun vect_tcs + repr_tcs <- zipWithM buildPReprTyCon orig_tcs vect_tcs + pdata_tcs <- zipWithM buildPDataTyCon orig_tcs vect_tcs + dfuns <- mapM mkPADFun vect_tcs defTyConPAs (zip vect_tcs dfuns) binds <- sequence (zipWith5 buildTyConBindings orig_tcs vect_tcs repr_tcs - parr_tcs + pdata_tcs dfuns) - let all_new_tcs = new_tcs ++ repr_tcs ++ parr_tcs + let all_new_tcs = new_tcs ++ repr_tcs ++ pdata_tcs let new_env = extendTypeEnvList env (map ATyCon all_new_tcs ++ [ADataCon dc | tc <- all_new_tcs , dc <- tyConDataCons tc]) - return (new_env, map mkLocalFamInst (repr_tcs ++ parr_tcs), concat binds) + return (new_env, map mkLocalFamInst (repr_tcs ++ pdata_tcs), concat binds) where tycons = typeEnvTyCons env groups = tyConGroups tycons @@ -230,572 +230,298 @@ buildPReprTyCon orig_tc vect_tc where tyvars = tyConTyVars vect_tc - -data Repr = ProdRepr { - prod_components :: [Type] - , prod_tycon :: TyCon - , prod_data_con :: DataCon - , prod_arr_tycon :: TyCon - , prod_arr_data_con :: DataCon - } - - | SumRepr { - sum_components :: [Repr] - , sum_tycon :: TyCon - , sum_arr_tycon :: TyCon - , sum_arr_data_con :: DataCon - } - - | IdRepr Type - - | VoidRepr { - void_tycon :: TyCon - , void_bottom :: CoreExpr - } - - | EnumRepr { - enum_tycon :: TyCon - , enum_data_con :: DataCon - , enum_arr_tycon :: TyCon - , enum_arr_data_con :: DataCon - } - -voidRepr :: VM Repr -voidRepr - = do - tycon <- builtin voidTyCon - var <- builtin voidVar - return $ VoidRepr { - void_tycon = tycon - , void_bottom = Var var - } - -{- -enumRepr :: VM Repr -enumRepr - = do - tycon <- builtin enumerationTyCon - let [data_con] = tyConDataCons tycon - (arr_tycon, _) <- parrayReprTyCon (mkTyConApp tycon []) - let [arr_data_con] = tyConDataCons arr_tycon - - return $ EnumRepr { - enum_tycon = tycon - , enum_data_con = data_con - , enum_arr_tycon = arr_tycon - , enum_arr_data_con = arr_data_con - } --} - -unboxedProductRepr :: [Type] -> VM Repr -unboxedProductRepr [] = voidRepr -unboxedProductRepr [ty] = return $ IdRepr ty -unboxedProductRepr tys = boxedProductRepr tys - -boxedProductRepr :: [Type] -> VM Repr -boxedProductRepr tys - = do - tycon <- builtin (prodTyCon arity) - let [data_con] = tyConDataCons tycon - - tys' <- mapM boxType tys - (arr_tycon, _) <- parrayReprTyCon $ mkTyConApp tycon tys' - let [arr_data_con] = tyConDataCons arr_tycon - - return $ ProdRepr { - prod_components = tys - , prod_tycon = tycon - , prod_data_con = data_con - , prod_arr_tycon = arr_tycon - , prod_arr_data_con = arr_data_con - } - where - arity = length tys - -sumRepr :: [Repr] -> VM Repr -sumRepr [] = voidRepr -sumRepr [repr] = boxRepr repr -sumRepr reprs - = do - tycon <- builtin (sumTyCon arity) - (arr_tycon, _) <- parrayReprTyCon - . mkTyConApp tycon - $ map reprType reprs - - let [arr_data_con] = tyConDataCons arr_tycon - - return $ SumRepr { - sum_components = reprs - , sum_tycon = tycon - , sum_arr_tycon = arr_tycon - , sum_arr_data_con = arr_data_con - } +buildPReprType :: TyCon -> VM Type +buildPReprType vect_tc = sum_type . map dataConRepArgTys $ tyConDataCons vect_tc where - arity = length reprs - -splitSumRepr :: Repr -> [Repr] -splitSumRepr (SumRepr { sum_components = reprs }) = reprs -splitSumRepr repr = [repr] - -boxRepr :: Repr -> VM Repr -boxRepr (VoidRepr {}) = boxedProductRepr [] -boxRepr (IdRepr ty) = boxedProductRepr [ty] -boxRepr repr = return repr - -reprType :: Repr -> Type -reprType (ProdRepr { prod_tycon = tycon, prod_components = tys }) - = mkTyConApp tycon 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 [] -reprType (EnumRepr { enum_tycon = tycon }) = mkTyConApp tycon [] - -arrReprType :: Repr -> VM Type -arrReprType = mkPArrayType . reprType - -arrShapeTys :: Repr -> VM [Type] -arrShapeTys (SumRepr {}) = sumShapeTys -arrShapeTys (ProdRepr {}) = return [intPrimTy] -arrShapeTys (IdRepr _) = return [] -arrShapeTys (VoidRepr {}) = return [intPrimTy] -arrShapeTys (EnumRepr {}) = sumShapeTys - -sumShapeTys :: VM [Type] -sumShapeTys = do - int_arr <- builtin intPrimArrayTy - return [intPrimTy, int_arr, int_arr] - - -arrShapeVars :: Repr -> VM [Var] -arrShapeVars repr = mapM (newLocalVar (fsLit "sh")) =<< arrShapeTys repr - -replicateShape :: Repr -> CoreExpr -> CoreExpr -> VM [CoreExpr] -replicateShape (ProdRepr {}) len _ = return [len] -replicateShape (SumRepr {}) len tag = replicateSumShape len tag -replicateShape (IdRepr _) _ _ = return [] -replicateShape (VoidRepr {}) len _ = return [len] -replicateShape (EnumRepr {}) len tag = replicateSumShape len tag - -replicateSumShape :: CoreExpr -> CoreExpr -> VM [CoreExpr] -replicateSumShape len tag + sum_type [] = voidType + sum_type [tys] = prod_type tys + sum_type tys = do + (sum_tc, _, _, args) <- reprSumTyCons vect_tc + return $ mkTyConApp sum_tc args + + prod_type [] = voidType + prod_type [ty] = return ty + prod_type tys = do + prod_tc <- builtin (prodTyCon (length tys)) + return $ mkTyConApp prod_tc tys + +reprSumTyCons :: TyCon -> VM (TyCon, TyCon, Type, [Type]) +reprSumTyCons vect_tc = do - rep <- builtin replicatePAIntPrimVar - up <- builtin upToPAIntPrimVar - return [len, Var rep `mkApps` [len, tag], Var up `App` len] - -arrSelector :: Repr -> [CoreExpr] -> VM (CoreExpr, CoreExpr, CoreExpr) -arrSelector (SumRepr {}) [len, sel, is] = return (len, sel, is) -arrSelector (EnumRepr {}) [len, sel, is] = return (len, sel, is) -arrSelector _ _ = panic "arrSelector" - -emptyArrRepr :: Repr -> VM [CoreExpr] -emptyArrRepr (SumRepr { sum_components = prods }) - = liftM concat $ mapM emptyArrRepr prods -emptyArrRepr (ProdRepr { prod_components = [] }) - = return [Var unitDataConId] -emptyArrRepr (ProdRepr { prod_components = tys }) - = mapM emptyPA tys -emptyArrRepr (IdRepr ty) - = liftM singleton $ emptyPA ty -emptyArrRepr (VoidRepr { void_tycon = tycon }) - = liftM singleton $ emptyPA (mkTyConApp tycon []) -emptyArrRepr (EnumRepr {}) - = return [] - -arrReprTys :: Repr -> VM [Type] -arrReprTys (SumRepr { sum_components = reprs }) - = liftM concat $ mapM arrReprTys reprs -arrReprTys (ProdRepr { prod_components = [] }) - = return [unitTy] -arrReprTys (ProdRepr { prod_components = tys }) - = mapM mkPArrayType tys -arrReprTys (IdRepr ty) - = liftM singleton $ mkPArrayType ty -arrReprTys (VoidRepr { void_tycon = tycon }) - = liftM singleton $ mkPArrayType (mkTyConApp tycon []) -arrReprTys (EnumRepr {}) - = return [] - -arrReprTys' :: Repr -> VM [[Type]] -arrReprTys' (SumRepr { sum_components = reprs }) - = mapM arrReprTys reprs -arrReprTys' repr = liftM singleton $ arrReprTys repr - -arrReprVars :: Repr -> VM [[Var]] -arrReprVars repr - = mapM (mapM (newLocalVar (fsLit "rs"))) =<< arrReprTys' repr - -mkRepr :: TyCon -> VM Repr -mkRepr vect_tc - | [tys] <- rep_tys = boxedProductRepr tys - -- removed: | all null rep_tys = enumRepr - | otherwise = sumRepr =<< mapM unboxedProductRepr rep_tys + tc <- builtin (sumTyCon arity) + args <- mapM (prod . dataConRepArgTys) cons + (pdata_tc, _) <- pdataReprTyCon (mkTyConApp tc args) + sel_ty <- builtin (selTy arity) + return (tc, pdata_tc, sel_ty, args) where - rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc + cons = tyConDataCons vect_tc + arity = length cons -buildPReprType :: TyCon -> VM Type -buildPReprType = liftM reprType . mkRepr + prod [] = voidType + prod [ty] = return ty + prod tys = do + prod_tc <- builtin (prodTyCon (length tys)) + return $ mkTyConApp prod_tc tys -buildToPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildToPRepr repr vect_tc prepr_tc _ +buildToPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr +buildToPRepr vect_tc repr_tc _ = do + let arg_ty = mkTyConApp vect_tc ty_args + res_ty <- mkPReprType arg_ty arg <- newLocalVar (fsLit "x") arg_ty - result <- to_repr repr (Var arg) - - return . Lam arg - . wrapFamInstBody prepr_tc var_tys - $ result + result <- to_sum (Var arg) arg_ty res_ty (tyConDataCons vect_tc) + return $ Lam arg result where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - arg_ty = mkTyConApp vect_tc var_tys - res_ty = reprType repr + ty_args = mkTyVarTys (tyConTyVars vect_tc) - cons = tyConDataCons vect_tc - [con] = cons + wrap = wrapFamInstBody repr_tc ty_args - to_repr (SumRepr { sum_components = prods - , sum_tycon = tycon }) - expr + to_sum arg arg_ty res_ty [] = do - (vars, bodies) <- mapAndUnzipM to_unboxed prods - return . mkWildCase expr (exprType expr) res_ty - $ zipWith4 mk_alt cons vars (tyConDataCons tycon) bodies - where - mk_alt con vars sum_con body - = (DataAlt con, vars, mkConApp sum_con (ty_args ++ [body])) + void <- builtin voidVar + return $ wrap (Var void) - ty_args = map (Type . reprType) prods + to_sum arg arg_ty res_ty [con] + = do + (prod, vars) <- to_prod (dataConRepArgTys con) + return $ mkWildCase arg arg_ty res_ty + [(DataAlt con, vars, wrap prod)] - to_repr (EnumRepr { enum_data_con = data_con }) expr - = return . mkWildCase expr (exprType expr) res_ty - $ map mk_alt cons + to_sum arg arg_ty res_ty cons + = do + (prods, vars) <- mapAndUnzipM (to_prod . dataConRepArgTys) cons + (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc + let sum_cons = [mkConApp con (map Type sum_ty_args) + | con <- tyConDataCons sum_tc] + return . mkWildCase arg arg_ty res_ty + $ zipWith4 mk_alt cons vars sum_cons prods where - mk_alt con = (DataAlt con, [], mkConApp data_con [mkDataConTag con]) + arity = length cons - to_repr prod expr - = do - (vars, body) <- to_unboxed prod - return $ mkWildCase expr (exprType expr) res_ty - [(DataAlt con, vars, body)] + mk_alt con vars sum_con expr + = (DataAlt con, vars, wrap $ sum_con `App` expr) - to_unboxed (ProdRepr { prod_components = tys - , prod_data_con = data_con }) + to_prod [] = do - vars <- mapM (newLocalVar (fsLit "r")) tys - return (vars, mkConApp data_con (map Type tys ++ map Var vars)) - - to_unboxed (IdRepr ty) + void <- builtin voidVar + return (Var void, []) + to_prod [ty] = do - var <- newLocalVar (fsLit "y") ty - return ([var], Var var) - - to_unboxed (VoidRepr { void_bottom = bottom }) - = return ([], bottom) - - to_unboxed _ = panic "buildToPRepr/to_unboxed" + var <- newLocalVar (fsLit "x") ty + return (Var var, [var]) + to_prod tys + = do + prod_con <- builtin (prodDataCon (length tys)) + vars <- newLocalVars (fsLit "x") tys + return (mkConApp prod_con (map Type tys ++ map Var vars), vars) + where + arity = length tys -buildFromPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildFromPRepr repr vect_tc prepr_tc _ +buildFromPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr +buildFromPRepr vect_tc repr_tc _ = do arg_ty <- mkPReprType res_ty - arg <- newLocalVar (fsLit "x") arg_ty + arg <- newLocalVar (fsLit "x") arg_ty - liftM (Lam arg) - . from_repr repr - $ unwrapFamInstScrut prepr_tc var_tys (Var arg) + result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg)) + (tyConDataCons vect_tc) + return $ Lam arg result where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - res_ty = mkTyConApp vect_tc var_tys + ty_args = mkTyVarTys (tyConTyVars vect_tc) + res_ty = mkTyConApp vect_tc ty_args - cons = map (`mkConApp` map Type var_tys) (tyConDataCons vect_tc) - [con] = cons - - from_repr repr@(SumRepr { sum_components = prods - , sum_tycon = tycon }) - expr + from_sum expr [] = pprPanic "buildFromPRepr" (ppr vect_tc) + from_sum expr [con] = from_prod expr con + from_sum expr cons = do - vars <- mapM (newLocalVar (fsLit "x")) (map reprType prods) - bodies <- sequence . zipWith3 from_unboxed prods cons - $ map Var vars - return . mkWildCase expr (reprType repr) res_ty - $ zipWith3 sum_alt (tyConDataCons tycon) vars bodies + (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc + let sum_cons = tyConDataCons sum_tc + vars <- newLocalVars (fsLit "x") sum_ty_args + prods <- zipWithM from_prod (map Var vars) cons + return . mkWildCase expr (exprType expr) res_ty + $ zipWith3 mk_alt sum_cons vars prods where - sum_alt data_con var body = (DataAlt data_con, [var], body) - - from_repr repr@(EnumRepr { enum_data_con = data_con }) expr - = do - var <- newLocalVar (fsLit "n") intPrimTy - - let res = mkWildCase (Var var) intPrimTy res_ty - $ (DEFAULT, [], error_expr) - : zipWith mk_alt (tyConDataCons vect_tc) cons - - return $ mkWildCase expr (reprType repr) res_ty - [(DataAlt data_con, [var], res)] + arity = length cons + + mk_alt con var expr = (DataAlt con, [var], expr) + + from_prod expr con + = case dataConRepArgTys con of + [] -> return $ apply_con [] + [ty] -> return $ apply_con [expr] + tys -> do + prod_con <- builtin (prodDataCon (length tys)) + vars <- newLocalVars (fsLit "y") tys + return $ mkWildCase expr (exprType expr) res_ty + [(DataAlt prod_con, vars, apply_con (map Var vars))] where - mk_alt data_con con = (LitAlt (mkDataConTagLit data_con), [], con) - - error_expr = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty - . showSDoc - $ sep [text "Invalid NDP representation of", ppr vect_tc] - - from_repr repr expr = from_unboxed repr con expr + apply_con exprs = mkConApp con (map Type ty_args) `mkApps` exprs - from_unboxed prod@(ProdRepr { prod_components = tys - , prod_data_con = data_con }) - con - expr - = do - vars <- mapM (newLocalVar (fsLit "y")) tys - return $ mkWildCase expr (reprType prod) res_ty - [(DataAlt data_con, vars, con `mkVarApps` vars)] - - from_unboxed (IdRepr _) con expr - = return $ con `App` expr - - from_unboxed (VoidRepr {}) con _ - = return con - - from_unboxed _ _ _ = panic "buildFromPRepr/from_unboxed" - -buildToArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildToArrPRepr repr vect_tc prepr_tc arr_tc +buildToArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr +buildToArrPRepr vect_tc prepr_tc pdata_tc = do - arg_ty <- mkPArrayType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - res_ty <- mkPArrayType (reprType repr) - - shape_vars <- arrShapeVars repr - repr_vars <- arrReprVars repr - - parray_co <- mkBuiltinCo parrayTyCon + arg_ty <- mkPDataType el_ty + res_ty <- mkPDataType =<< mkPReprType el_ty + arg <- newLocalVar (fsLit "xs") arg_ty + pdata_co <- mkBuiltinCo pdataTyCon let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCoercion parray_co + co = mkAppCoercion pdata_co . mkSymCoercion - $ mkTyConApp repr_co var_tys + $ mkTyConApp repr_co ty_args - scrut = unwrapFamInstScrut arr_tc var_tys (Var arg) + scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) - result <- to_repr shape_vars repr_vars repr + (vars, result) <- to_sum (tyConDataCons vect_tc) return . Lam arg - . mkCoerce co - $ mkWildCase scrut (mkTyConApp arr_tc var_tys) res_ty - [(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)] + $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty + [(DataAlt pdata_dc, vars, mkCoerce co result)] where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc var_tys - - [arr_dc] = tyConDataCons arr_tc - - to_repr shape_vars@(_ : _) - repr_vars - (SumRepr { sum_components = prods - , sum_arr_tycon = tycon - , sum_arr_data_con = data_con }) - = do - exprs <- zipWithM to_prod repr_vars prods - - return . wrapFamInstBody tycon tys - . mkConApp data_con - $ map Type tys ++ map Var shape_vars ++ exprs + ty_args = mkTyVarTys $ tyConTyVars vect_tc + el_ty = mkTyConApp vect_tc ty_args + + [pdata_dc] = tyConDataCons pdata_tc + + to_sum [] = do + pvoid <- builtin pvoidVar + return ([], Var pvoid) + to_sum [con] = to_prod con + to_sum cons = do + (vars, exprs) <- mapAndUnzipM to_prod cons + (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc + sel <- newLocalVar (fsLit "sel") sel_ty + let [pdata_con] = tyConDataCons pdata_tc + result = wrapFamInstBody pdata_tc arg_tys + . mkConApp pdata_con + $ map Type arg_tys ++ (Var sel : exprs) + return (sel : concat vars, result) + + to_prod con + | [] <- tys = do + pvoid <- builtin pvoidVar + return ([], Var pvoid) + | [ty] <- tys = do + var <- newLocalVar (fsLit "x") ty + return ([var], Var var) + | otherwise + = do + vars <- newLocalVars (fsLit "x") tys + prod_tc <- builtin (prodTyCon (length tys)) + (pdata_prod_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys) + let [pdata_prod_con] = tyConDataCons pdata_prod_tc + result = wrapFamInstBody pdata_prod_tc tys + . mkConApp pdata_prod_con + $ map Type tys ++ map Var vars + return (vars, result) where - tys = map reprType prods - - to_repr [len_var] - [repr_vars] - (ProdRepr { prod_components = tys - , prod_arr_tycon = tycon - , prod_arr_data_con = data_con }) - = return . wrapFamInstBody tycon tys - . mkConApp data_con - $ map Type tys ++ map Var (len_var : repr_vars) - - to_repr shape_vars - _ - (EnumRepr { enum_arr_tycon = tycon - , enum_arr_data_con = data_con }) - = return . wrapFamInstBody tycon [] - . mkConApp data_con - $ map Var shape_vars - - to_repr _ _ _ = panic "buildToArrPRepr/to_repr" - - to_prod repr_vars@(r : _) - (ProdRepr { prod_components = tys@(ty : _) - , prod_arr_tycon = tycon - , prod_arr_data_con = data_con }) - = do - len <- lengthPA ty (Var r) - return . wrapFamInstBody tycon tys - . mkConApp data_con - $ map Type tys ++ len : map Var repr_vars - - to_prod [var] (IdRepr _) = return (Var var) - to_prod [var] (VoidRepr {}) = return (Var var) - to_prod _ _ = panic "buildToArrPRepr/to_prod" + tys = dataConRepArgTys con - -buildFromArrPRepr :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildFromArrPRepr repr vect_tc prepr_tc arr_tc +buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> VM CoreExpr +buildFromArrPRepr vect_tc prepr_tc pdata_tc = do - arg_ty <- mkPArrayType =<< mkPReprType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - res_ty <- mkPArrayType el_ty - - shape_vars <- arrShapeVars repr - repr_vars <- arrReprVars repr - - parray_co <- mkBuiltinCo parrayTyCon + arg_ty <- mkPDataType =<< mkPReprType el_ty + res_ty <- mkPDataType el_ty + arg <- newLocalVar (fsLit "xs") arg_ty + pdata_co <- mkBuiltinCo pdataTyCon let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCoercion parray_co + co = mkAppCoercion pdata_co $ mkTyConApp repr_co var_tys scrut = mkCoerce co (Var arg) - result = wrapFamInstBody arr_tc var_tys - . mkConApp arr_dc - $ map Type var_tys ++ map Var (shape_vars ++ concat repr_vars) + (args, mk) <- from_sum res_ty scrut (tyConDataCons vect_tc) + + let result = wrapFamInstBody pdata_tc var_tys + . mkConApp pdata_dc + $ map Type var_tys ++ args - liftM (Lam arg) - (from_repr repr scrut shape_vars repr_vars res_ty result) + return $ Lam arg (mk result) where var_tys = mkTyVarTys $ tyConTyVars vect_tc el_ty = mkTyConApp vect_tc var_tys - [arr_dc] = tyConDataCons arr_tc - - from_repr (SumRepr { sum_components = prods - , sum_arr_tycon = tycon - , sum_arr_data_con = data_con }) - expr - shape_vars - repr_vars - res_ty - body - = do - vars <- mapM (newLocalVar (fsLit "xs")) =<< mapM arrReprType prods - result <- go prods repr_vars vars body + [pdata_dc] = tyConDataCons pdata_tc - let scrut = unwrapFamInstScrut tycon ty_args expr - return . mkWildCase scrut scrut_ty res_ty - $ [(DataAlt data_con, shape_vars ++ vars, result)] + from_sum res_ty expr [] = return ([], mk) where - ty_args = map reprType prods - scrut_ty = mkTyConApp tycon ty_args - - go [] [] [] body = return body - go (prod : prods) (repr_vars : rss) (var : vars) body - = do - shape_vars <- mapM (newLocalVar (fsLit "s")) =<< arrShapeTys prod - - from_prod prod (Var var) shape_vars repr_vars res_ty - =<< go prods rss vars body - go _ _ _ _ = panic "buildFromArrPRepr/go" - - from_repr repr expr shape_vars [repr_vars] res_ty body - = from_prod repr expr shape_vars repr_vars res_ty body - - from_repr _ _ _ _ _ _ = panic "buildFromArrPRepr/from_repr" - - from_prod (ProdRepr { prod_components = tys - , prod_arr_tycon = tycon - , prod_arr_data_con = data_con }) - expr - shape_vars - repr_vars - res_ty - body + mk body = mkWildCase expr (exprType expr) res_ty [(DEFAULT, [], body)] + from_sum res_ty expr [con] = from_prod res_ty expr con + from_sum res_ty expr cons = do - let scrut = unwrapFamInstScrut tycon tys expr - scrut_ty = mkTyConApp tycon tys - - return $ mkWildCase scrut scrut_ty res_ty - [(DataAlt data_con, shape_vars ++ repr_vars, body)] - - from_prod (EnumRepr { enum_arr_tycon = tycon - , enum_arr_data_con = data_con }) - expr - shape_vars - _ - res_ty - body - = let scrut = unwrapFamInstScrut tycon [] expr - scrut_ty = mkTyConApp tycon [] - in - return $ mkWildCase scrut scrut_ty res_ty - [(DataAlt data_con, shape_vars, body)] - - from_prod (IdRepr _) - expr - _shape_vars - [repr_var] - _res_ty - 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 - - from_prod _ _ _ _ _ _ = panic "buildFromArrPRepr/from_prod" - -buildPRDictRepr :: Repr -> VM CoreExpr -buildPRDictRepr (VoidRepr { void_tycon = tycon }) - = prDFunOfTyCon tycon -buildPRDictRepr (IdRepr ty) = mkPR ty -buildPRDictRepr (ProdRepr { - prod_components = tys - , prod_tycon = tycon - }) - = do - prs <- mapM mkPR tys - dfun <- prDFunOfTyCon tycon - return $ dfun `mkTyApps` tys `mkApps` prs - -buildPRDictRepr (SumRepr { - sum_components = prods - , sum_tycon = tycon }) - = do - prs <- mapM buildPRDictRepr prods - dfun <- prDFunOfTyCon tycon - return $ dfun `mkTyApps` map reprType prods `mkApps` prs - -buildPRDictRepr (EnumRepr { enum_tycon = tycon }) - = prDFunOfTyCon tycon + (_, pdata_tc, sel_ty, arg_tys) <- reprSumTyCons vect_tc + prod_tys <- mapM mkPDataType arg_tys + sel <- newLocalVar (fsLit "sel") sel_ty + vars <- newLocalVars (fsLit "xs") arg_tys + rs <- zipWithM (from_prod res_ty) (map Var vars) cons + let (prods, mks) = unzip rs + [pdata_con] = tyConDataCons pdata_tc + scrut = unwrapFamInstScrut pdata_tc arg_tys expr + + mk body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt pdata_con, sel : vars, foldr ($) body mks)] + return (Var sel : concat prods, mk) + + + from_prod res_ty expr con + | [] <- tys = return ([], id) + | [ty] <- tys = return ([expr], id) + | otherwise + = do + prod_tc <- builtin (prodTyCon (length tys)) + (pdata_tc, _) <- pdataReprTyCon (mkTyConApp prod_tc tys) + pdata_tys <- mapM mkPDataType tys + vars <- newLocalVars (fsLit "ys") pdata_tys + let [pdata_con] = tyConDataCons pdata_tc + scrut = unwrapFamInstScrut pdata_tc tys expr + + mk body = mkWildCase scrut (exprType scrut) res_ty + [(DataAlt pdata_con, vars, body)] + + return (map Var vars, mk) + where + tys = dataConRepArgTys con -buildPRDict :: Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr -buildPRDict repr vect_tc prepr_tc _ +buildPRDict :: TyCon -> TyCon -> TyCon -> VM CoreExpr +buildPRDict vect_tc prepr_tc _ = do - dict <- buildPRDictRepr repr - + dict <- sum_dict (tyConDataCons vect_tc) pr_co <- mkBuiltinCo prTyCon let co = mkAppCoercion pr_co . mkSymCoercion - $ mkTyConApp arg_co var_tys - - return $ mkCoerce co dict + $ mkTyConApp arg_co ty_args + return (mkCoerce co dict) where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - + ty_args = mkTyVarTys (tyConTyVars vect_tc) Just arg_co = tyConFamilyCoercion_maybe prepr_tc -buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon -buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc -> + sum_dict [] = prDFunOfTyCon =<< builtin voidTyCon + sum_dict [con] = prod_dict con + sum_dict cons = do + dicts <- mapM prod_dict cons + (sum_tc, _, _, sum_ty_args) <- reprSumTyCons vect_tc + dfun <- prDFunOfTyCon sum_tc + return $ dfun `mkTyApps` sum_ty_args `mkApps` dicts + + prod_dict con + | [] <- tys = prDFunOfTyCon =<< builtin voidTyCon + | [ty] <- tys = mkPR ty + | otherwise = do + dicts <- mapM mkPR tys + prod_tc <- builtin (prodTyCon (length tys)) + dfun <- prDFunOfTyCon prod_tc + return $ dfun `mkTyApps` tys `mkApps` dicts + where + tys = dataConRepArgTys con + +buildPDataTyCon :: TyCon -> TyCon -> VM TyCon +buildPDataTyCon orig_tc vect_tc = fixV $ \repr_tc -> do - name' <- cloneName mkPArrayTyConOcc orig_name - rhs <- buildPArrayTyConRhs orig_name vect_tc repr_tc - parray <- builtin parrayTyCon + name' <- cloneName mkPDataTyConOcc orig_name + rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc + pdata <- builtin pdataTyCon liftDs $ buildAlgTyCon name' tyvars @@ -804,42 +530,48 @@ buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc -> rec_flag -- FIXME: is this ok? False -- FIXME: no generics False -- not GADT syntax - (Just $ mk_fam_inst parray vect_tc) + (Just $ mk_fam_inst pdata vect_tc) where orig_name = tyConName orig_tc tyvars = tyConTyVars vect_tc rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) -buildPArrayTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs -buildPArrayTyConRhs orig_name vect_tc repr_tc +buildPDataTyConRhs :: Name -> TyCon -> TyCon -> VM AlgTyConRhs +buildPDataTyConRhs orig_name vect_tc repr_tc = do - data_con <- buildPArrayDataCon orig_name vect_tc repr_tc + data_con <- buildPDataDataCon orig_name vect_tc repr_tc return $ DataTyCon { data_cons = [data_con], is_enum = False } -buildPArrayDataCon :: Name -> TyCon -> TyCon -> VM DataCon -buildPArrayDataCon orig_name vect_tc repr_tc +buildPDataDataCon :: Name -> TyCon -> TyCon -> VM DataCon +buildPDataDataCon orig_name vect_tc repr_tc = do - dc_name <- cloneName mkPArrayDataConOcc orig_name - repr <- mkRepr vect_tc - - shape_tys <- arrShapeTys repr - repr_tys <- arrReprTys repr - - let tys = shape_tys ++ repr_tys - tvs = tyConTyVars vect_tc + dc_name <- cloneName mkPDataDataConOcc orig_name + comp_tys <- components liftDs $ buildDataCon dc_name False -- not infix - (map (const NotMarkedStrict) tys) + (map (const NotMarkedStrict) comp_tys) [] -- no field labels tvs [] -- no existentials [] -- no eq spec [] -- no context - tys + comp_tys (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) repr_tc + where + tvs = tyConTyVars vect_tc + cons = tyConDataCons vect_tc + arity = length cons + + components + | arity > 1 = liftM2 (:) (builtin (selTy arity)) data_components + | otherwise = data_components + + data_components = mapM mkPDataType + . concat + $ map dataConRepArgTys cons mkPADFun :: TyCon -> VM Var mkPADFun vect_tc @@ -847,65 +579,63 @@ mkPADFun vect_tc buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> Var -> VM [(Var, CoreExpr)] -buildTyConBindings orig_tc vect_tc prepr_tc arr_tc dfun +buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc dfun = do - repr <- mkRepr vect_tc - vectDataConWorkers repr orig_tc vect_tc arr_tc - dict <- buildPADict repr vect_tc prepr_tc arr_tc dfun + vectDataConWorkers orig_tc vect_tc pdata_tc + dict <- buildPADict vect_tc prepr_tc pdata_tc dfun binds <- takeHoisted return $ (dfun, dict) : binds -vectDataConWorkers :: Repr -> TyCon -> TyCon -> TyCon - -> VM () -vectDataConWorkers repr orig_tc vect_tc arr_tc +vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () +vectDataConWorkers orig_tc vect_tc arr_tc = do bs <- sequence . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys $ zipWith4 mk_data_con (tyConDataCons vect_tc) rep_tys - (inits reprs) - (tail $ tails reprs) + (inits rep_tys) + (tail $ tails rep_tys) mapM_ (uncurry hoistBinding) bs where tyvars = tyConTyVars vect_tc var_tys = mkTyVarTys tyvars ty_args = map Type var_tys - res_ty = mkTyConApp vect_tc var_tys + cons = tyConDataCons vect_tc + arity = length cons + [arr_dc] = tyConDataCons arr_tc + rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc - reprs = splitSumRepr repr - [arr_dc] = tyConDataCons arr_tc mk_data_con con tys pre post = liftM2 (,) (vect_data_con con) (lift_data_con tys pre post (mkDataConTag con)) + sel_replicate len tag + | arity > 1 = do + rep <- builtin (selReplicate arity) + return [rep `mkApps` [len, tag]] + + | otherwise = return [] + vect_data_con con = return $ mkConApp con ty_args - lift_data_con tys pre_reprs post_reprs tag + lift_data_con tys pre_tys post_tys tag = do len <- builtin liftingContext args <- mapM (newLocalVar (fsLit "xs")) - =<< mapM mkPArrayType tys + =<< mapM mkPDataType tys - shape <- replicateShape repr (Var len) tag - repr <- mk_arr_repr (Var len) (map Var args) + sel <- sel_replicate (Var len) tag - pre <- liftM concat $ mapM emptyArrRepr pre_reprs - post <- liftM concat $ mapM emptyArrRepr post_reprs + pre <- mapM emptyPD (concat pre_tys) + post <- mapM emptyPD (concat post_tys) return . mkLams (len : args) . wrapFamInstBody arr_tc var_tys . mkConApp arr_dc - $ ty_args ++ shape ++ pre ++ repr ++ post - - mk_arr_repr len [] - = do - units <- replicatePA len (Var unitDataConId) - return [units] - - mk_arr_repr _ arrs = return arrs + $ ty_args ++ sel ++ pre ++ map Var args ++ post def_worker data_con arg_tys mk_body = do @@ -921,11 +651,11 @@ vectDataConWorkers repr orig_tc vect_tc arr_tc where orig_worker = dataConWorkId data_con -buildPADict :: Repr -> TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr -buildPADict repr vect_tc prepr_tc arr_tc _ +buildPADict :: TyCon -> TyCon -> TyCon -> Var -> VM CoreExpr +buildPADict vect_tc prepr_tc arr_tc _ = polyAbstract tvs $ \abstract -> do - meth_binds <- mapM (mk_method repr) paMethods + meth_binds <- mapM mk_method paMethods let meth_exprs = map (Var . fst) meth_binds pa_dc <- builtin paDataCon @@ -936,14 +666,14 @@ buildPADict repr vect_tc prepr_tc arr_tc _ tvs = tyConTyVars arr_tc arg_tys = mkTyVarTys tvs - mk_method repr (name, build) + mk_method (name, build) = localV $ do - body <- build repr vect_tc prepr_tc arr_tc + body <- build vect_tc prepr_tc arr_tc var <- newLocalVar name (exprType body) return (var, mkInlineMe body) -paMethods :: [(FastString, Repr -> TyCon -> TyCon -> TyCon -> VM CoreExpr)] +paMethods :: [(FastString, TyCon -> TyCon -> TyCon -> VM CoreExpr)] paMethods = [(fsLit "toPRepr", buildToPRepr), (fsLit "fromPRepr", buildFromPRepr), (fsLit "toArrPRepr", buildToArrPRepr), @@ -1026,7 +756,7 @@ fromVect (FunTy arg_ty res_ty) expr varg <- toVect arg_ty (Var arg) varg_ty <- vectType arg_ty vres_ty <- vectType res_ty - apply <- builtin applyClosureVar + apply <- builtin applyVar body <- fromVect res_ty $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg] return $ Lam arg body diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 228f76c..30ce9ac 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -5,13 +5,15 @@ module VectUtils ( newLocalVVar, - mkBuiltinCo, - mkPADictType, mkPArrayType, mkPReprType, + mkBuiltinCo, voidType, + mkPADictType, mkPArrayType, mkPDataType, mkPReprType, mkPArray, - parrayReprTyCon, parrayReprDataCon, mkVScrut, + pdataReprTyCon, pdataReprDataCon, mkVScrut, prDFunOfTyCon, paDictArgType, paDictOfType, paDFunType, - paMethod, mkPR, lengthPA, replicatePA, emptyPA, packPA, combinePA, liftPA, + paMethod, mkPR, replicatePD, emptyPD, packPD, + combinePD, + liftPD, zipScalars, scalarClosure, polyAbstract, polyApply, polyVApply, hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted, @@ -95,21 +97,8 @@ mkBuiltinTyConApps get_tc tys ty where mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] -{- -mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type -mkBuiltinTyConApps1 _ dft [] = return dft -mkBuiltinTyConApps1 get_tc _ tys - = do - tc <- builtin get_tc - case tys of - [] -> pprPanic "mkBuiltinTyConApps1" (ppr tc) - _ -> return $ foldr1 (mk tc) tys - where - mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] - -mkClosureType :: Type -> Type -> VM Type -mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty] --} +voidType :: VM Type +voidType = mkBuiltinTyConApp voidTyCon [] mkClosureTypes :: [Type] -> Type -> VM Type mkClosureTypes = mkBuiltinTyConApps closureTyCon @@ -130,27 +119,38 @@ mkPArrayType ty Nothing -> cantVectorise "Primitive tycon not vectorised" (ppr tycon) mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty] +mkPDataType :: Type -> VM Type +mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty] + +mkPArray :: Type -> CoreExpr -> CoreExpr -> VM CoreExpr +mkPArray ty len dat = do + tc <- builtin parrayTyCon + let [dc] = tyConDataCons tc + return $ mkConApp dc [Type ty, len, dat] + mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion mkBuiltinCo get_tc = do tc <- builtin get_tc return $ mkTyConApp tc [] -parrayReprTyCon :: Type -> VM (TyCon, [Type]) -parrayReprTyCon ty = builtin parrayTyCon >>= (`lookupFamInst` [ty]) +pdataReprTyCon :: Type -> VM (TyCon, [Type]) +pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty]) -parrayReprDataCon :: Type -> VM (DataCon, [Type]) -parrayReprDataCon ty +pdataReprDataCon :: Type -> VM (DataCon, [Type]) +pdataReprDataCon ty = do - (tc, arg_tys) <- parrayReprTyCon ty + (tc, arg_tys) <- pdataReprTyCon ty let [dc] = tyConDataCons tc return (dc, arg_tys) -mkVScrut :: VExpr -> VM (VExpr, TyCon, [Type]) +mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type]) mkVScrut (ve, le) = do - (tc, arg_tys) <- parrayReprTyCon (exprType ve) - return ((ve, unwrapFamInstScrut tc arg_tys le), tc, arg_tys) + (tc, arg_tys) <- pdataReprTyCon ty + return (ve, unwrapFamInstScrut tc arg_tys le, tc, arg_tys) + where + ty = exprType ve prDFunOfTyCon :: TyCon -> VM CoreExpr prDFunOfTyCon tycon @@ -217,20 +217,14 @@ paDFunApply dfun tys type PAMethod = (Builtins -> Var, String) -pa_length, pa_replicate, pa_empty, pa_pack :: (Builtins -> Var, String) -pa_length = (lengthPAVar, "lengthPA") -pa_replicate = (replicatePAVar, "replicatePA") -pa_empty = (emptyPAVar, "emptyPA") -pa_pack = (packPAVar, "packPA") - -paMethod :: PAMethod -> Type -> VM CoreExpr -paMethod (_method, name) ty +paMethod :: (Builtins -> Var) -> String -> Type -> VM CoreExpr +paMethod _ name ty | Just tycon <- splitPrimTyCon ty = liftM Var . maybeCantVectoriseM "No PA method" (text name <+> text "for" <+> ppr tycon) $ lookupPrimMethod tycon name -paMethod (method, _name) ty +paMethod method _ ty = do fn <- builtin method dict <- paDictOfType ty @@ -243,33 +237,30 @@ mkPR ty dict <- paDictOfType ty return $ mkApps (Var fn) [Type ty, dict] -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]) - (paMethod pa_replicate (exprType x)) +replicatePD :: CoreExpr -> CoreExpr -> VM CoreExpr +replicatePD len x = liftM (`mkApps` [len,x]) + (paMethod replicatePDVar "replicatePD" (exprType x)) -emptyPA :: Type -> VM CoreExpr -emptyPA = paMethod pa_empty +emptyPD :: Type -> VM CoreExpr +emptyPD = paMethod emptyPDVar "emptyPD" -packPA :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr -packPA ty xs len sel = liftM (`mkApps` [xs, len, sel]) - (paMethod pa_pack ty) +packPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr +packPD ty xs len sel = liftM (`mkApps` [xs, len, sel]) + (paMethod packPDVar "packPD" ty) -combinePA :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> [CoreExpr] +combinePD :: Type -> CoreExpr -> CoreExpr -> [CoreExpr] -> VM CoreExpr -combinePA ty len sel is xs - = liftM (`mkApps` (len : sel : is : xs)) - (paMethod (combinePAVar n, "combine" ++ show n ++ "PA") ty) +combinePD ty len sel xs + = liftM (`mkApps` (len : sel : xs)) + (paMethod (combinePDVar n) ("combine" ++ show n ++ "PD") ty) where n = length xs -liftPA :: CoreExpr -> VM CoreExpr -liftPA x +liftPD :: CoreExpr -> VM CoreExpr +liftPD x = do lc <- builtin liftingContext - replicatePA (Var lc) x + replicatePD (Var lc) x zipScalars :: [Type] -> Type -> VM CoreExpr zipScalars arg_tys res_ty @@ -292,7 +283,7 @@ scalarClosure arg_tys res_ty scalar_fun array_fun newLocalVVar :: FastString -> Type -> VM VVar newLocalVVar fs vty = do - lty <- mkPArrayType vty + lty <- mkPDataType vty vv <- newLocalVar fs vty lv <- newLocalVar fs lty return (vv,lv) @@ -377,18 +368,19 @@ mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) = do dict <- paDictOfType env_ty - mkv <- builtin mkClosureVar - mkl <- builtin mkClosurePVar + mkv <- builtin closureVar + mkl <- builtin liftedClosureVar 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 :: Type -> Type -> VExpr -> VExpr -> VM VExpr mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg) = do - vapply <- builtin applyClosureVar - lapply <- builtin applyClosurePVar + vapply <- builtin applyVar + lapply <- builtin liftedApplyVar + lc <- builtin liftingContext return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg], - Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [lclo, larg]) + Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg]) buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr buildClosures _ _ [] _ mk_body @@ -423,69 +415,51 @@ buildClosure tvs vars arg_ty res_ty mk_body $ do lc <- builtin liftingContext body <- mk_body - body' <- bind (vVar env_bndr) + return . vInlineMe + . vLams lc [env_bndr, arg_bndr] + $ bind (vVar env_bndr) (vVarApps lc body (vars ++ [arg_bndr])) - return . vInlineMe $ vLamsWithoutLC [env_bndr, arg_bndr] body' mkClosure arg_ty res_ty env_ty fn env -buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VM VExpr) -buildEnv vvs - = do - lc <- builtin liftingContext - let (ty, venv, vbind) = mkVectEnv tys vs - (lenv, lbind) <- mkLiftEnv lc tys ls - return (ty, (venv, lenv), - \(venv,lenv) (vbody,lbody) -> - do - let vbody' = vbind venv vbody - lbody' <- lbind lenv lbody - return (vbody', lbody')) - where - (vs,ls) = unzip vvs - tys = map varType vs - -mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExpr) -mkVectEnv [] [] = (unitTy, Var unitDataConId, \_ body -> body) -mkVectEnv [ty] [v] = (ty, Var v, \env body -> Let (NonRec v env) body) -mkVectEnv tys vs = (ty, mkCoreTup (map Var vs), - \env body -> mkWildCase env ty (exprType body) - [(DataAlt (tupleCon Boxed (length vs)), vs, body)]) - where - ty = mkCoreTupTy tys - -mkLiftEnv :: Var -> [Type] -> [Var] -> VM (CoreExpr, CoreExpr -> CoreExpr -> VM CoreExpr) -mkLiftEnv lc [ty] [v] - = return (Var v, \env body -> - do - len <- lengthPA ty (Var v) - return . Let (NonRec v env) - $ Case len lc (exprType body) [(DEFAULT, [], body)]) - --- NOTE: this transparently deals with empty environments -mkLiftEnv lc tys vs +buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr) +buildEnv [] = do + ty <- voidType + void <- builtin voidVar + pvoid <- builtin pvoidVar + return (ty, vVar (void, pvoid), \_ body -> body) + +buildEnv [v] = return (vVarType v, vVar v, + \env body -> vLet (vNonRec v env) body) + +buildEnv vs = do - (env_tc, env_tyargs) <- parrayReprTyCon vty - - bndrs <- if null vs then do - v <- newDummyVar unitTy - return [v] - else return vs - let [env_con] = tyConDataCons env_tc - - env = Var (dataConWrapId env_con) - `mkTyApps` env_tyargs - `mkApps` (Var lc : args) - - bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env - in - return $ mkWildCase scrut (exprType scrut) - (exprType body) - [(DataAlt env_con, lc : bndrs, body)] - return (env, bind) - where - vty = mkCoreTupTy tys + + (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty - args | null vs = [Var unitDataConId] - | otherwise = map Var vs + let venv_con = tupleCon Boxed (length vs) + [lenv_con] = tyConDataCons lenv_tc + + venv = mkCoreTup (map Var vvs) + lenv = Var (dataConWrapId lenv_con) + `mkTyApps` lenv_tyargs + `mkApps` map Var lvs + + vbind env body = mkWildCase venv ty (exprType body) + [(DataAlt venv_con, vvs, body)] + + lbind env body = + let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs lenv + in + mkWildCase scrut (exprType scrut) (exprType body) + [(DataAlt lenv_con, lvs, body)] + + bind (venv, lenv) (vbody, lbody) = (vbind venv vbody, + lbind lenv lbody) + + return (ty, (venv, lenv), bind) + where + (vvs, lvs) = unzip vs + tys = map vVarType vs + ty = mkCoreTupTy tys diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index a0e3e1a..27cdde3 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -12,6 +12,7 @@ import HscTypes hiding ( MonadThings(..) ) import Module ( PackageId ) import CoreSyn import CoreUtils +import MkCore ( mkWildCase ) import CoreFVs import CoreMonad ( CoreM, getHscEnv ) import DataCon @@ -163,7 +164,7 @@ vectVar v Local (vv,lv) -> return (Var vv, Var lv) Global vv -> do let vexpr = Var vv - lexpr <- liftPA vexpr + lexpr <- liftPD vexpr return (vexpr, lexpr) vectPolyVar :: Var -> [Type] -> VM VExpr @@ -176,13 +177,13 @@ vectPolyVar v tys (polyApply (Var lv) vtys) Global poly -> do vexpr <- polyApply (Var poly) vtys - lexpr <- liftPA vexpr + lexpr <- liftPD vexpr return (vexpr, lexpr) vectLiteral :: Literal -> VM VExpr vectLiteral lit = do - lexpr <- liftPA (Lit lit) + lexpr <- liftPD (Lit lit) return (Lit lit, lexpr) vectPolyExpr :: CoreExprWithFVs -> VM VExpr @@ -218,7 +219,7 @@ vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit)) , is_special_con con = do let vexpr = App (Var v) (Lit lit) - lexpr <- liftPA vexpr + lexpr <- liftPD vexpr return (vexpr, lexpr) where is_special_con con = con `elem` [intDataCon, floatDataCon, doubleDataCon] @@ -294,7 +295,7 @@ vectScalarLam args body clo <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var) clo_var <- hoistExpr (fsLit "clo") clo - lclo <- liftPA (Var clo_var) + lclo <- liftPD (Var clo_var) return (Var clo_var, lclo) where arg_tys = map idType args @@ -375,47 +376,55 @@ vectAlgCase tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] vect_tc <- maybeV (lookupTyCon tycon) (vty, lty) <- vectAndLiftType ty vexpr <- vectExpr scrut - (vbndr, (vbndrs, vbody)) <- vect_scrut_bndr - . vectBndrsIn bndrs - $ vectExpr body - - (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr) + (vbndr, (vbndrs, (vect_body, lift_body))) + <- vect_scrut_bndr + . vectBndrsIn bndrs + $ vectExpr body + let (vect_bndrs, lift_bndrs) = unzip vbndrs + (vscrut, lscrut, pdata_tc, _arg_tys) <- mkVScrut (vVar vbndr) vect_dc <- maybeV (lookupDataCon dc) - let [arr_dc] = tyConDataCons arr_tc - repr <- mkRepr vect_tc - shape_bndrs <- arrShapeVars repr - return . vLet (vNonRec vbndr vexpr) - $ vCaseProd vscrut vty lty vect_dc arr_dc shape_bndrs vbndrs vbody + let [pdata_dc] = tyConDataCons pdata_tc + + let vcase = mk_wild_case vscrut vty vect_dc vect_bndrs vect_body + lcase = mk_wild_case lscrut lty pdata_dc lift_bndrs lift_body + + return $ vLet (vNonRec vbndr vexpr) (vcase, lcase) where vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") | otherwise = vectBndrIn bndr + mk_wild_case expr ty dc bndrs body + = mkWildCase expr (exprType expr) ty [(DataAlt dc, bndrs, body)] + vectAlgCase tycon _ty_args scrut bndr ty alts = do vect_tc <- maybeV (lookupTyCon tycon) (vty, lty) <- vectAndLiftType ty - repr <- mkRepr vect_tc - shape_bndrs <- arrShapeVars repr - (len, sel, indices) <- arrSelector repr (map Var shape_bndrs) - (vbndr, valts) <- vect_scrut_bndr $ mapM (proc_alt sel vty lty) alts' + let arity = length (tyConDataCons vect_tc) + sel_ty <- builtin (selTy arity) + sel_bndr <- newLocalVar (fsLit "sel") sel_ty + let sel = Var sel_bndr + + (vbndr, valts) <- vect_scrut_bndr + $ mapM (proc_alt arity sel vty lty) alts' let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts vexpr <- vectExpr scrut - (vscrut, arr_tc, _arg_tys) <- mkVScrut (vVar vbndr) - let [arr_dc] = tyConDataCons arr_tc + (vect_scrut, lift_scrut, pdata_tc, _arg_tys) <- mkVScrut (vVar vbndr) + let [pdata_dc] = tyConDataCons pdata_tc - let (vect_scrut, lift_scrut) = vscrut - (vect_bodies, lift_bodies) = unzip vbodies + let (vect_bodies, lift_bodies) = unzip vbodies vdummy <- newDummyVar (exprType vect_scrut) ldummy <- newDummyVar (exprType lift_scrut) let vect_case = Case vect_scrut vdummy vty (zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies) - lbody <- combinePA vty len sel indices lift_bodies + lc <- builtin liftingContext + lbody <- combinePD vty (Var lc) sel lift_bodies let lift_case = Case lift_scrut ldummy lty - [(DataAlt arr_dc, shape_bndrs ++ concat lift_bndrss, + [(DataAlt pdata_dc, sel_bndr : concat lift_bndrss, lbody)] return . vLet (vNonRec vbndr vexpr) @@ -432,75 +441,50 @@ vectAlgCase tycon _ty_args scrut bndr ty alts cmp _ DEFAULT = GT cmp _ _ = panic "vectAlgCase/cmp" - proc_alt sel vty lty (DataAlt dc, bndrs, body) + proc_alt arity sel vty lty (DataAlt dc, bndrs, body) = do vect_dc <- maybeV (lookupDataCon dc) - let tag = mkDataConTag vect_dc - fvs = freeVarsOf body `delVarSetList` bndrs - (vect_bndrs, lift_bndrs, vbody) - <- vect_alt_bndrs bndrs - $ \len -> packLiftingContext len sel tag fvs vty lty - $ vectExpr body - + let ntag = dataConTagZ vect_dc + tag = mkDataConTag vect_dc + fvs = freeVarsOf body `delVarSetList` bndrs + + pick <- builtin (selPick arity) + let flags_expr = mkApps pick [sel, tag] + flags_var <- newLocalVar (fsLit "flags") (exprType flags_expr) + lc <- builtin liftingContext + elems <- builtin (selElements arity ntag) + + (vbndrs, vbody) + <- vectBndrsIn bndrs + . localV + $ do + binds <- mapM (pack_var (Var lc) (Var flags_var)) + . filter isLocalId + $ varSetElems fvs + (ve, le) <- vectExpr body + empty <- emptyPD vty + return (ve, Case (elems `App` sel) lc lty + [(DEFAULT, [], Let (NonRec flags_var flags_expr) + $ mkLets (concat binds) le), + (LitAlt (mkMachInt 0), [], empty)]) + let (vect_bndrs, lift_bndrs) = unzip vbndrs return (vect_dc, vect_bndrs, lift_bndrs, vbody) - proc_alt _ _ _ _ = panic "vectAlgCase/proc_alt" - vect_alt_bndrs [] p - = do - void_tc <- builtin voidTyCon - let void_ty = mkTyConApp void_tc [] - arr_ty <- mkPArrayType void_ty - bndr <- newLocalVar (fsLit "voids") arr_ty - len <- lengthPA void_ty (Var bndr) - e <- p len - return ([], [bndr], e) - - vect_alt_bndrs bndrs p - = localV - $ do - vbndrs <- mapM vectBndr bndrs - let (vect_bndrs, lift_bndrs) = unzip vbndrs - vv : _ = vect_bndrs - lv : _ = lift_bndrs - len <- lengthPA (idType vv) (Var lv) - e <- p len - return (vect_bndrs, lift_bndrs, e) + proc_alt _ _ _ _ _ = panic "vectAlgCase/proc_alt" mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body) -packLiftingContext :: CoreExpr -> CoreExpr -> CoreExpr -> VarSet - -> Type -> Type -> VM VExpr -> VM VExpr -packLiftingContext len shape tag fvs vty lty p - = do - select <- builtin selectPAIntPrimVar - let sel_expr = mkApps (Var select) [shape, tag] - sel_var <- newLocalVar (fsLit "sel#") (exprType sel_expr) - lc_var <- builtin liftingContext - localV $ - do - bnds <- mapM (packFreeVar (Var lc_var) (Var sel_var)) - . filter isLocalId - $ varSetElems fvs - (vexpr, lexpr) <- p - empty <- emptyPA vty - return (vexpr, Let (NonRec sel_var sel_expr) - $ Case len lc_var lty - [(DEFAULT, [], mkLets (concat bnds) lexpr), - (LitAlt (mkMachInt 0), [], empty)]) - -packFreeVar :: CoreExpr -> CoreExpr -> Var -> VM [CoreBind] -packFreeVar len sel v - = do - r <- lookupVar v - case r of - Local (vv,lv) -> - do - lv' <- cloneVar lv - expr <- packPA (idType vv) (Var lv) len sel - updLEnv (upd vv lv') - return [(NonRec lv' expr)] - - _ -> return [] - where - upd vv lv' env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv') } + pack_var len flags v + = do + r <- lookupVar v + case r of + Local (vv, lv) -> + do + lv' <- cloneVar lv + expr <- packPD (idType vv) (Var lv) len flags + updLEnv (\env -> env { local_vars = extendVarEnv + (local_vars env) v (vv, lv') }) + return [(NonRec lv' expr)] + + _ -> return []