diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/Annotations.lhs | 92 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 40 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 10 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 1 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 49 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs-boot | 3 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 5 |
7 files changed, 188 insertions, 12 deletions
diff --git a/compiler/main/Annotations.lhs b/compiler/main/Annotations.lhs new file mode 100644 index 0000000000..4cb7785d48 --- /dev/null +++ b/compiler/main/Annotations.lhs @@ -0,0 +1,92 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +\begin{code} +module Annotations ( + -- * Main Annotation data types + Annotation(..), + AnnTarget(..), CoreAnnTarget, + getAnnTargetName_maybe, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns + ) where + +import Name +import Module ( Module ) +import Outputable +import LazyUniqFM +import Serialized +import Unique + +import Control.Monad +import Data.Typeable +import Data.Maybe +import Data.Word ( Word8 ) + + +-- | Represents an annotation after it has been sufficiently desugared from +-- it's initial form of 'HsDecls.AnnDecl' +data Annotation = Annotation { + ann_target :: CoreAnnTarget, -- ^ The target of the annotation + ann_value :: Serialized -- ^ 'Serialized' version of the annotation that + -- allows recovery of its value or can + -- be persisted to an interface file + } + +-- | An annotation target +data AnnTarget name + = NamedTarget name -- ^ We are annotating something with a name: + -- a type or identifier + | ModuleTarget Module -- ^ We are annotating a particular module + +-- | The kind of annotation target found in the middle end of the compiler +type CoreAnnTarget = AnnTarget Name + +instance Functor AnnTarget where + fmap f (NamedTarget nm) = NamedTarget (f nm) + fmap _ (ModuleTarget mod) = ModuleTarget mod + +getAnnTargetName_maybe :: AnnTarget name -> Maybe name +getAnnTargetName_maybe (NamedTarget nm) = Just nm +getAnnTargetName_maybe _ = Nothing + +instance Uniquable name => Uniquable (AnnTarget name) where + getUnique (NamedTarget nm) = getUnique nm + getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0 + -- deriveUnique prevents OccName uniques clashing with NamedTarget + +instance Outputable name => Outputable (AnnTarget name) where + ppr (NamedTarget nm) = text "Named target" <+> ppr nm + ppr (ModuleTarget mod) = text "Module target" <+> ppr mod + + +-- | A collection of annotations +newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) +-- Can't use a type synonym or we hit bug #2412 due to source import + +emptyAnnEnv :: AnnEnv +emptyAnnEnv = MkAnnEnv emptyUFM + +mkAnnEnv :: [Annotation] -> AnnEnv +mkAnnEnv = extendAnnEnvList emptyAnnEnv + +extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv +extendAnnEnvList (MkAnnEnv env) anns + = MkAnnEnv $ addListToUFM_C (++) env $ + map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns + +plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv +plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] +findAnns deserialize (MkAnnEnv ann_env) + = (mapMaybe (fromSerialized deserialize)) + . (lookupWithDefaultUFM ann_env []) +\end{code}
\ No newline at end of file diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1ee8d7392f..df9efcbde2 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -91,6 +91,7 @@ import Data.IORef ( readIORef ) import Control.Monad ( when ) import Data.Char +import Data.List ( intersperse ) import System.FilePath import System.IO ( stderr, hPutChar ) @@ -908,18 +909,44 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things + data SimplifierMode -- See comments in SimplMonad = SimplGently | SimplPhase Int [String] +instance Outputable SimplifierMode where + ppr SimplGently = ptext (sLit "gentle") + ppr (SimplPhase n ss) = int n <+> brackets (text (concat $ intersperse "," ss)) + + data SimplifierSwitch = MaxSimplifierIterations Int | NoCaseOfCase -data FloatOutSwitches - = FloatOutSw Bool -- True <=> float lambdas to top level - Bool -- True <=> float constants to top level, - -- even if they do not escape a lambda + +data FloatOutSwitches = FloatOutSwitches { + floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level + floatOutConstants :: Bool -- ^ True <=> float constants to top level, + -- even if they do not escape a lambda + } + +instance Outputable FloatOutSwitches where + ppr = pprFloatOutSwitches + +pprFloatOutSwitches :: FloatOutSwitches -> SDoc +pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma + <+> pp_not (floatOutConstants sw) <+> text "constants" + where + pp_not True = empty + pp_not False = text "not" + +-- | Switches that specify the minimum amount of floating out +gentleFloatOutSwitches :: FloatOutSwitches +gentleFloatOutSwitches = FloatOutSwitches False False + +-- | Switches that do not specify floating out of lambdas, just of constants +constantsOnlyFloatOutSwitches :: FloatOutSwitches +constantsOnlyFloatOutSwitches = FloatOutSwitches False True -- The core-to-core pass ordering is derived from the DynFlags: @@ -1017,7 +1044,7 @@ getCoreToDo dflags -- so that overloaded functions have all their dictionary lambdas manifest CoreDoSpecialising, - runWhen full_laziness (CoreDoFloatOutwards (FloatOutSw False False)), + runWhen full_laziness (CoreDoFloatOutwards gentleFloatOutSwitches), CoreDoFloatInwards, @@ -1047,8 +1074,7 @@ getCoreToDo dflags ]), runWhen full_laziness - (CoreDoFloatOutwards (FloatOutSw False -- Not lambdas - True)), -- Float constants + (CoreDoFloatOutwards constantsOnlyFloatOutSwitches), -- nofib/spectral/hartel/wang doubles in speed if you -- do full laziness late in the day. It only happens -- after fusion and other stuff, so the early pass doesn't diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 0d2cca1ec4..e8ea87c6b3 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -74,6 +74,7 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, lookupGlobalName, + findGlobalAnns, mkPrintUnqualifiedForModule, -- * Printing @@ -278,6 +279,7 @@ import StaticFlagParser import qualified StaticFlags import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) +import Annotations import Module import LazyUniqFM import UniqSet @@ -304,6 +306,8 @@ import System.Directory ( getModificationTime, doesFileExist, import Data.Maybe import Data.List import qualified Data.List as List +import Data.Typeable ( Typeable ) +import Data.Word ( Word8 ) import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) import System.Time ( ClockTime, getClockTime ) @@ -1173,6 +1177,7 @@ mkModGuts coreModule = ModGuts { mg_binds = cm_binds coreModule, mg_foreign = NoStubs, mg_warns = NoWarnings, + mg_anns = [], mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, mg_vect_info = noVectInfo, @@ -2412,6 +2417,11 @@ lookupGlobalName name = withSession $ \hsc_env -> do return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name +findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] +findGlobalAnns deserialize target = withSession $ \hsc_env -> do + ann_env <- liftIO $ prepareAnnotations hsc_env Nothing + return (findAnns deserialize ann_env target) + #ifdef GHCI -- | get the GlobalRdrEnv for a session getGRE :: GhcMonad m => m GlobalRdrEnv diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 50c92d3e3a..086f6e895a 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -1050,4 +1050,3 @@ showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " i_str = show i padded = replicate (length n_str - length i_str) ' ' ++ i_str \end{code} - diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 059fe9c698..03bcca5e1e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -45,6 +45,10 @@ module HscTypes ( PackageInstEnv, PackageRuleBase, + + -- * Annotations + prepareAnnotations, + -- * Interactive context InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, @@ -121,6 +125,7 @@ import Var import Id import Type +import Annotations import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) @@ -623,6 +628,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 +668,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 +796,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 +859,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 +870,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], md_rules = [], md_fam_insts = [], + md_anns = [], md_vect_info = noVectInfo } @@ -865,6 +909,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 +1023,7 @@ emptyModIface mod mi_exp_hash = fingerprint0, mi_fixities = [], mi_warns = NoWarnings, + mi_anns = [], mi_insts = [], mi_fam_insts = [], mi_rules = [], @@ -1608,6 +1654,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 +1706,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 diff --git a/compiler/main/HscTypes.lhs-boot b/compiler/main/HscTypes.lhs-boot deleted file mode 100644 index c80d2313cd..0000000000 --- a/compiler/main/HscTypes.lhs-boot +++ /dev/null @@ -1,3 +0,0 @@ -> module HscTypes where -> -> data Session
\ No newline at end of file diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 01d47e6214..16f389bf14 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -142,6 +142,7 @@ mkBootModDetails hsc_env exports type_env insts fam_insts , md_insts = insts' , md_fam_insts = fam_insts , md_rules = [] + , md_anns = [] , md_exports = exports , md_vect_info = noVectInfo }) @@ -260,6 +261,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, mg_rules = imp_rules, mg_vect_info = vect_info, mg_dir_imps = dir_imps, + mg_anns = anns, mg_deps = deps, mg_foreign = foreign_stubs, mg_hpc_info = hpc_info, @@ -326,7 +328,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, md_insts = tidy_insts, md_fam_insts = fam_insts, md_exports = exports, - md_vect_info = vect_info -- is already tidy + md_anns = anns, -- are already tidy + md_vect_info = vect_info -- }) } |