[project @ 2000-07-24 14:29:55 by simonmar]

Some changes to the way FFI decls are handled:

  - a foreign export dynamic which returns a newtype of
    an Addr now works correctly.  Similarly for foreign label.

  - unlifted types are not allowed in the arguments of a foreign
    export.  Previously we generated incorrect code for these cases.

Newtypes in FFI declarations now work everywhere they should, as far
as I can see.

These changes will be backported into 4.08.1.

3 files changed, 39 insertions, 17 deletions

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 44fd7025f2..64cd16dd19 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -12,7 +12,7 @@ module DsForeign ( dsForeigns ) where
 
 import CoreSyn
 
-import DsCCall		( dsCCall, mkCCall, boxResult, unboxArg )
+import DsCCall		( dsCCall, mkCCall, boxResult, unboxArg, resultWrapper )
 import DsMonad
 
 import HsSyn		( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
@@ -39,11 +39,14 @@ import PrimOp		( PrimOp(..), CCall(..),
 import TysWiredIn	( unitTy, addrTy, stablePtrTyCon,
 			  addrDataCon
 			)
+import TysPrim		( addrPrimTy )
 import Unique		( Uniquable(..), hasKey,
 			  ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, 
 			  bindIOIdKey, makeStablePtrIdKey
 		)
 import Outputable
+
+import Maybe 		( fromJust )
 \end{code}
 
 Desugaring of @foreign@ declarations is naturally split up into
@@ -76,7 +79,7 @@ dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos
         dsFImport i (idType i) uns ext_nm cconv  `thenDs` \ bs -> 
 	returnDs (bs ++ acc_fi, acc_fe, acc_h, acc_c)
     | isForeignLabel = 
-        dsFLabel i ext_nm `thenDs` \ b -> 
+        dsFLabel i (idType i) ext_nm `thenDs` \ b -> 
 	returnDs (b:acc_fi, acc_fe, acc_h, acc_c)
     | isDynamicExtName ext_nm =
         dsFExportDynamic i (idType i) mod_name ext_nm cconv  `thenDs` \ (fi,fe,h,c) -> 
@@ -161,10 +164,12 @@ dsFImport fn_id ty may_not_gc ext_name cconv
 Foreign labels 
 
 \begin{code}
-dsFLabel :: Id -> ExtName -> DsM CoreBind
-dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs)
+dsFLabel :: Id -> Type -> ExtName -> DsM CoreBind
+dsFLabel nm ty ext_name = 
+   ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
+   returnDs (NonRec nm (fo_rhs (mkLit (MachLabel enm))))
   where
-   fo_rhs = mkConApp addrDataCon [mkLit (MachLabel enm)]
+   (res_ty, fo_rhs) = resultWrapper ty
    enm    = extNameStatic ext_name
 \end{code}
 
@@ -325,7 +330,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
        fe_ext_name = ExtName (_PK_ fe_nm) Nothing
      in
      dsFExport  i export_ty mod_name fe_ext_name cconv True
-     `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
+     	`thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
      newSysLocalDs arg_ty			`thenDs` \ cback ->
      dsLookupGlobalValue makeStablePtrIdKey	`thenDs` \ makeStablePtrId ->
      let
@@ -357,7 +362,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
 	-- (probably in the RTS.) 
       adjustor	    = SLIT("createAdjustor")
      in
-     dsCCall adjustor adj_args False False ioAddrTy `thenDs` \ ccall_adj ->
+     dsCCall adjustor adj_args False False io_res_ty `thenDs` \ ccall_adj ->
      let ccall_adj_ty = exprType ccall_adj
          ccall_io_adj = mkLams [stbl_value]		     $
 			Note (Coerce io_res_ty (unUsgTy ccall_adj_ty))
@@ -365,7 +370,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
      in
      let io_app = mkLams tvs	 $
 		  mkLams [cback] $
-		  stbl_app ccall_io_adj addrTy
+		  stbl_app ccall_io_adj res_ty
      in
 	-- Never inline the f.e.d. function, because the litlit might not be in scope
 	-- in other modules.
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 55bb4453c3..e132166a8e 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -65,6 +65,8 @@ module TysWiredIn (
 	isFFIArgumentTy,  -- :: Bool -> Type -> Bool
 	isFFIResultTy,    -- :: Type -> Bool
 	isFFIExternalTy,  -- :: Type -> Bool
+ 	isFFIDynResultTy, -- :: Type -> Bool
+ 	isFFILabelTy,     -- :: Type -> Bool
 	isAddrTy,	  -- :: Type -> Bool
 	isForeignObjTy    -- :: Type -> Bool
 
@@ -359,6 +361,14 @@ isFFIResultTy :: Type -> Bool
 -- But we allow () as well
 isFFIResultTy ty = checkRepTyCon (\tc -> tc == unitTyCon || legalIncomingTyCon tc) ty
 
+-- The result type of a foreign export dynamic must be either Addr, or
+-- a newtype of Addr.
+isFFIDynResultTy = checkRepTyCon (== addrTyCon)
+
+-- The type of a foreign label must be either Addr, or
+-- a newtype of Addr.
+isFFILabelTy = checkRepTyCon (== addrTyCon)
+
 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
 	-- look through newtypes
 checkRepTyCon check_tc ty = checkTyCon check_tc (repType ty)
@@ -384,8 +394,10 @@ legalIncomingTyCon :: TyCon -> Bool
 legalIncomingTyCon tc
   | getUnique tc `elem` [ foreignObjTyConKey, 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
-  = marshalableTyCon tc
+  = boxedMarshalableTyCon tc
 
 legalOutgoingTyCon :: Bool -> TyCon -> Bool
 -- Checks validity of types going from Haskell -> external world
@@ -399,7 +411,10 @@ legalOutgoingTyCon be_safe tc
 
 marshalableTyCon tc
   =  (opt_GlasgowExts && isUnLiftedTyCon tc)
-  || getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
+  || boxedMarshalableTyCon tc
+
+boxedMarshalableTyCon tc
+   = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
 			 , wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
 			 , floatTyConKey, doubleTyConKey
 			 , addrTyConKey, charTyConKey, foreignObjTyConKey
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 6999107060..883103dbe7 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -28,7 +28,7 @@ import RnHsSyn		( RenamedHsDecl, RenamedForeignDecl )
 import TcMonad
 import TcEnv		( newLocalId )
 import TcType		( tcSplitRhoTy, zonkTcTypeToType )
-import TcMonoType	( tcHsBoxedSigType )
+import TcMonoType	( tcHsSigType, tcHsBoxedSigType )
 import TcHsSyn		( TcMonoBinds, TypecheckedForeignDecl,
 			  TcForeignExportDecl )
 import TcExpr		( tcId, tcPolyExpr )			
@@ -42,7 +42,8 @@ import Type		( splitFunTys
 			, splitForAllTys
 			)
 import TysWiredIn	( isFFIArgumentTy, isFFIResultTy, 
-			  isFFIExternalTy, isAddrTy
+			  isFFIExternalTy, isAddrTy,
+			  isFFIDynResultTy, isFFILabelTy
 			)
 import Type             ( Type )
 import Unique
@@ -105,7 +106,8 @@ tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
       -- of the foreign type.
     (_, t_ty) = splitForAllTys sig_ty
    in
-   check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
+   check (isFFILabelTy t_ty) 
+	(illegalForeignTyErr False{-result-} sig_ty) 	`thenTc_`
    let i = (mkVanillaId nm sig_ty) in
    returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
 
@@ -113,7 +115,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_
    tcAddSrcLoc src_loc		     $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
-   tcHsBoxedSigType hs_ty	     `thenTc` \ ty ->
+   tcHsSigType hs_ty		     `thenTc` \ ty ->
     -- Check that the type has the right shape
     -- and that the argument and result types are acceptable.
    let
@@ -183,9 +185,9 @@ checkForeignExport is_dynamic ty args res
      [arg]  ->
 	case splitFunTys arg of
 	   (arg_tys, res_ty) -> 
-		mapTc (checkForeignArg isFFIExternalTy) arg_tys		`thenTc_`
-		checkForeignRes True  {-NonIO ok-} isFFIResultTy res_ty	`thenTc_`
-		checkForeignRes False {-Must be IO-} isAddrTy	   res
+		mapTc (checkForeignArg isFFIExternalTy) arg_tys	`thenTc_`
+		checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_`
+		checkForeignRes False {-Must be IO-} isFFIDynResultTy res
      _      -> check False (illegalForeignTyErr True{-Arg-} ty)
  | otherwise =
      mapTc (checkForeignArg isFFIExternalTy) args  	        `thenTc_`