diff options
| author | Richard Eisenberg <eir@cis.upenn.edu> | 2015-12-11 18:19:53 -0500 |
|---|---|---|
| committer | Richard Eisenberg <eir@cis.upenn.edu> | 2015-12-11 18:23:12 -0500 |
| commit | 6746549772c5cc0ac66c0fce562f297f4d4b80a2 (patch) | |
| tree | 96869fcfb5757651462511d64d99a3712f09e7fb /compiler/vectorise | |
| parent | 6e56ac58a6905197412d58e32792a04a63b94d7e (diff) | |
| download | haskell-6746549772c5cc0ac66c0fce562f297f4d4b80a2.tar.gz | |
Add kind equalities to GHC.
This implements the ideas originally put forward in
"System FC with Explicit Kind Equality" (ICFP'13).
There are several noteworthy changes with this patch:
* We now have casts in types. These change the kind
of a type. See new constructor `CastTy`.
* All types and all constructors can be promoted.
This includes GADT constructors. GADT pattern matches
take place in type family equations. In Core,
types can now be applied to coercions via the
`CoercionTy` constructor.
* Coercions can now be heterogeneous, relating types
of different kinds. A coercion proving `t1 :: k1 ~ t2 :: k2`
proves both that `t1` and `t2` are the same and also that
`k1` and `k2` are the same.
* The `Coercion` type has been significantly enhanced.
The documentation in `docs/core-spec/core-spec.pdf` reflects
the new reality.
* The type of `*` is now `*`. No more `BOX`.
* Users can write explicit kind variables in their code,
anywhere they can write type variables. For backward compatibility,
automatic inference of kind-variable binding is still permitted.
* The new extension `TypeInType` turns on the new user-facing
features.
* Type families and synonyms are now promoted to kinds. This causes
trouble with parsing `*`, leading to the somewhat awkward new
`HsAppsTy` constructor for `HsType`. This is dispatched with in
the renamer, where the kind `*` can be told apart from a
type-level multiplication operator. Without `-XTypeInType` the
old behavior persists. With `-XTypeInType`, you need to import
`Data.Kind` to get `*`, also known as `Type`.
* The kind-checking algorithms in TcHsType have been significantly
rewritten to allow for enhanced kinds.
* The new features are still quite experimental and may be in flux.
* TODO: Several open tickets: #11195, #11196, #11197, #11198, #11203.
* TODO: Update user manual.
Tickets addressed: #9017, #9173, #7961, #10524, #8566, #11142.
Updates Haddock submodule.
Diffstat (limited to 'compiler/vectorise')
29 files changed, 370 insertions, 349 deletions
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 38bd55482a..fa59f0832f 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -62,13 +62,13 @@ vectModule guts@(ModGuts { mg_tcs = tycons , mg_fam_insts = fam_insts , mg_vect_decls = vect_decls }) - = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ + = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ pprCoreBindings binds - + -- Pick out all 'VECTORISE [SCALAR] type' and 'VECTORISE class' pragmas ; let ty_vect_decls = [vd | vd@(VectType _ _ _) <- vect_decls] cls_vect_decls = [vd | vd@(VectClass _) <- vect_decls] - + -- Vectorise the type environment. This will add vectorised -- type constructors, their representaions, and the -- conrresponding data constructors. Moreover, we produce @@ -99,9 +99,9 @@ vectModule guts@(ModGuts { mg_tcs = tycons -- Try to vectorise a top-level binding. If it doesn't vectorise, or if it is entirely scalar, then -- omit vectorisation of that binding. -- --- For example, for the binding +-- For example, for the binding -- --- @ +-- @ -- foo :: Int -> Int -- foo = \x -> x + x -- @ @@ -109,17 +109,17 @@ vectModule guts@(ModGuts { mg_tcs = tycons -- we get -- @ -- foo :: Int -> Int --- foo = \x -> vfoo $: x +-- foo = \x -> vfoo $: x -- -- v_foo :: Closure void vfoo lfoo --- v_foo = closure vfoo lfoo void +-- v_foo = closure vfoo lfoo void -- -- vfoo :: Void -> Int -> Int -- vfoo = ... -- -- lfoo :: PData Void -> PData Int -> PData Int -- lfoo = ... --- @ +-- @ -- -- @vfoo@ is the "vectorised", or scalar, version that does the same as the original function foo, -- but takes an explicit environment. @@ -142,7 +142,7 @@ vectTopBind :: CoreBind -> VM CoreBind vectTopBind b@(NonRec var expr) = do { traceVt "= Vectorise non-recursive top-level variable" (ppr var) - + ; (hasNoVect, vectDecl) <- lookupVectDecl var ; if hasNoVect then do @@ -150,7 +150,7 @@ vectTopBind b@(NonRec var expr) ; traceVt "NOVECTORISE" $ ppr var ; return b } - else do + else do { vectRhs <- case vectDecl of Just (_, expr') -> -- 'VECTORISE' pragma => just use the provided vectorised rhs @@ -166,17 +166,17 @@ vectTopBind b@(NonRec var expr) ; vectTopExpr var expr } ; hs <- takeHoisted -- make sure we clean those out (even if we skip) - ; case vectRhs of + ; case vectRhs of { Nothing -> -- scalar binding => leave this binding as it is - do + do { traceVt "scalar binding [skip]" $ ppr var ; return b } - ; Just (parBind, inline, expr') -> do + ; Just (parBind, inline, expr') -> do { -- vanilla case => create an appropriate top-level binding & add it to the vectorisation map - ; when parBind $ + ; when parBind $ addGlobalParallelVar var ; var' <- vectTopBinder var inline expr' @@ -186,32 +186,32 @@ vectTopBind b@(NonRec var expr) ; return . Rec $ (var, cexpr) : (var', expr') : hs } } } } `orElseErrV` - do + do { emitVt " Could NOT vectorise top-level binding" $ ppr var ; return b } vectTopBind b@(Rec binds) = do { traceVt "= Vectorise recursive top-level variables" $ ppr vars - + ; vectDecls <- mapM lookupVectDecl vars ; let hasNoVects = map fst vectDecls - ; if and hasNoVects + ; if and hasNoVects then do { -- 'NOVECTORISE' pragmas => leave this entire binding group as it is ; traceVt "NOVECTORISE" $ ppr vars ; return b } - else do + else do { if or hasNoVects then do { -- Inconsistent 'NOVECTORISE' pragmas => bail out ; dflags <- getDynFlags ; cantVectorise dflags noVectoriseErr (ppr b) } - else do + else do { traceVt "[Vanilla]" $ vcat [ppr var <+> char '=' <+> ppr expr | (var, expr) <- binds] - + -- For all bindings *with* a pragma, just use the pragma-supplied vectorised expression ; newBindsWPragma <- concat <$> sequence [ vectTopBindAndConvert bind inlineMe expr' @@ -228,7 +228,7 @@ vectTopBind b@(Rec binds) { -- Create appropriate top-level bindings, enter them into the vectorisation map, and -- vectorise the right-hand sides ; newBindsWOPragma <- concat <$> - sequence [vectTopBindAndConvert bind inline expr + sequence [vectTopBindAndConvert bind inline expr | (bind, ~(inline, expr)) <- zipLazy bindsWOPragma exprs'] -- irrefutable pattern and 'zipLazy' to tie the knot; -- hence, can't use 'zipWithM' @@ -239,30 +239,30 @@ vectTopBind b@(Rec binds) Nothing -> -- scalar bindings => skip all bindings except those with pragmas and retract the -- entries into the vectorisation map for the scalar bindings - do + do { traceVt "scalar bindings [skip]" $ ppr vars ; mapM_ (undefGlobalVar . fst) bindsWOPragma ; return (bindsWOPragma ++ newBindsWPragma, exprs') } - Just (parBind, exprs') -> + Just (parBind, exprs') -> -- vanilla case => record parallel variables and return the final bindings do - { when parBind $ + { when parBind $ mapM_ addGlobalParallelVar vars - ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs') + ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs') } } ; return $ Rec newBinds } } } `orElseErrV` - do + do { emitVt " Could NOT vectorise top-level bindings" $ ppr vars ; return b } where vars = map fst binds noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group" - + -- Replace the original top-level bindings by a values projected from the vectorised -- closures and add any newly created hoisted top-level bindings to the group. vectTopBindAndConvert (var, expr) inline expr' @@ -279,13 +279,13 @@ vectTopBind b@(Rec binds) -- vectImpBind :: (Id, CoreExpr) -> VM CoreBind vectImpBind (var, expr) - = do + = do { traceVt "= Add vectorised binding to imported variable" (ppr var) ; var' <- vectTopBinder var inlineMe expr ; return $ NonRec var' expr } - + -- |Make the vectorised version of this top level binder, and add the mapping between it and the -- original to the state. For some binder @foo@ the vectorised version is @$v_foo@ -- @@ -299,15 +299,15 @@ vectTopBinder :: Var -- ^ Name of the binding. vectTopBinder var inline expr = do { -- Vectorise the type attached to the var. ; vty <- vectType (idType var) - + -- If there is a vectorisation declartion for this binding, make sure its type matches ; (_, vectDecl) <- lookupVectDecl var ; case vectDecl of Nothing -> return () - Just (vdty, _) + Just (vdty, _) | eqType vty vdty -> return () - | otherwise -> - do + | otherwise -> + do { dflags <- getDynFlags ; cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $ (text "Expected type" <+> ppr vty) @@ -315,7 +315,7 @@ vectTopBinder var inline expr (text "Inferred type" <+> ppr vdty) } -- Make the vectorised version of binding's name, and set the unfolding used for inlining - ; var' <- liftM (`setIdUnfoldingLazily` unfolding) + ; var' <- liftM (`setIdUnfoldingLazily` unfolding) $ mkVectId var vty -- Add the mapping between the plain and vectorised name to the state. @@ -348,9 +348,9 @@ tryConvert :: Var -- ^Name of the original binding (eg @foo@) -> CoreExpr -- ^The original body of the binding. -> VM CoreExpr tryConvert var vect_var rhs - = fromVect (idType var) (Var vect_var) - `orElseErrV` - do + = fromVect (idType var) (Var vect_var) + `orElseErrV` + do { emitVt " Could NOT call vectorised from original version" $ ppr var <+> dcolon <+> ppr (idType var) ; return rhs } 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 |