X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=1d3f4dcc7cac5d95a6c2750ea90082d19f7cefd8;hb=5e0453cad41cb0f004c1680b392d79651053a1d4;hp=83dda3f81b8ec908c32af0cbde8e1a9f09fd0b30;hpb=66579ff945831c5fc9a17c58c722ff01f2268d76;p=ghc-hetmet.git diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 83dda3f..1d3f4dc 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -13,11 +13,12 @@ module HscTypes ( ioMsgMaybe, ioMsg, logWarnings, clearWarnings, hasWarnings, SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, - handleSourceError, + throwOneError, handleSourceError, reflectGhc, reifyGhc, + handleFlagWarnings, -- * Sessions and compilation state - Session(..), withSession, modifySession, + Session(..), withSession, modifySession, withTempSession, HscEnv(..), hscEPS, FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, @@ -45,6 +46,10 @@ module HscTypes ( PackageInstEnv, PackageRuleBase, + + -- * Annotations + prepareAnnotations, + -- * Interactive context InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, @@ -121,12 +126,14 @@ import Var import Id import Type +import Annotations import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) -import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) +import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, + DynFlag(..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, Fixity, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) @@ -136,29 +143,24 @@ import CoreSyn ( CoreRule ) import Maybes ( orElse, expectJust, catMaybes ) import Outputable import BreakArray -import SrcLoc ( SrcSpan, Located ) +import SrcLoc ( SrcSpan, Located(..) ) import LazyUniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString import StringBuffer ( StringBuffer ) import Fingerprint import MonadUtils -import Bag ( emptyBag, unionBags, isEmptyBag ) import Data.Dynamic ( Typeable ) import qualified Data.Dynamic as Dyn -#if __GLASGOW_HASKELL__ < 609 -import Data.Dynamic ( toDyn, fromDyn, fromDynamic ) -#else -import Bag ( bagToList ) -#endif -import ErrUtils ( ErrorMessages, WarningMessages, Messages ) +import Bag +import ErrUtils import System.FilePath import System.Time ( ClockTime ) import Data.IORef import Data.Array ( Array, array ) import Data.List -import Control.Monad ( mplus, guard, liftM ) +import Control.Monad ( mplus, guard, liftM, when ) import Exception \end{code} @@ -181,7 +183,8 @@ mkSrcErr :: ErrorMessages -> SourceError srcErrorMessages :: SourceError -> ErrorMessages mkApiErr :: SDoc -> GhcApiError -#if __GLASGOW_HASKELL__ >= 609 +throwOneError :: MonadIO m => ErrMsg -> m ab +throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err -- | A source error is an error that is caused by one or more errors in the -- source code. A 'SourceError' is thrown by many functions in the @@ -242,43 +245,6 @@ instance Exception GhcApiError mkApiErr = GhcApiError -#else ------------------------------------------------------------------------- --- implementation for bootstrapping without extensible exceptions - -data SourceException = SourceException ErrorMessages -sourceExceptionTc :: Dyn.TyCon -sourceExceptionTc = Dyn.mkTyCon "SourceException" -{-# NOINLINE sourceExceptionTc #-} -instance Typeable SourceException where - typeOf _ = Dyn.mkTyConApp sourceExceptionTc [] - --- Source error has to look like a normal exception. Throwing a DynException --- directly would not allow us to use the Exception monad. We also cannot --- make it part of GhcException as that would lead to circular imports. - -type SourceError = Exception -type GhcApiError = Exception - -mkSrcErr msgs = DynException . toDyn $ SourceException msgs - -mkApiErr = IOException . userError . showSDoc - -srcErrorMessages (DynException ms) = - let SourceException msgs = (fromDyn ms (panic "SourceException expected")) - in msgs -srcErrorMessages _ = panic "SourceError expected" - -handleSourceError :: ExceptionMonad m => (Exception -> m a) -> m a -> m a -handleSourceError handler act = - gcatch act - (\e -> case e of - DynException dyn - | Just (SourceException _) <- fromDynamic dyn - -> handler e - _ -> throw e) -#endif - -- | A monad that allows logging of warnings. class Monad m => WarnLogMonad m where setWarnings :: WarningMessages -> m () @@ -327,6 +293,16 @@ 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'. @@ -345,10 +321,9 @@ instance MonadIO Ghc where instance ExceptionMonad Ghc where gcatch act handle = Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s -#if __GLASGOW_HASKELL__ < 609 - gcatchDyn act handler = - Ghc $ \s -> unGhc act s `gcatchDyn` \e -> unGhc (handler e) s -#endif + gblock (Ghc m) = Ghc $ \s -> gblock (m s) + gunblock (Ghc m) = Ghc $ \s -> gunblock (m s) + instance WarnLogMonad Ghc where setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns -- | Return 'Warnings' accumulated so far. @@ -378,9 +353,8 @@ instance MonadIO m => MonadIO (GhcT m) where instance ExceptionMonad m => ExceptionMonad (GhcT m) where gcatch act handle = GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s -#if __GLASGOW_HASKELL__ < 609 - gcatchDyn _act _handler = error "cannot use GhcT in stage1" -#endif + gblock (GhcT m) = GhcT $ \s -> gblock (m s) + gunblock (GhcT m) = GhcT $ \s -> gunblock (m s) instance MonadIO m => WarnLogMonad (GhcT m) where setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns @@ -413,7 +387,7 @@ ioMsgMaybe ioA = do ((warns,errs), mb_r) <- liftIO ioA logWarnings warns case mb_r of - Nothing -> throw (mkSrcErr errs) + Nothing -> liftIO $ throwIO (mkSrcErr errs) Just r -> ASSERT( isEmptyBag errs ) return r -- | Lift a non-failing IO action into a 'GhcMonad'. @@ -447,6 +421,24 @@ reflectGhc m = unGhc m -- > Dual to 'reflectGhc'. See its documentation. reifyGhc :: (Session -> IO a) -> Ghc a reifyGhc act = Ghc $ act + +handleFlagWarnings :: GhcMonad m => DynFlags -> [Located String] -> m () +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} @@ -542,9 +534,11 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env) -- is for use in an IDE where the file hasn't been saved by -- the user yet). data Target = Target - TargetId -- module or filename - Bool -- object code allowed? - (Maybe (StringBuffer,ClockTime)) -- in-memory text buffer? + { targetId :: TargetId -- ^ module or filename + , targetAllowObjCode :: Bool -- ^ object code allowed? + , targetContents :: Maybe (StringBuffer,ClockTime) + -- ^ in-memory text buffer? + } data TargetId = TargetModule ModuleName @@ -587,30 +581,31 @@ emptyPackageIfaceTable = emptyModuleEnv -- | Information about modules in the package being compiled data HomeModInfo - = HomeModInfo { hm_iface :: !ModIface, -- ^ The basic loaded interface file: every - -- loaded module has one of 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 - 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). - } + = HomeModInfo { + hm_iface :: !ModIface, + -- ^ The basic loaded interface file: every loaded module has one of + -- 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 + 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). + } -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information @@ -663,6 +658,12 @@ hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] -- ^ Get rules from modules \"below\" this one (in the dependency sense) hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False + +hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] +-- ^ Get annotations from modules \"below\" this one (in the dependency sense) +hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps +hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env + hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] hptAllThings extract hsc_env = concatMap extract (eltsUFM (hsc_HPT hsc_env)) @@ -697,7 +698,32 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- And get its dfuns , thing <- things ] +\end{code} +%************************************************************************ +%* * +\subsection{Dealing with Annotations} +%* * +%************************************************************************ + +\begin{code} +prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv +-- ^ Deal with gathering annotations in from all possible places +-- and combining them into a single 'AnnEnv' +prepareAnnotations hsc_env mb_guts + = do { eps <- hscEPS hsc_env + ; let -- Extract annotations from the module being compiled if supplied one + mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts + -- Extract dependencies of the module if we are supplied one, + -- otherwise load annotations from all home package table + -- entries regardless of dependency ordering. + home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts + other_pkg_anns = eps_ann_env eps + ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, + Just home_pkg_anns, + Just other_pkg_anns] + + ; return ann_env } \end{code} %************************************************************************ @@ -800,6 +826,11 @@ data ModIface -- 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) @@ -858,6 +889,8 @@ data ModDetails md_insts :: ![Instance], -- ^ 'DFunId's for the instances in this module md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules + md_anns :: ![Annotation], -- ^ Annotations present in this module: currently + -- they only annotate things also declared in this module md_vect_info :: !VectInfo -- ^ Module vectorisation information } @@ -867,6 +900,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], md_rules = [], md_fam_insts = [], + md_anns = [], md_vect_info = noVectInfo } @@ -905,6 +939,7 @@ 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_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module @@ -1018,6 +1053,7 @@ emptyModIface mod mi_exp_hash = fingerprint0, mi_fixities = [], mi_warns = NoWarnings, + mi_anns = [], mi_insts = [], mi_fam_insts = [], mi_rules = [], @@ -1338,7 +1374,7 @@ lookupType dflags hpt pte name lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) lookupTypeHscEnv hsc_env name = do eps <- readIORef (hsc_EPS hsc_env) - return $ lookupType dflags hpt (eps_PTE eps) name + return $! lookupType dflags hpt (eps_PTE eps) name where dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env @@ -1648,6 +1684,7 @@ type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv type PackageFamInstEnv = FamInstEnv type PackageVectInfo = VectInfo +type PackageAnnEnv = AnnEnv -- | Information about other packages that we have slurped in by reading -- their interface files @@ -1699,6 +1736,8 @@ data ExternalPackageState -- 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 eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external -- packages, keyed off the module that declared them @@ -1953,8 +1992,14 @@ data Linkable = LM { -- (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 + linkableUnlinked :: [Unlinked] + -- ^ Those files and chunks of code we have yet to link. + -- + -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. + -- If this list is empty, the Linkable represents a fake linkable, which + -- is generated in HscNothing mode to avoid recompiling modules. + -- + -- XXX: Do items get removed from this list when they get linked? } isObjectLinkable :: Linkable -> Bool