+%************************************************************************
+%* *
+ Foreign calls
+%* *
+%************************************************************************
+
+The interesting thing about @ccall@ is that it is just a template
+which we instantiate by filling in details about the types of its
+argument and result (ie minimal typechecking is performed). So, the
+basic story is that we allocate a load of type variables (to hold the
+arg/result types); unify them with the args/result; and store them for
+later use.
+
+\begin{code}
+tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty
+
+ = getDOpts `thenM` \ dflags ->
+
+ checkTc (not (is_casm && dopt_HscLang dflags /= HscC))
+ (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).",
+ text "Either compile with -fvia-C, or, better, rewrite your code",
+ text "to use the foreign function interface. _casm_s are deprecated",
+ text "and support for them may one day disappear."])
+ `thenM_`
+
+ -- Get the callable and returnable classes.
+ tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
+ tcLookupClass cReturnableClassName `thenM` \ cReturnableClass ->
+ tcLookupTyCon ioTyConName `thenM` \ ioTyCon ->
+ let
+ new_arg_dict (arg, arg_ty)
+ = newDicts (CCallOrigin (unpackFS lbl) (Just arg))
+ [mkClassPred cCallableClass [arg_ty]] `thenM` \ arg_dicts ->
+ returnM arg_dicts -- Actually a singleton bag
+
+ result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -}
+ in
+
+ -- Arguments
+ let tv_idxs | null args = []
+ | otherwise = [1..length args]
+ in
+ newTyVarTys (length tv_idxs) openTypeKind `thenM` \ arg_tys ->
+ tcMonoExprs args arg_tys `thenM` \ args' ->
+
+ -- The argument types can be unlifted or lifted; the result
+ -- type must, however, be lifted since it's an argument to the IO
+ -- type constructor.
+ newTyVarTy liftedTypeKind `thenM` \ result_ty ->
+ let
+ io_result_ty = mkTyConApp ioTyCon [result_ty]
+ in
+ unifyTauTy res_ty io_result_ty `thenM_`
+
+ -- Construct the extra insts, which encode the
+ -- constraints on the argument and result types.
+ mappM new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenM` \ ccarg_dicts_s ->
+ newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenM` \ ccres_dict ->
+ extendLIEs (ccres_dict ++ concat ccarg_dicts_s) `thenM_`
+ returnM (HsCCall lbl args' may_gc is_casm io_result_ty)
+\end{code}
+
+
+%************************************************************************
+%* *
+ Record construction and update
+%* *
+%************************************************************************
+
+\begin{code}