X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsCCall.lhs;h=f46d99e504c111c7e6e73ed2c2c43db8646c4a5c;hp=2ee9d08fb013dfa3de4d58a205ec5168994bdd9e;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=f2dcf256399e9a2de6343c625630b51f8abf4863 diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 2ee9d08..f46d99e 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,54 +21,27 @@ 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 ( tcSplitIOType_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, 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 MkCore +import Var +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 -import TypeRep -#endif - \end{code} Desugaring of @ccall@s consists of adding some state manipulation, @@ -109,18 +84,17 @@ 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) -> - boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> - newUnique `thenDs` \ uniq -> - let - target = StaticTarget lbl - the_fcall = CCall (CCallSpec target CCallConv may_gc) - the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty - in - returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers) + = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args + (ccall_result_ty, res_wrapper) <- boxResult result_ty + uniq <- newUnique + let + target = StaticTarget lbl Nothing + the_fcall = CCall (CCallSpec target CCallConv may_gc) + the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty + return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) mkFCall :: Unique -> ForeignCall -> [CoreExpr] -- Args @@ -157,35 +131,35 @@ unboxArg :: CoreExpr -- The supplied argument unboxArg arg -- Primtive types: nothing to unbox | isPrimitiveType arg_ty - = returnDs (arg, \body -> body) + = return (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, tc `hasKey` boolTyConKey - = newSysLocalDs intPrimTy `thenDs` \ prim_arg -> - returnDs (Var prim_arg, - \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy - [(DataAlt falseDataCon,[],mkIntLit 0), - (DataAlt trueDataCon, [],mkIntLit 1)]) - -- In increasing tag order! + = do prim_arg <- newSysLocalDs intPrimTy + return (Var prim_arg, + \ body -> Case (mkWildCase arg arg_ty intPrimTy + [(DataAlt falseDataCon,[],mkIntLit 0), + (DataAlt trueDataCon, [],mkIntLit 1)]) + -- In increasing tag order! prim_arg (exprType body) - [(DEFAULT,[],body)]) + [(DEFAULT,[],body)]) -- Data types with a single constructor, which has a single, primitive-typed arg -- This deals with Int, Float etc; also Ptr, ForeignPtr | is_product_type && data_con_arity == 1 = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty) - -- Typechecker ensures this - newSysLocalDs arg_ty `thenDs` \ case_bndr -> - newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg -> - returnDs (Var prim_arg, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] - ) + -- Typechecker ensures this + do case_bndr <- newSysLocalDs arg_ty + prim_arg <- newSysLocalDs data_con_arg_ty1 + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] + ) -- Byte-arrays, both mutable and otherwise; hack warning -- We're looking for values of type ByteArray, MutableByteArray @@ -196,51 +170,52 @@ unboxArg arg maybeToBool maybe_arg3_tycon && (arg3_tycon == byteArrayPrimTyCon || arg3_tycon == mutableByteArrayPrimTyCon) - = newSysLocalDs arg_ty `thenDs` \ case_bndr -> - newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] -> - returnDs (Var arr_cts_var, - \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] - - ) + = do case_bndr <- newSysLocalDs arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys + return (Var arr_cts_var, + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] + ) + ----- Cases for .NET; almost certainly bit-rotted --------- | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty, tc == listTyCon, Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon -- String; dotnet only - = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id -> - newSysLocalDs addrPrimTy `thenDs` \ prim_string -> - returnDs (Var prim_string, - \ body -> - let - io_ty = exprType body - Just (_,io_arg) = tcSplitIOType_maybe io_ty - in - mkApps (Var unpack_id) - [ Type io_arg - , arg - , Lam prim_string body - ]) - | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty, + = do unpack_id <- dsLookupGlobalId marshalStringName + prim_string <- newSysLocalDs addrPrimTy + return (Var prim_string, + \ body -> + let + io_ty = exprType body + Just (_,io_arg,_) = tcSplitIOType_maybe io_ty + in + mkApps (Var unpack_id) + [ Type io_arg + , arg + , Lam prim_string body + ]) + | Just (tc, [_]) <- splitTyConApp_maybe arg_ty, tyConName tc == objectTyConName -- Object; dotnet only - = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id -> - newSysLocalDs addrPrimTy `thenDs` \ prim_obj -> - returnDs (Var prim_obj, - \ body -> - let - io_ty = exprType body - Just (_,io_arg) = tcSplitIOType_maybe io_ty - in - mkApps (Var unpack_id) - [ Type io_arg - , arg - , Lam prim_obj body - ]) + = do unpack_id <- dsLookupGlobalId marshalObjectName + prim_obj <- newSysLocalDs addrPrimTy + return (Var prim_obj, + \ body -> + let + io_ty = exprType body + 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 -> - pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) + = do l <- getSrcSpanDs + pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) where arg_ty = exprType arg maybe_product_type = splitProductType_maybe arg_ty @@ -256,9 +231,7 @@ unboxArg arg \begin{code} -boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr)) - -> Maybe Id - -> Type +boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr) -- Takes the result of the user-level ccall: @@ -271,170 +244,167 @@ 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 +boxResult 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) - -boxResult augment mbTopCon result_ty - = -- It isn't IO, so do unsafePerformIO - -- It's not conveniently available, so we inline it - 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) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- resultWrapper io_res_ty + ; let extra_result_tys + = case 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 res + + ; state_id <- newSysLocalDs realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = mkCoerceI (mkSymCoI co) $ + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + ccall_res_ty + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) } + +boxResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- resultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + ccall_res_ty + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) where - return_result state [ans] = ans - return_result _ _ = panic "return_result: expected single result" + return_result _ [ans] = ans + return_result _ _ = panic "return_result: expected single result" +mk_alt :: (Expr Var -> [Expr Var] -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, (AltCon, [Id], Expr Var)) mk_alt return_result (Nothing, wrap_result) - = -- The ccall returns () - newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> - let - the_rhs = return_result (Var state_id) - [wrap_result (panic "boxResult")] + = do -- The ccall returns () + state_id <- newSysLocalDs realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + [wrap_result (panic "boxResult")] - ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy] - the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs) - in - returnDs (ccall_res_ty, the_alt) + ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy] + the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs) + + return (ccall_res_ty, the_alt) 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 -> + | isUnboxedTupleType prim_res_ty= do 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 -> + Just (_, ls) = splitTyConApp_maybe prim_res_ty + arity = 1 + length ls + args_ids@(result_id:as) <- mapM newSysLocalDs ls + state_id <- newSysLocalDs realWorldStatePrimTy + 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 + ) + return (ccall_res_ty, the_alt) + + | otherwise = do + result_id <- newSysLocalDs prim_res_ty + state_id <- newSysLocalDs realWorldStatePrimTy 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) + 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) + return (ccall_res_ty, the_alt) resultWrapper :: Type - -> DsM (Maybe Type, -- Type of the expected result, if any - CoreExpr -> CoreExpr) -- Wrapper for the result + -> 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 - = returnDs (Just result_ty, \e -> e) + = return (Just result_ty, \e -> e) -- Base case 2: the unit type () | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey - = returnDs (Nothing, \e -> Var unitDataConId) + = return (Nothing, \_ -> Var unitDataConId) -- Base case 3: the boolean type | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey - = returnDs - (Just intPrimTy, \e -> Case e (mkWildId intPrimTy) + = return + (Just intPrimTy, \e -> mkWildCase e intPrimTy boolTy - [(DEFAULT ,[],Var trueDataConId ), - (LitAlt (mkMachInt 0),[],Var falseDataConId)]) + [(DEFAULT ,[],Var trueDataConId ), + (LitAlt (mkMachInt 0),[],Var falseDataConId)]) -- Recursive newtypes - | Just rep_ty <- splitRecNewType_maybe result_ty - = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) -> - returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e)) + | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty + = do (maybe_ty, wrapper) <- resultWrapper rep_ty + return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e)) -- The type might contain foralls (eg. for dummy type arguments, -- referring to 'Ptr a' is legal). | Just (tyvar, rest) <- splitForAllTy_maybe result_ty - = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) -> - returnDs (maybe_ty, \e -> Lam tyvar (wrapper e)) + = do (maybe_ty, wrapper) <- resultWrapper rest + return (maybe_ty, \e -> Lam tyvar (wrapper e)) -- Data types with a single constructor, which has a single arg -- This includes types like Ptr and ForeignPtr | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty, dataConSourceArity data_con == 1 - = let - (unwrapped_res_ty : _) = data_con_arg_tys - narrow_wrapper = maybeNarrow tycon - in - resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) -> - returnDs - (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) - (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)])) + = do let + (unwrapped_res_ty : _) = data_con_arg_tys + narrow_wrapper = maybeNarrow tycon + (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty + return + (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) + (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)])) -- Strings; 'dotnet' only. | Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon, Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon - = dsLookupGlobalId unmarshalStringName `thenDs` \ pack_id -> - returnDs (Just addrPrimTy, - \ e -> App (Var pack_id) e) + = do pack_id <- dsLookupGlobalId unmarshalStringName + return (Just addrPrimTy, + \ e -> App (Var pack_id) e) -- Objects; 'dotnet' only. - | Just (tc, [arg_ty]) <- maybe_tc_app, + | Just (tc, [_]) <- maybe_tc_app, tyConName tc == objectTyConName - = dsLookupGlobalId unmarshalObjectName `thenDs` \ pack_id -> - returnDs (Just addrPrimTy, - \ e -> App (Var pack_id) e) + = do pack_id <- dsLookupGlobalId unmarshalObjectName + return (Just addrPrimTy, + \ e -> App (Var pack_id) e) | otherwise = pprPanic "resultWrapper" (ppr result_ty)