doubleTy,
isDoubleTy,
doubleTyCon,
- falseDataCon,
+ falseDataCon, falseDataConId,
floatDataCon,
floatTy,
isFloatTy,
intTy,
intTyCon,
isIntTy,
- inIntRange,
-
- int8TyCon,
- int16TyCon,
- int32TyCon,
-
- int64TyCon,
integerTy,
integerTyCon,
- integerDataCon,
+ smallIntegerDataCon,
+ largeIntegerDataCon,
isIntegerTy,
listTyCon,
-- tuples
mkTupleTy,
- tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
+ tupleTyCon, tupleCon, unitTyCon, unitDataConId, pairTyCon,
-- unboxed tuples
mkUnboxedTupleTy,
stablePtrTyCon,
stringTy,
- trueDataCon,
+ trueDataCon, trueDataConId,
unitTy,
voidTy,
wordDataCon,
wordTy,
wordTyCon,
- word8TyCon,
- word16TyCon,
- word32TyCon,
- word64TyCon,
-
- isFFIArgumentTy, -- :: Type -> Bool
+ isFFIArgumentTy, -- :: Bool -> Type -> Bool
isFFIResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
isAddrTy, -- :: Type -> Bool
+ isForeignObjTy -- :: Type -> Bool
) where
#include "HsVersions.h"
-import {-# SOURCE #-} MkId( mkDataConId )
+import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId )
-- friends:
import PrelMods
-- others:
import Constants ( mAX_TUPLE_SIZE )
-import Name ( Module, varOcc, mkWiredInTyConName, mkWiredInIdName )
-import DataCon ( DataCon, mkDataCon )
+import Module ( Module, mkPrelModule )
+import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName )
+import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId )
import Var ( TyVar, tyVarKind )
-import TyCon ( TyCon, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
-import BasicTypes ( Arity, NewOrData(..),
- RecFlag(..), StrictnessMark(..) )
+import TyCon ( TyCon, ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
+import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
mkFunTy, mkFunTys, isUnLiftedType,
splitTyConApp_maybe, splitAlgTyConApp_maybe,
- ThetaType, TauType )
+ TauType, ClassContext )
import PrimRep ( PrimRep(..) )
import Unique
import CmdLineOpts ( opt_GlasgowExts )
pcRecDataTyCon, pcNonRecDataTyCon, pcNonRecNewTyCon
:: Unique{-TyConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> [DataCon] -> TyCon
+ -> [TyVar] -> ArgVrcs -> [DataCon] -> TyCon
pcRecDataTyCon = pcTyCon DataType Recursive
pcNonRecDataTyCon = pcTyCon DataType NonRecursive
pcNonRecNewTyCon = pcTyCon NewType NonRecursive
-pcTyCon new_or_data is_rec key mod str tyvars cons
+pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons
= tycon
where
tycon = mkAlgTyCon name kind
tyvars
[] -- No context
+ argvrcs
cons
[] -- No derivings
Nothing -- Not a dictionary
name = mkWiredInTyConName key mod str tycon
kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
-pcSynTyCon key mod str kind arity tyvars expansion
+pcSynTyCon key mod str kind arity tyvars expansion argvrcs -- this fun never used!
= tycon
where
- tycon = mkSynTyCon name kind arity tyvars expansion
+ tycon = mkSynTyCon name kind arity tyvars expansion argvrcs
name = mkWiredInTyConName key mod str tycon
pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon
-pcDataCon key mod str tyvars context arg_tys tycon
+ -> [TyVar] -> ClassContext -> [TauType] -> 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.
+pcDataCon wrap_key mod str tyvars context arg_tys tycon
= data_con
where
- data_con = mkDataCon name
+ data_con = mkDataCon wrap_name
[ NotMarkedStrict | a <- arg_tys ]
[ {- no labelled fields -} ]
- tyvars context [] [] arg_tys tycon id
- name = mkWiredInIdName key mod (varOcc str) id
- id = mkDataConId data_con
+ tyvars context [] [] arg_tys tycon work_id wrap_id
+
+ work_occ = mkWorkerOcc wrap_occ
+ work_key = incrUnique wrap_key
+ work_name = mkWiredInIdName work_key mod work_occ work_id
+ work_id = mkDataConId work_name data_con
+
+ wrap_occ = mkSrcOccFS dataName str
+ wrap_name = mkWiredInIdName wrap_key mod wrap_occ wrap_id
+ wrap_id = mkDataConWrapId data_con
\end{code}
%************************************************************************
mk_tuple arity = (tycon, tuple_con)
where
tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con True
- tc_name = mkWiredInTyConName tc_uniq mod_name name_str tycon
+ tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
tc_kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
- tuple_con = pcDataCon dc_uniq mod_name name_str tyvars [] tyvar_tys tycon
+ 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 = mkPrelModule mod_name
unitTyCon = tupleTyCon 0
pairTyCon = tupleTyCon 2
-unitDataCon = tupleCon 0
-pairDataCon = tupleCon 2
+unitDataConId = dataConId (tupleCon 0)
\end{code}
%************************************************************************
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 name_str tycon
+ tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
tc_kind = mkArrowKinds (map tyVarKind tyvars) unboxedTypeKind
- tuple_con = pcDataCon dc_uniq mod_name name_str tyvars [] tyvar_tys tycon
+ 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
\begin{code}
charTy = mkTyConTy charTyCon
-charTyCon = pcNonRecDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [charDataCon]
+charTyCon = pcNonRecDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [] [charDataCon]
charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon
stringTy = mkListTy charTy -- convenience only
\begin{code}
intTy = mkTyConTy intTyCon
-intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [intDataCon]
+intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [] [intDataCon]
intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon
isIntTy :: Type -> Bool
= case (splitAlgTyConApp_maybe ty) of
Just (tycon, [], _) -> getUnique tycon == intTyConKey
_ -> False
-
-inIntRange :: Integer -> Bool -- Tells if an integer lies in the legal range of Ints
-inIntRange i = (min_int <= i) && (i <= max_int)
-
-max_int, min_int :: Integer
-max_int = toInteger maxInt
-min_int = toInteger minInt
-
-int8TyCon = pcNonRecDataTyCon int8TyConKey iNT SLIT("Int8") [] [int8DataCon]
- where
- int8DataCon = pcDataCon int8DataConKey iNT SLIT("I8#") [] [] [intPrimTy] int8TyCon
-
-int16TyCon = pcNonRecDataTyCon int16TyConKey iNT SLIT("Int16") [] [int16DataCon]
- where
- int16DataCon = pcDataCon int16DataConKey iNT SLIT("I16#") [] [] [intPrimTy] int16TyCon
-
-int32TyCon = pcNonRecDataTyCon int32TyConKey iNT SLIT("Int32") [] [int32DataCon]
- where
- int32DataCon = pcDataCon int32DataConKey iNT SLIT("I32#") [] [] [intPrimTy] int32TyCon
-
-int64TyCon = pcNonRecDataTyCon int64TyConKey pREL_ADDR SLIT("Int64") [] [int64DataCon]
- where
- int64DataCon = pcDataCon int64DataConKey pREL_ADDR SLIT("I64#") [] [] [int64PrimTy] int64TyCon
\end{code}
\begin{code}
wordTy = mkTyConTy wordTyCon
-wordTyCon = pcNonRecDataTyCon wordTyConKey pREL_ADDR SLIT("Word") [] [wordDataCon]
+wordTyCon = pcNonRecDataTyCon wordTyConKey pREL_ADDR SLIT("Word") [] [] [wordDataCon]
wordDataCon = pcDataCon wordDataConKey pREL_ADDR SLIT("W#") [] [] [wordPrimTy] wordTyCon
-
-word8TyCon = pcNonRecDataTyCon word8TyConKey wORD SLIT("Word8") [] [word8DataCon]
- where
- word8DataCon = pcDataCon word8DataConKey wORD SLIT("W8#") [] [] [wordPrimTy] word8TyCon
-
-word16TyCon = pcNonRecDataTyCon word16TyConKey wORD SLIT("Word16") [] [word16DataCon]
- where
- word16DataCon = pcDataCon word16DataConKey wORD SLIT("W16#") [] [] [wordPrimTy] word16TyCon
-
-word32TyCon = pcNonRecDataTyCon word32TyConKey wORD SLIT("Word32") [] [word32DataCon]
- where
- word32DataCon = pcDataCon word32DataConKey wORD SLIT("W32#") [] [] [wordPrimTy] word32TyCon
-
-word64TyCon = pcNonRecDataTyCon word64TyConKey pREL_ADDR SLIT("Word64") [] [word64DataCon]
- where
- word64DataCon = pcDataCon word64DataConKey pREL_ADDR SLIT("W64#") [] [] [word64PrimTy] word64TyCon
\end{code}
\begin{code}
addrTy = mkTyConTy addrTyCon
-addrTyCon = pcNonRecDataTyCon addrTyConKey pREL_ADDR SLIT("Addr") [] [addrDataCon]
+addrTyCon = pcNonRecDataTyCon addrTyConKey pREL_ADDR SLIT("Addr") [] [] [addrDataCon]
addrDataCon = pcDataCon addrDataConKey pREL_ADDR SLIT("A#") [] [] [addrPrimTy] addrTyCon
isAddrTy :: Type -> Bool
\begin{code}
floatTy = mkTyConTy floatTyCon
-floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [floatDataCon]
-floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon
+floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_FLOAT SLIT("Float") [] [] [floatDataCon]
+floatDataCon = pcDataCon floatDataConKey pREL_FLOAT SLIT("F#") [] [] [floatPrimTy] floatTyCon
isFloatTy :: Type -> Bool
isFloatTy ty
Just (tycon, [], _) -> getUnique tycon == doubleTyConKey
_ -> False
-doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [doubleDataCon]
-doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon
+doubleTyCon = pcNonRecDataTyCon doubleTyConKey pREL_FLOAT SLIT("Double") [] [] [doubleDataCon]
+doubleDataCon = pcDataCon doubleDataConKey pREL_FLOAT SLIT("D#") [] [] [doublePrimTy] doubleTyCon
\end{code}
\begin{code}
stablePtrTyCon
= pcNonRecDataTyCon stablePtrTyConKey pREL_STABLE SLIT("StablePtr")
- alpha_tyvar [stablePtrDataCon]
+ alpha_tyvar [(True,False)] [stablePtrDataCon]
where
stablePtrDataCon
= pcDataCon stablePtrDataConKey pREL_STABLE SLIT("StablePtr")
\begin{code}
foreignObjTyCon
= pcNonRecDataTyCon foreignObjTyConKey pREL_IO_BASE SLIT("ForeignObj")
- [] [foreignObjDataCon]
+ [] [] [foreignObjDataCon]
where
foreignObjDataCon
= pcDataCon foreignObjDataConKey pREL_IO_BASE SLIT("ForeignObj")
integerTy :: Type
integerTy = mkTyConTy integerTyCon
-integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [integerDataCon]
+integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_NUM SLIT("Integer")
+ [] [] [smallIntegerDataCon, largeIntegerDataCon]
+
+smallIntegerDataCon = pcDataCon smallIntegerDataConKey pREL_NUM SLIT("S#")
+ [] [] [intPrimTy] integerTyCon
+largeIntegerDataCon = pcDataCon largeIntegerDataConKey pREL_NUM SLIT("J#")
+ [] [] [intPrimTy, byteArrayPrimTy] integerTyCon
-integerDataCon = pcDataCon integerDataConKey pREL_BASE SLIT("J#")
- [] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon
isIntegerTy :: Type -> Bool
isIntegerTy ty
being the )
\begin{code}
-isFFIArgumentTy :: Type -> Bool
-isFFIArgumentTy ty =
- (opt_GlasgowExts && isUnLiftedType ty) || --leave out for now: maybeToBool (maybeBoxedPrimType ty))) ||
+isFFIArgumentTy :: Bool -> Type -> Bool
+isFFIArgumentTy forASafeCall ty =
+ (opt_GlasgowExts && isUnLiftedType ty) ||
case (splitAlgTyConApp_maybe ty) of
- Just (tycon, _, _) -> (getUnique tycon) `elem` primArgTyConKeys
+ Just (tycon, _, _) ->
+ let
+ u = getUnique tycon
+ in
+ u `elem` primArgTyConKeys && -- it has a suitable prim type, and
+ (not forASafeCall || not ( u `elem` notSafeExternalTyCons)) -- it is safe to pass out.
_ -> False
-- types that can be passed as arguments to "foreign" functions
-- (or be passed them as arguments in foreign exported functions).
notLegalExternalTyCons =
[ foreignObjTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ]
+
+-- it's really unsafe to pass out references to objects in the heap,
+-- so for safe call-outs we simply disallow it.
+notSafeExternalTyCons =
+ [ byteArrayTyConKey, mutableByteArrayTyConKey ]
+
+
+isForeignObjTy :: Type -> Bool
+isForeignObjTy ty =
+ case (splitAlgTyConApp_maybe ty) of
+ Just (tycon, _, _) -> (getUnique tycon) == foreignObjTyConKey
+ _ -> False
\end{code}
boolTy = mkTyConTy boolTyCon
boolTyCon = pcTyCon EnumType NonRecursive boolTyConKey
- pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon]
+ pREL_BASE SLIT("Bool") [] [] [falseDataCon, trueDataCon]
falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon
trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon
+
+falseDataConId = dataConId falseDataCon
+trueDataConId = dataConId trueDataCon
\end{code}
%************************************************************************
alphaListTy = mkSigmaTy alpha_tyvar [] (mkTyConApp listTyCon alpha_ty)
listTyCon = pcRecDataTyCon listTyConKey pREL_BASE SLIT("[]")
- alpha_tyvar [nilDataCon, consDataCon]
+ alpha_tyvar [(True,False)] [nilDataCon, consDataCon]
nilDataCon = pcDataCon nilDataConKey pREL_BASE SLIT("[]") alpha_tyvar [] [] listTyCon
consDataCon = pcDataCon consDataConKey pREL_BASE SLIT(":")
projects / ghc-hetmet.git / blobdiff