Skip to content

GitLab

Commit 30cf375e authored by partain's avatar partain
Browse files

[project @ 1996-05-20 13:15:10 by partain] 

Sansom changes through 960520
parent dabfa71f
Hide whitespace changes
Inline Side-by-side
ghc/compiler/prelude/PrelInfo.lhs
View file @ 30cf375e
......@@ -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}
......
ghc/compiler/prelude/PrelMods.lhs
View file @ 30cf375e
......@@ -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"))
......
ghc/compiler/rename/Rename.lhs
View file @ 30cf375e
......@@ -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)
......
ghc/compiler/rename/RnIfaces.lhs
View file @ 30cf375e
......@@ -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)
......
ghc/compiler/rename/RnMonad.lhs
View file @ 30cf375e
......@@ -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}
......
ghc/compiler/rename/RnNames.lhs
View file @ 30cf375e
......@@ -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 _)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment