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

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 44fd702..64cd16d 100644 (file)
--- 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 55bb445..e132166 100644 (file)
--- 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 6999107..883103d 100644 (file)
--- 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_`