X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=2aa614cde7816dac154852098bdc46c10a18b154;hp=17254d65141348e92e37478037ed3f165e0fdab9;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=cb8f0e566e65c1e54de43174668fa3531970c8f5 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 17254d6..2aa614c 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -92,12 +92,14 @@ import Maybes import ListSetOps import Binary import Fingerprint +import Bag import Panic import Control.Monad import Data.List import Data.IORef import System.FilePath +import System.Exit ( exitWith, ExitCode(..) ) \end{code} @@ -282,17 +284,32 @@ mkIface_ hsc_env maybe_old_fingerprint mi_fix_fn = mkIfaceFixCache fixities } } - ; (new_iface, no_change_at_all, pp_orphs) + ; (new_iface, no_change_at_all) <- {-# SCC "versioninfo" #-} addFingerprints hsc_env maybe_old_fingerprint intermediate_iface decls - -- Debug printing - ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags) - (printDump (expectJust "mkIface" pp_orphs)) + -- Warn about orphans + ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans + | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns + | otherwise = emptyBag + errs_and_warns = (orph_warnings, emptyBag) + unqual = mkPrintUnqualified dflags rdr_env + inst_warns = listToBag [ instOrphWarn unqual d + | (d,i) <- insts `zip` iface_insts + , isNothing (ifInstOrph i) ] + rule_warns = listToBag [ ruleOrphWarn unqual this_mod r + | r <- iface_rules + , isNothing (ifRuleOrph r) ] + + ; when (not (isEmptyBag orph_warnings)) + (do { printErrorsAndWarnings dflags errs_and_warns -- XXX + ; when (errorsFound dflags errs_and_warns) + (exitWith (ExitFailure 1)) }) -- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) - + + -- Debug printing ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" (pprModIface new_iface) @@ -353,7 +370,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) @@ -373,9 +390,8 @@ addFingerprints -> ModIface -- The new interface (lacking decls) -> [IfaceDecl] -- The new decls -> IO (ModIface, -- Updated interface - Bool, -- True <=> no changes at all; + Bool) -- True <=> no changes at all; -- no need to write Iface - Maybe SDoc) -- Warnings about orphans addFingerprints hsc_env mb_old_fingerprint iface0 new_decls = do @@ -395,8 +411,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 @@ -410,7 +427,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls where n = ifName d -- strongly-connected groups of declarations, in dependency order - groups = stronglyConnComp edges + groups = stronglyConnCompFromEdgedVertices edges global_hash_fn = mkHashFun hsc_env eps @@ -426,7 +443,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" @@ -548,7 +566,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls mi_decls = sorted_decls, mi_hash_fn = lookupOccEnv local_env } -- - return (final_iface, no_change_at_all, pp_orphs) + return (final_iface, no_change_at_all) where this_mod = mi_module iface0 @@ -560,7 +578,6 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- non-orphans? fam_insts = mi_fam_insts iface0 fix_fn = mi_fix_fn iface0 - pp_orphs = pprOrphans orph_insts orph_rules getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] @@ -683,9 +700,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 @@ -720,18 +737,19 @@ oldMD5 dflags bh = do return $! readHexFingerprint hash_str -} -pprOrphans :: [IfaceInst] -> [IfaceRule] -> Maybe SDoc -pprOrphans insts rules - | null insts && null rules = Nothing - | otherwise - = Just $ vcat [ - if null insts then empty else - hang (ptext (sLit "Warning: orphan instances:")) - 2 (vcat (map ppr insts)), - if null rules then empty else - hang (ptext (sLit "Warning: orphan rules:")) - 2 (vcat (map ppr rules)) - ] +instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg +instOrphWarn unqual inst + = mkWarnMsg (getSrcSpan inst) unqual $ + hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst) + +ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg +ruleOrphWarn unqual mod rule + = mkWarnMsg silly_loc unqual $ + ptext (sLit "Orphan rule:") <+> ppr rule + where + silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0) + -- We don't have a decent SrcSpan for a Rule, not even the CoreRule + -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to ---------------------- -- mkOrphMap partitions instance decls or rules into @@ -911,10 +929,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) @@ -1274,8 +1294,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) } @@ -1296,9 +1316,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) @@ -1351,7 +1372,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