X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=76e28be6d488dca9dcc85cba788d710574d8c554;hb=1246293616fc45787ecaed13aa31a2555510f7e3;hp=059fe9c698df62af1fbab9999e4fa580a562af80;hpb=049cdffa62fb2e0b1580eacb5ed8a30650c3faf7;p=ghc-hetmet.git diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 059fe9c..76e28be 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -15,6 +15,7 @@ module HscTypes ( SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, throwOneError, handleSourceError, reflectGhc, reifyGhc, + handleFlagWarnings, -- * Sessions and compilation state Session(..), withSession, modifySession, @@ -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,7 +143,7 @@ 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 @@ -153,7 +160,7 @@ 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} @@ -404,6 +411,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} @@ -623,6 +648,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)) @@ -657,7 +688,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} %************************************************************************ @@ -760,6 +816,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) @@ -818,6 +879,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 } @@ -827,6 +890,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], md_rules = [], md_fam_insts = [], + md_anns = [], md_vect_info = noVectInfo } @@ -865,6 +929,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 @@ -978,6 +1043,7 @@ emptyModIface mod mi_exp_hash = fingerprint0, mi_fixities = [], mi_warns = NoWarnings, + mi_anns = [], mi_insts = [], mi_fam_insts = [], mi_rules = [], @@ -1298,7 +1364,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 @@ -1608,6 +1674,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 @@ -1659,6 +1726,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