X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelInfo.lhs;h=e97d2882b6767fadc9de76311c759bb9bcb40ad3;hb=caac75c6a454396dadff0323162ed14adb4893cd;hp=f659a9b7b926c7db08c08ddcd12332f64acd762c;hpb=573ef10b2afd99d3c6a36370a9367609716c97d2;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index f659a9b..e97d288 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -1,45 +1,56 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge} \begin{code} -#include "HsVersions.h" - module PrelInfo ( + module PrelNames, + module MkId, + + wiredInThings, -- Names of wired in things + wiredInThingEnv, + ghcPrimExports, + cCallableClassDecl, cReturnableClassDecl, assertDecl, + + -- 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, + + -- Class categories + isCcallishClass, isCreturnableClass, isNoDictClass, + isNumericClass, isStandardClass - -- finite maps for built-in things (for the renamer and typechecker): - builtinNameInfo, builtinNameMaps, - builtinValNamesMap, builtinTcNamesMap, - builtinKeysMap, - SYN_IE(BuiltinNames), - SYN_IE(BuiltinKeys), SYN_IE(BuiltinIdInfos), - - maybeCharLikeTyCon, maybeIntLikeTyCon ) where -IMP_Ubiq() -IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo ) - --- friends: -import PrelMods -- Prelude module names -import PrelVals -- VALUES -import PrimOp ( PrimOp(..), allThePrimOps ) -import PrimRep ( PrimRep(..) ) -import TysPrim -- TYPES -import TysWiredIn - --- others: -import FiniteMap ( FiniteMap, emptyFM, listToFM ) -import Id ( mkTupleCon, GenId, SYN_IE(Id) ) -import Maybes ( catMaybes ) -import Name ( origName, OrigName(..), Name ) -import RnHsSyn ( RnName(..) ) -import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) -import Type -import UniqFM ( UniqFM, emptyUFM, listToUFM ) -import Unique -- *Key stuff -import Util ( nOfThem, panic ) +#include "HsVersions.h" + +import PrelNames -- Prelude module names + +import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName, primOpOcc ) +import DataCon ( DataCon ) +import Id ( idName ) +import MkId ( mkPrimOpId, wiredInIds ) +import MkId -- All of it, for re-export +import Name ( nameOccName, nameRdrName ) +import RdrName ( mkRdrUnqual ) +import HsSyn ( HsTyVarBndr(..), TyClDecl(..), HsType(..) ) +import OccName ( mkVarOcc ) +import TysPrim ( primTyCons ) +import TysWiredIn ( wiredInTyCons ) +import RdrHsSyn ( mkClassDecl ) +import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv, + GenAvailInfo(..), RdrAvailInfo ) +import Class ( Class, classKey ) +import Type ( funTyCon, openTypeKind, liftedTypeKind ) +import TyCon ( tyConName ) +import SrcLoc ( noSrcLoc ) +import Util ( isIn ) \end{code} %************************************************************************ @@ -52,289 +63,141 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and @Classes@, the other to look up values. \begin{code} -builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos ) - -type BuiltinNames = (FiniteMap OrigName RnName, -- WiredIn Ids - FiniteMap OrigName RnName) -- WiredIn TyCons - -- Two maps because "[]" is in both... - -type BuiltinKeys = FiniteMap OrigName (Unique, Name -> RnName) - -- Names with known uniques - -type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids - -builtinNameMaps = case builtinNameInfo of { (x,_,_) -> x } -builtinKeysMap = case builtinNameInfo of { (_,x,_) -> x } -builtinValNamesMap = fst builtinNameMaps -builtinTcNamesMap = snd builtinNameMaps - -builtinNameInfo - = ( (listToFM assoc_val_wired, listToFM assoc_tc_wired) - , listToFM assoc_keys - , listToUFM assoc_id_infos - ) +wiredInThings :: [TyThing] +wiredInThings + = concat + [ -- Wired in TyCons and their implicit Ids + tycon_things + , map AnId (implicitTyThingIds tycon_things) + + -- Wired in Ids + , map AnId wiredInIds + + -- PrimOps + , map (AnId . mkPrimOpId) allThePrimOps + ] where - assoc_val_wired - = concat [ - -- data constrs - concat (map pcDataConWiredInInfo g_con_tycons), - concat (map pcDataConWiredInInfo data_tycons), - - -- values - map pcIdWiredInInfo wired_in_ids, - primop_ids - ] - assoc_tc_wired - = concat [ - -- tycons - map pcTyConWiredInInfo prim_tycons, - map pcTyConWiredInInfo g_tycons, - map pcTyConWiredInInfo data_tycons - ] - - assoc_keys - = concat - [ - id_keys, - tysyn_keys, - class_keys, - class_op_keys - ] - - id_keys = map id_key id_keys_infos - id_key (str_mod, uniq, info) = (str_mod, (uniq, RnImplicit)) - - assoc_id_infos = catMaybes (map assoc_info id_keys_infos) - assoc_info (str_mod, uniq, Just info) = Just (uniq, info) - assoc_info (str_mod, uniq, Nothing) = Nothing -\end{code} + tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons) +wiredInThingEnv :: TypeEnv +wiredInThingEnv = mkTypeEnv wiredInThings +\end{code} We let a lot of "non-standard" values be visible, so that we can make sense of them in interface pragmas. It's cool, though they all have "non-standard" names, so they won't get past the parser in user code. -The WiredIn TyCons and DataCons ... -\begin{code} - -prim_tycons - = [ addrPrimTyCon - , arrayPrimTyCon - , byteArrayPrimTyCon - , charPrimTyCon - , doublePrimTyCon - , floatPrimTyCon - , intPrimTyCon - , foreignObjPrimTyCon - , mutableArrayPrimTyCon - , mutableByteArrayPrimTyCon - , synchVarPrimTyCon - , realWorldTyCon - , stablePtrPrimTyCon - , statePrimTyCon - , wordPrimTyCon - ] +%************************************************************************ +%* * +\subsection{Export lists for pseudo-modules (GHC.Prim)} +%* * +%************************************************************************ -g_tycons - = mkFunTyCon : g_con_tycons - -g_con_tycons - = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..37] ] - -data_tycons - = [ addrTyCon - , boolTyCon - , charTyCon - , doubleTyCon - , floatTyCon - , foreignObjTyCon - , intTyCon - , integerTyCon - , liftTyCon - , primIoTyCon - , return2GMPsTyCon - , returnIntAndGMPTyCon - , stTyCon - , stablePtrTyCon - , stateAndAddrPrimTyCon - , stateAndArrayPrimTyCon - , stateAndByteArrayPrimTyCon - , stateAndCharPrimTyCon - , stateAndDoublePrimTyCon - , stateAndFloatPrimTyCon - , stateAndForeignObjPrimTyCon - , stateAndIntPrimTyCon - , stateAndMutableArrayPrimTyCon - , stateAndMutableByteArrayPrimTyCon - , stateAndPtrPrimTyCon - , stateAndStablePtrPrimTyCon - , stateAndSynchVarPrimTyCon - , stateAndWordPrimTyCon - , stateTyCon - , voidTyCon - , wordTyCon - ] -\end{code} +GHC.Prim "exports" all the primops and primitive types, some +wired-in Ids, and the CCallable & CReturnable classes. -The WiredIn Ids ... -ToDo: Some of these should be moved to id_keys_infos! \begin{code} -wired_in_ids - = [ aBSENT_ERROR_ID - , augmentId - , buildId --- , copyableId - , eRROR_ID - , foldlId - , foldrId --- , forkId - , iRREFUT_PAT_ERROR_ID - , integerMinusOneId - , integerPlusOneId - , integerPlusTwoId - , integerZeroId - , nON_EXHAUSTIVE_GUARDS_ERROR_ID - , nO_DEFAULT_METHOD_ERROR_ID - , nO_EXPLICIT_METHOD_ERROR_ID --- , noFollowId - , pAR_ERROR_ID - , pAT_ERROR_ID - , packStringForCId --- , parAtAbsId --- , parAtForNowId --- , parAtId --- , parAtRelId --- , parGlobalId --- , parId --- , parLocalId - , rEC_CON_ERROR_ID - , rEC_UPD_ERROR_ID - , realWorldPrimId - , runSTId --- , seqId - , tRACE_ID - , unpackCString2Id - , unpackCStringAppendId - , unpackCStringFoldrId - , unpackCStringId - , voidId - ] - -pcTyConWiredInInfo :: TyCon -> (OrigName, RnName) -pcTyConWiredInInfo tc = (origName "pcTyConWiredInInfo" tc, WiredInTyCon tc) +ghcPrimExports :: [RdrAvailInfo] + = AvailTC cCallableOcc [ cCallableOcc ] : + AvailTC cReturnableOcc [ cReturnableOcc ] : + Avail (nameOccName assertName) : -- doesn't have an Id + map (Avail . nameOccName . idName) ghcPrimIds ++ + map (Avail . primOpOcc) allThePrimOps ++ + [ AvailTC occ [occ] | + n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n) + ] + where + cCallableOcc = nameOccName cCallableClassName + cReturnableOcc = nameOccName cReturnableClassName + +assertDecl + = IfaceSig { + tcdName = nameRdrName assertName, + tcdType = HsForAllTy (Just [liftedAlpha]) [] (HsTyVar alpha), + tcdIdInfo = [], + tcdLoc = noSrcLoc + } + +cCallableClassDecl + = mkClassDecl + ([], nameRdrName cCallableClassName, [openAlpha]) + [] -- no fds + [] -- no sigs + Nothing -- no mbinds + noSrcLoc + +cReturnableClassDecl + = mkClassDecl + ([], nameRdrName cReturnableClassName, [openAlpha]) + [] -- no fds + [] -- no sigs + Nothing -- no mbinds + noSrcLoc + +alpha = mkRdrUnqual (mkVarOcc FSLIT("a")) +openAlpha = IfaceTyVar alpha openTypeKind +liftedAlpha = IfaceTyVar alpha liftedTypeKind +\end{code} -pcDataConWiredInInfo :: TyCon -> [(OrigName, RnName)] -pcDataConWiredInInfo tycon - = [ (origName "pcDataConWiredInInfo" con, WiredInId con) | con <- tyConDataCons tycon ] +%************************************************************************ +%* * +\subsection{RdrNames for the primops} +%* * +%************************************************************************ -pcIdWiredInInfo :: Id -> (OrigName, RnName) -pcIdWiredInInfo id = (origName "pcIdWiredInInfo" id, WiredInId id) -\end{code} +These can't be in PrelNames, because we get the RdrName from the PrimOp, +which is above PrelNames in the module hierarchy. -WiredIn primitive numeric operations ... \begin{code} -primop_ids - = map prim_fn allThePrimOps ++ map funny_fn funny_name_primops - where - prim_fn op = case (primOpNameInfo op) of (s,n) -> ((OrigName gHC_BUILTINS s),n) - funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((OrigName gHC_BUILTINS s),n) - -funny_name_primops - = [ (IntAddOp, SLIT("+#")) - , (IntSubOp, SLIT("-#")) - , (IntMulOp, SLIT("*#")) - , (IntGtOp, SLIT(">#")) - , (IntGeOp, SLIT(">=#")) - , (IntEqOp, SLIT("==#")) - , (IntNeOp, SLIT("/=#")) - , (IntLtOp, SLIT("<#")) - , (IntLeOp, SLIT("<=#")) - , (DoubleAddOp, SLIT("+##")) - , (DoubleSubOp, SLIT("-##")) - , (DoubleMulOp, SLIT("*##")) - , (DoubleDivOp, SLIT("/##")) - , (DoublePowerOp, SLIT("**##")) - , (DoubleGtOp, SLIT(">##")) - , (DoubleGeOp, SLIT(">=##")) - , (DoubleEqOp, SLIT("==##")) - , (DoubleNeOp, SLIT("/=##")) - , (DoubleLtOp, SLIT("<##")) - , (DoubleLeOp, SLIT("<=##")) - ] +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} -Ids, Synonyms, Classes and ClassOps with builtin keys. -For the Ids we may also have some builtin IdInfo. -\begin{code} -id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)] -id_keys_infos - = [ -- here because we use them in derived instances - (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing) - , (OrigName pRELUDE SLIT("."), composeIdKey, Nothing) - , (OrigName gHC__ SLIT("lex"), lexIdKey, Nothing) - , (OrigName pRELUDE SLIT("not"), notIdKey, Nothing) - , (OrigName pRELUDE SLIT("readParen"), readParenIdKey, Nothing) - , (OrigName pRELUDE SLIT("showParen"), showParenIdKey, Nothing) - , (OrigName pRELUDE SLIT("showString"), showStringIdKey,Nothing) - , (OrigName gHC__ SLIT("readList__"), ureadListIdKey, Nothing) - , (OrigName gHC__ SLIT("showList__"), ushowListIdKey, Nothing) - , (OrigName gHC__ SLIT("showSpace"), showSpaceIdKey, Nothing) - ] +%************************************************************************ +%* * +\subsection{Built-in keys} +%* * +%************************************************************************ -tysyn_keys - = [ (OrigName gHC__ SLIT("IO"), (iOTyConKey, RnImplicitTyCon)) - , (OrigName pRELUDE SLIT("Ordering"), (orderingTyConKey, RnImplicitTyCon)) - , (OrigName rATIO SLIT("Rational"), (rationalTyConKey, RnImplicitTyCon)) - , (OrigName rATIO SLIT("Ratio"), (ratioTyConKey, RnImplicitTyCon)) - ] +ToDo: make it do the ``like'' part properly (as in 0.26 and before). --- this "class_keys" list *must* include: --- classes that are grabbed by key (e.g., eqClassKey) --- classes in "Class.standardClassKeys" (quite a few) - -class_keys - = [ (str_mod, (k, RnImplicitClass)) | (str_mod,k) <- - [ (OrigName pRELUDE SLIT("Eq"), eqClassKey) -- mentioned, derivable - , (OrigName pRELUDE SLIT("Eval"), evalClassKey) -- mentioned - , (OrigName pRELUDE SLIT("Ord"), ordClassKey) -- derivable - , (OrigName pRELUDE SLIT("Num"), numClassKey) -- mentioned, numeric - , (OrigName pRELUDE SLIT("Real"), realClassKey) -- numeric - , (OrigName pRELUDE SLIT("Integral"), integralClassKey) -- numeric - , (OrigName pRELUDE SLIT("Fractional"), fractionalClassKey) -- numeric - , (OrigName pRELUDE SLIT("Floating"), floatingClassKey) -- numeric - , (OrigName pRELUDE SLIT("RealFrac"), realFracClassKey) -- numeric - , (OrigName pRELUDE SLIT("RealFloat"), realFloatClassKey) -- numeric - , (OrigName iX SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) - , (OrigName pRELUDE SLIT("Bounded"), boundedClassKey) -- derivable - , (OrigName pRELUDE SLIT("Enum"), enumClassKey) -- derivable - , (OrigName pRELUDE SLIT("Show"), showClassKey) -- derivable - , (OrigName pRELUDE SLIT("Read"), readClassKey) -- derivable - , (OrigName pRELUDE SLIT("Monad"), monadClassKey) - , (OrigName pRELUDE SLIT("MonadZero"), monadZeroClassKey) - , (OrigName pRELUDE SLIT("MonadPlus"), monadPlusClassKey) - , (OrigName pRELUDE SLIT("Functor"), functorClassKey) - , (OrigName gHC__ SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish - , (OrigName gHC__ SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish - ]] - -class_op_keys - = [ (str_mod, (k, RnImplicit)) | (str_mod,k) <- - [ (OrigName pRELUDE SLIT("fromInt"), fromIntClassOpKey) - , (OrigName pRELUDE SLIT("fromInteger"), fromIntegerClassOpKey) - , (OrigName pRELUDE SLIT("fromRational"), fromRationalClassOpKey) - , (OrigName pRELUDE SLIT("enumFrom"), enumFromClassOpKey) - , (OrigName pRELUDE SLIT("enumFromThen"), enumFromThenClassOpKey) - , (OrigName pRELUDE SLIT("enumFromTo"), enumFromToClassOpKey) - , (OrigName pRELUDE SLIT("enumFromThenTo"),enumFromThenToClassOpKey) - , (OrigName pRELUDE SLIT("=="), eqClassOpKey) - , (OrigName pRELUDE SLIT(">>="), thenMClassOpKey) - , (OrigName pRELUDE SLIT("zero"), zeroClassOpKey) - ]] +\begin{code} +maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool +maybeCharLikeCon con = con `hasKey` charDataConKey +maybeIntLikeCon con = con `hasKey` intDataConKey \end{code} -ToDo: make it do the ``like'' part properly (as in 0.26 and before). + +%************************************************************************ +%* * +\subsection{Class predicates} +%* * +%************************************************************************ + \begin{code} -maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing -maybeIntLikeTyCon tc = if (uniqueOf tc == intDataConKey) then Just intDataCon else Nothing +isCcallishClass, isCreturnableClass, isNoDictClass, + isNumericClass, isStandardClass :: Class -> Bool + +isNumericClass clas = classKey clas `is_elem` numericClassKeys +isStandardClass clas = classKey clas `is_elem` standardClassKeys +isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys +isCreturnableClass clas = classKey clas == cReturnableClassKey +isNoDictClass clas = classKey clas `is_elem` noDictClassKeys +is_elem = isIn "is_X_Class" \end{code}