%
+% (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
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 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
-> [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) ->
+ = 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)
= 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,
)
+ ----- Cases for .NET; almost certainly bit-rotted ---------
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty,
\ 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
\ 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 ->
\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)
-- 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
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
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
(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).
projects / ghc-hetmet.git / blobdiff