X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FMkIface.lhs;h=c7a71b70985e19a1936038376fb6d0b8e4bf7a83;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=019b44ff714035cba967372219c099c175f1f5d8;hpb=475c938562ac28a3ff29d119a785cbf75c32b2d1;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 019b44f..c7a71b7 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -177,15 +177,16 @@ 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 TcType ( isFFITy ) import HscTypes ( ModIface(..), TyThing(..), ModGuts(..), ModGuts, IfaceExport, - GhciMode(..), + GhciMode(..), isOneShot, HscEnv(..), hscEPS, Dependencies(..), FixItem(..), mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, @@ -208,9 +209,10 @@ import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOc extendOccSet, extendOccSetList, isEmptyOccSet, intersectOccSet, intersectsOccSet, occNameFS, isTcOcc ) -import TyCon ( visibleDataCons, tyConDataCons, isNewTyCon ) +import TyCon ( visibleDataCons, tyConDataCons, isNewTyCon, newTyConRep ) import Class ( classSelIds ) -import DataCon ( dataConName ) +import DataCon ( dataConName, dataConFieldLabels ) +import FieldLabel ( fieldLabelName ) import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, ModLocation(..), mkSysModuleNameFS, moduleUserString, ModuleEnv, emptyModuleEnv, lookupModuleEnv, @@ -218,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(..) ) @@ -274,7 +276,7 @@ mkIface hsc_env location maybe_old_iface | not omit_prags = emptyNameSet -- In the -O case, nothing is abstract | otherwise = mkNameSet [ getName thing | thing <- local_things - , isAbstractThing exports thing] + , not (mustExposeThing exports thing)] ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm thing | thing <- local_things, wantDeclFor exports abstract_tcs thing ] @@ -284,9 +286,9 @@ mkIface hsc_env location maybe_old_iface ; 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, @@ -331,8 +333,8 @@ 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 @@ -340,24 +342,33 @@ mkIface hsc_env location maybe_old_iface omit_prags = dopt Opt_OmitInterfacePragmas dflags -isAbstractThing :: NameSet -> TyThing -> Bool -isAbstractThing exports (ATyCon tc) - = not (isNewTyCon tc) - -- Always expose the rep for newtypes. This is for a - -- very annoying reason. 'Foreign import' is meant to +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 - -- So, for now anyway, we always expose the rep of newtypes. Sigh. - && not (any exported_data_con (tyConDataCons tc)) - -- Don't expose rep if no datacons are exported where - exported_data_con con = dataConName con `elemNameSet` exports + exported_data_con con + = any (`elemNameSet` exports) (dataConName con : field_names) + where + field_names = map fieldLabelName (dataConFieldLabels con) -isAbstractThing exports (AClass cls) = not (any exported_class_op (classSelIds cls)) - where -- Don't expose rep if no classs op is exported +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 -isAbstractThing exports other = False +mustExposeThing exports other = False + wantDeclFor :: NameSet -- User-exported things -> NameSet -- Abstract things @@ -524,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 @@ -638,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 @@ -691,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 @@ -734,7 +745,7 @@ 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} @@ -846,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)