X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=6a8f89366f1777e967432b19d437fd2b276ec581;hp=8d9e904498a10a62b4d834c0d9ee4d74d3185095;hb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;hpb=ad94d40948668032189ad22a0ad741ac1f645f50 diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 8d9e904..6a8f893 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -1,14 +1,9 @@ -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings --- for details - module VectUtils ( collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg, collectAnnValBinders, - mkDataConTag, mkDataConTagLit, + dataConTagZ, mkDataConTag, mkDataConTagLit, + + newLocalVVar, mkBuiltinCo, mkPADictType, mkPArrayType, mkPReprType, @@ -16,19 +11,17 @@ 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 -import DsUtils +import MkCore import CoreSyn import CoreUtils import Coercion @@ -37,20 +30,16 @@ import TypeRep import TyCon 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 [] @@ -67,19 +56,21 @@ collectAnnTypeBinders expr = go [] expr collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) collectAnnValBinders expr = go [] expr where - go bs (_, AnnLam b e) | isId b = go (b:bs) e - go bs e = (reverse bs, e) + go bs (_, AnnLam b e) | isIdVar b = go (b:bs) e + go bs e = (reverse bs, e) isAnnTypeArg :: AnnExpr b ann -> Bool -isAnnTypeArg (_, AnnType t) = True +isAnnTypeArg (_, AnnType _) = True isAnnTypeArg _ = False +dataConTagZ :: DataCon -> Int +dataConTagZ con = dataConTag con - fIRST_TAG + mkDataConTagLit :: DataCon -> Literal -mkDataConTagLit con - = mkMachInt . toInteger $ dataConTag con - fIRST_TAG +mkDataConTagLit = mkMachInt . toInteger . dataConTagZ mkDataConTag :: DataCon -> CoreExpr -mkDataConTag con = mkIntLitInt (dataConTag con - fIRST_TAG) +mkDataConTag = mkIntLitInt . dataConTagZ splitPrimTyCon :: Type -> Maybe TyCon splitPrimTyCon ty @@ -103,9 +94,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 @@ -116,6 +108,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 @@ -130,9 +123,10 @@ mkPArrayType :: Type -> VM Type mkPArrayType ty | Just tycon <- splitPrimTyCon ty = do - arr <- traceMaybeV "mkPArrayType" (ppr tycon) - $ lookupPrimPArray tycon - return $ mkTyConApp arr [] + r <- lookupPrimPArray tycon + case r of + Just arr -> return $ mkTyConApp arr [] + Nothing -> cantVectorise "Primitive tycon not vectorised" (ppr tycon) mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty] mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion @@ -159,7 +153,9 @@ mkVScrut (ve, le) prDFunOfTyCon :: TyCon -> VM CoreExpr prDFunOfTyCon tycon - = liftM Var (traceMaybeV "prDictOfTyCon" (ppr tycon) (lookupTyConPR tycon)) + = liftM Var + . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon) + $ lookupTyConPR tycon paDictArgType :: TyVar -> VM (Maybe Type) paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) @@ -167,7 +163,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 @@ -179,7 +175,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 @@ -195,9 +191,11 @@ paDictOfTyApp (TyVarTy tv) ty_args paDFunApply dfun ty_args paDictOfTyApp (TyConApp tc _) ty_args = do - dfun <- traceMaybeV "paDictOfTyApp" (ppr tc) (lookupTyConPA tc) + dfun <- maybeCantVectoriseM "No PA dictionary for tycon" (ppr tc) + $ lookupTyConPA tc paDFunApply (Var dfun) ty_args -paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty) +paDictOfTyApp ty _ + = cantVectorise "Can't construct PA dictionary for type" (ppr ty) paDFunType :: TyCon -> VM Type paDFunType tc @@ -218,19 +216,20 @@ 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) + = liftM Var + . maybeCantVectoriseM "No PA method" (text name <+> text "for" <+> ppr tycon) + $ lookupPrimMethod tycon name -paMethod (method, name) ty +paMethod (method, _name) ty = do fn <- builtin method dict <- paDictOfType ty @@ -253,6 +252,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 @@ -278,7 +289,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]) @@ -329,6 +340,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 @@ -347,14 +372,14 @@ mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg) Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [lclo, larg]) 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 @@ -371,8 +396,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 @@ -398,13 +423,13 @@ buildEnv vvs return (vbody', lbody')) where (vs,ls) = unzip vvs - tys = map idType vs + tys = map varType 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) + \env body -> mkWildCase env ty (exprType body) [(DataAlt (tupleCon Boxed (length vs)), vs, body)]) where ty = mkCoreTupTy tys @@ -421,21 +446,26 @@ 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 - return $ Case scrut (mkWildId (exprType scrut)) + return $ mkWildCase scrut (exprType scrut) (exprType body) [(DataAlt env_con, lc : bndrs, body)] return (env, bind) where vty = mkCoreTupTy tys - bndrs | null vs = [mkWildId unitTy] - | otherwise = vs + args | null vs = [Var unitDataConId] + | otherwise = map Var vs