From: simonpj Date: Mon, 16 Jun 2003 15:32:18 +0000 (+0000) Subject: [project @ 2003-06-16 15:32:16 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~766 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=f5fbd41ca7f30e0f8db3f7b280a044d5af138428;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 0186671..f2fdc28 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -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 diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 2d4eb35..4f34d4c 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -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))) diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 6ad4980..2475dc8 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -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 diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 9e3dbfb..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, @@ -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 @@ -318,27 +305,6 @@ 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 floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] @@ -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} %************************************************************************ %* * diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 37d8212..5e4a31a 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -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) ] diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index cd4fe14..9635d41 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -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} ----------------------------------------------