X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=7aef39b6b959ca76c2d37266d96ee141a5955315;hp=533a8e769409987e37ee088e1d5642c0df1ffc43;hb=9ffadf219cbc4f8ec57264786df936a3cee88aec;hpb=9fd454ab395b70946928ed92c3cb7b28a4d036bc diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 533a8e7..7aef39b 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -1,10 +1,3 @@ -{-# 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/Commentary/CodingStyle#Warnings --- for details - module VectUtils ( collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg, collectAnnValBinders, @@ -25,12 +18,10 @@ module VectUtils ( mkClosureApp ) where -#include "HsVersions.h" - import VectCore import VectMonad -import DsUtils +import MkCore import CoreSyn import CoreUtils import Coercion @@ -39,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 [] @@ -73,7 +60,7 @@ collectAnnValBinders expr = go [] expr go bs e = (reverse bs, e) isAnnTypeArg :: AnnExpr b ann -> Bool -isAnnTypeArg (_, AnnType t) = True +isAnnTypeArg (_, AnnType _) = True isAnnTypeArg _ = False dataConTagZ :: DataCon -> Int @@ -107,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 @@ -120,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 @@ -134,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 @@ -163,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) @@ -171,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 @@ -183,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 @@ -199,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 @@ -222,20 +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 @@ -295,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]) @@ -346,6 +340,7 @@ takeHoisted setGEnv $ env { global_bindings = [] } return $ global_bindings env +{- boxExpr :: Type -> VExpr -> VM VExpr boxExpr ty (vexpr, lexpr) | Just (tycon, []) <- splitTyConApp_maybe ty @@ -357,7 +352,7 @@ boxExpr ty (vexpr, lexpr) 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) @@ -377,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 @@ -401,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 @@ -428,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 @@ -464,7 +459,7 @@ mkLiftEnv lc tys vs 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)