X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FMkIface.lhs;h=c7a71b70985e19a1936038376fb6d0b8e4bf7a83;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=4dad85aa7d4fa9ec200d69e8ea33df953e22a34e;hpb=ccbff992682223701536713b0a80de657a1ff01f;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 4dad85a..c7a71b7 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -177,18 +177,18 @@ import HsSyn import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..), eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, - eqMaybeBy, eqListBy, + eqMaybeBy, eqListBy, visibleIfConDecls, tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule ) import LoadIface ( readIface, loadInterface, ifaceInstGates ) import BasicTypes ( Version, initialVersion, bumpVersion ) import TcRnMonad import TcRnTypes ( ImportAvails(..), mkModDeps ) -import HscTypes ( ModIface(..), +import TcType ( isFFITy ) +import HscTypes ( ModIface(..), TyThing(..), ModGuts(..), ModGuts, IfaceExport, - GhciMode(..), + GhciMode(..), isOneShot, HscEnv(..), hscEPS, Dependencies(..), FixItem(..), - isImplicitTyThing, mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, typeEnvElts, Avails, AvailInfo, GenAvailInfo(..), availName, @@ -201,14 +201,18 @@ import HscTypes ( ModIface(..), import CmdLineOpts import Name ( Name, nameModule, nameOccName, nameParent, isExternalName, - nameParent_maybe, isWiredInName, NamedThing(..) ) + nameParent_maybe, isWiredInName, NamedThing(..), nameModuleName ) import NameEnv import NameSet import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv_C, OccSet, emptyOccSet, elemOccSet, occSetElts, extendOccSet, extendOccSetList, - isEmptyOccSet, intersectOccSet, intersectsOccSet ) -import TyCon ( visibleDataCons ) + isEmptyOccSet, intersectOccSet, intersectsOccSet, + occNameFS, isTcOcc ) +import TyCon ( visibleDataCons, tyConDataCons, isNewTyCon, newTyConRep ) +import Class ( classSelIds ) +import DataCon ( dataConName, dataConFieldLabels ) +import FieldLabel ( fieldLabelName ) import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, ModLocation(..), mkSysModuleNameFS, moduleUserString, ModuleEnv, emptyModuleEnv, lookupModuleEnv, @@ -216,7 +220,7 @@ import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, ) import Outputable import DriverUtil ( createDirectoryHierarchy, directoryOf ) -import Util ( sortLt, seqList ) +import Util ( sortLe, seqList ) import Binary ( getBinFileWithDict ) import BinIface ( writeBinIface, v_IgnoreHiWay ) import Unique ( Unique, Uniquable(..) ) @@ -227,6 +231,7 @@ import FastString import DATA_IOREF ( writeIORef ) import Monad ( when ) +import List ( insert ) import Maybes ( orElse, mapCatMaybes, isNothing, fromJust, expectJust ) \end{code} @@ -261,19 +266,29 @@ mkIface hsc_env location maybe_old_iface = do { eps <- hscEPS hsc_env ; let { this_mod_name = moduleName this_mod ; ext_nm = mkExtNameFn hsc_env eps this_mod_name - ; decls = [ tyThingToIfaceDecl omit_prags ext_nm thing - | thing <- typeEnvElts type_env - , not (isImplicitTyThing thing) && not (isWiredInName (getName thing)) ] + ; local_things = [thing | thing <- typeEnvElts type_env, + not (isWiredInName (getName thing)) ] + -- Do not export anything about wired-in things + -- (GHC knows about them already) + + ; abstract_tcs :: NameSet -- TyCons and Classes whose representation is not exposed + ; abstract_tcs + | not omit_prags = emptyNameSet -- In the -O case, nothing is abstract + | otherwise = mkNameSet [ getName thing + | thing <- local_things + , not (mustExposeThing exports thing)] + + ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm thing + | thing <- local_things, wantDeclFor exports abstract_tcs thing ] -- Don't put implicit Ids and class tycons in the interface file - -- Nor wired-in things (GHC knows about them already) ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] ; deprecs = mkIfaceDeprec src_deprecs ; iface_rules | omit_prags = [] - | otherwise = sortLt lt_rule $ + | otherwise = sortLe le_rule $ map (coreRuleToIfaceRule this_mod_name ext_nm) rules - ; iface_insts = sortLt lt_inst (map (dfunToIfaceInst this_mod_name) insts) + ; iface_insts = sortLe le_inst (map dfunToIfaceInst insts) ; intermediate_iface = ModIface { mi_module = this_mod, @@ -281,7 +296,7 @@ mkIface hsc_env location maybe_old_iface mi_boot = False, mi_deps = deps, mi_usages = usages, - mi_exports = groupAvails exports, + mi_exports = mkIfaceExports exports, mi_insts = iface_insts, mi_rules = iface_rules, mi_fixities = fixities, @@ -318,14 +333,55 @@ mkIface hsc_env location maybe_old_iface ; return new_iface } where - r1 `lt_rule` r2 = ifRuleName r1 < ifRuleName r2 - i1 `lt_inst` i2 = ifDFun i1 < ifDFun i2 + r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 + i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 dflags = hsc_dflags hsc_env ghci_mode = hsc_mode hsc_env hi_file_path = ml_hi_file location omit_prags = dopt Opt_OmitInterfacePragmas dflags + +mustExposeThing :: NameSet -> TyThing -> Bool +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types and classes whose constructors, fields, methods are +-- visible to an importing module +mustExposeThing exports (ATyCon tc) + = any exported_data_con (tyConDataCons tc) + -- Expose rep if any datacon or field is exported + + || (isNewTyCon tc && isFFITy (snd (newTyConRep tc))) + -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + where + exported_data_con con + = any (`elemNameSet` exports) (dataConName con : field_names) + where + field_names = map fieldLabelName (dataConFieldLabels con) + +mustExposeThing exports (AClass cls) + = any exported_class_op (classSelIds cls) + where -- Expose rep if any classs op is exported + exported_class_op op = getName op `elemNameSet` exports + +mustExposeThing exports other = False + + +wantDeclFor :: NameSet -- User-exported things + -> NameSet -- Abstract things + -> TyThing -> Bool +wantDeclFor exports abstracts thing + | Just parent <- nameParent_maybe name -- An implicit thing + = parent `elemNameSet` abstracts && name `elemNameSet` exports + | otherwise + = True + where + name = getName thing + + deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) ----------------------------- @@ -479,7 +535,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, eq_ind_occs [op | IfaceClassOp op _ _ <- sigs] eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons}) = same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too - eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleDataCons cons] + eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ _ <- visibleIfConDecls cons] eq_indirects other = Equal -- Synonyms and foreign declarations eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules @@ -593,7 +649,7 @@ anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs mkIfaceDeprec :: Deprecations -> IfaceDeprecs mkIfaceDeprec NoDeprecs = NoDeprecs mkIfaceDeprec (DeprecAll t) = DeprecAll t -mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLt (<) (nameEnvElts env)) +mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLe (<=) (nameEnvElts env)) ---------------------- bump_unless :: Bool -> Version -> Version @@ -646,8 +702,8 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names -- ToDo: do we need to sort into canonical order? import_all mod = case lookupModuleEnv dir_imp_mods mod of - Just (_,imp_all) -> isNothing imp_all - Nothing -> False + Just (_,imp_all,_) -> isNothing imp_all + Nothing -> False -- We want to create a Usage for a home module if -- a) we used something from; has something in used_names @@ -689,44 +745,40 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names used_occs = lookupModuleEnv ent_map mod `orElse` [] ent_vers :: [(OccName,Version)] ent_vers = [ (occ, version_env occ `orElse` initialVersion) - | occ <- sortLt (<) used_occs] + | occ <- sortLe (<=) used_occs] \end{code} \begin{code} -groupAvails :: Avails -> [(ModuleName, [GenAvailInfo OccName])] +mkIfaceExports :: NameSet -> [(ModuleName, [GenAvailInfo OccName])] -- Group by module and sort by occurrence -- This keeps the list in canonical order -groupAvails avails - = [ (mkSysModuleNameFS fs, sortLt lt avails) - | (fs,avails) <- fmToList groupFM +mkIfaceExports exports + = [ (mkSysModuleNameFS fs, eltsFM avails) + | (fs, avails) <- fmToList groupFM ] where - groupFM :: FiniteMap FastString [GenAvailInfo OccName] + groupFM :: FiniteMap FastString (FiniteMap FastString (GenAvailInfo OccName)) -- Deliberately use the FastString so we -- get a canonical ordering - groupFM = foldl add emptyFM avails + groupFM = foldl add emptyFM (nameSetToList exports) - add env avail = addToFM_C (\old _ -> avail':old) env mod_fs [avail'] - where - mod_fs = moduleNameFS (moduleName avail_mod) - avail_mod = nameModule (availName avail) - avail' = sortAvail avail - - a1 `lt` a2 = availName a1 < availName a2 - -sortAvail :: AvailInfo -> GenAvailInfo OccName --- Convert to OccName, and sort the sub-names into canonical order --- The canonical order has the "main name" at the beginning --- (if it's there at all) -sortAvail (Avail n) = Avail (nameOccName n) -sortAvail (AvailTC n ns) - | n `elem` ns = AvailTC occ (occ : mk_occs (filter (/= n) ns)) - | otherwise = AvailTC occ ( mk_occs ns) - where - occ = nameOccName n - mk_occs ns = sortLt (<) (map nameOccName ns) + add env name = addToFM_C add_avail env mod_fs + (unitFM avail_fs avail) + where + occ = nameOccName name + occ_fs = occNameFS occ + mod_fs = moduleNameFS (nameModuleName name) + avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ] + | isTcOcc occ = AvailTC occ [occ] + | otherwise = Avail occ + avail_fs = occNameFS (availName avail) + add_avail avail_fm _ = addToFM_C add_item avail_fm avail_fs avail + + add_item (AvailTC p occs) _ = AvailTC p (insert occ occs) + add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name) \end{code} + %************************************************************************ %* * Load the old interface file for this module (unless @@ -805,18 +857,22 @@ checkVersions source_unchanged iface | not source_unchanged = returnM outOfDate | otherwise - = traceHiDiffs (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) `thenM_` + = do { traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) -- Source code unchanged and no errors yet... carry on + -- First put the dependent-module info in the envt, just temporarily, -- so that when we look for interfaces we look for the right one (.hi or .hi-boot) -- It's just temporary because either the usage check will succeed -- (in which case we are done with this module) or it'll fail (in which -- case we'll compile the module from scratch anyhow). - updGblEnv (\ gbl -> gbl { if_is_boot = mod_deps }) ( - checkList [checkModUsage u | u <- mi_usages iface] - ) + ; mode <- getGhciMode + ; ifM (isOneShot mode) + (updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }) + + ; checkList [checkModUsage u | u <- mi_usages iface] + } where -- This is a bit of a hack really mod_deps :: ModuleEnv (ModuleName, IsBootInterface)