Skip to content
GitLab
Commit b601e528 authored by twanvl's avatar twanvl
Browse files

Monadify deSugar/DsCCall: use do, return, applicative, standard monad functions

parent 682cf829
Hide whitespace changes
Inline Side-by-side
compiler/deSugar/DsCCall.lhs
View file @ b601e528
......@@ -98,15 +98,14 @@ dsCCall :: CLabelString -- C routine to invoke
-> DsM CoreExpr -- Result, of type ???
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) ->
newUnique `thenDs` \ uniq ->
let
target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
in
returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
= do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
(ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty
uniq <- newUnique
let
target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
mkFCall :: Unique -> ForeignCall
-> [CoreExpr] -- Args
......@@ -143,7 +142,7 @@ unboxArg :: CoreExpr -- The supplied argument
unboxArg arg
-- Primtive types: nothing to unbox
| isPrimitiveType arg_ty
= returnDs (arg, \body -> body)
= return (arg, \body -> body)
-- Recursive newtypes
| Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
......@@ -152,26 +151,26 @@ unboxArg arg
-- Booleans
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
tc `hasKey` boolTyConKey
= newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
returnDs (Var prim_arg,
\ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
-- In increasing tag order!
= do prim_arg <- newSysLocalDs intPrimTy
return (Var prim_arg,
\ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
-- In increasing tag order!
prim_arg
(exprType body)
[(DEFAULT,[],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, 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 (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
-- Typechecker ensures this
do case_bndr <- newSysLocalDs arg_ty
prim_arg <- newSysLocalDs data_con_arg_ty1
return (Var prim_arg,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
-- Byte-arrays, both mutable and otherwise; hack warning
-- We're looking for values of type ByteArray, MutableByteArray
......@@ -182,12 +181,11 @@ unboxArg arg
maybeToBool maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
= 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 (exprType body) [(DataAlt data_con,vars,body)]
)
= do case_bndr <- newSysLocalDs arg_ty
vars@[l_var, r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
return (Var arr_cts_var,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
)
----- Cases for .NET; almost certainly bit-rotted ---------
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
......@@ -195,40 +193,40 @@ unboxArg arg
Just (cc,[]) <- splitTyConApp_maybe arg_ty,
cc == charTyCon
-- String; dotnet only
= dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
newSysLocalDs addrPrimTy `thenDs` \ prim_string ->
returnDs (Var prim_string,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_string body
])
= do unpack_id <- dsLookupGlobalId marshalStringName
prim_string <- newSysLocalDs addrPrimTy
return (Var prim_string,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_string body
])
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tyConName tc == objectTyConName
-- Object; dotnet only
= dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
newSysLocalDs addrPrimTy `thenDs` \ prim_obj ->
returnDs (Var prim_obj,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_obj body
])
= do unpack_id <- dsLookupGlobalId marshalObjectName
prim_obj <- newSysLocalDs addrPrimTy
return (Var prim_obj,
\ body ->
let
io_ty = exprType body
Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
in
mkApps (Var unpack_id)
[ Type io_arg
, arg
, Lam prim_obj body
])
--------------- End of cases for .NET --------------------
| otherwise
= getSrcSpanDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
= do l <- getSrcSpanDs
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
maybe_product_type = splitProductType_maybe arg_ty
......@@ -306,127 +304,122 @@ boxResult augment mbTopCon result_ty
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
boxResult augment mbTopCon result_ty
= -- It isn't IO, so do unsafePerformIO
-- It's not conveniently available, so we inline it
resultWrapper result_ty `thenDs` \ res ->
mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
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)
= do -- It isn't IO, so do unsafePerformIO
-- It's not conveniently available, so we inline it
res <- resultWrapper result_ty
(ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
(coreAltType the_alt)
[the_alt]
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
return_result state [ans] = ans
return_result _ _ = panic "return_result: expected single result"
mk_alt return_result (Nothing, wrap_result)
= -- The ccall returns ()
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
[wrap_result (panic "boxResult")]
= do -- The ccall returns ()
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
[wrap_result (panic "boxResult")]
ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
in
returnDs (ccall_res_ty, the_alt)
ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
return (ccall_res_ty, the_alt)
mk_alt return_result (Just prim_res_ty, wrap_result)
-- The ccall returns a non-() value
| isUnboxedTupleType prim_res_ty
= let
Just (_, ls) = splitTyConApp_maybe prim_res_ty
arity = 1 + length ls
in
mappM newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
| isUnboxedTupleType prim_res_ty= do
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id) : map Var as)
ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
(realWorldStatePrimTy : ls)
the_alt = ( DataAlt (tupleCon Unboxed arity)
, (state_id : args_ids)
, the_rhs
)
in
returnDs (ccall_res_ty, the_alt)
| otherwise
= newSysLocalDs prim_res_ty `thenDs` \ result_id ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
Just (_, ls) = splitTyConApp_maybe prim_res_ty
arity = 1 + length ls
args_ids@(result_id:as) <- mapM newSysLocalDs ls
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id) : map Var as)
ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
(realWorldStatePrimTy : ls)
the_alt = ( DataAlt (tupleCon Unboxed arity)
, (state_id : args_ids)
, the_rhs
)
return (ccall_res_ty, the_alt)
| otherwise = do
result_id <- newSysLocalDs prim_res_ty
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
[wrap_result (Var result_id)]
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)
the_rhs = return_result (Var state_id)
[wrap_result (Var result_id)]
ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
return (ccall_res_ty, the_alt)
resultWrapper :: Type
-> DsM (Maybe Type, -- Type of the expected result, if any
CoreExpr -> CoreExpr) -- Wrapper for the result
-> DsM (Maybe Type, -- Type of the expected result, if any
CoreExpr -> CoreExpr) -- Wrapper for the result
-- resultWrapper deals with the result *value*
-- E.g. foreign import foo :: Int -> IO T
-- Then resultWrapper deals with marshalling the 'T' part
resultWrapper result_ty
-- Base case 1: primitive types
| isPrimitiveType result_ty
= returnDs (Just result_ty, \e -> e)
= return (Just result_ty, \e -> e)
-- Base case 2: the unit type ()
| Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
= returnDs (Nothing, \e -> Var unitDataConId)
= return (Nothing, \e -> Var unitDataConId)
-- Base case 3: the boolean type
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= returnDs
= return
(Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
boolTy
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Recursive newtypes
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
= resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
returnDs (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
= do (maybe_ty, wrapper) <- resultWrapper rep_ty
return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
| Just (tyvar, rest) <- splitForAllTy_maybe result_ty
= resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
= do (maybe_ty, wrapper) <- resultWrapper rest
return (maybe_ty, \e -> Lam tyvar (wrapper e))
-- Data types with a single constructor, which has a single arg
-- This includes types like Ptr and ForeignPtr
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
dataConSourceArity data_con == 1
= let
(unwrapped_res_ty : _) = data_con_arg_tys
narrow_wrapper = maybeNarrow tycon
in
resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
returnDs
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
= do let
(unwrapped_res_ty : _) = data_con_arg_tys
narrow_wrapper = maybeNarrow tycon
(maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
return
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
-- Strings; 'dotnet' only.
| Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon
= dsLookupGlobalId unmarshalStringName `thenDs` \ pack_id ->
returnDs (Just addrPrimTy,
\ e -> App (Var pack_id) e)
= do pack_id <- dsLookupGlobalId unmarshalStringName
return (Just addrPrimTy,
\ e -> App (Var pack_id) e)
-- Objects; 'dotnet' only.
| Just (tc, [arg_ty]) <- maybe_tc_app,
tyConName tc == objectTyConName
= dsLookupGlobalId unmarshalObjectName `thenDs` \ pack_id ->
returnDs (Just addrPrimTy,
\ e -> App (Var pack_id) e)
= do pack_id <- dsLookupGlobalId unmarshalObjectName
return (Just addrPrimTy,
\ e -> App (Var pack_id) e)
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment