%
% (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 CoreUtils ( exprType, mkCoerce2 )
+import CoreUtils ( exprType, coreAltType, mkCoerce2 )
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 TcType ( tcSplitTyConApp_maybe )
import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy,
tyVarsOfType, mkForAllTys, mkTyConApp,
isPrimitiveType, splitTyConApp_maybe,
- splitNewType_maybe, splitForAllTy_maybe,
+ splitRecNewType_maybe, splitForAllTy_maybe,
isUnboxedTupleType
)
unboxedSingletonTyCon, unboxedPairTyCon,
trueDataCon, falseDataCon,
trueDataConId, falseDataConId,
- listTyCon, charTyCon,
+ listTyCon, charTyCon, boolTy,
tupleTyCon, tupleCon
)
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 ->
+ boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+ 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
tc `hasKey` boolTyConKey
= newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
- \ body -> Case (Case arg (mkWildId arg_ty)
+ \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
- prim_arg
+ -- In increasing tag order!
+ prim_arg
+ (exprType body)
[(DEFAULT,[],body)])
-- Data types with a single constructor, which has a single, primitive-typed arg
- -- This deals with Int, Float etc
+ -- 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,
- \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)]
+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
-- Byte-arrays, both mutable and otherwise; hack warning
maybeToBool maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
- -- and, of course, it is an instance of CCallable
= 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 [(DataAlt data_con,vars,body)]
+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+
)
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
])
| otherwise
- = getSrcLocDs `thenDs` \ l ->
+ = getSrcSpanDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
\begin{code}
-boxResult :: [Id]
- -> ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
+boxResult :: ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
-> Maybe Id
-> Type
-> DsM (Type, CoreExpr -> CoreExpr)
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
-boxResult arg_ids augment mbTopCon result_ty
+boxResult augment mbTopCon result_ty
= case tcSplitTyConApp_maybe result_ty of
-- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
Lam state_id $
Case (App the_call (Var state_id))
(mkWildId ccall_res_ty)
+ (coreAltType the_alt)
[the_alt]
]
in
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 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)
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= returnDs
(Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+ boolTy
[(DEFAULT ,[],Var trueDataConId ),
(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))
returnDs (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
projects / ghc-hetmet.git / blobdiff