Commit 2d5a1a5b authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 80f57ea4 6791fff4
......@@ -588,6 +588,7 @@ data HsBang = HsNoBang
| HsUnpackFailed -- An UNPACK pragma that we could not make
-- use of, because the type isn't unboxable;
-- equivalant to HsStrict except for checkValidDataCon
| HsNoUnpack -- {-# NOUNPACK #-} ! (GHC extension, meaning "strict but not unboxed")
deriving (Eq, Data, Typeable)
instance Outputable HsBang where
......@@ -595,6 +596,7 @@ instance Outputable HsBang where
ppr HsStrict = char '!'
ppr HsUnpack = ptext (sLit "{-# UNPACK #-} !")
ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
ppr HsNoUnpack = ptext (sLit "{-# NOUNPACK #-} !")
isBanged :: HsBang -> Bool
isBanged HsNoBang = False
......
......@@ -952,6 +952,7 @@ computeRep stricts tys
where
unbox HsNoBang ty = [(NotMarkedStrict, ty)]
unbox HsStrict ty = [(MarkedStrict, ty)]
unbox HsNoUnpack ty = [(MarkedStrict, ty)]
unbox HsUnpackFailed ty = [(MarkedStrict, ty)]
unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
where
......
......@@ -773,13 +773,15 @@ instance Binary HsBang where
put_ bh HsStrict = putByte bh 1
put_ bh HsUnpack = putByte bh 2
put_ bh HsUnpackFailed = putByte bh 3
put_ bh HsNoUnpack = putByte bh 4
get bh = do
h <- getByte bh
case h of
0 -> do return HsNoBang
1 -> do return HsStrict
2 -> do return HsUnpack
_ -> do return HsUnpackFailed
3 -> do return HsUnpackFailed
_ -> do return HsNoUnpack
instance Binary TupleSort where
put_ bh BoxedTuple = putByte bh 0
......
......@@ -1066,12 +1066,12 @@ setSafeHaskell s = updM f
-- | Are all direct imports required to be safe for this Safe Haskell mode?
-- Direct imports are when the code explicitly imports a module
safeDirectImpsReq :: DynFlags -> Bool
safeDirectImpsReq d = safeLanguageOn d || safeInferOn d
safeDirectImpsReq d = safeLanguageOn d
-- | Are all implicit imports required to be safe for this Safe Haskell mode?
-- Implicit imports are things in the prelude. e.g System.IO when print is used.
safeImplicitImpsReq :: DynFlags -> Bool
safeImplicitImpsReq d = safeLanguageOn d || safeInferOn d
safeImplicitImpsReq d = safeLanguageOn d
-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.
-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't
......@@ -1337,7 +1337,7 @@ safeFlagCheck dflags =
allFlags :: [String]
allFlags = map ('-':) $
[ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++
[ flagName flag | flag <- dynamic_flags ++ package_flags, ok (flagOptKind flag) ] ++
map ("fno-"++) fflags ++
map ("f"++) fflags ++
map ("X"++) supportedExtensions
......
......@@ -920,7 +920,10 @@ checkSafeImports dflags hsc_env tcg_env
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!"
condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
return (m, l, s)
-- we turn all imports into safe ones when
-- inference mode is on.
let s' = if safeInferOn dflags then True else s
return (m, l, s')
-- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
......
......@@ -477,6 +477,7 @@ data Token
| ITgenerated_prag
| ITcore_prag -- hdaume: core annotations
| ITunpack_prag
| ITnounpack_prag
| ITann_prag
| ITclose_prag
| IToptions_prag String
......@@ -2267,6 +2268,7 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
("generated", token ITgenerated_prag),
("core", token ITcore_prag),
("unpack", token ITunpack_prag),
("nounpack", token ITnounpack_prag),
("ann", token ITann_prag),
("vectorize", token ITvect_prag),
("novectorize", token ITnovect_prag)])
......
......@@ -263,6 +263,7 @@ incorrect.
'{-# DEPRECATED' { L _ ITdeprecated_prag }
'{-# WARNING' { L _ ITwarning_prag }
'{-# UNPACK' { L _ ITunpack_prag }
'{-# NOUNPACK' { L _ ITnounpack_prag }
'{-# ANN' { L _ ITann_prag }
'{-# VECTORISE' { L _ ITvect_prag }
'{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag }
......@@ -973,6 +974,7 @@ infixtype :: { LHsType RdrName }
strict_mark :: { Located HsBang }
: '!' { L1 HsStrict }
| '{-# UNPACK' '#-}' '!' { LL HsUnpack }
| '{-# NOUNPACK' '#-}' '!' { LL HsNoUnpack }
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
......
......@@ -4,13 +4,6 @@
\section[RnNames]{Extracting imported and top-level names in scope}
\begin{code}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module RnNames (
rnImports, getLocalNonValBinders,
rnExports, extendGlobalRdrEnvRn,
......@@ -42,16 +35,16 @@ import ErrUtils
import Util
import FastString
import ListSetOps
import Data.List ( partition, (\\), find )
import qualified Data.Set as Set
import System.IO
import Control.Monad
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.List ( partition, (\\), find )
import qualified Data.Set as Set
import System.IO
\end{code}
%************************************************************************
%* *
\subsection{rnImports}
......@@ -137,39 +130,35 @@ with yes we have gone with no for now.
\begin{code}
-- | Process Import Decls
-- Do the non SOURCE ones first, so that we get a helpful warning for SOURCE
-- ones that are unnecessary
rnImports :: [LImportDecl RdrName]
-> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
rnImports imports = do
this_mod <- getModule
let (source, ordinary) = partition is_source_import imports
is_source_import d = ideclSource (unLoc d)
stuff1 <- mapM (rnImportDecl this_mod) ordinary
stuff2 <- mapM (rnImportDecl this_mod) source
-- Safe Haskell: See Note [Tracking Trust Transitively]
let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)
return (decls, rdr_env, imp_avails, hpc_usage)
rnImports imports
-- PROCESS IMPORT DECLS
-- Do the non {- SOURCE -} ones first, so that we get a helpful
-- warning for {- SOURCE -} ones that are unnecessary
= do this_mod <- getModule
let (source, ordinary) = partition is_source_import imports
is_source_import d = ideclSource (unLoc d)
stuff1 <- mapM (rnImportDecl this_mod) ordinary
stuff2 <- mapM (rnImportDecl this_mod) source
-- Safe Haskell: See Note [Tracking Trust Transitively]
let (decls, rdr_env, imp_avails, hpc_usage) =
combine (stuff1 ++ stuff2)
return (decls, rdr_env, imp_avails, hpc_usage)
where
combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
-> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False)
where
plus (decl, gbl_env1, imp_avails1,hpc_usage1)
(decls, gbl_env2, imp_avails2,hpc_usage2)
= ( decl:decls,
gbl_env1 `plusGlobalRdrEnv` gbl_env2,
imp_avails1 `plusImportAvails` imp_avails2,
hpc_usage1 || hpc_usage2 )
rnImportDecl :: Module
-> LImportDecl RdrName
where
combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
-> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False)
plus (decl, gbl_env1, imp_avails1,hpc_usage1)
(decls, gbl_env2, imp_avails2,hpc_usage2)
= ( decl:decls,
gbl_env1 `plusGlobalRdrEnv` gbl_env2,
imp_avails1 `plusImportAvails` imp_avails2,
hpc_usage1 || hpc_usage2 )
rnImportDecl :: Module -> LImportDecl RdrName
-> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
rnImportDecl this_mod
(L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg
, ideclSource = want_boot, ideclSafe = mod_safe
......@@ -181,15 +170,13 @@ rnImportDecl this_mod
pkg_imports <- xoptM Opt_PackageImports
when (not pkg_imports) $ addErr packageImportErr
-- If there's an error in loadInterface, (e.g. interface
-- file not found) we get lots of spurious errors from 'filterImports'
let
imp_mod_name = unLoc loc_imp_mod_name
-- If there's an error in loadInterface, (e.g. interface
-- file not found) we get lots of spurious errors from 'filterImports'
let imp_mod_name = unLoc loc_imp_mod_name
doc = ppr imp_mod_name <+> ptext (sLit "is directly imported")
-- Check for a missing import list
-- (Opt_WarnMissingImportList also checks for T(..) items
-- but that is done in checkDodgyImport below)
-- Check for a missing import list (Opt_WarnMissingImportList also
-- checks for T(..) items but that is done in checkDodgyImport below)
case imp_details of
Just (False, _) -> return () -- Explicit import list
_ | implicit -> return () -- Do not bleat for implicit imports
......@@ -199,24 +186,27 @@ rnImportDecl this_mod
iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg
-- Compiler sanity check: if the import didn't say
-- {-# SOURCE #-} we should not get a hi-boot file
WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) (do
-- Compiler sanity check: if the import didn't say
-- {-# SOURCE #-} we should not get a hi-boot file
WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do
-- Issue a user warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
-- any of the {- SOURCE -} imports.
--
-- in --make and GHCi, the compilation manager checks for this,
-- and indeed we shouldn't do it here because the existence of
-- the non-boot module depends on the compilation order, which
-- is not deterministic. The hs-boot test can show this up.
-- Issue a user warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
-- any of the {- SOURCE -} imports.
--
-- in --make and GHCi, the compilation manager checks for this,
-- and indeed we shouldn't do it here because the existence of
-- the non-boot module depends on the compilation order, which
-- is not deterministic. The hs-boot test can show this up.
dflags <- getDOpts
warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
(warnRedundantSourceImport imp_mod_name)
when (mod_safe && not (safeImportsOn dflags)) $
addErrAt loc (ptext (sLit "safe import can't be used as Safe Haskell isn't on!")
$+$ ptext (sLit $ "please enable Safe Haskell through either"
++ "-XSafe, -XTruswrothy or -XUnsafe"))
let
imp_mod = mi_module iface
let imp_mod = mi_module iface
warns = mi_warns iface
orph_iface = mi_orphan iface
has_finsts = mi_finsts iface
......@@ -224,9 +214,7 @@ rnImportDecl this_mod
trust = getSafeMode $ mi_trust iface
trust_pkg = mi_trust_pkg iface
qual_mod_name = case as_mod of
Nothing -> imp_mod_name
Just another_name -> another_name
qual_mod_name = as_mod `orElse` imp_mod_name
imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,
is_dloc = loc, is_as = qual_mod_name }
......@@ -315,18 +303,18 @@ rnImportDecl this_mod
-- module as a safe import.
-- See Note [Tracking Trust Transitively]
-- and Note [Trust Transitive Property]
imp_trust_pkgs = if mod_safe'
then map fst $ filter snd dependent_pkgs
else [],
imp_trust_pkgs = if mod_safe'
then map fst $ filter snd dependent_pkgs
else [],
-- Do we require our own pkg to be trusted?
-- See Note [Trust Own Package]
imp_trust_own_pkg = pkg_trust_req
}
-- Complain if we import a deprecated module
ifWOptM Opt_WarnWarningsDeprecations (
ifWOptM Opt_WarnWarningsDeprecations (
case warns of
WarnAll txt -> addWarn (moduleWarn imp_mod_name txt)
WarnAll txt -> addWarn $ moduleWarn imp_mod_name txt
_ -> return ()
)
......@@ -334,7 +322,6 @@ rnImportDecl this_mod
, ideclHiding = new_imp_details })
return (new_imp_decl, gbl_env, imports, mi_hpc iface)
)
warnRedundantSourceImport :: ModuleName -> SDoc
warnRedundantSourceImport mod_name
......@@ -504,25 +491,25 @@ getLocalNonValBinders fixity_env
-- Process all type/class decls *except* family instances
; tc_avails <- mapM new_tc tycl_decls_noinsts
; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
; setEnvs envs $ do {
-- Bring these things into scope first
; setEnvs envs $ do {
-- Bring these things into scope first
-- See Note [Looking up family names in family instances]
-- Process all family instances
-- to bring new data constructors into scope
-- to bring new data constructors into scope
; ti_avails <- mapM (new_ti Nothing) tyinst_decls
; nti_avails <- concatMapM new_assoc inst_decls
-- Finish off with value binders:
-- foreign decls for an ordinary module
-- type sigs in case of a hs-boot file only
-- foreign decls for an ordinary module
-- type sigs in case of a hs-boot file only
; is_boot <- tcIsHsBoot
; let val_bndrs | is_boot = hs_boot_sig_bndrs
| otherwise = for_hs_bndrs
; val_avails <- mapM new_simple val_bndrs
; let avails = ti_avails ++ nti_avails ++ val_avails
new_bndrs = availsToNameSet avails `unionNameSets`
; let avails = ti_avails ++ nti_avails ++ val_avails
new_bndrs = availsToNameSet avails `unionNameSets`
availsToNameSet tc_avails
; envs <- extendGlobalRdrEnvRn avails fixity_env
; return (envs, new_bndrs) } }
......@@ -565,14 +552,14 @@ lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
-- Used for TyData and TySynonym only
-- See Note [Family instance binders]
lookupTcdName mb_cls tc_decl
| not (isFamInstDecl tc_decl) -- The normal case
= ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this
| not (isFamInstDecl tc_decl) -- The normal case
= ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this
lookupLocatedTopBndrRn tc_rdr
| Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind
| Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind
= wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
| otherwise -- Family instance; tc_rdr is an *occurrence*
| otherwise -- Family instance; tc_rdr is an *occurrence*
= lookupLocatedOccRn tc_rdr
where
tc_rdr = tcdLName tc_decl
......@@ -914,7 +901,7 @@ it re-exports @GHC@, which includes @takeMVar#@, whose type includes
Note [Exports of data families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose you see (Trac #5306)
module M where
module M where
import X( F )
data instance F Int = FInt
What does M export? AvailTC F [FInt]
......@@ -1042,8 +1029,8 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
; warnDodgyExports <- woptM Opt_WarnDodgyExports
; let { exportValid = (mod `elem` imported_modules)
|| (moduleName this_mod == mod)
; gres = filter (isModuleExported implicit_prelude mod)
(globalRdrEnvElts rdr_env)
; gres = filter (isModuleExported implicit_prelude mod)
(globalRdrEnvElts rdr_env)
; new_exports = map greExportAvail gres
; names = map gre_name gres }
......@@ -1419,9 +1406,9 @@ warnUnusedImportDecls gbl_env
explicit_import (L _ decl) = unLoc (ideclName decl) /= pRELUDE_NAME
-- Filter out the implicit Prelude import
-- which we do not want to bleat about
-- This also filters out an *explicit* Prelude import
-- but solving that problem involves more plumbing, and
-- it just doesn't seem worth it
-- This also filters out an *explicit* Prelude import
-- but solving that problem involves more plumbing, and
-- it just doesn't seem worth it
\end{code}
\begin{code}
......@@ -1648,7 +1635,7 @@ badImportItemErrDataCon dataType iface decl_spec ie
datacon = parenSymOcc datacon_occ (ppr datacon_occ)
source_import | mi_boot iface = ptext (sLit "(hi-boot interface)")
| otherwise = empty
parens_sp d = parens (space <> d <> space) -- T( f,g )
parens_sp d = parens (space <> d <> space) -- T( f,g )
badImportItemErr :: ModIface -> ImpDeclSpec -> IE RdrName -> [AvailInfo] -> SDoc
badImportItemErr iface decl_spec ie avails
......
......@@ -926,6 +926,7 @@ chooseBoxingStrategy arg_ty bang
HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields
; if unbox_strict then return (can_unbox HsStrict arg_ty)
else return HsStrict }
HsNoUnpack -> return HsStrict
HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas
-- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
-- See Trac #5252: unpacking means we must not conceal the
......
......@@ -79,7 +79,7 @@ mapCatMaybes f (x:xs) = case f x of
\end{code}
\begin{code}
-- | flipped version of @fromMaybe@.
orElse :: Maybe a -> a -> a
(Just x) `orElse` _ = x
Nothing `orElse` y = y
......
......@@ -81,25 +81,15 @@ vectModule guts@(ModGuts { mg_tcs = tycons
-- array types.
; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls
{- TODO:
instance Num Int where
(+) = primAdd
{-# VECTORISE SCALAR instance Num Int #-}
==> $dNumInt :: Num Int; $dNumInt = Num primAdd
=>> $v$dNumInt :: $vNum Int
$v$dNumInt = $vNum (closure1 (scalar_zipWith primAdd) (scalar_zipWith primAdd))
$dNumInt -v> $v$dNumInt
-}
-- Family instance environment for /all/ home-package modules including those instances
-- generated by 'vectTypeEnv'.
; (_, fam_inst_env) <- readGEnv global_fam_inst_env
-- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers
; let impBinds = [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id] ++
[imp_id | VectInst True imp_id <- vect_decls, isGlobalId imp_id]
; binds_top <- mapM vectTopBind binds
; binds_imp <- mapM vectImpBind [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id]
; binds_imp <- mapM vectImpBind impBinds
; return $ guts { mg_tcs = tycons ++ new_tycons
-- we produce no new classes or instances, only new class type constructors
......@@ -283,21 +273,63 @@ vectTopBinder var inline expr
unfolding = case inline of
Inline arity -> mkInlineUnfolding (Just arity) expr
DontInline -> noUnfolding
{-
!!!TODO: dfuns and unfoldings:
-- Do not inline the dfun; instead give it a magic DFunFunfolding
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
dfun_id_w_fun
| isNewTyCon class_tc
= dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
| otherwise
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args
`setInlinePragma` dfunInlinePragma
-}
-- | Vectorise the RHS of a top-level binding, in an empty local environment.
--
-- We need to distinguish three cases:
-- We need to distinguish four 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
-- (2) We have a scalar vectorisation declaration for a variable that is no dfun
-- => generate vectorised code that uses a scalar 'map'/'zipWith' to lift the computation
--
-- (3) There is no vectorisation declaration for the variable
-- (3) We have a scalar vectorisation declaration for a variable that *is* a dfun
-- => generate vectorised code according to the the "Note [Scalar dfuns]" below
--
-- (4) There is no vectorisation declaration for the variable
-- => perform automatic vectorisation of the RHS
--
-- Note [Scalar dfuns]
-- ~~~~~~~~~~~~~~~~~~~
--
-- Here is the translation scheme for scalar dfuns — assume the instance declaration:
--
-- instance Num Int where
-- (+) = primAdd
-- {-# VECTORISE SCALAR instance Num Int #-}
--
-- It desugars to
--
-- $dNumInt :: Num Int
-- $dNumInt = D:Num primAdd
--
-- We vectorise it to
--
-- $v$dNumInt :: V:Num Int
-- $v$dNumInt = D:V:Num (closure2 ((+) $dNumInt) (scalar_zipWith ((+) $dNumInt))))
--
-- while adding the following entry to the vectorisation map: '$dNumInt' --> '$v$dNumInt'.
--
-- See "Note [Vectorising classes]" in 'Vectorise.Type.Env' for the definition of 'V:Num'.
--
-- NB: The outlined vectorisation scheme does not require the right-hand side of the original dfun.
-- In fact, we definitely want to refer to the dfn variable instead of the right-hand side to
-- ensure that the dictionary selection rules fire.
--
vectTopRhs :: [Var] -- ^ Names of all functions in the rec block
-> Var -- ^ Name of the binding.
-> CoreExpr -- ^ Body of the binding.
......@@ -308,19 +340,24 @@ vectTopRhs recFs var expr
= closedV
$ do { globalScalar <- isGlobalScalar var
; vectDecl <- lookupVectDecl var
; let isDFun = isDFunId var
; traceVt ("vectTopRhs of " ++ show var ++ info globalScalar vectDecl) $ ppr expr
; traceVt ("vectTopRhs of " ++ show var ++ info globalScalar isDFun vectDecl) $ ppr expr
; rhs globalScalar vectDecl
; rhs globalScalar isDFun vectDecl
}
where
rhs _globalScalar (Just (_, expr')) -- Case (1)
rhs _globalScalar _isDFun (Just (_, expr')) -- Case (1)
= return (inlineMe, False, expr')
rhs True Nothing -- Case (2)
rhs True False Nothing -- Case (2)
= do { expr' <- vectScalarFun True recFs expr
; return (inlineMe, True, vectorised expr')
}
rhs False Nothing -- Case (3)
rhs True True Nothing -- Case (3)
= do { expr' <- vectScalarDFun var recFs
; return (DontInline, True, expr')
}
rhs False _isDFun Nothing -- Case (4)
= do { let fvs = freeVars expr
; (inline, isScalar, vexpr)
<- inBind var $
......@@ -328,9 +365,10 @@ vectTopRhs recFs var expr
; return (inline, isScalar, vectorised vexpr)
}
info True _ = " [VECTORISE SCALAR]"
info False vectDecl | isJust vectDecl = " [VECTORISE]"
| otherwise = " (no pragma)"
info True False _ = " [VECTORISE SCALAR]"
info True True _ = " [VECTORISE SCALAR instance]"
info False _ vectDecl | isJust vectDecl = " [VECTORISE]"
| otherwise = " (no pragma)"
-- |Project out the vectorised version of a binding from some closure,
-- or return the original body if that doesn't work or the binding is scalar.
......
......@@ -145,7 +145,8 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
-- FIXME: we currently only allow RHSes consisting of a
-- single variable to be able to obtain the type without
-- inference — see also 'TcBinds.tcVect'
scalar_vars = [var | Vect var Nothing <- vectDecls]
scalar_vars = [var | Vect var Nothing <- vectDecls] ++
[var | VectInst True var <- vectDecls]
novects = [var | NoVect var <- vectDecls]
scalar_tycons = [tyConName tycon | VectType True tycon _ <- vectDecls]
......
-- |Vectorisation of expressions.
-- | Vectorisation of expressions.
module Vectorise.Exp (
-- Vectorise a polymorphic expression
vectPolyExpr,
-- Vectorise a scalar expression of functional type
vectScalarFun
) where
module Vectorise.Exp
( -- * Vectorise polymorphic expressions with special cases for right-hand sides of particular
-- variable bindings
vectPolyExpr
, vectScalarFun
, vectScalarDFun
)
where
#include "HsVersions.h"
import Vectorise.Type.Type
import Vectorise.Var
import Vectorise.Convert
import Vectorise.Vect
import Vectorise.Env
import Vectorise.Monad
import Vectorise.Builtins
import Vectorise.Utils
import CoreSyn
import CoreUtils
import MkCore
import CoreSyn
import CoreFVs
import Class
import DataCon
import TyCon
import TcType
import Type
import NameSet
import Var
......@@ -38,6 +41,7 @@ import TysPrim
import Outputable
import FastString
import Control.Monad
import Control.Applicative
import Data.List
......@@ -82,6 +86,7 @@ vectExpr (_, AnnTick tickish expr)
-- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty';
-- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint
-- happy.
-- FIXME: can't be do this with a VECTORISE pragma on 'pAT_ERROR_ID' now?
vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err)
| v == pAT_ERROR_ID