Commit f2aaae97 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Added a VECTORISE pragma

- Added a pragma {-# VECTORISE var = exp #-} that prevents
  the vectoriser from vectorising the definition of 'var'.
  Instead it uses the binding '$v_var = exp' to vectorise
  'var'.  The vectoriser checks that the Core type of 'exp'
  matches the vectorised Core type of 'var'.  (It would be
  quite complicated to perform that check in the type checker
  as the vectorisation of a type needs the state of the VM
  monad.)
- Added parts of a related VECTORISE SCALAR pragma
- Documented -ddump-vect
- Added -ddump-vt-trace
- Some clean up
parent 19d8dcbd
......@@ -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"
......@@ -401,6 +404,20 @@ setRuleIdName nm ru = ru { ru_fn = nm }
\end{code}
%************************************************************************
%* *
\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
......
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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"