X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=837a5807dfcec13e1365780feb8fbf0989cb6a58;hp=958c5e6fd7a03c95b17c499da950ce1415f47853;hb=08652e67c4d5d9a40687f93c286021a867c1bca0;hpb=ee79af08084c320762b6b684e2ce8198395cf089 diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 958c5e6..837a580 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -1,8 +1,9 @@ module VectUtils ( collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg, collectAnnValBinders, - mkDataConTag, - splitClosureTy, + dataConTagZ, mkDataConTag, mkDataConTagLit, + + newLocalVVar, mkBuiltinCo, mkPADictType, mkPArrayType, mkPReprType, @@ -10,15 +11,13 @@ module VectUtils ( parrayReprTyCon, parrayReprDataCon, mkVScrut, prDFunOfTyCon, paDictArgType, paDictOfType, paDFunType, - paMethod, mkPR, lengthPA, replicatePA, emptyPA, liftPA, + paMethod, mkPR, lengthPA, replicatePA, emptyPA, packPA, combinePA, liftPA, polyAbstract, polyApply, polyVApply, hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted, buildClosure, buildClosures, mkClosureApp ) where -#include "HsVersions.h" - import VectCore import VectMonad @@ -33,17 +32,15 @@ import DataCon import Var import Id ( mkWildId ) import MkId ( unwrapFamInstScrut ) -import Name ( Name ) -import PrelNames import TysWiredIn -import TysPrim ( intPrimTy ) import BasicTypes ( Boxity(..) ) +import Literal ( Literal, mkMachInt ) import Outputable import FastString -import Data.List ( zipWith4 ) -import Control.Monad ( liftM, liftM2, zipWithM_ ) +import Control.Monad + collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type]) collectAnnTypeArgs expr = go expr [] @@ -64,41 +61,17 @@ collectAnnValBinders expr = go [] expr go bs e = (reverse bs, e) isAnnTypeArg :: AnnExpr b ann -> Bool -isAnnTypeArg (_, AnnType t) = True +isAnnTypeArg (_, AnnType _) = True isAnnTypeArg _ = False -mkDataConTag :: DataCon -> CoreExpr -mkDataConTag = mkIntLitInt . dataConTag - -splitUnTy :: String -> Name -> Type -> Type -splitUnTy s name ty - | Just (tc, [ty']) <- splitTyConApp_maybe ty - , tyConName tc == name - = ty' - - | otherwise = pprPanic s (ppr ty) - -splitBinTy :: String -> Name -> Type -> (Type, Type) -splitBinTy s name ty - | Just (tc, [ty1, ty2]) <- splitTyConApp_maybe ty - , tyConName tc == name - = (ty1, ty2) - - | otherwise = pprPanic s (ppr ty) - -splitFixedTyConApp :: TyCon -> Type -> [Type] -splitFixedTyConApp tc ty - | Just (tc', tys) <- splitTyConApp_maybe ty - , tc == tc' - = tys - - | otherwise = pprPanic "splitFixedTyConApp" (ppr tc <+> ppr ty) +dataConTagZ :: DataCon -> Int +dataConTagZ con = dataConTag con - fIRST_TAG -splitClosureTy :: Type -> (Type, Type) -splitClosureTy = splitBinTy "splitClosureTy" closureTyConName +mkDataConTagLit :: DataCon -> Literal +mkDataConTagLit = mkMachInt . toInteger . dataConTagZ -splitPArrayTy :: Type -> Type -splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName +mkDataConTag :: DataCon -> CoreExpr +mkDataConTag = mkIntLitInt . dataConTagZ splitPrimTyCon :: Type -> Maybe TyCon splitPrimTyCon ty @@ -122,9 +95,10 @@ mkBuiltinTyConApps get_tc tys ty where mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] +{- mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type -mkBuiltinTyConApps1 get_tc dft [] = return dft -mkBuiltinTyConApps1 get_tc dft tys +mkBuiltinTyConApps1 _ dft [] = return dft +mkBuiltinTyConApps1 get_tc _ tys = do tc <- builtin get_tc case tys of @@ -135,6 +109,7 @@ mkBuiltinTyConApps1 get_tc dft tys mkClosureType :: Type -> Type -> VM Type mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty] +-} mkClosureTypes :: [Type] -> Type -> VM Type mkClosureTypes = mkBuiltinTyConApps closureTyCon @@ -186,7 +161,7 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) go ty k | Just k' <- kindView k = go ty k' go ty (FunTy k1 k2) = do - tv <- newTyVar FSLIT("a") k1 + tv <- newTyVar (fsLit "a") k1 mty1 <- go (TyVarTy tv) k1 case mty1 of Just ty1 -> do @@ -198,7 +173,7 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) | isLiftedTypeKind k = liftM Just (mkPADictType ty) - go ty k = return Nothing + go _ _ = return Nothing paDictOfType :: Type -> VM CoreExpr paDictOfType ty = paDictOfTyApp ty_fn ty_args @@ -216,7 +191,7 @@ paDictOfTyApp (TyConApp tc _) ty_args = do dfun <- traceMaybeV "paDictOfTyApp" (ppr tc) (lookupTyConPA tc) paDFunApply (Var dfun) ty_args -paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty) +paDictOfTyApp ty _ = pprPanic "paDictOfTyApp" (ppr ty) paDFunType :: TyCon -> VM Type paDFunType tc @@ -237,19 +212,21 @@ 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 (_method, name) ty | Just tycon <- splitPrimTyCon ty = do fn <- traceMaybeV "paMethod" (ppr tycon <+> text name) $ lookupPrimMethod tycon name return (Var fn) -paMethod (method, name) ty +paMethod (method, _name) ty = do fn <- builtin method dict <- paDictOfType ty @@ -262,10 +239,8 @@ mkPR ty dict <- paDictOfType ty return $ mkApps (Var fn) [Type ty, dict] -lengthPA :: CoreExpr -> VM CoreExpr -lengthPA x = liftM (`App` x) (paMethod pa_length ty) - where - ty = splitPArrayTy (exprType x) +lengthPA :: Type -> CoreExpr -> VM CoreExpr +lengthPA ty x = liftM (`App` x) (paMethod pa_length ty) replicatePA :: CoreExpr -> CoreExpr -> VM CoreExpr replicatePA len x = liftM (`mkApps` [len,x]) @@ -274,6 +249,18 @@ replicatePA len x = liftM (`mkApps` [len,x]) emptyPA :: Type -> VM CoreExpr emptyPA = paMethod pa_empty +packPA :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr +packPA ty xs len sel = liftM (`mkApps` [xs, len, sel]) + (paMethod pa_pack ty) + +combinePA :: Type -> CoreExpr -> 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) + where + n = length xs + liftPA :: CoreExpr -> VM CoreExpr liftPA x = do @@ -299,7 +286,7 @@ polyAbstract tvs p mk_dict_var tv = do r <- paDictArgType tv case r of - Just ty -> liftM Just (newLocalVar FSLIT("dPA") ty) + Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty) Nothing -> return Nothing mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts]) @@ -350,6 +337,20 @@ takeHoisted setGEnv $ env { global_bindings = [] } return $ global_bindings env +{- +boxExpr :: Type -> VExpr -> VM VExpr +boxExpr ty (vexpr, lexpr) + | Just (tycon, []) <- splitTyConApp_maybe ty + , isUnLiftedTyCon tycon + = do + r <- lookupBoxedTyCon tycon + case r of + Just tycon' -> let [dc] = tyConDataCons tycon' + in + return (mkConApp dc [vexpr], lexpr) + Nothing -> return (vexpr, lexpr) +-} + mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) = do @@ -359,25 +360,23 @@ mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv], Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv]) -mkClosureApp :: VExpr -> VExpr -> VM VExpr -mkClosureApp (vclo, lclo) (varg, larg) +mkClosureApp :: Type -> Type -> VExpr -> VExpr -> VM VExpr +mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg) = do vapply <- builtin applyClosureVar lapply <- builtin applyClosurePVar return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg], Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [lclo, larg]) - where - (arg_ty, res_ty) = splitClosureTy (exprType vclo) buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr -buildClosures tvs vars [] res_ty mk_body +buildClosures _ _ [] _ mk_body = mk_body buildClosures tvs vars [arg_ty] res_ty mk_body = buildClosure tvs vars arg_ty res_ty mk_body buildClosures tvs vars (arg_ty : arg_tys) res_ty mk_body = do res_ty' <- mkClosureTypes arg_tys res_ty - arg <- newLocalVVar FSLIT("x") arg_ty + arg <- newLocalVVar (fsLit "x") arg_ty buildClosure tvs vars arg_ty res_ty' . hoistPolyVExpr tvs $ do @@ -394,8 +393,8 @@ buildClosure :: [TyVar] -> [VVar] -> Type -> Type -> VM VExpr -> VM VExpr buildClosure tvs vars arg_ty res_ty mk_body = do (env_ty, env, bind) <- buildEnv vars - env_bndr <- newLocalVVar FSLIT("env") env_ty - arg_bndr <- newLocalVVar FSLIT("arg") arg_ty + env_bndr <- newLocalVVar (fsLit "env") env_ty + arg_bndr <- newLocalVVar (fsLit "arg") arg_ty fn <- hoistPolyVExpr tvs $ do @@ -424,7 +423,7 @@ buildEnv vvs tys = map idType vs mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExpr) -mkVectEnv [] [] = (unitTy, Var unitDataConId, \env body -> body) +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 -> Case env (mkWildId ty) (exprType body) @@ -436,7 +435,7 @@ mkLiftEnv :: Var -> [Type] -> [Var] -> VM (CoreExpr, CoreExpr -> CoreExpr -> VM mkLiftEnv lc [ty] [v] = return (Var v, \env body -> do - len <- lengthPA (Var v) + len <- lengthPA ty (Var v) return . Let (NonRec v env) $ Case len lc (exprType body) [(DEFAULT, [], body)]) @@ -444,11 +443,16 @@ mkLiftEnv lc [ty] [v] mkLiftEnv lc tys 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 - `mkVarApps` (lc : vs) + `mkApps` (Var lc : args) bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env in @@ -459,6 +463,6 @@ mkLiftEnv lc tys vs where vty = mkCoreTupTy tys - bndrs | null vs = [mkWildId unitTy] - | otherwise = vs + args | null vs = [Var unitDataConId] + | otherwise = map Var vs