diff options
| -rw-r--r-- | ghc/compiler/prelude/PrelInfo.lhs | 115 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrelMods.lhs | 3 | ||||
| -rw-r--r-- | ghc/compiler/rename/Rename.lhs | 10 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnIfaces.lhs | 9 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnMonad.lhs | 49 | ||||
| -rw-r--r-- | ghc/compiler/rename/RnNames.lhs | 15 |
6 files changed, 99 insertions, 102 deletions
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index dee0852bb4..95af63e27c 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -34,7 +34,7 @@ import CmdLineOpts ( opt_HideBuiltinNames, import FiniteMap ( FiniteMap, emptyFM, listToFM ) import Id ( mkTupleCon, GenId, Id(..) ) import Maybes ( catMaybes ) -import Name ( origName, nameOf ) +import Name ( moduleNamePair ) import RnHsSyn ( RnName(..) ) import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) import Type @@ -55,11 +55,13 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and \begin{code} builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos ) -type BuiltinNames = (FiniteMap FAST_STRING RnName, -- WiredIn Ids - FiniteMap FAST_STRING RnName) -- WiredIn TyCons +type BuiltinNames = (FiniteMap (FAST_STRING,Module) RnName, -- WiredIn Ids + FiniteMap (FAST_STRING,Module) RnName) -- WiredIn TyCons -- Two maps because "[]" is in both... -type BuiltinKeys = FiniteMap FAST_STRING (Unique, Name -> RnName) - -- Names with known uniques + +type BuiltinKeys = FiniteMap (FAST_STRING,Module) (Unique, Name -> RnName) + -- Names with known uniques + type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids builtinNameInfo @@ -131,11 +133,11 @@ builtinNameInfo ] id_keys = map id_key id_keys_infos - id_key (str, uniq, info) = (str, (uniq, RnImplicit)) + id_key (str_mod, uniq, info) = (str_mod, (uniq, RnImplicit)) assoc_id_infos = catMaybes (map assoc_info id_keys_infos) - assoc_info (str, uniq, Just info) = Just (uniq, info) - assoc_info (str, uniq, Nothing) = Nothing + assoc_info (str_mod, uniq, Just info) = Just (uniq, info) + assoc_info (str_mod, uniq, Nothing) = Nothing \end{code} @@ -224,13 +226,6 @@ synonym_tycons , stTyCon , stringTyCon ] - -pcTyConWiredInInfo :: TyCon -> (FAST_STRING, RnName) -pcTyConWiredInInfo tc = (nameOf (origName tc), WiredInTyCon tc) - -pcDataConWiredInInfo :: TyCon -> [(FAST_STRING, RnName)] -pcDataConWiredInInfo tycon - = [ (nameOf (origName con), WiredInId con) | con <- tyConDataCons tycon ] \end{code} The WiredIn Ids ... @@ -271,16 +266,27 @@ parallel_ids , parLocalId ] -pcIdWiredInInfo :: Id -> (FAST_STRING, RnName) -pcIdWiredInInfo id = (nameOf (origName id), WiredInId id) + +pcTyConWiredInInfo :: TyCon -> ((FAST_STRING,Module), RnName) +pcTyConWiredInInfo tc = (swap (moduleNamePair tc), WiredInTyCon tc) + +pcDataConWiredInInfo :: TyCon -> [((FAST_STRING,Module), RnName)] +pcDataConWiredInInfo tycon + = [ (swap (moduleNamePair con), WiredInId con) | con <- tyConDataCons tycon ] + +pcIdWiredInInfo :: Id -> ((FAST_STRING,Module), RnName) +pcIdWiredInInfo id = (swap (moduleNamePair id), WiredInId id) + +swap (x,y) = (y,x) \end{code} WiredIn primitive numeric operations ... \begin{code} primop_ids - = map primOpNameInfo allThePrimOps ++ map fn funny_name_primops + = map prim_fn allThePrimOps ++ map funny_fn funny_name_primops where - fn (op,s) = case (primOpNameInfo op) of (_,n) -> (s,n) + prim_fn op = case (primOpNameInfo op) of (s,n) -> ((s,pRELUDE),n) + funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((s,pRELUDE),n) funny_name_primops = [ (IntAddOp, SLIT("+#")) @@ -310,14 +316,14 @@ funny_name_primops Ids, Synonyms, Classes and ClassOps with builtin keys. For the Ids we may also have some builtin IdInfo. \begin{code} -id_keys_infos :: [(FAST_STRING, Unique, Maybe IdInfo)] +id_keys_infos :: [((FAST_STRING,Module), Unique, Maybe IdInfo)] id_keys_infos - = [ (SLIT("main"), mainIdKey, Nothing) - , (SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing) + = [ ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing) + , ((SLIT("mainPrimIO"),SLIT("Main")), mainPrimIOIdKey, Nothing) ] tysyn_keys - = [ (SLIT("IO"), (iOTyConKey, RnImplicitTyCon)) + = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon)) ] -- this "class_keys" list *must* include: @@ -325,41 +331,40 @@ tysyn_keys -- classes in "Class.standardClassKeys" (quite a few) class_keys - = [ (s, (k, RnImplicitClass)) | (s,k) <- - [ (SLIT("Eq"), eqClassKey) -- mentioned, derivable - , (SLIT("Eval"), evalClassKey) -- mentioned - , (SLIT("Ord"), ordClassKey) -- derivable - , (SLIT("Num"), numClassKey) -- mentioned, numeric - , (SLIT("Real"), realClassKey) -- numeric - , (SLIT("Integral"), integralClassKey) -- numeric - , (SLIT("Fractional"), fractionalClassKey) -- numeric - , (SLIT("Floating"), floatingClassKey) -- numeric - , (SLIT("RealFrac"), realFracClassKey) -- numeric - , (SLIT("RealFloat"), realFloatClassKey) -- numeric --- , (SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) - -- see *hack* in Rename - , (SLIT("Bounded"), boundedClassKey) -- derivable - , (SLIT("Enum"), enumClassKey) -- derivable - , (SLIT("Show"), showClassKey) -- derivable - , (SLIT("Read"), readClassKey) -- derivable - , (SLIT("Monad"), monadClassKey) - , (SLIT("MonadZero"), monadZeroClassKey) - , (SLIT("MonadPlus"), monadPlusClassKey) - , (SLIT("Functor"), functorClassKey) - , (SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish - , (SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish + = [ (str_mod, (k, RnImplicitClass)) | (str_mod,k) <- + [ ((SLIT("Eq"),pRELUDE), eqClassKey) -- mentioned, derivable + , ((SLIT("Eval"),pRELUDE), evalClassKey) -- mentioned + , ((SLIT("Ord"),pRELUDE), ordClassKey) -- derivable + , ((SLIT("Num"),pRELUDE), numClassKey) -- mentioned, numeric + , ((SLIT("Real"),pRELUDE), realClassKey) -- numeric + , ((SLIT("Integral"),pRELUDE), integralClassKey) -- numeric + , ((SLIT("Fractional"),pRELUDE), fractionalClassKey) -- numeric + , ((SLIT("Floating"),pRELUDE), floatingClassKey) -- numeric + , ((SLIT("RealFrac"),pRELUDE), realFracClassKey) -- numeric + , ((SLIT("RealFloat"),pRELUDE), realFloatClassKey) -- numeric + , ((SLIT("Ix"),iX), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) + , ((SLIT("Bounded"),pRELUDE), boundedClassKey) -- derivable + , ((SLIT("Enum"),pRELUDE), enumClassKey) -- derivable + , ((SLIT("Show"),pRELUDE), showClassKey) -- derivable + , ((SLIT("Read"),pRELUDE), readClassKey) -- derivable + , ((SLIT("Monad"),pRELUDE), monadClassKey) + , ((SLIT("MonadZero"),pRELUDE), monadZeroClassKey) + , ((SLIT("MonadPlus"),pRELUDE), monadPlusClassKey) + , ((SLIT("Functor"),pRELUDE), functorClassKey) + , ((SLIT("CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish + , ((SLIT("CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish ]] class_op_keys - = [ (s, (k, RnImplicit)) | (s,k) <- - [ (SLIT("fromInt"), fromIntClassOpKey) - , (SLIT("fromInteger"), fromIntegerClassOpKey) - , (SLIT("fromRational"), fromRationalClassOpKey) - , (SLIT("enumFrom"), enumFromClassOpKey) - , (SLIT("enumFromThen"), enumFromThenClassOpKey) - , (SLIT("enumFromTo"), enumFromToClassOpKey) - , (SLIT("enumFromThenTo"), enumFromThenToClassOpKey) - , (SLIT("=="), eqClassOpKey) + = [ (str_mod, (k, RnImplicit)) | (str_mod,k) <- + [ ((SLIT("fromInt"),pRELUDE), fromIntClassOpKey) + , ((SLIT("fromInteger"),pRELUDE), fromIntegerClassOpKey) + , ((SLIT("fromRational"),pRELUDE), fromRationalClassOpKey) + , ((SLIT("enumFrom"),pRELUDE), enumFromClassOpKey) + , ((SLIT("enumFromThen"),pRELUDE), enumFromThenClassOpKey) + , ((SLIT("enumFromTo"),pRELUDE), enumFromToClassOpKey) + , ((SLIT("enumFromThenTo"),pRELUDE),enumFromThenToClassOpKey) + , ((SLIT("=="),pRELUDE), eqClassOpKey) ]] \end{code} diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 02fd9f6fef..17bef6a65b 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -14,7 +14,7 @@ module PrelMods ( pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS, gLASGOW_ST, gLASGOW_MISC, pRELUDE_FB, - rATIO, + rATIO, iX, fromPrelude ) where @@ -36,6 +36,7 @@ pRELUDE_PS = SLIT("PreludePS") pRELUDE_TEXT = SLIT("PreludeText") rATIO = SLIT("Ratio") +iX = SLIT("Ix") fromPrelude :: FAST_STRING -> Bool fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude")) diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 47ed0fd245..409abef3c9 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -164,15 +164,9 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) pair_orig rn = (origName rn, rn) - -- we must ensure that the definitions of things in the BuiltinKey - -- table which may be *required* by the typechecker etc are read. - -- We *hack* in a requirement for Ix.Ix here - -- (it's the one thing that doesn't come from Prelude.<blah>) - must_haves - = (RnImplicitClass (mkBuiltinName ixClassKey SLIT("Ix") SLIT("Ix"))) - : [ name_fn (mkBuiltinName u pRELUDE str) - | (str, (u, name_fn)) <- fmToList b_keys, + = [ name_fn (mkBuiltinName u mod str) + | ((str, mod), (u, name_fn)) <- fmToList b_keys, str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ] in -- ASSERT (isEmptyBag orig_occ_dups) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 76fe13cdbd..72fb264f35 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -45,6 +45,7 @@ import Name ( moduleNamePair, origName, RdrName(..) ) import PprStyle -- ToDo:rm import Outputable -- ToDo:rm import PrelInfo ( builtinNameInfo ) +import PrelMods ( pRELUDE ) import Pretty import Maybes ( MaybeErr(..) ) import UniqFM ( emptyUFM ) @@ -759,12 +760,10 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return = case lookupTcRnEnv occ_env nm of Just _ -> True Nothing -> -- maybe it's builtin - case nm of - Qual _ _ -> False - Unqual n -> - case (lookupFM b_tc_names n) of + let str_mod = case nm of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_tc_names str_mod) of Just _ -> True - Nothing -> maybeToBool (lookupFM b_keys n) + Nothing -> maybeToBool (lookupFM b_keys str_mod) (b_tc_names, b_keys) -- pretty UGLY ... = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys) diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index eaaa862186..78f89184f7 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -56,6 +56,7 @@ import Name ( Module(..), RdrName(..), isQual, getOccName ) import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) +import PrelMods ( pRELUDE ) import Pretty ( Pretty(..), PrettyRep ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) @@ -368,30 +369,26 @@ lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr - = case rdr of - Qual _ _ -> -- builtin things *don't* have Qual names - lookup_or_create_implicit_val b_key imp_var us_var rdr - - Unqual n -> case (lookupFM b_names n) of - Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr - Just xx -> returnSST xx + = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_names str_mod) of + Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr + Just xx -> returnSST xx lookup_or_create_implicit_val b_key imp_var us_var rdr = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> case lookupFM implicit_val_fm rdr of Just implicit -> returnSST implicit Nothing -> - (case rdr of - Qual _ _ -> get_unique us_var - Unqual n -> case (lookupFM b_key n) of - Just (u,_) -> returnSST u - _ -> get_unique us_var - ) `thenSST` \ uniq -> + (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_key str_mod) of + Just (u,_) -> returnSST u + _ -> get_unique us_var + ) `thenSST` \ uniq -> let implicit = mkRnImplicit (mkImplicitName uniq rdr) new_val_fm = addToFM implicit_val_fm rdr implicit in - writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` + writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` returnSST implicit \end{code} @@ -429,13 +426,10 @@ lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr - = case rdr of - Qual _ _ -> -- builtin things *don't* have Qual names - lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr - - Unqual n -> case (lookupFM b_names n) of - Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr - Just xx -> returnSST xx + = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_names str_mod) of + Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr + Just xx -> returnSST xx lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> @@ -443,17 +437,16 @@ lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr Just implicit | check implicit -> returnSST implicit | otherwise -> fail Nothing -> - (case rdr of - Qual _ _ -> get_unique us_var - Unqual n -> case (lookupFM b_key n) of - Just (u,_) -> returnSST u - _ -> get_unique us_var - ) `thenSST` \ uniq -> + (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_key str_mod) of + Just (u,_) -> returnSST u + _ -> get_unique us_var + ) `thenSST` \ uniq -> let implicit = mk_implicit (mkImplicitName uniq rdr) new_tc_fm = addToFM implicit_tc_fm rdr implicit in - writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` + writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` returnSST implicit \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index ff9736afdc..921cf614f4 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -40,7 +40,7 @@ import Name ( RdrName(..), Name, isQual, mkTopLevName, origName, pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( fromPrelude, pRELUDE ) +import PrelMods ( fromPrelude, pRELUDE, rATIO, iX ) import Pretty import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) import TyCon ( tyConDataCons ) @@ -482,7 +482,7 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) getBuiltins _ mod maybe_spec - | not (fromPrelude mod) + | not ((fromPrelude mod) || mod == iX || mod == rATIO ) = (emptyBag, emptyBag, maybe_spec) getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec @@ -501,15 +501,20 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec all_vals = do_all_builtin (fmToList b_val_names) all_tcs = do_all_builtin (fmToList b_tc_names) + filter_mod = if fromPrelude mod then pRELUDE else mod + do_all_builtin [] = emptyBag - do_all_builtin ((str,rn):rest) + do_all_builtin (((str,mod),rn):rest) + | mod == filter_mod = (str, rn) `consBag` do_all_builtin rest + | otherwise + = do_all_builtin rest do_builtin [] = (emptyBag,emptyBag,[]) do_builtin (ie:ies) = let str = unqual_str (ie_name ie) in - case (lookupFM b_tc_names str) of -- NB: we favour the tycon/class FM... + case (lookupFM b_tc_names (str,mod)) of -- NB: we favour the tycon/class FM... Just rn -> case (ie,rn) of (IEThingAbs _, WiredInTyCon tc) -> (vals, (str, rn) `consBag` tcs, ies_left) @@ -526,7 +531,7 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec _ -> panic "importing builtin names (1)" Nothing -> - case (lookupFM b_val_names str) of + case (lookupFM b_val_names (str,mod)) of Nothing -> (vals, tcs, ie:ies_left) Just rn -> case (ie,rn) of (IEVar _, WiredInId _) |