[project @ 2001-08-28 10:06:29 by simonpj]

----------------------------------------
	Make isFFIArgumentTy understand newtypes
	----------------------------------------

This fixes the bug Manuel reported:

	newtype T = T (Ptr T)
	foreign import ccall foo :: T -> IO (Ptr T)

  test.hs:6:
      Unacceptable argument type in foreign declaration: T


On the way, I moved isFFIArgumentTy and friends out of TysWiredIn,
where they didn't really belong, into TcType.  That in turn force
me to move isStrictType, and isPrimitiveType.

ghc/compiler/DEPEND-NOTES

@@ -24,9 +24,13 @@ then
 then
 	Unify, PprType (PprEnv)
 then
-	Literal (TysPrim, PprType), DataCon (PprType)
+	Literal (TysPrim, PprType), DataCon (loop PprType)
 then
 	TysWiredIn (DataCon.mkDataCon, loop MkId.mkDataConId, loop Generics.mkGenInfo)
+then
+	TcType( lots of TywWiredIn stuff)
+then
+	PprType( lots of TcType stuff )
 then
 	PrimOp (PprType, TysWiredIn)
 then

ghc/compiler/basicTypes/DataCon.lhs

@@ -23,13 +23,14 @@ module DataCon (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} Subst( substTyWith )
+import {-# SOURCE #-} PprType( pprType )
 
 import CmdLineOpts	( opt_DictsStrict )
 import Type		( Type, TauType, ThetaType, 
 			  mkForAllTys, mkFunTys, mkTyConApp,
-			  mkTyVarTys, splitTyConApp_maybe, repType
+			  mkTyVarTys, splitTyConApp_maybe, repType, 
+			  mkPredTys, isStrictType
 			)
-import TcType		( isStrictPred, mkPredTys )
 import TyCon		( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon,
 			  isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
 import Class		( Class, classTyCon )
@@ -41,7 +42,6 @@ import NewDemand 	( Demand, lazyDmd, seqDmd )
 import Outputable
 import Unique		( Unique, Uniquable(..) )
 import CmdLineOpts	( opt_UnboxStrictFields )
-import PprType		()	-- Instances
 import Maybe
 import ListSetOps	( assoc )
 import Util		( zipEqual, zipWithEqual )
@@ -236,7 +236,8 @@ mkDataCon name arg_stricts fields
 	-- Strictness marks for source-args
 	--	*after unboxing choices*, 
 	-- but  *including existential dictionaries*
-    real_stricts = (map mk_dict_strict_mark ex_theta) ++
+    ex_dict_tys  = mkPredTys ex_theta
+    real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
 		   zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon) 
 				orig_arg_tys arg_stricts 
 
@@ -245,7 +246,7 @@ mkDataCon name arg_stricts fields
 	= unzip $ concat $ 
 	  zipWithEqual "mkDataCon2" unbox_strict_arg_ty 
 		       real_stricts 
-		       (mkPredTys ex_theta ++ orig_arg_tys)
+		       (ex_dict_tys ++ orig_arg_tys)
 
     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
     ty  = mkForAllTys (tyvars ++ ex_tyvars)
@@ -254,8 +255,8 @@ mkDataCon name arg_stricts fields
 
     result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
 
-mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
-			 | otherwise	     = NotMarkedStrict
+mk_dict_strict_mark ty | isStrictType ty = MarkedStrict
+		       | otherwise	 = NotMarkedStrict
 \end{code}
 
 \begin{code}
@@ -409,7 +410,7 @@ splitProductType_maybe ty
 splitProductType str ty
   = case splitProductType_maybe ty of
 	Just stuff -> stuff
-	Nothing    -> pprPanic (str ++ ": not a product") (ppr ty)
+	Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
 
 -- We attempt to unbox/unpack a strict field when either:
 --   (i)  The tycon is imported, and the field is marked '! !', or

ghc/compiler/deSugar/DsCCall.lhs

@@ -183,7 +183,7 @@ unboxArg arg
   = getSrcLocDs `thenDs` \ l ->
     pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
-    arg_ty  					= repType (exprType arg)
+    arg_ty = repType (exprType arg)
 	-- The repType looks through any newtype or 
 	-- implicit-parameter wrappings on the argument;
 	-- this is necessary, because isBoolTy (in particular) does not.

ghc/compiler/prelude/TysWiredIn.lhs

@@ -69,15 +69,7 @@ module TysWiredIn (
 	voidTy,
 	wordDataCon,
 	wordTy,
-	wordTyCon,
-
-	isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
-	isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
-	isFFIExportResultTy, -- :: Type -> Bool
-	isFFIExternalTy,     -- :: Type -> Bool
-        isFFIDynArgumentTy,  -- :: Type -> Bool
- 	isFFIDynResultTy,    -- :: Type -> Bool
- 	isFFILabelTy,        -- :: Type -> Bool
+	wordTyCon
     ) where
 
 #include "HsVersions.h"
@@ -90,7 +82,6 @@ import PrelNames
 import TysPrim
 
 -- others:
-import ForeignCall	( Safety, playSafe )
 import Constants	( mAX_TUPLE_SIZE )
 import Module		( mkPrelModule )
 import Name		( Name, nameRdrName, nameUnique, nameOccName, 
@@ -406,117 +397,6 @@ largeIntegerDataCon = pcDataCon largeIntegerDataConName
 \end{code}
 
 
-%************************************************************************
-%*									*
-\subsection[TysWiredIn-ext-type]{External types}
-%*									*
-%************************************************************************
-
-The compiler's foreign function interface supports the passing of a
-restricted set of types as arguments and results (the restricting factor
-being the )
-
-\begin{code}
-isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
--- Checks for valid argument type for a 'foreign import'
-isFFIArgumentTy dflags safety ty 
-   = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
-
-isFFIExternalTy :: Type -> Bool
--- Types that are allowed as arguments of a 'foreign export'
-isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
-
-isFFIImportResultTy :: DynFlags -> Type -> Bool
-isFFIImportResultTy dflags ty 
-  = checkRepTyCon (legalFIResultTyCon dflags) ty
-
-isFFIExportResultTy :: Type -> Bool
-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)
-
-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)
-
-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)
-
-checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-	-- Look through newtypes
-checkRepTyCon check_tc ty = case splitTyConApp_maybe ty of
-				Just (tycon, _) -> check_tc tycon
-				Nothing		-> False
-\end{code}
-
-----------------------------------------------
-These chaps do the work; they are not exported
-----------------------------------------------
-
-\begin{code}
-legalFEArgTyCon :: TyCon -> Bool
--- It's illegal to return foreign objects and (mutable)
--- bytearrays from a _ccall_ / foreign declaration
--- (or be passed them as arguments in foreign exported functions).
-legalFEArgTyCon tc
-  | getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
-			  byteArrayTyConKey, mutableByteArrayTyConKey ] 
-  = False
-  -- It's also illegal to make foreign exports that take unboxed
-  -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
-  | otherwise
-  = boxedMarshalableTyCon tc
-
-legalFIResultTyCon :: DynFlags -> TyCon -> Bool
-legalFIResultTyCon dflags tc
-  | getUnique tc `elem`
-	[ foreignObjTyConKey, foreignPtrTyConKey,
-	  byteArrayTyConKey, mutableByteArrayTyConKey ]  = False
-  | tc == unitTyCon = True
-  | otherwise	    = marshalableTyCon dflags tc
-
-legalFEResultTyCon :: TyCon -> Bool
-legalFEResultTyCon tc
-  | getUnique tc `elem` 
-	[ foreignObjTyConKey, foreignPtrTyConKey,
-	  byteArrayTyConKey, mutableByteArrayTyConKey ]  = False
-  | tc == unitTyCon = True
-  | otherwise       = boxedMarshalableTyCon tc
-
-legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
--- Checks validity of types going from Haskell -> external world
-legalOutgoingTyCon dflags safety tc
-  | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
-  = False
-  | otherwise
-  = marshalableTyCon dflags tc
-
-marshalableTyCon dflags tc
-  =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
-  || boxedMarshalableTyCon tc
-
-boxedMarshalableTyCon tc
-   = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
-			 , int32TyConKey, int64TyConKey
-			 , wordTyConKey, word8TyConKey, word16TyConKey
-			 , word32TyConKey, word64TyConKey
-			 , floatTyConKey, doubleTyConKey
-			 , addrTyConKey, ptrTyConKey, funPtrTyConKey
-			 , charTyConKey, foreignObjTyConKey
-			 , foreignPtrTyConKey
-			 , stablePtrTyConKey
-			 , byteArrayTyConKey, mutableByteArrayTyConKey
-			 , boolTyConKey
-			 ]
-\end{code}
-
-
 %************************************************************************
 %*									*
 \subsection[TysWiredIn-Bool]{The @Bool@ type}

ghc/compiler/simplCore/SimplUtils.lhs

@@ -40,10 +40,9 @@ import NewDemand	( isStrictDmd, isBotRes, splitStrictSig )
 import SimplMonad
 import Type		( Type, mkForAllTys, seqType, 
 			  splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
-			  isUnLiftedType,
+			  isUnLiftedType, isStrictType,
 			  splitRepFunTys
 			)
-import TcType		( isStrictType )
 import TyCon		( tyConDataConsIfAvailable )
 import DataCon		( dataConRepArity )
 import VarEnv		( SubstEnv )

ghc/compiler/typecheck/TcForeign.lhs

@@ -34,14 +34,13 @@ import Inst		( emptyLIE, LIE, plusLIE )
 import ErrUtils		( Message )
 import Id		( Id, mkLocalId )
 import Name		( nameOccName )
-import TysWiredIn	( isFFIArgumentTy, isFFIImportResultTy, 
-			  isFFIExportResultTy,
-			  isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
-			  isFFILabelTy
-			)
 import PrimRep		( getPrimRepSize )
 import Type		( typePrimRep )
-import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys )
+import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys,
+			  isFFIArgumentTy, isFFIImportResultTy, 
+			  isFFIExportResultTy, isFFILabelTy,
+			  isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy
+			)
 import ForeignCall	( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget )
 import CStrings		( CLabelString, isCLabelString )
 import PrelNames	( hasKey, ioTyConKey )
@@ -317,3 +316,4 @@ foreignDeclCtxt fo
   = hang (ptext SLIT("When checking declaration:"))
          4 (ppr fo)
 \end{code}
+

ghc/compiler/typecheck/TcMType.lhs

@@ -61,7 +61,9 @@ import TcType		( tcEqType, tcCmpPred,
 			  liftedTypeKind, unliftedTypeKind, openTypeKind, defaultKind, superKind,
 			  superBoxity, liftedBoxity, hasMoreBoxityInfo, typeKind,
 			  tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyTyVar,
-			  eqKind, isTypeKind
+			  eqKind, isTypeKind,
+
+			  isFFIArgumentTy, isFFIImportResultTy
 			)
 import Subst		( Subst, mkTopTyVarSubst, substTy )
 import Class		( classArity, className )
@@ -73,8 +75,7 @@ import Var		( TyVar, varName, tyVarKind, tyVarName, isTyVar, mkTyVar,
 
 -- others:
 import TcMonad          -- TcType, amongst others
-import TysWiredIn	( voidTy, listTyCon, mkListTy, mkTupleTy,
-			  isFFIArgumentTy, isFFIImportResultTy )
+import TysWiredIn	( voidTy, listTyCon, mkListTy, mkTupleTy )
 import PrelNames	( cCallableClassKey, cReturnableClassKey, hasKey )
 import ForeignCall	( Safety(..) )
 import FunDeps		( grow )

ghc/compiler/typecheck/TcType.lhs

@@ -36,9 +36,9 @@ module TcType (
   -- Predicates. 
   -- Again, newtypes are opaque
   tcEqType, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
-  isQualifiedTy, isOverloadedTy, isStrictType, isStrictPred,
+  isQualifiedTy, isOverloadedTy, 
   isDoubleTy, isFloatTy, isIntTy,
-  isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy, isPrimitiveType,
+  isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy, 
   isTauTy, tcIsTyVarTy, tcIsForAllTy,
 
   ---------------------------------
@@ -49,12 +49,22 @@ module TcType (
 
   ---------------------------------
   -- Predicate types  
-  PredType, mkPredTy, mkPredTys, getClassPredTys_maybe, getClassPredTys, 
+  PredType, getClassPredTys_maybe, getClassPredTys, 
   isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
   mkDictTy, tcSplitPredTy_maybe, predTyUnique,
   isDictTy, tcSplitDFunTy, predTyUnique, 
   mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName,
 
+  ---------------------------------
+  -- Foreign import and export
+  isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
+  isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
+  isFFIExportResultTy, -- :: Type -> Bool
+  isFFIExternalTy,     -- :: Type -> Bool
+  isFFIDynArgumentTy,  -- :: Type -> Bool
+  isFFIDynResultTy,    -- :: Type -> Bool
+  isFFILabelTy,        -- :: Type -> Bool
+
   ---------------------------------
   -- Unifier and matcher  
   unifyTysX, unifyTyListsX, unifyExtendTysX,
@@ -72,10 +82,11 @@ module TcType (
   mkForAllTy, mkForAllTys, 
   mkFunTy, mkFunTys, zipFunTys, 
   mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
-  mkTyVarTy, mkTyVarTys, mkTyConTy, 
+  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, 
 
   isUnLiftedType,	-- Source types are always lifted
   isUnboxedTupleType,	-- Ditto
+  isPrimitiveType,
 
   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
   tidyTyVar, tidyTyVars,
@@ -100,25 +111,27 @@ import Type		(	-- Re-exports
 			  mkForAllTy, mkForAllTys, defaultKind, isTypeKind,
 			  mkFunTy, mkFunTys, zipFunTys, 
 			  mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
-			  mkTyVarTy, mkTyVarTys, mkTyConTy,
-			  isUnLiftedType, isUnboxedTupleType,
+			  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
+			  isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
+			  splitNewType_maybe, splitTyConApp_maybe,
 			  tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
 			  tidyTyVar, tidyTyVars, eqKind, eqUsage,
 			  hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind
 			)
-import TyCon		( TyCon, isPrimTyCon, tyConArity, isNewTyCon )
+import TyCon		( TyCon, isPrimTyCon, tyConArity, isNewTyCon, isUnLiftedTyCon )
 import Class		( classTyCon, classHasFDs, Class )
 import Var		( TyVar, tyVarKind )
+import ForeignCall	( Safety, playSafe )
 import VarEnv
 import VarSet
 
 -- others:
-import CmdLineOpts	( opt_DictsStrict )
+import CmdLineOpts	( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
 import Name		( Name, NamedThing(..), mkLocalName )
 import OccName		( OccName, mkDictOcc )
 import NameSet
-import PrelNames	( floatTyConKey, doubleTyConKey, foreignPtrTyConKey,
-			  integerTyConKey, intTyConKey, addrTyConKey, boolTyConKey )
+import PrelNames	-- Lots (e.g. in isFFIArgumentTy
+import TysWiredIn	( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon )
 import Unique		( Unique, Uniquable(..), mkTupleTyConUnique )
 import SrcLoc		( SrcLoc )
 import Util		( cmpList, thenCmp )
@@ -346,12 +359,6 @@ tcSplitPredTy_maybe (UsageTy _ ty)	    = tcSplitPredTy_maybe ty
 tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p
 tcSplitPredTy_maybe other	      	    = Nothing
 	
-mkPredTy :: PredType -> Type
-mkPredTy pred = SourceTy pred
-
-mkPredTys :: ThetaType -> [Type]
-mkPredTys preds = map SourceTy preds
-
 predTyUnique :: PredType -> Unique
 predTyUnique (IParam n _)      = getUnique n
 predTyUnique (ClassP clas tys) = getUnique clas
@@ -561,36 +568,6 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 			Nothing	     -> False
 \end{code}
 
-\begin{code}
-isPrimitiveType :: Type -> Bool
--- Returns types that are opaque to Haskell.
--- Most of these are unlifted, but now that we interact with .NET, we
--- may have primtive (foreign-imported) types that are lifted
-isPrimitiveType ty = case tcSplitTyConApp_maybe ty of
-			Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
-					      isPrimTyCon tc
-			other		   -> False
-\end{code}
-
-@isStrictType@ computes whether an argument (or let RHS) should
-be computed strictly or lazily, based only on its type
-
-\begin{code}
-isStrictType :: Type -> Bool
-isStrictType ty
-  | isUnLiftedType ty			= True
-  | Just pred <- tcSplitPredTy_maybe ty = isStrictPred pred
-  | otherwise				= False
-
-isStrictPred (ClassP clas _) =  opt_DictsStrict
-			     && not (isNewTyCon (classTyCon clas))
-isStrictPred pred	     =  False
-	-- We may be strict in dictionary types, but only if it 
-	-- has more than one component.
-	-- [Being strict in a single-component dictionary risks
-	--  poking the dictionary component, which is wrong.]
-\end{code}
-
 
 %************************************************************************
 %*									*
@@ -666,6 +643,120 @@ namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of
 \end{code}
 
 
+%************************************************************************
+%*									*
+\subsection[TysWiredIn-ext-type]{External types}
+%*									*
+%************************************************************************
+
+The compiler's foreign function interface supports the passing of a
+restricted set of types as arguments and results (the restricting factor
+being the )
+
+\begin{code}
+isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
+-- Checks for valid argument type for a 'foreign import'
+isFFIArgumentTy dflags safety ty 
+   = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
+
+isFFIExternalTy :: Type -> Bool
+-- Types that are allowed as arguments of a 'foreign export'
+isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
+
+isFFIImportResultTy :: DynFlags -> Type -> Bool
+isFFIImportResultTy dflags ty 
+  = checkRepTyCon (legalFIResultTyCon dflags) ty
+
+isFFIExportResultTy :: Type -> Bool
+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)
+
+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)
+
+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)
+
+checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
+	-- Look through newtypes
+	-- Non-recursive ones are transparent to splitTyConApp,
+	-- but recursive ones aren't; hence the splitNewType_maybe
+checkRepTyCon check_tc ty 
+  | Just ty'    <- splitNewType_maybe ty  = checkRepTyCon check_tc ty'
+  | Just (tc,_) <- splitTyConApp_maybe ty = check_tc tc
+  | otherwise				  = False
+\end{code}
+
+----------------------------------------------
+These chaps do the work; they are not exported
+----------------------------------------------
+
+\begin{code}
+legalFEArgTyCon :: TyCon -> Bool
+-- It's illegal to return foreign objects and (mutable)
+-- bytearrays from a _ccall_ / foreign declaration
+-- (or be passed them as arguments in foreign exported functions).
+legalFEArgTyCon tc
+  | getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
+			  byteArrayTyConKey, mutableByteArrayTyConKey ] 
+  = False
+  -- It's also illegal to make foreign exports that take unboxed
+  -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
+  | otherwise
+  = boxedMarshalableTyCon tc
+
+legalFIResultTyCon :: DynFlags -> TyCon -> Bool
+legalFIResultTyCon dflags tc
+  | getUnique tc `elem`
+	[ foreignObjTyConKey, foreignPtrTyConKey,
+	  byteArrayTyConKey, mutableByteArrayTyConKey ]  = False
+  | tc == unitTyCon = True
+  | otherwise	    = marshalableTyCon dflags tc
+
+legalFEResultTyCon :: TyCon -> Bool
+legalFEResultTyCon tc
+  | getUnique tc `elem` 
+	[ foreignObjTyConKey, foreignPtrTyConKey,
+	  byteArrayTyConKey, mutableByteArrayTyConKey ]  = False
+  | tc == unitTyCon = True
+  | otherwise       = boxedMarshalableTyCon tc
+
+legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
+-- Checks validity of types going from Haskell -> external world
+legalOutgoingTyCon dflags safety tc
+  | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
+  = False
+  | otherwise
+  = marshalableTyCon dflags tc
+
+marshalableTyCon dflags tc
+  =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
+  || boxedMarshalableTyCon tc
+
+boxedMarshalableTyCon tc
+   = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
+			 , int32TyConKey, int64TyConKey
+			 , wordTyConKey, word8TyConKey, word16TyConKey
+			 , word32TyConKey, word64TyConKey
+			 , floatTyConKey, doubleTyConKey
+			 , addrTyConKey, ptrTyConKey, funPtrTyConKey
+			 , charTyConKey, foreignObjTyConKey
+			 , foreignPtrTyConKey
+			 , stablePtrTyConKey
+			 , byteArrayTyConKey, mutableByteArrayTyConKey
+			 , boolTyConKey
+			 ]
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection{Unification with an explicit substitution}

ghc/compiler/types/Type.lhs

@@ -49,13 +49,13 @@ module Type (
 	applyTy, applyTys, isForAllTy,
 
 	-- Source types
-	SourceType(..), sourceTypeRep,
+	SourceType(..), sourceTypeRep, mkPredTy, mkPredTys,
 
 	-- Newtypes
 	splitNewType_maybe,
 
 	-- Lifting and boxity
-	isUnLiftedType, isUnboxedTupleType, isAlgType,
+	isUnLiftedType, isUnboxedTupleType, isAlgType, isStrictType, isPrimitiveType,
 
 	-- Free variables
 	tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
@@ -94,7 +94,7 @@ import VarSet
 
 import Name	( NamedThing(..), mkLocalName, tidyOccName )
 import Class	( classTyCon )
-import TyCon	( TyCon, isRecursiveTyCon,
+import TyCon	( TyCon, isRecursiveTyCon, isPrimTyCon,
 		  isUnboxedTupleTyCon, isUnLiftedTyCon,
 		  isFunTyCon, isNewTyCon, newTyConRep,
 		  isAlgTyCon, isSynTyCon, tyConArity, 
@@ -103,6 +103,7 @@ import TyCon	( TyCon, isRecursiveTyCon,
 		)
 
 -- others
+import CmdLineOpts	( opt_DictsStrict )
 import Maybes		( maybeToBool )
 import SrcLoc		( noSrcLoc )
 import PrimRep		( PrimRep(..) )
@@ -606,6 +607,12 @@ Source types are always lifted.
 The key function is sourceTypeRep which gives the representation of a source type:
 
 \begin{code}
+mkPredTy :: PredType -> Type
+mkPredTy pred = SourceTy pred
+
+mkPredTys :: ThetaType -> [Type]
+mkPredTys preds = map SourceTy preds
+
 sourceTypeRep :: SourceType -> Type
 -- Convert a predicate to its "representation type";
 -- the type of evidence for that predicate, which is actually passed at runtime
@@ -682,7 +689,6 @@ typeKind (UsageTy _ ty)         = typeKind ty  -- we don't have separate kinds f
 		Free variables of a type
 		~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-
 tyVarsOfType :: Type -> TyVarSet
 tyVarsOfType (TyVarTy tv)		= unitVarSet tv
 tyVarsOfType (TyConApp tycon tys)	= tyVarsOfTypes tys
@@ -867,6 +873,37 @@ isAlgType ty = case splitTyConApp_maybe ty of
 			other		   -> False
 \end{code}
 
+@isStrictType@ computes whether an argument (or let RHS) should
+be computed strictly or lazily, based only on its type.
+Works just like isUnLiftedType, except that it has a special case 
+for dictionaries.  Since it takes account of ClassP, you might think
+this function should be in TcType, but isStrictType is used by DataCon,
+which is below TcType in the hierarchy, so it's convenient to put it here.
+
+\begin{code}
+isStrictType (ForAllTy tv ty)		= isStrictType ty
+isStrictType (NoteTy _ ty)   		= isStrictType ty
+isStrictType (TyConApp tc _)		= isUnLiftedTyCon tc
+isStrictType (UsageTy _ ty)		= isStrictType ty
+isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
+	-- We may be strict in dictionary types, but only if it 
+	-- has more than one component.
+	-- [Being strict in a single-component dictionary risks
+	--  poking the dictionary component, which is wrong.]
+isStrictType other			= False	
+\end{code}
+
+\begin{code}
+isPrimitiveType :: Type -> Bool
+-- Returns types that are opaque to Haskell.
+-- Most of these are unlifted, but now that we interact with .NET, we
+-- may have primtive (foreign-imported) types that are lifted
+isPrimitiveType ty = case splitTyConApp_maybe ty of
+			Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
+					      isPrimTyCon tc
+			other		   -> False
+\end{code}
+
 
 %************************************************************************
 %*									*