summaryrefslogtreecommitdiff
path: root/ghc/compiler/prelude
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/prelude')
-rw-r--r--ghc/compiler/prelude/PrelInfo.lhs319
-rw-r--r--ghc/compiler/prelude/PrelMods.lhs101
-rw-r--r--ghc/compiler/prelude/PrelNames.lhs341
-rw-r--r--ghc/compiler/prelude/PrelRules.lhs27
-rw-r--r--ghc/compiler/prelude/PrimOp.lhs19
-rw-r--r--ghc/compiler/prelude/ThinAir.lhs109
-rw-r--r--ghc/compiler/prelude/TysPrim.lhs2
-rw-r--r--ghc/compiler/prelude/TysWiredIn.lhs125
8 files changed, 467 insertions, 576 deletions
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index a24196185d..ad67d07d5a 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -5,7 +5,7 @@
\begin{code}
module PrelInfo (
- module ThinAir,
+ module PrelNames,
module MkId,
builtinNames, -- Names of things whose *unique* must be known, but
@@ -18,51 +18,27 @@ module PrelInfo (
-- deriving(C) clause
- -- Random other things
- main_NAME, ioTyCon_NAME,
- deRefStablePtr_NAME, makeStablePtr_NAME,
- bindIO_NAME, returnIO_NAME,
+
+ -- Primop RdrNames
+ eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR,
+ eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR, ltH_Float_RDR,
+ eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR,
+ geH_RDR, leH_RDR, minusH_RDR, tagToEnumH_RDR,
+ -- Random other things
maybeCharLikeCon, maybeIntLikeCon,
needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys,
isNoDictClass, isNumericClass, isStandardClass, isCcallishClass,
isCreturnableClass, numericTyKeys, fractionalClassKeys,
- -- RdrNames for lots of things, mainly used in derivings
- eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
- compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR,
- enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR,
- ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR,
- readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR,
- ltTag_RDR, eqTag_RDR, gtTag_RDR, eqH_Char_RDR, ltH_Char_RDR,
- eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR,
- ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR,
- ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR,
- and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
- error_RDR, assertErr_RDR, getTag_RDR, tagToEnumH_RDR,
- showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
- showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
-
- numClass_RDR, fractionalClass_RDR, eqClass_RDR,
- ccallableClass_RDR, creturnableClass_RDR,
- monadClass_RDR, enumClass_RDR, ordClass_RDR,
- ioDataCon_RDR,
-
- main_RDR,
-
- mkTupConRdrName, mkUbxTupConRdrName
-
) where
#include "HsVersions.h"
-
-
-- friends:
-import ThinAir -- Re-export all these
import MkId -- Ditto
+import PrelNames -- Prelude module names
-import PrelMods -- Prelude module names
import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName )
import DataCon ( DataCon, dataConId, dataConWrapId )
import PrimRep ( PrimRep(..) )
@@ -70,18 +46,18 @@ import TysPrim -- TYPES
import TysWiredIn
-- others:
-import RdrName ( RdrName, mkPreludeQual )
+import RdrName ( RdrName )
import Var ( varUnique, Id )
import Name ( Name, OccName, Provenance(..),
NameSpace, tcName, clsName, varName, dataName,
mkKnownKeyGlobal,
getName, mkGlobalName, nameRdrName
)
-import RdrName ( rdrNameModule, rdrNameOcc, mkSrcQual )
import Class ( Class, classKey )
-import TyCon ( tyConDataCons, TyCon )
+import TyCon ( tyConDataConsIfAvailable, TyCon )
import Type ( funTyCon )
import Bag
+import BasicTypes ( Boxity(..) )
import Unique -- *Key stuff
import UniqFM ( UniqFM, listToUFM )
import Util ( isIn )
@@ -110,9 +86,6 @@ builtinNames
-- PrimOps
, listToBag (map (getName . mkPrimOpId) allThePrimOps)
- -- Thin-air ids
- , listToBag thinAirIdNames
-
-- Other names with magic keys
, listToBag knownKeyNames
]
@@ -123,7 +96,7 @@ builtinNames
getTyConNames :: TyCon -> Bag Name
getTyConNames tycon
= getName tycon `consBag`
- unionManyBags (map get_data_con_names (tyConDataCons tycon))
+ unionManyBags (map get_data_con_names (tyConDataConsIfAvailable tycon))
-- Synonyms return empty list of constructors
where
get_data_con_names dc = listToBag [getName (dataConId dc), -- Worker
@@ -137,6 +110,35 @@ sense of them in interface pragmas. It's cool, though they all have
%************************************************************************
%* *
+\subsection{RdrNames for the primops}
+%* *
+%************************************************************************
+
+These can't be in PrelNames, because we get the RdrName from the PrimOp,
+which is above PrelNames in the module hierarchy.
+
+\begin{code}
+eqH_Char_RDR = primOpRdrName CharEqOp
+ltH_Char_RDR = primOpRdrName CharLtOp
+eqH_Word_RDR = primOpRdrName WordEqOp
+ltH_Word_RDR = primOpRdrName WordLtOp
+eqH_Addr_RDR = primOpRdrName AddrEqOp
+ltH_Addr_RDR = primOpRdrName AddrLtOp
+eqH_Float_RDR = primOpRdrName FloatEqOp
+ltH_Float_RDR = primOpRdrName FloatLtOp
+eqH_Double_RDR = primOpRdrName DoubleEqOp
+ltH_Double_RDR = primOpRdrName DoubleLtOp
+eqH_Int_RDR = primOpRdrName IntEqOp
+ltH_Int_RDR = primOpRdrName IntLtOp
+geH_RDR = primOpRdrName IntGeOp
+leH_RDR = primOpRdrName IntLeOp
+minusH_RDR = primOpRdrName IntSubOp
+
+tagToEnumH_RDR = primOpRdrName TagToEnumOp
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Wired in TyCons}
%* *
%************************************************************************
@@ -172,8 +174,8 @@ prim_tycons
, word64PrimTyCon
]
-tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ]
-unboxed_tuple_tycons = [unboxedTupleTyCon i | i <- [1..37] ]
+tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ]
+unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ]
data_tycons
= [ addrTyCon
@@ -198,23 +200,14 @@ data_tycons
Ids, Synonyms, Classes and ClassOps with builtin keys.
\begin{code}
-ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey)
-main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
-
- -- Operations needed when compiling FFI decls
-bindIO_NAME = mkKnownKeyGlobal (bindIO_RDR, bindIOIdKey)
-returnIO_NAME = mkKnownKeyGlobal (returnIO_RDR, returnIOIdKey)
-deRefStablePtr_NAME = mkKnownKeyGlobal (deRefStablePtr_RDR, deRefStablePtrIdKey)
-makeStablePtr_NAME = mkKnownKeyGlobal (makeStablePtr_RDR, makeStablePtrIdKey)
-
knownKeyNames :: [Name]
knownKeyNames
- = [main_NAME, ioTyCon_NAME]
- ++
- map mkKnownKeyGlobal
+ = map mkKnownKeyGlobal
[
-- Type constructors (synonyms especially)
- (orderingTyCon_RDR, orderingTyConKey)
+ (ioTyCon_RDR, ioTyConKey)
+ , (main_RDR, mainKey)
+ , (orderingTyCon_RDR, orderingTyConKey)
, (rationalTyCon_RDR, rationalTyConKey)
, (ratioDataCon_RDR, ratioDataConKey)
, (ratioTyCon_RDR, ratioTyConKey)
@@ -268,14 +261,21 @@ knownKeyNames
, (makeStablePtr_RDR, makeStablePtrIdKey)
, (bindIO_RDR, bindIOIdKey)
, (returnIO_RDR, returnIOIdKey)
+ , (addr2Integer_RDR, addr2IntegerIdKey)
+ -- Strings and lists
, (map_RDR, mapIdKey)
, (append_RDR, appendIdKey)
+ , (unpackCString_RDR, unpackCStringIdKey)
+ , (unpackCString2_RDR, unpackCString2IdKey)
+ , (unpackCStringAppend_RDR, unpackCStringAppendIdKey)
+ , (unpackCStringFoldr_RDR, unpackCStringFoldrIdKey)
-- List operations
, (concat_RDR, concatIdKey)
, (filter_RDR, filterIdKey)
, (zip_RDR, zipIdKey)
+ , (foldr_RDR, foldrIdKey)
, (build_RDR, buildIdKey)
, (augment_RDR, augmentIdKey)
@@ -300,203 +300,12 @@ ToDo: make it do the ``like'' part properly (as in 0.26 and before).
\begin{code}
maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
-maybeCharLikeCon con = getUnique con == charDataConKey
-maybeIntLikeCon con = getUnique con == intDataConKey
+maybeCharLikeCon con = con `hasKey` charDataConKey
+maybeIntLikeCon con = con `hasKey` intDataConKey
\end{code}
%************************************************************************
%* *
-\subsection{Commonly-used RdrNames}
-%* *
-%************************************************************************
-
-These RdrNames are not really "built in", but some parts of the compiler
-(notably the deriving mechanism) need to mention their names, and it's convenient
-to write them all down in one place.
-
-\begin{code}
-main_RDR = varQual mAIN_Name SLIT("main")
-otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise")
-
-intTyCon_RDR = nameRdrName (getName intTyCon)
-ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO")
-ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO")
-bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO")
-returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO")
-
-orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering")
-
-rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational")
-ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio")
-ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%")
-
-byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray")
-mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray")
-
-foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj")
-stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr")
-stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr")
-deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr")
-makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr")
-
--- Random PrelBase data constructors
-mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#")
-false_RDR = dataQual pREL_BASE_Name SLIT("False")
-true_RDR = dataQual pREL_BASE_Name SLIT("True")
-
--- Random PrelBase functions
-and_RDR = varQual pREL_BASE_Name SLIT("&&")
-not_RDR = varQual pREL_BASE_Name SLIT("not")
-compose_RDR = varQual pREL_BASE_Name SLIT(".")
-append_RDR = varQual pREL_BASE_Name SLIT("++")
-map_RDR = varQual pREL_BASE_Name SLIT("map")
-build_RDR = varQual pREL_BASE_Name SLIT("build")
-augment_RDR = varQual pREL_BASE_Name SLIT("augment")
-
--- Classes Eq and Ord
-eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq")
-ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord")
-eq_RDR = varQual pREL_BASE_Name SLIT("==")
-ne_RDR = varQual pREL_BASE_Name SLIT("/=")
-le_RDR = varQual pREL_BASE_Name SLIT("<=")
-lt_RDR = varQual pREL_BASE_Name SLIT("<")
-ge_RDR = varQual pREL_BASE_Name SLIT(">=")
-gt_RDR = varQual pREL_BASE_Name SLIT(">")
-ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT")
-eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ")
-gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT")
-max_RDR = varQual pREL_BASE_Name SLIT("max")
-min_RDR = varQual pREL_BASE_Name SLIT("min")
-compare_RDR = varQual pREL_BASE_Name SLIT("compare")
-
--- Class Monad
-monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad")
-monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus")
-thenM_RDR = varQual pREL_BASE_Name SLIT(">>=")
-returnM_RDR = varQual pREL_BASE_Name SLIT("return")
-failM_RDR = varQual pREL_BASE_Name SLIT("fail")
-
--- Class Functor
-functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor")
-
--- Class Show
-showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show")
-showList___RDR = varQual pREL_SHOW_Name SLIT("showList__")
-showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec")
-showList_RDR = varQual pREL_SHOW_Name SLIT("showList")
-showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace")
-showString_RDR = varQual pREL_SHOW_Name SLIT("showString")
-showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen")
-
-
--- Class Read
-readClass_RDR = clsQual pREL_READ_Name SLIT("Read")
-readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec")
-readList_RDR = varQual pREL_READ_Name SLIT("readList")
-readParen_RDR = varQual pREL_READ_Name SLIT("readParen")
-lex_RDR = varQual pREL_READ_Name SLIT("lex")
-readList___RDR = varQual pREL_READ_Name SLIT("readList__")
-
-
--- Class Num
-numClass_RDR = clsQual pREL_NUM_Name SLIT("Num")
-fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt")
-fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger")
-minus_RDR = varQual pREL_NUM_Name SLIT("-")
-negate_RDR = varQual pREL_NUM_Name SLIT("negate")
-plus_RDR = varQual pREL_NUM_Name SLIT("+")
-times_RDR = varQual pREL_NUM_Name SLIT("*")
-
--- Other numberic classes
-realClass_RDR = clsQual pREL_REAL_Name SLIT("Real")
-integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral")
-realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac")
-fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional")
-fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational")
-
-floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating")
-realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat")
-
--- Class Ix
-ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix")
-range_RDR = varQual pREL_ARR_Name SLIT("range")
-index_RDR = varQual pREL_ARR_Name SLIT("index")
-inRange_RDR = varQual pREL_ARR_Name SLIT("inRange")
-
--- Class CCallable and CReturnable
-ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable")
-creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable")
-
--- Class Enum
-enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum")
-succ_RDR = varQual pREL_ENUM_Name SLIT("succ")
-pred_RDR = varQual pREL_ENUM_Name SLIT("pred")
-toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum")
-fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum")
-enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom")
-enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo")
-enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen")
-enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo")
-
--- Class Bounded
-boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded")
-minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound")
-maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound")
-
-
--- List functions
-concat_RDR = varQual pREL_LIST_Name SLIT("concat")
-filter_RDR = varQual pREL_LIST_Name SLIT("filter")
-zip_RDR = varQual pREL_LIST_Name SLIT("zip")
-
-int8TyCon_RDR = tcQual iNT_Name SLIT("Int8")
-int16TyCon_RDR = tcQual iNT_Name SLIT("Int16")
-int32TyCon_RDR = tcQual iNT_Name SLIT("Int32")
-int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64")
-
-word8TyCon_RDR = tcQual wORD_Name SLIT("Word8")
-word16TyCon_RDR = tcQual wORD_Name SLIT("Word16")
-word32TyCon_RDR = tcQual wORD_Name SLIT("Word32")
-word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64")
-
-error_RDR = varQual pREL_ERR_Name SLIT("error")
-assert_RDR = varQual pREL_GHC_Name SLIT("assert")
-assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError")
-runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep")
-
-eqH_Char_RDR = primOpRdrName CharEqOp
-ltH_Char_RDR = primOpRdrName CharLtOp
-eqH_Word_RDR = primOpRdrName WordEqOp
-ltH_Word_RDR = primOpRdrName WordLtOp
-eqH_Addr_RDR = primOpRdrName AddrEqOp
-ltH_Addr_RDR = primOpRdrName AddrLtOp
-eqH_Float_RDR = primOpRdrName FloatEqOp
-ltH_Float_RDR = primOpRdrName FloatLtOp
-eqH_Double_RDR = primOpRdrName DoubleEqOp
-ltH_Double_RDR = primOpRdrName DoubleLtOp
-eqH_Int_RDR = primOpRdrName IntEqOp
-ltH_Int_RDR = primOpRdrName IntLtOp
-geH_RDR = primOpRdrName IntGeOp
-leH_RDR = primOpRdrName IntLeOp
-minusH_RDR = primOpRdrName IntSubOp
-
-tagToEnumH_RDR = primOpRdrName TagToEnumOp
-getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#")
-\end{code}
-
-\begin{code}
-mkTupConRdrName :: Int -> RdrName
-mkTupConRdrName arity = case mkTupNameStr arity of
- (mod, occ) -> dataQual mod occ
-
-mkUbxTupConRdrName :: Int -> RdrName
-mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of
- (mod, occ) -> dataQual mod occ
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
%* *
%************************************************************************
@@ -633,17 +442,3 @@ noDictClassKeys -- These classes are used only for type annotations;
= cCallishClassKeys
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local helpers}
-%* *
-%************************************************************************
-
-\begin{code}
-varQual = mkPreludeQual varName
-dataQual = mkPreludeQual dataName
-tcQual = mkPreludeQual tcName
-clsQual = mkPreludeQual clsName
-\end{code}
-
diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs
deleted file mode 100644
index 885685d7c4..0000000000
--- a/ghc/compiler/prelude/PrelMods.lhs
+++ /dev/null
@@ -1,101 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[PrelMods]{Definitions of prelude modules}
-
-The strings identify built-in prelude modules. They are
-defined here so as to avod
-
-[oh dear, looks like the recursive module monster caught up with
- and gobbled whoever was writing the above :-) -- SOF ]
-
-\begin{code}
-module PrelMods
- (
- mkTupNameStr, mkUbxTupNameStr,
-
- pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE,
- pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL,
-
- pREL_GHC_Name, pRELUDE_Name,
- mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name,
- pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name,
- pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name,
- pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name,
- pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name,
- pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name,
- pREL_REAL_Name, pREL_FLOAT_Name
- ) where
-
-#include "HsVersions.h"
-
-import Module ( Module, ModuleName, mkPrelModule, mkSrcModule )
-import Util ( nOfThem )
-import Panic ( panic )
-\end{code}
-
-\begin{code}
-pRELUDE_Name = mkSrcModule "Prelude"
-pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values
-pREL_BASE_Name = mkSrcModule "PrelBase"
-pREL_ENUM_Name = mkSrcModule "PrelEnum"
-pREL_SHOW_Name = mkSrcModule "PrelShow"
-pREL_READ_Name = mkSrcModule "PrelRead"
-pREL_NUM_Name = mkSrcModule "PrelNum"
-pREL_LIST_Name = mkSrcModule "PrelList"
-pREL_TUP_Name = mkSrcModule "PrelTup"
-pREL_PACK_Name = mkSrcModule "PrelPack"
-pREL_CONC_Name = mkSrcModule "PrelConc"
-pREL_IO_BASE_Name = mkSrcModule "PrelIOBase"
-pREL_ST_Name = mkSrcModule "PrelST"
-pREL_ARR_Name = mkSrcModule "PrelArr"
-pREL_BYTEARR_Name = mkSrcModule "PrelByteArr"
-pREL_FOREIGN_Name = mkSrcModule "PrelForeign"
-pREL_STABLE_Name = mkSrcModule "PrelStable"
-pREL_ADDR_Name = mkSrcModule "PrelAddr"
-pREL_ERR_Name = mkSrcModule "PrelErr"
-pREL_REAL_Name = mkSrcModule "PrelReal"
-pREL_FLOAT_Name = mkSrcModule "PrelFloat"
-
-pREL_MAIN_Name = mkSrcModule "PrelMain"
-mAIN_Name = mkSrcModule "Main"
-iNT_Name = mkSrcModule "Int"
-wORD_Name = mkSrcModule "Word"
-
-pREL_GHC = mkPrelModule pREL_GHC_Name
-pREL_BASE = mkPrelModule pREL_BASE_Name
-pREL_ADDR = mkPrelModule pREL_ADDR_Name
-pREL_STABLE = mkPrelModule pREL_STABLE_Name
-pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name
-pREL_PACK = mkPrelModule pREL_PACK_Name
-pREL_ERR = mkPrelModule pREL_ERR_Name
-pREL_NUM = mkPrelModule pREL_NUM_Name
-pREL_REAL = mkPrelModule pREL_REAL_Name
-pREL_FLOAT = mkPrelModule pREL_FLOAT_Name
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Constructing the names of tuples
-%* *
-%************************************************************************
-
-\begin{code}
-mkTupNameStr, mkUbxTupNameStr :: Int -> (ModuleName, FAST_STRING)
-
-mkTupNameStr 0 = (pREL_BASE_Name, SLIT("()"))
-mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary
-mkTupNameStr 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto
-mkTupNameStr 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto
-mkTupNameStr n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
-
-mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???"
-mkUbxTupNameStr 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!!
-mkUbxTupNameStr 2 = (pREL_GHC_Name, _PK_ "(#,#)")
-mkUbxTupNameStr 3 = (pREL_GHC_Name, _PK_ "(#,,#)")
-mkUbxTupNameStr 4 = (pREL_GHC_Name, _PK_ "(#,,,#)")
-mkUbxTupNameStr n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
-\end{code}
-
-
diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
new file mode 100644
index 0000000000..0d4328d278
--- /dev/null
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -0,0 +1,341 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[PrelNames]{Definitions of prelude modules}
+
+The strings identify built-in prelude modules. They are
+defined here so as to avod
+
+[oh dear, looks like the recursive module monster caught up with
+ and gobbled whoever was writing the above :-) -- SOF ]
+
+\begin{code}
+module PrelNames
+ (
+ -- Prelude modules
+ pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE,
+ pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL,
+
+ -- Module names (both Prelude and otherwise)
+ pREL_GHC_Name, pRELUDE_Name,
+ mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name,
+ pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name,
+ pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name,
+ pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name,
+ pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name,
+ pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name,
+ pREL_REAL_Name, pREL_FLOAT_Name,
+
+ -- RdrNames for lots of things, mainly used in derivings
+ eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
+ compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR,
+ enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR,
+ ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR,
+ readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR,
+ ltTag_RDR, eqTag_RDR, gtTag_RDR, false_RDR, true_RDR,
+ and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
+ error_RDR, assertErr_RDR,
+ showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
+ showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
+ addr2Integer_RDR, ioTyCon_RDR,
+ foldr_RDR, build_RDR, getTag_RDR,
+
+ orderingTyCon_RDR, rationalTyCon_RDR, ratioTyCon_RDR, byteArrayTyCon_RDR,
+ mutableByteArrayTyCon_RDR, foreignObjTyCon_RDR,
+ intTyCon_RDR, stablePtrTyCon_RDR, stablePtrDataCon_RDR,
+ int8TyCon_RDR, int16TyCon_RDR, int32TyCon_RDR, int64TyCon_RDR,
+ word8TyCon_RDR, word16TyCon_RDR, word32TyCon_RDR, word64TyCon_RDR,
+
+ boundedClass_RDR, monadPlusClass_RDR, functorClass_RDR, showClass_RDR,
+ realClass_RDR, integralClass_RDR, floatingClass_RDR, realFracClass_RDR,
+ realFloatClass_RDR, readClass_RDR, ixClass_RDR,
+ fromInt_RDR, fromInteger_RDR, minus_RDR, fromRational_RDR,
+
+ bindIO_RDR, returnIO_RDR, thenM_RDR, returnM_RDR, failM_RDR,
+
+ deRefStablePtr_RDR, makeStablePtr_RDR,
+ concat_RDR, filter_RDR, zip_RDR, augment_RDR,
+ otherwiseId_RDR, assert_RDR, runSTRep_RDR,
+
+ unpackCString_RDR, unpackCString2_RDR, unpackCStringAppend_RDR, unpackCStringFoldr_RDR,
+ numClass_RDR, fractionalClass_RDR, eqClass_RDR,
+ ccallableClass_RDR, creturnableClass_RDR,
+ monadClass_RDR, enumClass_RDR, ordClass_RDR,
+ ioDataCon_RDR,
+
+ main_RDR,
+
+ mkTupNameStr, mkTupConRdrName
+
+ ) where
+
+#include "HsVersions.h"
+
+import Module ( Module, ModuleName, mkPrelModule, mkSrcModule )
+import OccName ( NameSpace, varName, dataName, tcName, clsName )
+import RdrName ( RdrName, mkPreludeQual )
+import BasicTypes ( Boxity(..), Arity )
+import Util ( nOfThem )
+import Panic ( panic )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Module names}
+%* *
+%************************************************************************
+
+\begin{code}
+pRELUDE_Name = mkSrcModule "Prelude"
+pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values
+pREL_BASE_Name = mkSrcModule "PrelBase"
+pREL_ENUM_Name = mkSrcModule "PrelEnum"
+pREL_SHOW_Name = mkSrcModule "PrelShow"
+pREL_READ_Name = mkSrcModule "PrelRead"
+pREL_NUM_Name = mkSrcModule "PrelNum"
+pREL_LIST_Name = mkSrcModule "PrelList"
+pREL_TUP_Name = mkSrcModule "PrelTup"
+pREL_PACK_Name = mkSrcModule "PrelPack"
+pREL_CONC_Name = mkSrcModule "PrelConc"
+pREL_IO_BASE_Name = mkSrcModule "PrelIOBase"
+pREL_ST_Name = mkSrcModule "PrelST"
+pREL_ARR_Name = mkSrcModule "PrelArr"
+pREL_BYTEARR_Name = mkSrcModule "PrelByteArr"
+pREL_FOREIGN_Name = mkSrcModule "PrelForeign"
+pREL_STABLE_Name = mkSrcModule "PrelStable"
+pREL_ADDR_Name = mkSrcModule "PrelAddr"
+pREL_ERR_Name = mkSrcModule "PrelErr"
+pREL_REAL_Name = mkSrcModule "PrelReal"
+pREL_FLOAT_Name = mkSrcModule "PrelFloat"
+
+pREL_MAIN_Name = mkSrcModule "PrelMain"
+mAIN_Name = mkSrcModule "Main"
+iNT_Name = mkSrcModule "Int"
+wORD_Name = mkSrcModule "Word"
+
+pREL_GHC = mkPrelModule pREL_GHC_Name
+pREL_BASE = mkPrelModule pREL_BASE_Name
+pREL_ADDR = mkPrelModule pREL_ADDR_Name
+pREL_STABLE = mkPrelModule pREL_STABLE_Name
+pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name
+pREL_PACK = mkPrelModule pREL_PACK_Name
+pREL_ERR = mkPrelModule pREL_ERR_Name
+pREL_NUM = mkPrelModule pREL_NUM_Name
+pREL_REAL = mkPrelModule pREL_REAL_Name
+pREL_FLOAT = mkPrelModule pREL_FLOAT_Name
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Constructing the names of tuples
+%* *
+%************************************************************************
+
+\begin{code}
+mkTupNameStr :: Boxity -> Int -> (ModuleName, FAST_STRING)
+
+mkTupNameStr Boxed 0 = (pREL_BASE_Name, SLIT("()"))
+mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???"
+mkTupNameStr Boxed 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary
+mkTupNameStr Boxed 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto
+mkTupNameStr Boxed 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto
+mkTupNameStr Boxed n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
+
+mkTupNameStr Unboxed 0 = panic "Name.mkUbxTupNameStr: 0 ???"
+mkTupNameStr Unboxed 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!!
+mkTupNameStr Unboxed 2 = (pREL_GHC_Name, _PK_ "(#,#)")
+mkTupNameStr Unboxed 3 = (pREL_GHC_Name, _PK_ "(#,,#)")
+mkTupNameStr Unboxed 4 = (pREL_GHC_Name, _PK_ "(#,,,#)")
+mkTupNameStr Unboxed n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
+
+mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName
+mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of
+ (mod, occ) -> mkPreludeQual space mod occ
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Commonly-used RdrNames}
+%* *
+%************************************************************************
+
+These RdrNames are not really "built in", but some parts of the compiler
+(notably the deriving mechanism) need to mention their names, and it's convenient
+to write them all down in one place.
+
+\begin{code}
+main_RDR = varQual mAIN_Name SLIT("main")
+
+ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO")
+ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO")
+bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO")
+returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO")
+
+
+rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational")
+ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio")
+ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%")
+
+byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray")
+mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray")
+
+foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj")
+stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr")
+stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr")
+deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr")
+makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr")
+
+-- Random PrelBase data types and constructors
+intTyCon_RDR = tcQual pREL_BASE_Name SLIT("Int")
+orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering")
+mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#")
+false_RDR = dataQual pREL_BASE_Name SLIT("False")
+true_RDR = dataQual pREL_BASE_Name SLIT("True")
+
+-- Random PrelBase functions
+otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise")
+and_RDR = varQual pREL_BASE_Name SLIT("&&")
+not_RDR = varQual pREL_BASE_Name SLIT("not")
+compose_RDR = varQual pREL_BASE_Name SLIT(".")
+append_RDR = varQual pREL_BASE_Name SLIT("++")
+foldr_RDR = varQual pREL_BASE_Name SLIT("foldr")
+map_RDR = varQual pREL_BASE_Name SLIT("map")
+build_RDR = varQual pREL_BASE_Name SLIT("build")
+augment_RDR = varQual pREL_BASE_Name SLIT("augment")
+
+-- Strings
+unpackCString_RDR = varQual pREL_BASE_Name SLIT("unpackCString#")
+unpackCString2_RDR = varQual pREL_BASE_Name SLIT("unpackNBytes#")
+unpackCStringAppend_RDR = varQual pREL_BASE_Name SLIT("unpackAppendCString#")
+unpackCStringFoldr_RDR = varQual pREL_BASE_Name SLIT("unpackFoldrCString#")
+
+-- Classes Eq and Ord
+eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq")
+ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord")
+eq_RDR = varQual pREL_BASE_Name SLIT("==")
+ne_RDR = varQual pREL_BASE_Name SLIT("/=")
+le_RDR = varQual pREL_BASE_Name SLIT("<=")
+lt_RDR = varQual pREL_BASE_Name SLIT("<")
+ge_RDR = varQual pREL_BASE_Name SLIT(">=")
+gt_RDR = varQual pREL_BASE_Name SLIT(">")
+ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT")
+eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ")
+gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT")
+max_RDR = varQual pREL_BASE_Name SLIT("max")
+min_RDR = varQual pREL_BASE_Name SLIT("min")
+compare_RDR = varQual pREL_BASE_Name SLIT("compare")
+
+-- Class Monad
+monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad")
+monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus")
+thenM_RDR = varQual pREL_BASE_Name SLIT(">>=")
+returnM_RDR = varQual pREL_BASE_Name SLIT("return")
+failM_RDR = varQual pREL_BASE_Name SLIT("fail")
+
+-- Class Functor
+functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor")
+
+-- Class Show
+showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show")
+showList___RDR = varQual pREL_SHOW_Name SLIT("showList__")
+showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec")
+showList_RDR = varQual pREL_SHOW_Name SLIT("showList")
+showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace")
+showString_RDR = varQual pREL_SHOW_Name SLIT("showString")
+showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen")
+
+
+-- Class Read
+readClass_RDR = clsQual pREL_READ_Name SLIT("Read")
+readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec")
+readList_RDR = varQual pREL_READ_Name SLIT("readList")
+readParen_RDR = varQual pREL_READ_Name SLIT("readParen")
+lex_RDR = varQual pREL_READ_Name SLIT("lex")
+readList___RDR = varQual pREL_READ_Name SLIT("readList__")
+
+
+-- Class Num
+numClass_RDR = clsQual pREL_NUM_Name SLIT("Num")
+fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt")
+fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger")
+minus_RDR = varQual pREL_NUM_Name SLIT("-")
+negate_RDR = varQual pREL_NUM_Name SLIT("negate")
+plus_RDR = varQual pREL_NUM_Name SLIT("+")
+times_RDR = varQual pREL_NUM_Name SLIT("*")
+addr2Integer_RDR = varQual pREL_NUM_Name SLIT("addr2Integer")
+
+-- Other numberic classes
+realClass_RDR = clsQual pREL_REAL_Name SLIT("Real")
+integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral")
+realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac")
+fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional")
+fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational")
+
+floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating")
+realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat")
+
+-- Class Ix
+ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix")
+range_RDR = varQual pREL_ARR_Name SLIT("range")
+index_RDR = varQual pREL_ARR_Name SLIT("index")
+inRange_RDR = varQual pREL_ARR_Name SLIT("inRange")
+
+-- Class CCallable and CReturnable
+ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable")
+creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable")
+
+-- Class Enum
+enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum")
+succ_RDR = varQual pREL_ENUM_Name SLIT("succ")
+pred_RDR = varQual pREL_ENUM_Name SLIT("pred")
+toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum")
+fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum")
+enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom")
+enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo")
+enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen")
+enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo")
+
+-- Class Bounded
+boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded")
+minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound")
+maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound")
+
+
+-- List functions
+concat_RDR = varQual pREL_LIST_Name SLIT("concat")
+filter_RDR = varQual pREL_LIST_Name SLIT("filter")
+zip_RDR = varQual pREL_LIST_Name SLIT("zip")
+
+int8TyCon_RDR = tcQual iNT_Name SLIT("Int8")
+int16TyCon_RDR = tcQual iNT_Name SLIT("Int16")
+int32TyCon_RDR = tcQual iNT_Name SLIT("Int32")
+int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64")
+
+word8TyCon_RDR = tcQual wORD_Name SLIT("Word8")
+word16TyCon_RDR = tcQual wORD_Name SLIT("Word16")
+word32TyCon_RDR = tcQual wORD_Name SLIT("Word32")
+word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64")
+
+error_RDR = varQual pREL_ERR_Name SLIT("error")
+assert_RDR = varQual pREL_GHC_Name SLIT("assert")
+getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#")
+assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError")
+runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Local helpers}
+%* *
+%************************************************************************
+
+\begin{code}
+varQual = mkPreludeQual varName
+dataQual = mkPreludeQual dataName
+tcQual = mkPreludeQual tcName
+clsQual = mkPreludeQual clsName
+\end{code}
+
diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
index 63e986330c..5f2c0df729 100644
--- a/ghc/compiler/prelude/PrelRules.lhs
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -21,15 +21,17 @@ import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
, addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
)
+import RdrName ( RdrName )
import PrimOp ( PrimOp(..), primOpOcc )
import TysWiredIn ( trueDataConId, falseDataConId )
-import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon )
+import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
import DataCon ( DataCon, dataConTag, dataConRepArity, dataConTyCon, dataConId, fIRST_TAG )
import CoreUnfold ( maybeUnfoldingTemplate )
import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
import Type ( splitTyConApp_maybe )
import OccName ( occNameUserString)
-import ThinAir ( unpackCStringFoldrId )
+import PrelNames ( unpackCStringFoldr_RDR )
+import Unique ( unpackCStringFoldrIdKey, hasKey )
import Maybes ( maybeToBool )
import Char ( ord, chr )
import Bits ( Bits(..) )
@@ -55,7 +57,7 @@ primOpRule op
= BuiltinRule (primop_rule op)
where
op_name = _PK_ (occNameUserString (primOpOcc op))
- op_name_case = op_name _APPEND_ SLIT("case")
+ op_name_case = op_name _APPEND_ SLIT("->case")
-- ToDo: something for integer-shift ops?
-- NotOp
@@ -404,11 +406,15 @@ seqRule other = Nothing
\begin{code}
tagToEnumRule [Type ty, Lit (MachInt i)]
= ASSERT( isEnumerationTyCon tycon )
- Just (SLIT("TagToEnum"), Var (dataConId dc))
+ case filter correct_tag (tyConDataConsIfAvailable tycon) of
+
+
+ [] -> Nothing -- Abstract type
+ (dc:rest) -> ASSERT( null rest )
+ Just (SLIT("TagToEnum"), Var (dataConId dc))
where
+ correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
tag = fromInteger i
- constrs = tyConDataCons tycon
- (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ]
(Just (tycon,_)) = splitTyConApp_maybe ty
tagToEnumRule other = Nothing
@@ -438,15 +444,14 @@ dataToTagRule other = Nothing
%************************************************************************
\begin{code}
-builtinRules :: [ProtoCoreRule]
+builtinRules :: [(RdrName, CoreRule)]
-- Rules for non-primops that can't be expressed using a RULE pragma
builtinRules
- = [ ProtoCoreRule False unpackCStringFoldrId
- (BuiltinRule match_append_lit_str)
+ = [ (unpackCStringFoldr_RDR, BuiltinRule match_append_lit_str)
]
--- unpack "foo" c (unpack "baz" c n) = unpack "foobaz" c n
+-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
match_append_lit_str [Type ty1,
Lit (MachStr s1),
@@ -456,7 +461,7 @@ match_append_lit_str [Type ty1,
`App` c2
`App` n
]
- | unpk == unpackCStringFoldrId &&
+ | unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
= ASSERT( ty1 == ty2 )
Just (SLIT("AppendLitString"),
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 7a0627d6f0..a55af165de 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -42,9 +42,9 @@ import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
UsageAnn(..), mkUsgTy
)
import Unique ( Unique, mkPrimOpIdUnique )
-import BasicTypes ( Arity )
+import BasicTypes ( Arity, Boxity(..) )
import CStrings ( CLabelString, pprCLabelString )
-import PrelMods ( pREL_GHC, pREL_GHC_Name )
+import PrelNames ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( assoc, zipWithEqual )
import GlaExts ( Int(..), Int#, (==#) )
@@ -832,9 +832,10 @@ an_Integer_and_Int_tys
= [intPrimTy, byteArrayPrimTy, -- Integer
intPrimTy]
-unboxedPair = mkUnboxedTupleTy 2
-unboxedTriple = mkUnboxedTupleTy 3
-unboxedQuadruple = mkUnboxedTupleTy 4
+unboxedSingleton = mkTupleTy Unboxed 1
+unboxedPair = mkTupleTy Unboxed 2
+unboxedTriple = mkTupleTy Unboxed 3
+unboxedQuadruple = mkTupleTy Unboxed 4
mkIOTy ty = mkFunTy realWorldStatePrimTy
(unboxedPair [realWorldStatePrimTy,ty])
@@ -1270,7 +1271,7 @@ primOpInfo WriteArrayOp
primOpInfo IndexArrayOp
= let { elt = alphaTy; elt_tv = alphaTyVar } in
mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
- (mkUnboxedTupleTy 1 [elt])
+ (unboxedSingleton [elt])
---------------------------------------------------------------------------
-- Primitive arrays full of unboxed bytes:
@@ -2302,8 +2303,8 @@ primOpUsg op
Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)
inUB fs ty = case splitTyConApp_maybe ty of
- Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) )
- mkUnboxedTupleTy (length fs) (zipWithEqual "primOpUsg"
+ Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) )
+ mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg"
($) fs tys)
Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty)
\end{code}
@@ -2409,6 +2410,7 @@ data CCall
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
CallConv -- calling convention to use.
+ deriving( Eq )
data CCallTarget
= StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
@@ -2416,6 +2418,7 @@ data CCallTarget
-- (unique is used to generate a 'typedef' to cast
-- the function pointer if compiling the ccall# down to
-- .hc code - can't do this inline for tedious reasons.)
+ deriving( Eq )
ccallMayGC :: CCall -> Bool
ccallMayGC (CCall _ _ may_gc _) = may_gc
diff --git a/ghc/compiler/prelude/ThinAir.lhs b/ghc/compiler/prelude/ThinAir.lhs
deleted file mode 100644
index 8852598b64..0000000000
--- a/ghc/compiler/prelude/ThinAir.lhs
+++ /dev/null
@@ -1,109 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section{Thin air Ids}
-
-\begin{code}
-module ThinAir (
- thinAirIdNames, -- Names of non-wired-in Ids that may be used out of
- setThinAirIds, -- thin air in any compilation. If they are not wired in
- -- we must be sure to import them from some Prelude
- -- interface file even if they are not overtly
- -- mentioned. Subset of builtinNames.
- -- Here are the thin-air Ids themselves
- addr2IntegerId,
- unpackCStringId, unpackCString2Id,
- unpackCStringAppendId, unpackCStringFoldrId,
- foldrId, buildId,
-
- noRepIntegerIds,
- noRepStrIds
-
- ) where
-
-#include "HsVersions.h"
-
-import Var ( Id, varUnique )
-import Name ( mkKnownKeyGlobal, varName )
-import RdrName ( mkPreludeQual )
-import PrelMods
-import UniqFM ( UniqFM, listToUFM, lookupWithDefaultUFM )
-import Unique
-import Outputable
-import IOExts
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Thin air entities}
-%* *
-%************************************************************************
-
-These are Ids that we need to reference in various parts of the
-system, and we'd like to pull them out of thin air rather than pass
-them around. We'd also like to have all the IdInfo available for each
-one: i.e. everything that gets pulled out of the interface file.
-
-The solution is to generate this map of global Ids after the
-typechecker, and assign it to a global variable. Any subsequent
-pass may refer to the map to pull Ids out. Any invalid
-(i.e. pre-typechecker) access to the map will result in a panic.
-
-\begin{code}
-thinAirIdNames
- = map mkKnownKeyGlobal
- [
- -- Needed for converting literals to Integers (used in tidyCoreExpr)
- (varQual pREL_NUM_Name SLIT("addr2Integer"), addr2IntegerIdKey)
-
- -- Folds and builds; introduced by desugaring list comprehensions
- , (varQual pREL_BASE_Name SLIT("unpackNBytes#"), unpackCString2IdKey)
- , (varQual pREL_BASE_Name SLIT("unpackCString#"), unpackCStringIdKey)
- , (varQual pREL_BASE_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey)
- , (varQual pREL_BASE_Name SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey)
-
- , (varQual pREL_BASE_Name SLIT("foldr"), foldrIdKey)
- , (varQual pREL_BASE_Name SLIT("build"), buildIdKey)
- ]
-
-varQual = mkPreludeQual varName
-\end{code}
-
-
-\begin{code}
-noRepIntegerIds = [addr2IntegerId]
-
-noRepStrIds = [unpackCString2Id, unpackCStringId]
-
-addr2IntegerId = lookupThinAirId addr2IntegerIdKey
-
-unpackCStringId = lookupThinAirId unpackCStringIdKey
-unpackCString2Id = lookupThinAirId unpackCString2IdKey
-unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey
-unpackCStringFoldrId = lookupThinAirId unpackCStringFoldrIdKey
-
-foldrId = lookupThinAirId foldrIdKey
-buildId = lookupThinAirId buildIdKey
-\end{code}
-
-\begin{code}
-{-# NOINLINE thinAirIdMapRef #-}
-thinAirIdMapRef :: IORef (UniqFM Id)
-thinAirIdMapRef = unsafePerformIO (newIORef (panic "thinAirIdMap: still empty"))
-
-setThinAirIds :: [Id] -> IO ()
-setThinAirIds thin_air_ids
- = writeIORef thinAirIdMapRef the_map
- where
- the_map = listToUFM [(varUnique id, id) | id <- thin_air_ids]
-
-thinAirIdMap :: UniqFM Id
-thinAirIdMap = unsafePerformIO (readIORef thinAirIdMapRef)
- -- Read it just once, the first time someone tugs on thinAirIdMap
-
-lookupThinAirId :: Unique -> Id
-lookupThinAirId uniq = lookupWithDefaultUFM thinAirIdMap
- (panic "lookupThinAirId: no mapping") uniq
-\end{code}
-
diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index 694492e333..10673367a3 100644
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -53,7 +53,7 @@ import Type ( Type,
mkTyConApp, mkTyConTy, mkTyVarTys,
unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds
)
-import PrelMods ( pREL_GHC )
+import PrelNames ( pREL_GHC )
import Outputable
import Unique
\end{code}
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 7a76a1acc1..a2b6ae3910 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -48,11 +48,9 @@ module TysWiredIn (
-- tuples
mkTupleTy,
- tupleTyCon, tupleCon, unitTyCon, unitDataConId, pairTyCon,
-
- -- unboxed tuples
- mkUnboxedTupleTy,
- unboxedTupleTyCon, unboxedTupleCon,
+ tupleTyCon, tupleCon,
+ unitTyCon, unitDataConId, pairTyCon,
+ unboxedSingletonTyCon, unboxedSingletonDataCon,
unboxedPairTyCon, unboxedPairDataCon,
stablePtrTyCon,
@@ -77,7 +75,7 @@ module TysWiredIn (
import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId )
-- friends:
-import PrelMods
+import PrelNames
import TysPrim
-- others:
@@ -89,7 +87,7 @@ import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, tyConDataCons,
mkAlgTyCon, mkSynTyCon, mkTupleTyCon, isUnLiftedTyCon
)
-import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
+import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
mkFunTy, mkFunTys,
@@ -121,6 +119,7 @@ pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons
[] -- No context
argvrcs
cons
+ (length cons)
[] -- No derivings
new_or_data
is_rec
@@ -165,88 +164,49 @@ pcDataCon wrap_key mod str tyvars context arg_tys tycon
%************************************************************************
\begin{code}
-tupleTyCon :: Arity -> TyCon
-tupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_tuple i) -- Build one specially
- | otherwise = tupleTyConArr!i
-
-tupleCon :: Arity -> DataCon
-tupleCon i | i > mAX_TUPLE_SIZE = snd (mk_tuple i) -- Build one specially
- | otherwise = tupleConArr!i
-
-tupleTyCons :: [TyCon]
-tupleTyCons = elems tupleTyConArr
-
-tupleTyConArr :: Array Int TyCon
-tupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst tuples)
-
-tupleConArr :: Array Int DataCon
-tupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd tuples)
-
-tuples :: [(TyCon,DataCon)]
-tuples = [mk_tuple i | i <- [0..mAX_TUPLE_SIZE]]
-
-mk_tuple :: Int -> (TyCon,DataCon)
-mk_tuple arity = (tycon, tuple_con)
+tupleTyCon :: Boxity -> Arity -> TyCon
+tupleTyCon boxity i | i > mAX_TUPLE_SIZE = fst (mk_tuple boxity i) -- Build one specially
+tupleTyCon Boxed i = fst (boxedTupleArr ! i)
+tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)
+
+tupleCon :: Boxity -> Arity -> DataCon
+tupleCon boxity i | i > mAX_TUPLE_SIZE = snd (mk_tuple boxity i) -- Build one specially
+tupleCon Boxed i = snd (boxedTupleArr ! i)
+tupleCon Unboxed i = snd (unboxedTupleArr ! i)
+
+boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
+boxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Boxed i) | i <- [0..mAX_TUPLE_SIZE]]
+unboxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Unboxed i) | i <- [0..mAX_TUPLE_SIZE]]
+
+mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
+mk_tuple boxity arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con True
+ tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity
tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
- tc_kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
+ tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind
+ res_kind | isBoxed boxity = boxedTypeKind
+ | otherwise = unboxedTypeKind
+
+ tyvars | isBoxed boxity = take arity alphaTyVars
+ | otherwise = take arity openAlphaTyVars
tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon
- tyvars = take arity alphaTyVars
tyvar_tys = mkTyVarTys tyvars
- (mod_name, name_str) = mkTupNameStr arity
- tc_uniq = mkTupleTyConUnique arity
- dc_uniq = mkTupleDataConUnique arity
+ (mod_name, name_str) = mkTupNameStr boxity arity
+ tc_uniq = mkTupleTyConUnique boxity arity
+ dc_uniq = mkTupleDataConUnique boxity arity
mod = mkPrelModule mod_name
-unitTyCon = tupleTyCon 0
+unitTyCon = tupleTyCon Boxed 0
unitDataConId = dataConId (head (tyConDataCons unitTyCon))
-pairTyCon = tupleTyCon 2
-\end{code}
+pairTyCon = tupleTyCon Boxed 2
-%************************************************************************
-%* *
-\subsection[TysWiredIn-ubx-tuples]{Unboxed Tuple Types}
-%* *
-%************************************************************************
+unboxedSingletonTyCon = tupleTyCon Unboxed 1
+unboxedSingletonDataCon = tupleCon Unboxed 1
-\begin{code}
-unboxedTupleTyCon :: Arity -> TyCon
-unboxedTupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_unboxed_tuple i)
- | otherwise = unboxedTupleTyConArr!i
-
-unboxedTupleCon :: Arity -> DataCon
-unboxedTupleCon i | i > mAX_TUPLE_SIZE = snd (mk_unboxed_tuple i)
- | otherwise = unboxedTupleConArr!i
-
-unboxedTupleTyConArr :: Array Int TyCon
-unboxedTupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst ubx_tuples)
-
-unboxedTupleConArr :: Array Int DataCon
-unboxedTupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd ubx_tuples)
-
-ubx_tuples :: [(TyCon,DataCon)]
-ubx_tuples = [mk_unboxed_tuple i | i <- [0..mAX_TUPLE_SIZE]]
-
-mk_unboxed_tuple :: Int -> (TyCon,DataCon)
-mk_unboxed_tuple arity = (tycon, tuple_con)
- where
- tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con False
- tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
- tc_kind = mkArrowKinds (map tyVarKind tyvars) unboxedTypeKind
-
- tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon
- tyvars = take arity openAlphaTyVars
- tyvar_tys = mkTyVarTys tyvars
- (mod_name, name_str) = mkUbxTupNameStr arity
- tc_uniq = mkUbxTupleTyConUnique arity
- dc_uniq = mkUbxTupleDataConUnique arity
- mod = mkPrelModule mod_name
-
-unboxedPairTyCon = unboxedTupleTyCon 2
-unboxedPairDataCon = unboxedTupleCon 2
+unboxedPairTyCon = tupleTyCon Unboxed 2
+unboxedPairDataCon = tupleCon Unboxed 2
\end{code}
%************************************************************************
@@ -589,11 +549,8 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}.
\end{itemize}
\begin{code}
-mkTupleTy :: Int -> [Type] -> Type
-mkTupleTy arity tys = mkTyConApp (tupleTyCon arity) tys
-
-mkUnboxedTupleTy :: Int -> [Type] -> Type
-mkUnboxedTupleTy arity tys = mkTyConApp (unboxedTupleTyCon arity) tys
+mkTupleTy :: Boxity -> Int -> [Type] -> Type
+mkTupleTy boxity arity tys = mkTyConApp (tupleTyCon boxity arity) tys
-unitTy = mkTupleTy 0 []
+unitTy = mkTupleTy Boxed 0 []
\end{code}