import CoreSyn
import DsMonad
-import DsUtils
import CoreUtils ( exprType, mkCoerce )
-import Id ( Id, mkWildId )
+import Id ( mkWildId )
import MkId ( mkCCallOpId, realWorldPrimId )
import Maybes ( maybeToBool )
-import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
-import DataCon ( DataCon, splitProductType_maybe, dataConSourceArity, dataConWrapId )
+import PrimOp ( CCall(..), CCallTarget(..) )
+import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId )
import CallConv
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
splitTyConApp_maybe, tyVarsOfType, mkForAllTys,
- isNewType, repType, isUnLiftedType, mkFunTy,
+ isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
Type
)
-import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
+import TysPrim ( realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy
)
-import TysWiredIn ( unitDataConId, stringTy,
- unboxedPairDataCon,
- mkUnboxedTupleTy, unboxedTupleCon,
- boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId,
- unitTy
+import TysWiredIn ( unitDataConId,
+ unboxedSingletonDataCon, unboxedPairDataCon,
+ unboxedSingletonTyCon, unboxedPairTyCon,
+ boolTy, trueDataCon, falseDataCon,
+ trueDataConId, falseDataConId, unitTy
)
import Literal ( mkMachInt )
import CStrings ( CLabelString )
-import Unique ( Unique, Uniquable(..), ioTyConKey )
+import PrelNames ( Unique, hasKey, ioTyConKey )
import VarSet ( varSetElems )
import Outputable
\end{code}
= getSrcLocDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
- arg_ty = exprType arg
- arg_rep_ty = repType arg_ty
-
- maybe_product_type = splitProductType_maybe arg_ty
- is_product_type = maybeToBool maybe_product_type
- Just (tycon, _, data_con, data_con_arg_tys) = maybe_product_type
- data_con_arity = dataConSourceArity data_con
- (data_con_arg_ty1 : _) = data_con_arg_tys
+ arg_ty = exprType arg
+ maybe_product_type = splitProductType_maybe arg_ty
+ is_product_type = maybeToBool maybe_product_type
+ Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
+ data_con_arity = dataConSourceArity data_con
+ (data_con_arg_ty1 : _) = data_con_arg_tys
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
= case splitAlgTyConApp_maybe result_ty of
-- The result is IO t, so wrap the result in an IO constructor
- Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey
+ Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey
-> mk_alt return_result
(resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult"))
- ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
- the_alt = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs)
+ ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
+ the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
in
returnDs (ccall_res_ty, the_alt)
newSysLocalDs prim_res_ty `thenDs` \ result_id ->
let
the_rhs = return_result (Var state_id) (wrap_result (Var result_id))
- ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty]
+ 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)
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
where
- maybe_product_type = splitProductType_maybe result_ty
- is_product_type = maybeToBool maybe_product_type
- Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
- data_con_arity = dataConSourceArity data_con
+ maybe_product_type = splitProductType_maybe result_ty
+ is_product_type = maybeToBool maybe_product_type
+ Just (_, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
+ data_con_arity = dataConSourceArity data_con
\end{code}