-
-\end{code}
-
-%*
-%
-\subsection{Helper functions}
-%
-%*
-
-@boxArg@ boxes up an argument in preparation for calling
-a function that maybe expects a boxed version of it, i.e.,
-
-\begin{verbatim}
-boxArg Addr a# ==> let ds_foo :: Addr ; ds_foo = A# a# in f ...ds_foo..
-\end{verbatim}
-
-\begin{code}
-boxArg :: Type -- Expected type after possible boxing of arg.
- -> Id -- The (unboxed) argument
- -> DsM (Id, -- To pass as the actual, boxed argument
- CoreExpr -> CoreExpr -- Wrapper to box the arg
- )
-boxArg box_ty prim_arg
- | isUnpointedType box_ty = returnDs (prim_arg, \body -> body)
- -- Data types with a single constructor,
- -- which has a single, primitive-typed arg
- | otherwise
- = newSysLocalDs box_ty `thenDs` \ box_arg ->
- returnDs ( box_arg
- , Let (NonRec box_arg (mkCon box_data_con tys_applied [VarArg prim_arg]))
- )
- where
- maybe_boxed_prim_arg_ty = maybeBoxedPrimType box_ty
- (Just (_,tys_applied,_)) = splitAlgTyConApp_maybe box_ty
- (Just (box_data_con, _)) = maybe_boxed_prim_arg_ty
-\end{code}
-
-@foreign export@ed functions may return a value back to the outside world.
-@unboxResult@ takes care of converting from the (boxed) value that the
-exported action returns to the (unboxed) value that is returned across
-the border.
-
-\begin{code}
-unboxResult :: Maybe Type -- the (unboxed) type we want to return (along with the state token)
- -- Nothing => no result, just the state token.
- -> Type -- the (boxed) type we have in our hand.
- -> Id -- the state token
- -> Id -- boxed arg
- -> DsM (Type, -- type of returned expression.
- CoreExpr) -- expr that unboxes result and returns state+unboxed result.
-
-unboxResult mb_res_uboxed_ty res_ty new_s v_boxed
- | not (maybeToBool mb_res_uboxed_ty)
- = -- no result, just return state token
- mkConDs stateDataCon [ TyArg realWorldTy
- , VarArg (Var new_s)] `thenDs` \ the_st ->
- returnDs (realWorldStateTy, the_st)
-
- | null data_cons
- -- oops! can't see the data constructors
- = can'tSeeDataConsPanic "result" res_ty
-
- | (maybeToBool maybe_data_type) && -- Data type
- (null other_data_cons) && -- - with one constructor,
- isUnpointedType res_uboxed_ty -- - and of primitive type.
- -- (Glasgow extension)
- =
- newSysLocalDs res_uboxed_ty `thenDs` \ v_unboxed ->
- mkConDs state_and_prim_datacon
- ((TyArg realWorldTy):map (TyArg ) tycon_arg_tys ++
- [ VarArg (Var new_s)
- , VarArg (Var v_unboxed)]) `thenDs` \ the_result ->
- let
- the_alt = (the_data_con, [v_unboxed], the_result)
- in
- returnDs (state_and_prim_ty,
- Case (Var v_boxed) (AlgAlts [the_alt] NoDefault))
-
- | otherwise
- = pprPanic "unboxResult: " (ppr res_ty)
- where
- (Just res_uboxed_ty) = mb_res_uboxed_ty
-
- maybe_data_type = splitAlgTyConApp_maybe res_ty
- Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
- (the_data_con : other_data_cons) = data_cons
-
- (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo res_uboxed_ty
-
-\end{code}
-
-Returned the unboxed type of a (primitive) type:
-
-\begin{code}
-unboxTy :: Type -> Type
-unboxTy ty
- | isUnpointedType ty || (ty == unitTy) = ty
- | otherwise =
- ASSERT( isFFIArgumentTy ty ) -- legal arg types subsume result types.
- case splitTyConApp_maybe ty of
- Just (tyc,ts) ->
- case (tyConDataCons tyc) of
- [dc] -> case (dataConArgTys dc ts) of
- [ubox] -> ubox
- -- HACK: for the array types, the prim type is
- -- the second tycon arg.
- [_,ubox] -> ubox
- _ -> pprPanic "unboxTy: " (ppr ty)
- _ -> pprPanic "unboxTy: " (ppr ty)
- _ -> pprPanic "unboxTy: " (ppr ty)
-