import DsMonad
import CoreUtils
-import Id
+import MkCore
+import Var
import MkId
import Maybes
import ForeignCall
import VarSet
import Constants
import Outputable
-
-#ifdef DEBUG
-import TypeRep
-#endif
-
\end{code}
Desugaring of @ccall@s consists of adding some state manipulation,
-> 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
unboxArg arg
-- Primtive types: nothing to unbox
| isPrimitiveType arg_ty
- = returnDs (arg, \body -> body)
+ = return (arg, \body -> body)
-- Recursive newtypes
- | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
+ | 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
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
\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:
-- 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, co) <- splitNewTypeRepCo_maybe result_ty
- = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
- returnDs (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
+ = 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)
projects / ghc-hetmet.git / blobdiff