diff options
Diffstat (limited to 'compiler/vectorise/Vectorise')
28 files changed, 333 insertions, 312 deletions
diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs index a897ad29f4..7fe5b2cecc 100644 --- a/compiler/vectorise/Vectorise/Builtins.hs +++ b/compiler/vectorise/Vectorise/Builtins.hs @@ -6,10 +6,10 @@ module Vectorise.Builtins ( -- * Restrictions mAX_DPH_SCALAR_ARGS, - + -- * Builtins Builtins(..), - + -- * Wrapped selectors selTy, selsTy, selReplicate, diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index d5bbd65ee9..30438f0d1a 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -8,10 +8,10 @@ module Vectorise.Builtins.Base ( mAX_DPH_COMBINE, mAX_DPH_SCALAR_ARGS, aLL_DPH_PRIM_TYCONS, - + -- * Builtins Builtins(..), - + -- * Projections selTy, selsTy, selReplicate, @@ -68,8 +68,8 @@ aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doubleP -- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the -- vectoriser. -- -data Builtins - = Builtins +data Builtins + = Builtins { parrayTyCon :: TyCon -- ^ PArray , pdataTyCon :: TyCon -- ^ PData , pdatasTyCon :: TyCon -- ^ PDatas @@ -100,7 +100,7 @@ data Builtins , closureTyCon :: TyCon -- ^ :-> , closureVar :: Var -- ^ closure , liftedClosureVar :: Var -- ^ liftedClosure - , applyVar :: Var -- ^ $: + , applyVar :: Var -- ^ $: , liftedApplyVar :: Var -- ^ liftedApply , closureCtrFuns :: Array Int Var -- ^ closure1 .. closure3 , selTys :: Array Int Type -- ^ Sel2 @@ -127,7 +127,7 @@ selsLength :: Int -> Builtins -> CoreExpr selsLength = indexBuiltin "selLength" selsLengths selReplicate :: Int -> Builtins -> CoreExpr -selReplicate = indexBuiltin "selReplicate" selReplicates +selReplicate = indexBuiltin "selReplicate" selReplicates selTags :: Int -> Builtins -> CoreExpr selTags = indexBuiltin "selTags" selTagss @@ -140,13 +140,13 @@ sumTyCon = indexBuiltin "sumTyCon" sumTyCons prodTyCon :: Int -> Builtins -> TyCon prodTyCon n _ - | n >= 2 && n <= mAX_DPH_PROD + | n >= 2 && n <= mAX_DPH_PROD = tupleTyCon Boxed n | otherwise = pprPanic "prodTyCon" (ppr n) prodDataCon :: Int -> Builtins -> DataCon -prodDataCon n bi +prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of [con] -> con _ -> pprPanic "prodDataCon" (ppr n) @@ -168,7 +168,7 @@ combinePDVar = indexBuiltin "combinePDVar" combinePDVars combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var combinePD_PrimVar i tc bi - = lookupEnvBuiltin "combinePD_PrimVar" + = lookupEnvBuiltin "combinePD_PrimVar" (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc) scalarZip :: Int -> Builtins -> Var @@ -179,18 +179,18 @@ closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns -- | Get an element from one of the arrays of `Builtins`. -- Panic if the indexed thing is not in the array. -indexBuiltin :: (Ix i, Outputable i) +indexBuiltin :: (Ix i, Outputable i) => String -- ^ Name of the selector we've used, for panic messages. -> (Builtins -> Array i a) -- ^ Field selector for the `Builtins`. -> i -- ^ Index into the array. - -> Builtins + -> Builtins -> a indexBuiltin fn f i bi | inRange (bounds xs) i = xs ! i - | otherwise - = pprSorry "Vectorise.Builtins.indexBuiltin" + | otherwise + = pprSorry "Vectorise.Builtins.indexBuiltin" (vcat [ text "" - , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> + , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> text "' is not yet implemented." , text "This function does not appear in your source program, but it is needed" , text "to compile your code in the backend. This is a known, current limitation" @@ -206,10 +206,10 @@ lookupEnvBuiltin :: String -- Function name for error message -> a lookupEnvBuiltin fn env n | Just r <- lookupNameEnv env n = r - | otherwise - = pprSorry "Vectorise.Builtins.lookupEnvBuiltin" + | otherwise + = pprSorry "Vectorise.Builtins.lookupEnvBuiltin" (vcat [ text "" - , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <> + , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <> text "' is not yet implemented." , text "This function does not appear in your source program, but it is needed" , text "to compile your code in the backend. This is a known, current limitation" diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index ee7cf9c2b5..21de8dcb8b 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -32,7 +32,7 @@ initBuiltins :: DsM Builtins initBuiltins = do { -- 'PArray: representation type for parallel arrays ; parrayTyCon <- externalTyCon (fsLit "PArray") - + -- 'PData': type family mapping array element types to array representation types -- Not all backends use `PDatas`. ; pdataTyCon <- externalTyCon (fsLit "PData") @@ -78,7 +78,7 @@ initBuiltins ; scalar_map <- externalVar (fsLit "scalar_map") ; scalar_zip2 <- externalVar (fsLit "scalar_zipWith") ; scalar_zips <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) - ; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) + ; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips) -- Types and functions for generic type representations @@ -115,9 +115,9 @@ initBuiltins selElementss = array ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements -- Distinct local variable - ; liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique + ; liftingContext <- liftM (\u -> mkSysLocalOrCoVar (fsLit "lc") u intPrimTy) newUnique - ; return $ Builtins + ; return $ Builtins { parrayTyCon = parrayTyCon , pdataTyCon = pdataTyCon , pdatasTyCon = pdatasTyCon @@ -222,11 +222,11 @@ externalType fs -- |Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name. externalClass :: FastString -> DsM Class -externalClass fs +externalClass fs = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon ; case tyConClass_maybe tycon of - Nothing -> pprPanic "Vectorise.Builtins.Initialise" $ - ptext (sLit "Data.Array.Parallel.Prim.") <> + Nothing -> pprPanic "Vectorise.Builtins.Initialise" $ + ptext (sLit "Data.Array.Parallel.Prim.") <> ftext fs <+> ptext (sLit "is not a type class") Just cls -> return cls } diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs index 84797b139b..af807c8fd7 100644 --- a/compiler/vectorise/Vectorise/Convert.hs +++ b/compiler/vectorise/Vectorise/Convert.hs @@ -10,7 +10,7 @@ import Vectorise.Type.Type import CoreSyn import TyCon import Type -import TypeRep +import TyCoRep import NameSet import FastString import Outputable @@ -24,9 +24,9 @@ import Prelude -- avoid redundant import warning due to AMP -- For functions, we eta expand the function and convert the arguments and result: -- For example --- @ --- \(x :: Double) -> --- \(y :: Double) -> +-- @ +-- \(x :: Double) -> +-- \(y :: Double) -> -- ($v_foo $: x) $: y -- @ -- @@ -35,16 +35,16 @@ import Prelude -- avoid redundant import warning due to AMP fromVect :: Type -- ^ The type of the original binding. -> CoreExpr -- ^ Expression giving the closure to use, eg @$v_foo@. -> VM CoreExpr - + -- Convert the type to the core view if it isn't already. -- -fromVect ty expr - | Just ty' <- coreView ty +fromVect ty expr + | Just ty' <- coreView ty = fromVect ty' expr --- For each function constructor in the original type we add an outer +-- For each function constructor in the original type we add an outer -- lambda to bind the parameter variable, and an inner application of it. -fromVect (FunTy arg_ty res_ty) expr +fromVect (ForAllTy (Anon arg_ty) res_ty) expr = do arg <- newLocalVar (fsLit "x") arg_ty varg <- toVect arg_ty (Var arg) @@ -74,25 +74,26 @@ toVect ty expr = identityConv ty >> return expr -- are not altered by vectorisation as they contain no parallel arrays. -- identityConv :: Type -> VM () -identityConv ty - | Just ty' <- coreView ty +identityConv ty + | Just ty' <- coreView ty = identityConv ty' identityConv (TyConApp tycon tys) = do { mapM_ identityConv tys ; identityConvTyCon tycon } -identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" -identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" -identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" -identityConv (FunTy {}) = noV $ text "identityConv: function type changes under vectorisation" -identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" +identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" +identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" +identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" +identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" +identityConv (CastTy {}) = noV $ text "identityConv: not sure about casted types under vectorisation" +identityConv (CoercionTy {}) = noV $ text "identityConv: not sure about coercions under vectorisation" -- |Check that this type constructor is not changed by vectorisation — i.e., it does not embed any -- parallel arrays. -- identityConvTyCon :: TyCon -> VM () identityConvTyCon tc - = do + = do { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons ; parray <- builtin parrayTyCon ; if isParallel && not (tc == parray) diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 098e9c8227..c3b0ee1b02 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -37,8 +37,8 @@ import Data.Maybe -- |Indicates what scope something (a variable) is in. -- -data Scope a b - = Global a +data Scope a b + = Global a | Local b @@ -51,13 +51,13 @@ data LocalEnv { local_vars :: VarEnv (Var, Var) -- ^Mapping from local variables to their vectorised and lifted versions. - , local_tyvars :: [TyVar] + , local_tyvars :: [TyVar] -- ^In-scope type variables. - , local_tyvar_pa :: VarEnv CoreExpr + , local_tyvar_pa :: VarEnv CoreExpr -- ^Mapping from tyvars to their PA dictionaries. - , local_bind_name :: FastString + , local_bind_name :: FastString -- ^Local binding name. This is only used to generate better names for hoisted -- expressions. } @@ -77,7 +77,7 @@ emptyLocalEnv = LocalEnv -- |The global environment: entities that exist at top-level. -- -data GlobalEnv +data GlobalEnv = GlobalEnv { global_vect_avoid :: Bool -- ^'True' implies to avoid vectorisation as far as possible. @@ -113,7 +113,7 @@ data GlobalEnv -- 'global_tycons' (to a type other than themselves) and are still not parallel. An -- example is '(->)'. Moreover, some types have *not* got a mapping in 'global_tycons' -- (because they couldn't be vectorised), but still contain parallel types. - + , global_datacons :: NameEnv DataCon -- ^Mapping from DataCons to their vectorised versions. @@ -146,7 +146,7 @@ initGlobalEnv :: Bool -> FamInstEnvs -> GlobalEnv initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs - = GlobalEnv + = GlobalEnv { global_vect_avoid = vectAvoid , global_vars = mapVarEnv snd $ vectInfoVar info , global_vect_decls = mkVarEnv vects @@ -204,7 +204,7 @@ setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps } -- modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo modVectInfo env mg_ids mg_tyCons vectDecls info - = info + = info { vectInfoVar = mk_env ids (global_vars env) , vectInfoTyCon = mk_env tyCons (global_tycons env) , vectInfoDataCon = mk_env dataCons (global_datacons env) @@ -222,10 +222,10 @@ modVectInfo env mg_ids mg_tyCons vectDecls info tyCons = mg_tyCons ++ vectTypeTyCons dataCons = concatMap tyConDataCons mg_tyCons ++ vectDataCons dataConIds = map dataConWorkId dataCons - selIds = concat [ classAllSelIds cls + selIds = concat [ classAllSelIds cls | tycon <- tyCons , cls <- maybeToList . tyConClass_maybe $ tycon] - + -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv' mk_env decls inspectedEnv = mkNameEnv [(name, (decl, to)) diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 83c87100a2..ffc1b9caf2 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -31,7 +31,7 @@ import DataCon import TyCon import TcType import Type -import TypeRep +import TyCoRep import Var import VarEnv import VarSet @@ -363,7 +363,7 @@ vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) | v == pAT_ERROR_ID = do { (vty, lty) <- vectAndLiftType ty - ; return (mkCoreApps (Var v) [Type vty, err'], mkCoreApps (Var v) [Type lty, err']) + ; return (mkCoreApps (Var v) [Type (getLevity "vectExpr" vty), Type vty, err'], mkCoreApps (Var v) [Type lty, err']) } where err' = deAnnotate err @@ -712,11 +712,11 @@ vectScalarDFun var ; return $ mkLams (tvs ++ vThetaBndr) vBody } where - ty = varType var - (tvs, theta, pty) = tcSplitSigmaTy ty -- 'theta' is the instance context - (cls, tys) = tcSplitDFunHead pty -- 'pty' is the instance head - selIds = classAllSelIds cls - dataCon = classDataCon cls + ty = varType var + (tvs, theta, pty) = tcSplitSigmaTy ty -- 'theta' is the instance context + (cls, tys) = tcSplitDFunHead pty -- 'pty' is the instance head + selIds = classAllSelIds cls + dataCon = classDataCon cls -- Build a value of the dictionary before vectorisation from original, unvectorised type and an -- expression computing the vectorised dictionary. @@ -1039,7 +1039,7 @@ unlessVIParrExpr e1 e2 = e1 `unlessVIParr` vectAvoidInfoOf e2 -- * The first argument is the set of free, local variables whose evaluation may entail parallelism. -- vectAvoidInfo :: VarSet -> CoreExprWithFVs -> VM CoreExprWithVectInfo -vectAvoidInfo pvs ce@(fvs, AnnVar v) +vectAvoidInfo pvs ce@(_, AnnVar v) = do { gpvs <- globalParallelVars ; vi <- if v `elemVarSet` pvs || v `elemVarSet` gpvs @@ -1052,15 +1052,19 @@ vectAvoidInfo pvs ce@(fvs, AnnVar v) ; return ((udfmToUfm fvs, vi), AnnVar v) } + where + fvs = freeVarsOf ce -vectAvoidInfo _pvs ce@(fvs, AnnLit lit) +vectAvoidInfo _pvs ce@(_, AnnLit lit) = do { vi <- vectAvoidInfoTypeOf ce ; viTrace ce vi [] ; return ((udfmToUfm fvs, vi), AnnLit lit) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs ce@(fvs, AnnApp e1 e2) +vectAvoidInfo pvs ce@(_, AnnApp e1 e2) = do { ceVI <- vectAvoidInfoTypeOf ce ; eVI1 <- vectAvoidInfo pvs e1 @@ -1069,8 +1073,10 @@ vectAvoidInfo pvs ce@(fvs, AnnApp e1 e2) -- ; viTrace ce vi [eVI1, eVI2] ; return ((udfmToUfm fvs, vi), AnnApp eVI1 eVI2) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs (fvs, AnnLam var body) +vectAvoidInfo pvs ce@(_, AnnLam var body) = do { bodyVI <- vectAvoidInfo pvs body ; varVI <- vectAvoidInfoType $ varType var @@ -1078,8 +1084,10 @@ vectAvoidInfo pvs (fvs, AnnLam var body) -- ; viTrace ce vi [bodyVI] ; return ((udfmToUfm fvs, vi), AnnLam var bodyVI) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs ce@(fvs, AnnLet (AnnNonRec var e) body) +vectAvoidInfo pvs ce@(_, AnnLet (AnnNonRec var e) body) = do { ceVI <- vectAvoidInfoTypeOf ce ; eVI <- vectAvoidInfo pvs e @@ -1096,8 +1104,10 @@ vectAvoidInfo pvs ce@(fvs, AnnLet (AnnNonRec var e) body) -- ; viTrace ce vi [eVI, bodyVI] ; return ((udfmToUfm fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body) +vectAvoidInfo pvs ce@(_, AnnLet (AnnRec bnds) body) = do { ceVI <- vectAvoidInfoTypeOf ce ; bndsVI <- mapM (vectAvoidInfoBnd pvs) bnds @@ -1119,6 +1129,7 @@ vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body) } } where + fvs = freeVarsOf ce vectAvoidInfoBnd pvs (var, e) = (var,) <$> vectAvoidInfo pvs e isVIParrBnd (var, eVI) @@ -1127,7 +1138,7 @@ vectAvoidInfo pvs ce@(fvs, AnnLet (AnnRec bnds) body) ; return $ isVIParr eVI && not isScalarTy } -vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts) +vectAvoidInfo pvs ce@(_, AnnCase e var ty alts) = do { ceVI <- vectAvoidInfoTypeOf ce ; eVI <- vectAvoidInfo pvs e @@ -1138,6 +1149,7 @@ vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts) ; return ((udfmToUfm fvs, vi), AnnCase eVI var ty altsVI) } where + fvs = freeVarsOf ce vectAvoidInfoAlt scrutIsPar (con, bndrs, e) = do { allScalar <- allScalarVarType bndrs @@ -1146,24 +1158,31 @@ vectAvoidInfo pvs ce@(fvs, AnnCase e var ty alts) ; (con, bndrs,) <$> vectAvoidInfo altPvs e } -vectAvoidInfo pvs (fvs, AnnCast e (fvs_ann, ann)) +vectAvoidInfo pvs ce@(_, AnnCast e (fvs_ann, ann)) = do { eVI <- vectAvoidInfo pvs e - ; return ((udfmToUfm fvs, vectAvoidInfoOf eVI) - , AnnCast eVI ((udfmToUfm fvs_ann, VISimple), ann)) + ; return ((udfmToUfm fvs, vectAvoidInfoOf eVI), AnnCast eVI ((udfmToUfm $ freeVarsOfAnn fvs_ann, VISimple), ann)) } + where + fvs = freeVarsOf ce -vectAvoidInfo pvs (fvs, AnnTick tick e) +vectAvoidInfo pvs ce@(_, AnnTick tick e) = do { eVI <- vectAvoidInfo pvs e ; return ((udfmToUfm fvs, vectAvoidInfoOf eVI), AnnTick tick eVI) } + where + fvs = freeVarsOf ce -vectAvoidInfo _pvs (fvs, AnnType ty) +vectAvoidInfo _pvs ce@(_, AnnType ty) = return ((udfmToUfm fvs, VISimple), AnnType ty) + where + fvs = freeVarsOf ce -vectAvoidInfo _pvs (fvs, AnnCoercion coe) +vectAvoidInfo _pvs ce@(_, AnnCoercion coe) = return ((udfmToUfm fvs, VISimple), AnnCoercion coe) + where + fvs = freeVarsOf ce -- Compute vectorisation avoidance information for a type. -- @@ -1212,6 +1231,7 @@ maybeParrTy ty then return True else or <$> mapM maybeParrTy ts } + -- must be a Named ForAllTy because anon ones respond to splitTyConApp_maybe maybeParrTy (ForAllTy _ ty) = maybeParrTy ty maybeParrTy _ = return False diff --git a/compiler/vectorise/Vectorise/Generic/Description.hs b/compiler/vectorise/Vectorise/Generic/Description.hs index e6a2ee174e..78a8f2c192 100644 --- a/compiler/vectorise/Vectorise/Generic/Description.hs +++ b/compiler/vectorise/Vectorise/Generic/Description.hs @@ -5,7 +5,7 @@ -- from our generic representation. This module computes a description of what -- that generic representation is. -- -module Vectorise.Generic.Description +module Vectorise.Generic.Description ( CompRepr(..) , ProdRepr(..) , ConRepr(..) @@ -13,7 +13,7 @@ module Vectorise.Generic.Description , tyConRepr , sumReprType , compOrigType - ) + ) where import Vectorise.Utils @@ -31,7 +31,7 @@ import Outputable -- | Describes the generic representation of a data type. -- If the data type has multiple constructors then we bundle them -- together into a generic sum type. -data SumRepr +data SumRepr = -- | Data type has no data constructors. EmptySum @@ -57,7 +57,7 @@ data SumRepr , repr_sels_ty :: Type -- | Function to get the length of a Sels of this type. - , repr_selsLength_v :: CoreExpr + , repr_selsLength_v :: CoreExpr -- | Type of each data constructor. , repr_con_tys :: [Type] @@ -68,16 +68,16 @@ data SumRepr -- | Describes the representation type of a data constructor. -data ConRepr - = ConRepr +data ConRepr + = ConRepr { repr_dc :: DataCon - , repr_prod :: ProdRepr + , repr_prod :: ProdRepr } -- | Describes the representation type of the fields \/ components of a constructor. --- If the data constructor has multiple fields then we bundle them +-- If the data constructor has multiple fields then we bundle them -- together into a generic product type. -data ProdRepr +data ProdRepr = -- | Data constructor has no fields. EmptyProd @@ -115,7 +115,7 @@ data CompRepr -- |Determine the generic representation of a data type, given its tycon. -- tyConRepr :: TyCon -> VM SumRepr -tyConRepr tc +tyConRepr tc = sum_repr (tyConDataCons tc) where -- Build the representation type for a data type with the given constructors. @@ -124,22 +124,22 @@ tyConRepr tc sum_repr :: [DataCon] -> VM SumRepr sum_repr [] = return EmptySum sum_repr [con] = liftM UnarySum (con_repr con) - sum_repr cons + sum_repr cons = do let arity = length cons rs <- mapM con_repr cons tys <- mapM conReprType rs -- Get the 'Sum' tycon of this arity (eg Sum2). sum_tc <- builtin (sumTyCon arity) - + -- Get the 'PData' and 'PDatas' tycons for the sum. psum_tc <- pdataReprTyConExact sum_tc psums_tc <- pdatasReprTyConExact sum_tc - + sel_ty <- builtin (selTy arity) sels_ty <- builtin (selsTy arity) selsLength_v <- builtin (selsLength arity) - return $ Sum + return $ Sum { repr_sum_tc = sum_tc , repr_psum_tc = psum_tc , repr_psums_tc = psums_tc @@ -159,7 +159,7 @@ tyConRepr tc prod_repr :: [Type] -> VM ProdRepr prod_repr [] = return EmptyProd prod_repr [ty] = liftM UnaryProd (comp_repr ty) - prod_repr tys + prod_repr tys = do let arity = length tys rs <- mapM comp_repr tys tys' <- mapM compReprType rs @@ -170,15 +170,15 @@ tyConRepr tc -- Get the 'PData' and 'PDatas' tycons for the product. ptup_tc <- pdataReprTyConExact tup_tc ptups_tc <- pdatasReprTyConExact tup_tc - - return $ Prod + + return $ Prod { repr_tup_tc = tup_tc , repr_ptup_tc = ptup_tc , repr_ptups_tc = ptups_tc , repr_comp_tys = tys' , repr_comps = rs } - + -- Build the representation type for a single data constructor field. comp_repr ty = liftM (Keep ty) (prDictOfReprType ty) `orElseV` return (Wrap ty) @@ -228,7 +228,7 @@ instance Outputable SumRepr where -> sep [text "UnarySum", ppr con] Sum sumtc psumtc psumstc selty selsty selsLength contys cons - -> text "Sum" $+$ braces (nest 4 + -> text "Sum" $+$ braces (nest 4 $ sep [ text "repr_sum_tc = " <> ppr sumtc , text "repr_psum_tc = " <> ppr psumtc , text "repr_psums_tc = " <> ppr psumstc @@ -251,10 +251,10 @@ instance Outputable ProdRepr where = case ss of EmptyProd -> text "EmptyProd" - + UnaryProd cr -> sep [text "UnaryProd", ppr cr] - + Prod tuptcs ptuptcs ptupstcs comptys comps -> sep [text "Prod", ppr tuptcs, ppr ptuptcs, ppr ptupstcs, ppr comptys, ppr comps] @@ -264,7 +264,7 @@ instance Outputable CompRepr where = case ss of Keep t ce -> text "Keep" $+$ sep [ppr t, ppr ce] - + Wrap t -> sep [text "Wrap", ppr t] diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs index 7e70f2dd11..85256cf3ab 100644 --- a/compiler/vectorise/Vectorise/Generic/PADict.hs +++ b/compiler/vectorise/Vectorise/Generic/PADict.hs @@ -38,9 +38,9 @@ import FastString -- -- Example: -- df :: forall a. PR (PRepr a) -> PA a -> PA (T a) --- df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ... +-- df = /\a. \(c:PR (PRepr a)) (d:PA a). MkPA c ($PR_df a d) ($toPRepr a d) ... -- $dPR_df :: forall a. PA a -> PR (PRepr (T a)) --- $dPR_df = .... +-- $dPR_df = .... -- $toRepr :: forall a. PA a -> T a -> PRepr (T a) -- $toPRepr = ... -- The "..." stuff is filled in by buildPAScAndMethods @@ -49,7 +49,7 @@ import FastString buildPADict :: TyCon -- ^ tycon of the type being vectorised. -> CoAxiom Unbranched - -- ^ Coercion between the type and + -- ^ Coercion between the type and -- its vectorised representation. -> TyCon -- ^ PData instance tycon -> TyCon -- ^ PDatas instance tycon @@ -62,7 +62,7 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr -- the envt; they don't include the silent superclass args yet do { mod <- liftDs getModule ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name - + -- The superclass dictionary is a (silent) argument if the tycon is polymorphic... ; let mk_super_ty = do { r <- mkPReprType inst_ty ; pr_cls <- builtin prClass @@ -72,7 +72,7 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys ; let val_args = super_args ++ args all_args = tvs ++ val_args - + -- ...it is constant otherwise ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs] @@ -84,13 +84,13 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr ; pa_dc <- builtin paDataCon ; let dict = mkLams all_args (mkConApp pa_dc con_args) con_args = Type inst_ty - : map Var super_args -- the superclass dictionary is either + : map Var super_args -- the superclass dictionary is either ++ super_consts -- lambda-bound or constant ++ map (method_call val_args) method_ids -- Build the type of the dictionary function. ; pa_cls <- builtin paClass - ; let dfun_ty = mkForAllTys tvs + ; let dfun_ty = mkInvForAllTys tvs $ mkFunTys (map varType val_args) (mkClassPred pa_cls [inst_ty]) diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index b5626bd566..d480ea926b 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -1,12 +1,12 @@ -- | Generate methods for the PA class. -- --- TODO: there is a large amount of redundancy here between the +-- TODO: there is a large amount of redundancy here between the -- a, PData a, and PDatas a forms. See if we can factor some of this out. -- module Vectorise.Generic.PAMethods ( buildPReprTyCon - , buildPAScAndMethods + , buildPAScAndMethods ) where import Vectorise.Utils @@ -38,7 +38,7 @@ buildPReprTyCon orig_tc vect_tc repr = do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc) rhs_ty <- sumReprType repr prepr_tc <- builtin preprTyCon - let axiom = mkSingleCoAxiom Nominal name tyvars prepr_tc instTys rhs_ty + let axiom = mkSingleCoAxiom Nominal name tyvars [] prepr_tc instTys rhs_ty liftDs $ newFamInst SynFamilyInst axiom where tyvars = tyConTyVars vect_tc @@ -62,7 +62,7 @@ buildPReprTyCon orig_tc vect_tc repr -- @ -- type PAInstanceBuilder - = TyCon -- ^ Vectorised TyCon + = TyCon -- ^ Vectorised TyCon -> CoAxiom Unbranched -- ^ Coercion to the representation TyCon -> TyCon -- ^ 'PData' TyCon @@ -100,7 +100,7 @@ buildToPRepr vect_tc repr_ax _ _ repr where ty_args = mkTyVarTys (tyConTyVars vect_tc) - wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args + wrap_repr_inst = wrapTypeUnbranchedFamInstBody repr_ax ty_args [] -- CoreExp to convert the given argument to the generic representation. -- We start by doing a case branch on the possible data constructors. @@ -163,7 +163,7 @@ buildFromPRepr vect_tc repr_ax _ _ repr arg_ty <- mkPReprType res_ty arg <- newLocalVar (fsLit "x") arg_ty - result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args (Var arg)) + result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args [] (Var arg)) repr return $ Lam arg result where @@ -191,7 +191,7 @@ buildFromPRepr vect_tc repr_ax _ _ repr from_prod expr con (UnaryProd r) = do e <- from_comp expr r return $ con `App` e - + from_prod expr con (Prod { repr_tup_tc = tup_tc , repr_comp_tys = tys , repr_comps = comps @@ -218,8 +218,8 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r pdata_co <- mkBuiltinCo pdataTyCon let co = mkAppCo pdata_co - . mkSymCo - $ mkUnbranchedAxInstCo Nominal repr_co ty_args + $ mkSymCo + $ mkUnbranchedAxInstCo Nominal repr_co ty_args [] scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) @@ -235,7 +235,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r to_sum ss = case ss of - EmptySum -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) + EmptySum -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) UnarySum r -> to_con r Sum{} -> do let psum_tc = repr_psum_tc ss @@ -244,7 +244,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r sel <- newLocalVar (fsLit "sel") (repr_sel_ty ss) return ( sel : concat vars , wrapFamInstBody psum_tc (repr_con_tys ss) - $ mkConApp psum_con + $ mkConApp psum_con $ map Type (repr_con_tys ss) ++ (Var sel : exprs)) to_prod ss @@ -283,7 +283,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r pdata_co <- mkBuiltinCo pdataTyCon let co = mkAppCo pdata_co - $ mkUnbranchedAxInstCo Nominal repr_co var_tys + $ mkUnbranchedAxInstCo Nominal repr_co var_tys [] let scrut = mkCast (Var arg) co @@ -330,7 +330,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r let scrut = unwrapFamInstScrut ptup_tc (repr_comp_tys ss) expr let body = mkWildCase scrut (exprType scrut) res_ty [(DataAlt ptup_con, vars, res')] - return (body, args) + return (body, args) from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r @@ -342,7 +342,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) where - f' (expr, r) (res, args) + f' (expr, r) (res, args) = do (res', args') <- f res_ty res expr r return (res', args' ++ args) @@ -357,7 +357,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- eg: 'PDatas (Tree a b)' arg_ty <- mkPDatasType el_ty - -- The result type. + -- The result type. -- eg: 'PDatas (PRepr (Tree a b))' res_ty <- mkPDatasType =<< mkPReprType el_ty @@ -368,8 +368,8 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- Coercion to case between the (PRepr a) type and its instance. pdatas_co <- mkBuiltinCo pdatasTyCon let co = mkAppCo pdatas_co - . mkSymCo - $ mkUnbranchedAxInstCo Nominal repr_co ty_args + $ mkSymCo + $ mkUnbranchedAxInstCo Nominal repr_co ty_args [] let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg) (vars, result) <- to_sum r @@ -383,10 +383,10 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- eg: 'Tree a b'. ty_args = mkTyVarTys $ tyConTyVars vect_tc el_ty = mkTyConApp vect_tc ty_args - + -- PDatas data constructor [pdatas_dc] = tyConDataCons pdatas_tc - + to_sum ss = case ss of -- We can't convert data types with no data. @@ -401,7 +401,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r let [psums_con] = tyConDataCons psums_tc sels <- newLocalVar (fsLit "sels") (repr_sels_ty ss) - -- Take the number of selectors to serve as the length of + -- Take the number of selectors to serve as the length of -- and PDatas Void arrays in the product. See Note [Empty PDatas]. let xSums = App (repr_selsLength_v ss) (Var sels) @@ -412,12 +412,12 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r , wrapFamInstBody psums_tc (repr_con_tys ss) $ mkCoreLet (NonRec xSums_var xSums) -- mkCoreLet ensures that the let/app invariant holds - $ mkConApp psums_con - $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) + $ mkConApp psums_con + $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) to_prod xSums ss = case ss of - EmptyProd + EmptyProd -> do pvoids <- builtin pvoidsVar return ([], App (Var pvoids) (Var xSums) ) @@ -447,23 +447,23 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- buildFromArrPReprs --------------------------------------------------------- buildFromArrPReprs :: PAInstanceBuilder buildFromArrPReprs vect_tc repr_co _ pdatas_tc r - = do + = do -- The argument type of the instance. -- eg: 'PDatas (PRepr (Tree a b))' arg_ty <- mkPDatasType =<< mkPReprType el_ty - -- The result type. + -- The result type. -- eg: 'PDatas (Tree a b)' res_ty <- mkPDatasType el_ty - + -- Variable to bind the argument to the instance -- eg: (xss :: PDatas (PRepr (Tree a b))) varg <- newLocalVar (fsLit "xss") arg_ty - + -- Build the coercion between PRepr and the instance type pdatas_co <- mkBuiltinCo pdatasTyCon let co = mkAppCo pdatas_co - $ mkUnbranchedAxInstCo Nominal repr_co var_tys + $ mkUnbranchedAxInstCo Nominal repr_co var_tys [] let scrut = mkCast (Var varg) co @@ -518,7 +518,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r let scrut = unwrapFamInstScrut ptups_tc (repr_comp_tys ss) expr let body = mkWildCase scrut (exprType scrut) res_ty [(DataAlt ptups_con, vars, res')] - return (body, args) + return (body, args) from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r @@ -531,7 +531,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) where - f' (expr, r) (res, args) + f' (expr, r) (res, args) = do (res', args') <- f res_ty res expr r return (res', args' ++ args) @@ -563,12 +563,12 @@ initialise the two (PDatas Void) arrays. However, with this: data Empty1 = MkEmpty1 - + The native and generic representations would be: type instance (PDatas Empty1) = VPDs:Empty1 type instance (PDatas (Repr Empty1)) = PVoids Int - -The 'Int' argument of PVoids is supposed to store the length of the PDatas + +The 'Int' argument of PVoids is supposed to store the length of the PDatas array. When converting the (PDatas Empty1) to a (PDatas (Repr Empty1)) we need to come up with a value for it, but there isn't one. diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index b69a773626..a8bffbe962 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -46,20 +46,20 @@ buildDataFamInst name' fam_tc vect_tc rhs = do { axiom_name <- mkDerivedName mkInstTyCoOcc name' ; (_, tyvars') <- liftDs $ tcInstSigTyVarsLoc (getSrcSpan name') tyvars - ; let ax = mkSingleCoAxiom Representational axiom_name tyvars' fam_tc pat_tys rep_ty + ; let ax = mkSingleCoAxiom Representational axiom_name tyvars' [] fam_tc pat_tys rep_ty tys' = mkTyVarTys tyvars' rep_ty = mkTyConApp rep_tc tys' pat_tys = [mkTyConApp vect_tc tys'] - rep_tc = buildAlgTyCon name' + rep_tc = mkAlgTyCon name' + (mkPiTypesPreferFunTy tyvars' liftedTypeKind) tyvars' (map (const Nominal) tyvars') Nothing [] -- no stupid theta rhs + (DataFamInstTyCon ax fam_tc pat_tys) rec_flag -- FIXME: is this ok? - False -- Not promotable False -- not GADT syntax - (DataFamInstTyCon ax fam_tc pat_tys) ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } where tyvars = tyConTyVars vect_tc @@ -77,9 +77,10 @@ buildPDataDataCon orig_name vect_tc repr_tc repr dc_name <- mkLocalisedName mkPDataDataConOcc orig_name comp_tys <- mkSumTys repr_sel_ty mkPDataType repr fam_envs <- readGEnv global_fam_inst_env + rep_nm <- liftDs $ newTyConRepName dc_name liftDs $ buildDataCon fam_envs dc_name False -- not infix - NotPromoted -- not promotable + rep_nm (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels @@ -120,9 +121,10 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr fam_envs <- readGEnv global_fam_inst_env + rep_nm <- liftDs $ newTyConRepName dc_name liftDs $ buildDataCon fam_envs dc_name False -- not infix - NotPromoted -- not promotable + rep_nm (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 4e9726a598..4e7ee168b7 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -10,12 +10,12 @@ module Vectorise.Monad ( liftBuiltinDs, builtin, builtins, - + -- * Variables lookupVar, lookupVar_maybe, - addGlobalParallelVar, - addGlobalParallelTyCon, + addGlobalParallelVar, + addGlobalParallelTyCon, ) where import Vectorise.Monad.Base @@ -72,13 +72,13 @@ initV hsc_env guts info thing_inside dflags = hsc_dflags hsc_env dumpIfVtTrace = dumpIfSet_dyn dflags Opt_D_dump_vt_trace - + bindsToIds (NonRec v _) = [v] bindsToIds (Rec binds) = map fst binds - + ids = concatMap bindsToIds (mg_binds guts) - go + go = do { -- set up tables of builtin entities ; builtins <- initBuiltins ; builtin_vars <- initBuiltinVars builtins @@ -96,15 +96,15 @@ initV hsc_env guts info thing_inside ; let genv = extendImportedVarsEnv builtin_vars . setPAFunsEnv builtin_pas . setPRFunsEnv builtin_prs - $ initGlobalEnv (gopt Opt_VectorisationAvoidance dflags) + $ initGlobalEnv (gopt Opt_VectorisationAvoidance dflags) info (mg_vect_decls guts) instEnvs famInstEnvs - + -- perform vectorisation ; r <- runVM thing_inside builtins genv emptyLocalEnv ; case r of Yes genv _ x -> return $ Just (new_info genv, x) No reason -> do { unqual <- mkPrintUnqualifiedDs - ; liftIO $ + ; liftIO $ printOutputForUser dflags unqual $ mkDumpDoc "Warning: vectorisation failure:" reason ; return Nothing @@ -193,6 +193,6 @@ addGlobalParallelVar var addGlobalParallelTyCon :: TyCon -> VM () addGlobalParallelTyCon tycon = do { traceVt "addGlobalParallelTyCon" (ppr tycon) - ; updGEnv $ \env -> + ; updGEnv $ \env -> env{global_parallel_tycons = extendNameSet (global_parallel_tycons env) (tyConName tycon)} } diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs index f043f2552e..da53e8b94d 100644 --- a/compiler/vectorise/Vectorise/Monad/Base.hs +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -12,10 +12,10 @@ module Vectorise.Monad.Base ( cantVectorise, maybeCantVectorise, maybeCantVectoriseM, - + -- * Debugging emitVt, traceVt, dumpOptVt, dumpVt, - + -- * Control noV, traceNoV, ensureV, traceEnsureV, @@ -43,11 +43,11 @@ import Control.Monad -- |Vectorisation can either succeed with new envionment and a value, or return with failure -- (including a description of the reason for failure). -- -data VResult a - = Yes GlobalEnv LocalEnv a +data VResult a + = Yes GlobalEnv LocalEnv a | No SDoc -newtype VM a +newtype VM a = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) } instance Monad VM where @@ -61,10 +61,10 @@ instance Monad VM where instance Applicative VM where pure x = VM $ \_ genv lenv -> return (Yes genv lenv x) (<*>) = ap - + instance Functor VM where fmap = liftM - + instance MonadIO VM where liftIO = liftDs . liftIO @@ -113,7 +113,7 @@ maybeCantVectoriseM s d p -- |Output a trace message if -ddump-vt-trace is active. -- -emitVt :: String -> SDoc -> VM () +emitVt :: String -> SDoc -> VM () emitVt herald doc = liftDs $ do dflags <- getDynFlags @@ -122,7 +122,7 @@ emitVt herald doc -- |Output a trace message if -ddump-vt-trace is active. -- -traceVt :: String -> SDoc -> VM () +traceVt :: String -> SDoc -> VM () traceVt herald doc = do dflags <- getDynFlags when (1 <= traceLevel dflags) $ @@ -131,17 +131,17 @@ traceVt herald doc -- |Dump the given program conditionally. -- dumpOptVt :: DumpFlag -> String -> SDoc -> VM () -dumpOptVt flag header doc +dumpOptVt flag header doc = do { b <- liftDs $ doptM flag - ; if b - then dumpVt header doc - else return () + ; if b + then dumpVt header doc + else return () } -- |Dump the given program unconditionally. -- dumpVt :: String -> SDoc -> VM () -dumpVt header doc +dumpVt header doc = do { unqual <- liftDs mkPrintUnqualifiedDs ; dflags <- liftDs getDynFlags ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc) @@ -190,7 +190,7 @@ tryErrV (VM p) = VM $ \bi genv lenv -> Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) No reason -> do { unqual <- mkPrintUnqualifiedDs ; dflags <- getDynFlags - ; liftIO $ + ; liftIO $ printInfoForUser dflags unqual $ text "Warning: vectorisation failure:" <+> reason ; return (Yes genv lenv Nothing) diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index 143330554f..2ad0059596 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -4,31 +4,31 @@ module Vectorise.Monad.Global ( readGEnv, setGEnv, updGEnv, - + -- * Configuration isVectAvoidanceAggressive, - + -- * Vars defGlobalVar, undefGlobalVar, - + -- * Vectorisation declarations - lookupVectDecl, - + lookupVectDecl, + -- * Scalars globalParallelVars, globalParallelTyCons, - + -- * TyCons lookupTyCon, defTyConName, defTyCon, globalVectTyCons, - + -- * Datacons lookupDataCon, defDataCon, - + -- * PA Dictionaries lookupTyConPA, defTyConPAs, - + -- * PR Dictionaries lookupTyConPR ) where @@ -85,7 +85,7 @@ isVectAvoidanceAggressive = readGEnv global_vect_avoid -- defGlobalVar :: Var -> Var -> VM () defGlobalVar v v' - = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') + = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') -- check for duplicate vectorisation ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v @@ -101,7 +101,7 @@ defGlobalVar v v' where moduleOf var var' | var == var' = ptext (sLit "vectorises to itself") - | Just mod <- nameModule_maybe (Var.varName var') + | Just mod <- nameModule_maybe (Var.varName var') = ptext (sLit "in module") <+> ppr mod | otherwise = ptext (sLit "in the current module") @@ -110,7 +110,7 @@ defGlobalVar v v' -- undefGlobalVar :: Var -> VM () undefGlobalVar v - = do + = do { traceVt "REMOVING global var mapping:" (ppr v) ; updGEnv $ \env -> env { global_vars = delVarEnv (global_vars env) v } } @@ -124,8 +124,8 @@ undefGlobalVar v -- The second component contains the given type and expression in case of a 'VECTORISE' declaration. -- lookupVectDecl :: Var -> VM (Bool, Maybe (Type, CoreExpr)) -lookupVectDecl var - = readGEnv $ \env -> +lookupVectDecl var + = readGEnv $ \env -> case lookupVarEnv (global_vect_decls env) var of Nothing -> (False, Nothing) Just Nothing -> (True, Nothing) @@ -164,7 +164,7 @@ lookupTyCon tc -- defTyConName :: TyCon -> Name -> TyCon -> VM () defTyConName tc nameOfTc' tc' - = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc') + = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc') -- check for duplicate vectorisation ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) @@ -175,13 +175,13 @@ defTyConName tc nameOfTc' tc' ppr tc <+> moduleOf tc old_tc' Nothing -> return () - ; updGEnv $ \env -> + ; updGEnv $ \env -> env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' } } where moduleOf tc tc' | tc == tc' = ptext (sLit "vectorises to itself") - | Just mod <- nameModule_maybe (tyConName tc') + | Just mod <- nameModule_maybe (tyConName tc') = ptext (sLit "in module") <+> ppr mod | otherwise = ptext (sLit "in the current module") @@ -203,9 +203,9 @@ globalVectTyCons = readGEnv global_tycons -- lookupDataCon :: DataCon -> VM (Maybe DataCon) lookupDataCon dc - | isTupleTyCon (dataConTyCon dc) + | isTupleTyCon (dataConTyCon dc) = return (Just dc) - | otherwise + | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc) -- |Add the mapping between plain and vectorised `DataCon`s to the global environment. diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index a97f319b4f..64b7441235 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} -module Vectorise.Monad.InstEnv +module Vectorise.Monad.InstEnv ( existsInst , lookupInst , lookupFamInst - ) + ) where import Vectorise.Monad.Global @@ -34,8 +34,8 @@ existsInst cls tys -- Look up the dfun of a class instance. -- --- The match must be unique —i.e., match exactly one instance— but the --- type arguments used for matching may be more specific than those of +-- The match must be unique —i.e., match exactly one instance— but the +-- type arguments used for matching may be more specific than those of -- the class instance declaration. The found class instances must not have -- any type variables in the instance context that do not appear in the -- instances head (i.e., no flexi vars); for details for what this means, @@ -53,8 +53,8 @@ lookupInst cls tys -- Look up a family instance. -- --- The match must be unique - ie, match exactly one instance - but the --- type arguments used for matching may be more specific than those of +-- The match must be unique - ie, match exactly one instance - but the +-- type arguments used for matching may be more specific than those of -- the family instance declaration. -- -- Return the family instance and its type instance. For example, if we have @@ -73,7 +73,7 @@ lookupFamInst tycon tys do { instEnv <- readGEnv global_fam_inst_env ; case lookupFamInstEnv instEnv tycon tys of [match] -> return match - _other -> + _other -> do dflags <- getDynFlags cantVectorise dflags "Vectorise.Monad.InstEnv.lookupFamInst: not found: " (ppr $ mkTyConApp tycon tys) diff --git a/compiler/vectorise/Vectorise/Monad/Local.hs b/compiler/vectorise/Vectorise/Monad/Local.hs index 6816627fb9..61f55ccd43 100644 --- a/compiler/vectorise/Vectorise/Monad/Local.hs +++ b/compiler/vectorise/Vectorise/Monad/Local.hs @@ -1,4 +1,4 @@ -module Vectorise.Monad.Local +module Vectorise.Monad.Local ( readLEnv , setLEnv , updLEnv @@ -12,7 +12,7 @@ module Vectorise.Monad.Local , localTyVars ) where - + import Vectorise.Monad.Base import Vectorise.Env @@ -43,8 +43,8 @@ updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ()) -- This does not alter the environment of the current state. -- localV :: VM a -> VM a -localV p - = do +localV p + = do { env <- readLEnv id ; x <- p ; setLEnv env @@ -54,7 +54,7 @@ localV p -- |Perform a computation in an empty local environment. -- closedV :: VM a -> VM a -closedV p +closedV p = do { env <- readLEnv id ; setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env }) @@ -68,7 +68,7 @@ closedV p getBindName :: VM FastString getBindName = readLEnv local_bind_name --- |Run a vectorisation computation in a local environment, +-- |Run a vectorisation computation in a local environment, -- with this id set as the current binding. -- inBind :: Id -> VM a -> VM a @@ -77,13 +77,11 @@ inBind id p p -- |Lookup a PA tyvars from the local environment. --- lookupTyVarPA :: Var -> VM (Maybe CoreExpr) -lookupTyVarPA tv - = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv +lookupTyVarPA tv + = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv -- |Add a tyvar to the local environment. --- defLocalTyVar :: TyVar -> VM () defLocalTyVar tv = updLEnv $ \env -> env { local_tyvars = tv : local_tyvars env @@ -91,7 +89,6 @@ defLocalTyVar tv = updLEnv $ \env -> } -- |Add mapping between a tyvar and pa dictionary to the local environment. --- defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM () defLocalTyVarWithPA tv pa = updLEnv $ \env -> env { local_tyvars = tv : local_tyvars env @@ -99,6 +96,5 @@ defLocalTyVarWithPA tv pa = updLEnv $ \env -> } -- |Get the set of tyvars from the local environment. --- localTyVars :: VM [TyVar] localTyVars = readLEnv (reverse . local_tyvars) diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs index b53324012f..9bb9bd1923 100644 --- a/compiler/vectorise/Vectorise/Monad/Naming.hs +++ b/compiler/vectorise/Vectorise/Monad/Naming.hs @@ -10,6 +10,7 @@ module Vectorise.Monad.Naming , newLocalVars , newDummyVar , newTyVar + , newCoVar ) where @@ -50,11 +51,11 @@ mkLocalisedName mk_occ name mkDerivedName :: (OccName -> OccName) -> Name -> VM Name -- Similar to mkLocalisedName, but assumes the --- incoming name is from this module. +-- incoming name is from this module. -- Works on External names only -mkDerivedName mk_occ name +mkDerivedName mk_occ name = do { u <- liftDs newUnique - ; return (mkExternalName u (nameModule name) + ; return (mkExternalName u (nameModule name) (mk_occ (nameOccName name)) (nameSrcSpan name)) } @@ -69,7 +70,7 @@ mkVectId id ty = do { name <- mkLocalisedName mkVectOcc (getName id) ; let id' | isDFunId id = MkId.mkDictFunId name tvs theta cls tys | isExportedId id = Id.mkExportedLocalId VanillaId name ty - | otherwise = Id.mkLocalId name ty + | otherwise = Id.mkLocalIdOrCoVar name ty ; return id' } where @@ -87,7 +88,7 @@ cloneVar var = liftM (setIdUnique var) (liftDs newUnique) -- |Make a fresh exported variable with the given type. -- newExportedVar :: OccName -> Type -> VM Var -newExportedVar occ_name ty +newExportedVar occ_name ty = do mod <- liftDs getModule u <- liftDs newUnique @@ -101,7 +102,7 @@ newExportedVar occ_name ty newLocalVar :: FastString -> Type -> VM Var newLocalVar fs ty = do u <- liftDs newUnique - return $ mkSysLocal fs u ty + return $ mkSysLocalOrCoVar fs u ty -- |Make several fresh local variables with the given types. -- The variable's names are formed using the given string as the prefix. @@ -121,3 +122,9 @@ newTyVar :: FastString -> Kind -> VM Var newTyVar fs k = do u <- liftDs newUnique return $ mkTyVar (mkSysTvName u fs) k + +-- |Mkae a fresh coercion variable with the given kind. +newCoVar :: FastString -> Kind -> VM Var +newCoVar fs k + = do u <- liftDs newUnique + return $ mkCoVar (mkSystemVarName u fs) k diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index 21a221d968..55eb459e8e 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -13,9 +13,9 @@ -- types. As '([::])' is being vectorised, any type constructor whose definition involves -- '([::])', either directly or indirectly, will be vectorised. -module Vectorise.Type.Classify +module Vectorise.Type.Classify ( classifyTyCons - ) + ) where import NameSet @@ -23,12 +23,11 @@ import UniqSet import UniqFM import DataCon import TyCon -import TypeRep -import Type hiding (tyConsOfType) +import TyCoRep +import qualified Type import PrelNames import Digraph - -- |From a list of type constructors, extract those that can be vectorised, returning them in two -- sets, where the first result list /must be/ vectorised and the second result list /need not be/ -- vectorised. The third result list are those type constructors that we cannot convert (either @@ -66,14 +65,14 @@ classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyC = classify conv keep (par ++ tcs_par) (tcs ++ novect) cs pts' rs where refs = ds `delListFromUniqSet` tcs - + -- the tycons that directly or indirectly depend on parallel arrays tcs_par | any ((`elemNameSet` parTyCons) . tyConName) . eltsUFM $ refs = tcs | otherwise = [] pts' = pts `extendNameSetList` map tyConName tcs_par - can_convert = (isNullUFM (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `minusUFM` cs)) + can_convert = (isNullUFM (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `minusUFM` cs)) && all convertable tcs) || isShowClass tcs must_convert = foldUFM (||) False (intersectUFM_C const cs refs) @@ -81,10 +80,10 @@ classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyC -- We currently admit Haskell 2011-style data and newtype declarations as well as type -- constructors representing classes. - convertable tc + convertable tc = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc) || isClassTyCon tc - + -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a -- vectorised definition (to be able to vectorise 'Num') isShowClass [tc] = tyConName tc == showClassName @@ -120,18 +119,6 @@ tyConsOfTypes = unionManyUniqSets . map tyConsOfType -- |Collect the set of TyCons that occur in this type. -- tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty - | Just ty' <- coreView ty = tyConsOfType ty' -tyConsOfType (TyVarTy _) = emptyUniqSet -tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys) - where - extend | isUnLiftedTyCon tc - || isTupleTyCon tc = id - - | otherwise = (`addOneToUniqSet` tc) +tyConsOfType ty = filterUniqSet not_tuple_or_unlifted $ Type.tyConsOfType ty + where not_tuple_or_unlifted tc = not (isUnLiftedTyCon tc || isTupleTyCon tc) -tyConsOfType (AppTy a b) = tyConsOfType a `unionUniqSets` tyConsOfType b -tyConsOfType (FunTy a b) = (tyConsOfType a `unionUniqSets` tyConsOfType b) - `addOneToUniqSet` funTyCon -tyConsOfType (LitTy _) = emptyUniqSet -tyConsOfType (ForAllTy _ ty) = tyConsOfType ty diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 8396e2cafa..e4b538ac34 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -5,10 +5,10 @@ -- This produces new type constructors and family instances top be included in the module toplevel -- as well as bindings for worker functions, dfuns, and the like. -module Vectorise.Type.Env ( +module Vectorise.Type.Env ( vectTypeEnv, ) where - + #include "HsVersions.h" import Vectorise.Env @@ -84,7 +84,7 @@ import Data.List -- -- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an -- explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code (i.e., the --- constructors of 'T' may not occur in vectorised code). +-- constructors of 'T' may not occur in vectorised code). -- -- An example is the treatment of '[::]'. The type '[::]' can be used in vectorised code and is -- vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised @@ -123,7 +123,7 @@ import Data.List -- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated -- by the vectoriser). -- --- Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this +-- Type constructors declared with {-# VECTORISE SCALAR type T = Tv #-} are treated in this -- manner. (The vectoriser never treats a type constructor automatically in this manner.) -- -- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}. @@ -173,21 +173,21 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls impVectTyCons = ( [tycon | VectType False tycon Nothing <- vectTypeDecls] ++ [tycon | VectClass tycon <- vectClassDecls]) \\ tycons - + -- {-# VECTORISE type T = Tv -#} (imported & local tycons with an /RHS/) vectTyConsWithRHS = [ (tycon, rhs) | VectType False tycon (Just rhs) <- vectTypeDecls] -- {-# VECTORISE SCALAR type T = Tv -#} (imported & local tycons with an /RHS/) - scalarTyConsWithRHS = [ (tycon, rhs) + scalarTyConsWithRHS = [ (tycon, rhs) | VectType True tycon (Just rhs) <- vectTypeDecls] -- {-# VECTORISE SCALAR type T -#} (imported & local /scalar/ tycons without an RHS) scalarTyConsNoRHS = [tycon | VectType True tycon Nothing <- vectTypeDecls] -- Check that is not a VECTORISE SCALAR tycon nor VECTORISE tycons with explicit rhs? - vectSpecialTyConNames = mkNameSet . map tyConName $ - scalarTyConsNoRHS ++ + vectSpecialTyConNames = mkNameSet . map tyConName $ + scalarTyConsNoRHS ++ map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS) notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames @@ -197,14 +197,14 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ; vectTyCons <- globalVectTyCons ; let vectTyConBase = mapUFM_Directly isDistinct vectTyCons -- 'True' iff tc /= V[[tc]] isDistinct u tc = u /= getUnique tc - vectTyConFlavour = vectTyConBase - `plusNameEnv` - mkNameEnv [ (tyConName tycon, True) + vectTyConFlavour = vectTyConBase + `plusNameEnv` + mkNameEnv [ (tyConName tycon, True) | (tycon, _) <- vectTyConsWithRHS ++ scalarTyConsWithRHS] `plusNameEnv` mkNameEnv [ (tyConName tycon, False) -- original representation | tycon <- scalarTyConsNoRHS] - + -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2) -- that we could, but don't need to vectorise. Type constructors that are not data @@ -230,19 +230,19 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ; traceVt " -- after classification (local and VECT [class] tycons) --" Outputable.empty ; traceVt " reuse : " $ ppr keep_tcs ; traceVt " convert : " $ ppr conv_tcs - + -- warn the user about unvectorised type constructors ; let explanation = ptext (sLit "(They use unsupported language extensions") $$ ptext (sLit "or depend on type constructors that are not vectorised)") drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) . filter (not . isTypeSynonymTyCon) $ drop_tcs ; unless (null drop_tcs_nosyn) $ - emitVt "Warning: cannot vectorise these type constructors:" $ + emitVt "Warning: cannot vectorise these type constructors:" $ pprQuotedList drop_tcs_nosyn $$ explanation ; mapM_ addParallelTyConAndCons $ par_tcs ++ map fst vectTyConsWithRHS - ; let mapping = + ; let mapping = -- Type constructors that we found we don't need to vectorise and those -- declared VECTORISE SCALAR /without/ an explicit right-hand side, use the same -- representation in both unvectorised and vectorised code; they are not @@ -256,7 +256,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Vectorise all the data type declarations that we can and must vectorise (enter the -- type and data constructors into the vectorisation map on-the-fly.) ; new_tcs <- vectTyConDecls conv_tcs - + ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$ ppr vTc <+> text "::" <+> ppr (dataConSig vTc)) dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc @@ -280,7 +280,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls repr_axs = map famInstAxiom repr_fis pdata_tcs = famInstsRepTyCons pdata_fis pdatas_tcs = famInstsRepTyCons pdatas_fis - + ; updGEnv $ extendFamEnv fam_insts -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of @@ -328,7 +328,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Ignoring the promoted tycon; hope that's ok } - -- Add a mapping from the original to vectorised type constructor to the vectorisation map. + -- Add a mapping from the original to vectorised type constructor to the vectorisation map. -- Unless the type constructor is abstract, also mappings from the orignal's data constructors -- to the vectorised type's data constructors. -- @@ -343,7 +343,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls { canonName <- mkLocalisedName mkVectTyConOcc origName ; if origName == vectName -- Case (1) || vectName == canonName -- Case (2) - then do + then do { defTyCon origTyCon vectTyCon -- T --> vT ; defDataCons -- Ci --> vCi ; return Nothing @@ -360,10 +360,10 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls vectName = tyConName vectTyCon mkSyn canonName ty = mkSynonymTyCon canonName (typeKind ty) [] [] ty - + defDataCons | isAbstract = return () - | otherwise + | otherwise = do { MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon)) ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon) } @@ -386,7 +386,7 @@ buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () vectDataConWorkers orig_tc vect_tc arr_tc = do { traceVt "Building vectorised worker for datatype" (ppr orig_tc) - + ; bs <- sequence . zipWith3 def_worker (tyConDataCons orig_tc) rep_tys $ zipWith4 mk_data_con (tyConDataCons vect_tc) diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index e462d0fac1..859df3749b 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -6,7 +6,7 @@ module Vectorise.Type.TyConDecl ( import Vectorise.Type.Type import Vectorise.Monad import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) -import BuildTyCl( TcMethInfo, buildClass, buildDataCon ) +import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName ) import OccName import Class import Type @@ -64,6 +64,7 @@ vectTyConDecl tycon name' (tyConTyVars tycon) -- keep original type vars (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety theta' -- superclasses + (tyConKind tycon) -- keep original kind (snd . classTvsFds $ cls) -- keep the original functional dependencies [] -- no associated types (for the moment) methods' -- method info @@ -100,17 +101,17 @@ vectTyConDecl tycon name' -- build the vectorised type constructor ; tc_rep_name <- mkDerivedName mkTyConRepUserOcc name' - ; return $ buildAlgTyCon + ; return $ mkAlgTyCon name' -- new name + (tyConKind tycon) -- keep original kind (tyConTyVars tycon) -- keep original type vars (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety Nothing [] -- no stupid theta rhs' -- new constructor defs + (VanillaAlgTyCon tc_rep_name) rec_flag -- whether recursive - False -- Not promotable gadt_flag -- whether in GADT syntax - (VanillaAlgTyCon tc_rep_name) } -- some other crazy thing that we don't handle @@ -181,10 +182,11 @@ vectDataCon dc ; arg_tys <- mapM vectType rep_arg_tys ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs) ; fam_envs <- readGEnv global_fam_inst_env + ; rep_nm <- liftDs $ newTyConRepName name' ; liftDs $ buildDataCon fam_envs name' (dataConIsInfix dc) -- infix if the original is - NotPromoted -- Vectorised type is not promotable + rep_nm (dataConSrcBangs dc) -- strictness as original constructor (Just $ dataConImplBangs dc) [] -- no labelled fields for now diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index 77b5b17e5f..088269130f 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -4,7 +4,7 @@ module Vectorise.Type.Type ( vectTyCon , vectAndLiftType , vectType - ) + ) where import Vectorise.Utils @@ -12,11 +12,12 @@ import Vectorise.Monad import Vectorise.Builtins import TcType import Type -import TypeRep +import TyCoRep import TyCon import Control.Monad import Control.Applicative import Data.Maybe +import Outputable import Prelude -- avoid redundant import warning due to AMP -- |Vectorise a type constructor. Unless there is a vectorised version (stripped of embedded @@ -41,12 +42,12 @@ vectAndLiftType ty } where (tyvars, phiTy) = splitForAllTys ty - (theta, mono_ty) = tcSplitPhiTy phiTy + (theta, mono_ty) = tcSplitPhiTy phiTy -- |Vectorise a type. -- -- For each quantified var we need to add a PA dictionary out the front of the type. --- So forall a. C a => a -> a +-- So forall a. C a => a -> a -- turns into forall a. PA a => Cv a => a :-> a -- vectType :: Type -> VM Type @@ -57,12 +58,12 @@ vectType (TyVarTy tv) = return $ TyVarTy tv vectType (LitTy l) = return $ LitTy l vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2 vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys -vectType (FunTy ty1 ty2) +vectType (ForAllTy (Anon ty1) ty2) | isPredTy ty1 - = FunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction + = mkFunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction | otherwise = TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2] -vectType ty@(ForAllTy _ _) +vectType ty@(ForAllTy {}) = do { -- strip off consecutive foralls ; let (tyvars, tyBody) = splitForAllTys ty @@ -75,8 +76,12 @@ vectType ty@(ForAllTy _ _) -- add the PA dictionaries after the foralls ; return $ abstractType tyvars dictsPA vtyBody } +vectType ty@(CastTy {}) + = pprSorry "Vectorise.Type.Type.vectType: CastTy" (ppr ty) +vectType ty@(CoercionTy {}) + = pprSorry "Vectorise.Type.Type.vectType: CoercionTy" (ppr ty) -- |Add quantified vars and dictionary parameters to the front of a type. -- abstractType :: [TyVar] -> [Type] -> Type -> Type -abstractType tyvars dicts = mkForAllTys tyvars . mkFunTys dicts +abstractType tyvars dicts = mkInvForAllTys tyvars . mkFunTys dicts diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs index fafce7a67d..733eeb9cfd 100644 --- a/compiler/vectorise/Vectorise/Utils.hs +++ b/compiler/vectorise/Vectorise/Utils.hs @@ -48,7 +48,7 @@ collectAnnTypeArgs expr = go expr [] collectAnnDictArgs :: AnnExpr Var ann -> (AnnExpr Var ann, [AnnExpr Var ann]) collectAnnDictArgs expr = go expr [] where - go e@(_, AnnApp f arg) dicts + go e@(_, AnnApp f arg) dicts | isPredTy . exprType . deAnnotate $ arg = go f (arg : dicts) | otherwise = (e, dicts) go e dicts = (e, dicts) @@ -64,7 +64,7 @@ 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 bs (_, AnnLam b e) | isId b && (not . isPredTy . idType $ b) = go (b : bs) e go bs e = (reverse bs, e) @@ -75,7 +75,7 @@ isAnnTypeArg _ = False -- PD "Parallel Data" Functions ----------------------------------------------- -- --- Given some data that has a PA dictionary, we can convert it to its +-- Given some data that has a PA dictionary, we can convert it to its -- representation type, perform some operation on the data, then convert it back. -- -- In the DPH backend, the types of these functions are defined @@ -92,14 +92,14 @@ emptyPD = paMethod emptyPDVar emptyPD_PrimVar replicatePD :: CoreExpr -- ^ Number of copies in the resulting array. -> CoreExpr -- ^ Value to replicate. -> VM CoreExpr -replicatePD len x +replicatePD len x = liftM (`mkApps` [len,x]) $ paMethod replicatePDVar replicatePD_PrimVar (exprType x) -- |Select some elements from an array that correspond to a particular tag value and pack them into a new -- array. -- --- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2 +-- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2 -- > ==> [:42, 50, 49:] -- packByTagPD :: Type -- ^ Element type. @@ -146,7 +146,7 @@ isScalar ty zipScalars :: [Type] -> Type -> VM CoreExpr zipScalars arg_tys res_ty - = do + = do { scalar <- builtin scalarClass ; (dfuns, _) <- mapAndUnzipM (\ty -> lookupInst scalar [ty]) ty_args ; zipf <- builtin (scalarZip $ length arg_tys) diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index 9c603807d6..0b8cb7099b 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module Vectorise.Utils.Base +module Vectorise.Utils.Base ( voidType , newLocalVVar @@ -18,12 +18,12 @@ module Vectorise.Utils.Base , unwrapNewTypeBodyOfPDataWrap , wrapNewTypeBodyOfPDatasWrap , unwrapNewTypeBodyOfPDatasWrap - + , pdataReprTyCon , pdataReprTyConExact , pdatasReprTyConExact , pdataUnwrapScrut - + , preprFamInst ) where @@ -206,10 +206,10 @@ unwrapNewTypeBodyOfPDatasWrap e ty -- The type for which we look up a 'PData' instance may be more specific than the type in the -- instance declaration. In that case the second component of the result will be more specific than -- a set of distinct type variables. --- +-- pdataReprTyCon :: Type -> VM (TyCon, [Type]) -pdataReprTyCon ty - = do +pdataReprTyCon ty + = do { FamInstMatch { fim_instance = famInst , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) ; return (dataFamInstRepTyCon famInst, tys) diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index 335b34b909..118f34dfbf 100644 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ b/compiler/vectorise/Vectorise/Utils/Closure.hs @@ -100,7 +100,7 @@ buildClosure :: [TyVar] -- ^Type variables passed during closure constru -> [VVar] -- ^Variables in the environment. -> Type -- ^Type of the closure argument. -> Type -- ^Type of the result. - -> VM VExpr + -> VM VExpr -> VM VExpr buildClosure tvs vars vvars arg_ty res_ty mk_body = do { (env_ty, env, bind) <- buildEnv vvars @@ -122,7 +122,7 @@ buildClosure tvs vars vvars arg_ty res_ty mk_body -- Build the environment for a single closure. -- buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr) -buildEnv [] +buildEnv [] = do ty <- voidType void <- builtin voidVar diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs index 105c8210ae..7bca567d1b 100644 --- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs +++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs @@ -2,7 +2,7 @@ module Vectorise.Utils.Hoisting ( Inline(..) , addInlineArity , inlineMe - + , hoistBinding , hoistExpr , hoistVExpr @@ -31,7 +31,7 @@ import Prelude -- avoid redundant import warning due to AMP -- |Records whether we should inline a particular binding. -- -data Inline +data Inline = Inline Arity | DontInline diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index c2ca20a683..ca2006b91f 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -15,7 +15,7 @@ import CoreUtils import FamInstEnv import Coercion import Type -import TypeRep +import TyCoRep import TyCon import CoAxiom import Var @@ -31,16 +31,18 @@ import Control.Monad -- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a) -- paDictArgType :: TyVar -> VM (Maybe Type) -paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) +paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv) where - go ty (FunTy k1 k2) + go ty (ForAllTy (Anon k1) k2) = do - tv <- newTyVar (fsLit "a") k1 - mty1 <- go (TyVarTy tv) k1 + tv <- if isCoercionType k1 + then newCoVar (fsLit "c") k1 + else newTyVar (fsLit "a") k1 + mty1 <- go (mkTyVarTy tv) k1 case mty1 of Just ty1 -> do - mty2 <- go (AppTy ty (TyVarTy tv)) k2 - return $ fmap (ForAllTy tv . FunTy ty1) mty2 + mty2 <- go (mkAppTy ty (mkTyVarTy tv)) k2 + return $ fmap (mkNamedForAllTy tv Invisible . mkFunTy ty1) mty2 Nothing -> go ty k2 go ty k @@ -55,20 +57,20 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) -- |Get the PA dictionary for some type -- paDictOfType :: Type -> VM CoreExpr -paDictOfType ty +paDictOfType ty = paDictOfTyApp ty_fn ty_args where (ty_fn, ty_args) = splitAppTys ty paDictOfTyApp :: Type -> [Type] -> VM CoreExpr paDictOfTyApp ty_fn ty_args - | Just ty_fn' <- coreView ty_fn + | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args -- for type variables, look up the dfun and apply to the PA dictionaries -- of the type arguments paDictOfTyApp (TyVarTy tv) ty_args - = do + = do { dfun <- maybeCantVectoriseM "No PA dictionary for type variable" (ppr tv <+> text "in" <+> ppr ty) $ lookupTyVarPA tv @@ -79,7 +81,7 @@ paDictOfType ty -- for tycons, we also need to apply the dfun to the PR dictionary of -- the representation type if the tycon is polymorphic paDictOfTyApp (TyConApp tc []) ty_args - = do + = do { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty) $ lookupTyConPA tc ; super <- super_dict tc ty_args @@ -95,7 +97,7 @@ paDictOfType ty { pr <- prDictOfPReprInst (TyConApp tycon ty_args) ; return [pr] } - + paDictOfTyApp _ _ = getDynFlags >>= failure failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty) @@ -141,12 +143,12 @@ prDictOfPReprInst ty prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr prDictOfPReprInstTyCon _ty prepr_ax prepr_args = do - let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args + let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args [] dict <- prDictOfReprType' rhs pr_co <- mkBuiltinCo prTyCon let co = mkAppCo pr_co $ mkSymCo - $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args + $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args [] return $ mkCast dict co -- |Get the PR dictionary for a type. The argument must be a representation @@ -163,9 +165,9 @@ prDictOfReprType ty pa <- paDictOfType ty' sel <- builtin paPRSel return $ Var sel `App` Type ty' `App` pa - else do + else do -- a representation tycon must have a PR instance - dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $ + dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $ lookupTyConPR tycon prDFunApply dfun tyargs @@ -200,7 +202,7 @@ prDFunApply dfun tys , length tycons == length tys = do pa <- builtin paTyCon - pr <- builtin prTyCon + pr <- builtin prTyCon dflags <- getDynFlags args <- zipWithM (dictionary dflags pa pr) tys tycons return $ Var dfun `mkTyApps` tys `mkApps` args @@ -225,4 +227,3 @@ prDFunApply dfun tys | otherwise = invalid dflags invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) - diff --git a/compiler/vectorise/Vectorise/Utils/Poly.hs b/compiler/vectorise/Vectorise/Utils/Poly.hs index e943313be9..d9f657f950 100644 --- a/compiler/vectorise/Vectorise/Utils/Poly.hs +++ b/compiler/vectorise/Vectorise/Utils/Poly.hs @@ -5,7 +5,7 @@ module Vectorise.Utils.Poly , polyApply , polyVApply , polyArity - ) + ) where import Vectorise.Vect @@ -36,7 +36,7 @@ polyAbstract tvs p ; p (mk_args mdicts) } where - mk_dict_var tv + mk_dict_var tv = do { r <- paDictArgType tv ; case r of Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty) @@ -49,7 +49,7 @@ polyAbstract tvs p -- on their kinds). -- polyArity :: [TyVar] -> VM Int -polyArity tvs +polyArity tvs = do { tys <- mapM paDictArgType tvs ; return $ length [() | Just _ <- tys] } @@ -62,7 +62,7 @@ polyApply expr tys ; return $ expr `mkTyApps` tys `mkApps` dicts } --- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for +-- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for -- these type arguments. -- polyVApply :: VExpr -> [Type] -> VM VExpr diff --git a/compiler/vectorise/Vectorise/Var.hs b/compiler/vectorise/Vectorise/Var.hs index 09daf76368..5cfc8415f7 100644 --- a/compiler/vectorise/Vectorise/Var.hs +++ b/compiler/vectorise/Vectorise/Var.hs @@ -2,7 +2,7 @@ -- |Vectorise variables and literals. -module Vectorise.Var +module Vectorise.Var ( vectBndr , vectBndrNew , vectBndrIn diff --git a/compiler/vectorise/Vectorise/Vect.hs b/compiler/vectorise/Vectorise/Vect.hs index b64f956185..fac1ab46f4 100644 --- a/compiler/vectorise/Vectorise/Vect.hs +++ b/compiler/vectorise/Vectorise/Vect.hs @@ -19,7 +19,7 @@ module Vectorise.Vect , vCaseDEFAULT ) where - + import CoreSyn import Type ( Type ) import Var @@ -97,7 +97,7 @@ vLams :: Var -- ^ Var bound to the lifting context. -> [VVar] -- ^ Parameter vars for the abstraction. -> VExpr -- ^ Body of the abstraction. -> VExpr -vLams lc vs (ve, le) +vLams lc vs (ve, le) = (mkLams vvs ve, mkLams (lc:lvs) le) where (vvs, lvs) = unzip vs @@ -107,10 +107,10 @@ vLams lc vs (ve, le) -- The lifted version is also applied to the variable of the lifting context. -- vVarApps :: Var -> VExpr -> [VVar] -> VExpr -vVarApps lc (ve, le) vvs +vVarApps lc (ve, le) vvs = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls)) where - (vs, ls) = unzip vvs + (vs, ls) = unzip vvs vCaseDEFAULT :: VExpr -- scrutiniy |