X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsCCall.lhs;h=fca20df03dd1f04fd83a2d8fb521af8d1d9fb751;hb=8a2809c29de9f23eba7ca682b48390033a9d40f6;hp=3554197fb8cbb42897f551d5a07c2086cfd39d9b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 3554197..fca20df 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1994-1998 % -\section[DsCCall]{Desugaring C calls} + +Desugaring foreign calls \begin{code} module DsCCall @@ -19,48 +21,25 @@ import CoreSyn import DsMonad -import CoreUtils ( exprType, coreAltType, mkCoerce2 ) -import Id ( Id, mkWildId ) -import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId ) -import Maybes ( maybeToBool ) -import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, - CCallConv(..), CLabelString ) -import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId ) - -import TcType ( tcSplitTyConApp_maybe ) -import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy, - tyVarsOfType, mkForAllTys, mkTyConApp, - isPrimitiveType, splitTyConApp_maybe, - splitRecNewType_maybe, splitForAllTy_maybe, - isUnboxedTupleType - ) - -import PrimOp ( PrimOp(..) ) -import TysPrim ( realWorldStatePrimTy, intPrimTy, - byteArrayPrimTyCon, mutableByteArrayPrimTyCon, - addrPrimTy - ) -import TyCon ( TyCon, tyConDataCons, tyConName ) -import TysWiredIn ( unitDataConId, - unboxedSingletonDataCon, unboxedPairDataCon, - unboxedSingletonTyCon, unboxedPairTyCon, - trueDataCon, falseDataCon, - trueDataConId, falseDataConId, - listTyCon, charTyCon, boolTy, - tupleTyCon, tupleCon - ) -import BasicTypes ( Boxity(..) ) -import Literal ( mkMachInt ) -import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey, - int8TyConKey, int16TyConKey, int32TyConKey, - word8TyConKey, word16TyConKey, word32TyConKey - -- dotnet interop - , marshalStringName, unmarshalStringName - , marshalObjectName, unmarshalObjectName - , objectTyConName - ) -import VarSet ( varSetElems ) -import Constants ( wORD_SIZE) +import CoreUtils +import Id +import MkId +import Maybes +import ForeignCall +import DataCon + +import TcType +import Type +import Coercion +import PrimOp +import TysPrim +import TyCon +import TysWiredIn +import BasicTypes +import Literal +import PrelNames +import VarSet +import Constants import Outputable #ifdef DEBUG @@ -109,7 +88,7 @@ dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) -> Safety -- Safety of the call -> Type -- Type of the result: IO t - -> DsM CoreExpr + -> DsM CoreExpr -- Result, of type ??? dsCCall lbl args may_gc result_ty = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> @@ -160,8 +139,8 @@ unboxArg arg = returnDs (arg, \body -> body) -- Recursive newtypes - | Just rep_ty <- splitRecNewType_maybe arg_ty - = unboxArg (mkCoerce2 rep_ty arg_ty arg) + | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty + = unboxArg (mkCoerce co arg) -- Booleans | Just (tc,_) <- splitTyConApp_maybe arg_ty, @@ -214,7 +193,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 +209,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 +250,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 + | 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 - = 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 + = -- 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 +324,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 @@ -394,9 +378,9 @@ resultWrapper result_ty (LitAlt (mkMachInt 0),[],Var falseDataConId)]) -- Recursive newtypes - | Just rep_ty <- splitRecNewType_maybe result_ty + | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) -> - returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e)) + returnDs (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e)) -- The type might contain foralls (eg. for dummy type arguments, -- referring to 'Ptr a' is legal).