X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelInfo.lhs;h=466c140b963bc0fb56361c6f6b457f111733925c;hb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;hp=f857b893295eff96563da61f606e5c12ecd656a4;hpb=f9120c200bcf613b58d742802172fb4c08171f0d;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index f857b89..466c140 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -8,85 +8,15 @@ module PrelInfo ( - pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO, - pRELUDE_LIST, pRELUDE_TEXT, - pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS, - gLASGOW_ST, gLASGOW_MISC, - -- finite maps for built-in things (for the renamer and typechecker): builtinNameInfo, BuiltinNames(..), BuiltinKeys(..), BuiltinIdInfos(..), - -- *odd* values that need to be reached out and grabbed: - eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID, - packStringForCId, - unpackCStringId, unpackCString2Id, - unpackCStringAppendId, unpackCStringFoldrId, - integerZeroId, integerPlusOneId, - integerPlusTwoId, integerMinusOneId, - - ----------------------------------------------------- - -- the rest of the export list is organised by *type* - ----------------------------------------------------- - - -- type: Bool - boolTyCon, boolTy, falseDataCon, trueDataCon, - - -- types: Char#, Char, String (= [Char]) - charPrimTy, charTy, stringTy, - charPrimTyCon, charTyCon, charDataCon, - - -- type: Ordering (used in deriving) - orderingTy, ltDataCon, eqDataCon, gtDataCon, - - -- types: Double#, Double - doublePrimTy, doubleTy, - doublePrimTyCon, doubleTyCon, doubleDataCon, - - -- types: Float#, Float - floatPrimTy, floatTy, - floatPrimTyCon, floatTyCon, floatDataCon, - - -- types: Glasgow *primitive* arrays, sequencing and I/O - mkPrimIoTy, -- to typecheck "mainPrimIO" & for _ccall_s - realWorldStatePrimTy, realWorldStateTy{-boxed-}, - realWorldTy, realWorldTyCon, realWorldPrimId, - statePrimTyCon, stateDataCon, getStatePairingConInfo, - - byteArrayPrimTy, - - -- types: Void# (only used within the compiler) - voidPrimTy, voidPrimId, - - -- types: Addr#, Int#, Word#, Int - intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon, - wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon, - addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon, - - -- types: Integer, Rational (= Ratio Integer) - integerTy, rationalTy, - integerTyCon, integerDataCon, - rationalTyCon, ratioDataCon, - - -- type: Lift - liftTyCon, liftDataCon, mkLiftTy, - - -- type: List - listTyCon, mkListTy, nilDataCon, consDataCon, - - -- type: tuples - mkTupleTy, unitTy, - - -- for compilation of List Comprehensions and foldr - foldlId, foldrId, - mkBuild, buildId, augmentId, appendId - - -- and, finally, we must put in some (abstract) data types, - -- to make the interface self-sufficient + maybeCharLikeTyCon, maybeIntLikeTyCon ) where -import Ubiq -import PrelLoop ( primOpNameInfo ) +IMP_Ubiq() +IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo ) -- friends: import PrelMods -- Prelude module names @@ -104,8 +34,7 @@ import CmdLineOpts ( opt_HideBuiltinNames, import FiniteMap ( FiniteMap, emptyFM, listToFM ) import Id ( mkTupleCon, GenId, Id(..) ) import Maybes ( catMaybes ) -import Name ( mkBuiltinName ) -import Outputable ( getOrigName ) +import Name ( origName, OrigName(..) ) import RnHsSyn ( RnName(..) ) import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) import Type @@ -126,39 +55,38 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and \begin{code} builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos ) -type BuiltinNames = FiniteMap FAST_STRING RnName -- WiredIn Ids/TyCons -type BuiltinKeys = FiniteMap FAST_STRING Unique -- Names with known uniques +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 builtinNameInfo = if opt_HideBuiltinNames then ( - emptyFM, + (emptyFM, emptyFM), emptyFM, emptyUFM ) else if opt_HideMostBuiltinNames then ( - listToFM min_assoc_wired, + (listToFM min_assoc_val_wired, listToFM min_assoc_tc_wired), emptyFM, emptyUFM ) else ( - listToFM assoc_wired, + (listToFM assoc_val_wired, listToFM assoc_tc_wired), listToFM assoc_keys, listToUFM assoc_id_infos ) where - min_assoc_wired -- min needed when compiling bits of Prelude - = concat - [ - -- tycons - map pcTyConWiredInInfo prim_tycons, - map pcTyConWiredInInfo g_tycons, - map pcTyConWiredInInfo min_nonprim_tycon_list, - + min_assoc_val_wired -- min needed when compiling bits of Prelude + = concat [ -- data constrs concat (map pcDataConWiredInInfo g_con_tycons), concat (map pcDataConWiredInInfo min_nonprim_tycon_list), @@ -166,26 +94,32 @@ builtinNameInfo -- values map pcIdWiredInInfo wired_in_ids, primop_ids - ] - - assoc_wired - = concat - [ + ] + min_assoc_tc_wired + = concat [ -- tycons map pcTyConWiredInInfo prim_tycons, map pcTyConWiredInInfo g_tycons, - map pcTyConWiredInInfo data_tycons, - map pcTyConWiredInInfo synonym_tycons, + map pcTyConWiredInInfo min_nonprim_tycon_list + ] - -- data consts + assoc_val_wired + = concat [ + -- data constrs concat (map pcDataConWiredInInfo g_con_tycons), concat (map pcDataConWiredInInfo data_tycons), -- values map pcIdWiredInInfo wired_in_ids, - map pcIdWiredInInfo parallel_ids, primop_ids ] + assoc_tc_wired + = concat [ + -- tycons + map pcTyConWiredInInfo prim_tycons, + map pcTyConWiredInInfo g_tycons, + map pcTyConWiredInInfo data_tycons + ] assoc_keys = concat @@ -197,11 +131,11 @@ builtinNameInfo ] id_keys = map id_key id_keys_infos - id_key (str, uniq, info) = (str, uniq) + id_key (str_mod, uniq, info) = (str_mod, (uniq, RnImplicit)) assoc_id_infos = catMaybes (map assoc_info id_keys_infos) - assoc_info (str, uniq, Just info) = Just (uniq, info) - assoc_info (str, uniq, Nothing) = Nothing + assoc_info (str_mod, uniq, Just info) = Just (uniq, info) + assoc_info (str_mod, uniq, Nothing) = Nothing \end{code} @@ -213,21 +147,21 @@ The WiredIn TyCons and DataCons ... \begin{code} prim_tycons - = [addrPrimTyCon, - arrayPrimTyCon, - byteArrayPrimTyCon, - charPrimTyCon, - doublePrimTyCon, - floatPrimTyCon, - intPrimTyCon, - mallocPtrPrimTyCon, - mutableArrayPrimTyCon, - mutableByteArrayPrimTyCon, - synchVarPrimTyCon, - realWorldTyCon, - stablePtrPrimTyCon, - statePrimTyCon, - wordPrimTyCon + = [ addrPrimTyCon + , arrayPrimTyCon + , byteArrayPrimTyCon + , charPrimTyCon + , doublePrimTyCon + , floatPrimTyCon + , intPrimTyCon + , foreignObjPrimTyCon + , mutableArrayPrimTyCon + , mutableByteArrayPrimTyCon + , synchVarPrimTyCon + , realWorldTyCon + , stablePtrPrimTyCon + , statePrimTyCon + , wordPrimTyCon ] g_tycons @@ -237,142 +171,138 @@ g_con_tycons = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..32] ] min_nonprim_tycon_list -- used w/ HideMostBuiltinNames - = [ boolTyCon, - orderingTyCon, - charTyCon, - intTyCon, - floatTyCon, - doubleTyCon, - integerTyCon, - ratioTyCon, - liftTyCon, - return2GMPsTyCon, -- ADR asked for these last two (WDP 94/11) - returnIntAndGMPTyCon + = [ boolTyCon + , charTyCon + , intTyCon + , floatTyCon + , doubleTyCon + , integerTyCon + , liftTyCon + , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11) + , returnIntAndGMPTyCon ] data_tycons - = [ - addrTyCon, - boolTyCon, - charTyCon, - orderingTyCon, - doubleTyCon, - floatTyCon, - intTyCon, - integerTyCon, - liftTyCon, - mallocPtrTyCon, - ratioTyCon, - return2GMPsTyCon, - returnIntAndGMPTyCon, - stablePtrTyCon, - stateAndAddrPrimTyCon, - stateAndArrayPrimTyCon, - stateAndByteArrayPrimTyCon, - stateAndCharPrimTyCon, - stateAndDoublePrimTyCon, - stateAndFloatPrimTyCon, - stateAndIntPrimTyCon, - stateAndMallocPtrPrimTyCon, - stateAndMutableArrayPrimTyCon, - stateAndMutableByteArrayPrimTyCon, - stateAndSynchVarPrimTyCon, - stateAndPtrPrimTyCon, - stateAndStablePtrPrimTyCon, - stateAndWordPrimTyCon, - stateTyCon, - wordTyCon + = [ 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 ] - -synonym_tycons - = [ - primIoTyCon, - rationalTyCon, - stTyCon, - stringTyCon - ] - -pcTyConWiredInInfo :: TyCon -> (FAST_STRING, RnName) -pcTyConWiredInInfo tc = (snd (getOrigName tc), WiredInTyCon tc) - -pcDataConWiredInInfo :: TyCon -> [(FAST_STRING, RnName)] -pcDataConWiredInInfo tycon - = [ (snd (getOrigName con), WiredInId con) | con <- tyConDataCons tycon ] \end{code} The WiredIn Ids ... ToDo: Some of these should be moved to id_keys_infos! \begin{code} wired_in_ids - = [eRROR_ID, - pAT_ERROR_ID, -- occurs in i/faces - pAR_ERROR_ID, -- ditto - tRACE_ID, - - runSTId, - seqId, - realWorldPrimId, - - -- foldr/build Ids have magic unfoldings - buildId, - augmentId, - foldlId, - foldrId, - unpackCStringAppendId, - unpackCStringFoldrId + = [ 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 + , tRACE_ID + , unpackCString2Id + , unpackCStringAppendId + , unpackCStringFoldrId + , unpackCStringId + , voidId ] -parallel_ids - = if not opt_ForConcurrent then - [] - else - [parId, - forkId -#ifdef GRAN - ,parLocalId - ,parGlobalId - -- Add later: - -- ,parAtId - -- ,parAtForNowId - -- ,copyableId - -- ,noFollowId -#endif {-GRAN-} - ] - -pcIdWiredInInfo :: Id -> (FAST_STRING, RnName) -pcIdWiredInInfo id = (snd (getOrigName id), WiredInId id) +pcTyConWiredInInfo :: TyCon -> (OrigName, RnName) +pcTyConWiredInInfo tc = (origName "pcTyConWiredInInfo" tc, WiredInTyCon tc) + +pcDataConWiredInInfo :: TyCon -> [(OrigName, RnName)] +pcDataConWiredInInfo tycon + = [ (origName "pcDataConWiredInInfo" con, WiredInId con) | con <- tyConDataCons tycon ] + +pcIdWiredInInfo :: Id -> (OrigName, RnName) +pcIdWiredInInfo id = (origName "pcIdWiredInInfo" id, WiredInId id) \end{code} WiredIn primitive numeric operations ... \begin{code} primop_ids - = map primOpNameInfo allThePrimOps ++ map fn funny_name_primops + = map prim_fn allThePrimOps ++ map funny_fn funny_name_primops where - fn (op,s) = case (primOpNameInfo op) of (_,n) -> (s,n) + prim_fn op = case (primOpNameInfo op) of (s,n) -> ((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("<=##")) + = [ (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("<=##")) ] \end{code} @@ -380,48 +310,78 @@ funny_name_primops Ids, Synonyms, Classes and ClassOps with builtin keys. For the Ids we may also have some builtin IdInfo. \begin{code} -id_keys_infos :: [(FAST_STRING, Unique, Maybe IdInfo)] +id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)] id_keys_infos - = [ + = [ -- here so we can check the type of main/mainPrimIO + (OrigName SLIT("Main") SLIT("main"), mainIdKey, Nothing) + , (OrigName SLIT("Main") SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing) + + -- here because we use them in derived instances + , (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing) + , (OrigName pRELUDE SLIT("."), composeIdKey, Nothing) + , (OrigName pRELUDE 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) ] tysyn_keys - = [ - (SLIT("IO"), iOTyConKey) -- SLIT("PreludeMonadicIO") + = [ (OrigName gHC__ SLIT("IO"), (iOTyConKey, RnImplicitTyCon)) + , (OrigName pRELUDE SLIT("Ordering"), (orderingTyConKey, RnImplicitTyCon)) + , (OrigName rATIO SLIT("Rational"), (rationalTyConKey, RnImplicitTyCon)) + , (OrigName rATIO SLIT("Ratio"), (ratioTyConKey, RnImplicitTyCon)) ] +-- this "class_keys" list *must* include: +-- classes that are grabbed by key (e.g., eqClassKey) +-- classes in "Class.standardClassKeys" (quite a few) + class_keys - = [ - (SLIT("Eq"), eqClassKey), - (SLIT("Ord"), ordClassKey), - (SLIT("Num"), numClassKey), - (SLIT("Real"), realClassKey), - (SLIT("Integral"), integralClassKey), - (SLIT("Fractional"), fractionalClassKey), - (SLIT("Floating"), floatingClassKey), - (SLIT("RealFrac"), realFracClassKey), - (SLIT("RealFloat"), realFloatClassKey), - (SLIT("Ix"), ixClassKey), - (SLIT("Enum"), enumClassKey), - (SLIT("Show"), showClassKey), - (SLIT("Read"), readClassKey), - (SLIT("Monad"), monadClassKey), - (SLIT("MonadZero"), monadZeroClassKey), - (SLIT("Binary"), binaryClassKey), - (SLIT("_CCallable"), cCallableClassKey), - (SLIT("_CReturnable"), cReturnableClassKey) - ] + = [ (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 - = [ - (SLIT("fromInt"), fromIntClassOpKey), - (SLIT("fromInteger"), fromIntegerClassOpKey), - (SLIT("fromRational"), fromRationalClassOpKey), - (SLIT("enumFrom"), enumFromClassOpKey), - (SLIT("enumFromThen"), enumFromThenClassOpKey), - (SLIT("enumFromTo"), enumFromToClassOpKey), - (SLIT("enumFromThenTo"), enumFromThenToClassOpKey), - (SLIT("=="), eqClassOpKey), - (SLIT(">="), geClassOpKey) - ] + = [ (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) + ]] +\end{code} + +ToDo: make it do the ``like'' part properly (as in 0.26 and before). +\begin{code} +maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing +maybeIntLikeTyCon tc = if (uniqueOf tc == intDataConKey) then Just intDataCon else Nothing \end{code}