mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
- mkPArrayTyConOcc, mkPArrayDataConOcc,
+ mkPDataTyConOcc, mkPDataDataConOcc,
mkPReprTyConOcc,
mkPADFunOcc,
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
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_"
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,
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 )
mAX_DPH_PROD = 5
mAX_DPH_SUM :: Int
-mAX_DPH_SUM = 3
+mAX_DPH_SUM = 2
mAX_DPH_COMBINE :: Int
mAX_DPH_COMBINE = 2
, dph_Instances :: Module
, dph_Combinators :: Module
, dph_Scalar :: Module
+ , dph_Selector :: Module
, dph_Prelude_PArr :: Module
, dph_Prelude_Int :: Module
, dph_Prelude_Word8 :: Module
, 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")
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
| 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)
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
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 })
, 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
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
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)
vectorised, lifted,
mapVect,
+ vVarType,
+
vNonRec, vRec,
vVar, vType, vNote, vLet,
vLams, vLamsWithoutLC, vVarApps,
- vCaseDEFAULT, vCaseProd, vInlineMe
+ vCaseDEFAULT, vInlineMe
) where
#include "HsVersions.h"
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
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)
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(..),
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")
-
module VectType ( vectTyCon, vectAndLiftType, vectType, vectTypeEnv,
- mkRepr, arrShapeTys, arrShapeVars, arrSelector,
+ -- arrSumArity, pdataCompTys, pdataCompVars,
buildPADict,
fromVect )
where
import Outputable
import FastString
+import MonadUtils ( mapAndUnzip3M )
import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_, mapAndUnzipM )
import Data.List ( inits, tails, zipWith4, zipWith5 )
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
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
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
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
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
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
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),
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
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,
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
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
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
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
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)
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
$ 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
import Module ( PackageId )
import CoreSyn
import CoreUtils
+import MkCore ( mkWildCase )
import CoreFVs
import CoreMonad ( CoreM, getHscEnv )
import DataCon
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
(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
, 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]
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
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)
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 []
projects / ghc-hetmet.git / commitdiff