Desugaring foreign calls
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module DsCCall
( dsCCall
, mkFCall
import DsMonad
import CoreUtils
+import MkCore
+import Var
import Id
import MkId
import Maybes
= return (arg, \body -> body)
-- Recursive newtypes
- | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
+ | Just(_rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
= unboxArg (mkCoerce co arg)
-- Booleans
tc `hasKey` boolTyConKey
= do prim_arg <- newSysLocalDs intPrimTy
return (Var prim_arg,
- \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
+ \ body -> Case (mkWildCase arg arg_ty intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)])
-- In increasing tag order!
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
= do case_bndr <- newSysLocalDs arg_ty
- vars@[l_var, r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
+ 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)]
)
, arg
, Lam prim_string body
])
- | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
+ | Just (tc, [_]) <- splitTyConApp_maybe arg_ty,
tyConName tc == objectTyConName
-- Object; dotnet only
= do unpack_id <- dsLookupGlobalId marshalObjectName
mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
- Case (App the_call (Var state_id))
- (mkWildId ccall_res_ty)
+ mkWildCase (App the_call (Var state_id))
+ ccall_res_ty
(coreAltType the_alt)
[the_alt]
]
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
-boxResult augment mbTopCon result_ty
+boxResult augment _mbTopCon result_ty
= 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]
+ wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
+ 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"
+ return_result _ [ans] = ans
+ return_result _ _ = panic "return_result: expected single result"
+mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
+ -> (Maybe Type, Expr Var -> Expr Var)
+ -> DsM (Type, (AltCon, [Id], Expr Var))
mk_alt return_result (Nothing, wrap_result)
= do -- The ccall returns ()
state_id <- newSysLocalDs realWorldStatePrimTy
-- Base case 2: the unit type ()
| Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
- = return (Nothing, \e -> Var unitDataConId)
+ = return (Nothing, \_ -> Var unitDataConId)
-- Base case 3: the boolean type
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= return
- (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+ (Just intPrimTy, \e -> mkWildCase e intPrimTy
boolTy
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
\ e -> App (Var pack_id) e)
-- Objects; 'dotnet' only.
- | Just (tc, [arg_ty]) <- maybe_tc_app,
+ | Just (tc, [_]) <- maybe_tc_app,
tyConName tc == objectTyConName
= do pack_id <- dsLookupGlobalId unmarshalObjectName
return (Just addrPrimTy,