X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectType.hs;h=96745c500516baa9f98c70a7397705f22ce92adf;hb=263a30f1db8fc4f5b6cecc26176c6f881807e348;hp=fad264448d756f30e8d38b7515eb41094b37abdc;hpb=f5cbabe851fa8adb9e86daa5c7ec8c9138acc0b7;p=ghc-hetmet.git diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index fad2644..96745c5 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -1,11 +1,12 @@ module VectType ( vectTyCon, vectType, vectTypeEnv, - PAInstance, painstInstance, buildPADict ) + PAInstance, buildPADict ) where #include "HsVersions.h" import VectMonad import VectUtils +import VectCore import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) import CoreSyn @@ -35,7 +36,7 @@ import Digraph ( SCC(..), stronglyConnComp ) import Outputable import Control.Monad ( liftM, liftM2, zipWithM, zipWithM_ ) -import Data.List ( inits, tails ) +import Data.List ( inits, tails, zipWith4 ) -- ---------------------------------------------------------------------------- -- Types @@ -76,12 +77,13 @@ vectType ty = pprPanic "vectType:" (ppr ty) type TyConGroup = ([TyCon], UniqSet TyCon) data PAInstance = PAInstance { - painstInstance :: Instance + painstDFun :: Var + , painstOrigTyCon :: TyCon , painstVectTyCon :: TyCon , painstArrTyCon :: TyCon } -vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [PAInstance]) +vectTypeEnv :: TypeEnv -> VM (TypeEnv, [FamInst], [(Var, CoreExpr)]) vectTypeEnv env = do cs <- readGEnv $ mk_map . global_tycons @@ -95,7 +97,9 @@ vectTypeEnv env vect_tcs = keep_tcs ++ new_tcs parr_tcs <- zipWithM buildPArrayTyCon orig_tcs vect_tcs - pa_insts <- zipWithM buildPAInstance vect_tcs parr_tcs + dfuns <- mapM mkPADFun vect_tcs + defTyConPAs (zip vect_tcs dfuns) + binds <- sequence (zipWith4 buildTyConBindings orig_tcs vect_tcs parr_tcs dfuns) let all_new_tcs = new_tcs ++ parr_tcs @@ -104,7 +108,7 @@ vectTypeEnv env ++ [ADataCon dc | tc <- all_new_tcs , dc <- tyConDataCons tc]) - return (new_env, map mkLocalFamInst parr_tcs, pa_insts) + return (new_env, map mkLocalFamInst parr_tcs, concat binds) where tycons = typeEnvTyCons env groups = tyConGroups tycons @@ -191,35 +195,6 @@ vectDataCon dc rep_arg_tys = dataConRepArgTys dc tycon = dataConTyCon dc -data Shape = Shape { - shapeReprTys :: [Type] - , shapeStrictness :: [StrictnessMark] - , shapeLength :: [CoreExpr] -> VM CoreExpr - , shapeReplicate :: CoreExpr -> CoreExpr -> VM [CoreExpr] - } - -tyConShape :: TyCon -> VM Shape -tyConShape vect_tc - | isProductTyCon vect_tc - = return $ Shape { - shapeReprTys = [intPrimTy] - , shapeStrictness = [NotMarkedStrict] - , shapeLength = \[len] -> return len - , shapeReplicate = \len _ -> return [len] - } - - | otherwise - = do - repr_ty <- mkPArrayType intTy -- FIXME: we want to unbox this - return $ Shape { - shapeReprTys = [repr_ty] - , shapeStrictness = [MarkedStrict] - , shapeLength = \[sel] -> lengthPA sel - , shapeReplicate = \len n -> do - e <- replicatePA len n - return [e] - } - buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc -> do @@ -296,40 +271,111 @@ buildPArrayDataCon orig_name vect_tc repr_tc types = [ty | dc <- tyConDataCons vect_tc , ty <- dataConRepArgTys dc] -buildPAInstance :: TyCon -> TyCon -> VM PAInstance -buildPAInstance vect_tc arr_tc - = do - pa <- builtin paClass - let inst_ty = mkForAllTys tvs - . (mkFunTys $ mkPredTys [ClassP pa [ty] | ty <- arg_tys]) - $ mkPredTy (ClassP pa [mkTyConApp vect_tc arg_tys]) +mkPADFun :: TyCon -> VM Var +mkPADFun vect_tc + = newExportedVar (mkPADFunOcc $ getOccName vect_tc) =<< paDFunType vect_tc - dfun <- newExportedVar (mkPADFunOcc $ getOccName vect_tc) inst_ty +data Shape = Shape { + shapeReprTys :: [Type] + , shapeStrictness :: [StrictnessMark] + , shapeLength :: [CoreExpr] -> VM CoreExpr + , shapeReplicate :: CoreExpr -> CoreExpr -> VM [CoreExpr] + } - return $ PAInstance { - painstInstance = mkLocalInstance dfun NoOverlap - , painstVectTyCon = vect_tc - , painstArrTyCon = arr_tc +tyConShape :: TyCon -> VM Shape +tyConShape vect_tc + | isProductTyCon vect_tc + = return $ Shape { + shapeReprTys = [intPrimTy] + , shapeStrictness = [NotMarkedStrict] + , shapeLength = \[len] -> return len + , shapeReplicate = \len _ -> return [len] + } + + | otherwise + = do + repr_ty <- mkPArrayType intTy -- FIXME: we want to unbox this + return $ Shape { + shapeReprTys = [repr_ty] + , shapeStrictness = [MarkedStrict] + , shapeLength = \[sel] -> lengthPA sel + , shapeReplicate = \len n -> do + e <- replicatePA len n + return [e] } + +buildTyConBindings :: TyCon -> TyCon -> TyCon -> Var -> VM [(Var, CoreExpr)] +buildTyConBindings orig_tc vect_tc arr_tc dfun + = do + shape <- tyConShape vect_tc + sequence_ (zipWith4 (vectDataConWorker shape vect_tc arr_tc arr_dc) + orig_dcs + vect_dcs + (inits repr_tys) + (tails repr_tys)) + dict <- buildPADict shape vect_tc arr_tc dfun + binds <- takeHoisted + return $ (dfun, dict) : binds where - tvs = tyConTyVars arr_tc - arg_tys = mkTyVarTys tvs + orig_dcs = tyConDataCons orig_tc + vect_dcs = tyConDataCons vect_tc + [arr_dc] = tyConDataCons arr_tc + + repr_tys = map dataConRepArgTys vect_dcs -buildPADict :: PAInstance -> VM [(Var, CoreExpr)] -buildPADict (PAInstance { - painstInstance = inst - , painstVectTyCon = vect_tc - , painstArrTyCon = arr_tc }) - = localV . abstractOverTyVars (tyConTyVars arr_tc) $ \abstract -> +vectDataConWorker :: Shape -> TyCon -> TyCon -> DataCon + -> DataCon -> DataCon -> [[Type]] -> [[Type]] + -> VM () +vectDataConWorker shape vect_tc arr_tc arr_dc orig_dc vect_dc pre (dc_tys : post) + = do + clo <- closedV + . inBind orig_worker + . polyAbstract tvs $ \abstract -> + liftM (abstract . vectorised) + $ buildClosures tvs [] dc_tys res_ty (liftM2 (,) mk_vect mk_lift) + + worker <- cloneId mkVectOcc orig_worker (exprType clo) + hoistBinding worker clo + defGlobalVar orig_worker worker + return () + where + tvs = tyConTyVars vect_tc + arg_tys = mkTyVarTys tvs + res_ty = mkTyConApp vect_tc arg_tys + + orig_worker = dataConWorkId orig_dc + + mk_vect = return . mkConApp vect_dc $ map Type arg_tys + mk_lift = do + len <- newLocalVar FSLIT("n") intPrimTy + arr_tys <- mapM mkPArrayType dc_tys + args <- mapM (newLocalVar FSLIT("xs")) arr_tys + shapes <- shapeReplicate shape + (Var len) + (mkDataConTag vect_dc) + + empty_pre <- mapM emptyPA (concat pre) + empty_post <- mapM emptyPA (concat post) + + return . mkLams (len : args) + . wrapFamInstBody arr_tc arg_tys + . mkConApp arr_dc + $ map Type arg_tys ++ shapes + ++ empty_pre + ++ map Var args + ++ empty_post + +buildPADict :: Shape -> TyCon -> TyCon -> Var -> VM CoreExpr +buildPADict shape vect_tc arr_tc dfun + = polyAbstract tvs $ \abstract -> do - shape <- tyConShape vect_tc meth_binds <- mapM (mk_method shape) paMethods let meth_exprs = map (Var . fst) meth_binds - pa_dc <- builtin paDictDataCon + pa_dc <- builtin paDataCon let dict = mkConApp pa_dc (Type (mkTyConApp vect_tc arg_tys) : meth_exprs) body = Let (Rec meth_binds) dict - return [(instanceDFunId inst, mkInlineMe $ abstract body)] + return . mkInlineMe $ abstract body where tvs = tyConTyVars arr_tc arg_tys = mkTyVarTys tvs