[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.

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

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)))

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

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
@@ -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}
 
 %************************************************************************
 %*									*

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)
     ]

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}
 
 ----------------------------------------------