Allow IO to be wrapped in a newtype in foreign import/export

Up to now, the silent unwrapping of newtypes in foreign import/export
has been limited to data values.  But it's useful for the IO monad
itself:

	newtype MyIO a = MIO (IO a)

	foreign import foo :: Int -> MyIO Int

This patch allows the IO monad to be
wrapped too. This applies to foreign import "dynamic" and "wrapper",
thus
   foreign import "wrapper" foo :: MyIO () -> HisIO (FunPtr (MyIO ()))

Warning: I did on the plane, and I'm no longer sure if its 100%
complete, so needs more testing.  In particular the wrapper/dynamic bit.

diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 3554197..8467539 100644 (file)
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -27,12 +27,12 @@ import ForeignCall  ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety,
                          CCallConv(..), CLabelString )
 import DataCon         ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
 
-import TcType          ( tcSplitTyConApp_maybe )
+import TcType          ( tcSplitIOType_maybe )
 import Type            ( Type, isUnLiftedType, mkFunTys, mkFunTy,
                          tyVarsOfType, mkForAllTys, mkTyConApp, 
                          isPrimitiveType, splitTyConApp_maybe, 
                          splitRecNewType_maybe, splitForAllTy_maybe,
-                         isUnboxedTupleType
+                         isUnboxedTupleType, coreView
                        )
 
 import PrimOp          ( PrimOp(..) )
@@ -214,7 +214,7 @@ unboxArg arg
              \ body ->
                let
                 io_ty = exprType body
-                (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
+                Just (_,io_arg) = tcSplitIOType_maybe io_ty
                in
                mkApps (Var unpack_id)
                       [ Type io_arg
@@ -230,7 +230,7 @@ unboxArg arg
              \ body ->
                let
                 io_ty = exprType body
-                (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
+                Just (_,io_arg) = tcSplitIOType_maybe io_ty
                in
                mkApps (Var unpack_id)
                       [ Type io_arg
@@ -271,65 +271,70 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> Cor
 -- where t' is the unwrapped form of t.  If t is simply (), then
 -- the result type will be 
 --     State# RealWorld -> (# State# RealWorld #)
+--
+-- The gruesome 'augment' and 'mbTopCon' are to do with .NET foreign calls
+-- It looks a mess: I wonder if it could be refactored.
 
 boxResult augment mbTopCon result_ty
-  = case tcSplitTyConApp_maybe result_ty of
-       -- This split absolutely has to be a tcSplit, because we must
-       -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
-
-       -- The result is IO t, so wrap the result in an IO constructor
-       Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
-               -> resultWrapper io_res_ty             `thenDs` \ res ->
-                  let aug_res          = augment res
-                      extra_result_tys =
-                        case aug_res of
-                          (Just ty,_) 
-                            | isUnboxedTupleType ty ->
-                               let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
-                          _ -> []
-                  in
-                  mk_alt (return_result extra_result_tys) aug_res 
-                                                       `thenDs` \ (ccall_res_ty, the_alt) ->
-                  newSysLocalDs  realWorldStatePrimTy  `thenDs` \ state_id ->
-                  let
-                       io_data_con = head (tyConDataCons io_tycon)
-                       toIOCon = 
-                         case mbTopCon of
-                           Nothing -> dataConWrapId io_data_con
-                           Just x  -> x
-                       wrap = \ the_call -> 
-                                mkApps (Var toIOCon)
-                                          [ Type io_res_ty, 
-                                            Lam state_id $
-                                             Case (App the_call (Var state_id))
-                                                  (mkWildId ccall_res_ty)
-                                                   (coreAltType the_alt) 
-                                                  [the_alt]
-                                          ]
-                  in
-                  returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
-               where
-                  return_result ts state anss 
-                    = mkConApp (tupleCon Unboxed (2 + length ts))
-                               (Type realWorldStatePrimTy : Type io_res_ty : map Type ts ++
-                                state : anss) 
-       -- It isn't, so do unsafePerformIO
+  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
+       -- isIOType_maybe handles the case where the type is a 
+       -- simple wrapping of IO.  E.g.
+       --      newtype Wrap a = W (IO a)
+       -- No coercion necessay because its a non-recursive newtype
+       -- (If we wanted to handle a *recursive* newtype too, we'd need
+       -- another case, and a coercion.)
+  =    -- The result is IO t, so wrap the result in an IO constructor
+       
+    resultWrapper io_res_ty             `thenDs` \ res ->
+    let aug_res          = augment res
+        extra_result_tys = case aug_res of
+                            (Just ty,_) 
+                              | isUnboxedTupleType ty 
+                              -> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
+                            _ -> []
+
+        return_result state anss
+         = mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
+                    (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
+                     ++ (state : anss)) 
+    in
+    mk_alt return_result aug_res       `thenDs` \ (ccall_res_ty, the_alt) ->
+    newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+    let
+       io_data_con = head (tyConDataCons io_tycon)
+       toIOCon = case mbTopCon of
+                       Nothing -> dataConWrapId io_data_con
+                       Just x  -> x
+       wrap = \ the_call -> mkApps (Var toIOCon)
+                                   [ Type io_res_ty, 
+                                     Lam state_id $
+                                      Case (App the_call (Var state_id))
+                                          (mkWildId ccall_res_ty)
+                                            (coreAltType the_alt) 
+                                          [the_alt]
+                                   ]
+    in
+    returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+
+boxResult augment mbTopCon result_ty
+  =    -- It isn't IO, so do unsafePerformIO
        -- It's not conveniently available, so we inline it
-       other -> resultWrapper result_ty            `thenDs` \ res ->
-                mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
-                let
-                   wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
+    resultWrapper result_ty            `thenDs` \ res ->
+    mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
+    let
+       wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
                                              (mkWildId ccall_res_ty)
                                               (coreAltType the_alt)
                                              [the_alt]
-                in
-                returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
-             where
-                return_result state [ans] = ans
-                return_result _ _ = panic "return_result: expected single result"
+    in
+    returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
   where
-    mk_alt return_result (Nothing, wrap_result)
-       =       -- The ccall returns ()
+    return_result state [ans] = ans
+    return_result _ _ = panic "return_result: expected single result"
+
+
+mk_alt return_result (Nothing, wrap_result)
+  =    -- The ccall returns ()
          newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
          let
                the_rhs = return_result (Var state_id) 
@@ -340,37 +345,37 @@ boxResult augment mbTopCon result_ty
          in
          returnDs (ccall_res_ty, the_alt)
 
-    mk_alt return_result (Just prim_res_ty, wrap_result)
+mk_alt return_result (Just prim_res_ty, wrap_result)
                -- The ccall returns a non-() value
-        | isUnboxedTupleType prim_res_ty
-        = let
-               Just (_, ls) = splitTyConApp_maybe prim_res_ty
-               arity = 1 + length ls
-         in
-         mappM newSysLocalDs ls                `thenDs` \ args_ids@(result_id:as) ->
-         newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
-         let
-               the_rhs = return_result (Var state_id) 
-                                       (wrap_result (Var result_id) : map Var as)
-               ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
-                                         (realWorldStatePrimTy : ls)
-               the_alt      = ( DataAlt (tupleCon Unboxed arity)
-                              , (state_id : args_ids)
-                              , the_rhs
-                              )
-         in
-         returnDs (ccall_res_ty, the_alt)
-       | otherwise
-       = newSysLocalDs prim_res_ty             `thenDs` \ result_id ->
-         newSysLocalDs realWorldStatePrimTy    `thenDs` \ state_id ->
-         let
-               the_rhs = return_result (Var state_id) 
-                                       [wrap_result (Var result_id)]
+  | isUnboxedTupleType prim_res_ty
+  = let
+       Just (_, ls) = splitTyConApp_maybe prim_res_ty
+       arity = 1 + length ls
+    in
+    mappM newSysLocalDs ls             `thenDs` \ args_ids@(result_id:as) ->
+    newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+    let
+       the_rhs = return_result (Var state_id) 
+                               (wrap_result (Var result_id) : map Var as)
+       ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
+                                 (realWorldStatePrimTy : ls)
+       the_alt      = ( DataAlt (tupleCon Unboxed arity)
+                      , (state_id : args_ids)
+                      , the_rhs
+                      )
+    in
+    returnDs (ccall_res_ty, the_alt)
 
-               ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
-               the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
-         in
-         returnDs (ccall_res_ty, the_alt)
+  | otherwise
+  = newSysLocalDs prim_res_ty          `thenDs` \ result_id ->
+    newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+    let
+       the_rhs = return_result (Var state_id) 
+                               [wrap_result (Var result_id)]
+       ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
+       the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
+    in
+    returnDs (ccall_res_ty, the_alt)
 
 
 resultWrapper :: Type

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 52956a0..fcac3a6 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -32,21 +32,21 @@ import Module               ( moduleFS )
 import Name            ( getOccString, NamedThing(..) )
 import Type            ( repType, coreEqType )
 import TcType          ( Type, mkFunTys, mkForAllTys, mkTyConApp,
-                         mkFunTy, tcSplitTyConApp_maybe, 
+                         mkFunTy, tcSplitTyConApp_maybe, tcSplitIOType_maybe,
                          tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
                        )
 
 import BasicTypes       ( Boxity(..) )
 import HscTypes                ( ForeignStubs(..) )
 import ForeignCall     ( ForeignCall(..), CCallSpec(..), 
-                         Safety(..), playSafe,
+                         Safety(..), 
                          CExportSpec(..), CLabelString,
                          CCallConv(..), ccallConvToInt,
                          ccallConvAttribute
                        )
 import TysWiredIn      ( unitTy, tupleTyCon )
 import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
-import PrelNames       ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
+import PrelNames       ( stablePtrTyConName, newStablePtrName, bindIOName,
                          checkDotnetResName )
 import BasicTypes      ( Activation( NeverActive ) )
 import SrcLoc          ( Located(..), unLoc )
@@ -253,9 +253,6 @@ dsFCall fn_id fcall no_hdrs
         wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
     in
     returnDs ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
-
-unsafe_call (CCall (CCallSpec _ _ safety)) = playSafe safety
-unsafe_call (DNCall _)                    = False
 \end{code}
 
 
@@ -304,19 +301,12 @@ dsFExport fn_id ty ext_name cconv isDyn
        -- Look at the result type of the exported function, orig_res_ty
        -- If it's IO t, return         (t, True)
        -- If it's plain t, return      (t, False)
-     (case tcSplitTyConApp_maybe orig_res_ty of
-       -- We must use tcSplit here so that we see the (IO t) in
-       -- the type.  [IO t is transparent to plain splitTyConApp.]
-
-       Just (ioTyCon, [res_ty])
-             -> ASSERT( ioTyCon `hasKey` ioTyConKey )
-                -- The function already returns IO t
-                returnDs (res_ty, True)
-
-       other -> -- The function returns t
-                returnDs (orig_res_ty, False)
-     )
-                                       `thenDs` \ (res_ty,             -- t
+     (case tcSplitIOType_maybe orig_res_ty of
+       Just (ioTyCon, res_ty) -> returnDs (res_ty, True)
+               -- The function already returns IO t
+       Nothing                -> returnDs (orig_res_ty, False) 
+               -- The function returns t
+     )                                 `thenDs` \ (res_ty,             -- t
                                                    is_IO_res_ty) ->    -- Bool
      returnDs $
        mkFExportCBits ext_name 

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 4be039b..fc98fdb 100644 (file)
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -35,7 +35,7 @@ import SMRep          ( argMachRep, primRepToCgRep, primRepHint )
 import OccName         ( mkForeignExportOcc )
 import Name            ( Name, NamedThing(..), mkExternalName )
 import TcType          ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
-                         tcSplitForAllTys, 
+                         tcSplitForAllTys, tcSplitIOType_maybe,
                          isFFIArgumentTy, isFFIImportResultTy, 
                          isFFIExportResultTy, isFFILabelTy,
                          isFFIExternalTy, isFFIDynArgumentTy,
@@ -277,13 +277,14 @@ nonIOok  = True
 mustBeIO = False
 
 checkForeignRes non_io_result_ok pred_res_ty ty
- = case tcSplitTyConApp_maybe ty of
-      Just (io, [res_ty]) 
-        | io `hasKey` ioTyConKey && pred_res_ty res_ty 
-       -> returnM ()
-      _   
-        -> check (non_io_result_ok && pred_res_ty ty) 
-                (illegalForeignTyErr result ty)
+       -- (IO t) is ok, and so is any newtype wrapping thereof
+  | Just (io, res_ty) <- tcSplitIOType_maybe ty,
+    pred_res_ty res_ty
+  = returnM ()
+ 
+  | otherwise
+  = check (non_io_result_ok && pred_res_ty ty) 
+         (illegalForeignTyErr result ty)
 \end{code}
 
 \begin{code}

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 4b6e7b8..0818437 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -82,7 +82,7 @@ module TcType (
   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
   isFFIDotnetObjTy,    -- :: Type -> Bool
   isFFITy,            -- :: Type -> Bool
-  
+  tcSplitIOType_maybe, -- :: Type -> Maybe Type  
   toDNType,            -- :: Type -> DNType
 
   --------------------------------
@@ -160,7 +160,7 @@ import Type         (       -- Re-exports
                          substTy, substTys, substTyWith, substTheta, 
                          substTyVar, substTyVarBndr, substPred, lookupTyVar,
 
-                         typeKind, repType,
+                         typeKind, repType, coreView,
                          pprKind, pprParendKind,
                          pprType, pprParendType, pprTyThingCategory,
                          pprPred, pprTheta, pprThetaArrow, pprClassPred
@@ -1029,6 +1029,23 @@ restricted set of types as arguments and results (the restricting factor
 being the )
 
 \begin{code}
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
+-- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or
+--                                    some newtype wrapping thereof
+--             returns Nothing otherwise
+tcSplitIOType_maybe ty 
+  | Just (io_tycon, [io_res_ty]) <- tcSplitTyConApp_maybe ty,
+       -- This split absolutely has to be a tcSplit, because we must
+       -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
+    io_tycon `hasKey` ioTyConKey
+  = Just (io_tycon, io_res_ty)
+
+  | Just ty' <- coreView ty    -- Look through non-recursive newtypes
+  = tcSplitIOType_maybe ty'
+
+  | otherwise
+  = Nothing
+
 isFFITy :: Type -> Bool
 -- True for any TyCon that can possibly be an arg or result of an FFI call
 isFFITy ty = checkRepTyCon legalFFITyCon ty