X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=ea0cd6357b1f89f7e75599765e06d7bef3139415;hp=bc9c9eef8ffeeeb8e44456bb7e027791418ec884;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=e95ee1f718c6915c478005aad8af81705357d6ab diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index bc9c9ee..ea0cd63 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -6,29 +6,15 @@ \begin{code} -- | Types for the per-module compiler module HscTypes ( - -- * 'Ghc' monad stuff - Ghc(..), GhcT(..), liftGhcT, - GhcMonad(..), WarnLogMonad(..), - liftIO, - ioMsgMaybe, ioMsg, - logWarnings, clearWarnings, hasWarnings, - SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, - throwOneError, handleSourceError, - reflectGhc, reifyGhc, - handleFlagWarnings, - - -- * Sessions and compilation state - Session(..), withSession, modifySession, withTempSession, + -- * compilation state HscEnv(..), hscEPS, FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, - -- ** Callbacks - GhcApiCallbacks(..), withLocalCallbacks, -- * Information about modules ModDetails(..), emptyModDetails, - ModGuts(..), CoreModule(..), CgGuts(..), ForeignStubs(..), + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ModSummary(..), ms_mod_name, showModMsg, isBootSummary, @@ -39,8 +25,9 @@ module HscTypes ( -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, hptVectInfo, - + hptInstances, hptRules, hptVectInfo, + hptObjs, + -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -67,13 +54,13 @@ module HscTypes ( -- * TyThings and type environments TyThing(..), - tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, - implicitTyThings, isImplicitTyThing, + tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom, + implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing, TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, - typeEnvDataCons, + typeEnvDataCons, typeEnvCoAxioms, -- * MonadThings MonadThings(..), @@ -90,7 +77,7 @@ module HscTypes ( Warnings(..), WarningTxt(..), plusWarns, -- * Linker stuff - Linkable(..), isObjectLinkable, + Linkable(..), isObjectLinkable, linkableObjs, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, @@ -102,13 +89,18 @@ module HscTypes ( -- * Vectorisation information VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, - noIfaceVectInfo + noIfaceVectInfo, + + -- * Compilation errors and warnings + SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, + throwOneError, handleSourceError, + handleFlagWarnings, printOrThrowWarnings, ) where #include "HsVersions.h" #ifdef GHCI -import ByteCodeAsm ( CompiledByteCode ) +import ByteCodeAsm ( CompiledByteCode ) import {-# SOURCE #-} InteractiveEval ( Resume ) #endif @@ -116,17 +108,17 @@ import HsSyn import RdrName import Name import NameEnv -import NameSet +import NameSet import Module -import InstEnv ( InstEnv, Instance ) -import FamInstEnv ( FamInstEnv, FamInst ) -import Rules ( RuleBase ) -import CoreSyn ( CoreBind ) +import InstEnv ( InstEnv, Instance ) +import FamInstEnv ( FamInstEnv, FamInst ) +import Rules ( RuleBase ) +import CoreSyn ( CoreBind ) import VarEnv import VarSet import Var import Id -import Type +import Type import Annotations import Class ( Class, classAllSelIds, classATs, classTyCon ) @@ -140,11 +132,11 @@ import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) import IfaceSyn -import CoreSyn ( CoreRule ) +import CoreSyn ( CoreRule, CoreVect ) import Maybes ( orElse, expectJust, catMaybes ) import Outputable import BreakArray -import SrcLoc ( SrcSpan, Located(..) ) +import SrcLoc import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString @@ -164,22 +156,12 @@ import Data.List import Data.Map (Map) import Control.Monad ( mplus, guard, liftM, when ) import Exception -\end{code} - - -%************************************************************************ -%* * -\subsection{Compilation environment} -%* * -%************************************************************************ +-- ----------------------------------------------------------------------------- +-- Source Errors -\begin{code} --- | The Session is a handle to the complete state of a compilation --- session. A compilation session consists of a set of modules --- constituting the current program or library, the context for --- interactive evaluation, and various caches. -data Session = Session !(IORef HscEnv) !(IORef WarningMessages) +-- When the compiler (HscMain) discovers errors, it throws an +-- exception in the IO monad. mkSrcErr :: ErrorMessages -> SourceError srcErrorMessages :: SourceError -> ErrorMessages @@ -247,255 +229,25 @@ instance Exception GhcApiError mkApiErr = GhcApiError --- | A monad that allows logging of warnings. -class Monad m => WarnLogMonad m where - setWarnings :: WarningMessages -> m () - getWarnings :: m WarningMessages - -logWarnings :: WarnLogMonad m => WarningMessages -> m () -logWarnings warns = do - warns0 <- getWarnings - setWarnings (unionBags warns warns0) - --- | Clear the log of 'Warnings'. -clearWarnings :: WarnLogMonad m => m () -clearWarnings = setWarnings emptyBag - --- | Returns true if there were any warnings. -hasWarnings :: WarnLogMonad m => m Bool -hasWarnings = getWarnings >>= return . not . isEmptyBag - --- | A monad that has all the features needed by GHC API calls. --- --- In short, a GHC monad --- --- - allows embedding of IO actions, --- --- - can log warnings, --- --- - allows handling of (extensible) exceptions, and --- --- - maintains a current session. --- --- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' --- before any call to the GHC API functions can occur. --- -class (Functor m, MonadIO m, WarnLogMonad m, ExceptionMonad m) - => GhcMonad m where - getSession :: m HscEnv - setSession :: HscEnv -> m () - --- | Call the argument with the current session. -withSession :: GhcMonad m => (HscEnv -> m a) -> m a -withSession f = getSession >>= f - --- | Set the current session to the result of applying the current session to --- the argument. -modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () -modifySession f = do h <- getSession - setSession $! f h - -withSavedSession :: GhcMonad m => m a -> m a -withSavedSession m = do - saved_session <- getSession - m `gfinally` setSession saved_session - --- | Call an action with a temporarily modified Session. -withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a -withTempSession f m = - withSavedSession $ modifySession f >> m - --- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, --- e.g., to maintain additional state consider wrapping this monad or using --- 'GhcT'. -newtype Ghc a = Ghc { unGhc :: Session -> IO a } - -instance Functor Ghc where - fmap f m = Ghc $ \s -> f `fmap` unGhc m s - -instance Monad Ghc where - return a = Ghc $ \_ -> return a - m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s - -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA - -instance ExceptionMonad Ghc where - gcatch act handle = - Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s - gblock (Ghc m) = Ghc $ \s -> gblock (m s) - gunblock (Ghc m) = Ghc $ \s -> gunblock (m s) - gmask f = - Ghc $ \s -> gmask $ \io_restore -> - let - g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) - in - unGhc (f g_restore) s - -instance WarnLogMonad Ghc where - setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns - -- | Return 'Warnings' accumulated so far. - getWarnings = Ghc $ \(Session _ wref) -> readIORef wref - -instance GhcMonad Ghc where - getSession = Ghc $ \(Session r _) -> readIORef r - setSession s' = Ghc $ \(Session r _) -> writeIORef r s' - --- | A monad transformer to add GHC specific features to another monad. --- --- Note that the wrapped monad must support IO and handling of exceptions. -newtype GhcT m a = GhcT { unGhcT :: Session -> m a } -liftGhcT :: Monad m => m a -> GhcT m a -liftGhcT m = GhcT $ \_ -> m - -instance Functor m => Functor (GhcT m) where - fmap f m = GhcT $ \s -> f `fmap` unGhcT m s - -instance Monad m => Monad (GhcT m) where - return x = GhcT $ \_ -> return x - m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s - -instance MonadIO m => MonadIO (GhcT m) where - liftIO ioA = GhcT $ \_ -> liftIO ioA - -instance ExceptionMonad m => ExceptionMonad (GhcT m) where - gcatch act handle = - GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s - gblock (GhcT m) = GhcT $ \s -> gblock (m s) - gunblock (GhcT m) = GhcT $ \s -> gunblock (m s) - gmask f = - GhcT $ \s -> gmask $ \io_restore -> - let - g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) - in - unGhcT (f g_restore) s - -instance MonadIO m => WarnLogMonad (GhcT m) where - setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns - -- | Return 'Warnings' accumulated so far. - getWarnings = GhcT $ \(Session _ wref) -> liftIO $ readIORef wref - -instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where - getSession = GhcT $ \(Session r _) -> liftIO $ readIORef r - setSession s' = GhcT $ \(Session r _) -> liftIO $ writeIORef r s' - --- | Lift an IO action returning errors messages into a 'GhcMonad'. --- --- In order to reduce dependencies to other parts of the compiler, functions --- outside the "main" parts of GHC return warnings and errors as a parameter --- and signal success via by wrapping the result in a 'Maybe' type. This --- function logs the returned warnings and propagates errors as exceptions --- (of type 'SourceError'). --- --- This function assumes the following invariants: --- --- 1. If the second result indicates success (is of the form 'Just x'), --- there must be no error messages in the first result. --- --- 2. If there are no error messages, but the second result indicates failure --- there should be warnings in the first result. That is, if the action --- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: GhcMonad m => - IO (Messages, Maybe a) -> m a -ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO ioA - logWarnings warns - case mb_r of - Nothing -> liftIO $ throwIO (mkSrcErr errs) - Just r -> ASSERT( isEmptyBag errs ) return r - --- | Lift a non-failing IO action into a 'GhcMonad'. --- --- Like 'ioMsgMaybe', but assumes that the action will never return any error --- messages. -ioMsg :: GhcMonad m => IO (Messages, a) -> m a -ioMsg ioA = do - ((warns,errs), r) <- liftIO ioA - logWarnings warns - ASSERT( isEmptyBag errs ) return r - --- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. --- --- You can use this to call functions returning an action in the 'Ghc' monad --- inside an 'IO' action. This is needed for some (too restrictive) callback --- arguments of some library functions: --- --- > libFunc :: String -> (Int -> IO a) -> IO a --- > ghcFunc :: Int -> Ghc a --- > --- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a --- > ghcFuncUsingLibFunc str = --- > reifyGhc $ \s -> --- > libFunc $ \i -> do --- > reflectGhc (ghcFunc i) s --- -reflectGhc :: Ghc a -> Session -> IO a -reflectGhc m = unGhc m - --- > Dual to 'reflectGhc'. See its documentation. -reifyGhc :: (Session -> IO a) -> Ghc a -reifyGhc act = Ghc $ act +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns + | dopt Opt_WarnIsError dflags + = when (not (isEmptyBag warns)) $ do + throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg + | otherwise + = printBagOfWarnings dflags warns -handleFlagWarnings :: GhcMonad m => DynFlags -> [Located String] -> m () +handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns - = when (dopt Opt_WarnDeprecatedFlags dflags) - (handleFlagWarnings' dflags warns) - -handleFlagWarnings' :: GhcMonad m => DynFlags -> [Located String] -> m () -handleFlagWarnings' _ [] = return () -handleFlagWarnings' dflags warns - = do -- It would be nicer if warns :: [Located Message], but that has circular - -- import problems. - logWarnings $ listToBag (map mkFlagWarning warns) - when (dopt Opt_WarnIsError dflags) $ - liftIO $ throwIO $ mkSrcErr emptyBag - -mkFlagWarning :: Located String -> WarnMsg -mkFlagWarning (L loc warn) - = mkPlainWarnMsg loc (text warn) -\end{code} - -\begin{code} --- | These functions are called in various places of the GHC API. --- --- API clients can override any of these callbacks to change GHC's default --- behaviour. -data GhcApiCallbacks - = GhcApiCallbacks { - - -- | Called by 'load' after the compilating of each module. - -- - -- The default implementation simply prints all warnings and errors to - -- @stderr@. Don't forget to call 'clearWarnings' when implementing your - -- own call. - -- - -- The first argument is the module that was compiled. - -- - -- The second argument is @Nothing@ if no errors occured, but there may - -- have been warnings. If it is @Just err@ at least one error has - -- occured. If 'srcErrorMessages' is empty, compilation failed due to - -- @-Werror@. - reportModuleCompilationResult :: GhcMonad m => - ModSummary -> Maybe SourceError - -> m () - } - --- | Temporarily modify the callbacks. After the action is executed all --- callbacks are reset (not, however, any other modifications to the session --- state.) -withLocalCallbacks :: GhcMonad m => - (GhcApiCallbacks -> GhcApiCallbacks) - -> m a -> m a -withLocalCallbacks f m = do - hsc_env <- getSession - let cb0 = hsc_callbacks hsc_env - let cb' = f cb0 - setSession (hsc_env { hsc_callbacks = cb' `seq` cb' }) - r <- m - hsc_env' <- getSession - setSession (hsc_env' { hsc_callbacks = cb0 }) - return r + = when (dopt Opt_WarnDeprecatedFlags dflags) $ do + -- It would be nicer if warns :: [Located Message], but that + -- has circular import problems. + let bag = listToBag [ mkPlainWarnMsg loc (text warn) + | L loc warn <- warns ] + printOrThrowWarnings dflags bag \end{code} \begin{code} @@ -514,9 +266,6 @@ data HscEnv hsc_dflags :: DynFlags, -- ^ The dynamic flag settings - hsc_callbacks :: GhcApiCallbacks, - -- ^ Callbacks for the GHC API. - hsc_targets :: [Target], -- ^ The targets (or roots) of the current session @@ -567,21 +316,10 @@ data HscEnv -- by limiting the number of transformations, -- we can use binary search to help find compiler bugs. - hsc_type_env_var :: Maybe (Module, IORef TypeEnv), + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) -- ^ Used for one-shot compilation only, to initialise -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRunTypes.TcGblEnv' - - hsc_global_rdr_env :: GlobalRdrEnv, - -- ^ A mapping from 'RdrName's that are in global scope during - -- the compilation of the current file to more detailed - -- information about those names. Not necessarily just the - -- names directly imported by the module being compiled! - - hsc_global_type_env :: TypeEnv - -- ^ Typing information about all those things in global scope. - -- Not necessarily just the things directly imported by the module - -- being compiled! } hscEPS :: HscEnv -> IO ExternalPackageState @@ -758,6 +496,9 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- And get its dfuns , thing <- things ] + +hptObjs :: HomePackageTable -> [FilePath] +hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) \end{code} %************************************************************************ @@ -811,14 +552,22 @@ data FindResult -- ^ The requested package was not found | FoundMultiple [PackageId] -- ^ _Error_: both in multiple packages - | NotFound [FilePath] (Maybe PackageId) [PackageId] [PackageId] - -- ^ The module was not found, including either - -- * the specified places were searched - -- * the package that this module should have been in - -- * list of packages in which the module was hidden, - -- * list of hidden packages containing this module - | NotFoundInPackage PackageId - -- ^ The module was not found in this package + + | NotFound -- Not found + { fr_paths :: [FilePath] -- Places where I looked + + , fr_pkg :: Maybe PackageId -- Just p => module is in this package's + -- manifest, but couldn't find + -- the .hi file + + , fr_mods_hidden :: [PackageId] -- Module is in these packages, + -- but the *module* is hidden + + , fr_pkgs_hidden :: [PackageId] -- Module is in these packages, + -- but the *package* is hidden + + , fr_suggestions :: [Module] -- Possible mis-spelled modules + } -- | Cache that remembers where we found a particular module. Contains both -- home modules and package modules. On @:load@, only home modules are @@ -969,7 +718,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)] -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module -- being compiled right now. Once it is compiled, a 'ModIface' and --- 'ModDetails' are extracted and the ModGuts is dicarded. +-- 'ModDetails' are extracted and the ModGuts is discarded. data ModGuts = ModGuts { mg_module :: !Module, -- ^ Module being compiled @@ -994,9 +743,11 @@ data ModGuts mg_binds :: ![CoreBind], -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_warns :: !Warnings, -- ^ Warnings declared in the module - mg_anns :: [Annotation], -- ^ Annotations declared in this module - mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module + mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module + -- (produced by desugarer & consumed by vectoriser) mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module -- The next two fields are unusual, because they give instance @@ -1018,24 +769,6 @@ data ModGuts -- mg_rules Orphan rules only (local ones now attached to binds) -- mg_binds With rules attached --- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for --- the 'GHC.compileToCoreModule' interface. -data CoreModule - = CoreModule { - -- | Module name - cm_module :: !Module, - -- | Type environment for types declared in this module - cm_types :: !TypeEnv, - -- | Declarations - cm_binds :: [CoreBind], - -- | Imports - cm_imports :: ![Module] - } - -instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = - text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) - -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly: @@ -1067,11 +800,7 @@ data CgGuts -- data constructor workers; reason: we we regard them -- as part of the code-gen of tycons - cg_dir_imps :: ![Module], - -- ^ Directly-imported modules; used to generate - -- initialisation code - - cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information @@ -1091,6 +820,10 @@ data ForeignStubs = NoStubs -- ^ We don't have any stubs -- -- 2) C stubs to use when calling -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) \end{code} \begin{code} @@ -1131,42 +864,49 @@ emptyModIface mod %************************************************************************ \begin{code} --- | Interactive context, recording information relevant to GHCi +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHC session. +-- data InteractiveContext = InteractiveContext { - ic_toplev_scope :: [Module], -- ^ The context includes the "top-level" scope of - -- these modules - - ic_exports :: [(Module, Maybe (ImportDecl RdrName))], -- ^ The context includes just the exported parts of these - -- modules - - ic_rn_gbl_env :: GlobalRdrEnv, -- ^ The contexts' cached 'GlobalRdrEnv', built from - -- 'ic_toplev_scope' and 'ic_exports' - - ic_tmp_ids :: [Id], -- ^ Names bound during interaction with the user. - -- Later Ids shadow earlier ones with the same OccName. - - ic_tyvars :: TyVarSet -- ^ Skolem type variables free in - -- 'ic_tmp_ids'. These arise at - -- breakpoints in a polymorphic - -- context, where we have only partial - -- type information. + -- These two fields are only stored here so that the client + -- can retrieve them with GHC.getContext. GHC itself doesn't + -- use them, but it does reset them to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + ic_toplev_scope :: [Module], + -- ^ The context includes the "top-level" scope of + -- these modules + ic_imports :: [ImportDecl RdrName], + -- ^ The context is extended with these import declarations + + ic_rn_gbl_env :: GlobalRdrEnv, + -- ^ The contexts' cached 'GlobalRdrEnv', built by + -- 'InteractiveEval.setContext' + + ic_tmp_ids :: [Id], + -- ^ Names bound during interaction with the user. Later + -- Ids shadow earlier ones with the same OccName + -- Expressions are typed with these Ids in the envt For + -- runtime-debugging, these Ids may have free TcTyVars of + -- RuntimUnkSkol flavour, but no free TyVars (because the + -- typechecker doesn't expect that) #ifdef GHCI - , ic_resume :: [Resume] -- ^ The stack of breakpoint contexts + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts #endif - , ic_cwd :: Maybe FilePath -- virtual CWD of the program + ic_cwd :: Maybe FilePath + -- virtual CWD of the program } emptyInteractiveContext :: InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], - ic_exports = [], + ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, - ic_tmp_ids = [], - ic_tyvars = emptyVarSet + ic_tmp_ids = [] #ifdef GHCI , ic_resume = [] #endif @@ -1180,29 +920,20 @@ icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt) extendInteractiveContext :: InteractiveContext -> [Id] - -> TyVarSet -> InteractiveContext -extendInteractiveContext ictxt ids tyvars - = ictxt { ic_tmp_ids = snub((ic_tmp_ids ictxt \\ ids) ++ ids), +extendInteractiveContext ictxt ids + = ictxt { ic_tmp_ids = snub ((ic_tmp_ids ictxt \\ ids) ++ ids) -- NB. must be this way around, because we want -- new ids to shadow existing bindings. - ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars } + } where snub = map head . group . sort substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt -substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst = - let ids' = map (\id -> id `setIdType` substTy subst (idType id)) ids - subst_dom= varEnvKeys$ getTvSubstEnv subst - subst_ran= varEnvElts$ getTvSubstEnv subst - new_tvs = [ tv | Just tv <- map getTyVar_maybe subst_ran] - ic_tyvars'= (`delVarSetListByKey` subst_dom) - . (`extendVarSetList` new_tvs) - $ ic_tyvars ictxt - in ictxt { ic_tmp_ids = ids' - , ic_tyvars = ic_tyvars' } - - where delVarSetListByKey = foldl' delVarSetByKey +substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst + = ictxt { ic_tmp_ids = map subst_ty ids } + where + subst_ty id = id `setIdType` substTy subst (idType id) \end{code} %************************************************************************ @@ -1307,19 +1038,18 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. implicitTyThings :: TyThing -> [TyThing] - --- For data and newtype declarations: -implicitTyThings (ATyCon tc) - = -- fields (names of selectors) - -- (possibly) implicit coercion and family coercion - -- depending on whether it's a newtype or a family instance or both - implicitCoTyCon tc ++ - -- for each data constructor in order, - -- the contructor, worker, and (possibly) wrapper - concatMap (extras_plus . ADataCon) (tyConDataCons tc) - -implicitTyThings (AClass cl) - = -- dictionary datatype: +implicitTyThings (AnId _) = [] +implicitTyThings (ACoAxiom _cc) = [] +implicitTyThings (ATyCon tc) = implicitTyConThings tc +implicitTyThings (AClass cl) = implicitClassThings cl +implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) + -- For data cons add the worker and (possibly) wrapper + +implicitClassThings :: Class -> [TyThing] +implicitClassThings cl + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + -- Dictionary datatype: -- [extras_plus:] -- type constructor -- [recursive call:] @@ -1335,11 +1065,16 @@ implicitTyThings (AClass cl) -- superclass and operation selectors map AnId (classAllSelIds cl) -implicitTyThings (ADataCon dc) = - -- For data cons add the worker and (possibly) wrapper - map AnId (dataConImplicitIds dc) +implicitTyConThings :: TyCon -> [TyThing] +implicitTyConThings tc + = -- fields (names of selectors) + -- (possibly) implicit coercion and family coercion + -- depending on whether it's a newtype or a family instance or both + implicitCoTyCon tc ++ + -- for each data constructor in order, + -- the contructor, worker, and (possibly) wrapper + concatMap (extras_plus . ADataCon) (tyConDataCons tc) -implicitTyThings (AnId _) = [] -- add a thing and recursive call extras_plus :: TyThing -> [TyThing] @@ -1349,10 +1084,10 @@ extras_plus thing = thing : implicitTyThings thing -- add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc - = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not - newTyConCo_maybe 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) @@ -1362,10 +1097,11 @@ implicitCoTyCon tc -- of some other declaration, or it is generated implicitly by some -- other declaration. isImplicitTyThing :: TyThing -> Bool -isImplicitTyThing (ADataCon _) = True -isImplicitTyThing (AnId id) = isImplicitId id -isImplicitTyThing (AClass _) = False -isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ADataCon {}) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (AClass {}) = False +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom {}) = True extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids @@ -1387,6 +1123,7 @@ emptyTypeEnv :: TypeEnv typeEnvElts :: TypeEnv -> [TyThing] typeEnvClasses :: TypeEnv -> [Class] typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom] typeEnvIds :: TypeEnv -> [Id] typeEnvDataCons :: TypeEnv -> [DataCon] lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing @@ -1395,6 +1132,7 @@ emptyTypeEnv = emptyNameEnv typeEnvElts env = nameEnvElts env typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] @@ -1450,6 +1188,11 @@ tyThingTyCon :: TyThing -> TyCon tyThingTyCon (ATyCon tc) = tc 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) + -- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise tyThingClass :: TyThing -> Class tyThingClass (AClass cls) = cls @@ -1980,9 +1723,9 @@ isHpcUsed (NoHpcInfo { hpcUsed = used }) = used \end{code} %************************************************************************ -%* * +%* * \subsection{Vectorisation Support} -%* * +%* * %************************************************************************ The following information is generated and consumed by the vectorisation @@ -1995,49 +1738,58 @@ vectorisation, we need to know `f_v', whose `Var' we cannot lookup based on just the OccName easily in a Core pass. \begin{code} --- | Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'. +-- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also +-- documentation at 'Vectorise.Env.GlobalEnv'. data VectInfo - = 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@ + = 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 } --- | Vectorisation information for 'ModIface': a slightly less low-level view +-- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated +-- across module boundaries. +-- data IfaceVectInfo - = IfaceVectInfo { - ifaceVectInfoVar :: [Name], - -- ^ All variables in here have a vectorised variant - ifaceVectInfoTyCon :: [Name], - -- ^ All 'TyCon's in here have a vectorised variant; - -- the name of the vectorised variant and those of its - -- data constructors are determined by 'OccName.mkVectTyConOcc' - -- and 'OccName.mkVectDataConOcc'; the names of - -- the isomorphisms are determined by 'OccName.mkVectIsoOcc' - ifaceVectInfoTyConReuse :: [Name] - -- ^ The vectorised form of all the 'TyCon's in here coincides with - -- the unconverted form; the name of the isomorphisms is determined - -- by 'OccName.mkVectIsoOcc' + = IfaceVectInfo + { ifaceVectInfoVar :: [Name] -- ^ All variables in here have a vectorised variant + , ifaceVectInfoTyCon :: [Name] -- ^ All 'TyCon's in here have a vectorised variant; + -- the name of the vectorised variant and those of its + -- data constructors are determined by + -- 'OccName.mkVectTyConOcc' and + -- 'OccName.mkVectDataConOcc'; the names of the + -- isomorphisms are determined by 'OccName.mkVectIsoOcc' + , ifaceVectInfoTyConReuse :: [Name] -- ^ The vectorised form of all the 'TyCon's in here + -- coincides with the unconverted form; the name of the + -- isomorphisms is determined by 'OccName.mkVectIsoOcc' + , ifaceVectInfoScalarVars :: [Name] -- iface version of 'vectInfoScalarVar' + , ifaceVectInfoScalarTyCons :: [Name] -- iface version of 'vectInfoScalarTyCon' } noVectInfo :: VectInfo -noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv +noVectInfo + = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv 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) + 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) concatVectInfo :: [VectInfo] -> VectInfo concatVectInfo = foldr plusVectInfo noVectInfo noIfaceVectInfo :: IfaceVectInfo -noIfaceVectInfo = IfaceVectInfo [] [] [] +noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] \end{code} %************************************************************************ @@ -2074,6 +1826,9 @@ isObjectLinkable l = not (null unlinked) && all isObject unlinked -- 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 ] + instance Outputable Linkable where ppr (LM when_made mod unlinkeds) = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) @@ -2148,13 +1903,16 @@ data ModBreaks -- ^ An array giving the source span of each breakpoint. , modBreaks_vars :: !(Array BreakIndex [OccName]) -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. } emptyModBreaks :: ModBreaks emptyModBreaks = ModBreaks { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" -- Todo: can we avoid this? - , modBreaks_locs = array (0,-1) [] - , modBreaks_vars = array (0,-1) [] + , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] + , modBreaks_decls = array (0,-1) [] } \end{code}