X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=11235cef2e07e8e1e191f8a62891c1f78bb2089c;hp=7901f7c5142325b9ca5a7e702e050e305394d46e;hb=2a8cdc3aee5997374273e27365f92c161aca8453;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7901f7c..11235ce 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -176,7 +176,8 @@ compiled with -O. I think this is the case.] #include "HsVersions.h" import IfaceSyn -- All of it -import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext ) +import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext, + ifaceTyConOccName ) import LoadIface ( readIface, loadInterface, pprModIface ) import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), @@ -190,20 +191,24 @@ import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..), isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon, - tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) + tyConArity, tyConTyVars, algTyConRhs, tyConExtName, + tyConFamInst_maybe ) import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks, - dataConTyCon, dataConIsInfix, dataConUnivTyVars, dataConExTyVars, dataConEqSpec, - dataConTheta, dataConOrigArgTys ) + dataConTyCon, dataConIsInfix, dataConUnivTyVars, + dataConExTyVars, dataConEqSpec, dataConTheta, + dataConOrigArgTys ) import Type ( TyThing(..), splitForAllTys, funResultTy ) import TcType ( deNoteType ) import TysPrim ( alphaTyVars ) import InstEnv ( Instance(..) ) +import FamInstEnv ( FamInst(..) ) import TcRnMonad import HscTypes ( ModIface(..), ModDetails(..), - ModGuts(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..), + ModGuts(..), HscEnv(..), hscEPS, Dependencies(..), + FixItem(..), ModSummary(..), msHiFilePath, mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, - typeEnvElts, + typeEnvElts, GenAvailInfo(..), availName, ExternalPackageState(..), Usage(..), IsBootInterface, @@ -228,7 +233,6 @@ import Module import Outputable import BasicTypes ( Version, initialVersion, bumpVersion, isAlwaysActive, Activation(..), RecFlag(..), boolToRecFlag ) -import Outputable import Util ( createDirectoryHierarchy, directoryOf, sortLe, seqList, lengthIs ) import BinIface ( writeBinIface ) import Unique ( Unique, Uniquable(..) ) @@ -264,17 +268,18 @@ mkIface :: HscEnv -- is identical, so no need to write it mkIface hsc_env maybe_old_iface - (ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_usages = usages, - mg_deps = deps, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = src_deprecs }) - (ModDetails{ md_insts = insts, - md_rules = rules, - md_types = type_env, - md_exports = exports }) + (ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_usages = usages, + mg_deps = deps, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_deprecs = src_deprecs }) + (ModDetails{ md_insts = insts, + md_fam_insts = fam_insts, + md_rules = rules, + md_types = type_env, + md_exports = exports }) -- NB: notice that mkIface does not look at the bindings -- only at the TypeEnv. The previous Tidy phase has @@ -292,10 +297,14 @@ mkIface hsc_env maybe_old_iface -- Don't put implicit Ids and class tycons in the interface file -- Nor wired-in things; the compiler knows about them anyhow - ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] - ; deprecs = mkIfaceDeprec src_deprecs - ; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules - ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts + ; fixities = [ (occ,fix) + | FixItem occ fix _ <- nameEnvElts fix_env] + ; deprecs = mkIfaceDeprec src_deprecs + ; iface_rules = map (coreRuleToIfaceRule + ext_nm_lhs ext_nm_rhs) rules + ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts + ; iface_fam_insts = map (famInstToIfaceFamInst ext_nm_lhs) + fam_insts ; intermediate_iface = ModIface { mi_module = this_mod, @@ -304,6 +313,7 @@ mkIface hsc_env maybe_old_iface mi_usages = usages, mi_exports = mkIfaceExports exports, mi_insts = sortLe le_inst iface_insts, + mi_fam_insts= sortLe le_fam_inst iface_fam_insts, mi_rules = sortLe le_rule iface_rules, mi_fixities = fixities, mi_deprecs = deprecs, @@ -337,11 +347,13 @@ mkIface hsc_env maybe_old_iface ; return (new_iface, no_change_at_all) } where - r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 - i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 + r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 + i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 + i1 `le_fam_inst` i2 = ifFamInstTyConOcc i1 <= ifFamInstTyConOcc i2 dflags = hsc_dflags hsc_env deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) + ifFamInstTyConOcc = ifaceTyConOccName . ifFamInstTyCon ----------------------------- @@ -377,17 +389,17 @@ mkExtNameFn hsc_env eps this_mod occ = nameOccName name par_occ = nameOccName (nameParent name) -- The version of the *parent* is the one want - vers = lookupVersion mod par_occ + vers = lookupVersion mod par_occ occ - lookupVersion :: Module -> OccName -> Version + lookupVersion :: Module -> OccName -> OccName -> Version -- Even though we're looking up a home-package thing, in -- one-shot mode the imported interfaces may be in the PIT - lookupVersion mod occ - = mi_ver_fn iface occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr occ) + lookupVersion mod par_occ occ + = mi_ver_fn iface par_occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr par_occ <+> ppr occ) where iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` - pprPanic "lookupVers2" (ppr mod <+> ppr occ) + pprPanic "lookupVers2" (ppr mod <+> ppr par_occ <+> ppr occ) --------------------- @@ -785,44 +797,42 @@ checkOldIface hsc_env mod_summary source_unchanged maybe_iface } check_old_iface hsc_env mod_summary source_unchanged maybe_iface - = -- CHECK WHETHER THE SOURCE HAS CHANGED - ifM (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - `thenM_` + = do -- CHECK WHETHER THE SOURCE HAS CHANGED + { ifM (not source_unchanged) + (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) -- If the source has changed and we're in interactive mode, avoid reading -- an interface; just return the one we might have been supplied with. - getGhcMode `thenM` \ ghc_mode -> - if (ghc_mode == Interactive || ghc_mode == JustTypecheck) - && not source_unchanged then - returnM (outOfDate, maybe_iface) - else - - case maybe_iface of { - Just old_iface -> do -- Use the one we already have - recomp <- checkVersions hsc_env source_unchanged old_iface - return (recomp, Just old_iface) - - ; Nothing -> + ; ghc_mode <- getGhcMode + ; if (ghc_mode == Interactive || ghc_mode == JustTypecheck) + && not source_unchanged then + return (outOfDate, maybe_iface) + else + case maybe_iface of { + Just old_iface -> do -- Use the one we already have + { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) + ; recomp <- checkVersions hsc_env source_unchanged old_iface + ; return (recomp, Just old_iface) } + + ; Nothing -> do -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it - let - iface_path = msHiFilePath mod_summary - in - readIface (ms_mod mod_summary) iface_path False `thenM` \ read_result -> - case read_result of { - Failed err -> -- Old interface file not found, or garbled; give up - traceIf (text "FYI: cannot read old interface file:" - $$ nest 4 err) `thenM_` - returnM (outOfDate, Nothing) + { let iface_path = msHiFilePath mod_summary + ; read_result <- readIface (ms_mod mod_summary) iface_path False + ; case read_result of { + Failed err -> do -- Old interface file not found, or garbled; give up + { traceIf (text "FYI: cannot read old interface file:" + $$ nest 4 err) + ; return (outOfDate, Nothing) } - ; Succeeded iface -> + ; Succeeded iface -> do -- We have got the old iface; check its versions - checkVersions hsc_env source_unchanged iface `thenM` \ recomp -> - returnM (recomp, Just iface) - }} + { traceIf (text "Read the interface file" <+> text iface_path) + ; recomp <- checkVersions hsc_env source_unchanged iface + ; returnM (recomp, Just iface) + }}}}} \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -855,7 +865,9 @@ checkVersions hsc_env source_unchanged iface -- (in which case we are done with this module) or it'll fail (in which -- case we'll compile the module from scratch anyhow). -- - -- We do this regardless of compilation mode + -- We do this regardless of compilation mode, although in --make mode + -- all the dependent modules should be in the HPT already, so it's + -- quite redundant ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } ; let this_pkg = thisPackage (hsc_dflags hsc_env) @@ -997,10 +1009,12 @@ tyThingToIfaceDecl ext (AClass clas) ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, ifFDs = map toIfaceFD clas_fds, + ifATs = map (tyThingToIfaceDecl ext . ATyCon) clas_ats, ifSigs = map toIfaceClassOp op_stuff, ifRec = boolToRecFlag (isRecursiveTyCon tycon) } where - (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas + (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas tycon = classTyCon clas toIfaceClassOp (sel_id, def_meth) @@ -1031,7 +1045,8 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifGeneric = tyConHasGenerics tycon } + ifGeneric = tyConHasGenerics tycon, + ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} | isForeignTyCon tycon = IfaceForeign { ifName = getOccName tycon, @@ -1045,7 +1060,8 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifCons = IfAbstractTyCon, ifGadtSyntax = False, ifGeneric = False, - ifRec = NonRecursive} + ifRec = NonRecursive, + ifFamInst = Nothing } | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where @@ -1073,12 +1089,18 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), ifConEqSpec = to_eq_spec (dataConEqSpec data_con), ifConCtxt = toIfaceContext ext (dataConTheta data_con), - ifConArgTys = map (toIfaceType ext) (dataConOrigArgTys data_con), - ifConFields = map getOccName (dataConFieldLabels data_con), + ifConArgTys = map (toIfaceType ext) + (dataConOrigArgTys data_con), + ifConFields = map getOccName + (dataConFieldLabels data_con), ifConStricts = dataConStrictMarks data_con } to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] + famInstToIface Nothing = Nothing + famInstToIface (Just (famTyCon, instTys)) = + Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys) + tyThingToIfaceDecl ext (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier @@ -1098,6 +1120,17 @@ instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) -------------------------- +famInstToIfaceFamInst :: (Name -> IfaceExtName) -> FamInst -> IfaceFamInst +famInstToIfaceFamInst ext_lhs fi@(FamInst { fi_tycon = tycon, + fi_fam = fam, fi_tcs = mb_tcs }) + = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext_lhs tycon + , ifFamInstFam = ext_lhs fam + , ifFamInstTys = map do_rough mb_tcs } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) + +-------------------------- toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] toIfaceIdInfo ext id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,