diff options
Diffstat (limited to 'ghc/compiler/prelude')
| -rw-r--r-- | ghc/compiler/prelude/PrelInfo.lhs | 319 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrelMods.lhs | 101 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrelNames.lhs | 341 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrelRules.lhs | 27 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrimOp.lhs | 19 | ||||
| -rw-r--r-- | ghc/compiler/prelude/ThinAir.lhs | 109 | ||||
| -rw-r--r-- | ghc/compiler/prelude/TysPrim.lhs | 2 | ||||
| -rw-r--r-- | ghc/compiler/prelude/TysWiredIn.lhs | 125 |
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} |