X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=92b7228dd50cba4c7051315ce2f64e89646acade;hb=cf411c9ae5d61d6e5baa5e5e6b0ad9803b041236;hp=d6edaeb7d4a359719f808ebe644e22f530e51117;hpb=4af2b117f0fdc6992eb2630df637f12b02e8181b;p=ghc-hetmet.git diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index d6edaeb..92b7228 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -51,7 +51,7 @@ module HscTypes ( GenAvailInfo(..), AvailInfo, RdrAvailInfo, IfaceExport, - Deprecations, DeprecTxt, lookupDeprec, plusDeprecs, + Deprecations, DeprecTxt, plusDeprecs, PackageInstEnv, PackageRuleBase, @@ -64,6 +64,7 @@ module HscTypes ( #include "HsVersions.h" +import Breakpoints ( SiteNumber, Coord, noDbgSites ) #ifdef GHCI import ByteCodeAsm ( CompiledByteCode ) #endif @@ -90,7 +91,7 @@ import TyCon import DataCon ( DataCon, dataConImplicitIds ) import PrelNames ( gHC_PRIM ) import Packages ( PackageId ) -import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) +import DynFlags ( DynFlags(..), DynFlag(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) @@ -209,9 +210,15 @@ data TargetId pprTarget :: Target -> SDoc pprTarget (Target id _) = pprTargetId id +instance Outputable Target where + ppr = pprTarget + pprTargetId (TargetModule m) = ppr m pprTargetId (TargetFile f _) = text f +instance Outputable TargetId where + ppr = pprTargetId + type HomePackageTable = ModuleNameEnv HomeModInfo -- Domain = modules in the home package -- "home" package name cached here for convenience @@ -295,12 +302,15 @@ hptRules hsc_env deps , mod /= moduleName gHC_PRIM -- Look it up in the HPT - , let mod_info = case lookupUFM hpt mod of - Nothing -> pprPanic "hptRules" (ppr mod <+> ppr deps) - Just x -> x + , let rules = case lookupUFM hpt mod of + Just info -> md_rules (hm_details info) + Nothing -> pprTrace "WARNING in hptRules" 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 - , rule <- md_rules (hm_details mod_info) ] + , rule <- rules ] \end{code} %************************************************************************ @@ -445,14 +455,16 @@ data ModDetails md_types :: !TypeEnv, md_insts :: ![Instance], -- Dfun-ids for the instances in this module md_fam_insts :: ![FamInst], - md_rules :: ![CoreRule] -- Domain may include Ids from other modules + md_rules :: ![CoreRule], -- Domain may include Ids from other modules + md_dbg_sites :: ![(SiteNumber, Coord)] -- Breakpoint sites inserted by the renamer } emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_exports = [], md_insts = [], md_rules = [], - md_fam_insts = [] } + md_fam_insts = [], + md_dbg_sites = noDbgSites} -- 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 @@ -473,7 +485,10 @@ data ModGuts mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in -- this module - mg_deprecs :: !Deprecations, -- Deprecations declared in the module + + mg_fam_inst_env :: FamInstEnv, -- Type-family instance enviroment + -- for *home-package* modules (including + -- this one). c.f. tcg_fam_inst_env mg_types :: !TypeEnv, mg_insts :: ![Instance], -- Instances @@ -481,7 +496,9 @@ data ModGuts mg_rules :: ![CoreRule], -- Rules from this module mg_binds :: ![CoreBind], -- Bindings for this module mg_foreign :: !ForeignStubs, - mg_hpc_info :: !HpcInfo -- info about coverage tick boxes + mg_deprecs :: !Deprecations, -- Deprecations declared in the module + mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes + mg_dbg_sites :: ![(SiteNumber, Coord)] -- Bkpts inserted by the renamer } -- The ModGuts takes on several slightly different forms: @@ -657,12 +674,14 @@ implicitTyThings (ATyCon tc) = implicitCoTyCon tc ++ concatMap (extras_plus . ADataCon) (tyConDataCons tc) - -- For classes, add the class TyCon too (and its extras) - -- and the class selector Ids and the associated types (they don't - -- have extras as these are only the family decls) -implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ - map ATyCon (classATs cl) ++ - extras_plus (ATyCon (classTyCon cl)) + -- For classes, add the class selector Ids, and assoicated TyCons + -- and the class TyCon too (and its extras) +implicitTyThings (AClass cl) + = map AnId (classSelIds cl) ++ + map ATyCon (classATs cl) ++ + -- No extras_plus for the classATs, because they + -- are only the family decls; they have no implicit things + extras_plus (ATyCon (classTyCon cl)) -- For data cons add the worker and wrapper (if any) implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) @@ -806,13 +825,6 @@ mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName emptyIfaceDepCache :: Name -> Maybe DeprecTxt emptyIfaceDepCache n = Nothing -lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt -lookupDeprec NoDeprecs name = Nothing -lookupDeprec (DeprecAll txt) name = Just txt -lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of - Just (_, txt) -> Just txt - Nothing -> Nothing - plusDeprecs :: Deprecations -> Deprecations -> Deprecations plusDeprecs d NoDeprecs = d plusDeprecs NoDeprecs d = d @@ -1128,7 +1140,12 @@ showModMsg target recomp mod_summary = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), char '(', text (msHsFilePath mod_summary) <> comma, case target of - HscInterpreted | recomp +#if defined(GHCI) && defined(DEBUGGER) + HscInterpreted | recomp && + Opt_Debugging `elem` modflags + -> text "interpreted(debugging)" +#endif + HscInterpreted | recomp -> text "interpreted" HscNothing -> text "nothing" _other -> text (msObjFilePath mod_summary), @@ -1136,6 +1153,7 @@ showModMsg target recomp mod_summary where mod = moduleName (ms_mod mod_summary) mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) + modflags= flags(ms_hspp_opts mod_summary) \end{code}