From fb0f3349561dd4493d81ca7c3a140b37fa0dc0de Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 11 Apr 2006 12:04:41 +0000 Subject: [PATCH] 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. --- compiler/deSugar/DsCCall.lhs | 175 ++++++++++++++++++++------------------ compiler/deSugar/DsForeign.lhs | 28 ++---- compiler/typecheck/TcForeign.lhs | 17 ++-- compiler/typecheck/TcType.lhs | 21 ++++- 4 files changed, 127 insertions(+), 114 deletions(-) diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 3554197..8467539 100644 --- 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 --- 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 --- 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 --- 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 -- 1.7.10.4