Commit f5fbd41c authored by simonpj's avatar simonpj
Browse files

[project @ 2003-06-16 15:32:16 by simonpj]

--------------------------
	Remove some wired-in types
	--------------------------

ptrTyCon, funPtrTyCon, addrTyCon, stablePtrTyCon have no business
being wired in. This commit makes them into knownKey Names, which
is much better.
parent 76c6edcb
......@@ -172,7 +172,7 @@ unboxArg arg
[(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 ->
......@@ -398,6 +398,7 @@ resultWrapper result_ty
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
......
......@@ -39,10 +39,10 @@ import ForeignCall ( ForeignCall(..), CCallSpec(..),
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
......@@ -353,23 +353,24 @@ dsFExportDynamic id cconv
-- 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
......@@ -383,12 +384,12 @@ dsFExportDynamic id cconv
]
-- 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
......@@ -411,7 +412,6 @@ dsFExportDynamic id cconv
([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)))
......
......@@ -136,8 +136,6 @@ basicKnownKeyNames
byteArrayTyConName,
mutableByteArrayTyConName,
bcoPrimTyConName,
stablePtrTyConName,
stablePtrDataConName,
-- Classes. *Must* include:
-- classes that are grabbed by key (e.g., eqClassKey)
......@@ -203,6 +201,7 @@ basicKnownKeyNames
toPName, bpermutePName, bpermuteDftPName, indexOfPName,
-- FFI primitive types that are not wired-in.
stablePtrTyConName, ptrTyConName, funPtrTyConName, addrTyConName,
int8TyConName, int16TyConName, int32TyConName, int64TyConName,
word8TyConName, word16TyConName, word32TyConName, word64TyConName,
......@@ -382,6 +381,7 @@ unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName
unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
newStablePtr_RDR = nameRdrName newStablePtrName
addrDataCon_RDR = dataQual_RDR aDDR_Name FSLIT("A#")
bindIO_RDR = nameRdrName bindIOName
returnIO_RDR = nameRdrName returnIOName
......@@ -664,14 +664,11 @@ wordTyConName = wTcQual pREL_WORD_Name FSLIT("Word") wordTyConKey
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
......@@ -679,7 +676,6 @@ mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("MutableByteArray")
-- 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
......@@ -869,7 +865,6 @@ unitTyConKey = mkTupleTyConUnique Boxed 0
%************************************************************************
\begin{code}
addrDataConKey = mkPreludeDataConUnique 0
charDataConKey = mkPreludeDataConUnique 1
consDataConKey = mkPreludeDataConUnique 2
doubleDataConKey = mkPreludeDataConUnique 3
......@@ -880,13 +875,10 @@ smallIntegerDataConKey = mkPreludeDataConUnique 7
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
......
......@@ -13,15 +13,6 @@ types and operations.''
module TysWiredIn (
wiredInTyCons, genericTyCons,
addrDataCon,
addrTy,
addrTyCon,
ptrDataCon,
ptrTy,
ptrTyCon,
funPtrDataCon,
funPtrTy,
funPtrTyCon,
boolTy,
boolTyCon,
charDataCon,
......@@ -62,7 +53,6 @@ module TysWiredIn (
plusTyCon, inrDataCon, inlDataCon,
crossTyCon, crossDataCon,
stablePtrTyCon,
stringTy,
trueDataCon, trueDataConId,
unitTy,
......@@ -128,10 +118,7 @@ wiredInTyCons :: [TyCon]
wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons
data_tycons = genericTyCons ++
[ addrTyCon
, ptrTyCon
, funPtrTyCon
, boolTyCon
[ boolTyCon
, charTyCon
, doubleTyCon
, floatTyCon
......@@ -317,27 +304,6 @@ wordTyCon = pcNonRecDataTyCon wordTyConName [] [] [wordDataCon]
wordDataCon = pcDataCon wordDataConName [] [] [wordPrimTy] wordTyCon
\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
......@@ -348,19 +314,10 @@ floatDataCon = pcDataCon floatDataConName [] [] [floatPrimTy] floatTyCon
\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}
%************************************************************************
%* *
......
......@@ -59,7 +59,7 @@ import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
)
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 )
......@@ -1341,7 +1341,7 @@ box_con_tbl =
[(charPrimTy, getRdrName charDataCon)
,(intPrimTy, getRdrName intDataCon)
,(wordPrimTy, getRdrName wordDataCon)
,(addrPrimTy, getRdrName addrDataCon)
,(addrPrimTy, addrDataCon_RDR)
,(floatPrimTy, getRdrName floatDataCon)
,(doublePrimTy, getRdrName doubleDataCon)
]
......
......@@ -140,7 +140,7 @@ import Type ( -- Re-exports
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
......@@ -155,8 +155,7 @@ import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc )
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 )
......@@ -831,17 +830,17 @@ 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)
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
......@@ -907,6 +906,11 @@ checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
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}
----------------------------------------------
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment