summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2011-10-25 11:23:53 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2011-10-25 11:23:53 +0100
commit0fac50a4438478727190b053f1d3c575aa1dcba3 (patch)
tree4397129385be6edf4894ff92caa42c81d76d3bd3 /compiler
parent570cab3f6ba823417212791409bf7fc263445d15 (diff)
parent95d66964bb315f1c500f179ab2da001d8f52e2ac (diff)
downloadhaskell-0fac50a4438478727190b053f1d3c575aa1dcba3.tar.gz
Merge branch 'master' of http://darcs.haskell.org/ghc
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/DsMonad.lhs315
-rwxr-xr-xcompiler/ghc.cabal.in1
-rw-r--r--compiler/iface/LoadIface.lhs582
-rw-r--r--compiler/iface/TcIface.lhs896
-rw-r--r--compiler/main/HscTypes.lhs885
-rw-r--r--compiler/main/TidyPgm.lhs9
-rw-r--r--compiler/prelude/PrelNames.lhs3
-rw-r--r--compiler/typecheck/TcMType.lhs37
-rw-r--r--compiler/vectorise/Vectorise/Builtins.hs62
-rw-r--r--compiler/vectorise/Vectorise/Builtins/Base.hs218
-rw-r--r--compiler/vectorise/Vectorise/Builtins/Initialise.hs388
-rw-r--r--compiler/vectorise/Vectorise/Builtins/Modules.hs60
-rw-r--r--compiler/vectorise/Vectorise/Env.hs26
-rw-r--r--compiler/vectorise/Vectorise/Monad.hs77
-rw-r--r--compiler/vectorise/Vectorise/Utils.hs44
-rw-r--r--compiler/vectorise/Vectorise/Utils/Base.hs60
-rw-r--r--compiler/vectorise/Vectorise/Utils/Closure.hs48
-rw-r--r--compiler/vectorise/Vectorise/Utils/PADict.hs32
18 files changed, 1846 insertions, 1897 deletions
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 798b8ba386..87f3343f94 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -7,10 +7,10 @@
\begin{code}
module DsMonad (
- DsM, mapM, mapAndUnzipM,
- initDs, initDsTc, fixDs,
- foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM,
- Applicative(..),(<$>),
+ DsM, mapM, mapAndUnzipM,
+ initDs, initDsTc, fixDs,
+ foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM,
+ Applicative(..),(<$>),
newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
@@ -22,18 +22,18 @@ module DsMonad (
UniqSupply, newUniqueSupply,
getDOptsDs, getGhcModeDs, doptDs, woptDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
+
+ assertDAPPLoaded, lookupDAPPRdrEnv, dsImportDecl, dsImportId, dsImportTyCon,
- DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
+ DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
- dsLoadModule,
+ -- Warnings
+ DsWarning, warnDs, failWithDs,
- -- Warnings
- DsWarning, warnDs, failWithDs,
-
- -- Data types
- DsMatchContext(..),
- EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
- CanItFail(..), orFail
+ -- Data types
+ DsMatchContext(..),
+ EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
+ CanItFail(..), orFail
) where
import TcRnMonad
@@ -41,6 +41,8 @@ import CoreSyn
import HsSyn
import TcIface
import LoadIface
+import PrelNames
+import Avail
import RdrName
import HscTypes
import Bag
@@ -57,14 +59,16 @@ import NameEnv
import DynFlags
import ErrUtils
import FastString
+import Maybes
+import Control.Monad
import Data.IORef
\end{code}
%************************************************************************
-%* *
- Data types for the desugarer
-%* *
+%* *
+ Data types for the desugarer
+%* *
%************************************************************************
\begin{code}
@@ -73,8 +77,8 @@ data DsMatchContext
deriving ()
data EquationInfo
- = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
- eqn_rhs :: MatchResult } -- What to do after match
+ = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
+ eqn_rhs :: MatchResult } -- What to do after match
instance Outputable EquationInfo where
ppr (EqnInfo pats _) = ppr pats
@@ -84,18 +88,18 @@ idDsWrapper :: DsWrapper
idDsWrapper e = e
-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
--- \fail. wrap (case vs of { pats -> rhs fail })
+-- \fail. wrap (case vs of { pats -> rhs fail })
-- where vs are not bound by wrap
-- A MatchResult is an expression with a hole in it
data MatchResult
= MatchResult
- CanItFail -- Tells whether the failure expression is used
- (CoreExpr -> DsM CoreExpr)
- -- Takes a expression to plug in at the
- -- failure point(s). The expression should
- -- be duplicatable!
+ CanItFail -- Tells whether the failure expression is used
+ (CoreExpr -> DsM CoreExpr)
+ -- Takes a expression to plug in at the
+ -- failure point(s). The expression should
+ -- be duplicatable!
data CanItFail = CanFail | CantFail
@@ -106,14 +110,15 @@ orFail _ _ = CanFail
%************************************************************************
-%* *
- Monad stuff
-%* *
+%* *
+ Monad stuff
+%* *
%************************************************************************
Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
a @UniqueSupply@ and some annotations, which
presumably include source-file location information:
+
\begin{code}
type DsM result = TcRnIf DsGblEnv DsLclEnv result
@@ -122,21 +127,24 @@ fixDs :: (a -> DsM a) -> DsM a
fixDs = fixM
type DsWarning = (SrcSpan, SDoc)
- -- Not quite the same as a WarnMsg, we have an SDoc here
- -- and we'll do the print_unqual stuff later on to turn it
- -- into a Doc.
+ -- Not quite the same as a WarnMsg, we have an SDoc here
+ -- and we'll do the print_unqual stuff later on to turn it
+ -- into a Doc.
data DsGblEnv = DsGblEnv {
- ds_mod :: Module, -- For SCC profiling
- ds_unqual :: PrintUnqualified,
- ds_msgs :: IORef Messages, -- Warning messages
- ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
- -- possibly-imported things
+ ds_mod :: Module, -- For SCC profiling
+ ds_unqual :: PrintUnqualified,
+ ds_msgs :: IORef Messages, -- Warning messages
+ ds_if_env :: (IfGblEnv, IfLclEnv), -- Used for looking up global,
+ -- possibly-imported things
+ ds_dph_env :: GlobalRdrEnv -- exported entities of 'Data.Array.Parallel.Prim' iff
+ -- '-fdph-*' flag was given (i.e., 'DynFlags.DPHBackend /=
+ -- DPHNone'); otherwise, empty
}
data DsLclEnv = DsLclEnv {
- ds_meta :: DsMetaEnv, -- Template Haskell bindings
- ds_loc :: SrcSpan -- to put in pattern-matching error msgs
+ ds_meta :: DsMetaEnv, -- Template Haskell bindings
+ ds_loc :: SrcSpan -- to put in pattern-matching error msgs
}
-- Inside [| |] brackets, the desugarer looks
@@ -144,71 +152,121 @@ data DsLclEnv = DsLclEnv {
type DsMetaEnv = NameEnv DsMetaVal
data DsMetaVal
- = Bound Id -- Bound by a pattern inside the [| |].
- -- Will be dynamically alpha renamed.
- -- The Id has type THSyntax.Var
+ = Bound Id -- Bound by a pattern inside the [| |].
+ -- Will be dynamically alpha renamed.
+ -- The Id has type THSyntax.Var
- | Splice (HsExpr Id) -- These bindings are introduced by
- -- the PendingSplices on a HsBracketOut
+ | Splice (HsExpr Id) -- These bindings are introduced by
+ -- the PendingSplices on a HsBracketOut
initDs :: HscEnv
- -> Module -> GlobalRdrEnv -> TypeEnv
- -> DsM a
- -> IO (Messages, Maybe a)
+ -> Module -> GlobalRdrEnv -> TypeEnv
+ -> DsM a
+ -> IO (Messages, Maybe a)
-- Print errors and warnings, if any arise
initDs hsc_env mod rdr_env type_env thing_inside
- = do { msg_var <- newIORef (emptyBag, emptyBag)
- ; let dflags = hsc_dflags hsc_env
- ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
-
- ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
- tryM thing_inside -- Catch exceptions (= errors during desugaring)
-
- -- Display any errors and warnings
- -- Note: if -Werror is used, we don't signal an error here.
- ; msgs <- readIORef msg_var
-
- ; let final_res | errorsFound dflags msgs = Nothing
- | otherwise = case either_res of
- Right res -> Just res
- Left exn -> pprPanic "initDs" (text (show exn))
- -- The (Left exn) case happens when the thing_inside throws
- -- a UserError exception. Then it should have put an error
- -- message in msg_var, so we just discard the exception
-
- ; return (msgs, final_res) }
+ = do { msg_var <- newIORef (emptyBag, emptyBag)
+ ; let dflags = hsc_dflags hsc_env
+ (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
+
+ ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
+ loadDAPP dflags $
+ tryM thing_inside -- Catch exceptions (= errors during desugaring)
+
+ -- Display any errors and warnings
+ -- Note: if -Werror is used, we don't signal an error here.
+ ; msgs <- readIORef msg_var
+
+ ; let final_res | errorsFound dflags msgs = Nothing
+ | otherwise = case either_res of
+ Right res -> Just res
+ Left exn -> pprPanic "initDs" (text (show exn))
+ -- The (Left exn) case happens when the thing_inside throws
+ -- a UserError exception. Then it should have put an error
+ -- message in msg_var, so we just discard the exception
+
+ ; return (msgs, final_res)
+ }
+ where
+ -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
+ -- 'Data.Array.Parallel.Prim' if '-fdph-*' specified.
+ loadDAPP dflags thing_inside
+ | Just pkg <- dphPackageMaybe dflags
+ = do { rdr_env <- loadModule sdoc (dATA_ARRAY_PARALLEL_PRIM pkg)
+ ; updGblEnv (\env -> env {ds_dph_env = rdr_env}) thing_inside
+ }
+ | otherwise
+ = do { ifXOptM Opt_ParallelArrays (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrPA)
+ ; ifDOptM Opt_Vectorise (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrVect)
+ ; thing_inside
+ }
+
+ sdoc = ptext (sLit "Internal Data Parallel Haskell interface 'Data.Array.Parallel.Prim'")
+
+ selectBackendErrVect = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
+ selectBackendErrPA = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
initDsTc :: DsM a -> TcM a
initDsTc thing_inside
- = do { this_mod <- getModule
- ; tcg_env <- getGblEnv
- ; msg_var <- getErrsVar
+ = do { this_mod <- getModule
+ ; tcg_env <- getGblEnv
+ ; msg_var <- getErrsVar
; dflags <- getDOpts
- ; let type_env = tcg_type_env tcg_env
- rdr_env = tcg_rdr_env tcg_env
- ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
- ; setEnvs ds_envs thing_inside }
+ ; let type_env = tcg_type_env tcg_env
+ rdr_env = tcg_rdr_env tcg_env
+ ds_envs = mkDsEnvs dflags this_mod rdr_env type_env msg_var
+ ; setEnvs ds_envs thing_inside
+ }
-mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
+mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env msg_var
- = do -- TODO: unnecessarily monadic
- let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
- if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
- gbl_env = DsGblEnv { ds_mod = mod,
- ds_if_env = (if_genv, if_lenv),
- ds_unqual = mkPrintUnqualified dflags rdr_env,
- ds_msgs = msg_var}
- lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
- ds_loc = noSrcSpan }
-
- return (gbl_env, lcl_env)
+ = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+ if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
+ gbl_env = DsGblEnv { ds_mod = mod
+ , ds_if_env = (if_genv, if_lenv)
+ , ds_unqual = mkPrintUnqualified dflags rdr_env
+ , ds_msgs = msg_var
+ , ds_dph_env = emptyGlobalRdrEnv
+ }
+ lcl_env = DsLclEnv { ds_meta = emptyNameEnv
+ , ds_loc = noSrcSpan
+ }
+ in (gbl_env, lcl_env)
+
+-- Attempt to load the given module and return its exported entities if successful; otherwise, return an
+-- empty environment. See "Note [Loading Data.Array.Parallel.Prim]".
+--
+loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
+loadModule doc mod
+ = do { env <- getGblEnv
+ ; setEnvs (ds_if_env env) $ do
+ { iface <- loadInterface doc mod ImportBySystem
+ ; case iface of
+ Failed _err -> return $ mkGlobalRdrEnv []
+ Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
+ } }
+ where
+ prov = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
+ imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
+ is_dloc = wiredInSrcSpan, is_as = name }
+ name = moduleName mod
\end{code}
+Note [Loading Data.Array.Parallel.Prim]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We generally attempt to load the interface of 'Data.Array.Parallel.Prim' when a DPH backend is selected.
+However, while compiling packages containing a DPH backend, we will start out compiling the modules
+'Data.Array.Parallel.Prim' depends on — i.e., when compiling these modules, the interface won't exist yet.
+This is fine, as these modules do not use the vectoriser, but we need to ensure that GHC doesn't barf when
+the interface is missing. Instead of an error message, we just put an empty 'GlobalRdrEnv' into the
+'DsM' state.
+
+
%************************************************************************
-%* *
- Operations in the monad
-%* *
+%* *
+ Operations in the monad
+%* *
%************************************************************************
And all this mysterious stuff is so we can occasionally reach out and
@@ -223,8 +281,8 @@ newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs old_local
- = do { uniq <- newUnique
- ; return (setIdUnique old_local uniq) }
+ = do { uniq <- newUnique
+ ; return (setIdUnique old_local uniq) }
newPredVarDs :: PredType -> DsM Var
newPredVarDs pred
@@ -265,18 +323,18 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc})
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv
- ; loc <- getSrcSpanDs
- ; let msg = mkWarnMsg loc (ds_unqual env)
- (ptext (sLit "Warning:") <+> warn)
- ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
+ ; loc <- getSrcSpanDs
+ ; let msg = mkWarnMsg loc (ds_unqual env)
+ (ptext (sLit "Warning:") <+> warn)
+ ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
failWithDs :: SDoc -> DsM a
failWithDs err
- = do { env <- getGblEnv
- ; loc <- getSrcSpanDs
- ; let msg = mkErrMsg loc (ds_unqual env) err
- ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
- ; failM }
+ = do { env <- getGblEnv
+ ; loc <- getSrcSpanDs
+ ; 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
@@ -289,9 +347,9 @@ instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
dsLookupGlobal :: Name -> DsM TyThing
-- Very like TcEnv.tcLookupGlobal
dsLookupGlobal name
- = do { env <- getGblEnv
- ; setEnvs (ds_if_env env)
- (tcIfaceGlobal name) }
+ = do { env <- getGblEnv
+ ; setEnvs (ds_if_env env)
+ (tcIfaceGlobal name) }
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
@@ -320,6 +378,51 @@ dsLookupDataCon name
\end{code}
\begin{code}
+-- Complain if 'Data.Array.Parallel.Prim' wasn't loaded (and we are about to use it).
+--
+-- See "Note [Loading Data.Array.Parallel.Prim]".
+--
+assertDAPPLoaded :: DsM ()
+assertDAPPLoaded
+ = do { env <- ds_dph_env <$> getGblEnv
+ ; when (null $ occEnvElts env) $
+ panic "'Data.Array.Parallel.Prim' not available; probably missing dependencies in DPH package"
+ }
+
+-- Look up a name exported by 'Data.Array.Parallel.Prim'.
+--
+lookupDAPPRdrEnv :: OccName -> DsM Name
+lookupDAPPRdrEnv occ
+ = do { env <- ds_dph_env <$> getGblEnv
+ ; let gres = lookupGlobalRdrEnv env occ
+ ; case gres of
+ [] -> pprPanic "Name not found in 'Data.Array.Parallel.Prim':" (ppr occ)
+ [gre] -> return $ gre_name gre
+ _ -> pprPanic "Multiple definitions in 'Data.Array.Parallel.Prim':" (ppr occ)
+ }
+
+-- Find the thing repferred to by an imported name.
+--
+dsImportDecl :: Name -> DsM TyThing
+dsImportDecl name
+ = do { env <- getGblEnv
+ ; setEnvs (ds_if_env env) $ do
+ { mb_thing <- importDecl name
+ ; case mb_thing of
+ Failed err -> failIfM err
+ Succeeded thing -> return thing
+ } }
+
+dsImportId :: Name -> DsM Id
+dsImportId name
+ = tyThingId <$> dsImportDecl name
+
+dsImportTyCon :: Name -> DsM TyCon
+dsImportTyCon name
+ = tyThingTyCon <$> dsImportDecl name
+\end{code}
+
+\begin{code}
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
@@ -327,13 +430,3 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
\end{code}
-
-\begin{code}
-dsLoadModule :: SDoc -> Module -> DsM ()
-dsLoadModule doc mod
- = do { env <- getGblEnv
- ; setEnvs (ds_if_env env)
- (loadSysInterface doc mod >> return ())
- }
-\end{code}
-
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 56d9538524..f84da150fe 100755
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -459,7 +459,6 @@ Library
Util
Vectorise.Builtins.Base
Vectorise.Builtins.Initialise
- Vectorise.Builtins.Modules
Vectorise.Builtins
Vectorise.Monad.Base
Vectorise.Monad.Naming
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index bbee0424ff..cc95762312 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -12,19 +12,19 @@ module LoadIface (
loadSrcInterface, loadInterfaceForName,
-- IfM functions
- loadInterface, loadWiredInHomeIface,
- loadSysInterface, loadUserInterface,
- findAndReadIface, readIface, -- Used when reading the module's old interface
- loadDecls, -- Should move to TcIface and be renamed
- initExternalPackageState,
+ loadInterface, loadWiredInHomeIface,
+ loadSysInterface, loadUserInterface,
+ findAndReadIface, readIface, -- Used when reading the module's old interface
+ loadDecls, -- Should move to TcIface and be renamed
+ initExternalPackageState,
- ifaceStats, pprModIface, showIface
+ ifaceStats, pprModIface, showIface
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
- tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
+import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
+ tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
import DynFlags
import IfaceSyn
@@ -36,7 +36,7 @@ import TcRnMonad
import PrelNames
import PrelInfo
-import MkId ( seqId )
+import MkId ( seqId )
import Rules
import Annotations
import InstEnv
@@ -62,11 +62,11 @@ import Control.Monad
%************************************************************************
-%* *
- loadSrcInterface, loadOrphanModules, loadHomeInterface
+%* *
+ loadSrcInterface, loadOrphanModules, loadHomeInterface
- These three are called from TcM-land
-%* *
+ These three are called from TcM-land
+%* *
%************************************************************************
\begin{code}
@@ -90,11 +90,11 @@ loadSrcInterface doc mod want_boot maybe_pkg = do
Found _ mod -> do
mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
case mb_iface of
- Failed err -> failWithTc err
- Succeeded iface -> return iface
+ Failed err -> failWithTc err
+ Succeeded iface -> return iface
err ->
let dflags = hsc_dflags hsc_env in
- failWithTc (cannotFindInterface dflags mod err)
+ failWithTc (cannotFindInterface dflags mod err)
-- | Load interface for a module.
loadModuleInterface :: SDoc -> Module -> TcM ModIface
@@ -124,13 +124,13 @@ loadInterfaceForName doc name
%*********************************************************
-%* *
- loadInterface
+%* *
+ loadInterface
- The main function to load an interface
- for an imported module, and put it in
- the External Package State
-%* *
+ The main function to load an interface
+ for an imported module, and put it in
+ the External Package State
+%* *
%*********************************************************
\begin{code}
@@ -160,142 +160,142 @@ loadUserInterface is_boot doc mod_name
-- | A wrapper for 'loadInterface' that throws an exception if it fails
loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
loadInterfaceWithException doc mod_name where_from
- = do { mb_iface <- loadInterface doc mod_name where_from
- ; case mb_iface of
- Failed err -> ghcError (ProgramError (showSDoc err))
- Succeeded iface -> return iface }
+ = do { mb_iface <- loadInterface doc mod_name where_from
+ ; case mb_iface of
+ Failed err -> ghcError (ProgramError (showSDoc err))
+ Succeeded iface -> return iface }
------------------
loadInterface :: SDoc -> Module -> WhereFrom
- -> IfM lcl (MaybeErr Message ModIface)
+ -> IfM lcl (MaybeErr Message ModIface)
-- loadInterface looks in both the HPT and PIT for the required interface
-- If not found, it loads it, and puts it in the PIT (always).
-- If it can't find a suitable interface file, we
--- a) modify the PackageIfaceTable to have an empty entry
--- (to avoid repeated complaints)
--- b) return (Left message)
+-- a) modify the PackageIfaceTable to have an empty entry
+-- (to avoid repeated complaints)
+-- b) return (Left message)
--
-- It's not necessarily an error for there not to be an interface
-- file -- perhaps the module has changed, and that interface
-- is no longer used
loadInterface doc_str mod from
- = do { -- Read the state
- (eps,hpt) <- getEpsAndHpt
-
- ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
-
- -- Check whether we have the interface already
- ; dflags <- getDOpts
- ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {
- Just iface
- -> return (Succeeded iface) ; -- Already loaded
- -- The (src_imp == mi_boot iface) test checks that the already-loaded
- -- interface isn't a boot iface. This can conceivably happen,
- -- if an earlier import had a before we got to real imports. I think.
- _ -> do {
-
- -- READ THE MODULE IN
- ; read_result <- case (wantHiBootFile dflags eps mod from) of
+ = do { -- Read the state
+ (eps,hpt) <- getEpsAndHpt
+
+ ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
+
+ -- Check whether we have the interface already
+ ; dflags <- getDOpts
+ ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {
+ Just iface
+ -> return (Succeeded iface) ; -- Already loaded
+ -- The (src_imp == mi_boot iface) test checks that the already-loaded
+ -- interface isn't a boot iface. This can conceivably happen,
+ -- if an earlier import had a before we got to real imports. I think.
+ _ -> do {
+
+ -- READ THE MODULE IN
+ ; read_result <- case (wantHiBootFile dflags eps mod from) of
Failed err -> return (Failed err)
Succeeded hi_boot_file -> findAndReadIface doc_str mod hi_boot_file
- ; case read_result of {
- Failed err -> do
- { let fake_iface = emptyModIface mod
-
- ; updateEps_ $ \eps ->
- eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
- -- Not found, so add an empty iface to
- -- the EPS map so that we don't look again
-
- ; return (Failed err) } ;
-
- -- Found and parsed!
- -- We used to have a sanity check here that looked for:
- -- * System importing ..
- -- * a home package module ..
- -- * that we know nothing about (mb_dep == Nothing)!
- --
- -- But this is no longer valid because thNameToGhcName allows users to
- -- cause the system to load arbitrary interfaces (by supplying an appropriate
- -- Template Haskell original-name).
- Succeeded (iface, file_path) ->
-
- let
- loc_doc = text file_path
- in
- initIfaceLcl mod loc_doc $ do
-
- -- Load the new ModIface into the External Package State
- -- Even home-package interfaces loaded by loadInterface
- -- (which only happens in OneShot mode; in Batch/Interactive
- -- mode, home-package modules are loaded one by one into the HPT)
- -- are put in the EPS.
- --
- -- The main thing is to add the ModIface to the PIT, but
- -- we also take the
- -- IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo
- -- out of the ModIface and put them into the big EPS pools
-
- -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
- --- names is done correctly (notably, whether this is an .hi file or .hi-boot file).
- -- If we do loadExport first the wrong info gets into the cache (unless we
- -- explicitly tag each export which seems a bit of a bore)
-
- ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
- ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
- ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
- ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
- ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
+ ; case read_result of {
+ Failed err -> do
+ { let fake_iface = emptyModIface mod
+
+ ; updateEps_ $ \eps ->
+ eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
+ -- Not found, so add an empty iface to
+ -- the EPS map so that we don't look again
+
+ ; return (Failed err) } ;
+
+ -- Found and parsed!
+ -- We used to have a sanity check here that looked for:
+ -- * System importing ..
+ -- * a home package module ..
+ -- * that we know nothing about (mb_dep == Nothing)!
+ --
+ -- But this is no longer valid because thNameToGhcName allows users to
+ -- cause the system to load arbitrary interfaces (by supplying an appropriate
+ -- Template Haskell original-name).
+ Succeeded (iface, file_path) ->
+
+ let
+ loc_doc = text file_path
+ in
+ initIfaceLcl mod loc_doc $ do
+
+ -- Load the new ModIface into the External Package State
+ -- Even home-package interfaces loaded by loadInterface
+ -- (which only happens in OneShot mode; in Batch/Interactive
+ -- mode, home-package modules are loaded one by one into the HPT)
+ -- are put in the EPS.
+ --
+ -- The main thing is to add the ModIface to the PIT, but
+ -- we also take the
+ -- IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo
+ -- out of the ModIface and put them into the big EPS pools
+
+ -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
+ --- names is done correctly (notably, whether this is an .hi file or .hi-boot file).
+ -- If we do loadExport first the wrong info gets into the cache (unless we
+ -- explicitly tag each export which seems a bit of a bore)
+
+ ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
+ ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
+ ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+ ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
+ ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls)
(mi_vect_info iface)
- ; let { final_iface = iface {
- mi_decls = panic "No mi_decls in PIT",
- mi_insts = panic "No mi_insts in PIT",
- mi_fam_insts = panic "No mi_fam_insts in PIT",
- mi_rules = panic "No mi_rules in PIT",
- mi_anns = panic "No mi_anns in PIT"
+ ; let { final_iface = iface {
+ mi_decls = panic "No mi_decls in PIT",
+ mi_insts = panic "No mi_insts in PIT",
+ mi_fam_insts = panic "No mi_fam_insts in PIT",
+ mi_rules = panic "No mi_rules in PIT",
+ mi_anns = panic "No mi_anns in PIT"
}
}
- ; updateEps_ $ \ eps ->
+ ; updateEps_ $ \ eps ->
if elemModuleEnv mod (eps_PIT eps) then eps else
- eps {
- eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
- eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
- eps_rule_base = extendRuleBaseList (eps_rule_base eps)
- new_eps_rules,
- eps_inst_env = extendInstEnvList (eps_inst_env eps)
- new_eps_insts,
- eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
- new_eps_fam_insts,
+ eps {
+ eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
+ eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
+ eps_rule_base = extendRuleBaseList (eps_rule_base eps)
+ new_eps_rules,
+ eps_inst_env = extendInstEnvList (eps_inst_env eps)
+ new_eps_insts,
+ eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
+ new_eps_fam_insts,
eps_vect_info = plusVectInfo (eps_vect_info eps)
new_eps_vect_info,
eps_ann_env = extendAnnEnvList (eps_ann_env eps)
new_eps_anns,
eps_mod_fam_inst_env
- = let
- fam_inst_env =
- extendFamInstEnvList emptyFamInstEnv
- new_eps_fam_insts
- in
- extendModuleEnv (eps_mod_fam_inst_env eps)
- mod
- fam_inst_env,
- eps_stats = addEpsInStats (eps_stats eps)
- (length new_eps_decls)
- (length new_eps_insts)
- (length new_eps_rules) }
-
- ; return (Succeeded final_iface)
+ = let
+ fam_inst_env =
+ extendFamInstEnvList emptyFamInstEnv
+ new_eps_fam_insts
+ in
+ extendModuleEnv (eps_mod_fam_inst_env eps)
+ mod
+ fam_inst_env,
+ eps_stats = addEpsInStats (eps_stats eps)
+ (length new_eps_decls)
+ (length new_eps_insts)
+ (length new_eps_rules) }
+
+ ; return (Succeeded final_iface)
}}}}
wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
- -> MaybeErr Message IsBootInterface
+ -> MaybeErr Message IsBootInterface
-- Figure out whether we want Foo.hi or Foo.hi-boot
wantHiBootFile dflags eps mod from
= case from of
@@ -312,10 +312,10 @@ wantHiBootFile dflags eps mod from
| otherwise
-> case lookupUFM (eps_is_boot eps) (moduleName mod) of
- Just (_, is_boot) -> Succeeded is_boot
- Nothing -> Succeeded False
- -- The boot-ness of the requested interface,
- -- based on the dependencies in directly-imported modules
+ Just (_, is_boot) -> Succeeded is_boot
+ Nothing -> Succeeded False
+ -- The boot-ness of the requested interface,
+ -- based on the dependencies in directly-imported modules
where
this_package = thisPackage dflags == modulePackageId mod
@@ -334,12 +334,12 @@ badDepMsg :: Module -> SDoc
badDepMsg mod
= hang (ptext (sLit "Interface file inconsistency:"))
2 (sep [ptext (sLit "home-package module") <+> quotes (ppr mod) <+> ptext (sLit "is needed,"),
- ptext (sLit "but is not listed in the dependencies of the interfaces directly imported by the module being compiled")])
+ ptext (sLit "but is not listed in the dependencies of the interfaces directly imported by the module being compiled")])
-}
\begin{code}
-----------------------------------------------------
--- Loading type/class/value decls
+-- Loading type/class/value decls
-- We pass the full Module name here, replete with
-- its package info, so that we can build a Name for
-- each binder with the right package info in it
@@ -355,35 +355,35 @@ addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
addDeclsToPTE pte things = extendNameEnvList pte things
loadDecls :: Bool
- -> [(Fingerprint, IfaceDecl)]
- -> IfL [(Name,TyThing)]
+ -> [(Fingerprint, IfaceDecl)]
+ -> IfL [(Name,TyThing)]
loadDecls ignore_prags ver_decls
= do { mod <- getIfModule
- ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
- ; return (concat thingss)
- }
-
-loadDecl :: Bool -- Don't load pragmas into the decl pool
- -> Module
- -> (Fingerprint, IfaceDecl)
- -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
- -- TyThings are forkM'd thunks
+ ; thingss <- mapM (loadDecl ignore_prags mod) ver_decls
+ ; return (concat thingss)
+ }
+
+loadDecl :: Bool -- Don't load pragmas into the decl pool
+ -> Module
+ -> (Fingerprint, IfaceDecl)
+ -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
+ -- TyThings are forkM'd thunks
loadDecl ignore_prags mod (_version, decl)
- = do { -- Populate the name cache with final versions of all
- -- the names associated with the decl
- main_name <- lookupOrig mod (ifName decl)
+ = do { -- Populate the name cache with final versions of all
+ -- the names associated with the decl
+ main_name <- lookupOrig mod (ifName decl)
-- ; traceIf (text "Loading decl for " <> ppr main_name)
- ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl)
+ ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl)
- -- Typecheck the thing, lazily
- -- NB. Firstly, the laziness is there in case we never need the
- -- declaration (in one-shot mode), and secondly it is there so that
- -- we don't look up the occurrence of a name before calling mk_new_bndr
- -- on the binder. This is important because we must get the right name
- -- which includes its nameParent.
+ -- Typecheck the thing, lazily
+ -- NB. Firstly, the laziness is there in case we never need the
+ -- declaration (in one-shot mode), and secondly it is there so that
+ -- we don't look up the occurrence of a name before calling mk_new_bndr
+ -- on the binder. This is important because we must get the right name
+ -- which includes its nameParent.
- ; thing <- forkM doc $ do { bumpDeclStats main_name
- ; tcIfaceDecl ignore_prags decl }
+ ; thing <- forkM doc $ do { bumpDeclStats main_name
+ ; tcIfaceDecl ignore_prags decl }
-- Populate the type environment with the implicitTyThings too.
--
@@ -394,12 +394,12 @@ loadDecl ignore_prags mod (_version, decl)
-- 'forkM'd by tcIfaceDecl.
--
-- In more detail: Consider the example
- -- data T a = MkT { x :: T a }
+ -- data T a = MkT { x :: T a }
-- The implicitTyThings of T are: [ <datacon MkT>, <selector x>]
-- (plus their workers, wrappers, coercions etc etc)
--
-- We want to return an environment
- -- [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]
+ -- [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]
-- (where the "MkT" is the *Name* associated with MkT, etc.)
--
-- We do this by mapping the implict_names to the associated
@@ -440,71 +440,71 @@ loadDecl ignore_prags mod (_version, decl)
-- This mini-env and lookup function mediates between the
--'Name's n and the map from 'OccName's to the implicit TyThings
- ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
- lookup n = case lookupOccEnv mini_env (getOccName n) of
- Just thing -> thing
- Nothing ->
- pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
+ ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
+ lookup n = case lookupOccEnv mini_env (getOccName n) of
+ Just thing -> thing
+ Nothing ->
+ pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
- ; return $ (main_name, thing) :
+ ; return $ (main_name, thing) :
-- uses the invariant that implicit_names and
-- implictTyThings are bijective
[(n, lookup n) | n <- implicit_names]
- }
+ }
where
doc = ptext (sLit "Declaration for") <+> ppr (ifName decl)
-bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used
+bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used
bumpDeclStats name
- = do { traceIf (text "Loading decl for" <+> ppr name)
- ; updateEps_ (\eps -> let stats = eps_stats eps
- in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
- }
+ = do { traceIf (text "Loading decl for" <+> ppr name)
+ ; updateEps_ (\eps -> let stats = eps_stats eps
+ in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
+ }
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Reading an interface file}
-%* *
+%* *
%*********************************************************
\begin{code}
findAndReadIface :: SDoc -> Module
- -> IsBootInterface -- True <=> Look for a .hi-boot file
- -- False <=> Look for .hi file
- -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
- -- Nothing <=> file not found, or unreadable, or illegible
- -- Just x <=> successfully found and parsed
+ -> IsBootInterface -- True <=> Look for a .hi-boot file
+ -- False <=> Look for .hi file
+ -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
+ -- Nothing <=> file not found, or unreadable, or illegible
+ -- Just x <=> successfully found and parsed
- -- It *doesn't* add an error to the monad, because
- -- sometimes it's ok to fail... see notes with loadInterface
+ -- It *doesn't* add an error to the monad, because
+ -- sometimes it's ok to fail... see notes with loadInterface
findAndReadIface doc_str mod hi_boot_file
- = do { traceIf (sep [hsep [ptext (sLit "Reading"),
- if hi_boot_file
- then ptext (sLit "[boot]")
- else empty,
- ptext (sLit "interface for"),
- ppr mod <> semi],
- nest 4 (ptext (sLit "reason:") <+> doc_str)])
-
- -- Check for GHC.Prim, and return its static interface
- ; dflags <- getDOpts
- ; if mod == gHC_PRIM
- then return (Succeeded (ghcPrimIface,
- "<built in interface for GHC.Prim>"))
- else do
-
- -- Look for the file
- ; hsc_env <- getTopEnv
- ; mb_found <- liftIO (findExactModule hsc_env mod)
- ; case mb_found of {
+ = do { traceIf (sep [hsep [ptext (sLit "Reading"),
+ if hi_boot_file
+ then ptext (sLit "[boot]")
+ else empty,
+ ptext (sLit "interface for"),
+ ppr mod <> semi],
+ nest 4 (ptext (sLit "reason:") <+> doc_str)])
+
+ -- Check for GHC.Prim, and return its static interface
+ ; dflags <- getDOpts
+ ; if mod == gHC_PRIM
+ then return (Succeeded (ghcPrimIface,
+ "<built in interface for GHC.Prim>"))
+ else do
+
+ -- Look for the file
+ ; hsc_env <- getTopEnv
+ ; mb_found <- liftIO (findExactModule hsc_env mod)
+ ; case mb_found of {
- Found loc mod -> do
+ Found loc mod -> do
- -- Found file, so read it
- { let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) }
+ -- Found file, so read it
+ { let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) }
-- If the interface is in the current package then if we could
-- load it would already be in the HPT and we assume that our
@@ -515,21 +515,21 @@ findAndReadIface doc_str mod hi_boot_file
else do {
; traceIf (ptext (sLit "readIFace") <+> text file_path)
- ; read_result <- readIface mod file_path hi_boot_file
- ; case read_result of
- Failed err -> return (Failed (badIfaceFile file_path err))
- Succeeded iface
- | mi_module iface /= mod ->
- return (Failed (wrongIfaceModErr iface mod file_path))
- | otherwise ->
- return (Succeeded (iface, file_path))
- -- Don't forget to fill in the package name...
- }}
- ; err -> do
- { traceIf (ptext (sLit "...not found"))
- ; dflags <- getDOpts
- ; return (Failed (cannotFindInterface dflags
- (moduleName mod) err)) }
+ ; read_result <- readIface mod file_path hi_boot_file
+ ; case read_result of
+ Failed err -> return (Failed (badIfaceFile file_path err))
+ Succeeded iface
+ | mi_module iface /= mod ->
+ return (Failed (wrongIfaceModErr iface mod file_path))
+ | otherwise ->
+ return (Succeeded (iface, file_path))
+ -- Don't forget to fill in the package name...
+ }}
+ ; err -> do
+ { traceIf (ptext (sLit "...not found"))
+ ; dflags <- getDOpts
+ ; return (Failed (cannotFindInterface dflags
+ (moduleName mod) err)) }
}
}
\end{code}
@@ -538,30 +538,30 @@ findAndReadIface doc_str mod hi_boot_file
\begin{code}
readIface :: Module -> FilePath -> IsBootInterface
- -> TcRnIf gbl lcl (MaybeErr Message ModIface)
- -- Failed err <=> file not found, or unreadable, or illegible
- -- Succeeded iface <=> successfully found and parsed
+ -> TcRnIf gbl lcl (MaybeErr Message ModIface)
+ -- Failed err <=> file not found, or unreadable, or illegible
+ -- Succeeded iface <=> successfully found and parsed
readIface wanted_mod file_path _
- = do { res <- tryMostM $
+ = do { res <- tryMostM $
readBinIface CheckHiWay QuietBinIFaceReading file_path
- ; case res of
- Right iface
- | wanted_mod == actual_mod -> return (Succeeded iface)
- | otherwise -> return (Failed err)
- where
- actual_mod = mi_module iface
- err = hiModuleNameMismatchWarn wanted_mod actual_mod
-
- Left exn -> return (Failed (text (showException exn)))
+ ; case res of
+ Right iface
+ | wanted_mod == actual_mod -> return (Succeeded iface)
+ | otherwise -> return (Failed err)
+ where
+ actual_mod = mi_module iface
+ err = hiModuleNameMismatchWarn wanted_mod actual_mod
+
+ Left exn -> return (Failed (text (showException exn)))
}
\end{code}
%*********************************************************
-%* *
- Wired-in interface for GHC.Prim
-%* *
+%* *
+ Wired-in interface for GHC.Prim
+%* *
%*********************************************************
\begin{code}
@@ -574,42 +574,42 @@ initExternalPackageState
eps_inst_env = emptyInstEnv,
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules,
- -- Initialise the EPS rule pool with the built-in rules
+ -- Initialise the EPS rule pool with the built-in rules
eps_mod_fam_inst_env
= emptyModuleEnv,
eps_vect_info = noVectInfo,
eps_ann_env = emptyAnnEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
- , n_insts_in = 0, n_insts_out = 0
- , n_rules_in = length builtinRules, n_rules_out = 0 }
+ , n_insts_in = 0, n_insts_out = 0
+ , n_rules_in = length builtinRules, n_rules_out = 0 }
}
\end{code}
%*********************************************************
-%* *
- Wired-in interface for GHC.Prim
-%* *
+%* *
+ Wired-in interface for GHC.Prim
+%* *
%*********************************************************
\begin{code}
ghcPrimIface :: ModIface
ghcPrimIface
= (emptyModIface gHC_PRIM) {
- mi_exports = ghcPrimExports,
- mi_decls = [],
- mi_fixities = fixities,
- mi_fix_fn = mkIfaceFixCache fixities
- }
+ mi_exports = ghcPrimExports,
+ mi_decls = [],
+ mi_fixities = fixities,
+ mi_fix_fn = mkIfaceFixCache fixities
+ }
where
fixities = [(getOccName seqId, Fixity 0 InfixR)]
- -- seq is infixr 0
+ -- seq is infixr 0
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Statistics}
-%* *
+%* *
%*********************************************************
\begin{code}
@@ -619,21 +619,21 @@ ifaceStats eps
where
stats = eps_stats eps
msg = vcat
- [int (n_ifaces_in stats) <+> text "interfaces read",
- hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
- int (n_decls_in stats), text "read"],
- hsep [ int (n_insts_out stats), text "instance decls imported, out of",
- int (n_insts_in stats), text "read"],
- hsep [ int (n_rules_out stats), text "rule decls imported, out of",
- int (n_rules_in stats), text "read"]
- ]
+ [int (n_ifaces_in stats) <+> text "interfaces read",
+ hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
+ int (n_decls_in stats), text "read"],
+ hsep [ int (n_insts_out stats), text "instance decls imported, out of",
+ int (n_insts_in stats), text "read"],
+ hsep [ int (n_rules_out stats), text "rule decls imported, out of",
+ int (n_rules_in stats), text "read"]
+ ]
\end{code}
%************************************************************************
-%* *
- Printing interfaces
-%* *
+%* *
+ Printing interfaces
+%* *
%************************************************************************
\begin{code}
@@ -652,23 +652,23 @@ pprModIface :: ModIface -> SDoc
-- Show a ModIface
pprModIface iface
= vcat [ ptext (sLit "interface")
- <+> ppr (mi_module iface) <+> pp_boot
- <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty)
- <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty)
- <+> (if mi_hpc iface then ptext (sLit "[hpc]") else empty)
- <+> integer opt_HiVersion
+ <+> ppr (mi_module iface) <+> pp_boot
+ <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty)
+ <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty)
+ <+> (if mi_hpc iface then ptext (sLit "[hpc]") else empty)
+ <+> integer opt_HiVersion
, nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
, nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
, nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
, nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
, nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
, nest 2 (ptext (sLit "where"))
- , ptext (sLit "exports:")
+ , ptext (sLit "exports:")
, nest 2 (vcat (map pprExport (mi_exports iface)))
- , pprDeps (mi_deps iface)
- , vcat (map pprUsage (mi_usages iface))
- , vcat (map pprIfaceAnnotation (mi_anns iface))
- , pprFixities (mi_fixities iface)
+ , pprDeps (mi_deps iface)
+ , vcat (map pprUsage (mi_usages iface))
+ , vcat (map pprIfaceAnnotation (mi_anns iface))
+ , pprFixities (mi_fixities iface)
, vcat (map pprIfaceDecl (mi_decls iface))
, vcat (map ppr (mi_insts iface))
, vcat (map ppr (mi_fam_insts iface))
@@ -684,9 +684,9 @@ pprModIface iface
\end{code}
When printing export lists, we print like this:
- Avail f f
- AvailTC C [C, x, y] C(x,y)
- AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
+ Avail f f
+ AvailTC C [C, x, y] C(x,y)
+ AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
\begin{code}
pprExport :: IfaceExport -> SDoc
@@ -705,7 +705,7 @@ pprUsage usage@UsagePackageModule{}
pprUsage usage@UsageHomeModule{}
= pprUsageImport usage usg_mod_name $$
nest 2 (
- maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
+ maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
)
@@ -719,12 +719,12 @@ pprUsageImport usage usg_mod'
pprDeps :: Dependencies -> SDoc
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
- dep_finsts = finsts })
+ dep_finsts = finsts })
= vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods),
- ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs),
- ptext (sLit "orphans:") <+> fsep (map ppr orphs),
- ptext (sLit "family instance modules:") <+> fsep (map ppr finsts)
- ]
+ ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs),
+ ptext (sLit "orphans:") <+> fsep (map ppr orphs),
+ ptext (sLit "family instance modules:") <+> fsep (map ppr finsts)
+ ]
where
ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
ppr_pkg (pkg,trust_req) = ppr pkg <>
@@ -739,8 +739,8 @@ pprIfaceDecl (ver, decl)
pprFixities :: [(OccName, Fixity)] -> SDoc
pprFixities [] = empty
pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes
- where
- pprFix (occ,fix) = ppr fix <+> ppr occ
+ where
+ pprFix (occ,fix) = ppr fix <+> ppr occ
pprVectInfo :: IfaceVectInfo -> SDoc
pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars
@@ -767,7 +767,7 @@ instance Outputable Warnings where
ppr = pprWarns
pprWarns :: Warnings -> SDoc
-pprWarns NoWarnings = empty
+pprWarns NoWarnings = empty
pprWarns (WarnAll txt) = ptext (sLit "Warn all") <+> ppr txt
pprWarns (WarnSome prs) = ptext (sLit "Warnings")
<+> vcat (map pprWarning prs)
@@ -780,16 +780,16 @@ pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedVal
%*********************************************************
-%* *
+%* *
\subsection{Errors}
-%* *
+%* *
%*********************************************************
\begin{code}
badIfaceFile :: String -> SDoc -> SDoc
badIfaceFile file err
= vcat [ptext (sLit "Bad interface file:") <+> text file,
- nest 4 err]
+ nest 4 err]
hiModuleNameMismatchWarn :: Module -> Module -> Message
hiModuleNameMismatchWarn requested_mod read_mod =
@@ -797,21 +797,21 @@ hiModuleNameMismatchWarn requested_mod read_mod =
-- we want the Modules below to be qualified with package names,
-- so reset the PrintUnqualified setting.
hsep [ ptext (sLit "Something is amiss; requested module ")
- , ppr requested_mod
- , ptext (sLit "differs from name found in the interface file")
- , ppr read_mod
- ]
+ , ppr requested_mod
+ , ptext (sLit "differs from name found in the interface file")
+ , ppr read_mod
+ ]
wrongIfaceModErr :: ModIface -> Module -> String -> SDoc
wrongIfaceModErr iface mod_name file_path
= sep [ptext (sLit "Interface file") <+> iface_file,
ptext (sLit "contains module") <+> quotes (ppr (mi_module iface)) <> comma,
ptext (sLit "but we were expecting module") <+> quotes (ppr mod_name),
- sep [ptext (sLit "Probable cause: the source code which generated"),
- nest 2 iface_file,
- ptext (sLit "has an incompatible module name")
- ]
- ]
+ sep [ptext (sLit "Probable cause: the source code which generated"),
+ nest 2 iface_file,
+ ptext (sLit "has an incompatible module name")
+ ]
+ ]
where iface_file = doubleQuotes (text file_path)
homeModError :: Module -> ModLocation -> SDoc
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 2115034b38..dff668f5ac 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -7,9 +7,9 @@ Type checking of type signatures in interface files
\begin{code}
module TcIface (
- tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
- tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
- tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings
+ tcImportDecl, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
+ tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
+ tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings
) where
#include "HsVersions.h"
@@ -55,7 +55,7 @@ import Demand ( isBottomingSig )
import Module
import UniqFM
import UniqSupply
-import Outputable
+import Outputable
import ErrUtils
import Maybes
import SrcLoc
@@ -64,49 +64,48 @@ import Util
import FastString
import Control.Monad
-import Data.List
\end{code}
This module takes
- IfaceDecl -> TyThing
- IfaceType -> Type
- etc
+ IfaceDecl -> TyThing
+ IfaceType -> Type
+ etc
An IfaceDecl is populated with RdrNames, and these are not renamed to
Names before typechecking, because there should be no scope errors etc.
- -- For (b) consider: f = \$(...h....)
- -- where h is imported, and calls f via an hi-boot file.
- -- This is bad! But it is not seen as a staging error, because h
- -- is indeed imported. We don't want the type-checker to black-hole
- -- when simplifying and compiling the splice!
- --
- -- Simple solution: discard any unfolding that mentions a variable
- -- bound in this module (and hence not yet processed).
- -- The discarding happens when forkM finds a type error.
+ -- For (b) consider: f = \$(...h....)
+ -- where h is imported, and calls f via an hi-boot file.
+ -- This is bad! But it is not seen as a staging error, because h
+ -- is indeed imported. We don't want the type-checker to black-hole
+ -- when simplifying and compiling the splice!
+ --
+ -- Simple solution: discard any unfolding that mentions a variable
+ -- bound in this module (and hence not yet processed).
+ -- The discarding happens when forkM finds a type error.
%************************************************************************
-%* *
-%* tcImportDecl is the key function for "faulting in" *
-%* imported things
-%* *
+%* *
+%* tcImportDecl is the key function for "faulting in" *
+%* imported things
+%* *
%************************************************************************
The main idea is this. We are chugging along type-checking source code, and
find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find
it in the EPS type envt. So it
- 1 loads GHC.Base.hi
- 2 gets the decl for GHC.Base.map
- 3 typechecks it via tcIfaceDecl
- 4 and adds it to the type env in the EPS
+ 1 loads GHC.Base.hi
+ 2 gets the decl for GHC.Base.map
+ 3 typechecks it via tcIfaceDecl
+ 4 and adds it to the type env in the EPS
Note that DURING STEP 4, we may find that map's type mentions a type
constructor that also
Notice that for imported things we read the current version from the EPS
mutable variable. This is important in situations like
- ...$(e1)...$(e2)...
+ ...$(e1)...$(e2)...
where the code that e1 expands to might import some defns that
also turn out to be needed by the code that e2 expands to.
@@ -115,49 +114,49 @@ tcImportDecl :: Name -> TcM TyThing
-- Entry point for *source-code* uses of importDecl
tcImportDecl name
| Just thing <- wiredInNameTyThing_maybe name
- = do { when (needWiredInHomeIface thing)
- (initIfaceTcRn (loadWiredInHomeIface name))
- -- See Note [Loading instances for wired-in things]
- ; return thing }
+ = do { when (needWiredInHomeIface thing)
+ (initIfaceTcRn (loadWiredInHomeIface name))
+ -- See Note [Loading instances for wired-in things]
+ ; return thing }
| otherwise
- = do { traceIf (text "tcImportDecl" <+> ppr name)
- ; mb_thing <- initIfaceTcRn (importDecl name)
- ; case mb_thing of
- Succeeded thing -> return thing
- Failed err -> failWithTc err }
+ = do { traceIf (text "tcImportDecl" <+> ppr name)
+ ; mb_thing <- initIfaceTcRn (importDecl name)
+ ; case mb_thing of
+ Succeeded thing -> return thing
+ Failed err -> failWithTc err }
importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
-- Get the TyThing for this Name from an interface file
-- It's not a wired-in thing -- the caller caught that
importDecl name
= ASSERT( not (isWiredInName name) )
- do { traceIf nd_doc
-
- -- Load the interface, which should populate the PTE
- ; mb_iface <- ASSERT2( isExternalName name, ppr name )
- loadInterface nd_doc (nameModule name) ImportBySystem
- ; case mb_iface of {
- Failed err_msg -> return (Failed err_msg) ;
- Succeeded _ -> do
-
- -- Now look it up again; this time we should find it
- { eps <- getEps
- ; case lookupTypeEnv (eps_PTE eps) name of
- Just thing -> return (Succeeded thing)
- Nothing -> return (Failed not_found_msg)
+ do { traceIf nd_doc
+
+ -- Load the interface, which should populate the PTE
+ ; mb_iface <- ASSERT2( isExternalName name, ppr name )
+ loadInterface nd_doc (nameModule name) ImportBySystem
+ ; case mb_iface of {
+ Failed err_msg -> return (Failed err_msg) ;
+ Succeeded _ -> do
+
+ -- Now look it up again; this time we should find it
+ { eps <- getEps
+ ; case lookupTypeEnv (eps_PTE eps) name of
+ Just thing -> return (Succeeded thing)
+ Nothing -> return (Failed not_found_msg)
}}}
where
nd_doc = ptext (sLit "Need decl for") <+> ppr name
not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+>
- pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
- 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
- ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
+ pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
+ 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
+ ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
\end{code}
%************************************************************************
-%* *
+%* *
Checks for wired-in things
-%* *
+%* *
%************************************************************************
Note [Loading instances for wired-in things]
@@ -193,18 +192,18 @@ checkWiredInTyCon :: TyCon -> TcM ()
-- are loaded. See Note [Loading instances for wired-in things]
-- It might not be a wired-in tycon (see the calls in TcUnify),
-- in which case this is a no-op.
-checkWiredInTyCon tc
+checkWiredInTyCon tc
| not (isWiredInName tc_name)
= return ()
| otherwise
- = do { mod <- getModule
- ; ASSERT( isExternalName tc_name )
- when (mod /= nameModule tc_name)
- (initIfaceTcRn (loadWiredInHomeIface tc_name))
- -- Don't look for (non-existent) Float.hi when
- -- compiling Float.lhs, which mentions Float of course
- -- A bit yukky to call initIfaceTcRn here
- }
+ = do { mod <- getModule
+ ; ASSERT( isExternalName tc_name )
+ when (mod /= nameModule tc_name)
+ (initIfaceTcRn (loadWiredInHomeIface tc_name))
+ -- Don't look for (non-existent) Float.hi when
+ -- compiling Float.lhs, which mentions Float of course
+ -- A bit yukky to call initIfaceTcRn here
+ }
where
tc_name = tyConName tc
@@ -214,16 +213,16 @@ ifCheckWiredInThing :: TyThing -> IfL ()
-- Ditto want to ensure that RULES are loaded too
-- See Note [Loading instances for wired-in things]
ifCheckWiredInThing thing
- = do { mod <- getIfModule
- -- Check whether we are typechecking the interface for this
- -- very module. E.g when compiling the base library in --make mode
- -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
- -- the HPT, so without the test we'll demand-load it into the PIT!
- -- C.f. the same test in checkWiredInTyCon above
+ = do { mod <- getIfModule
+ -- Check whether we are typechecking the interface for this
+ -- very module. E.g when compiling the base library in --make mode
+ -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
+ -- the HPT, so without the test we'll demand-load it into the PIT!
+ -- C.f. the same test in checkWiredInTyCon above
; let name = getName thing
- ; ASSERT2( isExternalName name, ppr name )
- when (needWiredInHomeIface thing && mod /= nameModule name)
- (loadWiredInHomeIface name) }
+ ; ASSERT2( isExternalName name, ppr name )
+ when (needWiredInHomeIface thing && mod /= nameModule name)
+ (loadWiredInHomeIface name) }
needWiredInHomeIface :: TyThing -> Bool
-- Only for TyCons; see Note [Loading instances for wired-in things]
@@ -232,9 +231,9 @@ needWiredInHomeIface _ = False
\end{code}
%************************************************************************
-%* *
- Type-checking a complete interface
-%* *
+%* *
+ Type-checking a complete interface
+%* *
%************************************************************************
Suppose we discover we don't need to recompile. Then we must type
@@ -246,59 +245,59 @@ knot. Remember, the decls aren't necessarily in dependency order --
and even if they were, the type decls might be mutually recursive.
\begin{code}
-typecheckIface :: ModIface -- Get the decls from here
- -> TcRnIf gbl lcl ModDetails
+typecheckIface :: ModIface -- Get the decls from here
+ -> TcRnIf gbl lcl ModDetails
typecheckIface iface
= initIfaceTc iface $ \ tc_env_var -> do
- -- The tc_env_var is freshly allocated, private to
- -- type-checking this particular interface
- { -- Get the right set of decls and rules. If we are compiling without -O
- -- we discard pragmas before typechecking, so that we don't "see"
- -- information that we shouldn't. From a versioning point of view
- -- It's not actually *wrong* to do so, but in fact GHCi is unable
- -- to handle unboxed tuples, so it must not see unfoldings.
- ignore_prags <- doptM Opt_IgnoreInterfacePragmas
-
- -- Typecheck the decls. This is done lazily, so that the knot-tying
- -- within this single module work out right. In the If monad there is
- -- no global envt for the current interface; instead, the knot is tied
- -- through the if_rec_types field of IfGblEnv
- ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
- ; let type_env = mkNameEnv names_w_things
- ; writeMutVar tc_env_var type_env
-
- -- Now do those rules, instances and annotations
- ; insts <- mapM tcIfaceInst (mi_insts iface)
- ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
- ; rules <- tcIfaceRules ignore_prags (mi_rules iface)
- ; anns <- tcIfaceAnnotations (mi_anns iface)
+ -- The tc_env_var is freshly allocated, private to
+ -- type-checking this particular interface
+ { -- Get the right set of decls and rules. If we are compiling without -O
+ -- we discard pragmas before typechecking, so that we don't "see"
+ -- information that we shouldn't. From a versioning point of view
+ -- It's not actually *wrong* to do so, but in fact GHCi is unable
+ -- to handle unboxed tuples, so it must not see unfoldings.
+ ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+
+ -- Typecheck the decls. This is done lazily, so that the knot-tying
+ -- within this single module work out right. In the If monad there is
+ -- no global envt for the current interface; instead, the knot is tied
+ -- through the if_rec_types field of IfGblEnv
+ ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
+ ; let type_env = mkNameEnv names_w_things
+ ; writeMutVar tc_env_var type_env
+
+ -- Now do those rules, instances and annotations
+ ; insts <- mapM tcIfaceInst (mi_insts iface)
+ ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+ ; rules <- tcIfaceRules ignore_prags (mi_rules iface)
+ ; anns <- tcIfaceAnnotations (mi_anns iface)
-- Vectorisation information
; vect_info <- tcIfaceVectInfo (mi_module iface) type_env
(mi_vect_info iface)
- -- Exports
- ; exports <- ifaceExportNames (mi_exports iface)
-
- -- Finished
- ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
- text "Type envt:" <+> ppr type_env])
- ; return $ ModDetails { md_types = type_env
- , md_insts = insts
- , md_fam_insts = fam_insts
- , md_rules = rules
- , md_anns = anns
+ -- Exports
+ ; exports <- ifaceExportNames (mi_exports iface)
+
+ -- Finished
+ ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
+ text "Type envt:" <+> ppr type_env])
+ ; return $ ModDetails { md_types = type_env
+ , md_insts = insts
+ , md_fam_insts = fam_insts
+ , md_rules = rules
+ , md_anns = anns
, md_vect_info = vect_info
- , md_exports = exports
- }
+ , md_exports = exports
+ }
}
\end{code}
%************************************************************************
-%* *
- Type and class declarations
-%* *
+%* *
+ Type and class declarations
+%* *
%************************************************************************
\begin{code}
@@ -307,68 +306,68 @@ tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
-- if it indeed exists in the transitive closure of imports
-- Return the ModDetails, empty if no hi-boot iface
tcHiBootIface hsc_src mod
- | isHsBoot hsc_src -- Already compiling a hs-boot file
+ | isHsBoot hsc_src -- Already compiling a hs-boot file
= return emptyModDetails
| otherwise
- = do { traceIf (text "loadHiBootInterface" <+> ppr mod)
-
- ; mode <- getGhcMode
- ; if not (isOneShot mode)
- -- In --make and interactive mode, if this module has an hs-boot file
- -- we'll have compiled it already, and it'll be in the HPT
- --
- -- We check wheher the interface is a *boot* interface.
- -- It can happen (when using GHC from Visual Studio) that we
- -- compile a module in TypecheckOnly mode, with a stable,
- -- fully-populated HPT. In that case the boot interface isn't there
- -- (it's been replaced by the mother module) so we can't check it.
- -- And that's fine, because if M's ModInfo is in the HPT, then
- -- it's been compiled once, and we don't need to check the boot iface
- then do { hpt <- getHpt
- ; case lookupUFM hpt (moduleName mod) of
- Just info | mi_boot (hm_iface info)
- -> return (hm_details info)
- _ -> return emptyModDetails }
- else do
-
- -- OK, so we're in one-shot mode.
- -- In that case, we're read all the direct imports by now,
- -- so eps_is_boot will record if any of our imports mention us by
- -- way of hi-boot file
- { eps <- getEps
- ; case lookupUFM (eps_is_boot eps) (moduleName mod) of {
- Nothing -> return emptyModDetails ; -- The typical case
-
- Just (_, False) -> failWithTc moduleLoop ;
- -- Someone below us imported us!
- -- This is a loop with no hi-boot in the way
-
- Just (_mod, True) -> -- There's a hi-boot interface below us
-
- do { read_result <- findAndReadIface
- need mod
- True -- Hi-boot file
-
- ; case read_result of
- Failed err -> failWithTc (elaborate err)
- Succeeded (iface, _path) -> typecheckIface iface
+ = do { traceIf (text "loadHiBootInterface" <+> ppr mod)
+
+ ; mode <- getGhcMode
+ ; if not (isOneShot mode)
+ -- In --make and interactive mode, if this module has an hs-boot file
+ -- we'll have compiled it already, and it'll be in the HPT
+ --
+ -- We check wheher the interface is a *boot* interface.
+ -- It can happen (when using GHC from Visual Studio) that we
+ -- compile a module in TypecheckOnly mode, with a stable,
+ -- fully-populated HPT. In that case the boot interface isn't there
+ -- (it's been replaced by the mother module) so we can't check it.
+ -- And that's fine, because if M's ModInfo is in the HPT, then
+ -- it's been compiled once, and we don't need to check the boot iface
+ then do { hpt <- getHpt
+ ; case lookupUFM hpt (moduleName mod) of
+ Just info | mi_boot (hm_iface info)
+ -> return (hm_details info)
+ _ -> return emptyModDetails }
+ else do
+
+ -- OK, so we're in one-shot mode.
+ -- In that case, we're read all the direct imports by now,
+ -- so eps_is_boot will record if any of our imports mention us by
+ -- way of hi-boot file
+ { eps <- getEps
+ ; case lookupUFM (eps_is_boot eps) (moduleName mod) of {
+ Nothing -> return emptyModDetails ; -- The typical case
+
+ Just (_, False) -> failWithTc moduleLoop ;
+ -- Someone below us imported us!
+ -- This is a loop with no hi-boot in the way
+
+ Just (_mod, True) -> -- There's a hi-boot interface below us
+
+ do { read_result <- findAndReadIface
+ need mod
+ True -- Hi-boot file
+
+ ; case read_result of
+ Failed err -> failWithTc (elaborate err)
+ Succeeded (iface, _path) -> typecheckIface iface
}}}}
where
need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod
- <+> ptext (sLit "to compare against the Real Thing")
+ <+> ptext (sLit "to compare against the Real Thing")
moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod)
- <+> ptext (sLit "depends on itself")
+ <+> ptext (sLit "depends on itself")
elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+>
- quotes (ppr mod) <> colon) 4 err
+ quotes (ppr mod) <> colon) 4 err
\end{code}
%************************************************************************
-%* *
- Type and class declarations
-%* *
+%* *
+ Type and class declarations
+%* *
%************************************************************************
When typechecking a data type decl, we *lazily* (via forkM) typecheck
@@ -376,13 +375,13 @@ the constructor argument types. This is in the hope that we may never
poke on those argument types, and hence may never need to load the
interface files for types mentioned in the arg types.
-E.g.
- data Foo.S = MkS Baz.T
+E.g.
+ data Foo.S = MkS Baz.T
Mabye we can get away without even loading the interface for Baz!
This is not just a performance thing. Suppose we have
- data Foo.S = MkS Baz.T
- data Baz.T = MkT Foo.S
+ data Foo.S = MkS Baz.T
+ data Baz.T = MkT Foo.S
(in different interface files, of course).
Now, first we load and typecheck Foo.S, and add it to the type envt.
If we do explore MkS's argument, we'll load and typecheck Baz.T.
@@ -398,14 +397,14 @@ extend the type envt with S, MkS, and all its implicit Ids. Suppose
(a bug, but it happened) that the list of implicit Ids depended in
turn on the constructor arg types. Then the following sequence of
events takes place:
- * we build a thunk <t> for the constructor arg tys
- * we build a thunk for the extended type environment (depends on <t>)
- * we write the extended type envt into the global EPS mutvar
-
+ * we build a thunk <t> for the constructor arg tys
+ * we build a thunk for the extended type environment (depends on <t>)
+ * we write the extended type envt into the global EPS mutvar
+
Now we look something up in the type envt
- * that pulls on <t>
- * which reads the global type envt out of the global EPS mutvar
- * but that depends in turn on <t>
+ * that pulls on <t>
+ * which reads the global type envt out of the global EPS mutvar
+ * but that depends in turn on <t>
It's subtle, because, it'd work fine if we typechecked the constructor args
eagerly -- they don't need the extended type envt. They just get the extended
@@ -416,49 +415,49 @@ the forkM stuff.
\begin{code}
-tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
- -> IfaceDecl
- -> IfL TyThing
+tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
+ -> IfaceDecl
+ -> IfL TyThing
tcIfaceDecl = tc_iface_decl NoParentTyCon
-tc_iface_decl :: TyConParent -- For nested declarations
- -> Bool -- True <=> discard IdInfo on IfaceId bindings
- -> IfaceDecl
- -> IfL TyThing
+tc_iface_decl :: TyConParent -- For nested declarations
+ -> Bool -- True <=> discard IdInfo on IfaceId bindings
+ -> IfaceDecl
+ -> IfL TyThing
tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
- ifIdDetails = details, ifIdInfo = info})
- = do { name <- lookupIfaceTop occ_name
- ; ty <- tcIfaceType iface_type
- ; details <- tcIdDetails ty details
- ; info <- tcIdInfo ignore_prags name ty info
- ; return (AnId (mkGlobalId details name ty info)) }
+ ifIdDetails = details, ifIdInfo = info})
+ = do { name <- lookupIfaceTop occ_name
+ ; ty <- tcIfaceType iface_type
+ ; details <- tcIdDetails ty details
+ ; info <- tcIdInfo ignore_prags name ty info
+ ; return (AnId (mkGlobalId details name ty info)) }
tc_iface_decl parent _ (IfaceData {ifName = occ_name,
- ifTyVars = tv_bndrs,
- ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
- ifCons = rdr_cons,
- ifRec = is_rec,
- ifFamInst = mb_family })
+ ifTyVars = tv_bndrs,
+ ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+ ifCons = rdr_cons,
+ ifRec = is_rec,
+ ifFamInst = mb_family })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; tycon <- fixM ( \ tycon -> do
- { stupid_theta <- tcIfaceCtxt ctxt
- ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
- ; mb_fam_inst <- tcFamInst mb_family
- ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
- gadt_syn parent mb_fam_inst
- })
+ { stupid_theta <- tcIfaceCtxt ctxt
+ ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+ ; mb_fam_inst <- tcFamInst mb_family
+ ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
+ gadt_syn parent mb_fam_inst
+ })
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifSynRhs = mb_rhs_ty,
- ifSynKind = kind, ifFamInst = mb_family})
+ ifSynRhs = mb_rhs_ty,
+ ifSynKind = kind, ifFamInst = mb_family})
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
- ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
+ ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
- tc_syn_rhs mb_rhs_ty
+ tc_syn_rhs mb_rhs_ty
; fam_info <- tcFamInst mb_family
; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info
; return (ATyCon tycon)
@@ -467,15 +466,15 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
tc_syn_rhs Nothing = return SynFamilyTyCon
tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty
- ; return (SynonymTyCon rhs_ty) }
+ ; return (SynonymTyCon rhs_ty) }
tc_iface_decl _parent ignore_prags
- (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
- ifTyVars = tv_bndrs, ifFDs = rdr_fds,
- ifATs = rdr_ats, ifSigs = rdr_sigs,
- ifRec = tc_isrec })
+ (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
+ ifTyVars = tv_bndrs, ifFDs = rdr_fds,
+ ifATs = rdr_ats, ifSigs = rdr_sigs,
+ ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
--- as we do abstract tycons
+-- as we do abstract tycons
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop tc_occ
; ctxt <- tcIfaceCtxt rdr_ctxt
@@ -488,11 +487,11 @@ tc_iface_decl _parent ignore_prags
where
tc_sig (IfaceClassOp occ dm rdr_ty)
= do { op_name <- lookupIfaceTop occ
- ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
- -- Must be done lazily for just the same reason as the
- -- type of a data con; to avoid sucking in types that
- -- it mentions unless it's necessray to do so
- ; return (op_name, dm, op_ty) }
+ ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
+ -- Must be done lazily for just the same reason as the
+ -- type of a data con; to avoid sucking in types that
+ -- it mentions unless it's necessray to do so
+ ; return (op_name, dm, op_ty) }
tc_at cls (IfaceAT tc_decl defs_decls)
= do tc <- tc_iface_tc_decl (AssocFamilyTyCon cls) tc_decl
@@ -509,64 +508,64 @@ tc_iface_decl _parent ignore_prags
mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
- ; tvs2' <- mapM tcIfaceTyVar tvs2
- ; return (tvs1', tvs2') }
+ ; tvs2' <- mapM tcIfaceTyVar tvs2
+ ; return (tvs1', tvs2') }
tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
- = do { name <- lookupIfaceTop rdr_name
- ; return (ATyCon (mkForeignTyCon name ext_name
- liftedTypeKind 0)) }
+ = do { name <- lookupIfaceTop rdr_name
+ ; return (ATyCon (mkForeignTyCon name ext_name
+ liftedTypeKind 0)) }
tcFamInst :: Maybe (IfaceTyCon, [IfaceType]) -> IfL (Maybe (TyCon, [Type]))
tcFamInst Nothing = return Nothing
tcFamInst (Just (fam, tys)) = do { famTyCon <- tcIfaceTyCon fam
- ; insttys <- mapM tcIfaceType tys
- ; return $ Just (famTyCon, insttys) }
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys) }
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon _ if_cons
= case if_cons of
- IfAbstractTyCon dis -> return (AbstractTyCon dis)
- IfOpenDataTyCon -> return DataFamilyTyCon
- IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
- ; return (mkDataTyConRhs data_cons) }
- IfNewTyCon con -> do { data_con <- tc_con_decl con
- ; mkNewTyConRhs tycon_name tycon data_con }
+ IfAbstractTyCon dis -> return (AbstractTyCon dis)
+ IfOpenDataTyCon -> return DataFamilyTyCon
+ IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
+ ; return (mkDataTyConRhs data_cons) }
+ IfNewTyCon con -> do { data_con <- tc_con_decl con
+ ; mkNewTyConRhs tycon_name tycon data_con }
where
tc_con_decl (IfCon { ifConInfix = is_infix,
- ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
- ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
- ifConArgTys = args, ifConFields = field_lbls,
- ifConStricts = stricts})
+ ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+ ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
+ ifConArgTys = args, ifConFields = field_lbls,
+ ifConStricts = stricts})
= bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
- bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
- { name <- lookupIfaceTop occ
+ bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
+ { name <- lookupIfaceTop occ
; eq_spec <- tcIfaceEqSpec spec
- ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
- -- At one stage I thought that this context checking *had*
- -- to be lazy, because of possible mutual recursion between the
- -- type and the classe:
- -- E.g.
- -- class Real a where { toRat :: a -> Ratio Integer }
- -- data (Real a) => Ratio a = ...
- -- But now I think that the laziness in checking class ops breaks
- -- the loop, so no laziness needed
-
- -- Read the argument types, but lazily to avoid faulting in
- -- the component types unless they are really needed
- ; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args)
- ; lbl_names <- mapM lookupIfaceTop field_lbls
-
- -- Remember, tycon is the representation tycon
- ; let orig_res_ty = mkFamilyTyConApp tycon
- (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
-
- ; buildDataCon name is_infix {- Not infix -}
- stricts lbl_names
- univ_tyvars ex_tyvars
+ ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
+ -- At one stage I thought that this context checking *had*
+ -- to be lazy, because of possible mutual recursion between the
+ -- type and the classe:
+ -- E.g.
+ -- class Real a where { toRat :: a -> Ratio Integer }
+ -- data (Real a) => Ratio a = ...
+ -- But now I think that the laziness in checking class ops breaks
+ -- the loop, so no laziness needed
+
+ -- Read the argument types, but lazily to avoid faulting in
+ -- the component types unless they are really needed
+ ; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args)
+ ; lbl_names <- mapM lookupIfaceTop field_lbls
+
+ -- Remember, tycon is the representation tycon
+ ; let orig_res_ty = mkFamilyTyConApp tycon
+ (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
+
+ ; buildDataCon name is_infix {- Not infix -}
+ stricts lbl_names
+ univ_tyvars ex_tyvars
eq_spec theta
- arg_tys orig_res_ty tycon
- }
+ arg_tys orig_res_ty tycon
+ }
mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
@@ -597,9 +596,9 @@ Solution: record S's kind in the interface file; now we can safely
look at it.
%************************************************************************
-%* *
- Instances
-%* *
+%* *
+ Instances
+%* *
%************************************************************************
\begin{code}
@@ -613,8 +612,8 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
- ifFamInstFam = fam, ifFamInstTys = mb_tcs })
--- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $
+ ifFamInstFam = fam, ifFamInstTys = mb_tcs })
+-- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $
-- the above line doesn't work, but this below does => CPP in Haskell = evil!
= do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
tcIfaceTyCon tycon
@@ -624,9 +623,9 @@ tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
%************************************************************************
-%* *
- Rules
-%* *
+%* *
+ Rules
+%* *
%************************************************************************
We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
@@ -634,41 +633,41 @@ are in the type environment. However, remember that typechecking a Rule may
(as a side effect) augment the type envt, and so we may need to iterate the process.
\begin{code}
-tcIfaceRules :: Bool -- True <=> ignore rules
- -> [IfaceRule]
- -> IfL [CoreRule]
+tcIfaceRules :: Bool -- True <=> ignore rules
+ -> [IfaceRule]
+ -> IfL [CoreRule]
tcIfaceRules ignore_prags if_rules
| ignore_prags = return []
| otherwise = mapM tcIfaceRule if_rules
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
- ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
ifRuleAuto = auto })
- = do { ~(bndrs', args', rhs') <-
- -- Typecheck the payload lazily, in the hope it'll never be looked at
- forkM (ptext (sLit "Rule") <+> ftext name) $
- bindIfaceBndrs bndrs $ \ bndrs' ->
- do { args' <- mapM tcIfaceExpr args
- ; rhs' <- tcIfaceExpr rhs
- ; return (bndrs', args', rhs') }
- ; let mb_tcs = map ifTopFreeName args
- ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
- ru_bndrs = bndrs', ru_args = args',
- ru_rhs = occurAnalyseExpr rhs',
- ru_rough = mb_tcs,
+ = do { ~(bndrs', args', rhs') <-
+ -- Typecheck the payload lazily, in the hope it'll never be looked at
+ forkM (ptext (sLit "Rule") <+> ftext name) $
+ bindIfaceBndrs bndrs $ \ bndrs' ->
+ do { args' <- mapM tcIfaceExpr args
+ ; rhs' <- tcIfaceExpr rhs
+ ; return (bndrs', args', rhs') }
+ ; let mb_tcs = map ifTopFreeName args
+ ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
+ ru_bndrs = bndrs', ru_args = args',
+ ru_rhs = occurAnalyseExpr rhs',
+ ru_rough = mb_tcs,
ru_auto = auto,
- ru_local = False }) } -- An imported RULE is never for a local Id
- -- or, even if it is (module loop, perhaps)
- -- we'll just leave it in the non-local set
+ ru_local = False }) } -- An imported RULE is never for a local Id
+ -- or, even if it is (module loop, perhaps)
+ -- we'll just leave it in the non-local set
where
- -- This function *must* mirror exactly what Rules.topFreeName does
- -- We could have stored the ru_rough field in the iface file
- -- but that would be redundant, I think.
- -- The only wrinkle is that we must not be deceived by
- -- type syononyms at the top of a type arg. Since
- -- we can't tell at this point, we are careful not
- -- to write them out in coreRuleToIfaceRule
+ -- This function *must* mirror exactly what Rules.topFreeName does
+ -- We could have stored the ru_rough field in the iface file
+ -- but that would be redundant, I think.
+ -- The only wrinkle is that we must not be deceived by
+ -- type syononyms at the top of a type arg. Since
+ -- we can't tell at this point, we are careful not
+ -- to write them out in coreRuleToIfaceRule
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
@@ -678,9 +677,9 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
%************************************************************************
-%* *
- Annotations
-%* *
+%* *
+ Annotations
+%* *
%************************************************************************
\begin{code}
@@ -724,13 +723,11 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
; vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
; tyConRes2 <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
- ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
+ ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
; return $ VectInfo
{ vectInfoVar = mkVarEnv vVars
, vectInfoTyCon = mkNameEnv vTyCons
, vectInfoDataCon = mkNameEnv (concat vDataCons)
- , vectInfoPADFun = mkNameEnv (catMaybes vPAs)
- , vectInfoIso = mkNameEnv (catMaybes vIsos)
, vectInfoScalarVars = mkVarSet (map lookupVar scalarVars)
, vectInfoScalarTyCons = scalarTyConsSet
}
@@ -738,52 +735,41 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
where
vectVarMapping name
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name)
- ; var <- forkM (text ("vect var") <+> ppr name) $
+ ; var <- forkM (ptext (sLit "vect var") <+> ppr name) $
tcIfaceExtId name
- ; vVar <- forkM (text ("vect vVar") <+> ppr vName) $
+ ; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+>
+ ppr mod <> ptext (sLit "; nameModule =") <+>
+ ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
tcIfaceExtId vName
; return (var, (var, vVar))
}
vectTyConMapping name
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
- ; paName <- lookupOrig mod (mkLocalisedOccName mod mkPADFunOcc name)
- ; isoName <- lookupOrig mod (mkLocalisedOccName mod mkVectIsoOcc name)
-- FIXME: we will need to use tcIfaceTyCon/tcIfaceExtId on some of these (but depends
-- on how we exactly define the 'VECTORISE type' pragma to work)
; let { tycon = lookupTyCon name
; vTycon = lookupTyCon vName
- ; paTycon = lookupVar paName
- ; isoTycon = lookupVar isoName
}
; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon)
; return ( (name, (tycon, vTycon)) -- (T, T_v)
, vDataCons -- list of (Ci, Ci_v)
- , Just (vName, (vTycon, paTycon)) -- (T_v, paT)
- , Just (name, (tycon, isoTycon)) -- (T, isoT)
)
}
vectTyConReuseMapping scalarNames name
- = do { paName <- lookupOrig mod (mkLocalisedOccName mod mkPADFunOcc name)
- ; isoName <- lookupOrig mod (mkLocalisedOccName mod mkVectIsoOcc name)
- ; tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
+ = do { tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
; if name `elemNameSet` scalarNames
then do
- { return ( (name, (tycon, tycon)) -- scalar type constructors expose no data...
- , [] -- ...constructors and have no PA and ISO vars...
- , Nothing -- ...see "Note [Pragmas to vectorise tycons]" in..
- , Nothing -- ...'Vectorise.Type.Env'
- )
+ { return ( (name, (tycon, tycon)) -- scalar type constructors expose no data..
+ , [] -- ..constructors see..
+ ) -- .."Note [Pragmas to vectorise tycons]"..
+ -- ..in 'Vectorise.Type.Env'
} else do
- { let { paTycon = lookupVar paName
- ; isoTycon = lookupVar isoName
- ; vDataCons = [ (dataConName dc, (dc, dc))
+ { let { vDataCons = [ (dataConName dc, (dc, dc))
| dc <- tyConDataCons tycon]
}
; return ( (name, (tycon, tycon)) -- (T, T)
, vDataCons -- list of (Ci, Ci)
- , Just (name, (tycon, paTycon)) -- (T, paT)
- , Just (name, (tycon, isoTycon)) -- (T, isoT)
)
}}
vectDataConMapping datacon
@@ -837,9 +823,9 @@ tcIfaceCtxt sts = mapM tcIfaceType sts
\end{code}
%************************************************************************
-%* *
- Coercions
-%* *
+%* *
+ Coercions
+%* *
%************************************************************************
\begin{code}
@@ -869,9 +855,9 @@ tcIfaceCoVar = tcIfaceLclId
%************************************************************************
-%* *
- Core
-%* *
+%* *
+ Core
+%* *
%************************************************************************
\begin{code}
@@ -924,25 +910,25 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
scrut' <- tcIfaceExpr scrut
case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
let
- scrut_ty = exprType scrut'
- case_bndr' = mkLocalId case_bndr_name scrut_ty
- tc_app = splitTyConApp scrut_ty
- -- NB: Won't always succeed (polymoprhic case)
- -- but won't be demanded in those cases
- -- NB: not tcSplitTyConApp; we are looking at Core here
- -- look through non-rec newtypes to find the tycon that
- -- corresponds to the datacon in this case alternative
+ scrut_ty = exprType scrut'
+ case_bndr' = mkLocalId case_bndr_name scrut_ty
+ tc_app = splitTyConApp scrut_ty
+ -- NB: Won't always succeed (polymoprhic case)
+ -- but won't be demanded in those cases
+ -- NB: not tcSplitTyConApp; we are looking at Core here
+ -- look through non-rec newtypes to find the tycon that
+ -- corresponds to the datacon in this case alternative
extendIfaceIdEnv [case_bndr'] $ do
alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
return (Case scrut' case_bndr' (coreAltsType alts') alts')
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
- = do { name <- newIfaceName (mkVarOccFS fs)
- ; ty' <- tcIfaceType ty
+ = do { name <- newIfaceName (mkVarOccFS fs)
+ ; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
name ty' info
- ; let id = mkLocalIdWithInfo name ty' id_info
+ ; let id = mkLocalIdWithInfo name ty' id_info
; rhs' <- tcIfaceExpr rhs
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
; return (Let (NonRec id rhs') body') }
@@ -999,54 +985,54 @@ tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
- = do { con <- tcIfaceDataCon data_occ
- ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
- (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
- ; tcIfaceDataAlt con inst_tys arg_strs rhs }
+ = do { con <- tcIfaceDataCon data_occ
+ ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
+ (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
+ ; tcIfaceDataAlt con inst_tys arg_strs rhs }
tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
-> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceDataAlt con inst_tys arg_strs rhs
- = do { us <- newUniqueSupply
- ; let uniqs = uniqsFromSupply us
- ; let (ex_tvs, arg_ids)
- = dataConRepFSInstPat arg_strs uniqs con inst_tys
-
- ; rhs' <- extendIfaceTyVarEnv ex_tvs $
- extendIfaceIdEnv arg_ids $
- tcIfaceExpr rhs
- ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
+ = do { us <- newUniqueSupply
+ ; let uniqs = uniqsFromSupply us
+ ; let (ex_tvs, arg_ids)
+ = dataConRepFSInstPat arg_strs uniqs con inst_tys
+
+ ; rhs' <- extendIfaceTyVarEnv ex_tvs $
+ extendIfaceIdEnv arg_ids $
+ tcIfaceExpr rhs
+ ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
\end{code}
\begin{code}
-tcExtCoreBindings :: [IfaceBinding] -> IfL CoreProgram -- Used for external core
+tcExtCoreBindings :: [IfaceBinding] -> IfL CoreProgram -- Used for external core
tcExtCoreBindings [] = return []
tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
do_one (IfaceNonRec bndr rhs) thing_inside
- = do { rhs' <- tcIfaceExpr rhs
- ; bndr' <- newExtCoreBndr bndr
- ; extendIfaceIdEnv [bndr'] $ do
- { core_binds <- thing_inside
- ; return (NonRec bndr' rhs' : core_binds) }}
+ = do { rhs' <- tcIfaceExpr rhs
+ ; bndr' <- newExtCoreBndr bndr
+ ; extendIfaceIdEnv [bndr'] $ do
+ { core_binds <- thing_inside
+ ; return (NonRec bndr' rhs' : core_binds) }}
do_one (IfaceRec pairs) thing_inside
- = do { bndrs' <- mapM newExtCoreBndr bndrs
- ; extendIfaceIdEnv bndrs' $ do
- { rhss' <- mapM tcIfaceExpr rhss
- ; core_binds <- thing_inside
- ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
+ = do { bndrs' <- mapM newExtCoreBndr bndrs
+ ; extendIfaceIdEnv bndrs' $ do
+ { rhss' <- mapM tcIfaceExpr rhss
+ ; core_binds <- thing_inside
+ ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
where
(bndrs,rhss) = unzip pairs
\end{code}
%************************************************************************
-%* *
- IdInfo
-%* *
+%* *
+ IdInfo
+%* *
%************************************************************************
\begin{code}
@@ -1065,8 +1051,8 @@ tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo ignore_prags name ty info
| ignore_prags = return vanillaIdInfo
| otherwise = case info of
- NoInfo -> return vanillaIdInfo
- HasInfo info -> foldlM tcPrag init_info info
+ NoInfo -> return vanillaIdInfo
+ HasInfo info -> foldlM tcPrag init_info info
where
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
@@ -1078,48 +1064,48 @@ tcIdInfo ignore_prags name ty info
tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
- -- The next two are lazy, so they don't transitively suck stuff in
+ -- The next two are lazy, so they don't transitively suck stuff in
tcPrag info (HsUnfold lb if_unf)
= do { unf <- tcUnfolding name ty info if_unf
- ; let info1 | lb = info `setOccInfo` strongLoopBreaker
- | otherwise = info
- ; return (info1 `setUnfoldingInfoLazily` unf) }
+ ; let info1 | lb = info `setOccInfo` strongLoopBreaker
+ | otherwise = info
+ ; return (info1 `setUnfoldingInfoLazily` unf) }
\end{code}
\begin{code}
tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding name _ info (IfCoreUnfold stable if_expr)
- = do { mb_expr <- tcPragExpr name if_expr
+ = do { mb_expr <- tcPragExpr name if_expr
; let unf_src = if stable then InlineStable else InlineRhs
- ; return (case mb_expr of
- Nothing -> NoUnfolding
- Just expr -> mkUnfolding unf_src
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkUnfolding unf_src
True {- Top level -}
is_bottoming expr) }
where
-- Strictness should occur before unfolding!
is_bottoming = case strictnessInfo info of
- Just sig -> isBottomingSig sig
- Nothing -> False
+ Just sig -> isBottomingSig sig
+ Nothing -> False
tcUnfolding name _ _ (IfCompulsory if_expr)
- = do { mb_expr <- tcPragExpr name if_expr
- ; return (case mb_expr of
- Nothing -> NoUnfolding
- Just expr -> mkCompulsoryUnfolding expr) }
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkCompulsoryUnfolding expr) }
tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
- = do { mb_expr <- tcPragExpr name if_expr
- ; return (case mb_expr of
- Nothing -> NoUnfolding
- Just expr -> mkCoreUnfolding InlineStable True expr arity
+ = do { mb_expr <- tcPragExpr name if_expr
+ ; return (case mb_expr of
+ Nothing -> NoUnfolding
+ Just expr -> mkCoreUnfolding InlineStable True expr arity
(UnfWhen unsat_ok boring_ok))
}
tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
= do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
- Nothing -> noUnfolding
+ Nothing -> noUnfolding
Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
@@ -1132,24 +1118,24 @@ tcUnfolding name ty info (IfLclWrapper arity wkr)
-------------
tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding
tcIfaceWrapper name ty info arity get_worker
- = do { mb_wkr_id <- forkM_maybe doc get_worker
- ; us <- newUniqueSupply
- ; return (case mb_wkr_id of
- Nothing -> noUnfolding
- Just wkr_id -> make_inline_rule wkr_id us) }
+ = do { mb_wkr_id <- forkM_maybe doc get_worker
+ ; us <- newUniqueSupply
+ ; return (case mb_wkr_id of
+ Nothing -> noUnfolding
+ Just wkr_id -> make_inline_rule wkr_id us) }
where
doc = text "Worker for" <+> ppr name
make_inline_rule wkr_id us
- = mkWwInlineRule wkr_id
- (initUs_ us (mkWrapper ty strict_sig) wkr_id)
- arity
+ = mkWwInlineRule wkr_id
+ (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+ arity
- -- Again we rely here on strictness info always appearing
- -- before unfolding
+ -- Again we rely here on strictness info always appearing
+ -- before unfolding
strict_sig = case strictnessInfo info of
- Just sig -> sig
- Nothing -> pprPanic "Worker info but no strictness for" (ppr name)
+ Just sig -> sig
+ Nothing -> pprPanic "Worker info but no strictness for" (ppr name)
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
@@ -1177,8 +1163,8 @@ tcPragExpr name expr
doc = text "Unfolding of" <+> ppr name
get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
- get_in_scope
- = do { (gbl_env, lcl_env) <- getEnvs
+ get_in_scope
+ = do { (gbl_env, lcl_env) <- getEnvs
; rec_ids <- case if_rec_types gbl_env of
Nothing -> return []
Just (_, get_env) -> do
@@ -1192,41 +1178,41 @@ tcPragExpr name expr
%************************************************************************
-%* *
- Getting from Names to TyThings
-%* *
+%* *
+ Getting from Names to TyThings
+%* *
%************************************************************************
\begin{code}
tcIfaceGlobal :: Name -> IfL TyThing
tcIfaceGlobal name
| Just thing <- wiredInNameTyThing_maybe name
- -- Wired-in things include TyCons, DataCons, and Ids
+ -- Wired-in things include TyCons, DataCons, and Ids
= do { ifCheckWiredInThing thing; return thing }
| otherwise
- = do { env <- getGblEnv
- ; case if_rec_types env of { -- Note [Tying the knot]
- Just (mod, get_type_env)
- | nameIsLocalOrFrom mod name
- -> do -- It's defined in the module being compiled
- { type_env <- setLclEnv () get_type_env -- yuk
- ; case lookupNameEnv type_env name of
- Just thing -> return thing
- Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
- (ppr name $$ ppr type_env) }
-
- ; _ -> do
-
- { hsc_env <- getTopEnv
+ = do { env <- getGblEnv
+ ; case if_rec_types env of { -- Note [Tying the knot]
+ Just (mod, get_type_env)
+ | nameIsLocalOrFrom mod name
+ -> do -- It's defined in the module being compiled
+ { type_env <- setLclEnv () get_type_env -- yuk
+ ; case lookupNameEnv type_env name of
+ Just thing -> return thing
+ Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
+ (ppr name $$ ppr type_env) }
+
+ ; _ -> do
+
+ { hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
- ; case mb_thing of {
- Just thing -> return thing ;
- Nothing -> do
-
- { mb_thing <- importDecl name -- It's imported; go get it
- ; case mb_thing of
- Failed err -> failIfM err
- Succeeded thing -> return thing
+ ; case mb_thing of {
+ Just thing -> return thing ;
+ Nothing -> do
+
+ { mb_thing <- importDecl name -- It's imported; go get it
+ ; case mb_thing of
+ Failed err -> failIfM err
+ Succeeded thing -> return thing
}}}}}
-- Note [Tying the knot]
@@ -1249,7 +1235,7 @@ tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind
; tcWiredInTyCon (anyTyConOfKind tc_kind) }
tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
- ; return (check_tc (tyThingTyCon thing)) }
+ ; return (check_tc (tyThingTyCon thing)) }
where
check_tc tc
| debugIsOn = case toIfaceTyCon tc of
@@ -1262,75 +1248,75 @@ tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
-- Imagine: f :: Double -> Double
tcWiredInTyCon :: TyCon -> IfL TyCon
tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc)
- ; return tc }
+ ; return tc }
tcIfaceCoAxiom :: Name -> IfL CoAxiom
tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
- ; return (tyThingCoAxiom thing) }
+ ; return (tyThingCoAxiom thing) }
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
- ; case thing of
- ADataCon dc -> return dc
- _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
+ ; case thing of
+ ADataCon dc -> return dc
+ _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
- ; case thing of
- AnId id -> return id
- _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
+ ; case thing of
+ AnId id -> return id
+ _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
\end{code}
%************************************************************************
-%* *
- Bindings
-%* *
+%* *
+ Bindings
+%* *
%************************************************************************
\begin{code}
bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside
- = do { name <- newIfaceName (mkVarOccFS fs)
- ; ty' <- tcIfaceType ty
- ; let id = mkLocalId name ty'
- ; extendIfaceIdEnv [id] (thing_inside id) }
+ = do { name <- newIfaceName (mkVarOccFS fs)
+ ; ty' <- tcIfaceType ty
+ ; let id = mkLocalId name ty'
+ ; extendIfaceIdEnv [id] (thing_inside id) }
bindIfaceBndr (IfaceTvBndr bndr) thing_inside
= bindIfaceTyVar bndr thing_inside
bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs [] thing_inside = thing_inside []
bindIfaceBndrs (b:bs) thing_inside
- = bindIfaceBndr b $ \ b' ->
- bindIfaceBndrs bs $ \ bs' ->
+ = bindIfaceBndr b $ \ b' ->
+ bindIfaceBndrs bs $ \ bs' ->
thing_inside (b':bs')
-----------------------
newExtCoreBndr :: IfaceLetBndr -> IfL Id
newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now
- = do { mod <- getIfModule
- ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan
- ; ty' <- tcIfaceType ty
- ; return (mkLocalId name ty') }
+ = do { mod <- getIfModule
+ ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan
+ ; ty' <- tcIfaceType ty
+ ; return (mkLocalId name ty') }
-----------------------
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
- = do { name <- newIfaceName (mkTyVarOccFS occ)
- ; tyvar <- mk_iface_tyvar name kind
- ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
+ = do { name <- newIfaceName (mkTyVarOccFS occ)
+ ; tyvar <- mk_iface_tyvar name kind
+ ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars bndrs thing_inside
- = do { names <- newIfaceNames (map mkTyVarOccFS occs)
- ; tyvars <- zipWithM mk_iface_tyvar names kinds
- ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
+ = do { names <- newIfaceNames (map mkTyVarOccFS occs)
+ ; tyvars <- zipWithM mk_iface_tyvar names kinds
+ ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
where
(occs,kinds) = unzip bndrs
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
mk_iface_tyvar name ifKind
= do { kind <- tcIfaceType ifKind
- ; return (Var.mkTyVar name kind) }
+ ; return (Var.mkTyVar name kind) }
bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
-- Used for type variable in nested associated data/type declarations
@@ -1343,8 +1329,8 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
= bindIfaceTyVars_AT bs $ \ bs' ->
do { mb_tv <- lookupIfaceTyVar tv_occ
; case mb_tv of
- Just b' -> thing_inside (b':bs')
- Nothing -> bindIfaceTyVar b $ \ b' ->
- thing_inside (b':bs') }
+ Just b' -> thing_inside (b':bs')
+ Nothing -> bindIfaceTyVar b $ \ b' ->
+ thing_inside (b':bs') }
\end{code}
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index c14544cbd9..3e2551ef37 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -6,35 +6,35 @@
\begin{code}
-- | Types for the per-module compiler
module HscTypes (
- -- * compilation state
+ -- * compilation state
HscEnv(..), hscEPS,
- FinderCache, FindResult(..), ModLocationCache,
- Target(..), TargetId(..), pprTarget, pprTargetId,
- ModuleGraph, emptyMG,
+ FinderCache, FindResult(..), ModLocationCache,
+ Target(..), TargetId(..), pprTarget, pprTargetId,
+ ModuleGraph, emptyMG,
-- * Information about modules
- ModDetails(..), emptyModDetails,
+ ModDetails(..), emptyModDetails,
ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods, ImportedModsVal,
- ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary,
- msHsFilePath, msHiFilePath, msObjFilePath,
+ ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary,
+ msHsFilePath, msHiFilePath, msObjFilePath,
SourceModified(..),
-- * Information about the module being compiled
- HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases
-
- -- * State relating to modules in this package
- HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
+ HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases
+
+ -- * State relating to modules in this package
+ HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
hptInstances, hptRules, hptVectInfo,
hptObjs,
- -- * State relating to known packages
- ExternalPackageState(..), EpsStats(..), addEpsInStats,
- PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
- lookupIfaceByModule, emptyModIface,
-
- PackageInstEnv, PackageRuleBase,
+ -- * State relating to known packages
+ ExternalPackageState(..), EpsStats(..), addEpsInStats,
+ PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
+ lookupIfaceByModule, emptyModIface,
+
+ PackageInstEnv, PackageRuleBase,
-- * Annotations
@@ -47,42 +47,42 @@ module HscTypes (
InteractiveImport(..),
mkPrintUnqualified, pprModulePrefix,
- -- * Interfaces
- ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
- emptyIfaceWarnCache,
+ -- * Interfaces
+ ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
+ emptyIfaceWarnCache,
-- * Fixity
- FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
+ FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
-- * TyThings and type environments
TyThing(..), tyThingAvailInfo,
- tyThingTyCon, tyThingDataCon,
+ tyThingTyCon, tyThingDataCon,
tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyVars,
implicitTyThings, implicitTyConThings, implicitClassThings,
isImplicitTyThing,
-
- TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
+
+ TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
typeEnvFromEntities, mkTypeEnvWithImplicits,
- extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
- typeEnvElts, typeEnvTyCons, typeEnvIds,
+ extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
+ typeEnvElts, typeEnvTyCons, typeEnvIds,
typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
-- * MonadThings
MonadThings(..),
-- * Information on imports and exports
- WhetherHasOrphans, IsBootInterface, Usage(..),
- Dependencies(..), noDependencies,
- NameCache(..), OrigNameCache, OrigIParamCache,
+ WhetherHasOrphans, IsBootInterface, Usage(..),
+ Dependencies(..), noDependencies,
+ NameCache(..), OrigNameCache, OrigIParamCache,
IfaceExport,
- -- * Warnings
- Warnings(..), WarningTxt(..), plusWarns,
+ -- * Warnings
+ Warnings(..), WarningTxt(..), plusWarns,
- -- * Linker stuff
+ -- * Linker stuff
Linkable(..), isObjectLinkable, linkableObjs,
- Unlinked(..), CompiledByteCode,
- isObject, nameOfObject, isInterpretable, byteCodeOfObject,
+ Unlinked(..), CompiledByteCode,
+ isObject, nameOfObject, isInterpretable, byteCodeOfObject,
-- * Program coverage
HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,
@@ -126,21 +126,21 @@ import VarEnv
import VarSet
import Var
import Id
-import IdInfo ( IdDetails(..) )
+import IdInfo ( IdDetails(..) )
import Type
import Annotations
import Class
import TyCon
import DataCon
-import PrelNames ( gHC_PRIM )
+import PrelNames ( gHC_PRIM )
import Packages hiding ( Version(..) )
import DynFlags
import DriverPhases
import BasicTypes
-import OptimizationFuel ( OptFuelState )
+import OptimizationFuel ( OptFuelState )
import IfaceSyn
-import CoreSyn ( CoreRule, CoreVect )
+import CoreSyn ( CoreRule, CoreVect )
import Maybes
import Outputable
import BreakArray
@@ -149,7 +149,7 @@ import Unique
import UniqFM
import UniqSupply
import FastString
-import StringBuffer ( StringBuffer )
+import StringBuffer ( StringBuffer )
import Fingerprint
import MonadUtils
import Bag
@@ -157,7 +157,7 @@ import ErrUtils
import Util
import System.FilePath
-import System.Time ( ClockTime )
+import System.Time ( ClockTime )
import Data.IORef
import Data.Array ( Array, array )
import Data.Map ( Map )
@@ -262,53 +262,53 @@ handleFlagWarnings dflags warns
-- a single module.
data HscEnv
= HscEnv {
- hsc_dflags :: DynFlags,
- -- ^ The dynamic flag settings
-
- hsc_targets :: [Target],
- -- ^ The targets (or roots) of the current session
-
- hsc_mod_graph :: ModuleGraph,
- -- ^ The module graph of the current session
-
- hsc_IC :: InteractiveContext,
- -- ^ The context for evaluating interactive statements
-
- hsc_HPT :: HomePackageTable,
- -- ^ The home package table describes already-compiled
- -- home-package modules, /excluding/ the module we
- -- are compiling right now.
- -- (In one-shot mode the current module is the only
- -- home-package module, so hsc_HPT is empty. All other
- -- modules count as \"external-package\" modules.
- -- However, even in GHCi mode, hi-boot interfaces are
- -- demand-loaded into the external-package table.)
- --
- -- 'hsc_HPT' is not mutable because we only demand-load
- -- external packages; the home package is eagerly
- -- loaded, module by module, by the compilation manager.
- --
- -- The HPT may contain modules compiled earlier by @--make@
- -- but not actually below the current module in the dependency
- -- graph.
-
- -- (This changes a previous invariant: changed Jan 05.)
-
- hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),
- -- ^ Information about the currently loaded external packages.
- -- This is mutable because packages will be demand-loaded during
- -- a compilation run as required.
-
- hsc_NC :: {-# UNPACK #-} !(IORef NameCache),
- -- ^ As with 'hsc_EPS', this is side-effected by compiling to
- -- reflect sucking in interface files. They cache the state of
- -- external interface files, in effect.
-
- hsc_FC :: {-# UNPACK #-} !(IORef FinderCache),
- -- ^ The cached result of performing finding in the file system
- hsc_MLC :: {-# UNPACK #-} !(IORef ModLocationCache),
- -- ^ This caches the location of modules, so we don't have to
- -- search the filesystem multiple times. See also 'hsc_FC'.
+ hsc_dflags :: DynFlags,
+ -- ^ The dynamic flag settings
+
+ hsc_targets :: [Target],
+ -- ^ The targets (or roots) of the current session
+
+ hsc_mod_graph :: ModuleGraph,
+ -- ^ The module graph of the current session
+
+ hsc_IC :: InteractiveContext,
+ -- ^ The context for evaluating interactive statements
+
+ hsc_HPT :: HomePackageTable,
+ -- ^ The home package table describes already-compiled
+ -- home-package modules, /excluding/ the module we
+ -- are compiling right now.
+ -- (In one-shot mode the current module is the only
+ -- home-package module, so hsc_HPT is empty. All other
+ -- modules count as \"external-package\" modules.
+ -- However, even in GHCi mode, hi-boot interfaces are
+ -- demand-loaded into the external-package table.)
+ --
+ -- 'hsc_HPT' is not mutable because we only demand-load
+ -- external packages; the home package is eagerly
+ -- loaded, module by module, by the compilation manager.
+ --
+ -- The HPT may contain modules compiled earlier by @--make@
+ -- but not actually below the current module in the dependency
+ -- graph.
+
+ -- (This changes a previous invariant: changed Jan 05.)
+
+ hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),
+ -- ^ Information about the currently loaded external packages.
+ -- This is mutable because packages will be demand-loaded during
+ -- a compilation run as required.
+
+ hsc_NC :: {-# UNPACK #-} !(IORef NameCache),
+ -- ^ As with 'hsc_EPS', this is side-effected by compiling to
+ -- reflect sucking in interface files. They cache the state of
+ -- external interface files, in effect.
+
+ hsc_FC :: {-# UNPACK #-} !(IORef FinderCache),
+ -- ^ The cached result of performing finding in the file system
+ hsc_MLC :: {-# UNPACK #-} !(IORef ModLocationCache),
+ -- ^ This caches the location of modules, so we don't have to
+ -- search the filesystem multiple times. See also 'hsc_FC'.
hsc_OptFuel :: OptFuelState,
-- ^ Settings to control the use of \"optimization fuel\":
@@ -339,12 +339,12 @@ data Target = Target
data TargetId
= TargetModule ModuleName
- -- ^ A module name: search for the file
+ -- ^ A module name: search for the file
| TargetFile FilePath (Maybe Phase)
- -- ^ A filename: preprocess & parse it to find the module name.
- -- If specified, the Phase indicates how to compile this file
- -- (which phase to start from). Nothing indicates the starting phase
- -- should be determined from the suffix of the filename.
+ -- ^ A filename: preprocess & parse it to find the module name.
+ -- If specified, the Phase indicates how to compile this file
+ -- (which phase to start from). Nothing indicates the starting phase
+ -- should be determined from the suffix of the filename.
deriving Eq
pprTarget :: Target -> SDoc
@@ -363,12 +363,12 @@ instance Outputable TargetId where
-- | Helps us find information about modules in the home package
type HomePackageTable = ModuleNameEnv HomeModInfo
- -- Domain = modules in the home package that have been fully compiled
- -- "home" package name cached here for convenience
+ -- Domain = modules in the home package that have been fully compiled
+ -- "home" package name cached here for convenience
-- | Helps us find information about modules in the imported packages
type PackageIfaceTable = ModuleEnv ModIface
- -- Domain = modules in the imported packages
+ -- Domain = modules in the imported packages
emptyHomePackageTable :: HomePackageTable
emptyHomePackageTable = emptyUFM
@@ -384,43 +384,43 @@ data HomeModInfo
-- these, even if it is imported from another package
hm_details :: !ModDetails,
-- ^ Extra information that has been created from the 'ModIface' for
- -- the module, typically during typechecking
+ -- the module, typically during typechecking
hm_linkable :: !(Maybe Linkable)
-- ^ The actual artifact we would like to link to access things in
- -- this module.
- --
- -- 'hm_linkable' might be Nothing:
- --
- -- 1. If this is an .hs-boot module
- --
- -- 2. Temporarily during compilation if we pruned away
- -- the old linkable because it was out of date.
- --
- -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields
- -- in the 'HomePackageTable' will be @Just@.
- --
- -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the
- -- 'HomeModInfo' by building a new 'ModDetails' from the old
- -- 'ModIface' (only).
+ -- this module.
+ --
+ -- 'hm_linkable' might be Nothing:
+ --
+ -- 1. If this is an .hs-boot module
+ --
+ -- 2. Temporarily during compilation if we pruned away
+ -- the old linkable because it was out of date.
+ --
+ -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields
+ -- in the 'HomePackageTable' will be @Just@.
+ --
+ -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the
+ -- 'HomeModInfo' by building a new 'ModDetails' from the old
+ -- 'ModIface' (only).
}
-- | Find the 'ModIface' for a 'Module', searching in both the loaded home
-- and external package module information
lookupIfaceByModule
- :: DynFlags
- -> HomePackageTable
- -> PackageIfaceTable
- -> Module
- -> Maybe ModIface
+ :: DynFlags
+ -> HomePackageTable
+ -> PackageIfaceTable
+ -> Module
+ -> Maybe ModIface
lookupIfaceByModule dflags hpt pit mod
| modulePackageId mod == thisPackage dflags
- = -- The module comes from the home package, so look first
- -- in the HPT. If it's not from the home package it's wrong to look
- -- in the HPT, because the HPT is indexed by *ModuleName* not Module
+ = -- The module comes from the home package, so look first
+ -- in the HPT. If it's not from the home package it's wrong to look
+ -- in the HPT, because the HPT is indexed by *ModuleName* not Module
fmap hm_iface (lookupUFM hpt (moduleName mod))
`mplus` lookupModuleEnv pit mod
- | otherwise = lookupModuleEnv pit mod -- Look in PIT only
+ | otherwise = lookupModuleEnv pit mod -- Look in PIT only
-- If the module does come from the home package, why do we look in the PIT as well?
-- (a) In OneShot mode, even home-package modules accumulate in the PIT
@@ -471,29 +471,29 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
| isOneShot (ghcMode (hsc_dflags hsc_env)) = []
| otherwise
= let
- hpt = hsc_HPT hsc_env
+ hpt = hsc_HPT hsc_env
in
[ thing
- | -- Find each non-hi-boot module below me
+ | -- Find each non-hi-boot module below me
(mod, is_boot_mod) <- deps
, include_hi_boot || not is_boot_mod
- -- unsavoury: when compiling the base package with --make, we
- -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't
- -- be in the HPT, because we never compile it; it's in the EPT
- -- instead. ToDo: clean up, and remove this slightly bogus
- -- filter:
+ -- unsavoury: when compiling the base package with --make, we
+ -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't
+ -- be in the HPT, because we never compile it; it's in the EPT
+ -- instead. ToDo: clean up, and remove this slightly bogus
+ -- filter:
, mod /= moduleName gHC_PRIM
- -- Look it up in the HPT
+ -- Look it up in the HPT
, let things = case lookupUFM hpt mod of
- Just info -> extract info
- Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []
- msg = vcat [ptext (sLit "missing module") <+> ppr mod,
- ptext (sLit "Probable cause: out-of-date interface files")]
- -- This really shouldn't happen, but see Trac #962
+ Just info -> extract info
+ Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []
+ msg = vcat [ptext (sLit "missing module") <+> ppr mod,
+ ptext (sLit "Probable cause: out-of-date interface files")]
+ -- This really shouldn't happen, but see Trac #962
- -- And get its dfuns
+ -- And get its dfuns
, thing <- things ]
hptObjs :: HomePackageTable -> [FilePath]
@@ -501,9 +501,9 @@ hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt))
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Dealing with Annotations}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -527,9 +527,9 @@ prepareAnnotations hsc_env mb_guts
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{The Finder cache}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -546,11 +546,11 @@ type FinderCache = ModuleNameEnv FindResult
-- | The result of searching for an imported module.
data FindResult
= Found ModLocation Module
- -- ^ The module was found
+ -- ^ The module was found
| NoPackage PackageId
- -- ^ The requested package was not found
+ -- ^ The requested package was not found
| FoundMultiple [PackageId]
- -- ^ _Error_: both in multiple packages
+ -- ^ _Error_: both in multiple packages
| NotFound -- Not found
{ fr_paths :: [FilePath] -- Places where I looked
@@ -575,9 +575,9 @@ type ModLocationCache = ModuleEnv ModLocation
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Symbol tables and Module details}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -594,103 +594,103 @@ data ModIface
= ModIface {
mi_module :: !Module, -- ^ Name of the module we are for
mi_iface_hash :: !Fingerprint, -- ^ Hash of the whole interface
- mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only
+ mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only
mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans
mi_finsts :: !WhetherHasFamInst, -- ^ Whether this module has family instances
- mi_boot :: !IsBootInterface, -- ^ Read from an hi-boot file?
+ mi_boot :: !IsBootInterface, -- ^ Read from an hi-boot file?
- mi_deps :: Dependencies,
- -- ^ The dependencies of the module. This is
- -- consulted for directly-imported modules, but not
- -- for anything else (hence lazy)
+ mi_deps :: Dependencies,
+ -- ^ The dependencies of the module. This is
+ -- consulted for directly-imported modules, but not
+ -- for anything else (hence lazy)
mi_usages :: [Usage],
-- ^ Usages; kept sorted so that it's easy to decide
- -- whether to write a new iface file (changing usages
- -- doesn't affect the hash of this module)
+ -- whether to write a new iface file (changing usages
+ -- doesn't affect the hash of this module)
- -- NOT STRICT! we read this field lazily from the interface file
- -- It is *only* consulted by the recompilation checker
+ -- NOT STRICT! we read this field lazily from the interface file
+ -- It is *only* consulted by the recompilation checker
- -- Exports
- -- Kept sorted by (mod,occ), to make version comparisons easier
+ -- Exports
+ -- Kept sorted by (mod,occ), to make version comparisons easier
mi_exports :: ![IfaceExport],
-- ^ Records the modules that are the declaration points for things
-- exported by this module, and the 'OccName's of those things
- mi_exp_hash :: !Fingerprint, -- ^ Hash of export list
+ mi_exp_hash :: !Fingerprint, -- ^ Hash of export list
mi_used_th :: !Bool, -- ^ Module required TH splices when it was compiled. This disables recompilation avoidance (see #481).
mi_fixities :: [(OccName,Fixity)],
-- ^ Fixities
- -- NOT STRICT! we read this field lazily from the interface file
+ -- NOT STRICT! we read this field lazily from the interface file
- mi_warns :: Warnings,
- -- ^ Warnings
-
- -- NOT STRICT! we read this field lazily from the interface file
+ mi_warns :: Warnings,
+ -- ^ Warnings
+
+ -- NOT STRICT! we read this field lazily from the interface file
- mi_anns :: [IfaceAnnotation],
- -- ^ Annotations
-
- -- NOT STRICT! we read this field lazily from the interface file
+ mi_anns :: [IfaceAnnotation],
+ -- ^ Annotations
+
+ -- NOT STRICT! we read this field lazily from the interface file
- -- Type, class and variable declarations
- -- The hash of an Id changes if its fixity or deprecations change
- -- (as well as its type of course)
- -- Ditto data constructors, class operations, except that
- -- the hash of the parent class/tycon changes
- mi_decls :: [(Fingerprint,IfaceDecl)], -- ^ Sorted type, variable, class etc. declarations
+ -- Type, class and variable declarations
+ -- The hash of an Id changes if its fixity or deprecations change
+ -- (as well as its type of course)
+ -- Ditto data constructors, class operations, except that
+ -- the hash of the parent class/tycon changes
+ mi_decls :: [(Fingerprint,IfaceDecl)], -- ^ Sorted type, variable, class etc. declarations
mi_globals :: !(Maybe GlobalRdrEnv),
- -- ^ Binds all the things defined at the top level in
- -- the /original source/ code for this module. which
- -- is NOT the same as mi_exports, nor mi_decls (which
- -- may contains declarations for things not actually
- -- defined by the user). Used for GHCi and for inspecting
- -- the contents of modules via the GHC API only.
- --
- -- (We need the source file to figure out the
- -- top-level environment, if we didn't compile this module
- -- from source then this field contains @Nothing@).
- --
- -- Strictly speaking this field should live in the
- -- 'HomeModInfo', but that leads to more plumbing.
-
- -- Instance declarations and rules
- mi_insts :: [IfaceInst], -- ^ Sorted class instance
- mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances
- mi_rules :: [IfaceRule], -- ^ Sorted rules
- mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules and
- -- class and family instances
- -- combined
+ -- ^ Binds all the things defined at the top level in
+ -- the /original source/ code for this module. which
+ -- is NOT the same as mi_exports, nor mi_decls (which
+ -- may contains declarations for things not actually
+ -- defined by the user). Used for GHCi and for inspecting
+ -- the contents of modules via the GHC API only.
+ --
+ -- (We need the source file to figure out the
+ -- top-level environment, if we didn't compile this module
+ -- from source then this field contains @Nothing@).
+ --
+ -- Strictly speaking this field should live in the
+ -- 'HomeModInfo', but that leads to more plumbing.
+
+ -- Instance declarations and rules
+ mi_insts :: [IfaceInst], -- ^ Sorted class instance
+ mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances
+ mi_rules :: [IfaceRule], -- ^ Sorted rules
+ mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules and
+ -- class and family instances
+ -- combined
mi_vect_info :: !IfaceVectInfo, -- ^ Vectorisation information
- -- Cached environments for easy lookup
- -- These are computed (lazily) from other fields
- -- and are not put into the interface file
- mi_warn_fn :: Name -> Maybe WarningTxt, -- ^ Cached lookup for 'mi_warns'
- mi_fix_fn :: OccName -> Fixity, -- ^ Cached lookup for 'mi_fixities'
- mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint),
+ -- Cached environments for easy lookup
+ -- These are computed (lazily) from other fields
+ -- and are not put into the interface file
+ mi_warn_fn :: Name -> Maybe WarningTxt, -- ^ Cached lookup for 'mi_warns'
+ mi_fix_fn :: OccName -> Fixity, -- ^ Cached lookup for 'mi_fixities'
+ mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint),
-- ^ Cached lookup for 'mi_decls'.
- -- The @Nothing@ in 'mi_hash_fn' means that the thing
- -- isn't in decls. It's useful to know that when
- -- seeing if we are up to date wrt. the old interface.
+ -- The @Nothing@ in 'mi_hash_fn' means that the thing
+ -- isn't in decls. It's useful to know that when
+ -- seeing if we are up to date wrt. the old interface.
-- The 'OccName' is the parent of the name, if it has one.
- mi_hpc :: !AnyHpcUsage,
- -- ^ True if this program uses Hpc at any point in the program.
- mi_trust :: !IfaceTrustInfo,
- -- ^ Safe Haskell Trust information for this module.
- mi_trust_pkg :: !Bool
- -- ^ Do we require the package this module resides in be trusted
- -- to trust this module? This is used for the situation where a
- -- module is Safe (so doesn't require the package be trusted
- -- itself) but imports some trustworthy modules from its own
- -- package (which does require its own package be trusted).
+ mi_hpc :: !AnyHpcUsage,
+ -- ^ True if this program uses Hpc at any point in the program.
+ mi_trust :: !IfaceTrustInfo,
+ -- ^ Safe Haskell Trust information for this module.
+ mi_trust_pkg :: !Bool
+ -- ^ Do we require the package this module resides in be trusted
+ -- to trust this module? This is used for the situation where a
+ -- module is Safe (so doesn't require the package be trusted
+ -- itself) but imports some trustworthy modules from its own
+ -- package (which does require its own package be trusted).
-- See Note [RnNames . Trust Own Package]
}
@@ -702,8 +702,8 @@ type IfaceExport = AvailInfo
-- global environments in 'ExternalPackageState'.
data ModDetails
= ModDetails {
- -- The next two fields are created by the typechecker
- md_exports :: [AvailInfo],
+ -- The next two fields are created by the typechecker
+ md_exports :: [AvailInfo],
md_types :: !TypeEnv, -- ^ Local type environment for this particular module
md_insts :: ![Instance], -- ^ 'DFunId's for the instances in this module
md_fam_insts :: ![FamInst],
@@ -715,10 +715,10 @@ data ModDetails
emptyModDetails :: ModDetails
emptyModDetails = ModDetails { md_types = emptyTypeEnv,
- md_exports = [],
- md_insts = [],
- md_rules = [],
- md_fam_insts = [],
+ md_exports = [],
+ md_insts = [],
+ md_rules = [],
+ md_fam_insts = [],
md_anns = [],
md_vect_info = noVectInfo
}
@@ -737,29 +737,29 @@ type ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
data ModGuts
= ModGuts {
mg_module :: !Module, -- ^ Module being compiled
- mg_boot :: IsBootInterface, -- ^ Whether it's an hs-boot module
- mg_exports :: ![AvailInfo], -- ^ What it exports
- mg_deps :: !Dependencies, -- ^ What it depends on, directly or
- -- otherwise
- mg_dir_imps :: !ImportedMods, -- ^ Directly-imported modules; used to
- -- generate initialisation code
- mg_used_names:: !NameSet, -- ^ What the module needed (used in 'MkIface.mkIface')
+ mg_boot :: IsBootInterface, -- ^ Whether it's an hs-boot module
+ mg_exports :: ![AvailInfo], -- ^ What it exports
+ mg_deps :: !Dependencies, -- ^ What it depends on, directly or
+ -- otherwise
+ mg_dir_imps :: !ImportedMods, -- ^ Directly-imported modules; used to
+ -- generate initialisation code
+ mg_used_names:: !NameSet, -- ^ What the module needed (used in 'MkIface.mkIface')
mg_used_th :: !Bool, -- ^ Did we run a TH splice?
mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment
- -- These fields all describe the things **declared in this module**
- mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module
- -- TODO: I'm unconvinced this is actually used anywhere
+ -- These fields all describe the things **declared in this module**
+ mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module
+ -- TODO: I'm unconvinced this is actually used anywhere
mg_tcs :: ![TyCon], -- ^ TyCons declared in this module
mg_clss :: ![Class], -- ^ Classes declared in this module
- mg_insts :: ![Instance], -- ^ Class instances declared in this module
- mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module
- mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains
- -- See Note [Overall plumbing for rules] in Rules.lhs
- mg_binds :: !CoreProgram, -- ^ Bindings for this module
- mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module
- mg_warns :: !Warnings, -- ^ Warnings declared in the module
+ mg_insts :: ![Instance], -- ^ Class instances declared in this module
+ mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module
+ mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains
+ -- See Note [Overall plumbing for rules] in Rules.lhs
+ mg_binds :: !CoreProgram, -- ^ 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_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module
@@ -767,17 +767,17 @@ data ModGuts
-- (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
- -- environments for *all* modules in the home package, including
- -- this module, rather than for *just* this module.
- -- Reason: when looking up an instance we don't want to have to
- -- look at each module in the home package in turn
- mg_inst_env :: InstEnv,
+ -- The next two fields are unusual, because they give instance
+ -- environments for *all* modules in the home package, including
+ -- this module, rather than for *just* this module.
+ -- Reason: when looking up an instance we don't want to have to
+ -- look at each module in the home package in turn
+ mg_inst_env :: InstEnv,
-- ^ Class instance environment from /home-package/ modules (including
- -- this one); c.f. 'tcg_inst_env'
- mg_fam_inst_env :: FamInstEnv,
+ -- this one); c.f. 'tcg_inst_env'
+ mg_fam_inst_env :: FamInstEnv,
-- ^ Type-family instance enviroment for /home-package/ modules
- -- (including this one); c.f. 'tcg_fam_inst_env'
+ -- (including this one); c.f. 'tcg_fam_inst_env'
mg_trust_pkg :: Bool
-- ^ Do we need to trust our own package for Safe Haskell?
-- See Note [RnNames . Trust Own Package]
@@ -786,43 +786,43 @@ data ModGuts
-- The ModGuts takes on several slightly different forms:
--
-- After simplification, the following fields change slightly:
--- mg_rules Orphan rules only (local ones now attached to binds)
--- mg_binds With rules attached
+-- mg_rules Orphan rules only (local ones now attached to binds)
+-- mg_binds With rules attached
-- The ModGuts takes on several slightly different forms:
--
-- After simplification, the following fields change slightly:
--- mg_rules Orphan rules only (local ones now attached to binds)
--- mg_binds With rules attached
+-- mg_rules Orphan rules only (local ones now attached to binds)
+-- mg_binds With rules attached
---------------------------------------------------------
-- The Tidy pass forks the information about this module:
--- * one lot goes to interface file generation (ModIface)
--- and later compilations (ModDetails)
--- * the other lot goes to code generation (CgGuts)
+-- * one lot goes to interface file generation (ModIface)
+-- and later compilations (ModDetails)
+-- * the other lot goes to code generation (CgGuts)
-- | A restricted form of 'ModGuts' for code generation purposes
data CgGuts
= CgGuts {
- cg_module :: !Module, -- ^ Module being compiled
+ cg_module :: !Module, -- ^ Module being compiled
- cg_tycons :: [TyCon],
- -- ^ Algebraic data types (including ones that started
- -- life as classes); generate constructors and info
- -- tables. Includes newtypes, just for the benefit of
- -- External Core
+ cg_tycons :: [TyCon],
+ -- ^ Algebraic data types (including ones that started
+ -- life as classes); generate constructors and info
+ -- tables. Includes newtypes, just for the benefit of
+ -- External Core
- cg_binds :: CoreProgram,
- -- ^ The tidied main bindings, including
- -- previously-implicit bindings for record and class
- -- selectors, and data construtor wrappers. But *not*
- -- data constructor workers; reason: we we regard them
- -- as part of the code-gen of tycons
+ cg_binds :: CoreProgram,
+ -- ^ The tidied main bindings, including
+ -- previously-implicit bindings for record and class
+ -- selectors, and data construtor wrappers. But *not*
+ -- data constructor workers; reason: we we regard them
+ -- as part of the code-gen of tycons
cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
- cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to
- -- generate #includes for C code gen
+ cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to
+ -- generate #includes for C code gen
cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
cg_modBreaks :: !ModBreaks -- ^ Module breakpoints
}
@@ -830,12 +830,12 @@ data CgGuts
-----------------------------------
-- | Foreign export stubs
data ForeignStubs = NoStubs -- ^ We don't have any stubs
- | ForeignStubs
- SDoc
- SDoc
- -- ^ There are some stubs. Parameters:
- --
- -- 1) Header file prototypes for
+ | ForeignStubs
+ SDoc
+ SDoc
+ -- ^ There are some stubs. Parameters:
+ --
+ -- 1) Header file prototypes for
-- "foreign exported" functions
--
-- 2) C stubs to use when calling
@@ -850,40 +850,40 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)
emptyModIface :: Module -> ModIface
emptyModIface mod
= ModIface { mi_module = mod,
- mi_iface_hash = fingerprint0,
- mi_mod_hash = fingerprint0,
- mi_orphan = False,
- mi_finsts = False,
- mi_boot = False,
- mi_deps = noDependencies,
- mi_usages = [],
- mi_exports = [],
- mi_exp_hash = fingerprint0,
+ mi_iface_hash = fingerprint0,
+ mi_mod_hash = fingerprint0,
+ mi_orphan = False,
+ mi_finsts = False,
+ mi_boot = False,
+ mi_deps = noDependencies,
+ mi_usages = [],
+ mi_exports = [],
+ mi_exp_hash = fingerprint0,
mi_used_th = False,
mi_fixities = [],
- mi_warns = NoWarnings,
- mi_anns = [],
- mi_insts = [],
- mi_fam_insts = [],
- mi_rules = [],
- mi_decls = [],
- mi_globals = Nothing,
- mi_orphan_hash = fingerprint0,
+ mi_warns = NoWarnings,
+ mi_anns = [],
+ mi_insts = [],
+ mi_fam_insts = [],
+ mi_rules = [],
+ mi_decls = [],
+ mi_globals = Nothing,
+ mi_orphan_hash = fingerprint0,
mi_vect_info = noIfaceVectInfo,
- mi_warn_fn = emptyIfaceWarnCache,
- mi_fix_fn = emptyIfaceFixCache,
- mi_hash_fn = emptyIfaceHashCache,
- mi_hpc = False,
- mi_trust = noIfaceTrustInfo,
+ mi_warn_fn = emptyIfaceWarnCache,
+ mi_fix_fn = emptyIfaceFixCache,
+ mi_hash_fn = emptyIfaceHashCache,
+ mi_hpc = False,
+ mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False
- }
+ }
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{The interactive context}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -1013,10 +1013,10 @@ substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst
subst_ty tt = tt
data InteractiveImport
- = IIDecl (ImportDecl RdrName) -- Bring the exports of a particular module
+ = IIDecl (ImportDecl RdrName) -- Bring the exports of a particular module
-- (filtered by an import decl) into scope
- | IIModule Module -- Bring into scope the entire top-level envt of
+ | IIModule Module -- Bring into scope the entire top-level envt of
-- of this module, including the things imported
-- into it.
@@ -1027,9 +1027,9 @@ instance Outputable InteractiveImport where
\end{code}
%************************************************************************
-%* *
- Building a PrintUnqualified
-%* *
+%* *
+ Building a PrintUnqualified
+%* *
%************************************************************************
Note [Printing original names]
@@ -1070,8 +1070,8 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
where
qual_name name
| [gre] <- unqual_gres, right_name gre = NameUnqual
- -- If there's a unique entity that's in scope unqualified with 'occ'
- -- AND that entity is the right one, then we can use the unqualified name
+ -- If there's a unique entity that's in scope unqualified with 'occ'
+ -- AND that entity is the right one, then we can use the unqualified name
| [gre] <- qual_gres = NameQual (get_qual_mod (gre_prov gre))
@@ -1080,7 +1080,7 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
then NameNotInScope1
else NameNotInScope2
- | otherwise = panic "mkPrintUnqualified"
+ | otherwise = panic "mkPrintUnqualified"
where
mod = nameModule name
occ = nameOccName name
@@ -1095,8 +1095,8 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env
qual_gres = filter right_name (lookupGlobalRdrEnv env occ)
- get_qual_mod LocalDef = moduleName mod
- get_qual_mod (Imported is) = ASSERT( not (null is) ) is_as (is_decl (head is))
+ get_qual_mod LocalDef = moduleName mod
+ get_qual_mod (Imported is) = ASSERT( not (null is) ) is_as (is_decl (head is))
-- we can mention a module P:M without the P: qualifier iff
-- "import M" would resolve unambiguously to P:M. (if P is the
@@ -1137,9 +1137,9 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
%************************************************************************
-%* *
- TyThing
-%* *
+%* *
+ TyThing
+%* *
%************************************************************************
\begin{code}
@@ -1200,7 +1200,7 @@ implicitCoTyCon tc
= map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not
newTyConCo_maybe tc,
-- Just if family instance, Nothing if not
- tyConFamilyCoercion_maybe tc]
+ tyConFamilyCoercion_maybe tc]
-- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y)
@@ -1228,8 +1228,8 @@ tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of
Nothing -> Nothing
tyThingParent_maybe (AnId id) = case idDetails id of
RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
- ClassOpId cls -> Just (ATyCon (classTyCon cls))
- _other -> Nothing
+ ClassOpId cls -> Just (ATyCon (classTyCon cls))
+ _other -> Nothing
tyThingParent_maybe _other = Nothing
tyThingsTyVars :: [TyThing] -> TyVarSet
@@ -1261,9 +1261,9 @@ tyThingAvailInfo t
\end{code}
%************************************************************************
-%* *
- TypeEnv
-%* *
+%* *
+ TypeEnv
+%* *
%************************************************************************
\begin{code}
@@ -1280,7 +1280,7 @@ typeEnvDataCons :: TypeEnv -> [DataCon]
typeEnvClasses :: TypeEnv -> [Class]
lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
-emptyTypeEnv = emptyNameEnv
+emptyTypeEnv = emptyNameEnv
typeEnvElts env = nameEnvElts env
typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]
@@ -1291,7 +1291,7 @@ typeEnvClasses env = [cl | tc <- typeEnvTyCons env,
mkTypeEnv :: [TyThing] -> TypeEnv
mkTypeEnv things = extendTypeEnvList emptyTypeEnv things
-
+
mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv
mkTypeEnvWithImplicits things =
mkTypeEnv things
@@ -1329,10 +1329,10 @@ extendTypeEnvWithIds env ids
-- that this does NOT look up the 'TyThing' in the module being compiled: you
-- have to do that yourself, if desired
lookupType :: DynFlags
- -> HomePackageTable
- -> PackageTypeEnv
- -> Name
- -> Maybe TyThing
+ -> HomePackageTable
+ -> PackageTypeEnv
+ -> Name
+ -> Maybe TyThing
lookupType dflags hpt pte name
-- in one-shot, we don't use the HPT
@@ -1342,7 +1342,7 @@ lookupType dflags hpt pte name
| otherwise
= lookupNameEnv pte name
where mod = ASSERT( isExternalName name ) nameModule name
- this_pkg = thisPackage dflags
+ this_pkg = thisPackage dflags
-- | As 'lookupType', but with a marginally easier-to-use interface
-- if you have a 'HscEnv'
@@ -1359,17 +1359,17 @@ lookupTypeHscEnv hsc_env name = do
-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise
tyThingTyCon :: TyThing -> TyCon
tyThingTyCon (ATyCon tc) = tc
-tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other)
+tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other)
-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
tyThingCoAxiom :: TyThing -> CoAxiom
tyThingCoAxiom (ACoAxiom ax) = ax
-tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other)
+tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other)
-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise
tyThingDataCon :: TyThing -> DataCon
tyThingDataCon (ADataCon dc) = dc
-tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other)
+tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other)
-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise
tyThingId :: TyThing -> Id
@@ -1421,9 +1421,9 @@ emptyIfaceHashCache _occ = Nothing
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Auxiliary types}
-%* *
+%* *
%************************************************************************
These types are defined here because they are mentioned in ModDetails,
@@ -1434,7 +1434,7 @@ but they are mostly elaborated elsewhere
-- | Warning information for a module
data Warnings
= NoWarnings -- ^ Nothing deprecated
- | WarnAll WarningTxt -- ^ Whole module deprecated
+ | WarnAll WarningTxt -- ^ Whole module deprecated
| WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated
-- Only an OccName is needed because
@@ -1502,15 +1502,15 @@ emptyFixityEnv = emptyNameEnv
lookupFixity :: FixityEnv -> Name -> Fixity
lookupFixity env n = case lookupNameEnv env n of
- Just (FixItem _ fix) -> fix
- Nothing -> defaultFixity
+ Just (FixItem _ fix) -> fix
+ Nothing -> defaultFixity
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{WhatsImported}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -1564,45 +1564,45 @@ data Usage
usg_mod :: Module,
-- ^ External package module depended on
usg_mod_hash :: Fingerprint,
- -- ^ Cached module fingerprint
+ -- ^ Cached module fingerprint
usg_safe :: IsSafeImport
-- ^ Was this module imported as a safe import
} -- ^ Module from another package
| UsageHomeModule {
usg_mod_name :: ModuleName,
-- ^ Name of the module
- usg_mod_hash :: Fingerprint,
- -- ^ Cached module fingerprint
- usg_entities :: [(OccName,Fingerprint)],
+ usg_mod_hash :: Fingerprint,
+ -- ^ Cached module fingerprint
+ usg_entities :: [(OccName,Fingerprint)],
-- ^ Entities we depend on, sorted by occurrence name and fingerprinted.
-- NB: usages are for parent names only, e.g. type constructors
-- but not the associated data constructors.
- usg_exports :: Maybe Fingerprint,
+ usg_exports :: Maybe Fingerprint,
-- ^ Fingerprint for the export list we used to depend on this module,
-- if we depend on the export list
usg_safe :: IsSafeImport
-- ^ Was this module imported as a safe import
} -- ^ Module from the current package
deriving( Eq )
- -- The export list field is (Just v) if we depend on the export list:
- -- i.e. we imported the module directly, whether or not we
- -- enumerated the things we imported, or just imported
+ -- The export list field is (Just v) if we depend on the export list:
+ -- i.e. we imported the module directly, whether or not we
+ -- enumerated the things we imported, or just imported
-- everything
- -- We need to recompile if M's exports change, because
- -- if the import was import M, we might now have a name clash
+ -- We need to recompile if M's exports change, because
+ -- if the import was import M, we might now have a name clash
-- in the importing module.
- -- if the import was import M(x) M might no longer export x
- -- The only way we don't depend on the export list is if we have
- -- import M()
- -- And of course, for modules that aren't imported directly we don't
- -- depend on their export lists
+ -- if the import was import M(x) M might no longer export x
+ -- The only way we don't depend on the export list is if we have
+ -- import M()
+ -- And of course, for modules that aren't imported directly we don't
+ -- depend on their export lists
\end{code}
%************************************************************************
-%* *
- The External Package State
-%* *
+%* *
+ The External Package State
+%* *
%************************************************************************
\begin{code}
@@ -1617,76 +1617,76 @@ type PackageAnnEnv = AnnEnv
-- their interface files
data ExternalPackageState
= EPS {
- eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)),
- -- ^ In OneShot mode (only), home-package modules
- -- accumulate in the external package state, and are
- -- sucked in lazily. For these home-pkg modules
- -- (only) we need to record which are boot modules.
- -- We set this field after loading all the
- -- explicitly-imported interfaces, but before doing
- -- anything else
- --
- -- The 'ModuleName' part is not necessary, but it's useful for
- -- debug prints, and it's convenient because this field comes
- -- direct from 'TcRnTypes.imp_dep_mods'
-
- eps_PIT :: !PackageIfaceTable,
- -- ^ The 'ModIface's for modules in external packages
- -- whose interfaces we have opened.
- -- The declarations in these interface files are held in the
- -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules'
- -- fields of this record, not in the 'mi_decls' fields of the
- -- interface we have sucked in.
- --
- -- What /is/ in the PIT is:
- --
- -- * The Module
- --
- -- * Fingerprint info
- --
- -- * Its exports
- --
- -- * Fixities
- --
- -- * Deprecations and warnings
-
- eps_PTE :: !PackageTypeEnv,
- -- ^ Result of typechecking all the external package
- -- interface files we have sucked in. The domain of
- -- the mapping is external-package modules
-
- eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated
- -- from all the external-package modules
- eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated
- -- from all the external-package modules
- eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated
- -- from all the external-package modules
- eps_vect_info :: !PackageVectInfo, -- ^ The total 'VectInfo' accumulated
- -- from all the external-package modules
+ eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)),
+ -- ^ In OneShot mode (only), home-package modules
+ -- accumulate in the external package state, and are
+ -- sucked in lazily. For these home-pkg modules
+ -- (only) we need to record which are boot modules.
+ -- We set this field after loading all the
+ -- explicitly-imported interfaces, but before doing
+ -- anything else
+ --
+ -- The 'ModuleName' part is not necessary, but it's useful for
+ -- debug prints, and it's convenient because this field comes
+ -- direct from 'TcRnTypes.imp_dep_mods'
+
+ eps_PIT :: !PackageIfaceTable,
+ -- ^ The 'ModIface's for modules in external packages
+ -- whose interfaces we have opened.
+ -- The declarations in these interface files are held in the
+ -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules'
+ -- fields of this record, not in the 'mi_decls' fields of the
+ -- interface we have sucked in.
+ --
+ -- What /is/ in the PIT is:
+ --
+ -- * The Module
+ --
+ -- * Fingerprint info
+ --
+ -- * Its exports
+ --
+ -- * Fixities
+ --
+ -- * Deprecations and warnings
+
+ eps_PTE :: !PackageTypeEnv,
+ -- ^ Result of typechecking all the external package
+ -- interface files we have sucked in. The domain of
+ -- the mapping is external-package modules
+
+ eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated
+ -- from all the external-package modules
+ eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated
+ -- from all the external-package modules
+ eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated
+ -- from all the external-package modules
+ eps_vect_info :: !PackageVectInfo, -- ^ The total 'VectInfo' accumulated
+ -- from all the external-package modules
eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated
- -- from all the external-package modules
+ -- from all the external-package modules
eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external
-- packages, keyed off the module that declared them
- eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages
+ eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages
}
-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.
-- \"In\" means stuff that is just /read/ from interface files,
-- \"Out\" means actually sucked in and type-checked
data EpsStats = EpsStats { n_ifaces_in
- , n_decls_in, n_decls_out
- , n_rules_in, n_rules_out
- , n_insts_in, n_insts_out :: !Int }
+ , n_decls_in, n_decls_out
+ , n_rules_in, n_rules_out
+ , n_insts_in, n_insts_out :: !Int }
addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats
-- ^ Add stats for one newly-read interface
addEpsInStats stats n_decls n_insts n_rules
= stats { n_ifaces_in = n_ifaces_in stats + 1
- , n_decls_in = n_decls_in stats + n_decls
- , n_insts_in = n_insts_in stats + n_insts
- , n_rules_in = n_rules_in stats + n_rules }
+ , n_decls_in = n_decls_in stats + n_decls
+ , n_insts_in = n_insts_in stats + n_insts
+ , n_rules_in = n_rules_in stats + n_rules }
\end{code}
Names in a NameCache are always stored as a Global, and have the SrcLoc
@@ -1703,9 +1703,9 @@ its binding site, we fix it up.
-- something of a lookup mechanism for those names.
data NameCache
= NameCache { nsUniqs :: UniqSupply,
- -- ^ Supply of uniques
- nsNames :: OrigNameCache,
- -- ^ Ensures that one original name gets one unique
+ -- ^ Supply of uniques
+ nsNames :: OrigNameCache,
+ -- ^ Ensures that one original name gets one unique
nsIPs :: OrigIParamCache
-- ^ Ensures that one implicit parameter name gets one unique
}
@@ -1720,11 +1720,11 @@ type OrigIParamCache = Map FastString (IPName Name)
%************************************************************************
-%* *
- The module graph and ModSummary type
- A ModSummary is a node in the compilation manager's
- dependency graph, and it's also passed to hscMain
-%* *
+%* *
+ The module graph and ModSummary type
+ A ModSummary is a node in the compilation manager's
+ dependency graph, and it's also passed to hscMain
+%* *
%************************************************************************
\begin{code}
@@ -1748,17 +1748,17 @@ emptyMG = []
-- * An external-core source module
data ModSummary
= ModSummary {
- ms_mod :: Module, -- ^ Identity of the module
- ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core
- ms_location :: ModLocation, -- ^ Location of the various files belonging to the module
- ms_hs_date :: ClockTime, -- ^ Timestamp of source file
- ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one
- ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module
- ms_textual_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module from the module *text*
- ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file
+ ms_mod :: Module, -- ^ Identity of the module
+ ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core
+ ms_location :: ModLocation, -- ^ Location of the various files belonging to the module
+ ms_hs_date :: ClockTime, -- ^ Timestamp of source file
+ ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one
+ ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module
+ ms_textual_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module from the module *text*
+ ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file
ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@
-- and @LANGUAGE@ pragmas in the modules source code
- ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it
+ ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it
}
ms_mod_name :: ModSummary -> ModuleName
@@ -1774,7 +1774,7 @@ ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies
ideclName = noLoc mod_nm,
ideclPkgQual = Nothing,
ideclSource = False,
- ideclImplicit = True, -- Maybe implicit because not "in the program text"
+ ideclImplicit = True, -- Maybe implicit because not "in the program text"
ideclQualified = False,
ideclAs = Nothing,
ideclHiding = Nothing,
@@ -1805,7 +1805,7 @@ instance Outputable ModSummary where
= sep [text "ModSummary {",
nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
text "ms_mod =" <+> ppr (ms_mod ms)
- <> text (hscSourceString (ms_hsc_src ms)) <> comma,
+ <> text (hscSourceString (ms_hsc_src ms)) <> comma,
text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),
text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
char '}'
@@ -1828,9 +1828,9 @@ showModMsg target recomp mod_summary
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Recmpilation}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -1853,9 +1853,9 @@ data SourceModified
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Hpc Support}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -1879,7 +1879,7 @@ emptyHpcInfo = NoHpcInfo
-- | Find out if HPC is used by this module or any of the modules
-- it depends upon
isHpcUsed :: HpcInfo -> AnyHpcUsage
-isHpcUsed (HpcInfo {}) = True
+isHpcUsed (HpcInfo {}) = True
isHpcUsed (NoHpcInfo { hpcUsed = used }) = used
\end{code}
@@ -1910,8 +1910,6 @@ data VectInfo
{ vectInfoVar :: VarEnv (Var , Var ) -- ^ @(f, f_v)@ keyed on @f@
, vectInfoTyCon :: NameEnv (TyCon , TyCon) -- ^ @(T, T_v)@ keyed on @T@
, vectInfoDataCon :: NameEnv (DataCon, DataCon) -- ^ @(C, C_v)@ keyed on @C@
- , vectInfoPADFun :: NameEnv (TyCon , Var) -- ^ @(T_v, paT)@ keyed on @T_v@
- , vectInfoIso :: NameEnv (TyCon , Var) -- ^ @(T, isoT)@ keyed on @T@
, vectInfoScalarVars :: VarSet -- ^ set of purely scalar variables
, vectInfoScalarTyCons :: NameSet -- ^ set of scalar type constructors
}
@@ -1937,16 +1935,13 @@ data IfaceVectInfo
noVectInfo :: VectInfo
noVectInfo
- = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyVarSet
- emptyNameSet
+ = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyVarSet emptyNameSet
plusVectInfo :: VectInfo -> VectInfo -> VectInfo
plusVectInfo vi1 vi2 =
VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2)
(vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2)
(vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2)
- (vectInfoPADFun vi1 `plusNameEnv` vectInfoPADFun vi2)
- (vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2)
(vectInfoScalarVars vi1 `unionVarSet` vectInfoScalarVars vi2)
(vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2)
@@ -1961,17 +1956,15 @@ instance Outputable VectInfo where
[ ptext (sLit "variables :") <+> ppr (vectInfoVar info)
, ptext (sLit "tycons :") <+> ppr (vectInfoTyCon info)
, ptext (sLit "datacons :") <+> ppr (vectInfoDataCon info)
- , ptext (sLit "PA dfuns :") <+> ppr (vectInfoPADFun info)
- , ptext (sLit "iso :") <+> ppr (vectInfoIso info)
, ptext (sLit "scalar vars :") <+> ppr (vectInfoScalarVars info)
, ptext (sLit "scalar tycons :") <+> ppr (vectInfoScalarTyCons info)
]
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Safe Haskell Support}
-%* *
+%* *
%************************************************************************
This stuff here is related to supporting the Safe Haskell extension,
@@ -2017,9 +2010,9 @@ instance Outputable IfaceTrustInfo where
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Linkable stuff}
-%* *
+%* *
%************************************************************************
This stuff is in here, rather than (say) in Linker.lhs, because the Linker.lhs
@@ -2028,9 +2021,9 @@ stuff is the *dynamic* linker, and isn't present in a stage-1 compiler
\begin{code}
-- | Information we can use to dynamically link modules into the compiler
data Linkable = LM {
- linkableTime :: ClockTime, -- ^ Time at which this linkable was built
- -- (i.e. when the bytecodes were produced,
- -- or the mod date on the files)
+ linkableTime :: ClockTime, -- ^ Time at which this linkable was built
+ -- (i.e. when the bytecodes were produced,
+ -- or the mod date on the files)
linkableModule :: Module, -- ^ The linkable module itself
linkableUnlinked :: [Unlinked]
-- ^ Those files and chunks of code we have yet to link.
@@ -2045,10 +2038,10 @@ data Linkable = LM {
isObjectLinkable :: Linkable -> Bool
isObjectLinkable l = not (null unlinked) && all isObject unlinked
where unlinked = linkableUnlinked l
- -- A linkable with no Unlinked's is treated as a BCO. We can
- -- generate a linkable with no Unlinked's as a result of
- -- compiling a module in HscNothing mode, and this choice
- -- happens to work well with checkStability in module GHC.
+ -- A linkable with no Unlinked's is treated as a BCO. We can
+ -- generate a linkable with no Unlinked's as a result of
+ -- compiling a module in HscNothing mode, and this choice
+ -- happens to work well with checkStability in module GHC.
linkableObjs :: Linkable -> [FilePath]
linkableObjs l = [ f | DotO f <- linkableUnlinked l ]
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 980b46c34b..d800bc6db7 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -494,13 +494,9 @@ tidyInstances tidy_dfun ispecs
\begin{code}
tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
- , vectInfoPADFun = pas
- , vectInfoIso = isos
, vectInfoScalarVars = scalarVars
})
= info { vectInfoVar = tidy_vars
- , vectInfoPADFun = tidy_pas
- , vectInfoIso = tidy_isos
, vectInfoScalarVars = tidy_scalarVars
}
where
@@ -512,11 +508,6 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
, isExportedId tidy_var_v
]
- tidy_pas = mapNameEnv tidy_snd_var pas
- tidy_isos = mapNameEnv tidy_snd_var isos
-
- tidy_snd_var (x, var) = (x, lookup_var var)
-
tidy_scalarVars = mkVarSet [ lookup_var var
| var <- varSetElems scalarVars
, isGlobalId var || isExportedId var]
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index b48df7f94f..7eacbd5388 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -399,6 +399,9 @@ rANDOM = mkBaseModule (fsLit "System.Random")
gHC_EXTS = mkBaseModule (fsLit "GHC.Exts")
cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
+dATA_ARRAY_PARALLEL_PRIM :: PackageId -> Module
+dATA_ARRAY_PARALLEL_PRIM pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel.Prim"))
+
gHC_PARR :: PackageId -> Module
gHC_PARR pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel"))
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index c7341b891e..8a78ad771a 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -1485,6 +1485,9 @@ checkValidInstance hs_type tyvars theta clas inst_tys
L loc _ -> loc
\end{code}
+Note [Paterson conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
Termination test: the so-called "Paterson conditions" (see Section 5 of
"Understanding functionsl dependencies via Constraint Handling Rules,
JFP Jan 2007).
@@ -1633,7 +1636,6 @@ fvTypes tys = concat (map fvType tys)
-- Size of a type: the number of variables and constructors
sizeType :: Type -> Int
sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
-sizeType ty | isPredTy ty = sizePred ty
sizeType (TyVarTy _) = 1
sizeType (TyConApp _ tys) = sizeTypes tys + 1
sizeType (FunTy arg res) = sizeType arg + sizeType res + 1
@@ -1643,18 +1645,41 @@ sizeType (ForAllTy _ ty) = sizeType ty
sizeTypes :: [Type] -> Int
sizeTypes xs = sum (map sizeType xs)
--- Size of a predicate
+-- Size of a predicate: the number of variables and constructors
+--
+-- Note [Paterson conditions on PredTypes]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We are considering whether *class* constraints terminate
--- Once we get into an implicit parameter or equality we
--- can't get back to a class constraint, so it's safe
--- to say "size 0". See Trac #4200.
+-- (see Note [Paterson conditions]). Precisely, the Paterson conditions
+-- would have us check that "the constraint has fewer constructors and variables
+-- (taken together and counting repetitions) than the head.".
+--
+-- However, we can be a bit more refined by looking at which kind of constraint
+-- this actually is. There are two main tricks:
+--
+-- 1. It seems like it should be OK not to count the tuple type constructor
+-- for a PredType like (Show a, Eq a) :: Constraint, since we don't
+-- count the "implicit" tuple in the ThetaType itself.
+--
+-- In fact, the Paterson test just checks *each component* of the top level
+-- ThetaType against the size bound, one at a time. By analogy, it should be
+-- OK to return the size of the *largest* tuple component as the size of the
+-- whole tuple.
+--
+-- 2. Once we get into an implicit parameter or equality we
+-- can't get back to a class constraint, so it's safe
+-- to say "size 0". See Trac #4200.
+--
+-- NB: we don't want to detect PredTypes in sizeType (and then call
+-- sizePred on them), or we might get an infinite loop if that PredType
+-- is irreducible. See Trac #5581.
sizePred :: PredType -> Int
sizePred ty = go (predTypePredTree ty)
where
go (ClassPred _ tys') = sizeTypes tys'
go (IPPred {}) = 0
go (EqPred {}) = 0
- go (TuplePred ts) = sum (map go ts)
+ go (TuplePred ts) = maximum (0:map go ts)
go (IrredPred ty) = sizeType ty
\end{code}
diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs
index 5545df825d..bf0fae1c11 100644
--- a/compiler/vectorise/Vectorise/Builtins.hs
+++ b/compiler/vectorise/Vectorise/Builtins.hs
@@ -1,74 +1,32 @@
--- Types and functions declared in the DPH packages and used by the vectoriser.
+-- Types and functions declared in 'Data.Array.Parallel.Prim' and used by the vectoriser.
--
--- The @Builtins@ structure holds the name of all the things in the DPH packages that appear in
--- code generated by the vectoriser. We can get specific things using the selectors, which print a
--- civilized panic message if the specified thing cannot be found.
+-- The @Builtins@ structure holds the name of all the things in 'Data.Array.Parallel.Prim' that appear in
+-- code generated by the vectoriser.
module Vectorise.Builtins (
-- * Builtins
Builtins(..),
- indexBuiltin,
-- * Wrapped selectors
+ parray_PrimTyCon,
selTy,
selReplicate,
- selPick,
selTags,
selElements,
sumTyCon,
prodTyCon,
prodDataCon,
+ replicatePD_PrimVar,
+ emptyPD_PrimVar,
+ packByTagPD_PrimVar,
combinePDVar,
+ combinePD_PrimVar,
scalarZip,
closureCtrFun,
-- * Initialisation
- initBuiltins, initBuiltinVars, initBuiltinTyCons,
- initBuiltinPAs, initBuiltinPRs,
-
- -- * Lookup
- primMethod,
- primPArray
+ initBuiltins, initBuiltinVars, initBuiltinTyCons
) where
-
+
import Vectorise.Builtins.Base
-import Vectorise.Builtins.Modules
import Vectorise.Builtins.Initialise
-
-import TysPrim
-import IfaceEnv
-import TyCon
-import DsMonad
-import NameEnv
-import Name
-import Var
-import Control.Monad
-
-
--- |Lookup a method function given its name and instance type.
---
-primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
-primMethod tycon method (Builtins { dphModules = mods })
- | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
- = liftM Just
- $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
- (mkVarOcc $ method ++ suffix)
-
- | otherwise = return Nothing
-
--- |Lookup the representation type we use for PArrays that contain a given element type.
---
-primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
-primPArray tycon (Builtins { dphModules = mods })
- | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
- = liftM Just
- $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
- (mkTcOcc $ "PArray" ++ suffix)
-
- | otherwise = return Nothing
-
-prim_ty_cons :: NameEnv String
-prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
- where
- mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
-
diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs
index 52eb887233..13ab890425 100644
--- a/compiler/vectorise/Vectorise/Builtins/Base.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Base.hs
@@ -1,4 +1,5 @@
--- | Builtin types and functions used by the vectoriser. These are all defined in the DPH package.
+-- |Builtin types and functions used by the vectoriser. These are all defined in
+-- 'Data.Array.Parallel.Prim'.
module Vectorise.Builtins.Base (
-- * Hard config
@@ -6,26 +7,30 @@ module Vectorise.Builtins.Base (
mAX_DPH_SUM,
mAX_DPH_COMBINE,
mAX_DPH_SCALAR_ARGS,
+ aLL_DPH_PRIM_TYCONS,
-- * Builtins
Builtins(..),
- indexBuiltin,
-- * Projections
- selTy,
+ parray_PrimTyCon,
+ selTy,
selReplicate,
- selPick,
selTags,
selElements,
sumTyCon,
prodTyCon,
prodDataCon,
+ replicatePD_PrimVar,
+ emptyPD_PrimVar,
+ packByTagPD_PrimVar,
combinePDVar,
+ combinePD_PrimVar,
scalarZip,
closureCtrFun
) where
-import Vectorise.Builtins.Modules
+import TysPrim
import BasicTypes
import Class
import CoreSyn
@@ -33,11 +38,15 @@ import TysWiredIn
import Type
import TyCon
import DataCon
+import NameEnv
+import Name
import Outputable
+
import Data.Array
--- Numbers of things exported by the DPH library.
+-- Cardinality of the various families of types and functions exported by the DPH library.
+
mAX_DPH_PROD :: Int
mAX_DPH_PROD = 5
@@ -50,114 +59,83 @@ mAX_DPH_COMBINE = 2
mAX_DPH_SCALAR_ARGS :: Int
mAX_DPH_SCALAR_ARGS = 3
+-- Types from 'GHC.Prim' supported by DPH
+--
+aLL_DPH_PRIM_TYCONS :: [Name]
+aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doublePrimTyCon]
+
--- | Holds the names of the builtin types and functions used by the vectoriser.
+-- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the
+-- vectoriser.
+--
data Builtins
= Builtins
- { dphModules :: Modules
-
- -- From dph-common:Data.Array.Parallel.Lifted.PArray
- , parrayTyCon :: TyCon -- ^ PArray
- , parrayDataCon :: DataCon -- ^ PArray
- , pdataTyCon :: TyCon -- ^ PData
- , paClass :: Class -- ^ PA
- , paTyCon :: TyCon -- ^ PA
- , paDataCon :: DataCon -- ^ PA
- , paPRSel :: Var -- ^ PA
- , preprTyCon :: TyCon -- ^ PRepr
- , prClass :: Class -- ^ PR
- , prTyCon :: TyCon -- ^ PR
- , prDataCon :: DataCon -- ^ PR
- , replicatePDVar :: Var -- ^ replicatePD
- , emptyPDVar :: Var -- ^ emptyPD
- , packByTagPDVar :: Var -- ^ packByTagPD
- , combinePDVars :: Array Int Var -- ^ combinePD
- , scalarClass :: Class -- ^ Scalar
-
- -- From dph-common:Data.Array.Parallel.Lifted.Closure
- , closureTyCon :: TyCon -- ^ :->
- , closureVar :: Var -- ^ closure
- , applyVar :: Var -- ^ $:
- , liftedClosureVar :: Var -- ^ liftedClosure
- , liftedApplyVar :: Var -- ^ liftedApply
- , closureCtrFuns :: Array Int Var -- ^ closure1 .. closure2
-
- -- From dph-common:Data.Array.Parallel.Lifted.Repr
- , voidTyCon :: TyCon -- ^ Void
- , wrapTyCon :: TyCon -- ^ Wrap
- , sumTyCons :: Array Int TyCon -- ^ Sum2 .. Sum3
- , voidVar :: Var -- ^ void
- , pvoidVar :: Var -- ^ pvoid
- , fromVoidVar :: Var -- ^ fromVoid
- , punitVar :: Var -- ^ punit
-
- -- From dph-common:Data.Array.Parallel.Lifted.Selector
- , selTys :: Array Int Type -- ^ Sel2
- , selReplicates :: Array Int CoreExpr -- ^ replicate2
- , selPicks :: Array Int CoreExpr -- ^ pick2
- , selTagss :: Array Int CoreExpr -- ^ tagsSel2
- , selEls :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1
-
- -- From dph-common:Data.Array.Parallel.Lifted.Scalar
- -- NOTE: map is counted as a zipWith fn with one argument array.
- , scalarZips :: Array Int Var -- ^ map, zipWith, zipWith3
-
- -- A Fresh variable
- , liftingContext :: Var -- ^ lc
+ { parrayTyCon :: TyCon -- ^ PArray
+ , parray_PrimTyCons :: NameEnv TyCon -- ^ PArray_Int# etc.
+ , pdataTyCon :: TyCon -- ^ PData
+ , prClass :: Class -- ^ PR
+ , prTyCon :: TyCon -- ^ PR
+ , preprTyCon :: TyCon -- ^ PRepr
+ , paClass :: Class -- ^ PA
+ , paTyCon :: TyCon -- ^ PA
+ , paDataCon :: DataCon -- ^ PA
+ , paPRSel :: Var -- ^ PA
+ , replicatePDVar :: Var -- ^ replicatePD
+ , replicatePD_PrimVars :: NameEnv Var -- ^ replicatePD_Int# etc.
+ , emptyPDVar :: Var -- ^ emptyPD
+ , emptyPD_PrimVars :: NameEnv Var -- ^ emptyPD_Int# etc.
+ , packByTagPDVar :: Var -- ^ packByTagPD
+ , packByTagPD_PrimVars :: NameEnv Var -- ^ packByTagPD_Int# etc.
+ , combinePDVars :: Array Int Var -- ^ combinePD
+ , combinePD_PrimVarss :: Array Int (NameEnv Var) -- ^ combine2PD_Int# etc.
+ , scalarClass :: Class -- ^ Scalar
+ , scalarZips :: Array Int Var -- ^ map, zipWith, zipWith3
+ , voidTyCon :: TyCon -- ^ Void
+ , voidVar :: Var -- ^ void
+ , fromVoidVar :: Var -- ^ fromVoid
+ , sumTyCons :: Array Int TyCon -- ^ Sum2 .. Sum3
+ , wrapTyCon :: TyCon -- ^ Wrap
+ , pvoidVar :: Var -- ^ pvoid
+ , closureTyCon :: TyCon -- ^ :->
+ , closureVar :: Var -- ^ closure
+ , liftedClosureVar :: Var -- ^ liftedClosure
+ , applyVar :: Var -- ^ $:
+ , liftedApplyVar :: Var -- ^ liftedApply
+ , closureCtrFuns :: Array Int Var -- ^ closure1 .. closure3
+ , selTys :: Array Int Type -- ^ Sel2
+ , selReplicates :: Array Int CoreExpr -- ^ replicate2
+ , selTagss :: Array Int CoreExpr -- ^ tagsSel2
+ , selElementss :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1
+ , liftingContext :: Var -- ^ lc
}
--- | Get an element from one of the arrays of contained by a `Builtins`.
--- If the indexed thing is not in the array then panic.
-indexBuiltin
- :: (Ix i, Outputable i)
- => String -- ^ Name of the selector we've used, for panic messages.
- -> (Builtins -> Array i a) -- ^ Field selector for the `Builtins`.
- -> i -- ^ Index into the array.
- -> Builtins
- -> a
-
-indexBuiltin fn f i bi
- | inRange (bounds xs) i = xs ! i
- | otherwise
- = pprSorry "Vectorise.Builtins.indexBuiltin"
- (vcat [ text ""
- , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> text "' is not yet implemented."
- , text "This function does not appear in your source program, but it is needed"
- , text "to compile your code in the backend. This is a known, current limitation"
- , text "of DPH. If you want it to to work you should send mail to cvs-ghc@haskell.org"
- , text "and ask what you can do to help (it might involve some GHC hacking)."])
-
- where xs = f bi
-
-
-- Projections ----------------------------------------------------------------
-- We use these wrappers instead of indexing the `Builtin` structure directly
-- because they give nicer panic messages if the indexed thing cannot be found.
+parray_PrimTyCon :: TyCon -> Builtins -> TyCon
+parray_PrimTyCon tc bi = lookupEnvBuiltin "parray_PrimTyCon" (parray_PrimTyCons bi) (tyConName tc)
+
selTy :: Int -> Builtins -> Type
-selTy = indexBuiltin "selTy" selTys
+selTy = indexBuiltin "selTy" selTys
selReplicate :: Int -> Builtins -> CoreExpr
-selReplicate = indexBuiltin "selReplicate" selReplicates
-
-selPick :: Int -> Builtins -> CoreExpr
-selPick = indexBuiltin "selPick" selPicks
+selReplicate = indexBuiltin "selReplicate" selReplicates
selTags :: Int -> Builtins -> CoreExpr
selTags = indexBuiltin "selTags" selTagss
selElements :: Int -> Int -> Builtins -> CoreExpr
-selElements i j = indexBuiltin "selElements" selEls (i,j)
+selElements i j = indexBuiltin "selElements" selElementss (i, j)
sumTyCon :: Int -> Builtins -> TyCon
-sumTyCon = indexBuiltin "sumTyCon" sumTyCons
+sumTyCon = indexBuiltin "sumTyCon" sumTyCons
prodTyCon :: Int -> Builtins -> TyCon
prodTyCon n _
| n >= 2 && n <= mAX_DPH_PROD
= tupleTyCon BoxedTuple n
-
| otherwise
= pprPanic "prodTyCon" (ppr n)
@@ -167,13 +145,67 @@ prodDataCon n bi
[con] -> con
_ -> pprPanic "prodDataCon" (ppr n)
+replicatePD_PrimVar :: TyCon -> Builtins -> Var
+replicatePD_PrimVar tc bi
+ = lookupEnvBuiltin "replicatePD_PrimVar" (replicatePD_PrimVars bi) (tyConName tc)
+
+emptyPD_PrimVar :: TyCon -> Builtins -> Var
+emptyPD_PrimVar tc bi
+ = lookupEnvBuiltin "emptyPD_PrimVar" (emptyPD_PrimVars bi) (tyConName tc)
+
+packByTagPD_PrimVar :: TyCon -> Builtins -> Var
+packByTagPD_PrimVar tc bi
+ = lookupEnvBuiltin "packByTagPD_PrimVar" (packByTagPD_PrimVars bi) (tyConName tc)
+
combinePDVar :: Int -> Builtins -> Var
-combinePDVar = indexBuiltin "combinePDVar" combinePDVars
+combinePDVar = indexBuiltin "combinePDVar" combinePDVars
+
+combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var
+combinePD_PrimVar i tc bi
+ = lookupEnvBuiltin "combinePD_PrimVar"
+ (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc)
scalarZip :: Int -> Builtins -> Var
-scalarZip = indexBuiltin "scalarZip" scalarZips
+scalarZip = indexBuiltin "scalarZip" scalarZips
closureCtrFun :: Int -> Builtins -> Var
-closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
-
+closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
+
+-- Get an element from one of the arrays of `Builtins`. Panic if the indexed thing is not in the array.
+--
+indexBuiltin :: (Ix i, Outputable i)
+ => String -- ^ Name of the selector we've used, for panic messages.
+ -> (Builtins -> Array i a) -- ^ Field selector for the `Builtins`.
+ -> i -- ^ Index into the array.
+ -> Builtins
+ -> a
+indexBuiltin fn f i bi
+ | inRange (bounds xs) i = xs ! i
+ | otherwise
+ = pprSorry "Vectorise.Builtins.indexBuiltin"
+ (vcat [ text ""
+ , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <>
+ text "' is not yet implemented."
+ , text "This function does not appear in your source program, but it is needed"
+ , text "to compile your code in the backend. This is a known, current limitation"
+ , text "of DPH. If you want it to to work you should send mail to cvs-ghc@haskell.org"
+ , text "and ask what you can do to help (it might involve some GHC hacking)."])
+ where xs = f bi
+-- Get an entry from one of a 'NameEnv' of `Builtins`. Panic if the named item is not in the array.
+--
+lookupEnvBuiltin :: String -- Function name for error messages
+ -> NameEnv a -- Name environment
+ -> Name -- Index into the name environment
+ -> a
+lookupEnvBuiltin fn env n
+ | Just r <- lookupNameEnv env n = r
+ | otherwise
+ = pprSorry "Vectorise.Builtins.lookupEnvBuiltin"
+ (vcat [ text ""
+ , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <>
+ text "' is not yet implemented."
+ , text "This function does not appear in your source program, but it is needed"
+ , text "to compile your code in the backend. This is a known, current limitation"
+ , text "of DPH. If you want it to to work you should send mail to cvs-ghc@haskell.org"
+ , text "and ask what you can do to help (it might involve some GHC hacking)."])
diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
index ac7b580bbc..4f8361be82 100644
--- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
@@ -2,26 +2,22 @@
module Vectorise.Builtins.Initialise (
-- * Initialisation
- initBuiltins, initBuiltinVars, initBuiltinTyCons,
- initBuiltinPAs, initBuiltinPRs
+ initBuiltins, initBuiltinVars, initBuiltinTyCons
) where
import Vectorise.Builtins.Base
-import Vectorise.Builtins.Modules
import BasicTypes
import TysPrim
import DsMonad
-import IfaceEnv
-import InstEnv
import TysWiredIn
import DataCon
import TyCon
import Class
import CoreSyn
import Type
+import NameEnv
import Name
-import Module
import Id
import FastString
import Outputable
@@ -29,177 +25,137 @@ import Outputable
import Control.Monad
import Data.Array
+
-- |Create the initial map of builtin types and functions.
--
-initBuiltins :: PackageId -- ^ package id the builtins are in, eg dph-common
- -> DsM Builtins
-initBuiltins pkg
- = do mapM_ load dph_Orphans
-
- -- From dph-common:Data.Array.Parallel.PArray.PData
- -- PData is a type family that maps an element type onto the type
- -- we use to hold an array of those elements.
- pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData")
-
- -- PR is a type class that holds the primitive operators we can
- -- apply to array data. Its functions take arrays in terms of PData types.
- prClass <- externalClass dph_PArray_PData (fsLit "PR")
- let prTyCon = classTyCon prClass
- [prDataCon] = tyConDataCons prTyCon
-
-
- -- From dph-common:Data.Array.Parallel.PArray.PRepr
- preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr")
- paClass <- externalClass dph_PArray_PRepr (fsLit "PA")
- let paTyCon = classTyCon paClass
- [paDataCon] = tyConDataCons paTyCon
- paPRSel = classSCSelId paClass 0
-
- replicatePDVar <- externalVar dph_PArray_PRepr (fsLit "replicatePD")
- emptyPDVar <- externalVar dph_PArray_PRepr (fsLit "emptyPD")
- packByTagPDVar <- externalVar dph_PArray_PRepr (fsLit "packByTagPD")
- combines <- mapM (externalVar dph_PArray_PRepr)
- [mkFastString ("combine" ++ show i ++ "PD")
- | i <- [2..mAX_DPH_COMBINE]]
-
- let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
-
-
- -- From dph-common:Data.Array.Parallel.PArray.Scalar
- -- Scalar is the class of scalar values.
- -- The dictionary contains functions to coerce U.Arrays of scalars
- -- to and from the PData representation.
- scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar")
-
-
- -- From dph-common:Data.Array.Parallel.Lifted.PArray
- -- A PArray (Parallel Array) holds the array length and some array elements
- -- represented by the PData type family.
- parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray")
- let [parrayDataCon] = tyConDataCons parrayTyCon
-
- -- From dph-common:Data.Array.Parallel.PArray.Types
- voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void")
- voidVar <- externalVar dph_PArray_Types (fsLit "void")
- fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid")
- wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap")
- sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM)
-
- -- from dph-common:Data.Array.Parallel.PArray.PDataInstances
- pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid")
- punitVar <- externalVar dph_PArray_PDataInstances (fsLit "punit")
-
-
- closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
-
-
- -- From dph-common:Data.Array.Parallel.Lifted.Unboxed
- sel_tys <- mapM (externalType dph_Unboxed)
- (numbered "Sel" 2 mAX_DPH_SUM)
-
- sel_replicates <- mapM (externalFun dph_Unboxed)
- (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
-
- sel_picks <- mapM (externalFun dph_Unboxed)
- (numbered_hash "pickSel" 2 mAX_DPH_SUM)
-
- sel_tags <- mapM (externalFun dph_Unboxed)
- (numbered "tagsSel" 2 mAX_DPH_SUM)
-
- sel_els <- mapM mk_elements
- [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
-
-
- let selTys = listArray (2, mAX_DPH_SUM) sel_tys
- selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
- selPicks = listArray (2, mAX_DPH_SUM) sel_picks
- selTagss = listArray (2, mAX_DPH_SUM) sel_tags
- selEls = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els
- sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
-
-
-
- closureVar <- externalVar dph_Closure (fsLit "closure")
- applyVar <- externalVar dph_Closure (fsLit "$:")
- liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
- liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply")
-
- scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
- scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
- scalar_zips <- mapM (externalVar dph_Scalar)
- (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
-
- let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS)
- (scalar_map : scalar_zip2 : scalar_zips)
-
- closures <- mapM (externalVar dph_Closure)
- (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
-
- let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
-
- liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
- newUnique
-
- return $ Builtins
- { dphModules = mods
- , parrayTyCon = parrayTyCon
- , parrayDataCon = parrayDataCon
- , pdataTyCon = pdataTyCon
- , paClass = paClass
- , paTyCon = paTyCon
- , paDataCon = paDataCon
- , paPRSel = paPRSel
- , preprTyCon = preprTyCon
- , prClass = prClass
- , prTyCon = prTyCon
- , prDataCon = prDataCon
- , voidTyCon = voidTyCon
- , wrapTyCon = wrapTyCon
- , selTys = selTys
- , selReplicates = selReplicates
- , selPicks = selPicks
- , selTagss = selTagss
- , selEls = selEls
- , sumTyCons = sumTyCons
- , closureTyCon = closureTyCon
- , voidVar = voidVar
- , pvoidVar = pvoidVar
- , fromVoidVar = fromVoidVar
- , punitVar = punitVar
- , closureVar = closureVar
- , applyVar = applyVar
- , liftedClosureVar = liftedClosureVar
- , liftedApplyVar = liftedApplyVar
- , replicatePDVar = replicatePDVar
- , emptyPDVar = emptyPDVar
- , packByTagPDVar = packByTagPDVar
- , combinePDVars = combinePDVars
- , scalarClass = scalarClass
- , scalarZips = scalarZips
- , closureCtrFuns = closureCtrFuns
- , liftingContext = liftingContext
+initBuiltins :: DsM Builtins
+initBuiltins
+ = do { assertDAPPLoaded -- complain if 'Data.Array.Parallel.Prim' is not available
+
+ -- 'PArray': desugared array type
+ ; parrayTyCon <- externalTyCon (fsLit "PArray")
+ ; parray_tcs <- mapM externalTyCon (suffixed "PArray" aLL_DPH_PRIM_TYCONS)
+ ; let parray_PrimTyCons = mkNameEnv (zip aLL_DPH_PRIM_TYCONS parray_tcs)
+
+ -- 'PData': type family mapping array element types to array representation types
+ ; pdataTyCon <- externalTyCon (fsLit "PData")
+
+ -- 'PR': class of basic array operators operating on 'PData' types
+ ; prClass <- externalClass (fsLit "PR")
+ ; let prTyCon = classTyCon prClass
+
+ -- 'PRepr': type family mapping element types to representation types
+ ; preprTyCon <- externalTyCon (fsLit "PRepr")
+
+ -- 'PA': class of basic operations on arrays (parametrised by the element type)
+ ; paClass <- externalClass (fsLit "PA")
+ ; let paTyCon = classTyCon paClass
+ [paDataCon] = tyConDataCons paTyCon
+ paPRSel = classSCSelId paClass 0
+
+ -- Functions on array representations
+ ; replicatePDVar <- externalVar (fsLit "replicatePD")
+ ; replicate_vars <- mapM externalVar (suffixed "replicatePA" aLL_DPH_PRIM_TYCONS)
+ ; emptyPDVar <- externalVar (fsLit "emptyPD")
+ ; empty_vars <- mapM externalVar (suffixed "emptyPA" aLL_DPH_PRIM_TYCONS)
+ ; packByTagPDVar <- externalVar (fsLit "packByTagPD")
+ ; packByTag_vars <- mapM externalVar (suffixed "packByTagPA" aLL_DPH_PRIM_TYCONS)
+ ; let combineNamesD = [("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]]
+ ; let combineNamesA = [("combine" ++ show i ++ "PA") | i <- [2..mAX_DPH_COMBINE]]
+ ; combines <- mapM externalVar (map mkFastString combineNamesD)
+ ; combines_vars <- mapM (mapM externalVar) $
+ map (\name -> suffixed name aLL_DPH_PRIM_TYCONS) combineNamesA
+ ; let replicatePD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS replicate_vars)
+ emptyPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS empty_vars)
+ packByTagPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS packByTag_vars)
+ combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
+ combinePD_PrimVarss = listArray (2, mAX_DPH_COMBINE)
+ [ mkNameEnv (zip aLL_DPH_PRIM_TYCONS vars)
+ | vars <- combines_vars]
+
+ -- 'Scalar': class moving between plain unboxed arrays and 'PData' representations
+ ; scalarClass <- externalClass (fsLit "Scalar")
+
+ -- N-ary maps ('zipWith' family)
+ ; scalar_map <- externalVar (fsLit "scalar_map")
+ ; scalar_zip2 <- externalVar (fsLit "scalar_zipWith")
+ ; scalar_zips <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
+ ; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips)
+
+ -- Types and functions for generic type representations
+ ; voidTyCon <- externalTyCon (fsLit "Void")
+ ; voidVar <- externalVar (fsLit "void")
+ ; fromVoidVar <- externalVar (fsLit "fromVoid")
+ ; sum_tcs <- mapM externalTyCon (numbered "Sum" 2 mAX_DPH_SUM)
+ ; let sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
+ ; wrapTyCon <- externalTyCon (fsLit "Wrap")
+ ; pvoidVar <- externalVar (fsLit "pvoid")
+
+ -- Types and functions for closure conversion
+ ; closureTyCon <- externalTyCon (fsLit ":->")
+ ; closureVar <- externalVar (fsLit "closure")
+ ; liftedClosureVar <- externalVar (fsLit "liftedClosure")
+ ; applyVar <- externalVar (fsLit "$:")
+ ; liftedApplyVar <- externalVar (fsLit "liftedApply")
+ ; closures <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
+ ; let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
+
+ -- Types and functions for selectors
+ ; sel_tys <- mapM externalType (numbered "Sel" 2 mAX_DPH_SUM)
+ ; sel_replicates <- mapM externalFun (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
+ ; sel_tags <- mapM externalFun (numbered "tagsSel" 2 mAX_DPH_SUM)
+ ; sel_elements <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
+ ; let selTys = listArray (2, mAX_DPH_SUM) sel_tys
+ selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
+ selTagss = listArray (2, mAX_DPH_SUM) sel_tags
+ selElementss = array ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements
+
+ -- Distinct local variable
+ ; liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique
+
+ ; return $ Builtins
+ { parrayTyCon = parrayTyCon
+ , parray_PrimTyCons = parray_PrimTyCons
+ , pdataTyCon = pdataTyCon
+ , preprTyCon = preprTyCon
+ , prClass = prClass
+ , prTyCon = prTyCon
+ , paClass = paClass
+ , paTyCon = paTyCon
+ , paDataCon = paDataCon
+ , paPRSel = paPRSel
+ , replicatePDVar = replicatePDVar
+ , replicatePD_PrimVars = replicatePD_PrimVars
+ , emptyPDVar = emptyPDVar
+ , emptyPD_PrimVars = emptyPD_PrimVars
+ , packByTagPDVar = packByTagPDVar
+ , packByTagPD_PrimVars = packByTagPD_PrimVars
+ , combinePDVars = combinePDVars
+ , combinePD_PrimVarss = combinePD_PrimVarss
+ , scalarClass = scalarClass
+ , scalarZips = scalarZips
+ , voidTyCon = voidTyCon
+ , voidVar = voidVar
+ , fromVoidVar = fromVoidVar
+ , sumTyCons = sumTyCons
+ , wrapTyCon = wrapTyCon
+ , pvoidVar = pvoidVar
+ , closureTyCon = closureTyCon
+ , closureVar = closureVar
+ , liftedClosureVar = liftedClosureVar
+ , applyVar = applyVar
+ , liftedApplyVar = liftedApplyVar
+ , closureCtrFuns = closureCtrFuns
+ , selTys = selTys
+ , selReplicates = selReplicates
+ , selTagss = selTagss
+ , selElementss = selElementss
+ , liftingContext = liftingContext
}
+ }
where
- -- Extract out all the modules we'll use.
- -- These are the modules from the DPH base library that contain
- -- the primitive array types and functions that vectorised code uses.
- mods@(Modules
- { dph_PArray_Base = dph_PArray_Base
- , dph_PArray_Scalar = dph_PArray_Scalar
- , dph_PArray_PRepr = dph_PArray_PRepr
- , dph_PArray_PData = dph_PArray_PData
- , dph_PArray_PDataInstances = dph_PArray_PDataInstances
- , dph_PArray_Types = dph_PArray_Types
- , dph_Closure = dph_Closure
- , dph_Scalar = dph_Scalar
- , dph_Unboxed = dph_Unboxed
- })
- = dph_Modules pkg
-
- load get_mod = dsLoadModule doc mod
- where
- mod = get_mod mods
- doc = ppr mod <+> ptext (sLit "is a DPH module")
+ suffixed :: String -> [Name] -> [FastString]
+ suffixed pfx ns = [mkFastString (pfx ++ "_" ++ (occNameString . nameOccName) n) | n <- ns]
-- Make a list of numbered strings in some range, eg foo3, foo4, foo5
numbered :: String -> Int -> Int -> [FastString]
@@ -210,33 +166,33 @@ initBuiltins pkg
mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
mk_elements (i,j)
- = do
- v <- externalVar dph_Unboxed
- $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
- return ((i,j), Var v)
+ = do { v <- externalVar $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
+ ; return ((i, j), Var v)
+ }
--- | Get the mapping of names in the Prelude to names in the DPH library.
+-- |Get the mapping of names in the Prelude to names in the DPH library.
--
initBuiltinVars :: Builtins -> DsM [(Var, Var)]
-initBuiltinVars (Builtins { dphModules = mods })
+-- FIXME: must be replaced by VECTORISE pragmas!!!
+initBuiltinVars (Builtins { })
= do
- cvars <- zipWithM externalVar cmods cfs
+ cvars <- mapM externalVar cfs
return $ zip (map dataConWorkId cons) cvars
where
- (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
+ (cons, cfs) = unzip preludeDataCons
- preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
- preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
- = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
+ preludeDataCons :: [(DataCon, FastString)]
+ preludeDataCons
+ = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..3]]
where
- mk_tup n mod name = (tupleCon BoxedTuple n, mod, name)
+ mk_tup n name = (tupleCon BoxedTuple n, name)
-- |Get a list of names to `TyCon`s in the mock prelude.
--
initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
+-- FIXME: must be replaced by VECTORISE pragmas!!!
initBuiltinTyCons bi
= do
- -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
return $ (tyConName funTyCon, closureTyCon bi)
: (parrTyConName, parrayTyCon bi)
@@ -244,57 +200,39 @@ initBuiltinTyCons bi
: (tyConName $ parrayTyCon bi, parrayTyCon bi)
: []
--- |Get the names of all buildin instance functions for the PA class.
---
-initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
-initBuiltinPAs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA"))
-
--- |Get the names of all builtin instance functions for the PR class.
---
-initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
-initBuiltinPRs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR"))
-
--- |Get the names of all DPH instance functions for this class.
---
-initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
-initBuiltinDicts insts cls = map find $ classInstances insts cls
- where
- find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
- | otherwise = pprPanic "Invalid DPH instance" (ppr i)
-
-- Auxilliary look up functions ----------------
--- Lookup some variable given its name and the module that contains it.
+-- Lookup a variable given its name and the module that contains it.
--
-externalVar :: Module -> FastString -> DsM Var
-externalVar mod fs
- = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
+externalVar :: FastString -> DsM Var
+externalVar fs = lookupDAPPRdrEnv (mkVarOccFS fs) >>= dsImportId
-- Like `externalVar` but wrap the `Var` in a `CoreExpr`.
--
-externalFun :: Module -> FastString -> DsM CoreExpr
-externalFun mod fs
- = do var <- externalVar mod fs
- return $ Var var
+externalFun :: FastString -> DsM CoreExpr
+externalFun fs = liftM Var $ externalVar fs
--- Lookup some `TyCon` given its name and the module that contains it.
+-- Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name.
--
-externalTyCon :: Module -> FastString -> DsM TyCon
-externalTyCon mod fs
- = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
+externalTyCon :: FastString -> DsM TyCon
+externalTyCon fs = lookupDAPPRdrEnv (mkTcOccFS fs) >>= dsImportTyCon
-- Lookup some `Type` given its name and the module that contains it.
--
-externalType :: Module -> FastString -> DsM Type
-externalType mod fs
- = do tycon <- externalTyCon mod fs
+externalType :: FastString -> DsM Type
+externalType fs
+ = do tycon <- externalTyCon fs
return $ mkTyConApp tycon []
--- Lookup some `Class` given its name and the module that contains it.
+-- Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name.
--
-externalClass :: Module -> FastString -> DsM Class
-externalClass mod fs
- = fmap (maybe (panic "externalClass") id . tyConClass_maybe) $ dsLookupTyCon =<< lookupOrig mod (mkClsOccFS fs)
+externalClass :: FastString -> DsM Class
+externalClass fs
+ = do { tycon <- lookupDAPPRdrEnv (mkClsOccFS fs) >>= dsImportTyCon
+ ; case tyConClass_maybe tycon of
+ Nothing -> pprPanic "Vectorise.Builtins.Initialise" $
+ ptext (sLit "Data.Array.Parallel.Prim.") <>
+ ftext fs <+> ptext (sLit "is not a type class")
+ Just cls -> return cls
+ }
diff --git a/compiler/vectorise/Vectorise/Builtins/Modules.hs b/compiler/vectorise/Vectorise/Builtins/Modules.hs
deleted file mode 100644
index af74f803bc..0000000000
--- a/compiler/vectorise/Vectorise/Builtins/Modules.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-
--- | Modules that contain builtin functions used by the vectoriser.
-module Vectorise.Builtins.Modules
- ( Modules(..)
- , dph_Modules
- , dph_Orphans)
-where
-import Module
-import FastString
-
--- | Ids of the modules that contain our DPH builtins.
-data Modules
- = Modules
- { dph_PArray_Base :: Module
- , dph_PArray_Scalar :: Module
- , dph_PArray_ScalarInstances :: Module
- , dph_PArray_PRepr :: Module
- , dph_PArray_PReprInstances :: Module
- , dph_PArray_PData :: Module
- , dph_PArray_PDataInstances :: Module
- , dph_PArray_Types :: Module
-
- , dph_Closure :: Module
- , dph_Unboxed :: Module
- , dph_Scalar :: Module
-
- , dph_Prelude_Tuple :: Module
- }
-
-
--- | The locations of builtins in the current DPH library.
-dph_Modules :: PackageId -> Modules
-dph_Modules pkg
- = Modules
- { dph_PArray_Base = mk (fsLit "Data.Array.Parallel.PArray.Base")
- , dph_PArray_Scalar = mk (fsLit "Data.Array.Parallel.PArray.Scalar")
- , dph_PArray_ScalarInstances = mk (fsLit "Data.Array.Parallel.PArray.ScalarInstances")
- , dph_PArray_PRepr = mk (fsLit "Data.Array.Parallel.PArray.PRepr")
- , dph_PArray_PReprInstances = mk (fsLit "Data.Array.Parallel.PArray.PReprInstances")
- , dph_PArray_PData = mk (fsLit "Data.Array.Parallel.PArray.PData")
- , dph_PArray_PDataInstances = mk (fsLit "Data.Array.Parallel.PArray.PDataInstances")
- , dph_PArray_Types = mk (fsLit "Data.Array.Parallel.PArray.Types")
-
- , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
- , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
- , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
-
- , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Tuple")
- }
- where mk = mkModule pkg . mkModuleNameFS
-
-
-dph_Orphans :: [Modules -> Module]
-dph_Orphans
- = [ dph_PArray_Scalar
- , dph_PArray_ScalarInstances
- , dph_PArray_PReprInstances
- , dph_PArray_PDataInstances
- , dph_Scalar
- ]
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index a7578e4307..465d58c54a 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -12,7 +12,7 @@ module Vectorise.Env (
setFamEnv,
extendFamEnv,
extendTyConsEnv,
- extendPAFunsEnv,
+ setPAFunsEnv,
setPRFunsEnv,
modVectInfo
) where
@@ -134,7 +134,7 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
, global_novect_vars = mkVarSet novects
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
- , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
+ , global_pa_funs = emptyNameEnv
, global_pr_funs = emptyNameEnv
, global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs
@@ -179,17 +179,15 @@ extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
extendTyConsEnv ps genv
= genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
--- |Extend the list of PA functions in an environment.
+-- |Set the list of PA functions in an environment.
--
-extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
-extendPAFunsEnv ps genv
- = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
+setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+setPAFunsEnv ps genv = genv { global_pa_funs = mkNameEnv ps }
-- |Set the list of PR functions in an environment.
--
setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
-setPRFunsEnv ps genv
- = genv { global_pr_funs = mkNameEnv ps }
+setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps }
-- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files).
-- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'. The outgoing one contains only the
@@ -197,13 +195,12 @@ setPRFunsEnv ps genv
-- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported
-- module.
--
-modVectInfo :: GlobalEnv -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo
-modVectInfo env tycons vectDecls info
+modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo
+modVectInfo env mg_ids mg_tyCons vectDecls info
= info
{ vectInfoVar = mk_env ids (global_vars env)
, vectInfoTyCon = mk_env tyCons (global_tycons env)
, vectInfoDataCon = mk_env dataCons (global_datacons env)
- , vectInfoPADFun = mk_env tyCons (global_pa_funs env)
, vectInfoScalarVars = global_scalar_vars env `minusVarSet` vectInfoScalarVars info
, vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info
}
@@ -211,10 +208,9 @@ modVectInfo env tycons vectDecls info
vectIds = [id | Vect id _ <- vectDecls]
vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls]
vectDataCons = concatMap tyConDataCons vectTypeTyCons
- ids = {- typeEnvIds tyenv ++ -} vectIds
- -- XXX: what Ids do you want here?
- tyCons = tycons ++ vectTypeTyCons
- dataCons = concatMap tyConDataCons tycons ++ vectDataCons
+ ids = mg_ids ++ vectIds
+ tyCons = mg_tyCons ++ vectTypeTyCons
+ dataCons = concatMap tyConDataCons mg_tyCons ++ vectDataCons
-- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv'
mk_env decls inspectedEnv
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index cef46fdb20..eaf0c1f183 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -1,4 +1,3 @@
-
module Vectorise.Monad (
module Vectorise.Monad.Base,
module Vectorise.Monad.Naming,
@@ -17,10 +16,6 @@ module Vectorise.Monad (
maybeCantVectoriseVarM,
dumpVar,
addGlobalScalar,
-
- -- * Primitives
- lookupPrimPArray,
- lookupPrimMethod
) where
import Vectorise.Monad.Base
@@ -31,22 +26,25 @@ import Vectorise.Monad.InstEnv
import Vectorise.Builtins
import Vectorise.Env
+import CoreSyn
+import DsMonad
import HscTypes hiding ( MonadThings(..) )
import DynFlags
import MonadUtils (liftIO)
-import TyCon
+import InstEnv
+import Class
import VarSet
import VarEnv
import Var
import Id
-import DsMonad
+import Name
import ErrUtils
import Outputable
-import FastString
import Control.Monad
import System.IO
+
-- |Run a vectorisation computation.
--
initV :: HscEnv
@@ -56,8 +54,7 @@ initV :: HscEnv
-> IO (Maybe (VectInfo, a))
initV hsc_env guts info thing_inside
= do {
- let type_env = typeEnvFromEntities [] (mg_tcs guts) (mg_clss guts) (mg_fam_insts guts)
- -- XXX should we try to get the Ids here?
+ let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_clss guts) (mg_fam_insts guts)
; (_, Just res) <- initDs hsc_env (mg_module guts)
(mg_rdr_env guts) type_env go
@@ -72,16 +69,15 @@ initV hsc_env guts info thing_inside
}
where
dumpIfVtTrace = dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_vt_trace
+
+ bindsToIds (NonRec v _) = [v]
+ bindsToIds (Rec binds) = map fst binds
+
+ ids = concatMap bindsToIds (mg_binds guts)
go
- = do { -- pick a DPH backend
- ; dflags <- getDOptsDs
- ; case dphPackageMaybe dflags of
- Nothing -> failWithDs $ ptext selectBackendErr
- Just pkg -> do {
-
- -- set up tables of builtin entities
- ; builtins <- initBuiltins pkg
+ = do { -- set up tables of builtin entities
+ ; builtins <- initBuiltins
; builtin_vars <- initBuiltinVars builtins
; builtin_tycons <- initBuiltinTyCons builtins
@@ -89,14 +85,14 @@ initV hsc_env guts info thing_inside
; 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
+ builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all available 'PA' and..
+ builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances
-- construct the initial global environment
; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside
; let genv = extendImportedVarsEnv builtin_vars
. extendTyConsEnv builtin_tycons
- . extendPAFunsEnv builtin_pas
+ . setPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
$ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
@@ -110,24 +106,37 @@ initV hsc_env guts info thing_inside
mkDumpDoc "Warning: vectorisation failure:" reason
; return Nothing
}
- } }
+ }
+
+ new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info
- new_info genv = modVectInfo genv (mg_tcs guts) (mg_vect_decls guts) info
+ -- For a given DPH class, produce a mapping from type constructor (in head position) to the instance
+ -- dfun for that type constructor and class. (DPH class instances cannot overlap in head
+ -- constructors.)
+ --
+ initClassDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
+ initClassDicts insts cls = map find $ classInstances insts cls
+ where
+ find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
+ | otherwise = pprPanic invalidInstance (ppr i)
+
+ invalidInstance = "Invalid DPH instance (overlapping in head constructor)"
- 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.
+
+-- |Lift a desugaring computation using the `Builtins` into the vectorisation monad.
+--
liftBuiltinDs :: (Builtins -> DsM a) -> VM a
liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
-
--- | Project something from the set of builtins.
+-- |Project something from the set of builtins.
+--
builtin :: (Builtins -> a) -> VM a
builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
-
--- | Lift a function using the `Builtins` into the vectorisation monad.
+-- |Lift a function using the `Builtins` into the vectorisation monad.
+--
builtins :: (a -> Builtins -> b) -> VM (a -> b)
builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
@@ -174,13 +183,3 @@ addGlobalScalar var
= do { traceVt "addGlobalScalar" (ppr var)
; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var}
}
-
-
--- Primitives -----------------------------------------------------------------
-
-lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
-lookupPrimPArray = liftBuiltinDs . primPArray
-
-lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
-lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
-
diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs
index 8dd0af743f..255a6c5857 100644
--- a/compiler/vectorise/Vectorise/Utils.hs
+++ b/compiler/vectorise/Vectorise/Utils.hs
@@ -72,44 +72,44 @@ isAnnTypeArg _ = False
-- |An empty array of the given type.
--
emptyPD :: Type -> VM CoreExpr
-emptyPD = paMethod emptyPDVar "emptyPD"
+emptyPD = paMethod emptyPDVar emptyPD_PrimVar
-- |Produce an array containing copies of a given element.
--
-replicatePD :: CoreExpr -- ^ Number of copies in the resulting array.
- -> CoreExpr -- ^ Value to replicate.
+replicatePD :: CoreExpr -- ^ Number of copies in the resulting array.
+ -> CoreExpr -- ^ Value to replicate.
-> VM CoreExpr
replicatePD len x
= liftM (`mkApps` [len,x])
- $ paMethod replicatePDVar "replicatePD" (exprType x)
+ $ paMethod replicatePDVar replicatePD_PrimVar (exprType x)
--- | Select some elements from an array that correspond to a particular tag value
---- and pack them into a new array.
--- eg packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2
--- ==> [:42, 50, 49:]
+-- |Select some elements from an array that correspond to a particular tag value and pack them into a new
+-- array.
--
-packByTagPD :: Type -- ^ Element type.
- -> CoreExpr -- ^ Source array.
- -> CoreExpr -- ^ Length of resulting array.
- -> CoreExpr -- ^ Tag values of elements in source array.
- -> CoreExpr -- ^ The tag value for the elements to select.
+-- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2
+-- > ==> [:42, 50, 49:]
+--
+packByTagPD :: Type -- ^ Element type.
+ -> CoreExpr -- ^ Source array.
+ -> CoreExpr -- ^ Length of resulting array.
+ -> CoreExpr -- ^ Tag values of elements in source array.
+ -> CoreExpr -- ^ The tag value for the elements to select.
-> VM CoreExpr
packByTagPD ty xs len tags t
= liftM (`mkApps` [xs, len, tags, t])
- (paMethod packByTagPDVar "packByTagPD" ty)
+ (paMethod packByTagPDVar packByTagPD_PrimVar ty)
--- | Combine some arrays based on a selector.
--- The selector says which source array to choose for each element of the
--- resulting array.
+-- |Combine some arrays based on a selector. The selector says which source array to choose for each
+-- element of the resulting array.
--
-combinePD :: Type -- ^ Element type
- -> CoreExpr -- ^ Length of resulting array
- -> CoreExpr -- ^ Selector.
- -> [CoreExpr] -- ^ Arrays to combine.
+combinePD :: Type -- ^ Element type
+ -> CoreExpr -- ^ Length of resulting array
+ -> CoreExpr -- ^ Selector.
+ -> [CoreExpr] -- ^ Arrays to combine.
-> VM CoreExpr
combinePD ty len sel xs
= liftM (`mkApps` (len : sel : xs))
- (paMethod (combinePDVar n) ("combine" ++ show n ++ "PD") ty)
+ (paMethod (combinePDVar n) (combinePD_PrimVar n) ty)
where
n = length xs
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index d41be1e87a..e87c7ca96f 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/compiler/vectorise/Vectorise/Utils/Base.hs
@@ -1,27 +1,26 @@
-
module Vectorise.Utils.Base (
- voidType,
- newLocalVVar,
-
- mkDataConTagLit,
- mkDataConTag, dataConTagZ,
- mkBuiltinTyConApp,
- mkBuiltinTyConApps,
- mkWrapType,
- mkClosureTypes,
- mkPReprType,
- mkPArrayType, splitPrimTyCon,
- mkPArray,
- mkPDataType,
- mkBuiltinCo,
- mkVScrut,
-
- preprSynTyCon,
- pdataReprTyCon,
- pdataReprDataCon,
- prDFunOfTyCon
-)
-where
+ voidType,
+ newLocalVVar,
+
+ mkDataConTagLit,
+ mkDataConTag, dataConTagZ,
+ mkBuiltinTyConApp,
+ mkBuiltinTyConApps,
+ mkWrapType,
+ mkClosureTypes,
+ mkPReprType,
+ mkPArrayType, splitPrimTyCon,
+ mkPArray,
+ mkPDataType,
+ mkBuiltinCo,
+ mkVScrut,
+
+ preprSynTyCon,
+ pdataReprTyCon,
+ pdataReprDataCon,
+ prDFunOfTyCon
+) where
+
import Vectorise.Monad
import Vectorise.Vect
import Vectorise.Builtins
@@ -96,24 +95,23 @@ mkPReprType :: Type -> VM Type
mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
------
+-- |Wrap a type into 'PArray', treating unboxed types specially.
+--
mkPArrayType :: Type -> VM Type
mkPArrayType ty
| Just tycon <- splitPrimTyCon ty
- = do
- r <- lookupPrimPArray tycon
- case r of
- Just arr -> return $ mkTyConApp arr []
- Nothing -> cantVectorise "Primitive tycon not vectorised" (ppr tycon)
-
+ = do { arr <- builtin (parray_PrimTyCon tycon)
+ ; return $ mkTyConApp arr []
+ }
mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
+-- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it.
+--
splitPrimTyCon :: Type -> Maybe TyCon
splitPrimTyCon ty
| Just (tycon, []) <- splitTyConApp_maybe ty
, isPrimTyCon tycon
= Just tycon
-
| otherwise = Nothing
diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs
index 443850d531..f3fe742aef 100644
--- a/compiler/vectorise/Vectorise/Utils/Closure.hs
+++ b/compiler/vectorise/Vectorise/Utils/Closure.hs
@@ -1,13 +1,14 @@
+-- |Utils concerning closure construction and application.
--- | Utils concerning closure construction and application.
module Vectorise.Utils.Closure (
- mkClosure,
- mkClosureApp,
- buildClosure,
- buildClosures,
- buildEnv
+ mkClosure,
+ mkClosureApp,
+ buildClosure,
+ buildClosures,
+ buildEnv
)
where
+
import Vectorise.Builtins
import Vectorise.Vect
import Vectorise.Monad
@@ -29,12 +30,12 @@ import FastString
-- | Make a closure.
mkClosure
- :: Type -- ^ Type of the argument.
- -> Type -- ^ Type of the result.
- -> Type -- ^ Type of the environment.
- -> VExpr -- ^ The function to apply.
- -> VExpr -- ^ The environment to use.
- -> VM VExpr
+ :: Type -- ^ Type of the argument.
+ -> Type -- ^ Type of the result.
+ -> Type -- ^ Type of the environment.
+ -> VExpr -- ^ The function to apply.
+ -> VExpr -- ^ The environment to use.
+ -> VM VExpr
mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
= do dict <- paDictOfType env_ty
@@ -46,11 +47,11 @@ mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
-- | Make a closure application.
mkClosureApp
- :: Type -- ^ Type of the argument.
- -> Type -- ^ Type of the result.
- -> VExpr -- ^ Closure to apply.
- -> VExpr -- ^ Argument to use.
- -> VM VExpr
+ :: Type -- ^ Type of the argument.
+ -> Type -- ^ Type of the result.
+ -> VExpr -- ^ Closure to apply.
+ -> VExpr -- ^ Argument to use.
+ -> VM VExpr
mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
= do vapply <- builtin applyVar
@@ -60,14 +61,13 @@ mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg])
-
buildClosures
- :: [TyVar]
- -> [VVar]
- -> [Type] -- ^ Type of the arguments.
- -> Type -- ^ Type of result.
- -> VM VExpr
- -> VM VExpr
+ :: [TyVar]
+ -> [VVar]
+ -> [Type] -- ^ Type of the arguments.
+ -> Type -- ^ Type of result.
+ -> VM VExpr
+ -> VM VExpr
buildClosures _ _ [] _ mk_body
= mk_body
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 740a647180..836a363b78 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -1,12 +1,11 @@
-
module Vectorise.Utils.PADict (
- paDictArgType,
- paDictOfType,
- paMethod,
- prDictOfReprType,
- prDictOfPReprInstTyCon
-)
-where
+ paDictArgType,
+ paDictOfType,
+ paMethod,
+ prDictOfReprType,
+ prDictOfPReprInstTyCon
+) where
+
import Vectorise.Monad
import Vectorise.Builtins
import Vectorise.Utils.Base
@@ -23,7 +22,7 @@ import FastString
import Control.Monad
--- | Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's
+-- |Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's
-- just PA v. For (v :: (* -> *) -> *) it's
--
-- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a)
@@ -50,7 +49,7 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
go _ _ = return Nothing
--- | Get the PA dictionary for some type
+-- |Get the PA dictionary for some type
--
paDictOfType :: Type -> VM CoreExpr
paDictOfType ty
@@ -86,13 +85,12 @@ paDictOfType ty
failure = cantVectorise "Can't construct PA dictionary for type" (ppr ty)
-paMethod :: (Builtins -> Var) -> String -> Type -> VM CoreExpr
-paMethod _ name ty
- | Just tycon <- splitPrimTyCon ty
- = liftM Var
- . maybeCantVectoriseM "No PA method" (text name <+> text "for" <+> ppr tycon)
- $ lookupPrimMethod tycon name
-
+-- |Produce code that refers to a method of the 'PA' class.
+--
+paMethod :: (Builtins -> Var) -> (TyCon -> Builtins -> Var) -> Type -> VM CoreExpr
+paMethod _ query ty
+ | Just tycon <- splitPrimTyCon ty -- Is 'ty' from 'GHC.Prim' (e.g., 'Int#')?
+ = liftM Var $ builtin (query tycon)
paMethod method _ ty
= do
fn <- builtin method