X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FTysWiredIn.lhs;h=2975922af8db9f37b47845f3f3744e809ea93859;hb=ba2843abdfe6f055777e4e66e8add769fce31d29;hp=7e046be245ae9ebc213f77592568e1fbbb751049;hpb=f16228e47dbaf4c5eb710bf507b3b61bc5ad7122;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 7e046be..2975922 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -13,15 +13,6 @@ types and operations.'' module TysWiredIn ( wiredInTyCons, genericTyCons, - addrDataCon, - addrTy, - addrTyCon, - ptrDataCon, - ptrTy, - ptrTyCon, - funPtrDataCon, - funPtrTy, - funPtrTyCon, boolTy, boolTyCon, charDataCon, @@ -30,24 +21,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 +44,7 @@ module TysWiredIn ( -- tuples mkTupleTy, tupleTyCon, tupleCon, - unitTyCon, unitDataConId, pairTyCon, + unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, @@ -66,7 +53,6 @@ module TysWiredIn ( plusTyCon, inrDataCon, inlDataCon, crossTyCon, crossDataCon, - stablePtrTyCon, stringTy, trueDataCon, trueDataConId, unitTy, @@ -75,21 +61,14 @@ 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" -import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId ) +import {-# SOURCE #-} MkId( mkDataConWorkId ) import {-# SOURCE #-} Generics( mkTyConGenInfo ) -- friends: @@ -97,30 +76,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 OccName ( mkOccFS, tcName, dataName, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 ) +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 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,28 +110,28 @@ 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 data_tycons = genericTyCons ++ - [ addrTyCon - , ptrTyCon - , funPtrTyCon - , boolTyCon + [ boolTyCon , charTyCon , doubleTyCon , floatTyCon , 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 +154,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,29 +178,29 @@ 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 Name should be in the DataName name space; it's the name +-- of the DataCon itself. +-- -- 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. +-- the first is used for the datacon itself, +-- the second is used for the "worker name" -pcDataCon name tyvars context arg_tys tycon +pcDataCon dc_name tyvars context arg_tys tycon = data_con where - data_con = mkDataCon name - [ NotMarkedStrict | a <- arg_tys ] - [ {- no labelled fields -} ] - tyvars context [] [] arg_tys tycon work_id wrap_id - - wrap_rdr = nameRdrName name - wrap_occ = rdrNameOcc wrap_rdr - - mod = nameModule name - wrap_id = mkDataConWrapId data_con - - work_occ = mkWorkerOcc wrap_occ - work_key = incrUnique (nameUnique name) - work_name = mkWiredInName mod work_occ work_key - work_id = mkDataConId work_name data_con + data_con = mkDataCon dc_name + [{- No strictness -}] + [{- No labelled fields -}] + tyvars context [] [] arg_tys tycon work_id + Nothing {- No wrapper for wired-in things + (they are too simple to need one) -} + + mod = nameModule dc_name + wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) + wrk_key = incrUnique (nameUnique dc_name) + wrk_name = mkWiredInName mod wrk_occ wrk_key + work_id = mkDataConWorkId wrk_name data_con \end{code} @@ -247,8 +222,8 @@ 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]] +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) @@ -268,11 +243,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 +295,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] @@ -333,81 +305,19 @@ wordDataCon = pcDataCon wordDataConName [] [] [wordPrimTy] wordTyCon \end{code} \begin{code} -addrTy = mkTyConTy addrTyCon - -addrTyCon = pcNonRecDataTyCon addrTyConName [] [] [addrDataCon] -addrDataCon = pcDataCon addrDataConName [] [] [addrPrimTy] addrTyCon - -isAddrTy :: Type -> Bool -isAddrTy = isTyCon addrTyConKey -\end{code} - -\begin{code} -ptrTy = mkTyConTy ptrTyCon - -ptrTyCon = pcNonRecDataTyCon ptrTyConName alpha_tyvar [(True,False)] [ptrDataCon] -ptrDataCon = pcDataCon ptrDataConName alpha_tyvar [] [addrPrimTy] ptrTyCon -\end{code} - -\begin{code} -funPtrTy = mkTyConTy funPtrTyCon - -funPtrTyCon = pcNonRecDataTyCon funPtrTyConName alpha_tyvar [(True,False)] [funPtrDataCon] -funPtrDataCon = pcDataCon funPtrDataConName alpha_tyvar [] [addrPrimTy] funPtrTyCon -\end{code} - -\begin{code} 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] +doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [] [doubleDataCon] doubleDataCon = pcDataCon doubleDataConName [] [] [doublePrimTy] doubleTyCon \end{code} -\begin{code} -stablePtrTyCon - = pcNonRecDataTyCon stablePtrTyConName - alpha_tyvar [(True,False)] [stablePtrDataCon] - where - stablePtrDataCon - = pcDataCon stablePtrDataConName - 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} %************************************************************************ %* * @@ -427,127 +337,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 +397,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 +485,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} %* *