diff options
Diffstat (limited to 'compiler')
39 files changed, 912 insertions, 518 deletions
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 7bc4c447fd..603b745cf2 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -72,7 +72,10 @@ module CoreSyn ( -- ** Operations on 'CoreRule's seqRules, ruleArity, ruleName, ruleIdName, ruleActivation, setRuleIdName, - isBuiltinRule, isLocalRule + isBuiltinRule, isLocalRule, + + -- * Core vectorisation declarations data type + CoreVect(..) ) where #include "HsVersions.h" @@ -402,6 +405,20 @@ setRuleIdName nm ru = ru { ru_fn = nm } %************************************************************************ +%* * +\subsection{Vectorisation declarations} +%* * +%************************************************************************ + +Representation of desugared vectorisation declarations that are fed to the vectoriser (via +'ModGuts'). + +\begin{code} +data CoreVect = Vect Id (Maybe CoreExpr) +\end{code} + + +%************************************************************************ %* * Unfoldings %* * diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 60dec3047a..142f695cb5 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -69,12 +69,13 @@ deSugar hsc_env tcg_anns = anns, tcg_binds = binds, tcg_imp_specs = imp_specs, - tcg_ev_binds = ev_binds, - tcg_fords = fords, - tcg_rules = rules, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info }) + tcg_ev_binds = ev_binds, + tcg_fords = fords, + tcg_rules = rules, + tcg_vects = vects, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_hpc = other_hpc_info }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Desugar" @@ -88,7 +89,7 @@ deSugar hsc_env <- case target of HscNothing -> return (emptyMessages, - Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks)) + Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) _ -> do (binds_cvr,ds_hpc_info, modBreaks) <- if (opt_Hpc @@ -98,19 +99,20 @@ deSugar hsc_env (typeEnvTyCons type_env) binds else return (binds, hpcInfo, emptyModBreaks) initDs hsc_env mod rdr_env type_env $ do - do { ds_ev_binds <- dsEvBinds ev_binds - ; core_prs <- dsTopLHsBinds auto_scc binds_cvr + do { ds_ev_binds <- dsEvBinds ev_binds + ; core_prs <- dsTopLHsBinds auto_scc binds_cvr ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs - ; (ds_fords, foreign_prs) <- dsForeigns fords - ; rules <- mapMaybeM dsRule rules - ; return ( ds_ev_binds + ; (ds_fords, foreign_prs) <- dsForeigns fords + ; ds_rules <- mapMaybeM dsRule rules + ; ds_vects <- mapM dsVect vects + ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs - , spec_rules ++ rules + , spec_rules ++ ds_rules, ds_vects , ds_fords, ds_hpc_info, modBreaks) } - ; case mb_res of { - Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do + ; case mb_res of { + Nothing -> return (msgs, Nothing) ; + Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@ -161,6 +163,7 @@ deSugar hsc_env mg_foreign = ds_fords, mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, + mg_vect_decls = ds_vects, mg_vect_info = noVectInfo } ; return (msgs, Just mod_guts) @@ -374,3 +377,26 @@ That keeps the desugaring of list comprehensions simple too. Nor do we want to warn of conversion identities on the LHS; the rule is precisly to optimise them: {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} + + +%************************************************************************ +%* * +%* Desugaring vectorisation declarations +%* * +%************************************************************************ + +\begin{code} +dsVect :: LVectDecl Id -> DsM CoreVect +dsVect (L loc (HsVect v rhs)) + = putSrcSpanDs loc $ + do { rhs' <- fmapMaybeM dsLExpr rhs + ; return $ Vect (unLoc v) rhs' + } +-- dsVect (L loc (HsVect v Nothing)) +-- = return $ Vect v Nothing +-- dsVect (L loc (HsVect v (Just rhs))) +-- = putSrcSpanDs loc $ +-- do { rhs' <- dsLExpr rhs +-- ; return $ Vect v (Just rhs') +-- } +\end{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 4084310638..1781aef5f8 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -368,11 +368,11 @@ dsExpr (ExplicitList elt_ty xs) -- singletonP x1 +:+ ... +:+ singletonP xn -- dsExpr (ExplicitPArr ty []) = do - emptyP <- dsLookupGlobalId emptyPName + emptyP <- dsLookupDPHId emptyPName return (Var emptyP `App` Type ty) dsExpr (ExplicitPArr ty xs) = do - singletonP <- dsLookupGlobalId singletonPName - appP <- dsLookupGlobalId appPName + singletonP <- dsLookupDPHId singletonPName + appP <- dsLookupDPHId appPName xs' <- mapM dsLExpr xs return . foldr1 (binary appP) $ map (unary singletonP) xs' where diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 2292aedc12..cd22b8ff8c 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -514,7 +514,7 @@ dsPArrComp [ParStmt qss] body _ = -- parallel comprehension -- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) -- dsPArrComp (BindStmt p e _ _ : qs) body _ = do - filterP <- dsLookupGlobalId filterPName + filterP <- dsLookupDPHId filterPName ce <- dsLExpr e let ety'ce = parrElemType ce false = Var falseDataConId @@ -526,7 +526,7 @@ dsPArrComp (BindStmt p e _ _ : qs) body _ = do dePArrComp qs body p gen dsPArrComp qs body _ = do -- no ParStmt in `qs' - sglP <- dsLookupGlobalId singletonPName + sglP <- dsLookupDPHId singletonPName let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []] dePArrComp qs body (noLoc $ WildPat unitTy) unitArray @@ -543,7 +543,7 @@ dePArrComp :: [Stmt Id] -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea -- dePArrComp [] e' pa cea = do - mapP <- dsLookupGlobalId mapPName + mapP <- dsLookupDPHId mapPName let ty = parrElemType cea (clam, ty'e') <- deLambda ty pa e' return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] @@ -551,7 +551,7 @@ dePArrComp [] e' pa cea = do -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) -- dePArrComp (ExprStmt b _ _ : qs) body pa cea = do - filterP <- dsLookupGlobalId filterPName + filterP <- dsLookupDPHId filterPName let ty = parrElemType cea (clam,_) <- deLambda ty pa b dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea]) @@ -570,8 +570,8 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = do -- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) -- dePArrComp (BindStmt p e _ _ : qs) body pa cea = do - filterP <- dsLookupGlobalId filterPName - crossMapP <- dsLookupGlobalId crossMapPName + filterP <- dsLookupDPHId filterPName + crossMapP <- dsLookupDPHId crossMapPName ce <- dsLExpr e let ety'cea = parrElemType cea ety'ce = parrElemType ce @@ -595,7 +595,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- dePArrComp (LetStmt ds : qs) body pa cea = do - mapP <- dsLookupGlobalId mapPName + mapP <- dsLookupDPHId mapPName let xs = collectLocalBinders ds ty'cea = parrElemType cea v <- newSysLocalDs ty'cea @@ -640,7 +640,7 @@ dePArrParComp qss body = do --- parStmts [] pa cea = return (pa, cea) parStmts ((qs, xs):qss) pa cea = do -- subsequent statements (zip'ed) - zipP <- dsLookupGlobalId zipPName + zipP <- dsLookupDPHId zipPName let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea res_expr = mkLHsVarTuple xs diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 1238b1a2b5..62e805334e 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -12,15 +12,16 @@ module DsMonad ( foldlM, foldrM, ifDOptM, unsetOptM, Applicative(..),(<$>), - newLocalName, - duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, - newFailLocalDs, newPredVarDs, - getSrcSpanDs, putSrcSpanDs, - getModuleDs, - newUnique, - UniqSupply, newUniqueSupply, - getDOptsDs, getGhcModeDs, doptDs, - dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, + newLocalName, + duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, + newFailLocalDs, newPredVarDs, + getSrcSpanDs, putSrcSpanDs, + getModuleDs, + mkPrintUnqualifiedDs, + newUnique, + UniqSupply, newUniqueSupply, + getDOptsDs, getGhcModeDs, doptDs, + dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon, dsLookupClass, DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, @@ -282,6 +283,9 @@ failWithDs err ; let msg = mkErrMsg loc (ds_unqual env) err ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) ; failM } + +mkPrintUnqualifiedDs :: DsM PrintUnqualified +mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv \end{code} \begin{code} @@ -299,6 +303,19 @@ dsLookupGlobalId :: Name -> DsM Id dsLookupGlobalId name = tyThingId <$> dsLookupGlobal name +-- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked +-- up name is located, varies with the active DPH backend. +-- +dsLookupDPHId :: (PackageId -> Name) -> DsM Id +dsLookupDPHId nameInPkg + = do { dflags <- getDOpts + ; case dphPackageMaybe dflags of + Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg) + Nothing -> failWithDs $ ptext err + } + where + err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq" + dsLookupTyCon :: Name -> DsM TyCon dsLookupTyCon name = tyThingTyCon <$> dsLookupGlobal name diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index a4a9b80a8f..3a976878e3 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -383,7 +383,7 @@ mkCoAlgCaseMatchResult var ty match_alts isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" -- mk_parrCase fail = do - lengthP <- dsLookupGlobalId lengthPName + lengthP <- dsLookupDPHId lengthPName alt <- unboxAlt return (mkWildCase (len lengthP) intTy ty [alt]) where @@ -395,7 +395,7 @@ mkCoAlgCaseMatchResult var ty match_alts -- unboxAlt = do l <- newSysLocalDs intPrimTy - indexP <- dsLookupGlobalId indexPName + indexP <- dsLookupDPHId indexPName alts <- mapM (mkAlt indexP) sorted_alts return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) where diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 2544515391..e080bee8cf 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -621,10 +621,10 @@ data Sig name -- Signatures and pragmas -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE - -- A specialisation pragma for instance declarations only - -- {-# SPECIALISE instance Eq [Int] #-} - | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the - -- current instance decl + -- A specialisation pragma for instance declarations only + -- {-# SPECIALISE instance Eq [Int] #-} + | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the + -- current instance decl deriving (Data, Typeable) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 8827f3ab64..345ec32ef3 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -34,6 +34,8 @@ module HsDecls ( -- ** @RULE@ declarations RuleDecl(..), LRuleDecl, RuleBndr(..), collectRuleBndrSigTys, + -- ** @VECTORISE@ declarations + VectDecl(..), LVectDecl, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Top-level template haskell splice @@ -57,7 +59,7 @@ module HsDecls ( ) where -- friends: -import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) +import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, pprExpr ) -- Because Expr imports Decls via HsBracket import HsBinds @@ -102,6 +104,7 @@ data HsDecl id | WarningD (WarnDecl id) | AnnD (AnnDecl id) | RuleD (RuleDecl id) + | VectD (VectDecl id) | SpliceD (SpliceDecl id) | DocD (DocDecl) | QuasiQuoteD (HsQuasiQuote id) @@ -139,13 +142,14 @@ data HsGroup id -- Snaffled out of both top-level fixity signatures, -- and those in class declarations - hs_defds :: [LDefaultDecl id], - hs_fords :: [LForeignDecl id], - hs_warnds :: [LWarnDecl id], - hs_annds :: [LAnnDecl id], - hs_ruleds :: [LRuleDecl id], + hs_defds :: [LDefaultDecl id], + hs_fords :: [LForeignDecl id], + hs_warnds :: [LWarnDecl id], + hs_annds :: [LAnnDecl id], + hs_ruleds :: [LRuleDecl id], + hs_vects :: [LVectDecl id], - hs_docs :: [LDocDecl] + hs_docs :: [LDocDecl] } deriving (Data, Typeable) emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a @@ -154,49 +158,52 @@ emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], - hs_fords = [], hs_warnds = [], hs_ruleds = [], + hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], hs_valds = error "emptyGroup hs_valds: Can't happen", hs_docs = [] } appendGroups :: HsGroup a -> HsGroup a -> HsGroup a appendGroups HsGroup { - hs_valds = val_groups1, - hs_tyclds = tyclds1, - hs_instds = instds1, + hs_valds = val_groups1, + hs_tyclds = tyclds1, + hs_instds = instds1, hs_derivds = derivds1, - hs_fixds = fixds1, - hs_defds = defds1, - hs_annds = annds1, - hs_fords = fords1, - hs_warnds = warnds1, - hs_ruleds = rulds1, + hs_fixds = fixds1, + hs_defds = defds1, + hs_annds = annds1, + hs_fords = fords1, + hs_warnds = warnds1, + hs_ruleds = rulds1, + hs_vects = vects1, hs_docs = docs1 } HsGroup { - hs_valds = val_groups2, - hs_tyclds = tyclds2, - hs_instds = instds2, + hs_valds = val_groups2, + hs_tyclds = tyclds2, + hs_instds = instds2, hs_derivds = derivds2, - hs_fixds = fixds2, - hs_defds = defds2, - hs_annds = annds2, - hs_fords = fords2, - hs_warnds = warnds2, - hs_ruleds = rulds2, - hs_docs = docs2 } + hs_fixds = fixds2, + hs_defds = defds2, + hs_annds = annds2, + hs_fords = fords2, + hs_warnds = warnds2, + hs_ruleds = rulds2, + hs_vects = vects2, + hs_docs = docs2 } = HsGroup { - hs_valds = val_groups1 `plusHsValBinds` val_groups2, - hs_tyclds = tyclds1 ++ tyclds2, - hs_instds = instds1 ++ instds2, + hs_valds = val_groups1 `plusHsValBinds` val_groups2, + hs_tyclds = tyclds1 ++ tyclds2, + hs_instds = instds1 ++ instds2, hs_derivds = derivds1 ++ derivds2, - hs_fixds = fixds1 ++ fixds2, - hs_annds = annds1 ++ annds2, - hs_defds = defds1 ++ defds2, - hs_fords = fords1 ++ fords2, - hs_warnds = warnds1 ++ warnds2, - hs_ruleds = rulds1 ++ rulds2, - hs_docs = docs1 ++ docs2 } + hs_fixds = fixds1 ++ fixds2, + hs_annds = annds1 ++ annds2, + hs_defds = defds1 ++ defds2, + hs_fords = fords1 ++ fords2, + hs_warnds = warnds1 ++ warnds2, + hs_ruleds = rulds1 ++ rulds2, + hs_vects = vects1 ++ vects2, + hs_docs = docs1 ++ docs2 } \end{code} \begin{code} @@ -209,6 +216,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where ppr (ForD fd) = ppr fd ppr (SigD sd) = ppr sd ppr (RuleD rd) = ppr rd + ppr (VectD vect) = ppr vect ppr (WarningD wd) = ppr wd ppr (AnnD ad) = ppr ad ppr (SpliceD dd) = ppr dd @@ -225,11 +233,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where hs_annds = ann_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls }) + hs_ruleds = rule_decls, + hs_vects = vect_decls }) = vcat_mb empty [ppr_ds fix_decls, ppr_ds default_decls, ppr_ds deprec_decls, ppr_ds ann_decls, ppr_ds rule_decls, + ppr_ds vect_decls, if isEmptyValBinds val_decls then Nothing else Just (ppr val_decls), @@ -996,6 +1006,47 @@ instance OutputableBndr name => Outputable (RuleBndr name) where ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty \end{code} + +%************************************************************************ +%* * +\subsection{Vectorisation declarations} +%* * +%************************************************************************ + +A vectorisation pragma + + {-# VECTORISE f = closure1 g (scalar_map g) #-} OR + {-# VECTORISE SCALAR f #-} + +Note [Typechecked vectorisation pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In case of the first variant of vectorisation pragmas (with an explicit expression), +we need to infer the type of that expression during type checking and then keep that type +around until vectorisation, so that it can be checked against the *vectorised* type of 'f'. +(We cannot determine vectorised types during type checking due to internal information of +the vectoriser being needed.) + +To this end, we annotate the 'Id' of 'f' (the variable mentioned in the PRAGMA) with the +inferred type of the expression. This is slightly dodgy, as this is really the type of +'$v_f' (the name of the vectorised function). + +\begin{code} +type LVectDecl name = Located (VectDecl name) + +data VectDecl name + = HsVect + (Located name) + (Maybe (LHsExpr name)) -- 'Nothing' => SCALAR declaration + deriving (Data, Typeable) + +instance OutputableBndr name => Outputable (VectDecl name) where + ppr (HsVect v rhs) + = sep [text "{-# VECTORISE" <+> ppr v, + nest 4 (case rhs of + Nothing -> text "SCALAR #-}" + Just rhs -> pprExpr (unLoc rhs) <+> text "#-}") ] +\end{code} + %************************************************************************ %* * \subsection[DocDecl]{Document comments} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 3ef4bff177..bf75f4ccf4 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -20,7 +20,7 @@ module HsUtils( mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, - coiToHsWrapper, mkHsDictLet, + coiToHsWrapper, mkHsLams, mkHsDictLet, mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, @@ -159,8 +159,11 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) mkMatchGroup :: [LMatch id] -> MatchGroup id mkMatchGroup matches = MatchGroup matches placeHolderType +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr + mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id -mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictionary terms etc, so no locations diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1317441c00..494cc44a68 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -32,7 +32,7 @@ module DynFlags ( Option(..), showOpt, DynLibLoader(..), fFlags, fLangFlags, xFlags, - DPHBackend(..), dphPackage, + DPHBackend(..), dphPackageMaybe, wayNames, -- ** Manipulating DynFlags @@ -101,6 +101,7 @@ import Data.Char import Data.List import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe import System.FilePath import System.IO ( stderr, hPutChar ) @@ -156,6 +157,7 @@ data DynFlag | Opt_D_dump_cs_trace -- Constraint solver in type checker | Opt_D_dump_tc_trace | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect @@ -1262,6 +1264,7 @@ dynamic_flags = [ , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) , Flag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + , Flag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) @@ -2014,18 +2017,15 @@ data DPHBackend = DPHPar -- "dph-par" setDPHBackend :: DPHBackend -> DynP () setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend } --- Query the DPH backend package to be used by the vectoriser. +-- Query the DPH backend package to be used by the vectoriser and desugaring of DPH syntax. -- -dphPackage :: DynFlags -> PackageId -dphPackage dflags +dphPackageMaybe :: DynFlags -> Maybe PackageId +dphPackageMaybe dflags = case dphBackend dflags of - DPHPar -> dphParPackageId - DPHSeq -> dphSeqPackageId - DPHThis -> thisPackage dflags - DPHNone -> ghcError (CmdLineError dphBackendError) - -dphBackendError :: String -dphBackendError = "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq" + DPHPar -> Just dphParPackageId + DPHSeq -> Just dphSeqPackageId + DPHThis -> Just (thisPackage dflags) + DPHNone -> Nothing setMainIs :: String -> DynP () setMainIs arg diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 312772eff8..582b80da6c 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -161,9 +161,9 @@ import Data.IORef newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do { eps_var <- newIORef initExternalPackageState - ; us <- mkSplitUniqSupply 'r' - ; nc_var <- newIORef (initNameCache us knownKeyNames) - ; fc_var <- newIORef emptyUFM + ; us <- mkSplitUniqSupply 'r' + ; nc_var <- newIORef (initNameCache us knownKeyNames) + ; fc_var <- newIORef emptyUFM ; mlc_var <- newIORef emptyModuleEnv ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, @@ -179,12 +179,13 @@ newHscEnv dflags hsc_type_env_var = Nothing } ) } -knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, - -- where templateHaskellNames are defined -knownKeyNames = map getName wiredInThings - ++ basicKnownKeyNames +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, + -- where templateHaskellNames are defined +knownKeyNames + = map getName wiredInThings + ++ basicKnownKeyNames #ifdef GHCI - ++ templateHaskellNames + ++ templateHaskellNames #endif -- ----------------------------------------------------------------------------- @@ -1207,6 +1208,7 @@ mkModGuts mod binds = ModGuts { mg_insts = [], mg_fam_insts = [], mg_rules = [], + mg_vect_decls = [], mg_binds = binds, mg_foreign = NoStubs, mg_warns = NoWarnings, diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 5d53739d1f..3673b3ee7a 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -130,7 +130,7 @@ import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) import IfaceSyn -import CoreSyn ( CoreRule ) +import CoreSyn ( CoreRule, CoreVect ) import Maybes ( orElse, expectJust, catMaybes ) import Outputable import BreakArray @@ -738,9 +738,11 @@ data ModGuts mg_binds :: ![CoreBind], -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_warns :: !Warnings, -- ^ Warnings declared in the module - mg_anns :: [Annotation], -- ^ Annotations declared in this module - mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module + mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module + -- (produced by desugarer & consumed by vectoriser) mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module -- The next two fields are unusual, because they give instance diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 5e6535678e..5c41d7238d 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -485,6 +485,8 @@ data Token | IToptions_prag String | ITinclude_prag String | ITlanguage_prag + | ITvect_prag + | ITvect_scalar_prag | ITdotdot -- reserved symbols | ITcolon @@ -2275,13 +2277,14 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("generated", token ITgenerated_prag), ("core", token ITcore_prag), ("unpack", token ITunpack_prag), - ("ann", token ITann_prag)]) + ("ann", token ITann_prag), + ("vectorize", token ITvect_prag)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), ("specialize inline", token (ITspec_inline_prag True)), - ("specialize notinline", token (ITspec_inline_prag False))]) - + ("specialize notinline", token (ITspec_inline_prag False)), + ("vectorize scalar", token ITvect_scalar_prag)]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of @@ -2300,6 +2303,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) canonical prag' = case prag' of "noinline" -> "notinline" "specialise" -> "specialize" + "vectorise" -> "vectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s)) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index a0cc96417c..bfadfbaff8 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -266,6 +266,8 @@ incorrect. '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } '{-# ANN' { L _ ITann_prag } + '{-# VECTORISE' { L _ ITvect_prag } + '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -563,6 +565,8 @@ topdecl :: { OrdList (LHsDecl RdrName) } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) } + | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) } | annotation { unitOL $1 } | decl { unLoc $1 } diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs index 48981b3ab5..867e79d99a 100644 --- a/compiler/prelude/PrelInfo.lhs +++ b/compiler/prelude/PrelInfo.lhs @@ -8,23 +8,23 @@ module PrelInfo ( wiredInIds, ghcPrimIds, primOpRules, builtinRules, - ghcPrimExports, - wiredInThings, basicKnownKeyNames, - primOpId, - - -- Random other things - maybeCharLikeCon, maybeIntLikeCon, + ghcPrimExports, + wiredInThings, basicKnownKeyNames, + primOpId, + + -- Random other things + maybeCharLikeCon, maybeIntLikeCon, - -- Class categories - isNumericClass, isStandardClass + -- Class categories + isNumericClass, isStandardClass ) where #include "HsVersions.h" -import PrelNames ( basicKnownKeyNames, - hasKey, charDataConKey, intDataConKey, - numericClassKeys, standardClassKeys ) +import PrelNames ( basicKnownKeyNames, + hasKey, charDataConKey, intDataConKey, + numericClassKeys, standardClassKeys ) import PrelRules import PrimOp ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag ) import DataCon ( DataCon ) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 4d3c446a62..f92d94e28d 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -89,20 +89,27 @@ isUnboundName name = name `hasKey` unboundKey %************************************************************************ -%* * +%* * \subsection{Known key Names} -%* * +%* * %************************************************************************ This section tells what the compiler knows about the assocation of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. +The names for DPH can come from one of multiple backend packages. At the point where +'basicKnownKeyNames' is used, we don't know which backend it will be. Hence, we list +the names for multiple backends. That works out fine, although they use the same uniques, +as we are guaranteed to only load one backend; hence, only one of the different names +sharing a unique will be used. + \begin{code} basicKnownKeyNames :: [Name] basicKnownKeyNames = genericTyConNames ++ typeableClassNames + ++ dphKnownKeyNames dphSeqPackageId ++ dphKnownKeyNames dphParPackageId ++ [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, runMainIOName, @@ -149,7 +156,6 @@ basicKnownKeyNames -- Enum stuff enumFromName, enumFromThenName, enumFromThenToName, enumFromToName, - enumFromToPName, enumFromThenToPName, -- Monad stuff thenIOName, bindIOName, returnIOName, failIOName, @@ -187,11 +193,6 @@ basicKnownKeyNames dollarName, -- The ($) apply function - -- Parallel array operations - nullPName, lengthPName, replicatePName, singletonPName, mapPName, - filterPName, zipPName, crossMapPName, indexPName, - toPName, emptyPName, appPName, - -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, @@ -224,6 +225,20 @@ basicKnownKeyNames genericTyConNames :: [Name] genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] + +-- Know names from the DPH package which vary depending on the selected DPH backend. +-- +dphKnownKeyNames :: PackageId -> [Name] +dphKnownKeyNames dphPkg + = map ($ dphPkg) + [ + -- Parallel array operations + nullPName, lengthPName, replicatePName, singletonPName, mapPName, + filterPName, zipPName, crossMapPName, indexPName, + toPName, emptyPName, appPName, + enumFromToPName, enumFromThenToPName + + ] \end{code} @@ -242,7 +257,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_MAGIC, gHC_CLASSES, gHC_BASE, gHC_ENUM, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_PARR, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL, @@ -265,10 +280,9 @@ gHC_READ = mkBaseModule (fsLit "GHC.Read") gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") -gHC_LIST = mkBaseModule (fsLit "GHC.List") -gHC_PARR = mkBaseModule (fsLit "GHC.PArr") -gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") -dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") +gHC_LIST = mkBaseModule (fsLit "GHC.List") +gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") +dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") dATA_EITHER = mkBaseModule (fsLit "Data.Either") dATA_STRING = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") @@ -304,6 +318,12 @@ rANDOM = mkBaseModule (fsLit "System.Random") gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") +gHC_PARR :: PackageId -> Module +gHC_PARR pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel")) + +gHC_PARR' :: Module +gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") + mAIN, rOOT_MAIN :: Module mAIN = mkMainModule_ mAIN_NAME rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation @@ -739,21 +759,21 @@ readClassName = clsQual gHC_READ (fsLit "Read") readClassKey enumFromToPName, enumFromThenToPName, nullPName, lengthPName, singletonPName, replicatePName, mapPName, filterPName, zipPName, crossMapPName, indexPName, toPName, - emptyPName, appPName :: Name -enumFromToPName = varQual gHC_PARR (fsLit "enumFromToP") enumFromToPIdKey -enumFromThenToPName= varQual gHC_PARR (fsLit "enumFromThenToP") enumFromThenToPIdKey -nullPName = varQual gHC_PARR (fsLit "nullP") nullPIdKey -lengthPName = varQual gHC_PARR (fsLit "lengthP") lengthPIdKey -singletonPName = varQual gHC_PARR (fsLit "singletonP") singletonPIdKey -replicatePName = varQual gHC_PARR (fsLit "replicateP") replicatePIdKey -mapPName = varQual gHC_PARR (fsLit "mapP") mapPIdKey -filterPName = varQual gHC_PARR (fsLit "filterP") filterPIdKey -zipPName = varQual gHC_PARR (fsLit "zipP") zipPIdKey -crossMapPName = varQual gHC_PARR (fsLit "crossMapP") crossMapPIdKey -indexPName = varQual gHC_PARR (fsLit "!:") indexPIdKey -toPName = varQual gHC_PARR (fsLit "toP") toPIdKey -emptyPName = varQual gHC_PARR (fsLit "emptyP") emptyPIdKey -appPName = varQual gHC_PARR (fsLit "+:+") appPIdKey + emptyPName, appPName :: PackageId -> Name +enumFromToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromToP") enumFromToPIdKey +enumFromThenToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromThenToP") enumFromThenToPIdKey +nullPName pkg = varQual (gHC_PARR pkg) (fsLit "nullP") nullPIdKey +lengthPName pkg = varQual (gHC_PARR pkg) (fsLit "lengthP") lengthPIdKey +singletonPName pkg = varQual (gHC_PARR pkg) (fsLit "singletonP") singletonPIdKey +replicatePName pkg = varQual (gHC_PARR pkg) (fsLit "replicateP") replicatePIdKey +mapPName pkg = varQual (gHC_PARR pkg) (fsLit "mapP") mapPIdKey +filterPName pkg = varQual (gHC_PARR pkg) (fsLit "filterP") filterPIdKey +zipPName pkg = varQual (gHC_PARR pkg) (fsLit "zipP") zipPIdKey +crossMapPName pkg = varQual (gHC_PARR pkg) (fsLit "crossMapP") crossMapPIdKey +indexPName pkg = varQual (gHC_PARR pkg) (fsLit "!:") indexPIdKey +toPName pkg = varQual (gHC_PARR pkg) (fsLit "toP") toPIdKey +emptyPName pkg = varQual (gHC_PARR pkg) (fsLit "emptyP") emptyPIdKey +appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPIdKey -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index f77b272b31..db2ea1b55e 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -169,8 +169,10 @@ doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon parrTyConName, parrDataConName :: Name -parrTyConName = mkWiredInTyConName BuiltInSyntax gHC_PARR (fsLit "[::]") parrTyConKey parrTyCon -parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR (fsLit "PArr") parrDataConKey parrDataCon +parrTyConName = mkWiredInTyConName BuiltInSyntax + gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon +parrDataConName = mkWiredInDataConName UserSyntax + gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR:: RdrName @@ -600,7 +602,7 @@ mkPArrFakeCon arity = data_con tyvar = head alphaTyVars tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) - name = mkWiredInName gHC_PARR (mkDataOccFS nameStr) unique + name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique (ADataCon data_con) UserSyntax unique = mkPArrDataConUnique arity diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 2ce2170f9b..725baeb04f 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -97,6 +97,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_docs = docs }) = do { -- (A) Process the fixity declarations, creating a mapping from @@ -169,12 +170,13 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $ - rnList rnHsRuleDecl rule_decls ; - -- Inside RULES, scoped type variables are on - (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; - (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ; - (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ; - (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ; + rnList rnHsRuleDecl rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ; + (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ; -- Haddock docs; no free vars rn_docs <- mapM (wrapLocM rnDocDecl) docs ; @@ -190,13 +192,14 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, hs_annds = rn_ann_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, + hs_vects = rn_vect_decls, hs_docs = rn_docs } ; tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ; other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7] ; + src_fvs5, src_fvs6, src_fvs7, src_fvs8] ; -- It is tiresome to gather the binders from type and class decls src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; @@ -658,6 +661,25 @@ badRuleLhsErr name lhs bad_e %********************************************************* +%* * +\subsection{Vectorisation declarations} +%* * +%********************************************************* + +\begin{code} +rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) +rnHsVectDecl (HsVect var Nothing) + = do { var' <- wrapLocM lookupTopBndrRn var + ; return (HsVect var' Nothing, unitFV (unLoc var')) + } +rnHsVectDecl (HsVect var (Just rhs)) + = do { var' <- wrapLocM lookupTopBndrRn var + ; (rhs', fv_rhs) <- rnLExpr rhs + ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var') + } +\end{code} + +%********************************************************* %* * \subsection{Type, class and iface sig declarations} %* * @@ -1214,6 +1236,8 @@ add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds = addl (gp { hs_annds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds +add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds + = addl (gp { hs_vects = L l d : ts }) ds add gp l (DocD d) ds = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 0b8ea1e4a1..bb598c6f2a 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -58,7 +58,7 @@ import CoreUtils import CoreLint ( lintCoreBindings ) import PrelNames ( iNTERACTIVE ) import HscTypes -import Module ( PackageId, Module ) +import Module ( Module ) import DynFlags import StaticFlags import Rules ( RuleBase ) @@ -219,7 +219,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreCSE | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules -- matching this string - | CoreDoVectorisation PackageId + | CoreDoVectorisation | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things @@ -240,10 +240,10 @@ coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec coreDumpFlag CoreCSE = Just Opt_D_dump_cse -coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect -coreDumpFlag CoreDesugar = Just Opt_D_dump_ds -coreDumpFlag CoreTidy = Just Opt_D_dump_simpl -coreDumpFlag CorePrep = Just Opt_D_dump_prep +coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep coreDumpFlag CoreDoPrintCore = Nothing coreDumpFlag (CoreDoRuleCheck {}) = Nothing @@ -264,9 +264,9 @@ instance Outputable CoreToDo where ppr CoreDoSpecialising = ptext (sLit "Specialise") ppr CoreDoSpecConstr = ptext (sLit "SpecConstr") ppr CoreCSE = ptext (sLit "Common sub-expression") - ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation") - ppr CoreDesugar = ptext (sLit "Desugar") - ppr CoreTidy = ptext (sLit "Tidy Core") + ppr CoreDoVectorisation = ptext (sLit "Vectorisation") + ppr CoreDesugar = ptext (sLit "Desugar") + ppr CoreTidy = ptext (sLit "Tidy Core") ppr CorePrep = ptext (sLit "CorePrep") ppr CoreDoPrintCore = ptext (sLit "Print core") ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") @@ -379,9 +379,8 @@ getCoreToDo dflags ] vectorisation - = runWhen (dopt Opt_Vectorise dflags) - $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ] - + = runWhen (dopt Opt_Vectorise dflags) $ + CoreDoPasses [ simpl_gently, CoreDoVectorisation ] -- By default, we have 2 phases before phase 0. diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index b64de6e154..1a634d5e0e 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -123,8 +123,8 @@ doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} specConstrProgram -doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} - vectorise be +doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} + vectorise doCorePass CoreDoGlomBinds = doPassDM glomBinds doCorePass CoreDoPrintCore = observe printCore diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index c9f2a2d3ca..0da6cdb3b6 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -7,7 +7,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcPolyBinds, - PragFun, tcSpecPrags, mkPragFun, + PragFun, tcSpecPrags, tcVectDecls, mkPragFun, TcSigInfo(..), SigFun, mkSigFun, badBootDeclErr ) where @@ -35,6 +35,7 @@ import NameSet import NameEnv import SrcLoc import Bag +import ListSetOps import ErrUtils import Digraph import Maybes @@ -577,7 +578,65 @@ impSpecErr :: Name -> SDoc impSpecErr name = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name)) 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma") - , ptext (sLit "(or you compiled its definining module without -O)")]) + , ptext (sLit "(or you compiled its defining module without -O)")]) + +-------------- +tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId] +tcVectDecls decls + = do { decls' <- mapM (wrapLocM tcVect) decls + ; let ids = [unLoc id | L _ (HsVect id _) <- decls'] + dups = findDupsEq (==) ids + ; mapM_ reportVectDups dups + ; return decls' + } + where + reportVectDups (first:_second:_more) + = addErrAt (getSrcSpan first) $ + ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first + reportVectDups _ = return () + +-------------- +tcVect :: VectDecl Name -> TcM (VectDecl TcId) +-- We can't typecheck the expression of a vectorisation declaration against the vectorised type +-- of the original definition as this requires internals of the vectoriser not available during +-- type checking. Instead, we infer the type of the expression and leave it to the vectoriser +-- to check the compatibility of the Core types. +tcVect (HsVect name Nothing) + = addErrCtxt (vectCtxt name) $ + do { id <- wrapLocM tcLookupId name + ; return (HsVect id Nothing) + } +tcVect (HsVect name@(L loc _) (Just rhs)) + = addErrCtxt (vectCtxt name) $ + do { _id <- wrapLocM tcLookupId name -- need to ensure that the name is already defined + + -- turn the vectorisation declaration into a single non-recursive binding + ; let bind = L loc $ mkFunBind name [mkSimpleMatch [] rhs] + sigFun = const Nothing + pragFun = mkPragFun [] (unitBag bind) + + -- perform type inference (including generalisation) + ; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind] + + ; traceTc "tcVect inferred type" $ ppr (varType id') + + -- add the type variable and dictionary bindings produced by type generalisation to the + -- right-hand side of the vectorisation declaration + ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds + ; let [bind'] = bagToList actualBinds + MatchGroup + [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))] + _ = (fun_matches . unLoc) bind' + rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs') + + -- We return the type-checked 'Id', to propagate the inferred signature + -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls + ; return $ HsVect (L loc id') (Just rhsWrapped) + } + +vectCtxt :: Located Name -> SDoc +vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name + -------------- -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 3f5a258ed3..6bb0820823 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -49,6 +49,7 @@ import TysWiredIn import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames +import Module import DynFlags import SrcLoc import Util @@ -737,7 +738,7 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) - enumFromToPName elt_ty + (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak ; return $ mkHsWrapCoI coi (PArrSeq enum_from_to (FromTo expr1' expr2')) } @@ -747,7 +748,7 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) - enumFromThenToPName elt_ty + (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak ; return $ mkHsWrapCoI coi (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index b7b572f828..122b743742 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -269,15 +269,16 @@ zonkTopLExpr e = zonkLExpr emptyZonkEnv e zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> NameSet - -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] - -> TcM ([Id], - Bag EvBind, - Bag (LHsBind Id), - [LForeignDecl Id], - [LTcSpecPrag], - [LRuleDecl Id]) -zonkTopDecls ev_binds binds sig_ns rules imp_specs fords - = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds + -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] + -> TcM ([Id], + Bag EvBind, + Bag (LHsBind Id), + [LForeignDecl Id], + [LTcSpecPrag], + [LRuleDecl Id], + [LVectDecl Id]) +zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords + = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds -- Warn about missing signatures -- Do this only when we we have a type to offer @@ -286,11 +287,12 @@ zonkTopDecls ev_binds binds sig_ns rules imp_specs fords | otherwise = noSigWarn ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules + -- Top level is implicitly recursive + ; rules' <- zonkRules env2 rules + ; vects' <- zonkVects env2 vects ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } + ; fords' <- zonkForeignExports env2 fords + ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') } --------------------------------------------- zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) @@ -1006,6 +1008,21 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} +\begin{code} +zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] +zonkVects env = mappM (wrapLocM (zonkVect env)) + +zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) +zonkVect env (HsVect v Nothing) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; return $ HsVect v' Nothing + } +zonkVect env (HsVect v (Just e)) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; e' <- zonkLExpr env e + ; return $ HsVect v' (Just e') + } +\end{code} %************************************************************************ %* * diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 3f166cfe04..4889e3835b 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -365,7 +365,8 @@ solveInteract inert ws -> (ct,evVarPred ev)) ws) , text "inert = " <+> ppr inert ] - ; (flag, inert_ret) <- foldlBagM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) ws + ; (flag, inert_ret) <- foldrBagM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) ws + -- use foldr to preserve the order ; traceTcS "solveInteract, after clever canonicalization (and interaction):" $ vcat [ text "No interaction happened = " <+> ppr flag @@ -376,12 +377,11 @@ solveInteract inert ws tryPreSolveAndInteract :: SimplContext -> DynFlags - -> (Bool, InertSet) -> FlavoredEvVar + -> (Bool, InertSet) -> TcS (Bool, InertSet) -- Returns: True if it was able to discharge this constraint AND all previous ones -tryPreSolveAndInteract sctx dyn_flags (all_previous_discharged, inert) - flavev@(EvVarX ev_var fl) +tryPreSolveAndInteract sctx dyn_flags flavev@(EvVarX ev_var fl) (all_previous_discharged, inert) = do { let inert_cts = get_inert_cts (evVarPred ev_var) ; this_one_discharged <- dischargeFromCCans inert_cts flavev @@ -391,8 +391,7 @@ tryPreSolveAndInteract sctx dyn_flags (all_previous_discharged, inert) else do { extra_cts <- mkCanonical fl ev_var - ; inert_ret <- solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) - inert extra_cts + ; inert_ret <- solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) extra_cts inert ; return (False, inert_ret) } } where @@ -439,16 +438,16 @@ canonicals. If so, we add nothing to the returned canonical constraints. \begin{code} -solveOne :: InertSet -> WorkItem -> TcS InertSet -solveOne inerts workItem +solveOne :: WorkItem -> InertSet -> TcS InertSet +solveOne workItem inerts = do { dyn_flags <- getDynFlags - ; solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) inerts workItem + ; solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) workItem inerts } ----------------- solveInteractWithDepth :: (Int, Int, [WorkItem]) - -> InertSet -> WorkList -> TcS InertSet -solveInteractWithDepth ctxt@(max_depth,n,stack) inert ws + -> WorkList -> InertSet -> TcS InertSet +solveInteractWithDepth ctxt@(max_depth,n,stack) ws inert | isEmptyWorkList ws = return inert @@ -458,26 +457,27 @@ solveInteractWithDepth ctxt@(max_depth,n,stack) inert ws | otherwise = do { traceTcS "solveInteractWithDepth" $ vcat [ text "Current depth =" <+> ppr n - , text "Max depth =" <+> ppr max_depth ] + , text "Max depth =" <+> ppr max_depth + , text "ws =" <+> ppr ws ] -- Solve equalities first ; let (eqs, non_eqs) = Bag.partitionBag isCTyEqCan ws - ; is_from_eqs <- Bag.foldlBagM (solveOneWithDepth ctxt) inert eqs - ; Bag.foldlBagM (solveOneWithDepth ctxt) is_from_eqs non_eqs } + ; is_from_eqs <- Bag.foldrBagM (solveOneWithDepth ctxt) inert eqs + ; Bag.foldrBagM (solveOneWithDepth ctxt) is_from_eqs non_eqs } + -- use foldr to preserve the order ------------------ -- Fully interact the given work item with an inert set, and return a -- new inert set which has assimilated the new information. solveOneWithDepth :: (Int, Int, [WorkItem]) - -> InertSet -> WorkItem -> TcS InertSet -solveOneWithDepth (max_depth, depth, stack) inert work + -> WorkItem -> InertSet -> TcS InertSet +solveOneWithDepth (max_depth, depth, stack) work inert = do { traceFireTcS depth (text "Solving {" <+> ppr work) ; (new_inert, new_work) <- runSolverPipeline depth thePipeline inert work -- Recursively solve the new work generated -- from workItem, with a greater depth - ; res_inert <- solveInteractWithDepth (max_depth, depth+1, work:stack) - new_inert new_work + ; res_inert <- solveInteractWithDepth (max_depth, depth+1, work:stack) new_work new_inert ; traceFireTcS depth (text "Done }" <+> ppr work) @@ -796,7 +796,8 @@ data WhichComesFromInert = LeftComesFromInert | RightComesFromInert interactWithInertEqsStage :: SimplifierStage interactWithInertEqsStage depth workItem inert - = Bag.foldlBagM (interactNext depth) initITR (inert_eqs inert) + = Bag.foldrBagM (interactNext depth) initITR (inert_eqs inert) + -- use foldr to preserve the order where initITR = SR { sr_inerts = inert { inert_eqs = emptyCCan } , sr_new_work = emptyWorkList @@ -814,7 +815,8 @@ interactWithInertsStage depth workItem inert initITR = SR { sr_inerts = inert_residual , sr_new_work = emptyWorkList , sr_stop = ContinueWith workItem } - in Bag.foldlBagM (interactNext depth) initITR relevant + in Bag.foldrBagM (interactNext depth) initITR relevant + -- use foldr to preserve the order where getISRelevant :: CanonicalCt -> InertSet -> (CanonicalCts, InertSet) getISRelevant (CFrozenErr {}) is = (emptyCCan, is) @@ -841,8 +843,8 @@ interactWithInertsStage depth workItem inert , inert_ips = emptyCCanMap , inert_funeqs = emptyCCanMap }) -interactNext :: SubGoalDepth -> StageResult -> AtomicInert -> TcS StageResult -interactNext depth it inert +interactNext :: SubGoalDepth -> AtomicInert -> StageResult -> TcS StageResult +interactNext depth inert it | ContinueWith work_item <- sr_stop it = do { let inerts = sr_inerts it diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 38c4d7a027..3de19edbaa 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -2,7 +2,7 @@ % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcModule]{Typechecking a whole module} +\section[TcMovectle]{Typechecking a whole module} \begin{code} module TcRnDriver ( @@ -328,6 +328,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], + mg_vect_decls = [], mg_anns = [], mg_binds = core_binds, @@ -390,30 +391,32 @@ tcRnSrcDecls boot_iface decls -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures - let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, - tcg_binds = binds, - tcg_sigs = sig_ns, - tcg_ev_binds = cur_ev_binds, - tcg_imp_specs = imp_specs, - tcg_rules = rules, - tcg_fords = fords } = tcg_env + let { (tcg_env, _) = tc_envs + ; TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_sigs = sig_ns, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_vects = vects, + tcg_fords = fords } = tcg_env ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - (bind_ids, ev_binds', binds', fords', imp_specs', rules') - <- zonkTopDecls all_ev_binds binds sig_ns rules imp_specs fords ; - - let { final_type_env = extendTypeEnvWithIds type_env bind_ids - ; tcg_env' = tcg_env { tcg_binds = binds', - tcg_ev_binds = ev_binds', - tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_fords = fords' } } ; - - setGlobalTypeEnv tcg_env' final_type_env + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ; + + let { final_type_env = extendTypeEnvWithIds type_env bind_ids + ; tcg_env' = tcg_env { tcg_binds = binds', + tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', + tcg_rules = rules', + tcg_vects = vects', + tcg_fords = fords' } } ; + + setGlobalTypeEnv tcg_env' final_type_env } } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -480,6 +483,7 @@ tcRnHsBootDecls decls hs_fords = for_decls, hs_defds = def_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_annds = _, hs_valds = val_binds }) <- rnTopSrcDecls first_group ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { @@ -492,6 +496,7 @@ tcRnHsBootDecls decls ; mapM_ (badBootDecl "foreign") for_decls ; mapM_ (badBootDecl "default") def_decls ; mapM_ (badBootDecl "rule") rule_decls + ; mapM_ (badBootDecl "vect") vect_decls -- Typecheck type/class decls ; traceTc "Tc2" empty @@ -836,6 +841,7 @@ tcTopSrcDecls boot_details hs_defds = default_decls, hs_annds = annotation_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls @@ -878,21 +884,24 @@ tcTopSrcDecls boot_details setLclTypeEnv tcl_env $ do { -- Environment doesn't change now - -- Second pass over class and instance declarations, + -- Second pass over class and instance declarations, traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; + inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; - -- Foreign exports + -- Foreign exports traceTc "Tc7" empty ; - (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Annotations - annotations <- tcAnnotations annotation_decls ; + annotations <- tcAnnotations annotation_decls ; - -- Rules - rules <- tcRules rule_decls ; + -- Rules + rules <- tcRules rule_decls ; - -- Wrap up + -- Vectorisation declarations + vects <- tcVectDecls vect_decls ; + + -- Wrap up traceTc "Tc7a" empty ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` @@ -904,15 +913,17 @@ tcTopSrcDecls boot_details ; sig_names = mkNameSet (collectHsValBinders val_binds) `minusNameSet` getTypeSigNames val_binds - -- Extend the GblEnv with the (as yet un-zonked) - -- bindings, rules, foreign decls - ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds - , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ specs3 + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds + , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ + specs3 , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names - , tcg_rules = tcg_rules tcg_env ++ rules - , tcg_anns = tcg_anns tcg_env ++ annotations - , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; - return (tcg_env', tcl_env) + , tcg_rules = tcg_rules tcg_env ++ rules + , tcg_vects = tcg_vects tcg_env ++ vects + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; + return (tcg_env', tcl_env) }}}}}} \end{code} @@ -1563,18 +1574,20 @@ tcCoreDump mod_guts -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_imports = imports }) + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_vects = vects, + tcg_imports = imports }) = vcat [ ppr_types insts type_env , ppr_tycons fam_insts type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , vcat (map ppr rules) - , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext (sLit "Dependent modules:") <+> - ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) + , ppr_insts insts + , ppr_fam_insts fam_insts + , vcat (map ppr rules) + , vcat (map ppr vects) + , ppr_gen_tycons (typeEnvTyCons type_env) + , ptext (sLit "Dependent modules:") <+> + ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) , ptext (sLit "Dependent packages:") <+> ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] where -- The two uses of sortBy are just to reduce unnecessary diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 37e1166388..ad2405b95e 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -114,11 +114,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_warns = NoWarnings, tcg_anns = [], tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_vects = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, tcg_doc_hdr = Nothing, tcg_hpc = False, tcg_main = Nothing diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index f9422a8c25..3367f06ded 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -260,9 +260,10 @@ data TcGblEnv tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_insts :: [Instance], -- ...Instances - tcg_fam_insts :: [FamInst], -- ...Family instances - tcg_rules :: [LRuleDecl Id], -- ...Rules - tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports + tcg_fam_insts :: [FamInst], -- ...Family instances + tcg_rules :: [LRuleDecl Id], -- ...Rules + tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports + tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the @@ -714,10 +715,10 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 }) , wc_insol = n1 `unionBags` n2 } addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints -addFlats wc wevs = wc { wc_flat = wevs `unionBags` wc_flat wc } +addFlats wc wevs = wc { wc_flat = wc_flat wc `unionBags` wevs } addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints -addImplics wc implic = wc { wc_impl = implic `unionBags` wc_impl wc } +addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } instance Outputable WantedConstraints where ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n}) @@ -883,11 +884,12 @@ wantedToFlavored (EvVarX v wl) = EvVarX v (Wanted wl) keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar keepWanted flevs - = foldlBag keep_wanted emptyBag flevs + = foldrBag keep_wanted emptyBag flevs + -- Important: use fold*r*Bag to preserve the order of the evidence variables. where - keep_wanted :: Bag WantedEvVar -> FlavoredEvVar -> Bag WantedEvVar - keep_wanted r (EvVarX ev (Wanted wloc)) = consBag (EvVarX ev wloc) r - keep_wanted r _ = r + keep_wanted :: FlavoredEvVar -> Bag WantedEvVar -> Bag WantedEvVar + keep_wanted (EvVarX ev (Wanted wloc)) r = consBag (EvVarX ev wloc) r + keep_wanted _ r = r \end{code} diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index bb0f10481a..097a112359 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -16,7 +16,7 @@ module Bag ( concatBag, foldBag, foldrBag, foldlBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, listToBag, bagToList, - foldlBagM, mapBagM, mapBagM_, + foldrBagM, foldlBagM, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM ) where @@ -171,6 +171,12 @@ foldlBag k z (UnitBag x) = k z x foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 foldlBag k z (ListBag xs) = foldl k z xs +foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b +foldrBagM _ z EmptyBag = return z +foldrBagM k z (UnitBag x) = k x z +foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 } +foldrBagM k z (ListBag xs) = foldrM k z xs + foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b foldlBagM _ z EmptyBag = return z foldlBagM k z (UnitBag x) = k z x diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index e3e9646a19..72cca6e1c6 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -1,6 +1,6 @@ {-# OPTIONS -fno-warn-missing-signatures #-} -module Vectorise( vectorise ) +module Vectorise ( vectorise ) where import Vectorise.Type.Env @@ -13,14 +13,16 @@ import Vectorise.Env import Vectorise.Monad import HscTypes hiding ( MonadThings(..) ) -import Module ( PackageId ) -import CoreSyn import CoreUnfold ( mkInlineUnfolding ) import CoreFVs +import PprCore +import CoreSyn import CoreMonad ( CoreM, getHscEnv ) +import Type import Var import Id import OccName +import DynFlags import BasicTypes ( isLoopBreaker ) import Outputable import Util ( zipLazy ) @@ -28,53 +30,58 @@ import MonadUtils import Control.Monad -debug = False -dtrace s x = if debug then pprTrace "Vectorise" s x else x -- | Vectorise a single module. --- Takes the package containing the DPH backend we're using. Eg either dph-par or dph-seq. -vectorise :: PackageId -> ModGuts -> CoreM ModGuts -vectorise backend guts - = do hsc_env <- getHscEnv - liftIO $ vectoriseIO backend hsc_env guts - - --- | Vectorise a single monad, given its HscEnv (code gen environment). -vectoriseIO :: PackageId -> HscEnv -> ModGuts -> IO ModGuts -vectoriseIO backend hsc_env guts - = do -- Get information about currently loaded external packages. - eps <- hscEPS hsc_env +-- +vectorise :: ModGuts -> CoreM ModGuts +vectorise guts + = do { hsc_env <- getHscEnv + ; liftIO $ vectoriseIO hsc_env guts + } - -- Combine vectorisation info from the current module, and external ones. - let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps +-- | 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 - -- Run the main VM computation. - Just (info', guts') <- initV backend hsc_env guts info (vectModule guts) - return (guts' { mg_vect_info = info' }) + -- 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 - = do -- Vectorise the type environment. - -- This may add new TyCons and DataCons. - -- TODO: What new binds do we get back here? - (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts) - - (_, fam_inst_env) <- readGEnv global_fam_inst_env +vectModule guts@(ModGuts { mg_types = types + , mg_binds = binds + , mg_fam_insts = fam_insts + }) + = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ + pprCoreBindings binds + + -- Vectorise the type environment. + -- This may add new TyCons and DataCons. + ; (types', new_fam_insts, tc_binds) <- vectTypeEnv types + + ; (_, fam_inst_env) <- readGEnv global_fam_inst_env -- dicts <- mapM buildPADict pa_insts -- workers <- mapM vectDataConWorkers pa_insts - -- Vectorise all the top level bindings. - binds' <- mapM vectTopBind (mg_binds guts) - - return $ guts { mg_types = types' - , mg_binds = Rec tc_binds : binds' - , mg_fam_inst_env = fam_inst_env - , mg_fam_insts = mg_fam_insts guts ++ fam_insts - } + -- Vectorise all the top level bindings. + ; binds' <- mapM vectTopBind binds + ; return $ guts { mg_types = types' + , mg_binds = Rec tc_binds : binds' + , 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 then return it unharmed. @@ -116,14 +123,14 @@ vectTopBind :: CoreBind -> VM CoreBind vectTopBind b@(NonRec var expr) = do (inline, _, expr') <- vectTopRhs [] var expr - var' <- vectTopBinder var inline expr' + var' <- vectTopBinder var inline expr' -- Vectorising the body may create other top-level bindings. - hs <- takeHoisted + hs <- takeHoisted -- To get the same functionality as the original body we project -- out its vectorised version from the closure. - cexpr <- tryConvert var var' expr + cexpr <- tryConvert var var' expr return . Rec $ (var, cexpr) : (var', expr') : hs `orElseV` @@ -132,7 +139,7 @@ vectTopBind b@(NonRec var expr) vectTopBind b@(Rec bs) = do (vars', _, exprs') - <- fixV $ \ ~(_, inlines, rhss) -> + <- fixV $ \ ~(_, inlines, rhss) -> do vars' <- sequence [vectTopBinder var inline rhs | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)] (inlines', areScalars', exprs') @@ -152,67 +159,109 @@ vectTopBind b@(Rec bs) return b where (vars, exprs) = unzip bs - mapAndUnzip3M f xs = do - ys <- mapM f xs - return $ unzip3 ys - + -- | 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 the binding, used to set the `Unfolding` of the returned `Var`. - -> VM Var -- ^ Name of the vectorised binding. - +-- +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) - - -- Make the vectorised version of binding's name, and set the unfolding used for inlining. - var' <- liftM (`setIdUnfoldingLazily` unfolding) - $ cloneId mkVectOcc var vty - - -- Add the mapping between the plain and vectorised name to the state. - defGlobalVar var var' - - return var' + = do { -- Vectorise the type attached to the var. + ; vty <- vectType (idType var) + + -- If there is a vectorisation declartion for this binding, make sure that its type + -- matches + ; vectDecl <- lookupVectDecl var + ; case vectDecl of + Nothing -> return () + Just (vdty, _) + | coreEqType vty vdty -> return () + | otherwise -> + cantVectorise ("Type mismatch in vectorisation pragma for " ++ show 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 (`setIdUnfoldingLazily` unfolding) + $ cloneId mkVectOcc 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 -> mkInlineUnfolding (Just arity) expr DontInline -> noUnfolding - -- | Vectorise the RHS of a top-level binding, in an empty local environment. -vectTopRhs - :: [Var] -- ^ Names of all functions in the rec block - -> Var -- ^ Name of the binding. - -> CoreExpr -- ^ Body of the binding. - -> VM (Inline, Bool, CoreExpr) - +-- +-- We need to distinguish three cases: +-- +-- (1) We have a (non-scalar) vectorisation declaration for the variable (which explicitly provides +-- vectorised code implemented by the user) +-- => no automatic vectorisation & instead use the user-supplied code +-- +-- (2) We have a scalar vectorisation declaration for the variable +-- => generate vectorised code that uses a scalar 'map'/'zipWith' to lift the computation +-- +-- (3) There is no vectorisation declaration for the variable +-- => perform automatic vectorisation of the RHS +-- +vectTopRhs :: [Var] -- ^ Names of all functions in the rec block + -> Var -- ^ Name of the binding. + -> CoreExpr -- ^ Body of the binding. + -> VM ( Inline -- (1) inline specification for the binding + , Bool -- (2) whether the right-hand side is a scalar computation + , CoreExpr) -- (3) the vectorised right-hand side vectTopRhs recFs var expr - = dtrace (vcat [text "vectTopRhs", ppr expr]) - $ closedV - $ do (inline, isScalar, vexpr) <- - inBind var $ vectPolyExpr (isLoopBreaker $ idOccInfo var) recFs (freeVars expr) - if isScalar - then addGlobalScalar var - else deleteGlobalScalar var - return (inline, isScalar, vectorised vexpr) - + = closedV + $ do { traceVt ("vectTopRhs of " ++ show var) $ ppr expr + + ; globalScalar <- isGlobalScalar var + ; vectDecl <- lookupVectDecl var + ; rhs globalScalar vectDecl + } + where + rhs _globalScalar (Just (_, expr')) -- Case (1) + = return (inlineMe, False, expr') + rhs True _vectDecl -- Case (2) + = return (inlineMe, True, scalarRHS) + -- FIXME: that True is not enough to register scalarness + rhs False _vectDecl -- Case (3) + = do { let fvs = freeVars expr + ; (inline, isScalar, vexpr) <- inBind var $ + vectPolyExpr (isLoopBreaker $ idOccInfo var) recFs fvs + ; if isScalar + then addGlobalScalar var + else deleteGlobalScalar var + ; return (inline, isScalar, vectorised vexpr) + } + + -- For scalar right-hand sides, we know that the original binding will remain unaltered + -- (hence, we can refer to it without risk of cycles) - cf, 'tryConvert'. + scalarRHS = panic "Vectorise.scalarRHS: not implemented yet" -- | 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 - +-- or return the original body if that doesn't work or the binding is scalar. +-- +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) `orElseV` return rhs - + = do { globalScalar <- isGlobalScalar var + ; if globalScalar + then + return rhs + else + fromVect (idType var) (Var vect_var) `orElseV` return rhs + } diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs index 04e768b075..3647a7f875 100644 --- a/compiler/vectorise/Vectorise/Builtins.hs +++ b/compiler/vectorise/Vectorise/Builtins.hs @@ -1,6 +1,6 @@ -- | Builtin types and functions used by the vectoriser. --- The source program uses functions from GHC.PArr, which the vectoriser rewrites +-- The source program uses functions from Data.Array.Parallel, which the vectoriser rewrites -- to use equivalent vectorised versions in the DPH backend packages. -- -- The `Builtins` structure holds the name of all the things in the DPH packages diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 9e78f112f9..94de62aa72 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -191,10 +191,11 @@ initBuiltins pkg $ 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)] -initBuiltinVars (Builtins { dphModules = mods }) +-- +initBuiltinVars :: Bool -- FIXME + -> Builtins -> DsM [(Var, Var)] +initBuiltinVars compilingDPH (Builtins { dphModules = mods }) = do uvars <- zipWithM externalVar umods ufs vvars <- zipWithM externalVar vmods vfs @@ -203,7 +204,7 @@ initBuiltinVars (Builtins { dphModules = mods }) ++ zip (map dataConWorkId cons) cvars ++ zip uvars vvars where - (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods) + (umods, ufs, vmods, vfs) = if compilingDPH then ([], [], [], []) else unzip4 (preludeVars mods) (cons, cmods, cfs) = unzip3 (preludeDataCons mods) defaultDataConWorkers :: [DataCon] @@ -273,12 +274,12 @@ initBuiltinBoxedTyCons builtinBoxedTyCons _ = [(tyConName intPrimTyCon, intTyCon)] - -- | Get a list of all scalar functions in the mock prelude. -initBuiltinScalars :: Builtins -> DsM [Var] -initBuiltinScalars bi - = mapM (uncurry externalVar) (preludeScalars $ dphModules bi) - +-- +initBuiltinScalars :: Bool + -> Builtins -> DsM [Var] +initBuiltinScalars True _bi = return [] +initBuiltinScalars False bi = mapM (uncurry externalVar) (preludeScalars $ dphModules bi) -- | Lookup some variable given its name and the module that contains it. externalVar :: Module -> FastString -> DsM Var diff --git a/compiler/vectorise/Vectorise/Builtins/Prelude.hs b/compiler/vectorise/Vectorise/Builtins/Prelude.hs index b578f3087c..b0f305da73 100644 --- a/compiler/vectorise/Vectorise/Builtins/Prelude.hs +++ b/compiler/vectorise/Vectorise/Builtins/Prelude.hs @@ -1,4 +1,7 @@ +-- WARNING: This module is a temporary kludge. It will soon go away entirely (once +-- VECTORISE SCALAR pragmas are fully implemented.) + -- | Mapping of prelude functions to vectorised versions. -- Functions like filterP currently have a working but naive version in GHC.PArr -- During vectorisation we replace these by calls to filterPA, which are @@ -18,38 +21,36 @@ import Module import FastString -preludeVars - :: Modules -- ^ Modules containing the DPH backens +preludeVars :: Modules -> [( Module, FastString -- Maps the original variable to the one in the DPH , Module, FastString)] -- packages that it should be rewritten to. - -preludeVars (Modules { dph_Combinators = dph_Combinators - , dph_PArray = dph_PArray +preludeVars (Modules { dph_Combinators = _dph_Combinators + , dph_PArray = _dph_PArray , dph_Prelude_Int = dph_Prelude_Int , dph_Prelude_Word8 = dph_Prelude_Word8 , dph_Prelude_Double = dph_Prelude_Double , dph_Prelude_Bool = dph_Prelude_Bool - , dph_Prelude_PArr = dph_Prelude_PArr + , dph_Prelude_PArr = _dph_Prelude_PArr }) -- Functions that work on whole PArrays, defined in GHC.PArr - = [ mk gHC_PARR (fsLit "mapP") dph_Combinators (fsLit "mapPA") - , mk gHC_PARR (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA") - , mk gHC_PARR (fsLit "zipP") dph_Combinators (fsLit "zipPA") - , mk gHC_PARR (fsLit "unzipP") dph_Combinators (fsLit "unzipPA") - , mk gHC_PARR (fsLit "filterP") dph_Combinators (fsLit "filterPA") - , mk gHC_PARR (fsLit "lengthP") dph_Combinators (fsLit "lengthPA") - , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA") - , mk gHC_PARR (fsLit "!:") dph_Combinators (fsLit "indexPA") - , mk gHC_PARR (fsLit "sliceP") dph_Combinators (fsLit "slicePA") - , mk gHC_PARR (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA") - , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA") - , mk gHC_PARR (fsLit "concatP") dph_Combinators (fsLit "concatPA") - , mk gHC_PARR (fsLit "+:+") dph_Combinators (fsLit "appPA") - , mk gHC_PARR (fsLit "emptyP") dph_PArray (fsLit "emptyPA") + = [ {- mk gHC_PARR' (fsLit "mapP") dph_Combinators (fsLit "mapPA") + , mk gHC_PARR' (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA") + , mk gHC_PARR' (fsLit "zipP") dph_Combinators (fsLit "zipPA") + , mk gHC_PARR' (fsLit "unzipP") dph_Combinators (fsLit "unzipPA") + , mk gHC_PARR' (fsLit "filterP") dph_Combinators (fsLit "filterPA") + , mk gHC_PARR' (fsLit "lengthP") dph_Combinators (fsLit "lengthPA") + , mk gHC_PARR' (fsLit "replicateP") dph_Combinators (fsLit "replicatePA") + , mk gHC_PARR' (fsLit "!:") dph_Combinators (fsLit "indexPA") + , mk gHC_PARR' (fsLit "sliceP") dph_Combinators (fsLit "slicePA") + , mk gHC_PARR' (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA") + , mk gHC_PARR' (fsLit "singletonP") dph_Combinators (fsLit "singletonPA") + , mk gHC_PARR' (fsLit "concatP") dph_Combinators (fsLit "concatPA") + , mk gHC_PARR' (fsLit "+:+") dph_Combinators (fsLit "appPA") + , mk gHC_PARR' (fsLit "emptyP") dph_PArray (fsLit "emptyPA") -- Map scalar functions to versions using closures. - , mk' dph_Prelude_Int "div" "divV" + , -} mk' dph_Prelude_Int "div" "divV" , mk' dph_Prelude_Int "mod" "modV" , mk' dph_Prelude_Int "sqrt" "sqrtV" , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA" @@ -80,6 +81,7 @@ preludeVars (Modules { dph_Combinators = dph_Combinators , mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV") , mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV") +{- -- FIXME: temporary , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA") , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA") @@ -88,7 +90,7 @@ preludeVars (Modules { dph_Combinators = dph_Combinators , mk dph_Prelude_PArr (fsLit "updateP") dph_Combinators (fsLit "updatePA") , mk dph_Prelude_PArr (fsLit "bpermuteP") dph_Combinators (fsLit "bpermutePA") , mk dph_Prelude_PArr (fsLit "indexedP") dph_Combinators (fsLit "indexedPA") - ] +-} ] where mk = (,,,) mk' mod v v' = mk mod (fsLit v) mod (fsLit v') @@ -152,7 +154,6 @@ preludeVars (Modules { dph_Combinators = dph_Combinators , mk' mod "floor" "floorV" ] - preludeScalars :: Modules -> [(Module, FastString)] preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int , dph_Prelude_Word8 = dph_Prelude_Word8 diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 70ed8c4555..9a1fd4431a 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -20,10 +20,12 @@ module Vectorise.Env ( setBoxedTyConsEnv, updVectInfo ) where + import HscTypes import InstEnv import FamInstEnv import CoreSyn +import Type import TyCon import DataCon import VarEnv @@ -70,15 +72,22 @@ emptyLocalEnv = LocalEnv { -- GlobalEnv ------------------------------------------------------------------ -- | The global environment. --- These are things the exist at top-level. +-- These are things the exist at top-level. data GlobalEnv - = GlobalEnv { + = GlobalEnv { -- | Mapping from global variables to their vectorised versions. - global_vars :: VarEnv Var + global_vars :: VarEnv Var + + -- | Mapping from global variables that have a vectorisation declaration to the right-hand + -- side of that declaration and its type. This mapping only applies to non-scalar + -- vectorisation declarations. All variables with a scalar vectorisation declaration are + -- mentioned in 'global_scalars'. + , global_vect_decls :: VarEnv (Type, CoreExpr) - -- | Purely scalar variables. Code which mentions only these - -- variables doesn't have to be lifted. - , global_scalars :: VarSet + -- | Purely scalar variables. Code which mentions only these variables doesn't have to be + -- lifted. This includes variables from the current module that have a scalar + -- vectorisation declaration and those that the vectoriser determines to be scalar. + , global_scalars :: VarSet -- | Exported variables which have a vectorised version. , global_exported_vars :: VarEnv (Var, Var) @@ -88,10 +97,10 @@ data GlobalEnv , global_tycons :: NameEnv TyCon -- | Mapping from DataCons to their vectorised versions. - , global_datacons :: NameEnv DataCon + , global_datacons :: NameEnv DataCon -- | Mapping from TyCons to their PA dfuns. - , global_pa_funs :: NameEnv Var + , global_pa_funs :: NameEnv Var -- | Mapping from TyCons to their PR dfuns. , global_pr_funs :: NameEnv Var @@ -109,24 +118,26 @@ data GlobalEnv , global_bindings :: [(Var, CoreExpr)] } - -- | Create an initial global environment -initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv -initGlobalEnv info instEnvs famInstEnvs - = GlobalEnv - { global_vars = mapVarEnv snd $ vectInfoVar info - , global_scalars = emptyVarSet - , global_exported_vars = emptyVarEnv - , global_tycons = mapNameEnv snd $ vectInfoTyCon info - , global_datacons = mapNameEnv snd $ vectInfoDataCon info - , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info - , global_pr_funs = emptyNameEnv - , global_boxed_tycons = emptyNameEnv - , global_inst_env = instEnvs - , global_fam_inst_env = famInstEnvs - , global_bindings = [] - } - +initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv +initGlobalEnv info vectDecls instEnvs famInstEnvs + = GlobalEnv + { global_vars = mapVarEnv snd $ vectInfoVar info + , global_vect_decls = mkVarEnv vects + , global_scalars = mkVarSet scalars + , global_exported_vars = emptyVarEnv + , global_tycons = mapNameEnv snd $ vectInfoTyCon info + , global_datacons = mapNameEnv snd $ vectInfoDataCon info + , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info + , global_pr_funs = emptyNameEnv + , global_boxed_tycons = emptyNameEnv + , global_inst_env = instEnvs + , global_fam_inst_env = famInstEnvs + , global_bindings = [] + } + where + vects = [(var, (varType var, exp)) | Vect var (Just exp) <- vectDecls] + scalars = [var | Vect var Nothing <- vectDecls] -- Operators on Global Environments ------------------------------------------- @@ -135,13 +146,11 @@ extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv extendImportedVarsEnv ps genv = genv { global_vars = extendVarEnvList (global_vars genv) ps } - -- | Extend the set of scalar variables in an environment. extendScalars :: [Var] -> GlobalEnv -> GlobalEnv extendScalars vs genv = genv { global_scalars = extendVarSetList (global_scalars genv) vs } - -- | Set the list of type family instances in an environment. setFamEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv setFamEnv l_fam_inst genv diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 9cd34e3ac3..569057e5e8 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -33,17 +33,15 @@ import Data.List -- | Vectorise a polymorphic expression. -vectPolyExpr - :: Bool -- ^ When vectorising the RHS of a binding, whether that - -- binding is a loop breaker. - -> [Var] - -> CoreExprWithFVs - -> VM (Inline, Bool, VExpr) - +-- +vectPolyExpr :: Bool -- ^ When vectorising the RHS of a binding, whether that + -- binding is a loop breaker. + -> [Var] + -> CoreExprWithFVs + -> VM (Inline, Bool, VExpr) vectPolyExpr loop_breaker recFns (_, AnnNote note expr) = do (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr return (inline, isScalarFn, vNote note expr') - vectPolyExpr loop_breaker recFns expr = do arity <- polyArity tvs @@ -148,22 +146,19 @@ onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body) vectExpr e = cantVectorise "Can't vectorise expression (vectExpr)" (ppr $ deAnnotate e) - -- | Vectorise an expression with an outer lambda abstraction. -vectFnExpr - :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. - -> Bool -- ^ Whether the binding is a loop breaker. - -> [Var] - -> CoreExprWithFVs -- ^ Expression to vectorise. Must have an outer `AnnLam`. - -> VM (Inline, Bool, VExpr) - +-- +vectFnExpr :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. + -> Bool -- ^ Whether the binding is a loop breaker. + -> [Var] + -> CoreExprWithFVs -- ^ Expression to vectorise. Must have an outer `AnnLam`. + -> VM (Inline, Bool, VExpr) vectFnExpr inline loop_breaker recFns e@(fvs, AnnLam bndr _) | isId bndr = onlyIfV True -- (isEmptyVarSet fvs) -- we check for free variables later. TODO: clean up (mark DontInline True . vectScalarLam bs recFns $ deAnnotate body) `orElseV` mark inlineMe False (vectLam inline loop_breaker fvs bs body) where (bs,body) = collectAnnValBinders e - vectFnExpr _ _ _ e = mark DontInline False $ vectExpr e mark :: Inline -> Bool -> VM a -> VM (Inline, Bool, a) diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 259743058e..5fcd2ac088 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -22,8 +22,8 @@ module Vectorise.Monad ( -- * Primitives lookupPrimPArray, lookupPrimMethod -) -where +) where + import Vectorise.Monad.Base import Vectorise.Monad.Naming import Vectorise.Monad.Local @@ -32,68 +32,75 @@ import Vectorise.Monad.InstEnv import Vectorise.Builtins import Vectorise.Env -import HscTypes hiding ( MonadThings(..) ) +import HscTypes hiding ( MonadThings(..) ) +import DynFlags import MonadUtils (liftIO) -import Module import TyCon import Var import VarEnv import Id import DsMonad import Outputable +import FastString + import Control.Monad import VarSet -- | Run a vectorisation computation. -initV :: PackageId - -> HscEnv - -> ModGuts - -> VectInfo - -> VM a - -> IO (Maybe (VectInfo, a)) - -initV pkg hsc_env guts info p - = do - -- XXX: ignores error messages and warnings, check that this is - -- indeed ok (the use of "Just r" suggests so) - (_,Just r) <- initDs hsc_env (mg_module guts) - (mg_rdr_env guts) - (mg_types guts) - go - return r +-- +initV :: HscEnv + -> ModGuts + -> VectInfo + -> VM a + -> IO (Maybe (VectInfo, a)) +initV hsc_env guts info thing_inside + = do { (_, Just r) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go + ; return r + } where go - = do - builtins <- initBuiltins pkg - builtin_vars <- initBuiltinVars builtins - builtin_tycons <- initBuiltinTyCons builtins - let builtin_datacons = initBuiltinDataCons builtins - builtin_boxed <- initBuiltinBoxedTyCons builtins - builtin_scalars <- initBuiltinScalars builtins - - eps <- liftIO $ hscEPS hsc_env - let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) - instEnvs = (eps_inst_env eps, mg_inst_env guts) - - builtin_prs <- initBuiltinPRs builtins instEnvs - builtin_pas <- initBuiltinPAs builtins instEnvs - - let genv = extendImportedVarsEnv builtin_vars - . extendScalars builtin_scalars - . extendTyConsEnv builtin_tycons - . extendDataConsEnv builtin_datacons - . extendPAFunsEnv builtin_pas - . setPRFunsEnv builtin_prs - . setBoxedTyConsEnv builtin_boxed - $ initGlobalEnv info instEnvs famInstEnvs - - r <- runVM p builtins genv emptyLocalEnv - case r of - Yes genv _ x -> return $ Just (new_info genv, x) - No -> return Nothing + = do { -- pick a DPH backend + ; dflags <- getDOptsDs + ; case dphPackageMaybe dflags of + Nothing -> failWithDs $ ptext selectBackendErr + Just pkg -> do { + + -- set up tables of builtin entities + ; let compilingDPH = dphBackend dflags == DPHThis -- FIXME: temporary kludge support + ; builtins <- initBuiltins pkg + ; builtin_vars <- initBuiltinVars compilingDPH builtins + ; builtin_tycons <- initBuiltinTyCons builtins + ; let builtin_datacons = initBuiltinDataCons builtins + ; builtin_boxed <- initBuiltinBoxedTyCons builtins + ; builtin_scalars <- initBuiltinScalars compilingDPH 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 = (eps_inst_env eps, mg_inst_env guts) + ; builtin_prs <- initBuiltinPRs builtins instEnvs + ; builtin_pas <- initBuiltinPAs builtins instEnvs + + -- construct the initial global environment + ; let genv = extendImportedVarsEnv builtin_vars + . extendScalars builtin_scalars + . extendTyConsEnv builtin_tycons + . extendDataConsEnv builtin_datacons + . extendPAFunsEnv builtin_pas + . setPRFunsEnv builtin_prs + . setBoxedTyConsEnv builtin_boxed + $ initGlobalEnv 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 -> return Nothing + } } new_info genv = updVectInfo genv (mg_types guts) info + selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq" -- Builtins ------------------------------------------------------------------- -- | Lift a desugaring computation using the `Builtins` into the vectorisation monad. @@ -139,17 +146,20 @@ dumpVar var | otherwise = cantVectorise "Variable not vectorised:" (ppr var) --- local scalars -------------------------------------------------------------- --- | Check if the variable is a locally defined scalar function +-- local scalars -------------------------------------------------------------- addGlobalScalar :: Var -> VM () addGlobalScalar var - = updGEnv $ \env -> pprTrace "addGLobalScalar" (ppr var) env{global_scalars = extendVarSet (global_scalars env) var} + = do { traceVt "addGlobalScalar" (ppr var) + ; updGEnv $ \env -> env{global_scalars = extendVarSet (global_scalars env) var} + } deleteGlobalScalar :: Var -> VM () deleteGlobalScalar var - = updGEnv $ \env -> pprTrace "deleteGLobalScalar" (ppr var) env{global_scalars = delVarSet (global_scalars env) var} + = do { traceVt "deleteGlobalScalar" (ppr var) + ; updGEnv $ \env -> env{global_scalars = delVarSet (global_scalars env) var} + } -- Primitives ----------------------------------------------------------------- diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs index c2c314faf9..aa73e25264 100644 --- a/compiler/vectorise/Vectorise/Monad/Base.hs +++ b/compiler/vectorise/Vectorise/Monad/Base.hs @@ -13,6 +13,9 @@ module Vectorise.Monad.Base ( maybeCantVectorise, maybeCantVectoriseM, + -- * Debugging + traceVt, dumpOptVt, dumpVt, + -- * Control noV, traceNoV, ensureV, traceEnsureV, @@ -22,14 +25,23 @@ module Vectorise.Monad.Base ( orElseV, fixV, ) where + import Vectorise.Builtins import Vectorise.Env import DsMonad +import TcRnMonad +import ErrUtils import Outputable - +import DynFlags +import StaticFlags + +import Control.Monad +import System.IO (stderr) + -- The Vectorisation Monad ---------------------------------------------------- + -- | Vectorisation can either succeed with new envionment and a value, -- or return with failure. data VResult a @@ -46,6 +58,12 @@ instance Monad VM where Yes genv' lenv' x -> runVM (f x) bi genv' lenv' No -> return No +instance Functor VM where + fmap = liftM + +instance MonadIO VM where + liftIO = liftDs . liftIO + -- Lifting -------------------------------------------------------------------- -- | Lift a desugaring computation into the vectorisation monad. @@ -77,6 +95,36 @@ maybeCantVectoriseM s d p Just x -> return x Nothing -> cantVectorise s d + +-- Debugging ------------------------------------------------------------------ + +-- |Output a trace message if -ddump-vt-trace is active. +-- +traceVt :: String -> SDoc -> VM () +traceVt herald doc + | 1 <= opt_TraceLevel = liftDs $ + traceOptIf Opt_D_dump_vt_trace $ + hang (text herald) 2 doc + | otherwise = return () + +-- |Dump the given program conditionally. +-- +dumpOptVt :: DynFlag -> 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 + ; liftIO $ printForUser stderr unqual (mkDumpDoc header doc) + } + -- Control -------------------------------------------------------------------- -- | Return some result saying we've failed. noV :: VM a diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index 4bd6c770fd..ae68ffbc5c 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -4,11 +4,14 @@ module Vectorise.Monad.Global ( setGEnv, updGEnv, - -- * Vars - defGlobalVar, - - -- * Scalars - globalScalars, + -- * Vars + defGlobalVar, + + -- * Vectorisation declarations + lookupVectDecl, + + -- * Scalars + globalScalars, isGlobalScalar, -- * TyCons lookupTyCon, @@ -27,8 +30,12 @@ module Vectorise.Monad.Global ( -- * PR Dictionaries lookupTyConPR ) where + import Vectorise.Monad.Base import Vectorise.Env + +import CoreSyn +import Type import TyCon import DataCon import NameEnv @@ -65,11 +72,20 @@ defGlobalVar v v' = updGEnv $ \env -> | otherwise = env +-- Vectorisation declarations ------------------------------------------------- +-- | Check whether a variable has a (non-scalar) vectorisation declaration. +lookupVectDecl :: Var -> VM (Maybe (Type, CoreExpr)) +lookupVectDecl var = readGEnv $ \env -> lookupVarEnv (global_vect_decls env) var + + -- Scalars -------------------------------------------------------------------- -- | Get the set of global scalar variables. globalScalars :: VM VarSet -globalScalars - = readGEnv global_scalars +globalScalars = readGEnv global_scalars + +-- | Check whether a given variable is in the set of global scalar variables. +isGlobalScalar :: Var -> VM Bool +isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalars env) -- TyCons --------------------------------------------------------------------- diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 61a52bc4b7..84844101a3 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -1,12 +1,9 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -XNoMonoLocalBinds #-} --- Roman likes local bindings --- If this module lives on I'd like to get rid of this flag in due course module Vectorise.Type.Env ( vectTypeEnv, -) -where +) where + import Vectorise.Env import Vectorise.Vect import Vectorise.Monad @@ -42,20 +39,18 @@ import MonadUtils import Control.Monad import Data.List -debug = False -dtrace s x = if debug then pprTrace "VectType" s x else x -- | Vectorise a type environment. -- The type environment contains all the type things defined in a module. -vectTypeEnv - :: TypeEnv - -> VM ( TypeEnv -- Vectorised type environment. - , [FamInst] -- New type family instances. - , [(Var, CoreExpr)]) -- New top level bindings. - +-- +vectTypeEnv :: TypeEnv + -> VM ( TypeEnv -- Vectorised type environment. + , [FamInst] -- New type family instances. + , [(Var, CoreExpr)]) -- New top level bindings. vectTypeEnv env - = dtrace (ppr env) - $ do + = do + traceVt "** vectTypeEnv" $ ppr env + cs <- readGEnv $ mk_map . global_tycons -- Split the list of TyCons into the ones we have to vectorise vs the @@ -122,14 +117,11 @@ vectTypeEnv env where mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env] - - buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> SumRepr -> VM Var buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc repr = do vectDataConWorkers orig_tc vect_tc pdata_tc buildPADict vect_tc prepr_tc pdata_tc repr - vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () vectDataConWorkers orig_tc vect_tc arr_tc = do bs <- sequence diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index e62f45acb2..8cc2bec519 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -33,7 +33,7 @@ vectAndLiftType :: Type -> VM (Type, Type) vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' vectAndLiftType ty = do - mdicts <- mapM paDictArgType tyvars + mdicts <- mapM paDictArgType (reverse tyvars) let dicts = [dict | Just dict <- mdicts] vmono_ty <- vectType mono_ty lmono_ty <- mkPDataType vmono_ty @@ -78,7 +78,8 @@ vectType ty@(ForAllTy _ _) dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars -- pack it all back together. - return $ abstractType tyvars (dictsVect ++ dictsPA) tyBody'' + traceVt "vect ForAllTy: " $ ppr (abstractType tyvars (dictsPA ++ dictsVect) tyBody'') + return $ abstractType tyvars (dictsPA ++ dictsVect) tyBody'' vectType ty = cantVectorise "Can't vectorise type" (ppr ty) |