Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
30cf375e
Commit
30cf375e
authored
May 20, 1996
by
partain
Browse files
[project @ 1996-05-20 13:15:10 by partain]
Sansom changes through 960520
parent
dabfa71f
Changes
6
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 prim
OpNameInfo
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)
= [ (s
tr_mod
, (k, RnImplicit)) | (s
tr_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 _)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment