X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FTysWiredIn.lhs;h=5b6754efb75f36025c6be5904e4e368fedbfd158;hb=d8a22a2b98e2ccb3a49d6524583fbad636c7d81d;hp=7e046be245ae9ebc213f77592568e1fbbb751049;hpb=f16228e47dbaf4c5eb710bf507b3b61bc5ad7122;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 7e046be..5b6754e 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -30,24 +30,20 @@ module TysWiredIn ( consDataCon, doubleDataCon, doubleTy, - isDoubleTy, doubleTyCon, falseDataCon, falseDataConId, floatDataCon, floatTy, - isFloatTy, floatTyCon, intDataCon, intTy, intTyCon, - isIntTy, integerTy, integerTyCon, smallIntegerDataCon, largeIntegerDataCon, - isIntegerTy, listTyCon, @@ -57,7 +53,7 @@ module TysWiredIn ( -- tuples mkTupleTy, tupleTyCon, tupleCon, - unitTyCon, unitDataConId, pairTyCon, + unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, @@ -75,16 +71,9 @@ module TysWiredIn ( wordTy, wordTyCon, - isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool - isFFIImportResultTy, -- :: DynFlags -> Type -> Bool - isFFIExportResultTy, -- :: Type -> Bool - isFFIExternalTy, -- :: Type -> Bool - isFFIDynArgumentTy, -- :: Type -> Bool - isFFIDynResultTy, -- :: Type -> Bool - isFFILabelTy, -- :: Type -> Bool - isAddrTy, -- :: Type -> Bool - isForeignPtrTy -- :: Type -> Bool - + -- parallel arrays + mkPArrTy, + parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon ) where #include "HsVersions.h" @@ -97,30 +86,27 @@ import PrelNames import TysPrim -- others: -import ForeignCall ( Safety, playSafe ) import Constants ( mAX_TUPLE_SIZE ) -import Module ( mkPrelModule ) -import Name ( Name, nameRdrName, nameUnique, nameOccName, +import Module ( mkBasePkgModule ) +import Name ( Name, nameUnique, nameOccName, nameModule, mkWiredInName ) import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 ) -import RdrName ( rdrNameOcc ) -import DataCon ( DataCon, mkDataCon, dataConId ) -import Demand ( StrictnessMark(..) ) +import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) -import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons, - mkTupleTyCon, isUnLiftedTyCon, mkAlgTyCon +import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, + mkTupleTyCon, mkAlgTyCon, tyConName ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) -import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, +import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, - splitTyConApp_maybe, repType, - TauType, ThetaType ) -import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) + ThetaType ) +import Unique ( incrUnique, mkTupleTyConUnique, + mkTupleDataConUnique, mkPArrDataConUnique ) import PrelNames -import CmdLineOpts import Array +import FastString alpha_tyvar = [alphaTyVar] alpha_ty = [alphaTy] @@ -134,6 +120,9 @@ alpha_beta_tyvars = [alphaTyVar, betaTyVar] %* * %************************************************************************ +If you change which things are wired in, make sure you change their +names in PrelNames, so they use wTcQual, wDataQual, etc + \begin{code} wiredInTyCons :: [TyCon] wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons @@ -149,13 +138,13 @@ data_tycons = genericTyCons ++ , intTyCon , integerTyCon , listTyCon + , parrTyCon , wordTyCon ] genericTyCons :: [TyCon] genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ] - tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..mAX_TUPLE_SIZE] ] unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ] \end{code} @@ -178,8 +167,7 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons tyvars [] -- No context argvrcs - cons - (length cons) + (DataCons cons) [] -- No record selectors new_or_data is_rec @@ -203,7 +191,7 @@ mk_tc_gen_info mod tc_uniq tc_name tycon name1 = mkWiredInName mod occ_name1 fn1_key name2 = mkWiredInName mod occ_name2 fn2_key -pcDataCon :: Name -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon +pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon -- The unique is the first of two free uniques; -- the first is used for the datacon itself and the worker; -- the second is used for the wrapper. @@ -216,8 +204,7 @@ pcDataCon name tyvars context arg_tys tycon [ {- no labelled fields -} ] tyvars context [] [] arg_tys tycon work_id wrap_id - wrap_rdr = nameRdrName name - wrap_occ = rdrNameOcc wrap_rdr + wrap_occ = nameOccName name mod = nameModule name wrap_id = mkDataConWrapId data_con @@ -268,11 +255,12 @@ mk_tuple boxity arity = (tycon, tuple_con) name = mkWiredInName mod (mkOccFS dataName name_str) dc_uniq tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity - mod = mkPrelModule mod_name + mod = mkBasePkgModule mod_name gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon unitTyCon = tupleTyCon Boxed 0 -unitDataConId = dataConId (head (tyConDataCons unitTyCon)) +unitDataCon = head (tyConDataCons unitTyCon) +unitDataConId = dataConWorkId unitDataCon pairTyCon = tupleTyCon Boxed 2 @@ -319,13 +307,9 @@ intTy = mkTyConTy intTyCon intTyCon = pcNonRecDataTyCon intTyConName [] [] [intDataCon] intDataCon = pcDataCon intDataConName [] [] [intPrimTy] intTyCon - -isIntTy :: Type -> Bool -isIntTy = isTyCon intTyConKey \end{code} \begin{code} - wordTy = mkTyConTy wordTyCon wordTyCon = pcNonRecDataTyCon wordTyConName [] [] [wordDataCon] @@ -337,9 +321,6 @@ addrTy = mkTyConTy addrTyCon addrTyCon = pcNonRecDataTyCon addrTyConName [] [] [addrDataCon] addrDataCon = pcDataCon addrDataConName [] [] [addrPrimTy] addrTyCon - -isAddrTy :: Type -> Bool -isAddrTy = isTyCon addrTyConKey \end{code} \begin{code} @@ -361,17 +342,11 @@ floatTy = mkTyConTy floatTyCon floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] floatDataCon = pcDataCon floatDataConName [] [] [floatPrimTy] floatTyCon - -isFloatTy :: Type -> Bool -isFloatTy = isTyCon floatTyConKey \end{code} \begin{code} doubleTy = mkTyConTy doubleTyCon -isDoubleTy :: Type -> Bool -isDoubleTy = isTyCon doubleTyConKey - doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [] [doubleDataCon] doubleDataCon = pcDataCon doubleDataConName [] [] [doublePrimTy] doubleTyCon \end{code} @@ -386,29 +361,6 @@ stablePtrTyCon alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon \end{code} -\begin{code} -foreignObjTyCon - = pcNonRecDataTyCon foreignObjTyConName - [] [] [foreignObjDataCon] - where - foreignObjDataCon - = pcDataCon foreignObjDataConName - [] [] [foreignObjPrimTy] foreignObjTyCon -\end{code} - -\begin{code} -foreignPtrTyCon - = pcNonRecDataTyCon foreignPtrTyConName - alpha_tyvar [(True,False)] [foreignPtrDataCon] - where - foreignPtrDataCon - = pcDataCon foreignPtrDataConName - alpha_tyvar [] [foreignObjPrimTy] foreignPtrTyCon - -isForeignPtrTy :: Type -> Bool -isForeignPtrTy = isTyCon foreignPtrTyConKey -\end{code} - %************************************************************************ %* * \subsection[TysWiredIn-Integer]{@Integer@ and its related ``pairing'' types} @@ -427,127 +379,6 @@ smallIntegerDataCon = pcDataCon smallIntegerDataConName [] [] [intPrimTy] integerTyCon largeIntegerDataCon = pcDataCon largeIntegerDataConName [] [] [intPrimTy, byteArrayPrimTy] integerTyCon - - -isIntegerTy :: Type -> Bool -isIntegerTy = isTyCon integerTyConKey -\end{code} - - -%************************************************************************ -%* * -\subsection[TysWiredIn-ext-type]{External types} -%* * -%************************************************************************ - -The compiler's foreign function interface supports the passing of a -restricted set of types as arguments and results (the restricting factor -being the ) - -\begin{code} -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool --- Checks for valid argument type for a 'foreign import' -isFFIArgumentTy dflags safety ty - = checkRepTyCon (legalOutgoingTyCon dflags safety) ty - -isFFIExternalTy :: Type -> Bool --- Types that are allowed as arguments of a 'foreign export' -isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty - -isFFIImportResultTy :: DynFlags -> Type -> Bool -isFFIImportResultTy dflags ty - = checkRepTyCon (legalFIResultTyCon dflags) ty - -isFFIExportResultTy :: Type -> Bool -isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty - -isFFIDynArgumentTy :: Type -> Bool --- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr, --- or a newtype of either. -isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) - -isFFIDynResultTy :: Type -> Bool --- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr, --- or a newtype of either. -isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) - -isFFILabelTy :: Type -> Bool --- The type of a foreign label must be Ptr, FunPtr, Addr, --- or a newtype of either. -isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) - -checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool - -- look through newtypes -checkRepTyCon check_tc ty = checkTyCon check_tc (repType ty) - -checkTyCon :: (TyCon -> Bool) -> Type -> Bool -checkTyCon check_tc ty = case splitTyConApp_maybe ty of - Just (tycon, _) -> check_tc tycon - Nothing -> False - -isTyCon :: Unique -> Type -> Bool -isTyCon uniq ty = checkTyCon (\tc -> uniq == getUnique tc) ty -\end{code} - ----------------------------------------------- -These chaps do the work; they are not exported ----------------------------------------------- - -\begin{code} -legalFEArgTyCon :: TyCon -> Bool --- It's illegal to return foreign objects and (mutable) --- bytearrays from a _ccall_ / foreign declaration --- (or be passed them as arguments in foreign exported functions). -legalFEArgTyCon tc - | getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey, - byteArrayTyConKey, mutableByteArrayTyConKey ] - = False - -- It's also illegal to make foreign exports that take unboxed - -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 - | otherwise - = boxedMarshalableTyCon tc - -legalFIResultTyCon :: DynFlags -> TyCon -> Bool -legalFIResultTyCon dflags tc - | getUnique tc `elem` - [ foreignObjTyConKey, foreignPtrTyConKey, - byteArrayTyConKey, mutableByteArrayTyConKey ] = False - | tc == unitTyCon = True - | otherwise = marshalableTyCon dflags tc - -legalFEResultTyCon :: TyCon -> Bool -legalFEResultTyCon tc - | getUnique tc `elem` - [ foreignObjTyConKey, foreignPtrTyConKey, - byteArrayTyConKey, mutableByteArrayTyConKey ] = False - | tc == unitTyCon = True - | otherwise = boxedMarshalableTyCon tc - -legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool --- Checks validity of types going from Haskell -> external world -legalOutgoingTyCon dflags safety tc - | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] - = False - | otherwise - = marshalableTyCon dflags tc - -marshalableTyCon dflags tc - = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc) - || boxedMarshalableTyCon tc - -boxedMarshalableTyCon tc - = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey - , int32TyConKey, int64TyConKey - , wordTyConKey, word8TyConKey, word16TyConKey - , word32TyConKey, word64TyConKey - , floatTyConKey, doubleTyConKey - , addrTyConKey, ptrTyConKey, funPtrTyConKey - , charTyConKey, foreignObjTyConKey - , foreignPtrTyConKey - , stablePtrTyConKey - , byteArrayTyConKey, mutableByteArrayTyConKey - , boolTyConKey - ] \end{code} @@ -608,8 +439,8 @@ boolTyCon = pcTyCon EnumTyCon NonRecursive boolTyConName falseDataCon = pcDataCon falseDataConName [] [] [] boolTyCon trueDataCon = pcDataCon trueDataConName [] [] [] boolTyCon -falseDataConId = dataConId falseDataCon -trueDataConId = dataConId trueDataCon +falseDataConId = dataConWorkId falseDataCon +trueDataConId = dataConWorkId trueDataCon \end{code} %************************************************************************ @@ -696,6 +527,99 @@ unitTy = mkTupleTy Boxed 0 [] \end{code} %************************************************************************ +%* * +\subsection[TysWiredIn-PArr]{The @[::]@ type} +%* * +%************************************************************************ + +Special syntax for parallel arrays needs some wired in definitions. + +\begin{code} +-- construct a type representing the application of the parallel array +-- constructor +-- +mkPArrTy :: Type -> Type +mkPArrTy ty = mkTyConApp parrTyCon [ty] + +-- represents the type constructor of parallel arrays +-- +-- * this must match the definition in `PrelPArr' +-- +-- NB: Although the constructor is given here, it will not be accessible in +-- user code as it is not in the environment of any compiled module except +-- `PrelPArr'. +-- +parrTyCon :: TyCon +parrTyCon = tycon + where + tycon = mkAlgTyCon + parrTyConName + kind + tyvars + [] -- No context + [(True, False)] + (DataCons [parrDataCon]) -- The constructor defined in `PrelPArr' + [] -- No record selectors + DataTyCon + NonRecursive + genInfo + tyvars = alpha_tyvar + mod = nameModule parrTyConName + kind = mkArrowKinds (map tyVarKind tyvars) liftedTypeKind + genInfo = mk_tc_gen_info mod (nameUnique parrTyConName) parrTyConName tycon + +parrDataCon :: DataCon +parrDataCon = pcDataCon + parrDataConName + alpha_tyvar -- forall'ed type variables + [] -- context + [intPrimTy, -- 1st argument: Int# + mkTyConApp -- 2nd argument: Array# a + arrayPrimTyCon + alpha_ty] + parrTyCon + +-- check whether a type constructor is the constructor for parallel arrays +-- +isPArrTyCon :: TyCon -> Bool +isPArrTyCon tc = tyConName tc == parrTyConName + +-- fake array constructors +-- +-- * these constructors are never really used to represent array values; +-- however, they are very convenient during desugaring (and, in particular, +-- in the pattern matching compiler) to treat array pattern just like +-- yet another constructor pattern +-- +parrFakeCon :: Arity -> DataCon +parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially +parrFakeCon i = parrFakeConArr!i + +-- pre-defined set of constructors +-- +parrFakeConArr :: Array Int DataCon +parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) + | i <- [0..mAX_TUPLE_SIZE]] + +-- build a fake parallel array constructor for the given arity +-- +mkPArrFakeCon :: Int -> DataCon +mkPArrFakeCon arity = pcDataCon name [tyvar] [] tyvarTys parrTyCon + where + tyvar = head alphaTyVars + tyvarTys = replicate arity $ mkTyVarTy tyvar + nameStr = mkFastString ("MkPArr" ++ show arity) + name = mkWiredInName mod (mkOccFS dataName nameStr) uniq + uniq = mkPArrDataConUnique arity + mod = mkBasePkgModule pREL_PARR_Name + +-- checks whether a data constructor is a fake constructor for parallel arrays +-- +isPArrFakeCon :: DataCon -> Bool +isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) +\end{code} + +%************************************************************************ %* * \subsection{Wired In Type Constructors for Representation Types} %* *