X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=4976e1fc8f8d5029f79c2c70d21dbbb9e8dbe5b7;hp=3f1ee46e1f60499e0884956cdfc0bed3c5fdcd88;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hpb=a08b4f85df5fbebc237bb7798cabe3812500e921 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 3f1ee46..4976e1f 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -56,6 +56,7 @@ import LoadIface import Id import IdInfo import NewDemand +import Annotations import CoreSyn import CoreFVs import Class @@ -66,6 +67,7 @@ import TcType import InstEnv import FamInstEnv import TcRnMonad +import HsSyn import HscTypes import Finder import DynFlags @@ -99,7 +101,6 @@ import Control.Monad import Data.List import Data.IORef import System.FilePath -import System.Exit ( exitWith, ExitCode(..) ) \end{code} @@ -115,8 +116,9 @@ mkIface :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it -> ModDetails -- The trimmed, tidied interface -> ModGuts -- Usages, deprecations, etc - -> IO (ModIface, -- The new one - Bool) -- True <=> there was an old Iface, and the + -> IO (Messages, + Maybe (ModIface, -- The new one + Bool)) -- True <=> there was an old Iface, and the -- new one is identical, so no need -- to write it @@ -133,7 +135,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details = mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names deps rdr_env fix_env warns hpc_info dir_imp_mods mod_details - + -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). @@ -141,8 +143,7 @@ mkIfaceTc :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it -> ModDetails -- gotten from mkBootModDetails, probably -> TcGblEnv -- Usages, deprecations, etc - -> IO (ModIface, - Bool) + -> IO (Messages, Maybe (ModIface, Bool)) mkIfaceTc hsc_env maybe_old_fingerprint mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, @@ -213,13 +214,14 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameEnv FixItem -> Warnings -> HpcInfo -> ImportedMods -> ModDetails - -> IO (ModIface, Bool) + -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info dir_imp_mods ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, + md_anns = anns, md_vect_info = vect_info, md_types = type_env, md_exports = exports } @@ -265,6 +267,7 @@ mkIface_ hsc_env maybe_old_fingerprint mi_fixities = fixities, mi_warns = warns, + mi_anns = mkIfaceAnnotations anns, mi_globals = Just rdr_env, -- Left out deliberately: filled in by addVersionInfo @@ -302,10 +305,9 @@ mkIface_ hsc_env maybe_old_fingerprint | r <- iface_rules , isNothing (ifRuleOrph r) ] - ; when (not (isEmptyBag orph_warnings)) - (do { printErrorsAndWarnings dflags errs_and_warns - ; when (errorsFound dflags errs_and_warns) - (exitWith (ExitFailure 1)) }) + ; if errorsFound dflags errs_and_warns + then return ( errs_and_warns, Nothing ) + else do { -- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) @@ -319,7 +321,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- with the old GlobalRdrEnv (mi_globals). ; let final_iface = new_iface{ mi_globals = Just rdr_env } - ; return (final_iface, no_change_at_all) } + ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }} where r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2 @@ -370,7 +372,7 @@ mkHashFun mkHashFun hsc_env eps = \name -> let - mod = nameModule name + mod = ASSERT2( isExternalName name, ppr name ) nameModule name occ = nameOccName name iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` pprPanic "lookupVers2" (ppr mod <+> ppr occ) @@ -411,8 +413,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls , let out = localOccs $ freeNamesDeclABI abi ] + name_module n = ASSERT( isExternalName n ) nameModule n localOccs = map (getUnique . getParent . getOccName) - . filter ((== this_mod) . nameModule) + . filter ((== this_mod) . name_module) . nameSetToList where getParent occ = lookupOccEnv parent_map occ `orElse` occ @@ -442,7 +445,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls | isWiredInName name = putNameLiterally bh name -- wired-in names don't have fingerprints | otherwise - = let hash | nameModule name /= this_mod = global_hash_fn name + = ASSERT( isExternalName name ) + let hash | nameModule name /= this_mod = global_hash_fn name | otherwise = snd (lookupOccEnv local_env (getOccName name) `orElse` pprPanic "urk! lookup local fingerprint" @@ -698,9 +702,9 @@ lookupOccEnvL env k = lookupOccEnv env k `orElse` [] -- used when we want to fingerprint a structure without depending on the -- fingerprints of external Names that it refers to. putNameLiterally :: BinHandle -> Name -> IO () -putNameLiterally bh name = do - put_ bh $! nameModule name - put_ bh $! nameOccName name +putNameLiterally bh name = ASSERT( isExternalName name ) + do { put_ bh $! nameModule name + ; put_ bh $! nameOccName name } computeFingerprint :: Binary a => DynFlags @@ -818,7 +822,10 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names | otherwise = case nameModule_maybe name of Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map - Just mod -> extendModuleEnv_C (++) mv_map mod [occ] + Just mod -> -- We use this fiddly lambda function rather than + -- (++) as the argument to extendModuleEnv_C to + -- avoid quadratic behaviour (trac #2680) + extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ] where occ = nameOccName name -- We want to create a Usage for a home module if @@ -900,6 +907,17 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names \end{code} \begin{code} +mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation] +mkIfaceAnnotations = map mkIfaceAnnotation + +mkIfaceAnnotation :: Annotation -> IfaceAnnotation +mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation { + ifAnnotatedTarget = fmap nameOccName target, + ifAnnotatedValue = serialized + } +\end{code} + +\begin{code} mkIfaceExports :: [AvailInfo] -> [(Module, [GenAvailInfo OccName])] -- Group by module and sort by occurrence @@ -927,10 +945,12 @@ mkIfaceExports exports -- else the plusFM will simply discard one! They -- should have been combined by now. add env (Avail n) - = add_one env (nameModule n) (Avail (nameOccName n)) + = ASSERT( isExternalName n ) + add_one env (nameModule n) (Avail (nameOccName n)) add env (AvailTC tc ns) - = foldl add_for_mod env mods + = ASSERT( all isExternalName ns ) + foldl add_for_mod env mods where tc_occ = nameOccName tc mods = nub (map nameModule ns) @@ -1096,8 +1116,8 @@ checkDependencies hsc_env summary iface orM = foldr f (return False) where f m rest = do b <- m; if b then return True else rest - dep_missing (L _ mod) = do - find_res <- liftIO $ findImportedModule hsc_env mod Nothing + dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do + find_res <- liftIO $ findImportedModule hsc_env mod pkg case find_res of Found _ mod | pkg == this_pkg @@ -1290,8 +1310,8 @@ tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType syn_tyki, + ifSynRhs = syn_rhs, + ifSynKind = syn_ki, ifFamInst = famInstToIface (tyConFamInst_maybe tycon) } @@ -1312,9 +1332,10 @@ tyThingToIfaceDecl (ATyCon tycon) | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where tyvars = tyConTyVars tycon - (syn_isOpen, syn_tyki) = case synTyConRhs tycon of - OpenSynTyCon ki _ -> (True , ki) - SynonymTyCon ty -> (False, ty) + (syn_rhs, syn_ki) + = case synTyConRhs tycon of + OpenSynTyCon ki _ -> (Nothing, toIfaceType ki) + SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty)) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) @@ -1367,7 +1388,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, do_rough (Just n) = Just (toIfaceTyCon_name n) dfun_name = idName dfun_id - mod = nameModule dfun_name + mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name is_local name = nameIsLocalOrFrom mod name -- Compute orphanhood. See Note [Orphans] in IfaceSyn