X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsCCall.lhs;h=fc4305b54be7c3ab29b8c1f2e4b2a4c3cfb1dd8a;hp=a041665f23547a6269f24794c5d9cedc1921c5b8;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=5e0ea427646a5474dd7c659b0713c6a62d8c99c7 diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index a041665..fc4305b 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -1,9 +1,18 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1994-1998 % -\section[DsCCall]{Desugaring C calls} + +Desugaring foreign calls \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- for details + module DsCCall ( dsCCall , mkFCall @@ -19,48 +28,25 @@ import CoreSyn import DsMonad -import CoreUtils ( exprType, coreAltType, mkCoerce ) -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 ( tcSplitIOType_maybe ) -import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy, - tyVarsOfType, mkForAllTys, mkTyConApp, - isPrimitiveType, splitTyConApp_maybe, - splitRecNewType_maybe, splitForAllTy_maybe, - isUnboxedTupleType - ) -import Coercion ( Coercion, splitNewTypeRepCo_maybe, mkSymCoercion ) -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, 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 @@ -112,9 +98,9 @@ dsCCall :: CLabelString -- C routine to invoke -> DsM CoreExpr -- Result, of type ??? dsCCall lbl args may_gc result_ty - = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> + = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> - newUnique `thenDs` \ uniq -> + newUnique `thenDs` \ uniq -> let target = StaticTarget lbl the_fcall = CCall (CCallSpec target CCallConv may_gc) @@ -203,6 +189,7 @@ unboxArg arg ) + ----- Cases for .NET; almost certainly bit-rotted --------- | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty, tc == listTyCon, Just (cc,[]) <- splitTyConApp_maybe arg_ty, @@ -214,7 +201,7 @@ unboxArg arg \ body -> let io_ty = exprType body - Just (_,io_arg) = tcSplitIOType_maybe io_ty + Just (_,io_arg,_) = tcSplitIOType_maybe io_ty in mkApps (Var unpack_id) [ Type io_arg @@ -230,13 +217,14 @@ unboxArg arg \ body -> let io_ty = exprType body - Just (_,io_arg) = tcSplitIOType_maybe io_ty + Just (_,io_arg,_) = tcSplitIOType_maybe io_ty in mkApps (Var unpack_id) [ Type io_arg , arg , Lam prim_obj body ]) + --------------- End of cases for .NET -------------------- | otherwise = getSrcSpanDs `thenDs` \ l -> @@ -256,7 +244,8 @@ unboxArg arg \begin{code} -boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr)) +boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) + -> (Maybe Type, CoreExpr -> CoreExpr)) -> Maybe Id -> Type -> DsM (Type, CoreExpr -> CoreExpr) @@ -276,45 +265,45 @@ boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> Cor -- 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 + | Just (io_tycon, io_res_ty, co) <- 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 + -- No coercion necessary 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) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- resultWrapper io_res_ty + ; 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)) + + ; (ccall_res_ty, the_alt) <- mk_alt return_result aug_res + + ; state_id <- newSysLocalDs realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = mbTopCon `orElse` dataConWrapId io_data_con + + wrap the_call = mkCoerceI (mkSymCoI co) $ + 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] + ] + + ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) } boxResult augment mbTopCon result_ty = -- It isn't IO, so do unsafePerformIO @@ -323,9 +312,9 @@ boxResult augment mbTopCon result_ty 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] + (mkWildId ccall_res_ty) + (coreAltType the_alt) + [the_alt] in returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) where @@ -381,6 +370,9 @@ mk_alt return_result (Just prim_res_ty, wrap_result) resultWrapper :: Type -> DsM (Maybe Type, -- Type of the expected result, if any CoreExpr -> CoreExpr) -- Wrapper for the result +-- resultWrapper deals with the result *value* +-- E.g. foreign import foo :: Int -> IO T +-- Then resultWrapper deals with marshalling the 'T' part resultWrapper result_ty -- Base case 1: primitive types | isPrimitiveType result_ty