, getIoOkDataCon
, unboxArg
, boxResult
+ , wrapUnboxedValue
, can'tSeeDataConsPanic
) where
isUnpointedType the_prim_result_ty -- of primitive type
=
newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
- newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
-
- mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
-
+ wrapUnboxedValue result_ty `thenDs` \ (state_and_prim_datacon,
+ state_and_prim_ty, prim_result_id, the_result) ->
mkConDs ioOkDataCon
[TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
`thenDs` \ the_pair ->
| otherwise
= pprPanic "boxResult: " (ppr result_ty)
-
where
maybe_data_type = splitAlgTyConApp_maybe result_ty
Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
(the_prim_result_ty : other_args_tys) = data_con_arg_tys
- (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
+-- (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
+
+-- wrap up an unboxed value.
+wrapUnboxedValue :: Type -> DsM (Id, Type, Id, CoreExpr)
+wrapUnboxedValue ty
+ | null data_cons
+ -- oops! can't see the data constructors
+ = can'tSeeDataConsPanic "result" ty
+ -- Data types with a single constructor, which has a single, primitive-typed arg
+ | (maybeToBool maybe_data_type) && -- Data type
+ (null other_data_cons) && -- Just one constr
+ not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
+ isUnpointedType the_prim_result_ty -- of primitive type
+ =
+ newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
+ mkConDs the_data_con (map TyArg tycon_arg_tys ++
+ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
+ returnDs (state_and_prim_datacon, state_and_prim_ty, prim_result_id, the_result)
+
+ -- Data types with a single nullary constructor
+ | (maybeToBool maybe_data_type) && -- Data type
+ (null other_data_cons) && -- Just one constr
+ (null data_con_arg_tys)
+ =
+ let unit = unitDataCon in
+ returnDs (stateDataCon, realWorldStateTy, unit, Var unit)
+ | otherwise
+ = pprPanic "boxResult: " (ppr ty)
+ where
+ maybe_data_type = splitAlgTyConApp_maybe ty
+ Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
+ (the_data_con : other_data_cons) = data_cons
+
+ data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
+ (the_prim_result_ty : other_args_tys) = data_con_arg_tys
+ (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty
+
\end{code}
This grimy bit of code is for digging out the IOok constructor from an
import CoreSyn
import DsCCall ( getIoOkDataCon, boxResult, unboxArg,
- can'tSeeDataConsPanic
+ can'tSeeDataConsPanic, wrapUnboxedValue
)
import DsMonad
import DsUtils
import Literal ( Literal(..), mkMachInt )
import Maybes ( maybeToBool )
import Name ( nameString, occNameString, nameOccName, nameUnique )
-import PrelVals ( packStringForCId, eRROR_ID )
+import PrelVals ( packStringForCId, eRROR_ID, realWorldPrimId )
import PrimOp ( PrimOp(..) )
import Type ( isUnpointedType, splitAlgTyConApp_maybe,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
stateAndPtrPrimDataCon,
addrDataCon
)
+import Unique
import Outputable
\end{code}
mkArgs ty `thenDs` \ (tvs, args, io_res_ty) ->
mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
let
- final_args = Var old_s : unboxed_args
+ the_state_arg
+ | is_io_action = old_s
+ | otherwise = realWorldPrimId
+
+ final_args = Var the_state_arg : unboxed_args
(ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
+
+ is_io_action =
+ case (splitTyConApp_maybe io_res_ty) of
+ Just (iot,[_]) -> (uniqueOf iot) == ioTyConKey
+ _ -> False
in
- boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
+ (if not is_io_action then
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
+ wrapUnboxedValue io_res_ty `thenDs` \ (state_and_foo, state_and_foo_ty, v, res_v) ->
+ let the_alt = (state_and_foo, [state_tok,v], res_v) in
+ returnDs (state_and_foo_ty, \ prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault))
+ else
+ boxResult ioOkDataCon result_ty) `thenDs` \ (final_result_ty, res_wrapper) ->
(case ext_name of
- Dynamic -> getUniqueDs `thenDs` \ u -> returnDs (Right u)
- ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
+ Dynamic -> getUniqueDs `thenDs` \ u ->
+ returnDs (Right u)
+ ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
let
the_ccall_op = CCallOp label False (not may_not_gc) cconv
(map coreExprType final_args)
in
mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
let
- the_body = mkValLam [old_s]
- (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+ body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
+
+ the_body
+ | not is_io_action = body
+ | otherwise = mkValLam [old_s] body
in
newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
let
- io_app = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
+ io_app
+ | is_io_action = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
+ | otherwise = Var ds
+
fo_rhs = mkTyLam tvs $
mkValLam (map (\ (Var x) -> x) args)
(mkCoLetAny (NonRec ds the_body) io_app)