diff options
| author | Ben Gamari <bgamari.foss@gmail.com> | 2018-06-02 11:56:58 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2018-06-02 16:21:12 -0400 |
| commit | faee23bb69ca813296da484bc177f4480bcaee9f (patch) | |
| tree | 28e1c99f0de9d505c1df81ae7459839f5db4121c /compiler/vectorise | |
| parent | 13a86606e51400bc2a81a0e04cfbb94ada5d2620 (diff) | |
| download | haskell-faee23bb69ca813296da484bc177f4480bcaee9f.tar.gz | |
vectorise: Put it out of its misery
Poor DPH and its vectoriser have long been languishing; sadly it seems there is
little chance that the effort will be rekindled. Every few years we discuss
what to do with this mass of code and at least once we have agreed that it
should be archived on a branch and removed from `master`. Here we do just that,
eliminating heaps of dead code in the process.
Here we drop the ParallelArrays extension, the vectoriser, and the `vector` and
`primitive` submodules.
Test Plan: Validate
Reviewers: simonpj, simonmar, hvr, goldfire, alanz
Reviewed By: simonmar
Subscribers: goldfire, rwbarton, thomie, mpickering, carter
Differential Revision: https://phabricator.haskell.org/D4761
Diffstat (limited to 'compiler/vectorise')
29 files changed, 0 insertions, 6756 deletions
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs deleted file mode 100644 index 0181c6cdd1..0000000000 --- a/compiler/vectorise/Vectorise.hs +++ /dev/null @@ -1,358 +0,0 @@ --- Main entry point to the vectoriser. It is invoked iff the option '-fvectorise' is passed. --- --- This module provides the function 'vectorise', which vectorises an entire (desugared) module. --- It vectorises all type declarations and value bindings. It also processes all VECTORISE pragmas --- (aka vectorisation declarations), which can lead to the vectorisation of imported data types --- and the enrichment of imported functions with vectorised versions. - -module Vectorise ( vectorise ) -where - -import GhcPrelude - -import Vectorise.Type.Env -import Vectorise.Type.Type -import Vectorise.Convert -import Vectorise.Utils.Hoisting -import Vectorise.Exp -import Vectorise.Env -import Vectorise.Monad - -import HscTypes hiding ( MonadThings(..) ) -import CoreUnfold ( mkInlineUnfoldingWithArity ) -import PprCore -import CoreSyn -import CoreMonad ( CoreM, getHscEnv ) -import Type -import Id -import DynFlags -import Outputable -import Util ( zipLazy ) -import MonadUtils - -import Control.Monad - - --- |Vectorise a single module. --- -vectorise :: ModGuts -> CoreM ModGuts -vectorise guts - = do { hsc_env <- getHscEnv - ; liftIO $ vectoriseIO hsc_env guts - } - --- Vectorise a single monad, given the dynamic compiler flags and HscEnv. --- -vectoriseIO :: HscEnv -> ModGuts -> IO ModGuts -vectoriseIO hsc_env guts - = do { -- Get information about currently loaded external packages. - ; eps <- hscEPS hsc_env - - -- Combine vectorisation info from the current module, and external ones. - ; let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps - - -- Run the main VM computation. - ; Just (info', guts') <- initV hsc_env guts info (vectModule guts) - ; return (guts' { mg_vect_info = info' }) - } - --- Vectorise a single module, in the VM monad. --- -vectModule :: ModGuts -> VM ModGuts -vectModule guts@(ModGuts { mg_tcs = tycons - , mg_binds = binds - , mg_fam_insts = fam_insts - , mg_vect_decls = vect_decls - }) - = 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 representations, and the - -- corresponding data constructors. Moreover, we produce - -- bindings for dfuns and family instances of the classes - -- and type families used in the DPH library to represent - -- array types. - ; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls - - -- Family instance environment for /all/ home-package modules including those instances - -- generated by 'vectTypeEnv'. - ; (_, fam_inst_env) <- readGEnv global_fam_inst_env - - -- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers - -- NB: Need to vectorise the imported bindings first (local bindings may depend on them). - ; let impBinds = [(imp_id, expr) | Vect imp_id expr <- vect_decls, isGlobalId imp_id] - ; binds_imp <- mapM vectImpBind impBinds - ; binds_top <- mapM vectTopBind binds - - ; return $ guts { mg_tcs = tycons ++ new_tycons - -- we produce no new classes or instances, only new class type constructors - -- and dfuns - , mg_binds = Rec tc_binds : (binds_top ++ binds_imp) - , mg_fam_inst_env = fam_inst_env - , mg_fam_insts = fam_insts ++ new_fam_insts - } - } - --- 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 --- --- @ --- foo :: Int -> Int --- foo = \x -> x + x --- @ --- --- we get --- @ --- foo :: Int -> Int --- foo = \x -> vfoo $: x --- --- v_foo :: Closure void vfoo lfoo --- 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. --- --- @lfoo@ is the "lifted" version that works on arrays. --- --- @v_foo@ combines both of these into a `Closure` that also contains the environment. --- --- The original binding @foo@ is rewritten to call the vectorised version present in the closure. --- --- Vectorisation may be suppressed by annotating a binding with a 'NOVECTORISE' pragma. If this --- pragma is used in a group of mutually recursive bindings, either all or no binding must have --- the pragma. If only some bindings are annotated, a fatal error is being raised. (In the case of --- scalar bindings, we only omit vectorisation if all bindings in a group are scalar.) --- --- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or --- we may emit a warning and refrain from vectorising the entire group. --- -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 - { -- 'NOVECTORISE' pragma => leave this binding as it is - ; traceVt "NOVECTORISE" $ ppr var - ; return b - } - else do - { vectRhs <- case vectDecl of - Just (_, expr') -> - -- 'VECTORISE' pragma => just use the provided vectorised rhs - do - { traceVt "VECTORISE" $ ppr var - ; addGlobalParallelVar var - ; return $ Just (False, inlineMe, expr') - } - Nothing -> - -- no pragma => standard vectorisation of rhs - do - { traceVt "[Vanilla]" $ ppr var <+> char '=' <+> ppr expr - ; vectTopExpr var expr - } - ; hs <- takeHoisted -- make sure we clean those out (even if we skip) - ; case vectRhs of - { Nothing -> - -- scalar binding => leave this binding as it is - do - { traceVt "scalar binding [skip]" $ ppr var - ; return b - } - ; Just (parBind, inline, expr') -> do - { - -- vanilla case => create an appropriate top-level binding & add it to the vectorisation map - ; when parBind $ - addGlobalParallelVar var - ; var' <- vectTopBinder var inline expr' - - -- We replace the original top-level binding by a value projected from the vectorised - -- closure and add any newly created hoisted top-level bindings. - ; cexpr <- tryConvert var var' expr - ; return . Rec $ (var, cexpr) : (var', expr') : hs - } } } } - `orElseErrV` - 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 - then do - { -- 'NOVECTORISE' pragmas => leave this entire binding group as it is - ; traceVt "NOVECTORISE" $ ppr vars - ; return b - } - else do - { if or hasNoVects - then do - { -- Inconsistent 'NOVECTORISE' pragmas => bail out - ; dflags <- getDynFlags - ; cantVectorise dflags noVectoriseErr (ppr b) - } - 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' - | (bind, (_, Just (_, expr'))) <- zip binds vectDecls] - - -- Standard vectorisation of all rhses that are *without* a pragma. - -- NB: The reason for 'fixV' is rather subtle: 'vectTopBindAndConvert' adds entries for - -- the bound variables in the recursive group to the vectorisation map, which in turn - -- are needed by 'vectPolyExprs' (unless it returns 'Nothing'). - ; let bindsWOPragma = [bind | (bind, (_, Nothing)) <- zip binds vectDecls] - ; (newBinds, _) <- fixV $ - \ ~(_, exprs') -> - do - { -- Create appropriate top-level bindings, enter them into the vectorisation map, and - -- vectorise the right-hand sides - ; newBindsWOPragma <- concat <$> - sequence [vectTopBindAndConvert bind inline expr - | (bind, ~(inline, expr)) <- zipLazy bindsWOPragma exprs'] - -- irrefutable pattern and 'zipLazy' to tie the knot; - -- hence, can't use 'zipWithM' - ; vectRhses <- vectTopExprs bindsWOPragma - ; hs <- takeHoisted -- make sure we clean those out (even if we skip) - - ; case vectRhses of - Nothing -> - -- scalar bindings => skip all bindings except those with pragmas and retract the - -- entries into the vectorisation map for the scalar bindings - do - { traceVt "scalar bindings [skip]" $ ppr vars - ; mapM_ (undefGlobalVar . fst) bindsWOPragma - ; return (bindsWOPragma ++ newBindsWPragma, exprs') - } - Just (parBind, exprs') -> - -- vanilla case => record parallel variables and return the final bindings - do - { when parBind $ - mapM_ addGlobalParallelVar vars - ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs') - } - } - ; return $ Rec newBinds - } } } - `orElseErrV` - 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' - = do - { var' <- vectTopBinder var inline expr' - ; cexpr <- tryConvert var var' expr - ; return [(var, cexpr), (var', expr')] - } - --- Add a vectorised binding to an imported top-level variable that has a VECTORISE pragma --- in this module. --- --- RESTRICTION: Currently, we cannot use the pragma for mutually recursive definitions. --- -vectImpBind :: (Id, CoreExpr) -> VM CoreBind -vectImpBind (var, expr) - = 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@ --- --- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is used inside of --- 'fixV' in 'vectTopBind'. --- -vectTopBinder :: Var -- ^ Name of the binding. - -> Inline -- ^ Whether it should be inlined, used to annotate it. - -> CoreExpr -- ^ RHS of binding, used to set the 'Unfolding' of the returned 'Var'. - -> VM Var -- ^ Name of the vectorised binding. -vectTopBinder var inline expr - = do { -- Vectorise the type attached to the var. - ; vty <- vectType (idType var) - - -- If there is a vectorisation declaration for this binding, make sure its type matches - ; (_, vectDecl) <- lookupVectDecl var - ; case vectDecl of - Nothing -> return () - Just (vdty, _) - | eqType vty vdty -> return () - | otherwise -> - do - { dflags <- getDynFlags - ; cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $ - (text "Expected type" <+> ppr vty) - $$ - (text "Inferred type" <+> ppr vdty) - } - -- Make the vectorised version of binding's name, and set the unfolding used for inlining - ; var' <- liftM (`setIdUnfolding` unfolding) - $ mkVectId var vty - - -- Add the mapping between the plain and vectorised name to the state. - ; defGlobalVar var var' - - ; return var' - } - where - unfolding = case inline of - Inline arity -> mkInlineUnfoldingWithArity arity expr - DontInline -> noUnfolding -{- -!!!TODO: dfuns and unfoldings: - -- Do not inline the dfun; instead give it a magic DFunFunfolding - -- See Note [ClassOp/DFun selection] - -- See also note [Single-method classes] - dfun_id_w_fun - | isNewTyCon class_tc - = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } - | otherwise - = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args - `setInlinePragma` dfunInlinePragma - -} - --- |Project out the vectorised version of a binding from some closure, or return the original body --- if that doesn't work. --- -tryConvert :: Var -- ^Name of the original binding (eg @foo@) - -> Var -- ^Name of vectorised version of binding (eg @$vfoo@) - -> CoreExpr -- ^The original body of the binding. - -> VM CoreExpr -tryConvert var vect_var rhs - = 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 deleted file mode 100644 index 7fe5b2cecc..0000000000 --- a/compiler/vectorise/Vectorise/Builtins.hs +++ /dev/null @@ -1,35 +0,0 @@ --- Types and functions declared in 'Data.Array.Parallel.Prim' and used by the vectoriser. --- --- The @Builtins@ structure holds the name of all the things in 'Data.Array.Parallel.Prim' that --- appear in code generated by the vectoriser. - -module Vectorise.Builtins ( - -- * Restrictions - mAX_DPH_SCALAR_ARGS, - - -- * Builtins - Builtins(..), - - -- * Wrapped selectors - selTy, selsTy, - selReplicate, - selTags, - selElements, - selsLength, - sumTyCon, - prodTyCon, - prodDataCon, - replicatePD_PrimVar, - emptyPD_PrimVar, - packByTagPD_PrimVar, - combinePDVar, - combinePD_PrimVar, - scalarZip, - closureCtrFun, - - -- * Initialisation - initBuiltins, initBuiltinVars, -) where - -import Vectorise.Builtins.Base -import Vectorise.Builtins.Initialise diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs deleted file mode 100644 index ba61a8b548..0000000000 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ /dev/null @@ -1,219 +0,0 @@ --- |Builtin types and functions used by the vectoriser. These are all defined in --- 'Data.Array.Parallel.Prim'. - -module Vectorise.Builtins.Base ( - -- * Hard config - mAX_DPH_PROD, - mAX_DPH_SUM, - mAX_DPH_COMBINE, - mAX_DPH_SCALAR_ARGS, - aLL_DPH_PRIM_TYCONS, - - -- * Builtins - Builtins(..), - - -- * Projections - selTy, selsTy, - selReplicate, - selTags, - selElements, - selsLength, - sumTyCon, - prodTyCon, - prodDataCon, - replicatePD_PrimVar, - emptyPD_PrimVar, - packByTagPD_PrimVar, - combinePDVar, - combinePD_PrimVar, - scalarZip, - closureCtrFun -) where - -import GhcPrelude - -import TysPrim -import BasicTypes -import Class -import CoreSyn -import TysWiredIn hiding (sumTyCon) -import Type -import TyCon -import DataCon -import NameEnv -import Name -import Outputable - -import Data.Array - - --- Cardinality of the various families of types and functions exported by the DPH library. - -mAX_DPH_PROD :: Int -mAX_DPH_PROD = 5 - -mAX_DPH_SUM :: Int -mAX_DPH_SUM = 2 - -mAX_DPH_COMBINE :: Int -mAX_DPH_COMBINE = 2 - -mAX_DPH_SCALAR_ARGS :: Int -mAX_DPH_SCALAR_ARGS = 8 - --- Types from 'GHC.Prim' supported by DPH --- -aLL_DPH_PRIM_TYCONS :: [Name] -aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doublePrimTyCon] - - --- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the --- vectoriser. --- -data Builtins - = Builtins - { parrayTyCon :: TyCon -- ^ PArray - , pdataTyCon :: TyCon -- ^ PData - , pdatasTyCon :: TyCon -- ^ PDatas - , prClass :: Class -- ^ PR - , prTyCon :: TyCon -- ^ PR - , preprTyCon :: TyCon -- ^ PRepr - , paClass :: Class -- ^ PA - , paTyCon :: TyCon -- ^ PA - , paDataCon :: DataCon -- ^ PA - , paPRSel :: Var -- ^ PA - , replicatePDVar :: Var -- ^ replicatePD - , replicatePD_PrimVars :: NameEnv Var -- ^ replicatePD_Int# etc. - , emptyPDVar :: Var -- ^ emptyPD - , emptyPD_PrimVars :: NameEnv Var -- ^ emptyPD_Int# etc. - , packByTagPDVar :: Var -- ^ packByTagPD - , packByTagPD_PrimVars :: NameEnv Var -- ^ packByTagPD_Int# etc. - , combinePDVars :: Array Int Var -- ^ combinePD - , combinePD_PrimVarss :: Array Int (NameEnv Var) -- ^ combine2PD_Int# etc. - , scalarClass :: Class -- ^ Scalar - , scalarZips :: Array Int Var -- ^ map, zipWith, zipWith3 - , voidTyCon :: TyCon -- ^ Void - , voidVar :: Var -- ^ void - , fromVoidVar :: Var -- ^ fromVoid - , sumTyCons :: Array Int TyCon -- ^ Sum2 .. Sum3 - , wrapTyCon :: TyCon -- ^ Wrap - , pvoidVar :: Var -- ^ pvoid - , pvoidsVar :: Var -- ^ pvoids - , closureTyCon :: TyCon -- ^ :-> - , closureVar :: Var -- ^ closure - , liftedClosureVar :: Var -- ^ liftedClosure - , applyVar :: Var -- ^ $: - , liftedApplyVar :: Var -- ^ liftedApply - , closureCtrFuns :: Array Int Var -- ^ closure1 .. closure3 - , selTys :: Array Int Type -- ^ Sel2 - , selsTys :: Array Int Type -- ^ Sels2 - , selsLengths :: Array Int CoreExpr -- ^ lengthSels2 - , selReplicates :: Array Int CoreExpr -- ^ replicate2 - , selTagss :: Array Int CoreExpr -- ^ tagsSel2 - , selElementss :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1 - , liftingContext :: Var -- ^ lc - } - - --- Projections ---------------------------------------------------------------- --- We use these wrappers instead of indexing the `Builtin` structure directly --- because they give nicer panic messages if the indexed thing cannot be found. - -selTy :: Int -> Builtins -> Type -selTy = indexBuiltin "selTy" selTys - -selsTy :: Int -> Builtins -> Type -selsTy = indexBuiltin "selsTy" selsTys - -selsLength :: Int -> Builtins -> CoreExpr -selsLength = indexBuiltin "selLength" selsLengths - -selReplicate :: Int -> Builtins -> CoreExpr -selReplicate = indexBuiltin "selReplicate" selReplicates - -selTags :: Int -> Builtins -> CoreExpr -selTags = indexBuiltin "selTags" selTagss - -selElements :: Int -> Int -> Builtins -> CoreExpr -selElements i j = indexBuiltin "selElements" selElementss (i, j) - -sumTyCon :: Int -> Builtins -> TyCon -sumTyCon = indexBuiltin "sumTyCon" sumTyCons - -prodTyCon :: Int -> Builtins -> TyCon -prodTyCon n _ - | n >= 2 && n <= mAX_DPH_PROD - = tupleTyCon Boxed n - | otherwise - = pprPanic "prodTyCon" (ppr n) - -prodDataCon :: Int -> Builtins -> DataCon -prodDataCon n bi - = case tyConDataCons (prodTyCon n bi) of - [con] -> con - _ -> pprPanic "prodDataCon" (ppr n) - -replicatePD_PrimVar :: TyCon -> Builtins -> Var -replicatePD_PrimVar tc bi - = lookupEnvBuiltin "replicatePD_PrimVar" (replicatePD_PrimVars bi) (tyConName tc) - -emptyPD_PrimVar :: TyCon -> Builtins -> Var -emptyPD_PrimVar tc bi - = lookupEnvBuiltin "emptyPD_PrimVar" (emptyPD_PrimVars bi) (tyConName tc) - -packByTagPD_PrimVar :: TyCon -> Builtins -> Var -packByTagPD_PrimVar tc bi - = lookupEnvBuiltin "packByTagPD_PrimVar" (packByTagPD_PrimVars bi) (tyConName tc) - -combinePDVar :: Int -> Builtins -> Var -combinePDVar = indexBuiltin "combinePDVar" combinePDVars - -combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var -combinePD_PrimVar i tc bi - = lookupEnvBuiltin "combinePD_PrimVar" - (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc) - -scalarZip :: Int -> Builtins -> Var -scalarZip = indexBuiltin "scalarZip" scalarZips - -closureCtrFun :: Int -> Builtins -> Var -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) - => 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 - -> a -indexBuiltin fn f i bi - | inRange (bounds xs) i = xs ! i - | otherwise - = pprSorry "Vectorise.Builtins.indexBuiltin" - (vcat [ text "" - , 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" - , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org" - , text "and ask what you can do to help (it might involve some GHC hacking)."]) - where xs = f bi - - --- | Get an entry from one of a 'NameEnv' of `Builtins`. Panic if the named item is not in the array. -lookupEnvBuiltin :: String -- Function name for error messages - -> NameEnv a -- Name environment - -> Name -- Index into the name environment - -> a -lookupEnvBuiltin fn env n - | Just r <- lookupNameEnv env n = r - | otherwise - = pprSorry "Vectorise.Builtins.lookupEnvBuiltin" - (vcat [ text "" - , 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" - , text "of DPH. If you want it to work, you should send mail to ghc-commits@haskell.org" - , text "and ask what you can do to help (it might involve some GHC hacking)."]) diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs deleted file mode 100644 index 0772e5be43..0000000000 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ /dev/null @@ -1,234 +0,0 @@ --- Set up the data structures provided by 'Vectorise.Builtins'. - -module Vectorise.Builtins.Initialise ( - -- * Initialisation - initBuiltins, initBuiltinVars -) where - -import GhcPrelude - -import Vectorise.Builtins.Base - -import BasicTypes -import TysPrim -import DsMonad -import TysWiredIn -import DataCon -import TyCon -import Class -import CoreSyn -import Type -import NameEnv -import Name -import Id -import FastString -import Outputable - -import Control.Monad -import Data.Array - - --- |Create the initial map of builtin types and functions. --- -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") - ; pdatasTyCon <- externalTyCon (fsLit "PDatas") - - -- 'PR': class of basic array operators operating on 'PData' types - ; prClass <- externalClass (fsLit "PR") - ; let prTyCon = classTyCon prClass - - -- 'PRepr': type family mapping element types to representation types - ; preprTyCon <- externalTyCon (fsLit "PRepr") - - -- 'PA': class of basic operations on arrays (parametrised by the element type) - ; paClass <- externalClass (fsLit "PA") - ; let paTyCon = classTyCon paClass - [paDataCon] = tyConDataCons paTyCon - paPRSel = classSCSelId paClass 0 - - -- Functions on array representations - ; replicatePDVar <- externalVar (fsLit "replicatePD") - ; replicate_vars <- mapM externalVar (suffixed "replicatePA" aLL_DPH_PRIM_TYCONS) - ; emptyPDVar <- externalVar (fsLit "emptyPD") - ; empty_vars <- mapM externalVar (suffixed "emptyPA" aLL_DPH_PRIM_TYCONS) - ; packByTagPDVar <- externalVar (fsLit "packByTagPD") - ; packByTag_vars <- mapM externalVar (suffixed "packByTagPA" aLL_DPH_PRIM_TYCONS) - ; let combineNamesD = [("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]] - ; let combineNamesA = [("combine" ++ show i ++ "PA") | i <- [2..mAX_DPH_COMBINE]] - ; combines <- mapM externalVar (map mkFastString combineNamesD) - ; combines_vars <- mapM (mapM externalVar) $ - map (\name -> suffixed name aLL_DPH_PRIM_TYCONS) combineNamesA - ; let replicatePD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS replicate_vars) - emptyPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS empty_vars) - packByTagPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS packByTag_vars) - combinePDVars = listArray (2, mAX_DPH_COMBINE) combines - combinePD_PrimVarss = listArray (2, mAX_DPH_COMBINE) - [ mkNameEnv (zip aLL_DPH_PRIM_TYCONS vars) - | vars <- combines_vars] - - -- 'Scalar': class moving between plain unboxed arrays and 'PData' representations - ; scalarClass <- externalClass (fsLit "Scalar") - - -- N-ary maps ('zipWith' family) - ; 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) - (scalar_map : scalar_zip2 : scalar_zips) - - -- Types and functions for generic type representations - ; voidTyCon <- externalTyCon (fsLit "Void") - ; voidVar <- externalVar (fsLit "void") - ; fromVoidVar <- externalVar (fsLit "fromVoid") - ; sum_tcs <- mapM externalTyCon (numbered "Sum" 2 mAX_DPH_SUM) - ; let sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs - ; wrapTyCon <- externalTyCon (fsLit "Wrap") - ; pvoidVar <- externalVar (fsLit "pvoid") - ; pvoidsVar <- externalVar (fsLit "pvoids#") - - -- Types and functions for closure conversion - ; closureTyCon <- externalTyCon (fsLit ":->") - ; closureVar <- externalVar (fsLit "closure") - ; liftedClosureVar <- externalVar (fsLit "liftedClosure") - ; applyVar <- externalVar (fsLit "$:") - ; liftedApplyVar <- externalVar (fsLit "liftedApply") - ; closures <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) - ; let closureCtrFuns = listArray (1, mAX_DPH_SCALAR_ARGS) closures - - -- Types and functions for selectors - ; sel_tys <- mapM externalType (numbered "Sel" 2 mAX_DPH_SUM) - ; sels_tys <- mapM externalType (numbered "Sels" 2 mAX_DPH_SUM) - ; sels_length <- mapM externalFun (numbered_hash "lengthSels" 2 mAX_DPH_SUM) - ; sel_replicates <- mapM externalFun (numbered_hash "replicateSel" 2 mAX_DPH_SUM) - ; sel_tags <- mapM externalFun (numbered "tagsSel" 2 mAX_DPH_SUM) - ; sel_elements <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] - ; let selTys = listArray (2, mAX_DPH_SUM) sel_tys - selsTys = listArray (2, mAX_DPH_SUM) sels_tys - selsLengths = listArray (2, mAX_DPH_SUM) sels_length - selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates - selTagss = listArray (2, mAX_DPH_SUM) sel_tags - selElementss = array ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements - - -- Distinct local variable - ; liftingContext <- liftM (\u -> mkSysLocalOrCoVar (fsLit "lc") u intPrimTy) newUnique - - ; return $ Builtins - { parrayTyCon = parrayTyCon - , pdataTyCon = pdataTyCon - , pdatasTyCon = pdatasTyCon - , preprTyCon = preprTyCon - , prClass = prClass - , prTyCon = prTyCon - , paClass = paClass - , paTyCon = paTyCon - , paDataCon = paDataCon - , paPRSel = paPRSel - , replicatePDVar = replicatePDVar - , replicatePD_PrimVars = replicatePD_PrimVars - , emptyPDVar = emptyPDVar - , emptyPD_PrimVars = emptyPD_PrimVars - , packByTagPDVar = packByTagPDVar - , packByTagPD_PrimVars = packByTagPD_PrimVars - , combinePDVars = combinePDVars - , combinePD_PrimVarss = combinePD_PrimVarss - , scalarClass = scalarClass - , scalarZips = scalarZips - , voidTyCon = voidTyCon - , voidVar = voidVar - , fromVoidVar = fromVoidVar - , sumTyCons = sumTyCons - , wrapTyCon = wrapTyCon - , pvoidVar = pvoidVar - , pvoidsVar = pvoidsVar - , closureTyCon = closureTyCon - , closureVar = closureVar - , liftedClosureVar = liftedClosureVar - , applyVar = applyVar - , liftedApplyVar = liftedApplyVar - , closureCtrFuns = closureCtrFuns - , selTys = selTys - , selsTys = selsTys - , selsLengths = selsLengths - , selReplicates = selReplicates - , selTagss = selTagss - , selElementss = selElementss - , liftingContext = liftingContext - } - } - where - suffixed :: String -> [Name] -> [FastString] - suffixed pfx ns = [mkFastString (pfx ++ "_" ++ (occNameString . nameOccName) n) | n <- ns] - - -- Make a list of numbered strings in some range, eg foo3, foo4, foo5 - numbered :: String -> Int -> Int -> [FastString] - numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]] - - numbered_hash :: String -> Int -> Int -> [FastString] - numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]] - - mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr) - mk_elements (i,j) - = do { v <- externalVar $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#") - ; return ((i, j), Var v) - } - --- |Get the mapping of names in the Prelude to names in the DPH library. --- -initBuiltinVars :: Builtins -> DsM [(Var, Var)] --- FIXME: must be replaced by VECTORISE pragmas!!! -initBuiltinVars (Builtins { }) - = do - cvars <- mapM externalVar cfs - return $ zip (map dataConWorkId cons) cvars - where - (cons, cfs) = unzip preludeDataCons - - preludeDataCons :: [(DataCon, FastString)] - preludeDataCons - = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..5]] - where - mk_tup n name = (tupleDataCon Boxed n, name) - - --- Auxiliary look up functions ----------------------------------------------- - --- |Lookup a variable given its name and the module that contains it. -externalVar :: FastString -> DsM Var -externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId - - --- |Like `externalVar` but wrap the `Var` in a `CoreExpr`. -externalFun :: FastString -> DsM CoreExpr -externalFun fs = Var <$> externalVar fs - - --- |Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name. --- Panic if there isn't one. -externalTyCon :: FastString -> DsM TyCon -externalTyCon fs = dsLookupDPHRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon - - --- |Lookup some `Type` in 'Data.Array.Parallel.Prim', given its name. -externalType :: FastString -> DsM Type -externalType fs - = do tycon <- externalTyCon fs - return $ mkTyConApp tycon [] - - --- |Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name. -externalClass :: FastString -> DsM Class -externalClass fs - = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon - ; case tyConClass_maybe tycon of - Nothing -> pprPanic "Vectorise.Builtins.Initialise" $ - text "Data.Array.Parallel.Prim." <> - ftext fs <+> text "is not a type class" - Just cls -> return cls - } diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs deleted file mode 100644 index dda724ff5a..0000000000 --- a/compiler/vectorise/Vectorise/Convert.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Vectorise.Convert - ( fromVect - ) -where - -import GhcPrelude - -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Type.Type - -import CoreSyn -import TyCon -import Type -import TyCoRep -import NameSet -import FastString -import Outputable - --- |Convert a vectorised expression such that it computes the non-vectorised equivalent of its --- value. --- --- For functions, we eta expand the function and convert the arguments and result: - --- For example --- @ --- \(x :: Double) -> --- \(y :: Double) -> --- ($v_foo $: x) $: y --- @ --- --- We use the type of the original binding to work out how many outer lambdas to add. --- -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 - --- 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 - = do - arg <- newLocalVar (fsLit "x") arg_ty - varg <- toVect arg_ty (Var arg) - varg_ty <- vectType arg_ty - vres_ty <- vectType res_ty - apply <- builtin applyVar - body <- fromVect res_ty - $ Var apply `mkTyApps` [varg_ty, vres_ty] `mkApps` [expr, varg] - return $ Lam arg body - --- If the type isn't a function, then we can't current convert it unless the type is scalar (i.e., --- is identical to the non-vectorised version). --- -fromVect ty expr - = identityConv ty >> return expr - --- Convert an expression such that it evaluates to the vectorised equivalent of the value of the --- original expression. --- --- WARNING: Currently only works for the scalar types, where the vectorised value coincides with the --- original one. --- -toVect :: Type -> CoreExpr -> VM CoreExpr -toVect ty expr = identityConv ty >> return expr - --- |Check that the type is neutral under type vectorisation — i.e., all involved type constructor --- are not altered by vectorisation as they contain no parallel arrays. --- -identityConv :: Type -> VM () -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 (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 - { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons - ; parray <- builtin parrayTyCon - ; if isParallel && not (tc == parray) - then noV idErr - else return () - } - where - idErr = text "identityConvTyCon: type constructor contains parallel arrays" <+> ppr tc diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs deleted file mode 100644 index 8ae35896e1..0000000000 --- a/compiler/vectorise/Vectorise/Env.hs +++ /dev/null @@ -1,240 +0,0 @@ -module Vectorise.Env ( - Scope(..), - - -- * Local Environments - LocalEnv(..), - emptyLocalEnv, - - -- * Global Environments - GlobalEnv(..), - initGlobalEnv, - extendImportedVarsEnv, - extendFamEnv, - setPAFunsEnv, - setPRFunsEnv, - modVectInfo -) where - -import GhcPrelude - -import HscTypes -import InstEnv -import FamInstEnv -import CoreSyn -import Type -import Class -import TyCon -import DataCon -import VarEnv -import VarSet -import Var -import NameSet -import Name -import NameEnv -import FastString -import UniqDFM -import UniqSet - - -import Data.Maybe - - --- |Indicates what scope something (a variable) is in. --- -data Scope a b - = Global a - | Local b - - --- LocalEnv ------------------------------------------------------------------- - --- |The local environment. --- -data LocalEnv - = LocalEnv - { local_vars :: VarEnv (Var, Var) - -- ^Mapping from local variables to their vectorised and lifted versions. - - , local_tyvars :: [TyVar] - -- ^In-scope type variables. - - , local_tyvar_pa :: VarEnv CoreExpr - -- ^Mapping from tyvars to their PA dictionaries. - - , local_bind_name :: FastString - -- ^Local binding name. This is only used to generate better names for hoisted - -- expressions. - } - --- |Create an empty local environment. --- -emptyLocalEnv :: LocalEnv -emptyLocalEnv = LocalEnv - { local_vars = emptyVarEnv - , local_tyvars = [] - , local_tyvar_pa = emptyVarEnv - , local_bind_name = fsLit "fn" - } - - --- GlobalEnv ------------------------------------------------------------------ - --- |The global environment: entities that exist at top-level. --- -data GlobalEnv - = GlobalEnv - { global_vect_avoid :: Bool - -- ^'True' implies to avoid vectorisation as far as possible. - - , global_vars :: VarEnv Var - -- ^Mapping from global variables to their vectorised versions — aka the /vectorisation - -- map/. - - , global_parallel_vars :: DVarSet - -- ^The domain of 'global_vars'. - -- - -- This information is not redundant as it is impossible to extract the domain from a - -- 'VarEnv' (which is keyed on uniques alone). Moreover, we have mapped variables that - -- do not involve parallelism — e.g., the workers of vectorised, but scalar data types. - -- In addition, workers of parallel data types that we could not vectorise also need to - -- be tracked. - - , global_vect_decls :: VarEnv (Maybe (Type, CoreExpr)) - -- ^Mapping from global variables that have a vectorisation declaration to the right-hand - -- side of that declaration and its type and mapping variables that have NOVECTORISE - -- declarations to 'Nothing'. - - , global_tycons :: NameEnv TyCon - -- ^Mapping from TyCons to their vectorised versions. The vectorised version will be - -- identical to the original version if it is not changed by vectorisation. In any case, - -- if a tycon appears in the domain of this mapping, it was successfully vectorised. - - , global_parallel_tycons :: NameSet - -- ^Type constructors whose definition directly or indirectly includes a parallel type, - -- such as '[::]'. - -- - -- NB: This information is not redundant as some types have got a mapping in - -- '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. - - , global_pa_funs :: NameEnv Var - -- ^Mapping from TyCons to their PA dfuns. - - , global_pr_funs :: NameEnv Var - -- ^Mapping from TyCons to their PR dfuns. - - , global_inst_env :: InstEnvs - -- ^External package inst-env & home-package inst-env for class instances. - - , global_fam_inst_env :: FamInstEnvs - -- ^External package inst-env & home-package inst-env for family instances. - - , global_bindings :: [(Var, CoreExpr)] - -- ^Hoisted bindings — temporary storage for toplevel bindings during code gen. - } - --- |Create an initial global environment. --- --- We add scalar variables and type constructors identified by vectorisation pragmas already here --- to the global table, so that we can query scalarness during vectorisation, and especially, when --- vectorising the scalar entities' definitions themselves. --- -initGlobalEnv :: Bool - -> VectInfo - -> [CoreVect] - -> InstEnvs - -> FamInstEnvs - -> GlobalEnv -initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs - = GlobalEnv - { global_vect_avoid = vectAvoid - , global_vars = mapVarEnv snd $ udfmToUfm $ vectInfoVar info - , global_vect_decls = mkVarEnv vects - , global_parallel_vars = vectInfoParallelVars info - , global_parallel_tycons = vectInfoParallelTyCons info - , global_tycons = mapNameEnv snd $ vectInfoTyCon info - , global_datacons = mapNameEnv snd $ vectInfoDataCon info - , global_pa_funs = emptyNameEnv - , global_pr_funs = emptyNameEnv - , global_inst_env = instEnvs - , global_fam_inst_env = famInstEnvs - , global_bindings = [] - } - where - vects = [(var, Just (ty, exp)) | Vect var exp@(Var rhs_var) <- vectDecls - , let ty = varType rhs_var] ++ - -- FIXME: we currently only allow RHSes consisting of a - -- single variable to be able to obtain the type without - -- inference — see also 'TcBinds.tcVect' - [(var, Nothing) | NoVect var <- vectDecls] - - --- Operators on Global Environments ------------------------------------------- - --- |Extend the list of global variables in an environment. --- -extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv -extendImportedVarsEnv ps genv - = genv { global_vars = extendVarEnvList (global_vars genv) ps } - --- |Extend the list of type family instances. --- -extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv -extendFamEnv new genv - = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) } - where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv - --- |Set the list of PA functions in an environment. --- -setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv -setPAFunsEnv ps genv = genv { global_pa_funs = mkNameEnv ps } - --- |Set the list of PR functions in an environment. --- -setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv -setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps } - --- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files). --- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'. The outgoing one contains only the --- declarations for the currently compiled module; this includes variables, type constructors, and --- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported --- module. --- --- The variables explicitly include class selectors and dfuns. --- -modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo -modVectInfo env mg_ids mg_tyCons vectDecls info - = info - { vectInfoVar = mk_denv ids (global_vars env) - , vectInfoTyCon = mk_env tyCons (global_tycons env) - , vectInfoDataCon = mk_env dataCons (global_datacons env) - , vectInfoParallelVars = (global_parallel_vars env `minusDVarSet` vectInfoParallelVars info) - `udfmIntersectUFM` (getUniqSet $ mkVarSet ids) - , vectInfoParallelTyCons = global_parallel_tycons env `minusNameSet` vectInfoParallelTyCons info - } - where - vectIds = [id | Vect id _ <- vectDecls] ++ - [id | VectInst id <- vectDecls] - vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls] ++ - [tycon | VectClass tycon <- vectDecls] - vectDataCons = concatMap tyConDataCons vectTypeTyCons - ids = mg_ids ++ vectIds ++ dataConIds ++ selIds - tyCons = mg_tyCons ++ vectTypeTyCons - dataCons = concatMap tyConDataCons mg_tyCons ++ vectDataCons - dataConIds = map dataConWorkId dataCons - 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 $ mk_assoc_env decls inspectedEnv - mk_denv decls inspectedEnv = listToUDFM $ mk_assoc_env decls inspectedEnv - mk_assoc_env decls inspectedEnv - = [(name, (decl, to)) - | decl <- decls - , let name = getName decl - , Just to <- [lookupNameEnv inspectedEnv name]] diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs deleted file mode 100644 index c5de9c4250..0000000000 --- a/compiler/vectorise/Vectorise/Exp.hs +++ /dev/null @@ -1,1260 +0,0 @@ -{-# LANGUAGE CPP, TupleSections #-} - --- |Vectorisation of expressions. - -module Vectorise.Exp - ( -- * Vectorise right-hand sides of toplevel bindings - vectTopExpr - , vectTopExprs - , vectScalarFun - , vectScalarDFun - ) -where - -#include "HsVersions.h" - -import GhcPrelude - -import Vectorise.Type.Type -import Vectorise.Var -import Vectorise.Convert -import Vectorise.Vect -import Vectorise.Env -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Utils - -import CoreUtils -import MkCore -import CoreSyn -import CoreFVs -import Class -import DataCon -import TyCon -import TcType -import Type -import TyCoRep -import Var -import VarEnv -import VarSet -import NameSet -import Id -import BasicTypes( isStrongLoopBreaker ) -import Literal -import TysPrim -import Outputable -import FastString -import DynFlags -import Util - -import Control.Monad -import Data.Maybe -import Data.List - - --- Main entry point to vectorise expressions ----------------------------------- - --- |Vectorise a polymorphic expression that forms a *non-recursive* binding. --- --- Return 'Nothing' if the expression is scalar; otherwise, the first component of the result --- (which is of type 'Bool') indicates whether the expression is parallel (i.e., whether it is --- tagged as 'VIParr'). --- --- We have got the non-recursive case as a special case as it doesn't require to compute --- vectorisation information twice. --- -vectTopExpr :: Var -> CoreExpr -> VM (Maybe (Bool, Inline, CoreExpr)) -vectTopExpr var expr - = do - { exprVI <- encapsulateScalars <=< vectAvoidInfo emptyVarSet . freeVars $ expr - ; if isVIEncaps exprVI - then - return Nothing - else do - { vExpr <- closedV $ - inBind var $ - vectAnnPolyExpr False exprVI - ; inline <- computeInline exprVI - ; return $ Just (isVIParr exprVI, inline, vectorised vExpr) - } - } - --- Compute the inlining hint for the right-hand side of a top-level binding. --- -computeInline :: CoreExprWithVectInfo -> VM Inline -computeInline ((_, VIDict), _) = return $ DontInline -computeInline (_, AnnTick _ expr) = computeInline expr -computeInline expr@(_, AnnLam _ _) = Inline <$> polyArity tvs - where - (tvs, _) = collectAnnTypeBinders expr -computeInline _expr = return $ DontInline - --- |Vectorise a recursive group of top-level polymorphic expressions. --- --- Return 'Nothing' if the expression group is scalar; otherwise, the first component of the result --- (which is of type 'Bool') indicates whether the expressions are parallel (i.e., whether they are --- tagged as 'VIParr'). --- -vectTopExprs :: [(Var, CoreExpr)] -> VM (Maybe (Bool, [(Inline, CoreExpr)])) -vectTopExprs binds - = do - { exprVIs <- mapM (vectAvoidAndEncapsulate emptyVarSet) exprs - ; if all isVIEncaps exprVIs - -- if all bindings are scalar => don't vectorise this group of bindings - then return Nothing - else do - { -- non-scalar bindings need to be vectorised - ; let areVIParr = any isVIParr exprVIs - ; revised_exprVIs <- if not areVIParr - -- if no binding is parallel => 'exprVIs' is ready for vectorisation - then return exprVIs - -- if any binding is parallel => recompute the vectorisation info - else mapM (vectAvoidAndEncapsulate (mkVarSet vars)) exprs - - ; vExprs <- zipWithM vect vars revised_exprVIs - ; return $ Just (areVIParr, vExprs) - } - } - where - (vars, exprs) = unzip binds - - vectAvoidAndEncapsulate pvs = encapsulateScalars <=< vectAvoidInfo pvs . freeVars - - vect var exprVI - = do - { vExpr <- closedV $ - inBind var $ - vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo var) exprVI - ; inline <- computeInline exprVI - ; return (inline, vectorised vExpr) - } - --- |Vectorise a polymorphic expression annotated with vectorisation information. --- --- The special case of dictionary functions is currently handled separately. (Would be neater to --- integrate them, though!) --- -vectAnnPolyExpr :: Bool -> CoreExprWithVectInfo -> VM VExpr -vectAnnPolyExpr loop_breaker (_, AnnTick tickish expr) - -- traverse through ticks - = vTick tickish <$> vectAnnPolyExpr loop_breaker expr -vectAnnPolyExpr loop_breaker expr - | isVIDict expr - -- special case the right-hand side of dictionary functions - = (, undefined) <$> vectDictExpr (deAnnotate expr) - | otherwise - -- collect and vectorise type abstractions; then, descent into the body - = polyAbstract tvs $ \args -> - mapVect (mkLams $ tvs ++ args) <$> vectFnExpr False loop_breaker mono - where - (tvs, mono) = collectAnnTypeBinders expr - --- Encapsulate every purely sequential subexpression of a (potentially) parallel expression into a --- lambda abstraction over all its free variables followed by the corresponding application to those --- variables. We can, then, avoid the vectorisation of the ensapsulated subexpressions. --- --- Preconditions: --- --- * All free variables and the result type must be /simple/ types. --- * The expression is sufficiently complex (to warrant special treatment). For now, that is --- every expression that is not constant and contains at least one operation. --- --- --- The user has an option to choose between aggressive and minimal vectorisation avoidance. With --- minimal vectorisation avoidance, we only encapsulate individual scalar operations. With --- aggressive vectorisation avoidance, we encapsulate subexpression that are as big as possible. --- -encapsulateScalars :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo -encapsulateScalars ce@(_, AnnType _ty) - = return ce -encapsulateScalars ce@((_, VISimple), AnnVar _v) - -- NB: diverts from the paper: encapsulate scalar variables (including functions) - = liftSimpleAndCase ce -encapsulateScalars ce@(_, AnnVar _v) - = return ce -encapsulateScalars ce@(_, AnnLit _) - = return ce -encapsulateScalars ((fvs, vi), AnnTick tck expr) - = do - { encExpr <- encapsulateScalars expr - ; return ((fvs, vi), AnnTick tck encExpr) - } -encapsulateScalars ce@((fvs, vi), AnnLam bndr expr) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - -- NB: diverts from the paper: we need to check the scalarness of bound variables as well, - -- as 'vectScalarFun' will handle them just the same as those introduced for the 'fvs' - -- by encapsulation. - ; bndrsS <- allScalarVarType bndrs - ; case (vi, vectAvoid && varsS && bndrsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encExpr <- encapsulateScalars expr - ; return ((fvs, vi), AnnLam bndr encExpr) - } - } - where - (bndrs, _) = collectAnnBndrs ce -encapsulateScalars ce@((fvs, vi), AnnApp ce1 ce2) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - ; case (vi, (vectAvoid || isSimpleApplication ce) && varsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encCe1 <- encapsulateScalars ce1 - ; encCe2 <- encapsulateScalars ce2 - ; return ((fvs, vi), AnnApp encCe1 encCe2) - } - } - where - isSimpleApplication :: CoreExprWithVectInfo -> Bool - isSimpleApplication (_, AnnTick _ ce) = isSimpleApplication ce - isSimpleApplication (_, AnnCast ce _) = isSimpleApplication ce - isSimpleApplication ce | isSimple ce = True - isSimpleApplication (_, AnnApp ce1 ce2) = isSimple ce1 && isSimpleApplication ce2 - isSimpleApplication _ = False - -- - isSimple :: CoreExprWithVectInfo -> Bool - isSimple (_, AnnType {}) = True - isSimple (_, AnnVar {}) = True - isSimple (_, AnnLit {}) = True - isSimple (_, AnnTick _ ce) = isSimple ce - isSimple (_, AnnCast ce _) = isSimple ce - isSimple _ = False -encapsulateScalars ce@((fvs, vi), AnnCase scrut bndr ty alts) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - ; case (vi, vectAvoid && varsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encScrut <- encapsulateScalars scrut - ; encAlts <- mapM encAlt alts - ; return ((fvs, vi), AnnCase encScrut bndr ty encAlts) - } - } - where - encAlt (con, bndrs, expr) = (con, bndrs,) <$> encapsulateScalars expr -encapsulateScalars ce@((fvs, vi), AnnLet (AnnNonRec bndr expr1) expr2) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - ; case (vi, vectAvoid && varsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encExpr1 <- encapsulateScalars expr1 - ; encExpr2 <- encapsulateScalars expr2 - ; return ((fvs, vi), AnnLet (AnnNonRec bndr encExpr1) encExpr2) - } - } -encapsulateScalars ce@((fvs, vi), AnnLet (AnnRec binds) expr) - = do - { vectAvoid <- isVectAvoidanceAggressive - ; varsS <- allScalarVarTypeSet fvs - ; case (vi, vectAvoid && varsS) of - (VISimple, True) -> liftSimpleAndCase ce - _ -> do - { encBinds <- mapM encBind binds - ; encExpr <- encapsulateScalars expr - ; return ((fvs, vi), AnnLet (AnnRec encBinds) encExpr) - } - } - where - encBind (bndr, expr) = (bndr,) <$> encapsulateScalars expr -encapsulateScalars ((fvs, vi), AnnCast expr coercion) - = do - { encExpr <- encapsulateScalars expr - ; return ((fvs, vi), AnnCast encExpr coercion) - } -encapsulateScalars _ - = panic "Vectorise.Exp.encapsulateScalars: unknown constructor" - --- Lambda-lift the given simple expression and apply it to the abstracted free variables. --- --- If the expression is a case expression scrutinising anything, but a scalar type, then lift --- each alternative individually. --- -liftSimpleAndCase :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo -liftSimpleAndCase aexpr@((fvs, _vi), AnnCase expr bndr t alts) - = do - { vi <- vectAvoidInfoTypeOf expr - ; if (vi == VISimple) - then - liftSimple aexpr -- if the scrutinee is scalar, we need no special treatment - else do - { alts' <- mapM (\(ac, bndrs, aexpr) -> (ac, bndrs,) <$> liftSimpleAndCase aexpr) alts - ; return ((fvs, vi), AnnCase expr bndr t alts') - } - } -liftSimpleAndCase aexpr = liftSimple aexpr - -liftSimple :: CoreExprWithVectInfo -> VM CoreExprWithVectInfo -liftSimple ((fvs, vi), AnnVar v) - | v `elemDVarSet` fvs -- special case to avoid producing: (\v -> v) v - && not (isToplevel v) -- NB: if 'v' not free or is toplevel, we must get the 'VIEncaps' - = return $ ((fvs, vi), AnnVar v) -liftSimple aexpr@((fvs_orig, VISimple), expr) - = do - { let liftedExpr = mkAnnApps (mkAnnLams (reverse vars) fvs expr) vars - - ; traceVt "encapsulate:" $ ppr (deAnnotate aexpr) $$ text "==>" $$ ppr (deAnnotate liftedExpr) - - ; return $ liftedExpr - } - where - vars = dVarSetElems fvs - fvs = filterDVarSet (not . isToplevel) fvs_orig -- only include 'Id's that are not toplevel - - mkAnnLams :: [Var] -> DVarSet -> AnnExpr' Var (DVarSet, VectAvoidInfo) -> CoreExprWithVectInfo - mkAnnLams [] fvs expr = ASSERT(isEmptyDVarSet fvs) - ((emptyDVarSet, VIEncaps), expr) - mkAnnLams (v:vs) fvs expr = mkAnnLams vs (fvs `delDVarSet` v) (AnnLam v ((fvs, VIEncaps), expr)) - - mkAnnApps :: CoreExprWithVectInfo -> [Var] -> CoreExprWithVectInfo - mkAnnApps aexpr [] = aexpr - mkAnnApps aexpr (v:vs) = mkAnnApps (mkAnnApp aexpr v) vs - - mkAnnApp :: CoreExprWithVectInfo -> Var -> CoreExprWithVectInfo - mkAnnApp aexpr@((fvs, _vi), _expr) v - = ((fvs `extendDVarSet` v, VISimple), AnnApp aexpr ((unitDVarSet v, VISimple), AnnVar v)) -liftSimple aexpr - = pprPanic "Vectorise.Exp.liftSimple: not simple" $ ppr (deAnnotate aexpr) - -isToplevel :: Var -> Bool -isToplevel v | isId v = case realIdUnfolding v of - NoUnfolding -> False - BootUnfolding -> False - OtherCon {} -> True - DFunUnfolding {} -> True - CoreUnfolding {uf_is_top = top} -> top - | otherwise = False - --- |Vectorise an expression. --- -vectExpr :: CoreExprWithVectInfo -> VM VExpr - -vectExpr aexpr - -- encapsulated expression of functional type => try to vectorise as a scalar subcomputation - | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr - = vectFnExpr True False aexpr - -- encapsulated constant => vectorise as a scalar constant - | isVIEncaps aexpr - = traceVt "vectExpr (encapsulated constant):" (ppr . deAnnotate $ aexpr) >> - vectConst (deAnnotate aexpr) - -vectExpr (_, AnnVar v) - = vectVar v - -vectExpr (_, AnnLit lit) - = vectConst $ Lit lit - -vectExpr aexpr@(_, AnnLam _ _) - = traceVt "vectExpr [AnnLam]:" (ppr . deAnnotate $ aexpr) >> - vectFnExpr True False aexpr - - -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty'; - -- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint - -- happy. --- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now? -vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) - | v == pAT_ERROR_ID - = do - { (vty, lty) <- vectAndLiftType ty - ; return (mkCoreApps (Var v) [Type (getRuntimeRep vty), Type vty, err'], - mkCoreApps (Var v) [Type lty, err']) - } - where - err' = deAnnotate err - - -- type application (handle multiple consecutive type applications simultaneously to ensure the - -- PA dictionaries are put at the right places) -vectExpr e@(_, AnnApp _ arg) - | isAnnTypeArg arg - = vectPolyApp e - - -- Lifted literal -vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit)) - | Just _con <- isDataConId_maybe v - = do - { let vexpr = App (Var v) (Lit lit) - ; lexpr <- liftPD vexpr - ; return (vexpr, lexpr) - } - - -- value application (dictionary or user value) -vectExpr e@(_, AnnApp fn arg) - | isPredTy arg_ty -- dictionary application (whose result is not a dictionary) - = vectPolyApp e - | otherwise -- user value - = do - { -- vectorise the types - ; varg_ty <- vectType arg_ty - ; vres_ty <- vectType res_ty - - -- vectorise the function and argument expression - ; vfn <- vectExpr fn - ; varg <- vectExpr arg - - -- the vectorised function is a closure; apply it to the vectorised argument - ; mkClosureApp varg_ty vres_ty vfn varg - } - where - (arg_ty, res_ty) = splitFunTy . exprType $ deAnnotate fn - -vectExpr (_, AnnCase scrut bndr ty alts) - | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty - , isAlgTyCon tycon - = vectAlgCase tycon ty_args scrut bndr ty alts - | otherwise - = do - { dflags <- getDynFlags - ; cantVectorise dflags "Can't vectorise expression (no algebraic type constructor)" $ - ppr scrut_ty - } - where - scrut_ty = exprType (deAnnotate scrut) - -vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) - = do - { traceVt "let binding (non-recursive)" Outputable.empty - ; vrhs <- localV $ - inBind bndr $ - vectAnnPolyExpr False rhs - ; traceVt "let body (non-recursive)" Outputable.empty - ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) - ; return $ vLet (vNonRec vbndr vrhs) vbody - } - -vectExpr (_, AnnLet (AnnRec bs) body) - = do - { (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ do - { traceVt "let bindings (recursive)" Outputable.empty - ; vrhss <- zipWithM vect_rhs bndrs rhss - ; traceVt "let body (recursive)" Outputable.empty - ; vbody <- vectExpr body - ; return (vrhss, vbody) - } - ; return $ vLet (vRec vbndrs vrhss) vbody - } - where - (bndrs, rhss) = unzip bs - - vect_rhs bndr rhs = localV $ - inBind bndr $ - vectAnnPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) rhs - -vectExpr (_, AnnTick tickish expr) - = vTick tickish <$> vectExpr expr - -vectExpr (_, AnnType ty) - = vType <$> vectType ty - -vectExpr e - = do - { dflags <- getDynFlags - ; cantVectorise dflags "Can't vectorise expression (vectExpr)" $ ppr (deAnnotate e) - } - --- |Vectorise an expression that *may* have an outer lambda abstraction. If the expression is marked --- as encapsulated ('VIEncaps'), vectorise it as a scalar computation (using a generalised scalar --- zip). --- --- We do not handle type variables at this point, as they will already have been stripped off by --- 'vectPolyExpr'. We also only have to worry about one set of dictionary arguments as we (1) only --- deal with Haskell 2011 and (2) class selectors are vectorised elsewhere. --- -vectFnExpr :: Bool -- ^If we process the RHS of a binding, whether that binding - -- should be inlined - -> Bool -- ^Whether the binding is a loop breaker - -> CoreExprWithVectInfo -- ^Expression to vectorise; must have an outer `AnnLam` - -> VM VExpr -vectFnExpr inline loop_breaker aexpr@(_ann, AnnLam bndr body) - -- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type - | isId bndr - && isPredTy (idType bndr) - = do - { vBndr <- vectBndr bndr - ; vbody <- vectFnExpr inline loop_breaker body - ; return $ mapVect (mkLams [vectorised vBndr]) vbody - } - -- encapsulated non-predicate abstraction: vectorise as a scalar computation - | isId bndr && isVIEncaps aexpr - = vectScalarFun . deAnnotate $ aexpr - -- non-predicate abstraction: vectorise as a non-scalar computation - | isId bndr - = vectLam inline loop_breaker aexpr - | otherwise - = do - { dflags <- getDynFlags - ; cantVectorise dflags "Vectorise.Exp.vectFnExpr: Unexpected type lambda" $ - ppr (deAnnotate aexpr) - } -vectFnExpr _ _ aexpr - -- encapsulated function: vectorise as a scalar computation - | (isFunTy . annExprType $ aexpr) && isVIEncaps aexpr - = vectScalarFun . deAnnotate $ aexpr - | otherwise - -- not an abstraction: vectorise as a non-scalar vanilla expression - -- NB: we can get here due to the recursion in the first case above and from 'vectAnnPolyExpr' - = vectExpr aexpr - --- |Vectorise type and dictionary applications. --- --- These are always headed by a variable (as we don't support higher-rank polymorphism), but may --- involve two sets of type variables and dictionaries. Consider, --- --- > class C a where --- > m :: D b => b -> a --- --- The type of 'm' is 'm :: forall a. C a => forall b. D b => b -> a'. --- -vectPolyApp :: CoreExprWithVectInfo -> VM VExpr -vectPolyApp e0 - = case e4 of - (_, AnnVar var) - -> do { -- get the vectorised form of the variable - ; vVar <- lookupVar var - ; traceVt "vectPolyApp of" (ppr var) - - -- vectorise type and dictionary arguments - ; vDictsOuter <- mapM vectDictExpr (map deAnnotate dictsOuter) - ; vDictsInner <- mapM vectDictExpr (map deAnnotate dictsInner) - ; vTysOuter <- mapM vectType tysOuter - ; vTysInner <- mapM vectType tysInner - - ; let reconstructOuter v = (`mkApps` vDictsOuter) <$> polyApply v vTysOuter - - ; case vVar of - Local (vv, lv) - -> do { MASSERT( null dictsInner ) -- local vars cannot be class selectors - ; traceVt " LOCAL" (text "") - ; (,) <$> reconstructOuter (Var vv) <*> reconstructOuter (Var lv) - } - Global vv - | isDictComp var -- dictionary computation - -> do { -- in a dictionary computation, the innermost, non-empty set of - -- arguments are non-vectorised arguments, where no 'PA'dictionaries - -- are needed for the type variables - ; ve <- if null dictsInner - then - return $ Var vv `mkTyApps` vTysOuter `mkApps` vDictsOuter - else - reconstructOuter - (Var vv `mkTyApps` vTysInner `mkApps` vDictsInner) - ; traceVt " GLOBAL (dict):" (ppr ve) - ; vectConst ve - } - | otherwise -- non-dictionary computation - -> do { MASSERT( null dictsInner ) - ; ve <- reconstructOuter (Var vv) - ; traceVt " GLOBAL (non-dict):" (ppr ve) - ; vectConst ve - } - } - _ -> pprSorry "Cannot vectorise programs with higher-rank types:" (ppr . deAnnotate $ e0) - where - -- if there is only one set of variables or dictionaries, it will be the outer set - (e1, dictsOuter) = collectAnnDictArgs e0 - (e2, tysOuter) = collectAnnTypeArgs e1 - (e3, dictsInner) = collectAnnDictArgs e2 - (e4, tysInner) = collectAnnTypeArgs e3 - -- - isDictComp var = (isJust . isClassOpId_maybe $ var) || isDFunId var - --- |Vectorise the body of a dfun. --- --- Dictionary computations are special for the following reasons. The application of dictionary --- functions are always saturated, so there is no need to create closures. Dictionary computations --- don't depend on array values, so they are always scalar computations whose result we can --- replicate (instead of executing them in parallel). --- --- NB: To keep things simple, we are not rewriting any of the bindings introduced in a dictionary --- computation. Consequently, the variable case needs to deal with cases where binders are --- in the vectoriser environments and where that is not the case. --- -vectDictExpr :: CoreExpr -> VM CoreExpr -vectDictExpr (Var var) - = do { mb_scope <- lookupVar_maybe var - ; case mb_scope of - Nothing -> return $ Var var -- binder from within the dict. computation - Just (Local (vVar, _)) -> return $ Var vVar -- local vectorised variable - Just (Global vVar) -> return $ Var vVar -- global vectorised variable - } -vectDictExpr (Lit lit) - = pprPanic "Vectorise.Exp.vectDictExpr: literal in dictionary computation" (ppr lit) -vectDictExpr (Lam bndr e) - = Lam bndr <$> vectDictExpr e -vectDictExpr (App fn arg) - = App <$> vectDictExpr fn <*> vectDictExpr arg -vectDictExpr (Case e bndr ty alts) - = Case <$> vectDictExpr e <*> pure bndr <*> vectType ty <*> mapM vectDictAlt alts - where - vectDictAlt (con, bs, e) = (,,) <$> vectDictAltCon con <*> pure bs <*> vectDictExpr e - -- - vectDictAltCon (DataAlt datacon) = DataAlt <$> maybeV dataConErr (lookupDataCon datacon) - where - dataConErr = text "Cannot vectorise data constructor:" <+> ppr datacon - vectDictAltCon (LitAlt lit) = return $ LitAlt lit - vectDictAltCon DEFAULT = return DEFAULT -vectDictExpr (Let bnd body) - = Let <$> vectDictBind bnd <*> vectDictExpr body - where - vectDictBind (NonRec bndr e) = NonRec bndr <$> vectDictExpr e - vectDictBind (Rec bnds) = Rec <$> mapM (\(bndr, e) -> (bndr,) <$> vectDictExpr e) bnds -vectDictExpr e@(Cast _e _coe) - = pprSorry "Vectorise.Exp.vectDictExpr: cast" (ppr e) -vectDictExpr (Tick tickish e) - = Tick tickish <$> vectDictExpr e -vectDictExpr (Type ty) - = Type <$> vectType ty -vectDictExpr (Coercion coe) - = pprSorry "Vectorise.Exp.vectDictExpr: coercion" (ppr coe) - --- |Vectorise an expression of functional type, where all arguments and the result are of primitive --- types (i.e., 'Int', 'Float', 'Double' etc., which have instances of the 'Scalar' type class) and --- which does not contain any subcomputations that involve parallel arrays. Such functionals do not --- require the full blown vectorisation transformation; instead, they can be lifted by application --- of a member of the zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.) --- --- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised, --- instead they become dictionaries of vectorised methods). We treat them differently, though see --- "Note [Scalar dfuns]" in 'Vectorise'. --- -vectScalarFun :: CoreExpr -> VM VExpr -vectScalarFun expr - = do - { traceVt "vectScalarFun:" (ppr expr) - ; let (arg_tys, res_ty) = splitFunTys (exprType expr) - ; mkScalarFun arg_tys res_ty expr - } - --- Generate code for a scalar function by generating a scalar closure. If the function is a --- dictionary function, vectorise it as dictionary code. --- -mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr -mkScalarFun arg_tys res_ty expr - | isPredTy res_ty - = do { vExpr <- vectDictExpr expr - ; return (vExpr, unused) - } - | otherwise - = do { traceVt "mkScalarFun: " $ ppr expr $$ text " ::" <+> - ppr (mkFunTys arg_tys res_ty) - - ; fn_var <- hoistExpr (fsLit "fn") expr DontInline - ; zipf <- zipScalars arg_tys res_ty - ; clo <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var) - ; clo_var <- hoistExpr (fsLit "clo") clo DontInline - ; lclo <- liftPD (Var clo_var) - ; return (Var clo_var, lclo) - } - where - unused = error "Vectorise.Exp.mkScalarFun: we don't lift dictionary expressions" - --- |Vectorise a dictionary function that has a 'VECTORISE SCALAR instance' pragma. --- --- In other words, all methods in that dictionary are scalar functions — to be vectorised with --- 'vectScalarFun'. The dictionary "function" itself may be a constant, though. --- --- NB: You may think that we could implement this function guided by the structure of the Core --- expression of the right-hand side of the dictionary function. We cannot proceed like this as --- 'vectScalarDFun' must also work for *imported* dfuns, where we don't necessarily have access --- to the Core code of the unvectorised dfun. --- --- Here an example — assume, --- --- > class Eq a where { (==) :: a -> a -> Bool } --- > instance (Eq a, Eq b) => Eq (a, b) where { (==) = ... } --- > {-# VECTORISE SCALAR instance Eq (a, b) } --- --- The unvectorised dfun for the above instance has the following signature: --- --- > $dEqPair :: forall a b. Eq a -> Eq b -> Eq (a, b) --- --- We generate the following (scalar) vectorised dfun (liberally using TH notation): --- --- > $v$dEqPair :: forall a b. V:Eq a -> V:Eq b -> V:Eq (a, b) --- > $v$dEqPair = /\a b -> \dEqa :: V:Eq a -> \dEqb :: V:Eq b -> --- > D:V:Eq $(vectScalarFun True recFns --- > [| (==) @(a, b) ($dEqPair @a @b $(unVect dEqa) $(unVect dEqb)) |]) --- --- NB: --- * '(,)' vectorises to '(,)' — hence, the type constructor in the result type remains the same. --- * We share the '$(unVect di)' sub-expressions between the different selectors, but duplicate --- the application of the unvectorised dfun, to enable the dictionary selection rules to fire. --- -vectScalarDFun :: Var -- ^ Original dfun - -> VM CoreExpr -vectScalarDFun var - = do { -- bring the type variables into scope - ; mapM_ defLocalTyVar tvs - - -- vectorise dictionary argument types and generate variables for them - ; vTheta <- mapM vectType theta - ; vThetaBndr <- mapM (newLocalVar (fsLit "vd")) vTheta - ; let vThetaVars = varsToCoreExprs vThetaBndr - - -- vectorise superclass dictionaries and methods as scalar expressions - ; thetaVars <- mapM (newLocalVar (fsLit "d")) theta - ; thetaExprs <- zipWithM unVectDict theta vThetaVars - ; let thetaDictBinds = zipWith NonRec thetaVars thetaExprs - dict = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars - scsOps = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict]) - selIds - ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun e) scsOps - - -- vectorised applications of the class-dictionary data constructor - ; Just vDataCon <- lookupDataCon dataCon - ; vTys <- mapM vectType tys - ; let vBody = thetaDictBinds `mkLets` mkCoreConApps vDataCon (map Type vTys ++ vScsOps) - - ; 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 - --- Build a value of the dictionary before vectorisation from original, unvectorised type and an --- expression computing the vectorised dictionary. --- --- Given the vectorised version of a dictionary 'vd :: V:C vt1..vtn', generate code that computes --- the unvectorised version, thus: --- --- > D:C op1 .. opm --- > where --- > opi = $(fromVect opTyi [| vSeli @vt1..vtk vd |]) --- --- where 'opTyi' is the type of the i-th superclass or op of the unvectorised dictionary. --- -unVectDict :: Type -> CoreExpr -> VM CoreExpr -unVectDict ty e - = do { vTys <- mapM vectType tys - ; let meths = map (\sel -> Var sel `mkTyApps` vTys `mkApps` [e]) selIds - ; scOps <- zipWithM fromVect methTys meths - ; return $ mkCoreConApps dataCon (map Type tys ++ scOps) - } - where - (tycon, tys) = splitTyConApp ty - Just dataCon = isDataProductTyCon_maybe tycon - Just cls = tyConClass_maybe tycon - methTys = dataConInstArgTys dataCon tys - selIds = classAllSelIds cls - --- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures. --- --- All non-dictionary free variables go into the closure's environment, whereas the dictionary --- variables are passed explicit (as conventional arguments) into the body during closure --- construction. --- -vectLam :: Bool -- ^ Should the RHS of a binding be inlined? - -> Bool -- ^ Whether the binding is a loop breaker. - -> CoreExprWithVectInfo -- ^ Body of abstraction. - -> VM VExpr -vectLam inline loop_breaker expr@((fvs, _vi), AnnLam _ _) - = do { traceVt "fully vectorise a lambda expression" (ppr . deAnnotate $ expr) - - ; let (bndrs, body) = collectAnnValBinders expr - - -- grab the in-scope type variables - ; tyvars <- localTyVars - - -- collect and vectorise all /local/ free variables - ; vfvs <- readLEnv $ \env -> - [ (var, fromJust mb_vv) - | var <- dVarSetElems fvs - , let mb_vv = lookupVarEnv (local_vars env) var - , isJust mb_vv -- its local == is in local var env - ] - -- separate dictionary from non-dictionary variables in the free variable set - ; let (vvs_dict, vvs_nondict) = partition (isPredTy . varType . fst) vfvs - (_fvs_dict, vfvs_dict) = unzip vvs_dict - (fvs_nondict, vfvs_nondict) = unzip vvs_nondict - - -- compute the type of the vectorised closure - ; arg_tys <- mapM (vectType . idType) bndrs - ; res_ty <- vectType (exprType $ deAnnotate body) - - ; let arity = length fvs_nondict + length bndrs - vfvs_dict' = map vectorised vfvs_dict - ; buildClosures tyvars vfvs_dict' vfvs_nondict arg_tys res_ty - . hoistPolyVExpr tyvars vfvs_dict' (maybe_inline arity) - $ do { -- generate the vectorised body of the lambda abstraction - ; lc <- builtin liftingContext - ; (vbndrs, vbody) <- vectBndrsIn (fvs_nondict ++ bndrs) $ vectExpr body - - ; vbody' <- break_loop lc res_ty vbody - ; return $ vLams lc vbndrs vbody' - } - } - where - maybe_inline n | inline = Inline n - | otherwise = DontInline - - -- If this is the body of a binding marked as a loop breaker, add a recursion termination test - -- to the /lifted/ version of the function body. The termination tests checks if the lifting - -- context is empty. If so, it returns an empty array of the (lifted) result type instead of - -- executing the function body. This is the test from the last line (defining \mathcal{L}') - -- in Figure 6 of HtM. - break_loop lc ty (ve, le) - | loop_breaker - = do { dflags <- getDynFlags - ; empty <- emptyPD ty - ; lty <- mkPDataType ty - ; return (ve, mkWildCase (Var lc) intPrimTy lty - [(DEFAULT, [], le), - (LitAlt (mkMachInt dflags 0), [], empty)]) - } - | otherwise = return (ve, le) -vectLam _ _ _ = panic "Vectorise.Exp.vectLam: not a lambda" - --- Vectorise an algebraic case expression. --- --- We convert --- --- case e :: t of v { ... } --- --- to --- --- V: let v' = e in case v' of _ { ... } --- L: let v' = e in case v' `cast` ... of _ { ... } --- --- When lifting, we have to do it this way because v must have the type --- [:V(T):] but the scrutinee must be cast to the representation type. We also --- have to handle the case where v is a wild var correctly. --- - --- FIXME: this is too lazy...is it? -vectAlgCase :: TyCon -> [Type] -> CoreExprWithVectInfo -> Var -> Type - -> [(AltCon, [Var], CoreExprWithVectInfo)] - -> VM VExpr -vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)] - = do - { traceVt "scrutinee (DEFAULT only)" Outputable.empty - ; vscrut <- vectExpr scrut - ; (vty, lty) <- vectAndLiftType ty - ; traceVt "alternative body (DEFAULT only)" Outputable.empty - ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) - ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody - } -vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)] - = do - { traceVt "scrutinee (one shot w/o binders)" Outputable.empty - ; vscrut <- vectExpr scrut - ; (vty, lty) <- vectAndLiftType ty - ; traceVt "alternative body (one shot w/o binders)" Outputable.empty - ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) - ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody - } -vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] - = do - { traceVt "scrutinee (one shot w/ binders)" Outputable.empty - ; vexpr <- vectExpr scrut - ; (vty, lty) <- vectAndLiftType ty - ; traceVt "alternative body (one shot w/ binders)" Outputable.empty - ; (vbndr, (vbndrs, (vect_body, lift_body))) - <- vect_scrut_bndr - . vectBndrsIn bndrs - $ vectExpr body - ; let (vect_bndrs, lift_bndrs) = unzip vbndrs - ; (vscrut, lscrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) - ; vect_dc <- maybeV dataConErr (lookupDataCon dc) - - ; let vcase = mk_wild_case vscrut vty vect_dc vect_bndrs vect_body - lcase = mk_wild_case lscrut lty pdata_dc lift_bndrs lift_body - - ; return $ vLet (vNonRec vbndr vexpr) (vcase, lcase) - } - where - vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") - | otherwise = vectBndrIn bndr - - mk_wild_case expr ty dc bndrs body - = mkWildCase expr (exprType expr) ty [(DataAlt dc, bndrs, body)] - - dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc) - -vectAlgCase tycon _ty_args scrut bndr ty alts - = do - { traceVt "scrutinee (general case)" Outputable.empty - ; vexpr <- vectExpr scrut - - ; vect_tc <- vectTyCon tycon - ; (vty, lty) <- vectAndLiftType ty - - ; let arity = length (tyConDataCons vect_tc) - ; sel_ty <- builtin (selTy arity) - ; sel_bndr <- newLocalVar (fsLit "sel") sel_ty - ; let sel = Var sel_bndr - - ; traceVt "alternatives' body (general case)" Outputable.empty - ; (vbndr, valts) <- vect_scrut_bndr - $ mapM (proc_alt arity sel vty lty) alts' - ; let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts - - ; (vect_scrut, lift_scrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) - - ; let (vect_bodies, lift_bodies) = unzip vbodies - - ; vdummy <- newDummyVar (exprType vect_scrut) - ; ldummy <- newDummyVar (exprType lift_scrut) - ; let vect_case = Case vect_scrut vdummy vty - (zipWith3 mk_vect_alt vect_dcs vect_bndrss vect_bodies) - - ; lc <- builtin liftingContext - ; lbody <- combinePD vty (Var lc) sel lift_bodies - ; let lift_case = Case lift_scrut ldummy lty - [(DataAlt pdata_dc, sel_bndr : concat lift_bndrss, - lbody)] - - ; return . vLet (vNonRec vbndr vexpr) - $ (vect_case, lift_case) - } - where - vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") - | otherwise = vectBndrIn bndr - - alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts - - cmp (DataAlt dc1) (DataAlt dc2) = dataConTag dc1 `compare` dataConTag dc2 - cmp DEFAULT DEFAULT = EQ - cmp DEFAULT _ = LT - cmp _ DEFAULT = GT - cmp _ _ = panic "vectAlgCase/cmp" - - proc_alt arity sel _ lty (DataAlt dc, bndrs, body@((fvs_body, _), _)) - = do - dflags <- getDynFlags - vect_dc <- maybeV dataConErr (lookupDataCon dc) - let ntag = dataConTagZ vect_dc - tag = mkDataConTag dflags vect_dc - fvs = fvs_body `delDVarSetList` bndrs - - sel_tags <- liftM (`App` sel) (builtin (selTags arity)) - lc <- builtin liftingContext - elems <- builtin (selElements arity ntag) - - (vbndrs, vbody) - <- vectBndrsIn bndrs - . localV - $ do - { binds <- mapM (pack_var (Var lc) sel_tags tag) - . filter isLocalId - $ dVarSetElems fvs - ; traceVt "case alternative:" (ppr . deAnnotate $ body) - ; (ve, le) <- vectExpr body - ; return (ve, Case (elems `App` sel) lc lty - [(DEFAULT, [], (mkLets (concat binds) le))]) - } - -- empty <- emptyPD vty - -- return (ve, Case (elems `App` sel) lc lty - -- [(DEFAULT, [], Let (NonRec flags_var flags_expr) - -- $ mkLets (concat binds) le), - -- (LitAlt (mkMachInt 0), [], empty)]) - let (vect_bndrs, lift_bndrs) = unzip vbndrs - return (vect_dc, vect_bndrs, lift_bndrs, vbody) - where - dataConErr = (text "vectAlgCase: data constructor not vectorised" <+> ppr dc) - - proc_alt _ _ _ _ _ = panic "vectAlgCase/proc_alt" - - mk_vect_alt vect_dc bndrs body = (DataAlt vect_dc, bndrs, body) - - -- Pack a variable for a case alternative context *if* the variable is vectorised. If it - -- isn't, ignore it as scalar variables don't need to be packed. - pack_var len tags t v - = do - { r <- lookupVar_maybe v - ; case r of - Just (Local (vv, lv)) -> - do - { lv' <- cloneVar lv - ; expr <- packByTagPD (idType vv) (Var lv) len tags t - ; updLEnv (\env -> env { local_vars = extendVarEnv (local_vars env) v (vv, lv') }) - ; return [(NonRec lv' expr)] - } - _ -> return [] - } - - --- Support to compute information for vectorisation avoidance ------------------ - --- Annotation for Core AST nodes that describes how they should be handled during vectorisation --- and especially if vectorisation of the corresponding computation can be avoided. --- -data VectAvoidInfo = VIParr -- tree contains parallel computations - | VISimple -- result type is scalar & no parallel subcomputation - | VIComplex -- any result type, no parallel subcomputation - | VIEncaps -- tree encapsulated by 'liftSimple' - | VIDict -- dictionary computation (never parallel) - deriving (Eq, Show) - --- Core expression annotated with free variables and vectorisation-specific information. --- -type CoreExprWithVectInfo = AnnExpr Id (DVarSet, VectAvoidInfo) - --- Yield the type of an annotated core expression. --- -annExprType :: AnnExpr Var ann -> Type -annExprType = exprType . deAnnotate - --- Project the vectorisation information from an annotated Core expression. --- -vectAvoidInfoOf :: CoreExprWithVectInfo -> VectAvoidInfo -vectAvoidInfoOf ((_, vi), _) = vi - --- Is this a 'VIParr' node? --- -isVIParr :: CoreExprWithVectInfo -> Bool -isVIParr = (== VIParr) . vectAvoidInfoOf - --- Is this a 'VIEncaps' node? --- -isVIEncaps :: CoreExprWithVectInfo -> Bool -isVIEncaps = (== VIEncaps) . vectAvoidInfoOf - --- Is this a 'VIDict' node? --- -isVIDict :: CoreExprWithVectInfo -> Bool -isVIDict = (== VIDict) . vectAvoidInfoOf - --- 'VIParr' if either argument is 'VIParr'; otherwise, the first argument. --- -unlessVIParr :: VectAvoidInfo -> VectAvoidInfo -> VectAvoidInfo -unlessVIParr _ VIParr = VIParr -unlessVIParr vi _ = vi - --- 'VIParr' if either arguments vectorisation information is 'VIParr'; otherwise, the vectorisation --- information of the first argument is produced. --- -unlessVIParrExpr :: VectAvoidInfo -> CoreExprWithVectInfo -> VectAvoidInfo -infixl `unlessVIParrExpr` -unlessVIParrExpr e1 e2 = e1 `unlessVIParr` vectAvoidInfoOf e2 - --- Compute Core annotations to determine for which subexpressions we can avoid vectorisation. --- --- * The first argument is the set of free, local variables whose evaluation may entail parallelism. --- -vectAvoidInfo :: VarSet -> CoreExprWithFVs -> VM CoreExprWithVectInfo -vectAvoidInfo pvs ce@(_, AnnVar v) - = do - { gpvs <- globalParallelVars - ; vi <- if v `elemVarSet` pvs || v `elemDVarSet` gpvs - then return VIParr - else vectAvoidInfoTypeOf ce - ; viTrace ce vi [] - ; when (vi == VIParr) $ - traceVt " reason:" $ if v `elemVarSet` pvs then text "local" else - if v `elemDVarSet` gpvs then text "global" else text "parallel type" - - ; return ((fvs, vi), AnnVar v) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo _pvs ce@(_, AnnLit lit) - = do - { vi <- vectAvoidInfoTypeOf ce - ; viTrace ce vi [] - ; return ((fvs, vi), AnnLit lit) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnApp e1 e2) - = do - { ceVI <- vectAvoidInfoTypeOf ce - ; eVI1 <- vectAvoidInfo pvs e1 - ; eVI2 <- vectAvoidInfo pvs e2 - ; let vi = ceVI `unlessVIParrExpr` eVI1 `unlessVIParrExpr` eVI2 - -- ; viTrace ce vi [eVI1, eVI2] - ; return ((fvs, vi), AnnApp eVI1 eVI2) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnLam var body) - = do - { bodyVI <- vectAvoidInfo pvs body - ; varVI <- vectAvoidInfoType $ varType var - ; let vi = vectAvoidInfoOf bodyVI `unlessVIParr` varVI - -- ; viTrace ce vi [bodyVI] - ; return ((fvs, vi), AnnLam var bodyVI) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnLet (AnnNonRec var e) body) - = do - { ceVI <- vectAvoidInfoTypeOf ce - ; eVI <- vectAvoidInfo pvs e - ; isScalarTy <- isScalar $ varType var - ; (bodyVI, vi) <- if isVIParr eVI && not isScalarTy - then do -- binding is parallel - { bodyVI <- vectAvoidInfo (pvs `extendVarSet` var) body - ; return (bodyVI, VIParr) - } - else do -- binding doesn't affect parallelism - { bodyVI <- vectAvoidInfo pvs body - ; return (bodyVI, ceVI `unlessVIParrExpr` bodyVI) - } - -- ; viTrace ce vi [eVI, bodyVI] - ; return ((fvs, vi), AnnLet (AnnNonRec var eVI) bodyVI) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnLet (AnnRec bnds) body) - = do - { ceVI <- vectAvoidInfoTypeOf ce - ; bndsVI <- mapM (vectAvoidInfoBnd pvs) bnds - ; parrBndrs <- map fst <$> filterM isVIParrBnd bndsVI - ; if not . null $ parrBndrs - then do -- body may trigger parallelism via at least one binding - { new_pvs <- filterM ((not <$>) . isScalar . varType) parrBndrs - ; let extendedPvs = pvs `extendVarSetList` new_pvs - ; bndsVI <- mapM (vectAvoidInfoBnd extendedPvs) bnds - ; bodyVI <- vectAvoidInfo extendedPvs body - -- ; viTrace ce VIParr (map snd bndsVI ++ [bodyVI]) - ; return ((fvs, VIParr), AnnLet (AnnRec bndsVI) bodyVI) - } - else do -- demanded bindings cannot trigger parallelism - { bodyVI <- vectAvoidInfo pvs body - ; let vi = ceVI `unlessVIParrExpr` bodyVI - -- ; viTrace ce vi (map snd bndsVI ++ [bodyVI]) - ; return ((fvs, vi), AnnLet (AnnRec bndsVI) bodyVI) - } - } - where - fvs = freeVarsOf ce - vectAvoidInfoBnd pvs (var, e) = (var,) <$> vectAvoidInfo pvs e - - isVIParrBnd (var, eVI) - = do - { isScalarTy <- isScalar (varType var) - ; return $ isVIParr eVI && not isScalarTy - } - -vectAvoidInfo pvs ce@(_, AnnCase e var ty alts) - = do - { ceVI <- vectAvoidInfoTypeOf ce - ; eVI <- vectAvoidInfo pvs e - ; altsVI <- mapM (vectAvoidInfoAlt (isVIParr eVI)) alts - ; let alteVIs = [eVI | (_, _, eVI) <- altsVI] - vi = foldl unlessVIParrExpr ceVI (eVI:alteVIs) -- NB: same effect as in the paper - -- ; viTrace ce vi (eVI : alteVIs) - ; return ((fvs, vi), AnnCase eVI var ty altsVI) - } - where - fvs = freeVarsOf ce - vectAvoidInfoAlt scrutIsPar (con, bndrs, e) - = do - { allScalar <- allScalarVarType bndrs - ; let altPvs | scrutIsPar && not allScalar = pvs `extendVarSetList` bndrs - | otherwise = pvs - ; (con, bndrs,) <$> vectAvoidInfo altPvs e - } - -vectAvoidInfo pvs ce@(_, AnnCast e (fvs_ann, ann)) - = do - { eVI <- vectAvoidInfo pvs e - ; return ((fvs, vectAvoidInfoOf eVI), AnnCast eVI ((freeVarsOfAnn fvs_ann, VISimple), ann)) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo pvs ce@(_, AnnTick tick e) - = do - { eVI <- vectAvoidInfo pvs e - ; return ((fvs, vectAvoidInfoOf eVI), AnnTick tick eVI) - } - where - fvs = freeVarsOf ce - -vectAvoidInfo _pvs ce@(_, AnnType ty) - = return ((fvs, VISimple), AnnType ty) - where - fvs = freeVarsOf ce - -vectAvoidInfo _pvs ce@(_, AnnCoercion coe) - = return ((fvs, VISimple), AnnCoercion coe) - where - fvs = freeVarsOf ce - --- Compute vectorisation avoidance information for a type. --- -vectAvoidInfoType :: Type -> VM VectAvoidInfo -vectAvoidInfoType ty - | isPredTy ty - = return VIDict - | Just (arg, res) <- splitFunTy_maybe ty - = do - { argVI <- vectAvoidInfoType arg - ; resVI <- vectAvoidInfoType res - ; case (argVI, resVI) of - (VISimple, VISimple) -> return VISimple -- NB: diverts from the paper: scalar functions - (_ , VIDict) -> return VIDict - _ -> return $ VIComplex `unlessVIParr` argVI `unlessVIParr` resVI - } - | otherwise - = do - { parr <- maybeParrTy ty - ; if parr - then return VIParr - else do - { scalar <- isScalar ty - ; if scalar - then return VISimple - else return VIComplex - } } - --- Compute vectorisation avoidance information for the type of a Core expression (with FVs). --- -vectAvoidInfoTypeOf :: AnnExpr Var ann -> VM VectAvoidInfo -vectAvoidInfoTypeOf = vectAvoidInfoType . annExprType - --- Checks whether the type might be a parallel array type. --- -maybeParrTy :: Type -> VM Bool -maybeParrTy ty - -- looking through newtypes - | Just ty' <- coreView ty - = (== VIParr) <$> vectAvoidInfoType ty' - -- decompose constructor applications - | Just (tc, ts) <- splitTyConApp_maybe ty - = do - { isParallel <- (tyConName tc `elemNameSet`) <$> globalParallelTyCons - ; if isParallel - 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 - --- Are the types of all variables in the 'Scalar' class or toplevel variables? --- --- NB: 'liftSimple' does not abstract over toplevel variables. --- -allScalarVarType :: [Var] -> VM Bool -allScalarVarType vs = and <$> mapM isScalarOrToplevel vs - where - isScalarOrToplevel v | isToplevel v = return True - | otherwise = isScalar (varType v) - --- Are the types of all variables in the set in the 'Scalar' class or toplevel variables? --- -allScalarVarTypeSet :: DVarSet -> VM Bool -allScalarVarTypeSet = allScalarVarType . dVarSetElems - --- Debugging support --- -viTrace :: CoreExprWithFVs -> VectAvoidInfo -> [CoreExprWithVectInfo] -> VM () -viTrace ce vi vTs - = traceVt ("vect info: " ++ show vi ++ "[" ++ - (concat $ map ((++ " ") . show . vectAvoidInfoOf) vTs) ++ "]") - (ppr $ deAnnotate ce) diff --git a/compiler/vectorise/Vectorise/Generic/Description.hs b/compiler/vectorise/Vectorise/Generic/Description.hs deleted file mode 100644 index 483e96f712..0000000000 --- a/compiler/vectorise/Vectorise/Generic/Description.hs +++ /dev/null @@ -1,294 +0,0 @@ --- |Compute a description of the generic representation that we use for a user defined data type. --- --- During vectorisation, we generate a PRepr and PA instance for each user defined --- data type. The PA dictionary contains methods to convert the user type to and --- from our generic representation. This module computes a description of what --- that generic representation is. --- -module Vectorise.Generic.Description - ( CompRepr(..) - , ProdRepr(..) - , ConRepr(..) - , SumRepr(..) - , tyConRepr - , sumReprType - , compOrigType - ) -where - -import GhcPrelude - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Builtins - -import CoreSyn -import DataCon -import TyCon -import Type -import Control.Monad -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 type has no data constructors. - EmptySum - - -- | Data type has a single constructor. - | UnarySum ConRepr - - -- | Data type has multiple constructors. - | Sum { -- | Representation tycon for the sum (eg Sum2) - repr_sum_tc :: TyCon - - -- | PData version of the sum tycon (eg PDataSum2) - -- This TyCon doesn't appear explicitly in the source program. - -- See Note [PData TyCons]. - , repr_psum_tc :: TyCon - - -- | PDatas version of the sum tycon (eg PDatasSum2) - , repr_psums_tc :: TyCon - - -- | Type of the selector (eg Sel2) - , repr_sel_ty :: Type - - -- | Type of multi-selector (eg Sel2s) - , repr_sels_ty :: Type - - -- | Function to get the length of a Sels of this type. - , repr_selsLength_v :: CoreExpr - - -- | Type of each data constructor. - , repr_con_tys :: [Type] - - -- | Generic representation types of each data constructor. - , repr_cons :: [ConRepr] - } - - --- | Describes the representation type of a data constructor. -data ConRepr - = ConRepr - { repr_dc :: DataCon - , 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 --- together into a generic product type. -data ProdRepr - = -- | Data constructor has no fields. - EmptyProd - - -- | Data constructor has a single field. - | UnaryProd CompRepr - - -- | Data constructor has several fields. - | Prod { -- | Representation tycon for the product (eg Tuple2) - repr_tup_tc :: TyCon - - -- | PData version of the product tycon (eg PDataTuple2) - , repr_ptup_tc :: TyCon - - -- | PDatas version of the product tycon (eg PDatasTuple2s) - -- Not all lifted backends use `PDatas`. - , repr_ptups_tc :: TyCon - - -- | Types of each field. - , repr_comp_tys :: [Type] - - -- | Generic representation types for each field. - , repr_comps :: [CompRepr] - } - - --- | Describes the representation type of a data constructor field. -data CompRepr - = Keep Type - CoreExpr -- PR dictionary for the type - | Wrap Type - - -------------------------------------------------------------------------------- - --- |Determine the generic representation of a data type, given its tycon. --- -tyConRepr :: TyCon -> VM SumRepr -tyConRepr tc - = sum_repr (tyConDataCons tc) - where - -- Build the representation type for a data type with the given constructors. - -- The representation types for each individual constructor are bundled - -- together into a generic sum type. - sum_repr :: [DataCon] -> VM SumRepr - sum_repr [] = return EmptySum - sum_repr [con] = liftM UnarySum (con_repr con) - 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 - { repr_sum_tc = sum_tc - , repr_psum_tc = psum_tc - , repr_psums_tc = psums_tc - , repr_sel_ty = sel_ty - , repr_sels_ty = sels_ty - , repr_selsLength_v = selsLength_v - , repr_con_tys = tys - , repr_cons = rs - } - - -- Build the representation type for a single data constructor. - con_repr con = liftM (ConRepr con) (prod_repr (dataConRepArgTys con)) - - -- Build the representation type for the fields of a data constructor. - -- The representation types for each individual field are bundled - -- together into a generic product type. - prod_repr :: [Type] -> VM ProdRepr - prod_repr [] = return EmptyProd - prod_repr [ty] = liftM UnaryProd (comp_repr ty) - prod_repr tys - = do let arity = length tys - rs <- mapM comp_repr tys - tys' <- mapM compReprType rs - - -- Get the Prod \/ Tuple tycon of this arity (eg Tuple2) - tup_tc <- builtin (prodTyCon arity) - - -- Get the 'PData' and 'PDatas' tycons for the product. - ptup_tc <- pdataReprTyConExact tup_tc - ptups_tc <- pdatasReprTyConExact tup_tc - - 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) - --- |Yield the type of this sum representation. --- -sumReprType :: SumRepr -> VM Type -sumReprType EmptySum = voidType -sumReprType (UnarySum r) = conReprType r -sumReprType (Sum { repr_sum_tc = sum_tc, repr_con_tys = tys }) - = return $ mkTyConApp sum_tc tys - --- Yield the type of this constructor representation. --- -conReprType :: ConRepr -> VM Type -conReprType (ConRepr _ r) = prodReprType r - --- Yield the type of of this product representation. --- -prodReprType :: ProdRepr -> VM Type -prodReprType EmptyProd = voidType -prodReprType (UnaryProd r) = compReprType r -prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys }) - = return $ mkTyConApp tup_tc tys - --- Yield the type of this data constructor field \/ component representation. --- -compReprType :: CompRepr -> VM Type -compReprType (Keep ty _) = return ty -compReprType (Wrap ty) = mkWrapType ty - --- |Yield the original component type of a data constructor component representation. --- -compOrigType :: CompRepr -> Type -compOrigType (Keep ty _) = ty -compOrigType (Wrap ty) = ty - - --- Outputable instances ------------------------------------------------------- -instance Outputable SumRepr where - ppr ss - = case ss of - EmptySum - -> text "EmptySum" - - UnarySum con - -> sep [text "UnarySum", ppr con] - - Sum sumtc psumtc psumstc selty selsty selsLength contys cons - -> text "Sum" $+$ braces (nest 4 - $ sep [ text "repr_sum_tc = " <> ppr sumtc - , text "repr_psum_tc = " <> ppr psumtc - , text "repr_psums_tc = " <> ppr psumstc - , text "repr_sel_ty = " <> ppr selty - , text "repr_sels_ty = " <> ppr selsty - , text "repr_selsLength_v = " <> ppr selsLength - , text "repr_con_tys = " <> ppr contys - , text "repr_cons = " <> ppr cons]) - - -instance Outputable ConRepr where - ppr (ConRepr dc pr) - = text "ConRepr" $+$ braces (nest 4 - $ sep [ text "repr_dc = " <> ppr dc - , text "repr_prod = " <> ppr pr]) - - -instance Outputable ProdRepr where - ppr ss - = 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] - - -instance Outputable CompRepr where - ppr ss - = case ss of - Keep t ce - -> text "Keep" $+$ sep [ppr t, ppr ce] - - Wrap t - -> sep [text "Wrap", ppr t] - - --- Notes ---------------------------------------------------------------------- -{- -Note [PData TyCons] -~~~~~~~~~~~~~~~~~~~ -When PData is a type family, the compiler generates a type constructor for each -instance, which is named after the family and instance type. This type -constructor does not appear in the source program. Rather, it is implicitly -defined by the data instance. For example with: - - data family PData a - - data instance PData (Sum2 a b) - = PSum2 U.Sel2 - (PData a) - (PData b) - -The type constructor corresponding to the instance will be named 'PDataSum2', -and this is what we will get in the repr_psum_tc field of SumRepr.Sum. - --} - diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs deleted file mode 100644 index d24f989161..0000000000 --- a/compiler/vectorise/Vectorise/Generic/PADict.hs +++ /dev/null @@ -1,128 +0,0 @@ - -module Vectorise.Generic.PADict - ( buildPADict - ) where - -import GhcPrelude - -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Generic.Description -import Vectorise.Generic.PAMethods ( buildPAScAndMethods ) -import Vectorise.Utils - -import BasicTypes -import CoreSyn -import CoreUtils -import CoreUnfold -import Module -import TyCon -import CoAxiom -import Type -import Id -import Var -import Name -import FastString - - --- |Build the PA dictionary function for some type and hoist it to top level. --- --- The PA dictionary holds fns that convert values to and from their vectorised representations. --- --- @Recall the definition: --- class PR (PRepr a) => PA a where --- toPRepr :: a -> PRepr a --- fromPRepr :: PRepr a -> a --- toArrPRepr :: PData a -> PData (PRepr a) --- fromArrPRepr :: PData (PRepr a) -> PData a --- toArrPReprs :: PDatas a -> PDatas (PRepr a) --- fromArrPReprs :: PDatas (PRepr a) -> PDatas a --- --- 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) ... --- $dPR_df :: forall a. PA a -> PR (PRepr (T a)) --- $dPR_df = .... --- $toRepr :: forall a. PA a -> T a -> PRepr (T a) --- $toPRepr = ... --- The "..." stuff is filled in by buildPAScAndMethods --- @ --- -buildPADict - :: TyCon -- ^ tycon of the type being vectorised. - -> CoAxiom Unbranched - -- ^ Coercion between the type and - -- its vectorised representation. - -> TyCon -- ^ PData instance tycon - -> TyCon -- ^ PDatas instance tycon - -> SumRepr -- ^ representation used for the type being vectorised. - -> VM Var -- ^ name of the top-level dictionary function. - -buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr - = polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda abstract over; and they - -- are put in the envt, so when we need a (PA a) we can find it in - -- 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 - ; return $ mkClassPred pr_cls [r] - } - ; super_tys <- sequence [mk_super_ty | not (null tvs)] - ; 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] - - -- Get ids for each of the methods in the dictionary, including superclass - ; paMethodBuilders <- buildPAScAndMethods - ; method_ids <- mapM (method val_args dfun_name) paMethodBuilders - - -- Expression to build the dictionary. - ; 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 - ++ 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 = mkInvForAllTys tvs - $ mkFunTys (map varType val_args) - (mkClassPred pa_cls [inst_ty]) - - -- Set the unfolding for the inliner. - ; raw_dfun <- newExportedVar dfun_name dfun_ty - ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args - dfun = raw_dfun `setIdUnfolding` dfun_unf - `setInlinePragma` dfunInlinePragma - - -- Add the new binding to the top-level environment. - ; hoistBinding dfun dict - ; return dfun - } - where - tvs = tyConTyVars vect_tc - arg_tys = mkTyVarTys tvs - inst_ty = mkTyConApp vect_tc arg_tys - vect_tc_name = getName vect_tc - - method args dfun_name (name, build) - = localV - $ do expr <- build vect_tc prepr_ax pdata_tc pdatas_tc repr - let body = mkLams (tvs ++ args) expr - raw_var <- newExportedVar (method_name dfun_name name) (exprType body) - let var = raw_var - `setIdUnfolding` mkInlineUnfoldingWithArity - (length args) body - `setInlinePragma` alwaysInlinePragma - hoistBinding var body - return var - - method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args) - method_name dfun_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name) diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs deleted file mode 100644 index 34163d17f6..0000000000 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ /dev/null @@ -1,586 +0,0 @@ - --- | Generate methods for the PA class. --- --- 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 - ) where - -import GhcPrelude - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Generic.Description -import CoreSyn -import CoreUtils -import FamInstEnv -import MkCore ( mkWildCase, mkCoreLet ) -import TyCon -import CoAxiom -import Type -import OccName -import Coercion -import MkId -import FamInst -import TysPrim( intPrimTy ) - -import DynFlags -import FastString -import MonadUtils -import Control.Monad -import Outputable - - -buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst -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 - liftDs $ newFamInst SynFamilyInst axiom - where - tyvars = tyConTyVars vect_tc - instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc] - --- buildPAScAndMethods -------------------------------------------------------- - --- | This says how to build the PR superclass and methods of PA --- Recall the definition of the PA class: --- --- @ --- class class PR (PRepr a) => PA a where --- toPRepr :: a -> PRepr a --- fromPRepr :: PRepr a -> a --- --- toArrPRepr :: PData a -> PData (PRepr a) --- fromArrPRepr :: PData (PRepr a) -> PData a --- --- toArrPReprs :: PDatas a -> PDatas (PRepr a) --- fromArrPReprs :: PDatas (PRepr a) -> PDatas a --- @ --- -type PAInstanceBuilder - = TyCon -- ^ Vectorised TyCon - -> CoAxiom Unbranched - -- ^ Coercion to the representation TyCon - -> TyCon -- ^ 'PData' TyCon - -> TyCon -- ^ 'PDatas' TyCon - -> SumRepr -- ^ Description of generic representation. - -> VM CoreExpr -- ^ Instance function. - - -buildPAScAndMethods :: VM [(String, PAInstanceBuilder)] -buildPAScAndMethods - = return [ ("toPRepr", buildToPRepr) - , ("fromPRepr", buildFromPRepr) - , ("toArrPRepr", buildToArrPRepr) - , ("fromArrPRepr", buildFromArrPRepr) - , ("toArrPReprs", buildToArrPReprs) - , ("fromArrPReprs", buildFromArrPReprs)] - - --- buildToPRepr --------------------------------------------------------------- --- | Build the 'toRepr' method of the PA class. -buildToPRepr :: PAInstanceBuilder -buildToPRepr vect_tc repr_ax _ _ repr - = do let arg_ty = mkTyConApp vect_tc ty_args - - -- Get the representation type of the argument. - res_ty <- mkPReprType arg_ty - - -- Var to bind the argument - arg <- newLocalVar (fsLit "x") arg_ty - - -- Build the expression to convert the argument to the generic representation. - result <- to_sum (Var arg) arg_ty res_ty repr - - return $ Lam arg result - where - ty_args = mkTyVarTys (tyConTyVars vect_tc) - - 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. - to_sum :: CoreExpr -> Type -> Type -> SumRepr -> VM CoreExpr - to_sum _ _ _ EmptySum - = do void <- builtin voidVar - return $ wrap_repr_inst $ Var void - - to_sum arg arg_ty res_ty (UnarySum r) - = do (pat, vars, body) <- con_alt r - return $ mkWildCase arg arg_ty res_ty - [(pat, vars, wrap_repr_inst body)] - - to_sum arg arg_ty res_ty (Sum { repr_sum_tc = sum_tc - , repr_con_tys = tys - , repr_cons = cons }) - = do alts <- mapM con_alt cons - let alts' = [(pat, vars, wrap_repr_inst - $ mkConApp sum_con (map Type tys ++ [body])) - | ((pat, vars, body), sum_con) - <- zip alts (tyConDataCons sum_tc)] - return $ mkWildCase arg arg_ty res_ty alts' - - con_alt (ConRepr con r) - = do (vars, body) <- to_prod r - return (DataAlt con, vars, body) - - -- CoreExp to convert data constructor fields to the generic representation. - to_prod :: ProdRepr -> VM ([Var], CoreExpr) - to_prod EmptyProd - = do void <- builtin voidVar - return ([], Var void) - - to_prod (UnaryProd comp) - = do var <- newLocalVar (fsLit "x") (compOrigType comp) - body <- to_comp (Var var) comp - return ([var], body) - - to_prod (Prod { repr_tup_tc = tup_tc - , repr_comp_tys = tys - , repr_comps = comps }) - = do vars <- newLocalVars (fsLit "x") (map compOrigType comps) - exprs <- zipWithM to_comp (map Var vars) comps - let [tup_con] = tyConDataCons tup_tc - return (vars, mkConApp tup_con (map Type tys ++ exprs)) - - -- CoreExp to convert a data constructor component to the generic representation. - to_comp :: CoreExpr -> CompRepr -> VM CoreExpr - to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) = wrapNewTypeBodyOfWrap expr ty - - --- buildFromPRepr ------------------------------------------------------------- - --- |Build the 'fromPRepr' method of the PA class. --- -buildFromPRepr :: PAInstanceBuilder -buildFromPRepr vect_tc repr_ax _ _ repr - = do - arg_ty <- mkPReprType res_ty - arg <- newLocalVar (fsLit "x") arg_ty - - result <- from_sum (unwrapTypeUnbranchedFamInstScrut repr_ax ty_args [] (Var arg)) - repr - return $ Lam arg result - where - ty_args = mkTyVarTys (tyConTyVars vect_tc) - res_ty = mkTyConApp vect_tc ty_args - - from_sum _ EmptySum - = do dummy <- builtin fromVoidVar - return $ Var dummy `App` Type res_ty - - from_sum expr (UnarySum r) = from_con expr r - from_sum expr (Sum { repr_sum_tc = sum_tc - , repr_con_tys = tys - , repr_cons = cons }) - = do vars <- newLocalVars (fsLit "x") tys - es <- zipWithM from_con (map Var vars) cons - return $ mkWildCase expr (exprType expr) res_ty - [(DataAlt con, [var], e) - | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es] - - from_con expr (ConRepr con r) - = from_prod expr (mkConApp con $ map Type ty_args) r - - from_prod _ con EmptyProd = return con - 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 - }) - = do vars <- newLocalVars (fsLit "y") tys - es <- zipWithM from_comp (map Var vars) comps - let [tup_con] = tyConDataCons tup_tc - return $ mkWildCase expr (exprType expr) res_ty - [(DataAlt tup_con, vars, con `mkApps` es)] - - from_comp expr (Keep _ _) = return expr - from_comp expr (Wrap ty) = unwrapNewTypeBodyOfWrap expr ty - - --- buildToArrRepr ------------------------------------------------------------- - --- |Build the 'toArrRepr' method of the PA class. --- -buildToArrPRepr :: PAInstanceBuilder -buildToArrPRepr vect_tc repr_co pdata_tc _ r - = do arg_ty <- mkPDataType el_ty - res_ty <- mkPDataType =<< mkPReprType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - pdata_co <- mkBuiltinCo pdataTyCon - let co = mkAppCo pdata_co - $ mkSymCo - $ mkUnbranchedAxInstCo Nominal repr_co ty_args [] - - scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) - - (vars, result) <- to_sum r - - return . Lam arg - $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty - [(DataAlt pdata_dc, vars, mkCast result co)] - where - ty_args = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc ty_args - [pdata_dc] = tyConDataCons pdata_tc - - to_sum ss - = case ss of - EmptySum -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) - UnarySum r -> to_con r - Sum{} - -> do let psum_tc = repr_psum_tc ss - let [psum_con] = tyConDataCons psum_tc - (vars, exprs) <- mapAndUnzipM to_con (repr_cons ss) - sel <- newLocalVar (fsLit "sel") (repr_sel_ty ss) - return ( sel : concat vars - , wrapFamInstBody psum_tc (repr_con_tys ss) - $ mkConApp psum_con - $ map Type (repr_con_tys ss) ++ (Var sel : exprs)) - - to_prod ss - = case ss of - EmptyProd -> builtin pvoidVar >>= \pvoid -> return ([], Var pvoid) - UnaryProd r - -> do pty <- mkPDataType (compOrigType r) - var <- newLocalVar (fsLit "x") pty - expr <- to_comp (Var var) r - return ([var], expr) - Prod{} - -> do let [ptup_con] = tyConDataCons (repr_ptup_tc ss) - ptys <- mapM (mkPDataType . compOrigType) (repr_comps ss) - vars <- newLocalVars (fsLit "x") ptys - exprs <- zipWithM to_comp (map Var vars) (repr_comps ss) - return ( vars - , wrapFamInstBody (repr_ptup_tc ss) (repr_comp_tys ss) - $ mkConApp ptup_con - $ map Type (repr_comp_tys ss) ++ exprs) - - to_con (ConRepr _ r) = to_prod r - - to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) = wrapNewTypeBodyOfPDataWrap expr ty - - --- buildFromArrPRepr ---------------------------------------------------------- - --- |Build the 'fromArrPRepr' method for the PA class. --- -buildFromArrPRepr :: PAInstanceBuilder -buildFromArrPRepr vect_tc repr_co pdata_tc _ r - = do arg_ty <- mkPDataType =<< mkPReprType el_ty - res_ty <- mkPDataType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - pdata_co <- mkBuiltinCo pdataTyCon - let co = mkAppCo pdata_co - $ mkUnbranchedAxInstCo Nominal repr_co var_tys [] - - let scrut = mkCast (Var arg) co - - let mk_result args - = wrapFamInstBody pdata_tc var_tys - $ mkConApp pdata_con - $ map Type var_tys ++ args - - (expr, _) <- fixV $ \ ~(_, args) -> - from_sum res_ty (mk_result args) scrut r - - return $ Lam arg expr - where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc var_tys - [pdata_con] = tyConDataCons pdata_tc - - from_sum res_ty res expr ss - = case ss of - EmptySum -> return (res, []) - UnarySum r -> from_con res_ty res expr r - Sum {} - -> do let psum_tc = repr_psum_tc ss - let [psum_con] = tyConDataCons psum_tc - sel <- newLocalVar (fsLit "sel") (repr_sel_ty ss) - ptys <- mapM mkPDataType (repr_con_tys ss) - vars <- newLocalVars (fsLit "xs") ptys - (res', args) <- fold from_con res_ty res (map Var vars) (repr_cons ss) - let scrut = unwrapFamInstScrut psum_tc (repr_con_tys ss) expr - let body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt psum_con, sel : vars, res')] - return (body, Var sel : args) - - from_prod res_ty res expr ss - = case ss of - EmptyProd -> return (res, []) - UnaryProd r -> from_comp res_ty res expr r - Prod {} - -> do let ptup_tc = repr_ptup_tc ss - let [ptup_con] = tyConDataCons ptup_tc - ptys <- mapM mkPDataType (repr_comp_tys ss) - vars <- newLocalVars (fsLit "ys") ptys - (res', args) <- fold from_comp res_ty res (map Var vars) (repr_comps ss) - 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) - - from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r - - from_comp _ res expr (Keep _ _) = return (res, [expr]) - from_comp _ res expr (Wrap ty) = do { expr' <- unwrapNewTypeBodyOfPDataWrap expr ty - ; return (res, [expr']) - } - - fold f res_ty res exprs rs - = foldrM f' (res, []) (zip exprs rs) - where - f' (expr, r) (res, args) - = do (res', args') <- f res_ty res expr r - return (res', args' ++ args) - - --- buildToArrPReprs ----------------------------------------------------------- --- | Build the 'toArrPReprs' instance for the PA class. --- This converts a PData of elements into the generic representation. -buildToArrPReprs :: PAInstanceBuilder -buildToArrPReprs vect_tc repr_co _ pdatas_tc r - = do - -- The argument type of the instance. - -- eg: 'PDatas (Tree a b)' - arg_ty <- mkPDatasType el_ty - - -- The result type. - -- eg: 'PDatas (PRepr (Tree a b))' - res_ty <- mkPDatasType =<< mkPReprType el_ty - - -- Variable to bind the argument to the instance - -- eg: (xss :: PDatas (Tree a b)) - varg <- newLocalVar (fsLit "xss") arg_ty - - -- 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 [] - - let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg) - (vars, result) <- to_sum r - - return $ Lam varg - $ mkWildCase scrut (mkTyConApp pdatas_tc ty_args) res_ty - [(DataAlt pdatas_dc, vars, mkCast result co)] - - where - -- The element type of the argument. - -- 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. - -- See Note: [Empty PDatas]. - EmptySum -> do dflags <- getDynFlags - return ([], errorEmptyPDatas dflags el_ty) - UnarySum r -> do dflags <- getDynFlags - to_con (errorEmptyPDatas dflags el_ty) r - - Sum{} - -> do let psums_tc = repr_psums_tc ss - 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 - -- and PDatas Void arrays in the product. See Note [Empty PDatas]. - let xSums = App (repr_selsLength_v ss) (Var sels) - - xSums_var <- newLocalVar (fsLit "xsum") intPrimTy - - (vars, exprs) <- mapAndUnzipM (to_con xSums_var) (repr_cons ss) - return ( sels : concat vars - , 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)) - - to_prod xSums ss - = case ss of - EmptyProd - -> do pvoids <- builtin pvoidsVar - return ([], App (Var pvoids) (Var xSums) ) - - UnaryProd r - -> do pty <- mkPDatasType (compOrigType r) - var <- newLocalVar (fsLit "x") pty - expr <- to_comp (Var var) r - return ([var], expr) - - Prod{} - -> do let [ptups_con] = tyConDataCons (repr_ptups_tc ss) - ptys <- mapM (mkPDatasType . compOrigType) (repr_comps ss) - vars <- newLocalVars (fsLit "x") ptys - exprs <- zipWithM to_comp (map Var vars) (repr_comps ss) - return ( vars - , wrapFamInstBody (repr_ptups_tc ss) (repr_comp_tys ss) - $ mkConApp ptups_con - $ map Type (repr_comp_tys ss) ++ exprs) - - to_con xSums (ConRepr _ r) - = to_prod xSums r - - to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) = wrapNewTypeBodyOfPDatasWrap expr ty - - --- buildFromArrPReprs --------------------------------------------------------- -buildFromArrPReprs :: PAInstanceBuilder -buildFromArrPReprs vect_tc repr_co _ pdatas_tc r - = do - -- The argument type of the instance. - -- eg: 'PDatas (PRepr (Tree a b))' - arg_ty <- mkPDatasType =<< mkPReprType el_ty - - -- 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 [] - - let scrut = mkCast (Var varg) co - - let mk_result args - = wrapFamInstBody pdatas_tc var_tys - $ mkConApp pdatas_con - $ map Type var_tys ++ args - - (expr, _) <- fixV $ \ ~(_, args) -> - from_sum res_ty (mk_result args) scrut r - - return $ Lam varg expr - where - -- The element type of the argument. - -- eg: 'Tree a b'. - ty_args = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc ty_args - - var_tys = mkTyVarTys $ tyConTyVars vect_tc - [pdatas_con] = tyConDataCons pdatas_tc - - from_sum res_ty res expr ss - = case ss of - -- We can't convert data types with no data. - -- See Note: [Empty PDatas]. - EmptySum -> do dflags <- getDynFlags - return (res, errorEmptyPDatas dflags el_ty) - UnarySum r -> from_con res_ty res expr r - - Sum {} - -> do let psums_tc = repr_psums_tc ss - let [psums_con] = tyConDataCons psums_tc - sel <- newLocalVar (fsLit "sels") (repr_sels_ty ss) - ptys <- mapM mkPDatasType (repr_con_tys ss) - vars <- newLocalVars (fsLit "xs") ptys - (res', args) <- fold from_con res_ty res (map Var vars) (repr_cons ss) - let scrut = unwrapFamInstScrut psums_tc (repr_con_tys ss) expr - let body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt psums_con, sel : vars, res')] - return (body, Var sel : args) - - from_prod res_ty res expr ss - = case ss of - EmptyProd -> return (res, []) - UnaryProd r -> from_comp res_ty res expr r - Prod {} - -> do let ptups_tc = repr_ptups_tc ss - let [ptups_con] = tyConDataCons ptups_tc - ptys <- mapM mkPDatasType (repr_comp_tys ss) - vars <- newLocalVars (fsLit "ys") ptys - (res', args) <- fold from_comp res_ty res (map Var vars) (repr_comps ss) - 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) - - from_con res_ty res expr (ConRepr _ r) - = from_prod res_ty res expr r - - from_comp _ res expr (Keep _ _) = return (res, [expr]) - from_comp _ res expr (Wrap ty) = do { expr' <- unwrapNewTypeBodyOfPDatasWrap expr ty - ; return (res, [expr']) - } - - fold f res_ty res exprs rs - = foldrM f' (res, []) (zip exprs rs) - where - f' (expr, r) (res, args) - = do (res', args') <- f res_ty res expr r - return (res', args' ++ args) - - --- Notes ---------------------------------------------------------------------- -{- -Note [Empty PDatas] -~~~~~~~~~~~~~~~~~~~ -We don't support "empty" data types like the following: - - data Empty0 - data Empty1 = MkEmpty1 - data Empty2 = MkEmpty2 Empty0 - ... - -There is no parallel data associcated with these types, so there is no where -to store the length of the PDatas array with our standard representation. - -Enumerations like the following are ok: - data Bool = True | False - -The native and generic representations are: - type instance (PDatas Bool) = VPDs:Bool Sels2 - type instance (PDatas (Repr Bool)) = PSum2s Sels2 (PDatas Void) (PDatas Void) - -To take the length of a (PDatas Bool) we take the length of the contained Sels2. -When converting a (PDatas Bool) to a (PDatas (Repr Bool)) we use this length to -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 -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. - -To fix this we'd need to add an Int field to VPDs:Empty1 as well, but that's -too much hassle and there's no point running a parallel computation on no -data anyway. --} -errorEmptyPDatas :: DynFlags -> Type -> a -errorEmptyPDatas dflags tc - = cantVectorise dflags "Vectorise.PAMethods" - $ vcat [ text "Cannot vectorise data type with no parallel data " <> quotes (ppr tc) - , text "Data types to be vectorised must contain at least one constructor" - , text "with at least one field." ] diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs deleted file mode 100644 index 29e6bc86ed..0000000000 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ /dev/null @@ -1,178 +0,0 @@ - --- | Build instance tycons for the PData and PDatas type families. --- --- TODO: the PData and PDatas cases are very similar. --- We should be able to factor out the common parts. -module Vectorise.Generic.PData - ( buildPDataTyCon - , buildPDatasTyCon ) -where - -import GhcPrelude - -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Generic.Description -import Vectorise.Utils -import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) - -import BasicTypes ( SourceText(..) ) -import BuildTyCl -import DataCon -import TyCon -import Type -import FamInst -import FamInstEnv -import TcMType -import Name -import Util -import MonadUtils -import Control.Monad - - --- buildPDataTyCon ------------------------------------------------------------ --- | Build the PData instance tycon for a given type constructor. -buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst -buildPDataTyCon orig_tc vect_tc repr - = fixV $ \fam_inst -> - do let repr_tc = dataFamInstRepTyCon fam_inst - name' <- mkLocalisedName mkPDataTyConOcc orig_name - rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr - pdata <- builtin pdataTyCon - buildDataFamInst name' pdata vect_tc rhs - where - orig_name = tyConName orig_tc - -buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst -buildDataFamInst name' fam_tc vect_tc rhs - = do { axiom_name <- mkDerivedName mkInstTyCoOcc name' - - ; (_, tyvars') <- liftDs $ freshenTyVarBndrs tyvars - ; 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 = mkAlgTyCon name' - (mkTyConBindersPreferAnon tyvars' liftedTypeKind) - liftedTypeKind - (map (const Nominal) tyvars') - Nothing - [] -- no stupid theta - rhs - (DataFamInstTyCon ax fam_tc pat_tys) - False -- not GADT syntax - ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } - where - tyvars = tyConTyVars vect_tc - -buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs -buildPDataTyConRhs orig_name vect_tc repr_tc repr - = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr - return $ mkDataTyConRhs [data_con] - - -buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon -buildPDataDataCon orig_name vect_tc repr_tc repr - = do let tvs = tyConTyVars vect_tc - 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 - let univ_tvbs = mkTyVarBinders Specified tvs - tag_map = mkTyConTagMap repr_tc - liftDs $ buildDataCon fam_envs dc_name - False -- not infix - rep_nm - (map (const no_bang) comp_tys) - (Just $ map (const HsLazy) comp_tys) - [] -- no field labels - tvs - [] -- no existentials - univ_tvbs - [] -- no eq spec - [] -- no context - comp_tys - (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) - repr_tc - tag_map - where - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - --- buildPDatasTyCon ----------------------------------------------------------- --- | Build the PDatas instance tycon for a given type constructor. -buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst -buildPDatasTyCon orig_tc vect_tc repr - = fixV $ \fam_inst -> - do let repr_tc = dataFamInstRepTyCon fam_inst - name' <- mkLocalisedName mkPDatasTyConOcc orig_name - rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr - pdatas <- builtin pdatasTyCon - buildDataFamInst name' pdatas vect_tc rhs - where - orig_name = tyConName orig_tc - -buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs -buildPDatasTyConRhs orig_name vect_tc repr_tc repr - = do data_con <- buildPDatasDataCon orig_name vect_tc repr_tc repr - return $ mkDataTyConRhs [data_con] - - -buildPDatasDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon -buildPDatasDataCon orig_name vect_tc repr_tc repr - = do let tvs = tyConTyVars vect_tc - dc_name <- mkLocalisedName mkPDatasDataConOcc orig_name - - comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr - fam_envs <- readGEnv global_fam_inst_env - rep_nm <- liftDs $ newTyConRepName dc_name - let univ_tvbs = mkTyVarBinders Specified tvs - tag_map = mkTyConTagMap repr_tc - liftDs $ buildDataCon fam_envs dc_name - False -- not infix - rep_nm - (map (const no_bang) comp_tys) - (Just $ map (const HsLazy) comp_tys) - [] -- no field labels - tvs - [] -- no existentials - univ_tvbs - [] -- no eq spec - [] -- no context - comp_tys - (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) - repr_tc - tag_map - where - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - --- Utils ---------------------------------------------------------------------- --- | Flatten a SumRepr into a list of data constructor types. -mkSumTys - :: (SumRepr -> Type) - -> (Type -> VM Type) - -> SumRepr - -> VM [Type] - -mkSumTys repr_selX_ty mkTc repr - = sum_tys repr - where - sum_tys EmptySum = return [] - sum_tys (UnarySum r) = con_tys r - sum_tys d@(Sum { repr_cons = cons }) - = liftM (repr_selX_ty d :) (concatMapM con_tys cons) - - con_tys (ConRepr _ r) = prod_tys r - - prod_tys EmptyProd = return [] - prod_tys (UnaryProd r) = liftM singleton (comp_ty r) - prod_tys (Prod { repr_comps = comps }) = mapM comp_ty comps - - comp_ty r = mkTc (compOrigType r) - -{- -mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) -mk_fam_inst fam_tc arg_tc - = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) --} diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs deleted file mode 100644 index bcfb8deadf..0000000000 --- a/compiler/vectorise/Vectorise/Monad.hs +++ /dev/null @@ -1,196 +0,0 @@ -module Vectorise.Monad ( - module Vectorise.Monad.Base, - module Vectorise.Monad.Naming, - module Vectorise.Monad.Local, - module Vectorise.Monad.Global, - module Vectorise.Monad.InstEnv, - initV, - - -- * Builtins - liftBuiltinDs, - builtin, - builtins, - - -- * Variables - lookupVar, - lookupVar_maybe, - addGlobalParallelVar, - addGlobalParallelTyCon, -) where - -import GhcPrelude - -import Vectorise.Monad.Base -import Vectorise.Monad.Naming -import Vectorise.Monad.Local -import Vectorise.Monad.Global -import Vectorise.Monad.InstEnv -import Vectorise.Builtins -import Vectorise.Env - -import CoreSyn -import TcRnMonad -import DsMonad -import HscTypes hiding ( MonadThings(..) ) -import DynFlags -import InstEnv -import Class -import TyCon -import NameSet -import VarSet -import VarEnv -import Var -import Id -import Name -import ErrUtils -import Outputable -import Module - -import Control.Monad (join) - --- |Run a vectorisation computation. --- -initV :: HscEnv - -> ModGuts - -> VectInfo - -> VM a - -> IO (Maybe (VectInfo, a)) -initV hsc_env guts info thing_inside - = do { dumpIfVtTrace "Incoming VectInfo" (ppr info) - - ; (_, res) <- initDsWithModGuts hsc_env guts go - ; case join res of - Nothing - -> dumpIfVtTrace "Vectorisation FAILED!" empty - Just (info', _) - -> dumpIfVtTrace "Outgoing VectInfo" (ppr info') - - ; return $ join res - } - where - 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 - = do { -- set up tables of builtin entities - ; builtins <- initBuiltins - ; builtin_vars <- initBuiltinVars builtins - - -- set up class and type family envrionments - ; eps <- liftIO $ hscEPS hsc_env - ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) - instEnvs = InstEnvs (eps_inst_env eps) - (mg_inst_env guts) - (mkModuleSet (dep_orphs (mg_deps guts))) - builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all 'PA' and.. - builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances - - -- construct the initial global environment - ; let genv = extendImportedVarsEnv builtin_vars - . setPAFunsEnv builtin_pas - . setPRFunsEnv builtin_prs - $ 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 $ - printOutputForUser dflags unqual $ - mkDumpDoc "Warning: vectorisation failure:" reason - ; return Nothing - } - } - - new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info - - -- For a given DPH class, produce a mapping from type constructor (in head position) to the - -- instance dfun for that type constructor and class. (DPH class instances cannot overlap in - -- head constructors.) - -- - initClassDicts :: InstEnvs -> Class -> [(Name, Var)] - initClassDicts insts cls = map find $ classInstances insts cls - where - find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) - | otherwise = pprPanic invalidInstance (ppr i) - - invalidInstance = "Invalid DPH instance (overlapping in head constructor)" - --- Builtins ------------------------------------------------------------------- - --- |Lift a desugaring computation using the `Builtins` into the vectorisation monad. --- -liftBuiltinDs :: (Builtins -> DsM a) -> VM a -liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)} - --- |Project something from the set of builtins. --- -builtin :: (Builtins -> a) -> VM a -builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi)) - --- |Lift a function using the `Builtins` into the vectorisation monad. --- -builtins :: (a -> Builtins -> b) -> VM (a -> b) -builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi)) - - --- Var ------------------------------------------------------------------------ - --- |Lookup the vectorised, and if local, also the lifted version of a variable. --- --- * If it's in the global environment we get the vectorised version. --- * If it's in the local environment we get both the vectorised and lifted version. --- -lookupVar :: Var -> VM (Scope Var (Var, Var)) -lookupVar v - = do { mb_res <- lookupVar_maybe v - ; case mb_res of - Just x -> return x - Nothing -> - do dflags <- getDynFlags - dumpVar dflags v - } - -lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var))) -lookupVar_maybe v - = do { r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v - ; case r of - Just e -> return $ Just (Local e) - Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v) - } - -dumpVar :: DynFlags -> Var -> a -dumpVar dflags var - | Just _ <- isClassOpId_maybe var - = cantVectorise dflags "ClassOpId not vectorised:" (ppr var) - | otherwise - = cantVectorise dflags "Variable not vectorised:" (ppr var) - - --- Global parallel entities ---------------------------------------------------- - --- |Mark the given variable as parallel — i.e., executing the associated code might involve --- parallel array computations. --- -addGlobalParallelVar :: Var -> VM () -addGlobalParallelVar var - = do { traceVt "addGlobalParallelVar" (ppr var) - ; updGEnv $ \env -> env{global_parallel_vars = extendDVarSet (global_parallel_vars env) var} - } - --- |Mark the given type constructor as parallel — i.e., its values might embed parallel arrays. --- -addGlobalParallelTyCon :: TyCon -> VM () -addGlobalParallelTyCon tycon - = do { traceVt "addGlobalParallelTyCon" (ppr tycon) - ; 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 deleted file mode 100644 index eb648710a9..0000000000 --- a/compiler/vectorise/Vectorise/Monad/Base.hs +++ /dev/null @@ -1,245 +0,0 @@ --- |The Vectorisation monad. - -module Vectorise.Monad.Base ( - -- * The Vectorisation Monad - VResult(..), - VM(..), - - -- * Lifting - liftDs, - - -- * Error Handling - cantVectorise, - maybeCantVectorise, - maybeCantVectoriseM, - - -- * Debugging - emitVt, traceVt, dumpOptVt, dumpVt, - - -- * Control - noV, traceNoV, - ensureV, traceEnsureV, - onlyIfV, - tryV, tryErrV, - maybeV, traceMaybeV, - orElseV, orElseErrV, - fixV, -) where - -import GhcPrelude - -import Vectorise.Builtins -import Vectorise.Env - -import DsMonad -import TcRnMonad -import ErrUtils -import Outputable -import DynFlags - -import Control.Monad - - --- The Vectorisation 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 - | No SDoc - -newtype VM a - = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) } - -instance Monad VM where - VM p >>= f = VM $ \bi genv lenv -> do - r <- p bi genv lenv - case r of - Yes genv' lenv' x -> runVM (f x) bi genv' lenv' - No reason -> return $ No reason - -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 - -instance HasDynFlags VM where - getDynFlags = liftDs getDynFlags - --- Lifting -------------------------------------------------------------------- - --- |Lift a desugaring computation into the vectorisation monad. --- -liftDs :: DsM a -> VM a -liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) } - - --- Error Handling ------------------------------------------------------------- - --- |Throw a `pgmError` saying we can't vectorise something. --- -cantVectorise :: DynFlags -> String -> SDoc -> a -cantVectorise dflags s d = pgmError - . showSDoc dflags - $ vcat [text "*** Vectorisation error ***", - nest 4 $ sep [text s, nest 4 d]] - --- |Like `fromJust`, but `pgmError` on Nothing. --- -maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a -maybeCantVectorise dflags s d Nothing = cantVectorise dflags s d -maybeCantVectorise _ _ _ (Just x) = x - --- |Like `maybeCantVectorise` but in a `Monad`. --- -maybeCantVectoriseM :: (Monad m, HasDynFlags m) - => String -> SDoc -> m (Maybe a) -> m a -maybeCantVectoriseM s d p - = do - r <- p - case r of - Just x -> return x - Nothing -> - do dflags <- getDynFlags - cantVectorise dflags s d - - --- Debugging ------------------------------------------------------------------ - --- |Output a trace message if -ddump-vt-trace is active. --- -emitVt :: String -> SDoc -> VM () -emitVt herald doc - = liftDs $ do - dflags <- getDynFlags - liftIO . printOutputForUser dflags alwaysQualify $ - hang (text herald) 2 doc - --- |Output a trace message if -ddump-vt-trace is active. --- -traceVt :: String -> SDoc -> VM () -traceVt herald doc - = liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc - --- |Dump the given program conditionally. --- -dumpOptVt :: DumpFlag -> String -> SDoc -> VM () -dumpOptVt flag header doc - = do { b <- liftDs $ doptM flag - ; if b - then dumpVt header doc - else return () - } - --- |Dump the given program unconditionally. --- -dumpVt :: String -> SDoc -> VM () -dumpVt header doc - = do { unqual <- liftDs mkPrintUnqualifiedDs - ; dflags <- liftDs getDynFlags - ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc) - } - - --- Control -------------------------------------------------------------------- - --- |Return some result saying we've failed. --- -noV :: SDoc -> VM a -noV reason = VM $ \_ _ _ -> return $ No reason - --- |Like `traceNoV` but also emit some trace message to stderr. --- -traceNoV :: String -> SDoc -> VM a -traceNoV s d = pprTrace s d $ noV d - --- |If `True` then carry on, otherwise fail. --- -ensureV :: SDoc -> Bool -> VM () -ensureV reason False = noV reason -ensureV _reason True = return () - --- |Like `ensureV` but if we fail then emit some trace message to stderr. --- -traceEnsureV :: String -> SDoc -> Bool -> VM () -traceEnsureV s d False = traceNoV s d -traceEnsureV _ _ True = return () - --- |If `True` then return the first argument, otherwise fail. --- -onlyIfV :: SDoc -> Bool -> VM a -> VM a -onlyIfV reason b p = ensureV reason b >> p - --- |Try some vectorisation computaton. --- --- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a --- failure message. --- -tryErrV :: VM a -> VM (Maybe a) -tryErrV (VM p) = VM $ \bi genv lenv -> - do - r <- p bi genv lenv - case r of - Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) - No reason -> do { unqual <- mkPrintUnqualifiedDs - ; dflags <- getDynFlags - ; liftIO $ - printInfoForUser dflags unqual $ - text "Warning: vectorisation failure:" <+> reason - ; return (Yes genv lenv Nothing) - } - --- |Try some vectorisation computaton. --- --- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a --- failure message. --- -tryV :: VM a -> VM (Maybe a) -tryV (VM p) = VM $ \bi genv lenv -> - do - r <- p bi genv lenv - case r of - Yes genv' lenv' x -> return (Yes genv' lenv' (Just x)) - No _reason -> return (Yes genv lenv Nothing) - --- |If `Just` then return the value, otherwise fail. --- -maybeV :: SDoc -> VM (Maybe a) -> VM a -maybeV reason p = maybe (noV reason) return =<< p - --- |Like `maybeV` but emit a message to stderr if we fail. --- -traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a -traceMaybeV s d p = maybe (traceNoV s d) return =<< p - --- |Try the first computation, --- --- * if it succeeds then take the returned value, --- * if it fails then run the second computation instead while emitting a failure message. --- -orElseErrV :: VM a -> VM a -> VM a -orElseErrV p q = maybe q return =<< tryErrV p - --- |Try the first computation, --- --- * if it succeeds then take the returned value, --- * if it fails then run the second computation instead without emitting a failure message. --- -orElseV :: VM a -> VM a -> VM a -orElseV p q = maybe q return =<< tryV p - --- |Fixpoint in the vectorisation monad. --- -fixV :: (a -> VM a) -> VM a -fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv ) - where - -- NOTE: It is essential that we are lazy in r above so do not replace - -- calls to this function by an explicit case. - unYes (Yes _ _ x) = x - unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs deleted file mode 100644 index 9abeb59dcb..0000000000 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ /dev/null @@ -1,239 +0,0 @@ --- Operations on the global state of the vectorisation monad. - -module Vectorise.Monad.Global ( - readGEnv, - setGEnv, - updGEnv, - - -- * Configuration - isVectAvoidanceAggressive, - - -- * Vars - defGlobalVar, undefGlobalVar, - - -- * Vectorisation declarations - lookupVectDecl, - - -- * Scalars - globalParallelVars, globalParallelTyCons, - - -- * TyCons - lookupTyCon, - defTyConName, defTyCon, globalVectTyCons, - - -- * Datacons - lookupDataCon, - defDataCon, - - -- * PA Dictionaries - lookupTyConPA, - defTyConPAs, - - -- * PR Dictionaries - lookupTyConPR -) where - -import GhcPrelude - -import Vectorise.Monad.Base -import Vectorise.Env - -import CoreSyn -import Type -import TyCon -import DataCon -import DynFlags -import NameEnv -import NameSet -import Name -import VarEnv -import VarSet -import Var as Var -import Outputable - - --- Global Environment --------------------------------------------------------- - --- |Project something from the global environment. --- -readGEnv :: (GlobalEnv -> a) -> VM a -readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv)) - --- |Set the value of the global environment. --- -setGEnv :: GlobalEnv -> VM () -setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ()) - --- |Update the global environment using the provided function. --- -updGEnv :: (GlobalEnv -> GlobalEnv) -> VM () -updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ()) - - --- Configuration -------------------------------------------------------------- - --- |Should we avoid as much vectorisation as possible? --- --- Set by '-f[no]-vectorisation-avoidance' --- -isVectAvoidanceAggressive :: VM Bool -isVectAvoidanceAggressive = readGEnv global_vect_avoid - - --- Vars ----------------------------------------------------------------------- - --- |Add a mapping between a global var and its vectorised version to the state. --- -defGlobalVar :: Var -> Var -> VM () -defGlobalVar v v' - = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') - - -- check for duplicate vectorisation - ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v - ; case currentDef of - Just old_v' -> - do dflags <- getDynFlags - cantVectorise dflags "Variable is already vectorised:" $ - ppr v <+> moduleOf v old_v' - Nothing -> return () - - ; updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' } - } - where - moduleOf var var' | var == var' - = text "vectorises to itself" - | Just mod <- nameModule_maybe (Var.varName var') - = text "in module" <+> ppr mod - | otherwise - = text "in the current module" - --- |Remove the mapping of a variable in the vectorisation map. --- -undefGlobalVar :: Var -> VM () -undefGlobalVar v - = do - { traceVt "REMOVING global var mapping:" (ppr v) - ; updGEnv $ \env -> env { global_vars = delVarEnv (global_vars env) v } - } - - --- Vectorisation declarations ------------------------------------------------- - --- |Check whether a variable has a vectorisation declaration. --- --- The first component of the result indicates whether the variable has a 'NOVECTORISE' declaration. --- 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 -> - case lookupVarEnv (global_vect_decls env) var of - Nothing -> (False, Nothing) - Just Nothing -> (True, Nothing) - Just vectDecl -> (False, vectDecl) - - --- Parallel entities ----------------------------------------------------------- - --- |Get the set of global parallel variables. --- -globalParallelVars :: VM DVarSet -globalParallelVars = readGEnv global_parallel_vars - --- |Get the set of all parallel type constructors (those that may embed parallelism) including both --- both those parallel type constructors declared in an imported module and those declared in the --- current module. --- -globalParallelTyCons :: VM NameSet -globalParallelTyCons = readGEnv global_parallel_tycons - - --- TyCons --------------------------------------------------------------------- - --- |Determine the vectorised version of a `TyCon`. The vectorisation map in the global environment --- contains a vectorised version if the original `TyCon` embeds any parallel arrays. --- -lookupTyCon :: TyCon -> VM (Maybe TyCon) -lookupTyCon tc - = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) - --- |Add a mapping between plain and vectorised `TyCon`s to the global environment. --- --- The second argument is only to enable tracing for (mutually) recursively defined type --- constructors, where we /must not/ pull at the vectorised type constructors (because that would --- pull too early at the recursive knot). --- -defTyConName :: TyCon -> Name -> TyCon -> VM () -defTyConName tc nameOfTc' tc' - = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc') - - -- check for duplicate vectorisation - ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) - ; case currentDef of - Just old_tc' -> - do dflags <- getDynFlags - cantVectorise dflags "Type constructor or class is already vectorised:" $ - ppr tc <+> moduleOf tc old_tc' - Nothing -> return () - - ; updGEnv $ \env -> - env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' } - } - where - moduleOf tc tc' | tc == tc' - = text "vectorises to itself" - | Just mod <- nameModule_maybe (tyConName tc') - = text "in module" <+> ppr mod - | otherwise - = text "in the current module" - --- |Add a mapping between plain and vectorised `TyCon`s to the global environment. --- -defTyCon :: TyCon -> TyCon -> VM () -defTyCon tc tc' = defTyConName tc (tyConName tc') tc' - --- |Get the set of all vectorised type constructors. --- -globalVectTyCons :: VM (NameEnv TyCon) -globalVectTyCons = readGEnv global_tycons - - --- DataCons ------------------------------------------------------------------- - --- |Lookup the vectorised version of a `DataCon` from the global environment. --- -lookupDataCon :: DataCon -> VM (Maybe DataCon) -lookupDataCon dc - | isTupleTyCon (dataConTyCon dc) - = return (Just dc) - | otherwise - = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc) - --- |Add the mapping between plain and vectorised `DataCon`s to the global environment. --- -defDataCon :: DataCon -> DataCon -> VM () -defDataCon dc dc' = updGEnv $ \env -> - env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' } - - --- 'PA' dictionaries ------------------------------------------------------------ - --- |Lookup the 'PA' dfun of a vectorised type constructor in the global environment. --- -lookupTyConPA :: TyCon -> VM (Maybe Var) -lookupTyConPA tc - = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc) - --- |Associate vectorised type constructors with the dfun of their 'PA' instances in the global --- environment. --- -defTyConPAs :: [(TyCon, Var)] -> VM () -defTyConPAs ps = updGEnv $ \env -> - env { global_pa_funs = extendNameEnvList (global_pa_funs env) - [(tyConName tc, pa) | (tc, pa) <- ps] } - - --- PR Dictionaries ------------------------------------------------------------ - -lookupTyConPR :: TyCon -> VM (Maybe Var) -lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc) diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs deleted file mode 100644 index 68d70a46b6..0000000000 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Vectorise.Monad.InstEnv - ( existsInst - , lookupInst - , lookupFamInst - ) -where - -import GhcPrelude - -import Vectorise.Monad.Global -import Vectorise.Monad.Base -import Vectorise.Env - -import DynFlags -import FamInstEnv -import InstEnv -import Class -import Type -import TyCon -import Outputable -import Util - - -#include "HsVersions.h" - - --- Check whether a unique class instance for a given class and type arguments exists. --- -existsInst :: Class -> [Type] -> VM Bool -existsInst cls tys - = do { instEnv <- readGEnv global_inst_env - ; return $ either (const False) (const True) (lookupUniqueInstEnv instEnv 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 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, --- see the docs at InstEnv.lookupInstEnv. --- -lookupInst :: Class -> [Type] -> VM (DFunId, [Type]) -lookupInst cls tys - = do { instEnv <- readGEnv global_inst_env - ; case lookupUniqueInstEnv instEnv cls tys of - Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys) - Left err -> - do dflags <- getDynFlags - cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err - } - --- 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 family instance declaration. --- --- Return the family instance and its type instance. For example, if we have --- --- lookupFamInst 'T' '[Int]' yields (':R42T', 'Int') --- --- then we have a coercion (ie, type instance of family instance coercion) --- --- :Co:R42T Int :: T [Int] ~ :R42T Int --- --- which implies that :R42T was declared as 'data instance T [a]'. --- -lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch -lookupFamInst tycon tys - = ASSERT( isOpenFamilyTyCon tycon ) - do { instEnv <- readGEnv global_fam_inst_env - ; case lookupFamInstEnv instEnv tycon tys of - [match] -> return match - _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 deleted file mode 100644 index 1f0da7ebd2..0000000000 --- a/compiler/vectorise/Vectorise/Monad/Local.hs +++ /dev/null @@ -1,102 +0,0 @@ -module Vectorise.Monad.Local - ( readLEnv - , setLEnv - , updLEnv - , localV - , closedV - , getBindName - , inBind - , lookupTyVarPA - , defLocalTyVar - , defLocalTyVarWithPA - , localTyVars - ) -where - -import GhcPrelude - -import Vectorise.Monad.Base -import Vectorise.Env - -import CoreSyn -import Name -import VarEnv -import Var -import FastString - --- Local Environment ---------------------------------------------------------- - --- |Project something from the local environment. --- -readLEnv :: (LocalEnv -> a) -> VM a -readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv)) - --- |Set the local environment. --- -setLEnv :: LocalEnv -> VM () -setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ()) - --- |Update the environment using the provided function. --- -updLEnv :: (LocalEnv -> LocalEnv) -> VM () -updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ()) - --- |Perform a computation in its own local environment. --- This does not alter the environment of the current state. --- -localV :: VM a -> VM a -localV p - = do - { env <- readLEnv id - ; x <- p - ; setLEnv env - ; return x - } - --- |Perform a computation in an empty local environment. --- -closedV :: VM a -> VM a -closedV p - = do - { env <- readLEnv id - ; setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env }) - ; x <- p - ; setLEnv env - ; return x - } - --- |Get the name of the local binding currently being vectorised. --- -getBindName :: VM FastString -getBindName = readLEnv local_bind_name - --- |Run a vectorisation computation in a local environment, --- with this id set as the current binding. --- -inBind :: Id -> VM a -> VM a -inBind id p - = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) } - p - --- |Lookup a PA tyvars from the local environment. -lookupTyVarPA :: Var -> VM (Maybe CoreExpr) -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 - , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv - } - --- |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 - , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa - } - --- |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 deleted file mode 100644 index b1a8cb4092..0000000000 --- a/compiler/vectorise/Vectorise/Monad/Naming.hs +++ /dev/null @@ -1,132 +0,0 @@ --- |Computations in the vectorisation monad concerned with naming and fresh variable generation. - -module Vectorise.Monad.Naming - ( mkLocalisedName - , mkDerivedName - , mkVectId - , cloneVar - , newExportedVar - , newLocalVar - , newLocalVars - , newDummyVar - , newTyVar - , newCoVar - ) -where - -import GhcPrelude - -import Vectorise.Monad.Base - -import DsMonad -import TcType -import Type -import Var -import Module -import Name -import SrcLoc -import MkId -import Id -import IdInfo( IdDetails(VanillaId) ) -import FastString - -import Control.Monad - - --- Naming --------------------------------------------------------------------- - --- |Create a localised variant of a name, using the provided function to transform its `OccName`. --- --- If the name external, encode the original name's module into the new 'OccName'. The result is --- always an internal system name. --- -mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name -mkLocalisedName mk_occ name - = do { mod <- liftDs getModule - ; u <- liftDs newUnique - ; let occ_name = mkLocalisedOccName mod mk_occ name - - new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name) - | otherwise = mkSystemName u occ_name - - ; return new_name } - -mkDerivedName :: (OccName -> OccName) -> Name -> VM Name --- Similar to mkLocalisedName, but assumes the --- incoming name is from this module. --- Works on External names only -mkDerivedName mk_occ name - = do { u <- liftDs newUnique - ; return (mkExternalName u (nameModule name) - (mk_occ (nameOccName name)) - (nameSrcSpan name)) } - --- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that --- vectorised dfun ids must be dfuns again. --- --- Force the new name to be a system name and, if the original was an external name, disambiguate --- the new name with the module name of the original. --- -mkVectId :: Id -> Type -> VM Id -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.mkLocalIdOrCoVar name ty - ; return id' - } - where - -- Decompose a dictionary function signature: \forall tvs. theta -> cls tys - -- NB: We do *not* use closures '(:->)' for vectorised predicate abstraction as dictionary - -- functions are always fully applied. - (tvs, theta, pty) = tcSplitSigmaTy ty - (cls, tys) = tcSplitDFunHead pty - --- |Make a fresh instance of this var, with a new unique. --- -cloneVar :: Var -> VM Var -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 - = do mod <- liftDs getModule - u <- liftDs newUnique - - let name = mkExternalName u mod occ_name noSrcSpan - - return $ Id.mkExportedLocalId VanillaId name ty - --- |Make a fresh local variable with the given type. --- The variable's name is formed using the given string as the prefix. --- -newLocalVar :: FastString -> Type -> VM Var -newLocalVar fs ty - = do u <- liftDs newUnique - 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. --- -newLocalVars :: FastString -> [Type] -> VM [Var] -newLocalVars fs = mapM (newLocalVar fs) - --- |Make a new local dummy variable. --- -newDummyVar :: Type -> VM Var -newDummyVar = newLocalVar (fsLit "vv") - --- |Make a fresh type variable with the given kind. --- The variable's name is formed using the given string as the prefix. --- -newTyVar :: FastString -> Kind -> VM Var -newTyVar fs k - = do u <- liftDs newUnique - return $ mkTyVar (mkSysTvName u fs) k - --- |Make 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 deleted file mode 100644 index 5532c40ee1..0000000000 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ /dev/null @@ -1,131 +0,0 @@ --- Extract from a list of type constructors those (1) which need to be vectorised and (2) those --- that could be, but need not be vectorised (as a scalar representation is sufficient and more --- efficient). The type constructors that cannot be vectorised will be dropped. --- --- A type constructor will only be vectorised if it is --- --- (1) a data type constructor, with vanilla data constructors (i.e., data constructors admitted by --- Haskell 98) and --- (2) at least one of the type constructors that appears in its definition is also vectorised. --- --- If (1) is met, but not (2), the type constructor may appear in vectorised code, but there is no --- need to vectorise that type constructor itself. This holds, for example, for all enumeration --- types. As '([::])' is being vectorised, any type constructor whose definition involves --- '([::])', either directly or indirectly, will be vectorised. - -module Vectorise.Type.Classify - ( classifyTyCons - ) -where - -import GhcPrelude - -import NameSet -import UniqSet -import UniqFM -import DataCon -import TyCon -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 --- because they use language extensions or because they dependent on type constructors for which --- no vectorised version is available). --- --- NB: In order to be able to vectorise a type constructor, we require members of the depending set --- (i.e., those type constructors that the current one depends on) to be vectorised only if they --- are also parallel (i.e., appear in the second argument to the function). --- --- The first argument determines the /conversion status/ of external type constructors as follows: --- --- * tycons which have converted versions are mapped to 'True' --- * tycons which are not changed by vectorisation are mapped to 'False' --- * tycons which haven't been converted (because they can't or weren't vectorised) are not --- elements of the map --- -classifyTyCons :: UniqFM Bool -- ^type constructor vectorisation status - -> NameSet -- ^tycons involving parallel arrays - -> [TyCon] -- ^type constructors that need to be classified - -> ( [TyCon] -- to be converted - , [TyCon] -- need not be converted (but could be) - , [TyCon] -- involve parallel arrays (whether converted or not) - , [TyCon] -- can't be converted - ) -classifyTyCons convStatus parTyCons tcs = classify [] [] [] [] convStatus parTyCons (tyConGroups tcs) - where - classify conv keep par novect _ _ [] = (conv, keep, par, novect) - classify conv keep par novect cs pts ((tcs, ds) : rs) - | can_convert && must_convert - = classify (tcs ++ conv) keep (par ++ tcs_par) novect (cs `addListToUFM` [(tc, True) | tc <- tcs]) pts' rs - | can_convert - = classify conv (tcs ++ keep) (par ++ tcs_par) novect (cs `addListToUFM` [(tc, False) | tc <- tcs]) pts' rs - | otherwise - = 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 | uniqSetAny ((`elemNameSet` parTyCons) . tyConName) refs = tcs - | otherwise = [] - - pts' = pts `extendNameSetList` map tyConName tcs_par - - can_convert = (isEmptyUniqSet (filterUniqSet ((`elemNameSet` pts) . tyConName) (refs `uniqSetMinusUFM` cs)) - && all convertable tcs) - || isShowClass tcs - must_convert = anyUFM id (intersectUFM_C const cs (getUniqSet refs)) - && (not . isShowClass $ tcs) - - -- We currently admit Haskell 2011-style data and newtype declarations as well as type - -- constructors representing classes. - 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 - isShowClass _ = False - --- Used to group type constructors into mutually dependent groups. --- -type TyConGroup = ([TyCon], UniqSet TyCon) - --- Compute mutually recursive groups of tycons in topological order. --- -tyConGroups :: [TyCon] -> [TyConGroup] -tyConGroups tcs = map mk_grp (stronglyConnCompFromEdgedVerticesUniq edges) - where - edges :: [ Node TyCon (TyCon, UniqSet TyCon) ] - edges = [DigraphNode (tc, ds) tc (nonDetEltsUniqSet ds) | tc <- tcs - , let ds = tyConsOfTyCon tc] - -- It's OK to use nonDetEltsUniqSet here as - -- stronglyConnCompFromEdgedVertices is still deterministic even - -- if the edges are in nondeterministic order as explained in - -- Note [Deterministic SCC] in Digraph. - - mk_grp (AcyclicSCC (tc, ds)) = ([tc], ds) - mk_grp (CyclicSCC els) = (tcs, unionManyUniqSets dss) - where - (tcs, dss) = unzip els - --- |Collect the set of TyCons used by the representation of some data type. --- -tyConsOfTyCon :: TyCon -> UniqSet TyCon -tyConsOfTyCon = tyConsOfTypes . concatMap dataConRepArgTys . tyConDataCons - --- |Collect the set of TyCons that occur in these types. --- -tyConsOfTypes :: [Type] -> UniqSet TyCon -tyConsOfTypes = unionManyUniqSets . map tyConsOfType - --- |Collect the set of TyCons that occur in this type. --- -tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty = filterUniqSet not_tuple_or_unlifted $ Type.tyConsOfType ty - where not_tuple_or_unlifted tc = not (isUnliftedTyCon tc || isTupleTyCon tc) - diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs deleted file mode 100644 index a70e166aa2..0000000000 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ /dev/null @@ -1,457 +0,0 @@ -{-# LANGUAGE CPP #-} - --- Vectorise a modules type and class declarations. --- --- 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 ( - vectTypeEnv, -) where - -#include "HsVersions.h" - -import GhcPrelude - -import Vectorise.Env -import Vectorise.Vect -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Type.TyConDecl -import Vectorise.Type.Classify -import Vectorise.Generic.PADict -import Vectorise.Generic.PAMethods -import Vectorise.Generic.PData -import Vectorise.Generic.Description -import Vectorise.Utils - -import CoreSyn -import CoreUtils -import CoreUnfold -import DataCon -import TyCon -import CoAxiom -import Type -import FamInstEnv -import Id -import MkId -import NameEnv -import NameSet -import UniqFM -import OccName -import Unique - -import Util -import Outputable -import DynFlags -import FastString -import MonadUtils - -import Control.Monad -import Data.Maybe -import Data.List - - --- Note [Pragmas to vectorise tycons] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- All imported type constructors that are not mapped to a vectorised type in the vectorisation map --- (possibly because the defining module was not compiled with vectorisation) may be used in scalar --- code encapsulated in vectorised code. If a such a type constructor 'T' is a member of the --- 'Scalar' class (and hence also of 'PData' and 'PRepr'), it may also be used in vectorised code, --- where 'T' represents itself, but the representation of 'T' still remains opaque in vectorised --- code (i.e., it can only be used in scalar code). --- --- An example is the treatment of 'Int'. 'Int's can be used in vectorised code and remain unchanged --- by vectorisation. However, the representation of 'Int' by the 'I#' data constructor wrapping an --- 'Int#' is not exposed in vectorised code. Instead, computations involving the representation need --- to be confined to scalar code. --- --- VECTORISE pragmas for type constructors cover four different flavours of vectorising data type --- constructors: --- --- (1) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised --- code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types --- declared in a vectorised module. This includes the case where the vectoriser determines that --- the original representation of 'T' may be used in vectorised code (as it does not embed any --- parallel arrays.) This case is for type constructors that are *imported* from a non- --- vectorised module, but that we want to use with full vectorisation support. --- --- An example is the treatment of 'Ordering' and '[]'. The former remains unchanged by --- vectorisation, whereas the latter is fully vectorised. --- --- 'PData' and 'PRepr' instances are automatically generated by the vectoriser. --- --- Type constructors declared with {-# VECTORISE type T #-} are treated in this manner. --- --- (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). --- --- 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 --- code. Instead, computations involving the representation need to be confined to scalar code. --- --- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated --- by the vectoriser). --- --- Type constructors declared with {-# VECTORISE type T = Tv #-} are treated in this manner --- manner. (The vectoriser never treats a type constructor automatically in this manner.) --- --- (3) Data type constructor 'T' that does not contain any parallel arrays and has explicitly --- provided 'PData' and 'PRepr' instances (and maybe also a 'Scalar' instance), which together --- with the type's constructors 'Cn' may be used in vectorised code. The type 'T' and its --- constructors 'Cn' are represented by themselves in vectorised code. --- --- An example is 'Bool', which is represented by itself in vectorised code (as it cannot embed --- any parallel arrays). However, we do not want any automatic generation of class and family --- instances, which is why Case (1) does not apply. --- --- '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 #-} are treated in this manner. --- --- (4) Data type constructor 'T' that does not contain any parallel arrays and that, in vectorised --- code, is represented by an explicitly given 'Tv', but the representation of 'T' is opaque in --- vectorised code and 'T' is regarded to be scalar — i.e., it may be used in encapsulated --- scalar subcomputations. --- --- An example is the treatment of '(->)'. Types '(->)' can be used in vectorised code and are --- vectorised to '(:->)'. However, the representation of '(->)' is not exposed in vectorised --- code. Instead, computations involving the representation need to be confined to scalar code --- and may be part of encapsulated scalar computations. --- --- '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 --- 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 #-}. --- It implies that the class type constructor may be used in vectorised code together with its data --- constructor. We generally produce a vectorised version of the data type and data constructor. --- We do not generate 'PData' and 'PRepr' instances for class type constructors. This pragma is the --- default for all type classes declared in a vectorised module, but the pragma can also be used --- explitly on imported classes. - --- Note [Vectorising classes] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We vectorise classes essentially by just vectorising their desugared Core representation, but we --- do generate a 'Class' structure along the way (see 'Vectorise.Type.TyConDecl.vectTyConDecl'). --- --- Here is an example illustrating the mapping — assume --- --- class Num a where --- (+) :: a -> a -> a --- --- It desugars to --- --- data Num a = D:Num { (+) :: a -> a -> a } --- --- which we vectorise to --- --- data V:Num a = D:V:Num { ($v+) :: PArray a :-> PArray a :-> PArray a } --- --- while adding the following entries to the vectorisation map: --- --- tycon : Num --> V:Num --- datacon: D:Num --> D:V:Num --- var : (+) --> ($v+) - --- |Vectorise type constructor including class type constructors. --- -vectTypeEnv :: [TyCon] -- Type constructors defined in this module - -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module - -> [CoreVect] -- All 'VECTORISE class' declarations in this module - -> VM ( [TyCon] -- old TyCons ++ new TyCons - , [FamInst] -- New type family instances. - , [(Var, CoreExpr)]) -- New top level bindings. -vectTypeEnv tycons vectTypeDecls vectClassDecls - = do { traceVt "** vectTypeEnv" $ ppr tycons - - ; let -- {-# VECTORISE type T -#} (ONLY the imported tycons) - 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) - | 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 ++ - map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS) - notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames - - -- Build a map containing all vectorised type constructor. If the vectorised type - -- constructor differs from the original one, then it is mapped to 'True'; if they are - -- both the same, then it maps to 'False'. - ; 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) - | (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 - -- type constructors or use non-Haskell98 features are being dropped. They may not - -- appear in vectorised code. (We also drop the local type constructors appearing in a - -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as - -- these are being handled separately. NB: Some type constructors may be marked SCALAR - -- /and/ have an explicit right-hand side.) - -- - -- Furthermore, 'par_tcs' are those type constructors (converted or not) whose - -- definition, directly or indirectly, depends on parallel arrays. Finally, 'drop_tcs' - -- are all type constructors that cannot be vectorised. - ; parallelTyCons <- (`extendNameSetList` map (tyConName . fst) vectTyConsWithRHS) <$> - globalParallelTyCons - ; let maybeVectoriseTyCons = filter notVectSpecialTyCon tycons ++ impVectTyCons - (conv_tcs, keep_tcs, par_tcs, drop_tcs) - = classifyTyCons vectTyConFlavour parallelTyCons maybeVectoriseTyCons - - ; traceVt " known parallel : " $ ppr parallelTyCons - ; traceVt " VECT SCALAR : " $ ppr (scalarTyConsNoRHS ++ map fst scalarTyConsWithRHS) - ; traceVt " VECT [class] : " $ ppr impVectTyCons - ; traceVt " VECT with rhs : " $ ppr (map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS)) - ; 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 = text "(They use unsupported language extensions" - $$ text "or depend on type constructors that are" <+> - text "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:" $ - pprQuotedList drop_tcs_nosyn $$ explanation - - ; mapM_ addParallelTyConAndCons $ par_tcs ++ map fst vectTyConsWithRHS - - ; 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 - -- abstract. - [(tycon, tycon, False) | tycon <- keep_tcs ++ scalarTyConsNoRHS] - -- We do the same for type constructors declared VECTORISE SCALAR /without/ - -- an explicit right-hand side - ++ [(tycon, vTycon, True) | (tycon, vTycon) <- vectTyConsWithRHS ++ scalarTyConsWithRHS] - ; syn_tcs <- catMaybes <$> mapM defTyConDataCons mapping - - -- 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 - | otherwise = panic "dataConSig" - ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs) - - -- We don't need new representation types for dictionary constructors. The constructors - -- are always fully applied, and we don't need to lift them to arrays as a dictionary - -- of a particular type always has the same value. - ; let orig_tcs = filter (not . isClassTyCon) $ keep_tcs ++ conv_tcs - vect_tcs = filter (not . isClassTyCon) $ keep_tcs ++ new_tcs - - -- Build 'PRepr' and 'PData' instance type constructors and family instances for all - -- type constructors with vectorised representations. - ; reprs <- mapM tyConRepr vect_tcs - ; repr_fis <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs - ; pdata_fis <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs - ; pdatas_fis <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs - - ; let fam_insts = repr_fis ++ pdata_fis ++ pdatas_fis - 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 - -- the vectorised type constructors, and associate the type constructors with their dfuns - -- in the global environment. We get back the dfun bindings (which we will subsequently - -- inject into the modules toplevel). - ; (_, binds) <- fixV $ \ ~(dfuns, _) -> - do { defTyConPAs (zipLazy vect_tcs dfuns) - - -- Query the 'PData' instance type constructors for type constructors that have a - -- VECTORISE SCALAR type pragma without an explicit right-hand side (this is Item - -- (3) of "Note [Pragmas to vectorise tycons]" above). - ; pdata_scalar_tcs <- mapM pdataReprTyConExact scalarTyConsNoRHS - - -- Build workers for all vectorised data constructors (except abstract ones) - ; sequence_ $ - zipWith3 vectDataConWorkers (orig_tcs ++ scalarTyConsNoRHS) - (vect_tcs ++ scalarTyConsNoRHS) - (pdata_tcs ++ pdata_scalar_tcs) - - -- Build a 'PA' dictionary for all type constructors (except abstract ones & those - -- defined with an explicit right-hand side where the dictionary is user-supplied) - ; dfuns <- sequence $ - zipWith4 buildTyConPADict - vect_tcs - repr_axs - pdata_tcs - pdatas_tcs - - ; binds <- takeHoisted - ; return (dfuns, binds) - } - - -- Return the vectorised variants of type constructors as well as the generated instance - -- type constructors, family instances, and dfun bindings. - ; return ( new_tcs ++ pdata_tcs ++ pdatas_tcs ++ syn_tcs - , fam_insts, binds) - } - where - addParallelTyConAndCons tycon - = do - { addGlobalParallelTyCon tycon - ; mapM_ addGlobalParallelVar [ id | dc <- tyConDataCons tycon - , AnId id <- dataConImplicitTyThings dc ] - -- Ignoring the promoted tycon; hope that's ok - } - - -- Add a mapping from the original to vectorised type constructor to the vectorisation map. - -- Unless the type constructor is abstract, also mappings from the original's data constructors - -- to the vectorised type's data constructors. - -- - -- We have three cases: (1) original and vectorised type constructor are the same, (2) the - -- name of the vectorised type constructor is canonical (as prescribed by 'mkVectTyConOcc'), or - -- (3) the name is not canonical. In the third case, we additionally introduce a type synonym - -- with the canonical name that is set equal to the non-canonical name (so that we find the - -- right type constructor when reading vectorisation information from interface files). - -- - defTyConDataCons (origTyCon, vectTyCon, isAbstract) - = do - { canonName <- mkLocalisedName mkVectTyConOcc origName - ; if origName == vectName -- Case (1) - || vectName == canonName -- Case (2) - then do - { defTyCon origTyCon vectTyCon -- T --> vT - ; defDataCons -- Ci --> vCi - ; return Nothing - } - else do -- Case (3) - { let synTyCon = mkSyn canonName (mkTyConTy vectTyCon) -- type S = vT - ; defTyCon origTyCon synTyCon -- T --> S - ; defDataCons -- Ci --> vCi - ; return $ Just synTyCon - } - } - where - origName = tyConName origTyCon - vectName = tyConName vectTyCon - - mkSyn canonName ty = buildSynTyCon canonName [] (typeKind ty) [] ty - - defDataCons - | isAbstract = return () - | otherwise - = do { MASSERT(tyConDataCons origTyCon `equalLength` tyConDataCons vectTyCon) - ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon) - } - - --- Helpers -------------------------------------------------------------------- - -buildTyConPADict :: TyCon -> CoAxiom Unbranched -> TyCon -> TyCon -> VM Var -buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc - = tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc - --- Produce a custom-made worker for the data constructors of a vectorised data type. This includes --- all data constructors that may be used in vectorised code — i.e., all data constructors of data --- types with 'VECTORISE [SCALAR] type' pragmas with an explicit right-hand side. Also adds a mapping --- from the original to vectorised worker into the vectorisation map. --- --- FIXME: It's not nice that we need create a special worker after the data constructors has --- already been constructed. Also, I don't think the worker is properly added to the data --- constructor. Seems messy. -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) - rep_tys - (inits rep_tys) - (tail $ tails rep_tys) - ; mapM_ (uncurry hoistBinding) bs - } - where - tyvars = tyConTyVars vect_tc - var_tys = mkTyVarTys tyvars - ty_args = map Type var_tys - res_ty = mkTyConApp vect_tc var_tys - - cons = tyConDataCons vect_tc - arity = length cons - [arr_dc] = tyConDataCons arr_tc - - rep_tys = map dataConRepArgTys $ tyConDataCons vect_tc - - mk_data_con con tys pre post - = do dflags <- getDynFlags - liftM2 (,) (vect_data_con con) - (lift_data_con tys pre post (mkDataConTag dflags con)) - - sel_replicate len tag - | arity > 1 = do - rep <- builtin (selReplicate arity) - return [rep `mkApps` [len, tag]] - - | otherwise = return [] - - vect_data_con con = return $ mkConApp con ty_args - lift_data_con tys pre_tys post_tys tag - = do - len <- builtin liftingContext - args <- mapM (newLocalVar (fsLit "xs")) - =<< mapM mkPDataType tys - - sel <- sel_replicate (Var len) tag - - pre <- mapM emptyPD (concat pre_tys) - post <- mapM emptyPD (concat post_tys) - - return . mkLams (len : args) - . wrapFamInstBody arr_tc var_tys - . mkConApp arr_dc - $ ty_args ++ sel ++ pre ++ map Var args ++ post - - def_worker data_con arg_tys mk_body - = do - arity <- polyArity tyvars - body <- closedV - . inBind orig_worker - . polyAbstract tyvars $ \args -> - liftM (mkLams (tyvars ++ args) . vectorised) - $ buildClosures tyvars [] [] arg_tys res_ty mk_body - - raw_worker <- mkVectId orig_worker (exprType body) - let vect_worker = raw_worker `setIdUnfolding` - mkInlineUnfoldingWithArity arity body - defGlobalVar orig_worker vect_worker - return (vect_worker, body) - where - orig_worker = dataConWorkId data_con diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs deleted file mode 100644 index 4f1831e399..0000000000 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ /dev/null @@ -1,223 +0,0 @@ - -module Vectorise.Type.TyConDecl ( - vectTyConDecls -) where - -import GhcPrelude - -import Vectorise.Type.Type -import Vectorise.Monad -import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) -import BuildTyCl( TcMethInfo, buildClass, buildDataCon, newTyConRepName ) -import OccName -import Class -import Type -import TyCon -import DataCon -import DynFlags -import BasicTypes( DefMethSpec(..) ) -import SrcLoc( SrcSpan, noSrcSpan ) -import Var -import Name -import Outputable -import Util -import Control.Monad - - --- |Vectorise some (possibly recursively defined) type constructors. --- -vectTyConDecls :: [TyCon] -> VM [TyCon] -vectTyConDecls tcs = fixV $ \tcs' -> - do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs - ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs') - ; zipWithM vectTyConDecl tcs names' - } - --- |Vectorise a single type constructor. --- -vectTyConDecl :: TyCon -> Name -> VM TyCon -vectTyConDecl tycon name' - - -- Type constructor representing a type class - | Just cls <- tyConClass_maybe tycon - = do { unless (null $ classATs cls) $ - do dflags <- getDynFlags - cantVectorise dflags "Associated types are not yet supported" (ppr cls) - - -- vectorise superclass constraint (types) - ; theta' <- mapM vectType (classSCTheta cls) - - -- vectorise method selectors - ; let opItems = classOpItems cls - Just datacon = tyConSingleDataCon_maybe tycon - argTys = dataConRepArgTys datacon -- all selector types - opTys = drop (length argTys - length opItems) argTys -- only method types - ; methods' <- sequence [ vectMethod id meth ty | ((id, meth), ty) <- zip opItems opTys] - - -- construct the vectorised class (this also creates the class type constructors and its - -- data constructor) - -- - -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types - ; cls' <- liftDs $ - buildClass - name' -- new name: "V:Class" - (tyConBinders tycon) -- keep original kind - (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety - (snd . classTvsFds $ cls) -- keep the original functional dependencies - (Just ( - theta', -- superclasses - [], -- no associated types (for the moment) - methods', -- method info - (classMinimalDef cls))) -- Inherit minimal complete definition from cls - - -- the original dictionary constructor must map to the vectorised one - ; let tycon' = classTyCon cls' - Just datacon = tyConSingleDataCon_maybe tycon - Just datacon' = tyConSingleDataCon_maybe tycon' - ; defDataCon datacon datacon' - - -- the original superclass and methods selectors must map to the vectorised ones - ; let selIds = classAllSelIds cls - selIds' = classAllSelIds cls' - ; zipWithM_ defGlobalVar selIds selIds' - - -- return the type constructor of the vectorised class - ; return tycon' - } - - -- Regular algebraic type constructor — for now, Haskell 2011-style only - | isAlgTyCon tycon - = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $ - do dflags <- getDynFlags - cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon) - - -- vectorise the data constructor of the class tycon - ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon) - - -- keep the original GADT flags - ; let gadt_flag = isGadtSyntaxTyCon tycon - - -- build the vectorised type constructor - ; tc_rep_name <- mkDerivedName mkTyConRepOcc name' - ; return $ mkAlgTyCon - name' -- new name - (tyConBinders tycon) - (tyConResKind tycon) -- keep original kind - (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety - Nothing - [] -- no stupid theta - rhs' -- new constructor defs - (VanillaAlgTyCon tc_rep_name) - gadt_flag -- whether in GADT syntax - } - - -- some other crazy thing that we don't handle - | otherwise - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon) - --- |Vectorise a class method. (Don't enter it into the vectorisation map yet.) --- -vectMethod :: Id -> DefMethInfo -> Type -> VM TcMethInfo -vectMethod id defMeth ty - = do { -- Vectorise the method type. - ; ty' <- vectType ty - - -- Create a name for the vectorised method. - ; id' <- mkVectId id ty' - - ; return (Var.varName id', ty', defMethSpecOfDefMeth defMeth) - } - --- | Convert a `DefMethInfo` to a `DefMethSpec`, which discards the name field in --- the `DefMeth` constructor of the `DefMeth`. -defMethSpecOfDefMeth :: DefMethInfo -> Maybe (DefMethSpec (SrcSpan, Type)) -defMethSpecOfDefMeth Nothing = Nothing -defMethSpecOfDefMeth (Just (_, VanillaDM)) = Just VanillaDM -defMethSpecOfDefMeth (Just (_, GenericDM ty)) = Just (GenericDM (noSrcSpan, ty)) - --- |Vectorise the RHS of an algebraic type. --- -vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs -vectAlgTyConRhs tc (AbstractTyCon {}) - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc) -vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons - , data_cons_size = data_cons_size - , is_enum = is_enum - }) - = do { data_cons' <- mapM vectDataCon data_cons - ; zipWithM_ defDataCon data_cons data_cons' - ; return $ DataTyCon { data_cons = data_cons' - , data_cons_size = data_cons_size - , is_enum = is_enum - } - } - -vectAlgTyConRhs tc (TupleTyCon { data_con = con }) - = vectAlgTyConRhs tc (mkDataTyConRhs [con]) - -- I'm not certain this is what you want to do for tuples, - -- but it's the behaviour we had before I refactored the - -- representation of AlgTyConRhs to add tuples - -vectAlgTyConRhs tc (SumTyCon { data_cons = cons - , data_cons_size = data_cons_size }) - = -- FIXME (osa): I'm pretty sure this is broken.. TupleTyCon case is probably - -- also broken when the tuple is unboxed. - vectAlgTyConRhs tc (DataTyCon { data_cons = cons - , data_cons_size = data_cons_size - , is_enum = all (((==) 0) . dataConRepArity) cons }) - -vectAlgTyConRhs tc (NewTyCon {}) - = do dflags <- getDynFlags - cantVectorise dflags noNewtypeErr (ppr tc) - where - noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration" - --- |Vectorise a data constructor by vectorising its argument and return types.. --- -vectDataCon :: DataCon -> VM DataCon -vectDataCon dc - | not . null $ ex_tvs - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc) - | not . null $ eq_spec - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc) - | not . null $ dataConFieldLabels dc - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc) - | not . null $ theta - = do dflags <- getDynFlags - cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc) - | otherwise - = do { name' <- mkLocalisedName mkVectDataConOcc name - ; tycon' <- vectTyCon tycon - ; 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' - ; let tag_map = mkTyConTagMap tycon' - ; liftDs $ buildDataCon fam_envs - name' - (dataConIsInfix dc) -- infix if the original is - rep_nm - (dataConSrcBangs dc) -- strictness as original constructor - (Just $ dataConImplBangs dc) - [] -- no labelled fields for now - univ_tvs -- universally quantified vars - [] -- no existential tvs for now - user_bndrs - [] -- no equalities for now - [] -- no context for now - arg_tys -- argument types - ret_ty -- return type - tycon' -- representation tycon - tag_map - } - where - name = dataConName dc - rep_arg_tys = dataConRepArgTys dc - tycon = dataConTyCon dc - (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc - user_bndrs = dataConUserTyVarBinders dc diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs deleted file mode 100644 index 270f130123..0000000000 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ /dev/null @@ -1,87 +0,0 @@ --- Apply the vectorisation transformation to types. This is the \mathcal{L}_t scheme in HtM. - -module Vectorise.Type.Type - ( vectTyCon - , vectAndLiftType - , vectType - ) -where - -import GhcPrelude - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Builtins -import TcType -import Type -import TyCoRep -import TyCon -import Control.Monad -import Data.Maybe -import Outputable - --- |Vectorise a type constructor. Unless there is a vectorised version (stripped of embedded --- parallel arrays), the vectorised version is the same as the original. --- -vectTyCon :: TyCon -> VM TyCon -vectTyCon tc = maybe tc id <$> lookupTyCon tc - --- |Produce the vectorised and lifted versions of a type. --- --- NB: Here we are limited to properly handle predicates at the toplevel only. Anything embedded --- in what is called the 'body_ty' below will end up as an argument to the type family 'PData'. --- -vectAndLiftType :: Type -> VM (Type, Type) -vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' -vectAndLiftType ty - = do { padicts <- liftM catMaybes $ mapM paDictArgType tyvars - ; vmono_ty <- vectType mono_ty - ; lmono_ty <- mkPDataType vmono_ty - ; return (abstractType tyvars (padicts ++ theta) vmono_ty, - abstractType tyvars (padicts ++ theta) lmono_ty) - } - where - (tyvars, phiTy) = splitForAllTys ty - (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 --- turns into forall a. PA a => Cv a => a :-> a --- -vectType :: Type -> VM Type -vectType ty - | Just ty' <- coreView ty - = vectType ty' -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) - | isPredTy ty1 - = mkFunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction - | otherwise - = TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2] -vectType ty@(ForAllTy {}) - = do { -- strip off consecutive foralls - ; let (tyvars, tyBody) = splitForAllTys ty - - -- vectorise the body - ; vtyBody <- vectType tyBody - - -- make a PA dictionary for each of the type variables - ; dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars - - -- 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 = mkInvForAllTys tyvars . mkFunTys dicts diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs deleted file mode 100644 index 6467bf9e7a..0000000000 --- a/compiler/vectorise/Vectorise/Utils.hs +++ /dev/null @@ -1,167 +0,0 @@ -module Vectorise.Utils ( - module Vectorise.Utils.Base, - module Vectorise.Utils.Closure, - module Vectorise.Utils.Hoisting, - module Vectorise.Utils.PADict, - module Vectorise.Utils.Poly, - - -- * Annotated Exprs - collectAnnTypeArgs, - collectAnnDictArgs, - collectAnnTypeBinders, - collectAnnValBinders, - isAnnTypeArg, - - -- * PD Functions - replicatePD, emptyPD, packByTagPD, - combinePD, liftPD, - - -- * Scalars - isScalar, zipScalars, scalarClosure, - - -- * Naming - newLocalVar -) where - -import GhcPrelude - -import Vectorise.Utils.Base -import Vectorise.Utils.Closure -import Vectorise.Utils.Hoisting -import Vectorise.Utils.PADict -import Vectorise.Utils.Poly -import Vectorise.Monad -import Vectorise.Builtins -import CoreSyn -import CoreUtils -import Id -import Type -import Control.Monad - - --- Annotated Exprs ------------------------------------------------------------ - -collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type]) -collectAnnTypeArgs expr = go expr [] - where - go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys) - go e tys = (e, tys) - -collectAnnDictArgs :: AnnExpr Var ann -> (AnnExpr Var ann, [AnnExpr Var ann]) -collectAnnDictArgs expr = go expr [] - where - go e@(_, AnnApp f arg) dicts - | isPredTy . exprType . deAnnotate $ arg = go f (arg : dicts) - | otherwise = (e, dicts) - go e dicts = (e, dicts) - -collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) -collectAnnTypeBinders expr = go [] expr - where - go bs (_, AnnLam b e) | isTyVar b = go (b : bs) e - go bs e = (reverse bs, e) - --- |Collect all consecutive value binders that are not dictionaries. --- -collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) -collectAnnValBinders expr = go [] expr - where - go bs (_, AnnLam b e) | isId b - && (not . isPredTy . idType $ b) = go (b : bs) e - go bs e = (reverse bs, e) - -isAnnTypeArg :: AnnExpr b ann -> Bool -isAnnTypeArg (_, AnnType _) = True -isAnnTypeArg _ = False - - --- PD "Parallel Data" Functions ----------------------------------------------- --- --- 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 --- in dph-common/D.A.P.Lifted/PArray.hs --- - --- |An empty array of the given type. --- -emptyPD :: Type -> VM CoreExpr -emptyPD = paMethod emptyPDVar emptyPD_PrimVar - --- |Produce an array containing copies of a given element. --- -replicatePD :: CoreExpr -- ^ Number of copies in the resulting array. - -> CoreExpr -- ^ Value to replicate. - -> VM CoreExpr -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 --- > ==> [:42, 50, 49:] --- -packByTagPD :: Type -- ^ Element type. - -> CoreExpr -- ^ Source array. - -> CoreExpr -- ^ Length of resulting array. - -> CoreExpr -- ^ Tag values of elements in source array. - -> CoreExpr -- ^ The tag value for the elements to select. - -> VM CoreExpr -packByTagPD ty xs len tags t - = liftM (`mkApps` [xs, len, tags, t]) - (paMethod packByTagPDVar packByTagPD_PrimVar ty) - --- |Combine some arrays based on a selector. The selector says which source array to choose for each --- element of the resulting array. --- -combinePD :: Type -- ^ Element type - -> CoreExpr -- ^ Length of resulting array - -> CoreExpr -- ^ Selector. - -> [CoreExpr] -- ^ Arrays to combine. - -> VM CoreExpr -combinePD ty len sel xs - = liftM (`mkApps` (len : sel : xs)) - (paMethod (combinePDVar n) (combinePD_PrimVar n) ty) - where - n = length xs - --- |Like `replicatePD` but use the lifting context in the vectoriser state. --- -liftPD :: CoreExpr -> VM CoreExpr -liftPD x - = do - lc <- builtin liftingContext - replicatePD (Var lc) x - - --- Scalars -------------------------------------------------------------------- - -isScalar :: Type -> VM Bool -isScalar ty - = do - { scalar <- builtin scalarClass - ; existsInst scalar [ty] - } - -zipScalars :: [Type] -> Type -> VM CoreExpr -zipScalars arg_tys res_ty - = do - { scalar <- builtin scalarClass - ; (dfuns, _) <- mapAndUnzipM (\ty -> lookupInst scalar [ty]) ty_args - ; zipf <- builtin (scalarZip $ length arg_tys) - ; return $ Var zipf `mkTyApps` ty_args `mkApps` map Var dfuns - } - where - ty_args = arg_tys ++ [res_ty] - -scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr -scalarClosure arg_tys res_ty scalar_fun array_fun - = do - { ctr <- builtin (closureCtrFun $ length arg_tys) - ; pas <- mapM paDictOfType (init arg_tys) - ; return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty]) - `mkApps` (pas ++ [scalar_fun, array_fun]) - } diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs deleted file mode 100644 index 72ee0bed1e..0000000000 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Vectorise.Utils.Base - ( voidType - , newLocalVVar - - , mkDataConTag - , mkWrapType - , mkClosureTypes - , mkPReprType - , mkPDataType, mkPDatasType - , splitPrimTyCon - , mkBuiltinCo - - , wrapNewTypeBodyOfWrap - , unwrapNewTypeBodyOfWrap - , wrapNewTypeBodyOfPDataWrap - , unwrapNewTypeBodyOfPDataWrap - , wrapNewTypeBodyOfPDatasWrap - , unwrapNewTypeBodyOfPDatasWrap - - , pdataReprTyCon - , pdataReprTyConExact - , pdatasReprTyConExact - , pdataUnwrapScrut - - , preprFamInst -) where - -import GhcPrelude - -import Vectorise.Monad -import Vectorise.Vect -import Vectorise.Builtins - -import CoreSyn -import CoreUtils -import FamInstEnv -import Coercion -import Type -import TyCon -import DataCon -import MkId -import DynFlags -import FastString - -#include "HsVersions.h" - --- Simple Types --------------------------------------------------------------- - -voidType :: VM Type -voidType = mkBuiltinTyConApp voidTyCon [] - - --- Name Generation ------------------------------------------------------------ - -newLocalVVar :: FastString -> Type -> VM VVar -newLocalVVar fs vty - = do - lty <- mkPDataType vty - vv <- newLocalVar fs vty - lv <- newLocalVar fs lty - return (vv,lv) - - --- Constructors --------------------------------------------------------------- - -mkDataConTag :: DynFlags -> DataCon -> CoreExpr -mkDataConTag dflags = mkIntLitInt dflags . dataConTagZ - - --- Type Construction ---------------------------------------------------------- - --- |Make an application of the 'Wrap' type constructor. --- -mkWrapType :: Type -> VM Type -mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty] - --- |Make an application of the closure type constructor. --- -mkClosureTypes :: [Type] -> Type -> VM Type -mkClosureTypes = mkBuiltinTyConApps closureTyCon - --- |Make an application of the 'PRepr' type constructor. --- -mkPReprType :: Type -> VM Type -mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty] - --- | Make an application of the 'PData' tycon to some argument. --- -mkPDataType :: Type -> VM Type -mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty] - --- | Make an application of the 'PDatas' tycon to some argument. --- -mkPDatasType :: Type -> VM Type -mkPDatasType ty = mkBuiltinTyConApp pdatasTyCon [ty] - --- Make an application of a builtin type constructor to some arguments. --- -mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type -mkBuiltinTyConApp get_tc tys - = do { tc <- builtin get_tc - ; return $ mkTyConApp tc tys - } - --- Make a cascading application of a builtin type constructor. --- -mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type -mkBuiltinTyConApps get_tc tys ty - = do { tc <- builtin get_tc - ; return $ foldr (mk tc) ty tys - } - where - mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] - - --- Type decomposition --------------------------------------------------------- - --- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it. --- -splitPrimTyCon :: Type -> Maybe TyCon -splitPrimTyCon ty - | Just (tycon, []) <- splitTyConApp_maybe ty - , isPrimTyCon tycon - = Just tycon - | otherwise = Nothing - - --- Coercion Construction ----------------------------------------------------- - --- |Make a representational coercion to some builtin type. --- -mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion -mkBuiltinCo get_tc - = do { tc <- builtin get_tc - ; return $ mkTyConAppCo Representational tc [] - } - - --- Wrapping and unwrapping the 'Wrap' newtype --------------------------------- - --- |Apply the constructor wrapper of the 'Wrap' /newtype/. --- -wrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr -wrapNewTypeBodyOfWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; return $ wrapNewTypeBody wrap_tc [ty] e - } - --- |Strip the constructor wrapper of the 'Wrap' /newtype/. --- -unwrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr -unwrapNewTypeBodyOfWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; return $ unwrapNewTypeBody wrap_tc [ty] e - } - --- |Apply the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'. --- -wrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr -wrapNewTypeBodyOfPDataWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; pwrap_tc <- pdataReprTyConExact wrap_tc - ; return $ wrapNewTypeBody pwrap_tc [ty] e - } - --- |Strip the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'. --- -unwrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr -unwrapNewTypeBodyOfPDataWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; pwrap_tc <- pdataReprTyConExact wrap_tc - ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e) - } - --- |Apply the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'. --- -wrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr -wrapNewTypeBodyOfPDatasWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; pwrap_tc <- pdatasReprTyConExact wrap_tc - ; return $ wrapNewTypeBody pwrap_tc [ty] e - } - --- |Strip the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'. --- -unwrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr -unwrapNewTypeBodyOfPDatasWrap e ty - = do { wrap_tc <- builtin wrapTyCon - ; pwrap_tc <- pdatasReprTyConExact wrap_tc - ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e) - } - - --- 'PData' representation types ---------------------------------------------- - --- |Get the representation tycon of the 'PData' data family for a given type. --- --- This tycon does not appear explicitly in the source program — see Note [PData TyCons] in --- 'Vectorise.Generic.Description': --- --- @pdataReprTyCon {Sum2} = {PDataSum2}@ --- --- 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 - { FamInstMatch { fim_instance = famInst - , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) - ; return (dataFamInstRepTyCon famInst, tys) - } - --- |Get the representation tycon of the 'PData' data family for a given type constructor. --- --- For example, for a binary type constructor 'T', we determine the representation type constructor --- for 'PData (T a b)'. --- -pdataReprTyConExact :: TyCon -> VM TyCon -pdataReprTyConExact tycon - = do { -- look up the representation tycon; if there is a match at all, it will be exact - ; -- (i.e.,' _tys' will be distinct type variables) - ; (ptycon, _tys) <- pdataReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) - ; return ptycon - } - --- |Get the representation tycon of the 'PDatas' data family for a given type constructor. --- --- For example, for a binary type constructor 'T', we determine the representation type constructor --- for 'PDatas (T a b)'. --- -pdatasReprTyConExact :: TyCon -> VM TyCon -pdatasReprTyConExact tycon - = do { -- look up the representation tycon; if there is a match at all, it will be exact - ; (FamInstMatch { fim_instance = ptycon }) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) - ; return $ dataFamInstRepTyCon ptycon - } - where - pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty]) - --- |Unwrap a 'PData' representation scrutinee. --- -pdataUnwrapScrut :: VExpr -> VM (CoreExpr, CoreExpr, DataCon) -pdataUnwrapScrut (ve, le) - = do { (tc, arg_tys) <- pdataReprTyCon ty - ; let [dc] = tyConDataCons tc - ; return (ve, unwrapFamInstScrut tc arg_tys le, dc) - } - where - ty = exprType ve - - --- 'PRepr' representation types ---------------------------------------------- - --- |Get the representation tycon of the 'PRepr' type family for a given type. --- -preprFamInst :: Type -> VM FamInstMatch -preprFamInst ty = builtin preprTyCon >>= (`lookupFamInst` [ty]) diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs deleted file mode 100644 index 49ef127975..0000000000 --- a/compiler/vectorise/Vectorise/Utils/Closure.hs +++ /dev/null @@ -1,163 +0,0 @@ --- |Utils concerning closure construction and application. - -module Vectorise.Utils.Closure - ( mkClosure - , mkClosureApp - , buildClosures - ) -where - -import GhcPrelude - -import Vectorise.Builtins -import Vectorise.Vect -import Vectorise.Monad -import Vectorise.Utils.Base -import Vectorise.Utils.PADict -import Vectorise.Utils.Hoisting - -import CoreSyn -import Type -import MkCore -import CoreUtils -import TyCon -import DataCon -import MkId -import TysWiredIn -import BasicTypes( Boxity(..) ) -import FastString - - --- |Make a closure. --- -mkClosure :: Type -- ^ Type of the argument. - -> Type -- ^ Type of the result. - -> Type -- ^ Type of the environment. - -> VExpr -- ^ The function to apply. - -> VExpr -- ^ The environment to use. - -> VM VExpr -mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) - = do dict <- paDictOfType env_ty - mkv <- builtin closureVar - mkl <- builtin liftedClosureVar - return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv], - Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv]) - --- |Make a closure application. --- -mkClosureApp :: Type -- ^ Type of the argument. - -> Type -- ^ Type of the result. - -> VExpr -- ^ Closure to apply. - -> VExpr -- ^ Argument to use. - -> VM VExpr -mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg) - = do vapply <- builtin applyVar - lapply <- builtin liftedApplyVar - lc <- builtin liftingContext - return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg], - Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg]) - --- |Build a set of 'n' closures corresponding to an 'n'-ary vectorised function. The length of --- the list of types of arguments determines the arity. --- --- In addition to a set of type variables, a set of value variables is passed during closure --- /construction/. In contrast, the closure environment and the arguments are passed during closure --- application. --- -buildClosures :: [TyVar] -- ^ Type variables passed during closure construction. - -> [Var] -- ^ Variables passed during closure construction. - -> [VVar] -- ^ Variables in the environment. - -> [Type] -- ^ Type of the arguments. - -> Type -- ^ Type of result. - -> VM VExpr - -> VM VExpr -buildClosures _tvs _vars _env [] _res_ty mk_body - = mk_body -buildClosures tvs vars env [arg_ty] res_ty mk_body - = buildClosure tvs vars env arg_ty res_ty mk_body -buildClosures tvs vars env (arg_ty : arg_tys) res_ty mk_body - = do { res_ty' <- mkClosureTypes arg_tys res_ty - ; arg <- newLocalVVar (fsLit "x") arg_ty - ; buildClosure tvs vars env arg_ty res_ty' - . hoistPolyVExpr tvs vars (Inline (length env + 1)) - $ do { lc <- builtin liftingContext - ; clo <- buildClosures tvs vars (env ++ [arg]) arg_tys res_ty mk_body - ; return $ vLams lc (env ++ [arg]) clo - } - } - --- Build a closure taking one extra argument during closure application. --- --- (clo <x1,...,xn> <f,f^>, aclo (Arr lc xs1 ... xsn) <f,f^>) --- where --- f = \env v -> case env of <x1,...,xn> -> e x1 ... xn v --- f^ = \env v -> case env of Arr l xs1 ... xsn -> e^ l x1 ... xn v --- --- In addition to a set of type variables, a set of value variables is passed during closure --- /construction/. In contrast, the closure environment and the closure argument are passed during --- closure application. --- -buildClosure :: [TyVar] -- ^Type variables passed during closure construction. - -> [Var] -- ^Variables passed during closure construction. - -> [VVar] -- ^Variables in the environment. - -> Type -- ^Type of the closure argument. - -> Type -- ^Type of the result. - -> VM VExpr - -> VM VExpr -buildClosure tvs vars vvars arg_ty res_ty mk_body - = do { (env_ty, env, bind) <- buildEnv vvars - ; env_bndr <- newLocalVVar (fsLit "env") env_ty - ; arg_bndr <- newLocalVVar (fsLit "arg") arg_ty - - -- generate the closure function as a hoisted binding - ; fn <- hoistPolyVExpr tvs vars (Inline 2) $ - do { lc <- builtin liftingContext - ; body <- mk_body - ; return . vLams lc [env_bndr, arg_bndr] - $ bind (vVar env_bndr) - (vVarApps lc body (vvars ++ [arg_bndr])) - } - - ; mkClosure arg_ty res_ty env_ty fn env - } - --- Build the environment for a single closure. --- -buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr) -buildEnv [] - = do - ty <- voidType - void <- builtin voidVar - pvoid <- builtin pvoidVar - return (ty, vVar (void, pvoid), \_ body -> body) -buildEnv [v] - = return (vVarType v, vVar v, - \env body -> vLet (vNonRec v env) body) -buildEnv vs - = do (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty - - let venv_con = tupleDataCon Boxed (length vs) - [lenv_con] = tyConDataCons lenv_tc - - venv = mkCoreTup (map Var vvs) - lenv = Var (dataConWrapId lenv_con) - `mkTyApps` lenv_tyargs - `mkApps` map Var lvs - - vbind env body = mkWildCase env ty (exprType body) - [(DataAlt venv_con, vvs, body)] - - lbind env body = - let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env - in - mkWildCase scrut (exprType scrut) (exprType body) - [(DataAlt lenv_con, lvs, body)] - - bind (venv, lenv) (vbody, lbody) = (vbind venv vbody, - lbind lenv lbody) - - return (ty, (venv, lenv), bind) - where - (vvs, lvs) = unzip vs - tys = map vVarType vs - ty = mkBoxedTupleTy tys diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs deleted file mode 100644 index e1d208590d..0000000000 --- a/compiler/vectorise/Vectorise/Utils/Hoisting.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Vectorise.Utils.Hoisting - ( Inline(..) - , addInlineArity - , inlineMe - - , hoistBinding - , hoistExpr - , hoistVExpr - , hoistPolyVExpr - , takeHoisted - ) -where - -import GhcPrelude - -import Vectorise.Monad -import Vectorise.Env -import Vectorise.Vect -import Vectorise.Utils.Poly - -import CoreSyn -import CoreUtils -import CoreUnfold -import Type -import Id -import BasicTypes (Arity) -import FastString -import Control.Monad - --- Inline --------------------------------------------------------------------- - --- |Records whether we should inline a particular binding. --- -data Inline - = Inline Arity - | DontInline - --- |Add to the arity contained within an `Inline`, if any. --- -addInlineArity :: Inline -> Int -> Inline -addInlineArity (Inline m) n = Inline (m+n) -addInlineArity DontInline _ = DontInline - --- |Says to always inline a binding. --- -inlineMe :: Inline -inlineMe = Inline 0 - - --- Hoisting -------------------------------------------------------------------- - -hoistBinding :: Var -> CoreExpr -> VM () -hoistBinding v e = updGEnv $ \env -> - env { global_bindings = (v,e) : global_bindings env } - -hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var -hoistExpr fs expr inl - = do - var <- mk_inline `liftM` newLocalVar fs (exprType expr) - hoistBinding var expr - return var - where - mk_inline var = case inl of - Inline arity -> var `setIdUnfolding` - mkInlineUnfoldingWithArity arity expr - DontInline -> var - -hoistVExpr :: VExpr -> Inline -> VM VVar -hoistVExpr (ve, le) inl - = do - fs <- getBindName - vv <- hoistExpr ('v' `consFS` fs) ve inl - lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1) - return (vv, lv) - --- |Hoist a polymorphic vectorised expression into a new top-level binding (representing a closure --- function). --- --- The hoisted expression is parameterised by (1) a set of type variables and (2) a set of value --- variables that are passed as conventional type and value arguments. The latter is implicitly --- extended by the set of 'PA' dictionaries required for the type variables. --- -hoistPolyVExpr :: [TyVar] -> [Var] -> Inline -> VM VExpr -> VM VExpr -hoistPolyVExpr tvs vars inline p - = do { inline' <- addInlineArity inline . (+ length vars) <$> polyArity tvs - ; expr <- closedV . polyAbstract tvs $ \args -> - mapVect (mkLams $ tvs ++ args ++ vars) <$> p - ; fn <- hoistVExpr expr inline' - ; let varArgs = varsToCoreExprs vars - ; mapVect (\e -> e `mkApps` varArgs) <$> polyVApply (vVar fn) (mkTyVarTys tvs) - } - -takeHoisted :: VM [(Var, CoreExpr)] -takeHoisted - = do - env <- readGEnv id - setGEnv $ env { global_bindings = [] } - return $ global_bindings env diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs deleted file mode 100644 index 1176b78e54..0000000000 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ /dev/null @@ -1,232 +0,0 @@ -module Vectorise.Utils.PADict ( - paDictArgType, - paDictOfType, - paMethod, - prDictOfReprType, - prDictOfPReprInstTyCon -) where - -import GhcPrelude - -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Utils.Base - -import CoreSyn -import CoreUtils -import FamInstEnv -import Coercion -import Type -import TyCoRep -import TyCon -import CoAxiom -import Var -import Outputable -import DynFlags -import FastString -import Util -import Control.Monad - - --- |Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's --- just PA v. For (v :: (* -> *) -> *) it's --- --- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a) --- -paDictArgType :: TyVar -> VM (Maybe Type) -paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv) - where - go ty (FunTy k1 k2) - = do - 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 (mkAppTy ty (mkTyVarTy tv)) k2 - return $ fmap (mkInvForAllTy tv . mkFunTy ty1) mty2 - Nothing -> go ty k2 - - go ty k - | isLiftedTypeKind k - = do - pa_cls <- builtin paClass - return $ Just $ mkClassPred pa_cls [ty] - - go _ _ = return Nothing - - --- |Get the PA dictionary for some type --- -paDictOfType :: Type -> VM CoreExpr -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 - = 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 - { dfun <- maybeCantVectoriseM "No PA dictionary for type variable" - (ppr tv <+> text "in" <+> ppr ty) - $ lookupTyVarPA tv - ; dicts <- mapM paDictOfType ty_args - ; return $ dfun `mkTyApps` ty_args `mkApps` dicts - } - - -- 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 - { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty) - $ lookupTyConPA tc - ; super <- super_dict tc ty_args - ; dicts <- mapM paDictOfType ty_args - ; return $ Var dfun `mkTyApps` ty_args `mkApps` super `mkApps` dicts - } - where - noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)" - - super_dict _ [] = return [] - super_dict tycon ty_args - = do - { pr <- prDictOfPReprInst (TyConApp tycon ty_args) - ; return [pr] - } - - paDictOfTyApp _ _ = getDynFlags >>= failure - - failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty) - --- |Produce code that refers to a method of the 'PA' class. --- -paMethod :: (Builtins -> Var) -> (TyCon -> Builtins -> Var) -> Type -> VM CoreExpr -paMethod _ query ty - | Just tycon <- splitPrimTyCon ty -- Is 'ty' from 'GHC.Prim' (e.g., 'Int#')? - = liftM Var $ builtin (query tycon) -paMethod method _ ty - = do - { fn <- builtin method - ; dict <- paDictOfType ty - ; return $ mkApps (Var fn) [Type ty, dict] - } - --- |Given a type @ty@, return the PR dictionary for @PRepr ty@. --- -prDictOfPReprInst :: Type -> VM CoreExpr -prDictOfPReprInst ty - = do - { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) - <- preprFamInst ty - ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args - } - --- |Given a type @ty@, its PRepr synonym tycon and its type arguments, --- return the PR @PRepr ty@. Suppose we have: --- --- > type instance PRepr (T a1 ... an) = t --- --- which is internally translated into --- --- > type :R:PRepr a1 ... an = t --- --- and the corresponding coercion. Then, --- --- > prDictOfPReprInstTyCon (T a1 ... an) :R:PRepr u1 ... un = PR (T u1 ... un) --- --- Note that @ty@ is only used for error messages --- -prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr -prDictOfPReprInstTyCon _ty prepr_ax prepr_args - = do - 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 [] - return $ mkCast dict co - --- |Get the PR dictionary for a type. The argument must be a representation --- type. --- -prDictOfReprType :: Type -> VM CoreExpr -prDictOfReprType ty - | Just (tycon, tyargs) <- splitTyConApp_maybe ty - = do - prepr <- builtin preprTyCon - if tycon == prepr - then do - let [ty'] = tyargs - pa <- paDictOfType ty' - sel <- builtin paPRSel - return $ Var sel `App` Type ty' `App` pa - else do - -- a representation tycon must have a PR instance - dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $ - lookupTyConPR tycon - prDFunApply dfun tyargs - - | otherwise - = do - -- it is a tyvar or an application of a tyvar - -- determine the PR dictionary from its PA dictionary - -- - -- NOTE: This assumes that PRepr t ~ t is for all representation types - -- t - -- - -- FIXME: This doesn't work for kinds other than * at the moment. We'd - -- have to simply abstract the term over the missing type arguments. - pa <- paDictOfType ty - prsel <- builtin paPRSel - return $ Var prsel `mkApps` [Type ty, pa] - -prDictOfReprType' :: Type -> VM CoreExpr -prDictOfReprType' ty = prDictOfReprType ty `orElseV` - do dflags <- getDynFlags - cantVectorise dflags "No PR dictionary for representation type" - (ppr ty) - --- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding --- to the argument types. -prDFunApply :: Var -> [Type] -> VM CoreExpr -prDFunApply dfun tys - | Just [] <- ctxs -- PR (a :-> b) doesn't have a context - = return $ Var dfun `mkTyApps` tys - - | Just tycons <- ctxs - , tycons `equalLength` tys - = do - pa <- builtin paTyCon - pr <- builtin prTyCon - dflags <- getDynFlags - args <- zipWithM (dictionary dflags pa pr) tys tycons - return $ Var dfun `mkTyApps` tys `mkApps` args - - | otherwise = do dflags <- getDynFlags - invalid dflags - where - -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then - -- ctxs is Just [PA, PR] - ctxs = fmap (map fst) - $ sequence - $ map splitTyConApp_maybe - $ fst - $ splitFunTys - $ snd - $ splitForAllTys - $ varType dfun - - dictionary dflags pa pr ty tycon - | tycon == pa = paDictOfType ty - | tycon == pr = prDictOfReprType ty - | 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 deleted file mode 100644 index 6d7a4112da..0000000000 --- a/compiler/vectorise/Vectorise/Utils/Poly.hs +++ /dev/null @@ -1,74 +0,0 @@ --- |Auxiliary functions to vectorise type abstractions. - -module Vectorise.Utils.Poly - ( polyAbstract - , polyApply - , polyVApply - , polyArity - ) -where - -import GhcPrelude - -import Vectorise.Vect -import Vectorise.Monad -import Vectorise.Utils.PADict -import CoreSyn -import Type -import FastString -import Control.Monad - - --- Vectorisation of type arguments ------------------------------------------------------------- - --- |Vectorise under the 'PA' dictionary variables corresponding to a set of type arguments. --- --- The dictionary variables are new local variables that are entered into the local vectorisation --- map. --- --- The purpose of this function is to introduce the additional 'PA' dictionary arguments that are --- needed when vectorising type abstractions. --- -polyAbstract :: [TyVar] -> ([Var] -> VM a) -> VM a -polyAbstract tvs p - = localV - $ do { mdicts <- mapM mk_dict_var tvs - ; zipWithM_ (\tv -> maybe (defLocalTyVar tv) - (defLocalTyVarWithPA tv . Var)) tvs mdicts - ; p (mk_args mdicts) - } - where - mk_dict_var tv - = do { r <- paDictArgType tv - ; case r of - Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty) - Nothing -> return Nothing - } - - mk_args mdicts = [dict | Just dict <- mdicts] - --- |Determine the number of 'PA' dictionary arguments required for a set of type variables (depends --- on their kinds). --- -polyArity :: [TyVar] -> VM Int -polyArity tvs - = do { tys <- mapM paDictArgType tvs - ; return $ length [() | Just _ <- tys] - } - --- |Apply a expression to its type arguments as well as 'PA' dictionaries for these type arguments. --- -polyApply :: CoreExpr -> [Type] -> VM CoreExpr -polyApply expr tys - = do { dicts <- mapM paDictOfType tys - ; return $ expr `mkTyApps` tys `mkApps` dicts - } - --- |Apply a vectorised expression to a set of type arguments together with 'PA' dictionaries for --- these type arguments. --- -polyVApply :: VExpr -> [Type] -> VM VExpr -polyVApply expr tys - = do { dicts <- mapM paDictOfType tys - ; return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr - } diff --git a/compiler/vectorise/Vectorise/Var.hs b/compiler/vectorise/Vectorise/Var.hs deleted file mode 100644 index b107354899..0000000000 --- a/compiler/vectorise/Vectorise/Var.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE TupleSections #-} - --- |Vectorise variables and literals. - -module Vectorise.Var - ( vectBndr - , vectBndrNew - , vectBndrIn - , vectBndrNewIn - , vectBndrsIn - , vectVar - , vectConst - ) -where - -import GhcPrelude - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Env -import Vectorise.Vect -import Vectorise.Type.Type -import CoreSyn -import Type -import VarEnv -import Id -import FastString - --- Binders ---------------------------------------------------------------------------------------- - --- |Vectorise a binder variable, along with its attached type. --- -vectBndr :: Var -> VM VVar -vectBndr v - = do (vty, lty) <- vectAndLiftType (idType v) - let vv = v `Id.setIdType` vty - lv = v `Id.setIdType` lty - - updLEnv (mapTo vv lv) - - return (vv, lv) - where - mapTo vv lv env = env { local_vars = extendVarEnv (local_vars env) v (vv, lv) } - --- |Vectorise a binder variable, along with its attached type, but give the result a new name. --- -vectBndrNew :: Var -> FastString -> VM VVar -vectBndrNew v fs - = do vty <- vectType (idType v) - vv <- newLocalVVar fs vty - updLEnv (upd vv) - return vv - where - upd vv env = env { local_vars = extendVarEnv (local_vars env) v vv } - --- |Vectorise a binder then run a computation with that binder in scope. --- -vectBndrIn :: Var -> VM a -> VM (VVar, a) -vectBndrIn v p - = localV - $ do vv <- vectBndr v - x <- p - return (vv, x) - --- |Vectorise a binder, give it a new name, then run a computation with that binder in scope. --- -vectBndrNewIn :: Var -> FastString -> VM a -> VM (VVar, a) -vectBndrNewIn v fs p - = localV - $ do vv <- vectBndrNew v fs - x <- p - return (vv, x) - --- |Vectorise some binders, then run a computation with them in scope. --- -vectBndrsIn :: [Var] -> VM a -> VM ([VVar], a) -vectBndrsIn vs p - = localV - $ do vvs <- mapM vectBndr vs - x <- p - return (vvs, x) - - --- Variables -------------------------------------------------------------------------------------- - --- |Vectorise a variable, producing the vectorised and lifted versions. --- -vectVar :: Var -> VM VExpr -vectVar var - = do { vVar <- lookupVar var - ; case vVar of - Local (vv, lv) -> return (Var vv, Var lv) -- local variables have a vect & lifted version - Global vv -> vectConst (Var vv) -- global variables get replicated - } - - --- Constants -------------------------------------------------------------------------------------- - --- |Constants are lifted by replication along the integer context in the `VM` state for the number --- of elements in the result array. --- -vectConst :: CoreExpr -> VM VExpr -vectConst c = (c,) <$> liftPD c diff --git a/compiler/vectorise/Vectorise/Vect.hs b/compiler/vectorise/Vectorise/Vect.hs deleted file mode 100644 index 1b0e57167c..0000000000 --- a/compiler/vectorise/Vectorise/Vect.hs +++ /dev/null @@ -1,128 +0,0 @@ --- |Simple vectorised constructors and projections. --- -module Vectorise.Vect - ( Vect, VVar, VExpr, VBind - - , vectorised - , lifted - , mapVect - - , vVarType - , vNonRec - , vRec - , vVar - , vType - , vTick - , vLet - , vLams - , vVarApps - , vCaseDEFAULT - ) -where - -import GhcPrelude - -import CoreSyn -import Type ( Type ) -import Var - --- |Contains the vectorised and lifted versions of some thing. --- -type Vect a = (a,a) -type VVar = Vect Var -type VExpr = Vect CoreExpr -type VBind = Vect CoreBind - --- |Get the vectorised version of a thing. --- -vectorised :: Vect a -> a -vectorised = fst - --- |Get the lifted version of a thing. --- -lifted :: Vect a -> a -lifted = snd - --- |Apply some function to both the vectorised and lifted versions of a thing. --- -mapVect :: (a -> b) -> Vect a -> Vect b -mapVect f (x, y) = (f x, f y) - --- |Combine vectorised and lifted versions of two things componentwise. --- -zipWithVect :: (a -> b -> c) -> Vect a -> Vect b -> Vect c -zipWithVect f (x1, y1) (x2, y2) = (f x1 x2, f y1 y2) - --- |Get the type of a vectorised variable. --- -vVarType :: VVar -> Type -vVarType = varType . vectorised - --- |Wrap a vectorised variable as a vectorised expression. --- -vVar :: VVar -> VExpr -vVar = mapVect Var - --- |Wrap a vectorised type as a vectorised expression. --- -vType :: Type -> VExpr -vType ty = (Type ty, Type ty) - --- |Make a vectorised note. --- -vTick :: Tickish Id -> VExpr -> VExpr -vTick = mapVect . Tick - --- |Make a vectorised non-recursive binding. --- -vNonRec :: VVar -> VExpr -> VBind -vNonRec = zipWithVect NonRec - --- |Make a vectorised recursive binding. --- -vRec :: [VVar] -> [VExpr] -> VBind -vRec vs es = (Rec (zip vvs ves), Rec (zip lvs les)) - where - (vvs, lvs) = unzip vs - (ves, les) = unzip es - --- |Make a vectorised let expression. --- -vLet :: VBind -> VExpr -> VExpr -vLet = zipWithVect Let - --- |Make a vectorised lambda abstraction. --- --- The lifted version also binds the lifting context 'lc'. --- -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) - = (mkLams vvs ve, mkLams (lc:lvs) le) - where - (vvs, lvs) = unzip vs - --- |Apply an expression to a set of argument variables. --- --- The lifted version is also applied to the variable of the lifting context. --- -vVarApps :: Var -> VExpr -> [VVar] -> VExpr -vVarApps lc (ve, le) vvs - = (ve `mkVarApps` vs, le `mkVarApps` (lc : ls)) - where - (vs, ls) = unzip vvs - - -vCaseDEFAULT :: VExpr -- scrutinee - -> VVar -- bnder - -> Type -- type of vectorised version - -> Type -- type of lifted version - -> VExpr -- body of alternative. - -> VExpr -vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody) - = (Case vscrut vbndr vty (mkDEFAULT vbody), - Case lscrut lbndr lty (mkDEFAULT lbody)) - where - mkDEFAULT e = [(DEFAULT, [], e)] |