From 66579ff945831c5fc9a17c58c722ff01f2268d76 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 3 Oct 2008 13:53:34 +0000 Subject: [PATCH] Add ASSERTs to all calls of nameModule nameModule fails on an InternalName. These ASSERTS tell you which call failed. --- compiler/basicTypes/DataCon.lhs | 2 +- compiler/basicTypes/RdrName.lhs | 8 +++++--- compiler/deSugar/DsMeta.hs | 4 +++- compiler/ghci/ByteCodeLink.lhs | 2 +- compiler/ghci/InteractiveUI.hs | 14 +++++++++----- compiler/iface/BinIface.hs | 2 +- compiler/iface/IfaceEnv.lhs | 3 ++- compiler/iface/LoadIface.lhs | 3 ++- compiler/iface/MkIface.lhs | 22 +++++++++++++--------- compiler/iface/TcIface.lhs | 9 ++++++--- compiler/main/HscTypes.lhs | 6 +++--- compiler/prelude/TysWiredIn.lhs | 8 +++++--- compiler/rename/RnNames.lhs | 9 +++++---- compiler/typecheck/Inst.lhs | 3 ++- compiler/typecheck/TcSplice.lhs | 2 +- compiler/types/Generics.lhs | 2 +- 16 files changed, 60 insertions(+), 39 deletions(-) diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index e7ffb58..5a67ffe 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -800,7 +800,7 @@ dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) where name = dataConName dc - mod = nameModule name + mod = ASSERT( isExternalName name ) nameModule name \end{code} \begin{code} diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 5baebbc..6b28786 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -143,7 +143,8 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns = Orig (nameModule n) +setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n ) + Orig (nameModule n) (setOccNameSpace ns (nameOccName n)) \end{code} @@ -163,7 +164,8 @@ mkOrig mod occ = Orig mod occ -- is derived from that of it's parent using the supplied function mkDerivedRdrName :: Name -> (OccName -> OccName) -> RdrName mkDerivedRdrName parent mk_occ - = mkOrig (nameModule parent) (mk_occ (nameOccName parent)) + = ASSERT2( isExternalName parent, ppr parent ) + mkOrig (nameModule parent) (mk_occ (nameOccName parent)) --------------- -- These two are used when parsing source files @@ -556,7 +558,7 @@ hideSomeUnquals rdr_env occs qual_gre gre@(GRE { gre_name = name, gre_prov = LocalDef }) = gre { gre_prov = Imported [imp_spec] } where -- Local defs get transfomed to (fake) imported things - mod = moduleName (nameModule name) + mod = ASSERT2( isExternalName name, ppr name) moduleName (nameModule name) imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec } decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 3659498..554a945 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -28,6 +28,8 @@ module DsMeta( dsBracket, quoteExpName, quotePatName ) where +#include "HsVersions.h" + import {-# SOURCE #-} DsExpr ( dsExpr ) import MatchLit @@ -949,7 +951,7 @@ globalVar name ; MkC uni <- coreIntLit (getKey (getUnique name)) ; rep2 mkNameLName [occ,uni] } where - mod = nameModule name + mod = ASSERT( isExternalName name) nameModule name name_mod = moduleNameString (moduleName mod) name_pkg = packageIdString (modulePackageId mod) name_occ = nameOccName name diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 54dff1d..fabd5d1 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -265,7 +265,7 @@ nameToCLabel n suffix else qual_name where pkgid = modulePackageId mod - mod = nameModule n + mod = ASSERT( isExternalName n ) nameModule n package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod))) module_part = unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) occ_part = unpackFS (zEncodeFS (occNameFS (nameOccName n))) diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index e0dd5cc..b1baecd 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -1088,7 +1088,8 @@ checkModule m = do case GHC.moduleInfo r of cm | Just scope <- GHC.modInfoTopLevelScope cm -> let - (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope + (local,global) = ASSERT( all isExternalName scope ) + partition ((== modl) . GHC.moduleName . GHC.nameModule) scope in (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) @@ -1275,7 +1276,8 @@ browseModule bang modl exports_only = do -- We would like to improve this; see #1799. sorted_names = loc_sort local ++ occ_sort external where - (local,external) = partition ((==modl) . nameModule) names + (local,external) = ASSERT( all isExternalName names ) + partition ((==modl) . nameModule) names occ_sort = sortBy (compare `on` nameOccName) -- try to sort by src location. If the first name in -- our list has a good source location, then they all should. @@ -1896,7 +1898,7 @@ wantNameFromInterpretedModule noCanDo str and_then = case names of [] -> return () (n:_) -> do - let modl = GHC.nameModule n + let modl = ASSERT( isExternalName n ) GHC.nameModule n if not (GHC.isExternalName n) then noCanDo n $ ppr n <> text " is not defined in an interpreted module" @@ -2068,7 +2070,8 @@ breakSwitch (arg1:rest) wantNameFromInterpretedModule noCanDo arg1 $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc - then findBreakAndSet (GHC.nameModule name) $ + then ASSERT( isExternalName name ) + findBreakAndSet (GHC.nameModule name) $ findBreakByCoord (Just (GHC.srcLocFile loc)) (GHC.srcLocLine loc, GHC.srcLocCol loc) @@ -2215,7 +2218,8 @@ list2 [arg] = do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) if GHC.isGoodSrcLoc loc then do - tickArray <- getTickArray (GHC.nameModule name) + tickArray <- ASSERT( isExternalName name ) + getTickArray (GHC.nameModule name) let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc)) (GHC.srcLocLine loc, GHC.srcLocCol loc) tickArray diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index c155fb2..58c8373 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -263,7 +263,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do - let mod = nameModule name + let mod = ASSERT2( isExternalName name, ppr name ) nameModule name put_ bh (modulePackageId mod, moduleName mod, nameOccName name) diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 5dcab1e..20d7327 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -212,7 +212,8 @@ lookupOrigNameCache nc mod occ -- The normal case extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache extendOrigNameCache nc name - = extendNameCache nc (nameModule name) (nameOccName name) name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache extendNameCache nc mod occ name diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index d7089f1..50fa933 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -120,7 +120,8 @@ loadInterfaceForName doc name { this_mod <- getModule ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) } - ; initIfaceTcRn $ loadSysInterface doc (nameModule name) + ; ASSERT2( isExternalName name, ppr name ) + initIfaceTcRn $ loadSysInterface doc (nameModule name) } -- | An 'IfM' function to load the home interface for a wired-in thing, diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 1346a9a..2aa614c 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -370,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) @@ -411,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 @@ -442,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" @@ -698,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 @@ -927,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) @@ -1368,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 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 32735a4..d9072f8 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -127,7 +127,8 @@ checkWiredInTyCon tc = return () | otherwise = do { mod <- getModule - ; unless (mod == nameModule tc_name) + ; ASSERT( isExternalName tc_name ) + unless (mod == nameModule tc_name) (initIfaceTcRn (loadWiredInHomeIface tc_name)) -- Don't look for (non-existent) Float.hi when -- compiling Float.lhs, which mentions Float of course @@ -144,7 +145,8 @@ importDecl name do { traceIf nd_doc -- Load the interface, which should populate the PTE - ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem + ; mb_iface <- ASSERT2( isExternalName name, ppr name ) + loadInterface nd_doc (nameModule name) ImportBySystem ; case mb_iface of { Failed err_msg -> return (Failed err_msg) ; Succeeded _ -> do @@ -1047,7 +1049,8 @@ ifCheckWiredInThing name -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in -- the HPT, so without the test we'll demand-load it into the PIT! -- C.f. the same test in checkWiredInTyCon above - ; unless (mod == nameModule name) + ; ASSERT2( isExternalName name, ppr name ) + unless (mod == nameModule name) (loadWiredInHomeIface name) } tcIfaceTyCon :: IfaceTyCon -> IfL TyCon diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 6d43ea8..83dda3f 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -105,7 +105,7 @@ import {-# SOURCE #-} InteractiveEval ( Resume ) #endif import RdrName -import Name ( Name, NamedThing, getName, nameOccName, nameModule ) +import Name import NameEnv import NameSet import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, @@ -1160,7 +1160,7 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) | otherwise = panic "mkPrintUnqualified" where - right_name gre = nameModule (gre_name gre) == mod + right_name gre = nameModule_maybe (gre_name gre) == Just mod unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env qual_gres = filter right_name (lookupGlobalRdrEnv env occ) @@ -1330,7 +1330,7 @@ lookupType dflags hpt pte name lookupNameEnv (md_types (hm_details hm)) name | otherwise = lookupNameEnv pte name - where mod = nameModule name + where mod = ASSERT( isExternalName name ) nameModule name this_pkg = thisPackage dflags -- | As 'lookupType', but with a marginally easier-to-use interface diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 3e49d5e..b2f5b3f 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -56,6 +56,8 @@ module TysWiredIn ( parrTyCon_RDR, parrTyConName ) where +#include "HsVersions.h" + import {-# SOURCE #-} MkId( mkDataConIds ) -- friends: @@ -66,8 +68,7 @@ import TysPrim import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) import RdrName -import Name ( Name, BuiltInSyntax(..), nameUnique, nameOccName, - nameModule, mkWiredInName ) +import Name import OccName ( mkTcOccFS, mkDataOccFS, mkTupleOcc, mkDataConWorkerOcc, tcName, dataName ) import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) @@ -254,7 +255,8 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon (mkDataConIds bogus_wrap_name wrk_name data_con) - modu = nameModule dc_name + modu = ASSERT( isExternalName dc_name ) + nameModule dc_name wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) wrk_key = incrUnique (nameUnique dc_name) wrk_name = mkWiredInName modu wrk_occ wrk_key diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index f29b06f..68286b7 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -1006,7 +1006,7 @@ finishWarnings dflags mod_warn tcg_env (parens imp_msg) <> colon, (ppr deprec_txt) ]) where - name_mod = nameModule name + name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name imp_mod = importSpecModule imp_spec imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra extra | imp_mod == moduleName name_mod = empty @@ -1024,7 +1024,7 @@ lookupImpDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable -> GlobalRdrElt -> Maybe WarningTxt -- The name is definitely imported, so look in HPT, PIT lookupImpDeprec dflags hpt pit gre - = case lookupIfaceByModule dflags hpt pit (nameModule name) of + = case lookupIfaceByModule dflags hpt pit mod of Just iface -> mi_warn_fn iface name `mplus` -- Bleat if the thing, *or case gre_par gre of ParentIs p -> mi_warn_fn iface p -- its parent*, is warn'd @@ -1032,7 +1032,8 @@ lookupImpDeprec dflags hpt pit gre Nothing -> Nothing -- See Note [Used names with interface not loaded] where - name = gre_name gre + name = gre_name gre + mod = ASSERT2( isExternalName name, ppr name ) nameModule name \end{code} Note [Used names with interface not loaded] @@ -1343,7 +1344,7 @@ printMinimalImports imps where all_used avail_occs = all (`elem` map nameOccName ns) avail_occs doc = text "Compute minimal imports from" <+> ppr n - n_mod = nameModule n + n_mod = ASSERT( isExternalName n ) nameModule n \end{code} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 47629db..b5eeff0 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -859,7 +859,8 @@ record_dfun_usage :: Id -> TcRn () record_dfun_usage dfun_id = do { hsc_env <- getTopEnv ; let dfun_name = idName dfun_id - dfun_mod = nameModule dfun_name + dfun_mod = ASSERT( isExternalName dfun_name ) + nameModule dfun_name ; if isInternalName dfun_name || -- Internal name => defined in this module modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env) then return () -- internal, or in another package diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 55e0975..7139fa8 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -940,7 +940,7 @@ reifyName thing -- have free variables, we may need to generate NameL's for them. where name = getName thing - mod = nameModule name + mod = ASSERT( isExternalName name ) nameModule name pkg_str = packageIdString (modulePackageId mod) mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index c0fb4fc..01632d3 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -398,7 +398,7 @@ mkGenericNames tycon where tc_name = tyConName tycon tc_occ = nameOccName tc_name - tc_mod = nameModule tc_name + tc_mod = ASSERT( isExternalName tc_name ) nameModule tc_name from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) \end{code} -- 1.7.10.4