[(DEFAULT,[],body)])
-- Data types with a single constructor, which has a single, primitive-typed arg
- -- This deals with Int, Float etc
+ -- This deals with Int, Float etc; also Ptr, ForeignPtr
| is_product_type && data_con_arity == 1
= ASSERT(isUnLiftedType data_con_arg_ty1 ) -- Typechecker ensures this
newSysLocalDs arg_ty `thenDs` \ case_bndr ->
returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
-- Data types with a single constructor, which has a single arg
+ -- This includes types like Ptr and ForeignPtr
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
dataConSourceArity data_con == 1
= let
ccallConvAttribute
)
import CStrings ( CLabelString )
-import TysWiredIn ( unitTy, stablePtrTyCon, tupleTyCon )
+import TysWiredIn ( unitTy, tupleTyCon )
import TysPrim ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
import PrimRep ( getPrimRepSizeInBytes )
-import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName,
+import PrelNames ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
checkDotnetResName )
import BasicTypes ( Activation( NeverActive ) )
import Outputable
-- hack: need to get at the name of the C stub we're about to generate.
fe_nm = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
in
- dsFExport id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code, stub_args) ->
newSysLocalDs arg_ty `thenDs` \ cback ->
- dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
+ dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
+ dsLookupTyCon stablePtrTyConName `thenDs` \ stable_ptr_tycon ->
let
- mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+ mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+ stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
+ export_ty = mkFunTy stable_ptr_ty arg_ty
in
- dsLookupGlobalId bindIOName `thenDs` \ bindIOId ->
- newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
+ dsLookupGlobalId bindIOName `thenDs` \ bindIOId ->
+ newSysLocalDs stable_ptr_ty `thenDs` \ stbl_value ->
+ dsFExport id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code, stub_args) ->
let
- stbl_app cont ret_ty
- = mkApps (Var bindIOId)
- [ Type (mkTyConApp stablePtrTyCon [arg_ty])
- , Type ret_ty
- , mk_stbl_ptr_app
- , cont
- ]
-
+ stbl_app cont ret_ty = mkApps (Var bindIOId)
+ [ Type stable_ptr_ty
+ , Type ret_ty
+ , mk_stbl_ptr_app
+ , cont
+ ]
{-
The arguments to the external function which will
create a little bit of (template) code on the fly
]
-- name of external entry point providing these services.
-- (probably in the RTS.)
- adjustor = FSLIT("createAdjustor")
+ adjustor = FSLIT("createAdjustor")
- mb_sz_args =
- case cconv of
- StdCallConv -> Just (sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args))
- _ -> Nothing
+ sz_args = sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args)
+ mb_sz_args = case cconv of
+ StdCallConv -> Just sz_args
+ _ -> Nothing
in
dsCCall adjustor adj_args PlayRisky False io_res_ty `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
[res_ty] = tcTyConAppArgs io_res_ty
-- Must use tcSplit* to see the (IO t), which is a newtype
- export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
byteArrayTyConName,
mutableByteArrayTyConName,
bcoPrimTyConName,
- stablePtrTyConName,
- stablePtrDataConName,
-- Classes. *Must* include:
-- classes that are grabbed by key (e.g., eqClassKey)
toPName, bpermutePName, bpermuteDftPName, indexOfPName,
-- FFI primitive types that are not wired-in.
+ stablePtrTyConName, ptrTyConName, funPtrTyConName, addrTyConName,
int8TyConName, int16TyConName, int32TyConName, int64TyConName,
word8TyConName, word16TyConName, word32TyConName, word64TyConName,
unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
newStablePtr_RDR = nameRdrName newStablePtrName
+addrDataCon_RDR = dataQual_RDR aDDR_Name FSLIT("A#")
bindIO_RDR = nameRdrName bindIOName
returnIO_RDR = nameRdrName returnIOName
wordDataConName = wDataQual pREL_WORD_Name FSLIT("W#") wordDataConKey
-- Addr module
-addrTyConName = wTcQual aDDR_Name FSLIT("Addr") addrTyConKey
-addrDataConName = wDataQual aDDR_Name FSLIT("A#") addrDataConKey
+addrTyConName = tcQual aDDR_Name FSLIT("Addr") addrTyConKey
-- PrelPtr module
-ptrTyConName = wTcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey
-ptrDataConName = wDataQual pREL_PTR_Name FSLIT("Ptr") ptrDataConKey
-funPtrTyConName = wTcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey
-funPtrDataConName = wDataQual pREL_PTR_Name FSLIT("FunPtr") funPtrDataConKey
+ptrTyConName = tcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey
+funPtrTyConName = tcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey
-- Byte array types
byteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("ByteArray") byteArrayTyConKey
-- Foreign objects and weak pointers
stablePtrTyConName = tcQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrTyConKey
-stablePtrDataConName = dataQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrDataConKey
newStablePtrName = varQual pREL_STABLE_Name FSLIT("newStablePtr") newStablePtrIdKey
-- Error module
%************************************************************************
\begin{code}
-addrDataConKey = mkPreludeDataConUnique 0
charDataConKey = mkPreludeDataConUnique 1
consDataConKey = mkPreludeDataConUnique 2
doubleDataConKey = mkPreludeDataConUnique 3
largeIntegerDataConKey = mkPreludeDataConUnique 8
nilDataConKey = mkPreludeDataConUnique 11
ratioDataConKey = mkPreludeDataConUnique 12
-stablePtrDataConKey = mkPreludeDataConUnique 13
stableNameDataConKey = mkPreludeDataConUnique 14
trueDataConKey = mkPreludeDataConUnique 15
wordDataConKey = mkPreludeDataConUnique 16
ioDataConKey = mkPreludeDataConUnique 17
-ptrDataConKey = mkPreludeDataConUnique 18
-funPtrDataConKey = mkPreludeDataConUnique 19
-- Generic data constructors
crossDataConKey = mkPreludeDataConUnique 20
module TysWiredIn (
wiredInTyCons, genericTyCons,
- addrDataCon,
- addrTy,
- addrTyCon,
- ptrDataCon,
- ptrTy,
- ptrTyCon,
- funPtrDataCon,
- funPtrTy,
- funPtrTyCon,
boolTy,
boolTyCon,
charDataCon,
plusTyCon, inrDataCon, inlDataCon,
crossTyCon, crossDataCon,
- stablePtrTyCon,
stringTy,
trueDataCon, trueDataConId,
unitTy,
wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons
data_tycons = genericTyCons ++
- [ addrTyCon
- , ptrTyCon
- , funPtrTyCon
- , boolTyCon
+ [ boolTyCon
, charTyCon
, doubleTyCon
, floatTyCon
\end{code}
\begin{code}
-addrTy = mkTyConTy addrTyCon
-
-addrTyCon = pcNonRecDataTyCon addrTyConName [] [] [addrDataCon]
-addrDataCon = pcDataCon addrDataConName [] [] [addrPrimTy] addrTyCon
-\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]
\begin{code}
doubleTy = mkTyConTy doubleTyCon
-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}
%************************************************************************
%* *
)
import TcType ( isUnLiftedType, tcEqType, Type )
import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy )
-import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, addrDataCon, wordDataCon )
+import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, wordDataCon )
import Util ( zipWithEqual, isSingleton,
zipWith3Equal, nOfThem, zipEqual )
import Panic ( panic, assertPanic )
[(charPrimTy, getRdrName charDataCon)
,(intPrimTy, getRdrName intDataCon)
,(wordPrimTy, getRdrName wordDataCon)
- ,(addrPrimTy, getRdrName addrDataCon)
+ ,(addrPrimTy, addrDataCon_RDR)
,(floatPrimTy, getRdrName floatDataCon)
,(doublePrimTy, getRdrName doubleDataCon)
]
superBoxity, typeKind, superKind, repType
)
import DataCon ( DataCon )
-import TyCon ( TyCon, isUnLiftedTyCon )
+import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
import Class ( classHasFDs, Class )
import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails )
import ForeignCall ( Safety, playSafe
import OccName ( OccName, mkDictOcc )
import NameSet
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
-import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon,
- charTyCon, listTyCon )
+import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
import BasicTypes ( IPName(..), ipNameName )
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
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)
+isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
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)
+isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
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)
+isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
isFFIDotnetTy :: DynFlags -> Type -> Bool
isFFIDotnetTy dflags ty
checkRepTyCon check_tc ty
| Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
| otherwise = False
+
+checkRepTyConKey :: [Unique] -> Type -> Bool
+-- Like checkRepTyCon, but just looks at the TyCon key
+checkRepTyConKey keys
+ = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
\end{code}
----------------------------------------------
projects / ghc-hetmet.git / commitdiff