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,
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
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) ->
+ boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
newUnique `thenDs` \ uniq ->
let
target = StaticTarget lbl
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
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
= 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,
\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)
| 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)])