Commit fb0f3349 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent aa2c486e
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment