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(..) )
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
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; also Ptr, ForeignPtr
| is_product_type && data_con_arity == 1
- = ASSERT2(isUnLiftedType data_con_arg_ty1, crudePprType arg_ty)
+ = 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
= 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
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)])