%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
-\section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
+\section[DsCCall]{Desugaring C calls}
\begin{code}
module DsCCall
#include "HsVersions.h"
+
import CoreSyn
import DsMonad
import Id ( Id, mkWildId )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
-import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety,
+ CCallConv(..), CLabelString )
import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
import ForeignCall ( ForeignCall, CCallTarget(..) )
import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy,
tyVarsOfType, mkForAllTys, mkTyConApp,
isPrimitiveType, splitTyConApp_maybe,
- splitNewType_maybe, splitForAllTy_maybe,
+ splitRecNewType_maybe, splitForAllTy_maybe,
isUnboxedTupleType
)
)
import BasicTypes ( Boxity(..) )
import Literal ( mkMachInt )
-import CStrings ( CLabelString )
import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
int8TyConKey, int16TyConKey, int32TyConKey,
word8TyConKey, word16TyConKey, word32TyConKey
import VarSet ( varSetElems )
import Constants ( wORD_SIZE)
import Outputable
+
+#ifdef DEBUG
+import TypeRep
+#endif
+
\end{code}
Desugaring of @ccall@s consists of adding some state manipulation,
dsCCall :: CLabelString -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
-> Safety -- Safety of the call
- -> Bool -- True <=> really a "_casm_"
-> Type -- Type of the result: IO t
-> DsM CoreExpr
-dsCCall lbl args may_gc is_asm result_ty
+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) ->
- getUniqueDs `thenDs` \ uniq ->
+ newUnique `thenDs` \ uniq ->
let
- target | is_asm = CasmTarget lbl
- | otherwise = StaticTarget lbl
+ 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 (arg, \body -> body)
-- Recursive newtypes
- | Just rep_ty <- splitNewType_maybe arg_ty
+ | Just rep_ty <- splitRecNewType_maybe arg_ty
= unboxArg (mkCoerce2 rep_ty arg_ty arg)
-- Booleans
-- 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
- = ASSERT(isUnLiftedType data_con_arg_ty1 ) -- Typechecker ensures this
+ = 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,
])
| otherwise
- = getSrcLocDs `thenDs` \ l ->
+ = getSrcSpanDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
-- The ccall returns a non-() value
| isUnboxedTupleType prim_res_ty
= let
- (Just (_, ls@(prim_res_ty1:extras))) = splitTyConApp_maybe prim_res_ty
+ Just (_, ls) = splitTyConApp_maybe prim_res_ty
arity = 1 + length ls
in
- mapDs newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
+ mappM newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
in
returnDs (ccall_res_ty, the_alt)
| otherwise
- =
- newSysLocalDs prim_res_ty `thenDs` \ result_id ->
+ = newSysLocalDs prim_res_ty `thenDs` \ result_id ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Recursive newtypes
- | Just rep_ty <- splitNewType_maybe result_ty
+ | 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))