Add a returns field to Cmm.Cextcall

backend/afl_instrument.ml

@@ -103,11 +103,12 @@ let instrument_initialiser c dbg =
      calls *)
   with_afl_logging
     (Csequence
-       (Cop (Cextcall { name = "caml_setup_afl";
+       (Cop (Cextcall { func = "caml_setup_afl";
                         builtin = false;
+                        returns = true;
                         effects = Arbitrary_effects;
                         coeffects = Has_coeffects;
-                        ret = typ_int; alloc = false; ty_args = []; },
+                        ty = typ_int; alloc = false; ty_args = []; },
              [Cconst_int (0, dbg ())],
              dbg ()),
         c))

backend/amd64/selection.ml

@@ -167,7 +167,7 @@ method is_immediate_test _cmp n = is_immediate n
 
 method! is_simple_expr e =
   match e with
-  | Cop(Cextcall { name = fn; }, args, _)
+  | Cop(Cextcall { func = fn; }, args, _)
     when List.mem fn inline_ops ->
       (* inlined ops are simple if their arguments are *)
       List.for_all self#is_simple_expr args
@@ -176,7 +176,7 @@ method! is_simple_expr e =
 
 method! effects_of e =
   match e with
-  | Cop(Cextcall { name = fn; }, args, _)
+  | Cop(Cextcall { func = fn; }, args, _)
     when List.mem fn inline_ops ->
       Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
   | _ ->
@@ -233,7 +233,7 @@ method! select_operation op args dbg =
       self#select_floatarith true Imulf Ifloatmul args
   | Cdivf ->
       self#select_floatarith false Idivf Ifloatdiv args
-  | Cextcall { name = "sqrt"; alloc = false; } ->
+  | Cextcall { func = "sqrt"; alloc = false; } ->
      begin match args with
        [Cop(Cload ((Double as chunk), _), [loc], _dbg)] ->
          let (addr, arg) = self#select_addressing chunk loc in
@@ -243,8 +243,8 @@ method! select_operation op args dbg =
      | _ ->
          assert false
     end
-  | Cextcall { name; builtin = true; ret; ty_args = _; } ->
-      begin match name, ret with
+  | Cextcall { func; builtin = true; ty = ret; ty_args = _; } ->
+      begin match func, ret with
       | "caml_rdtsc_unboxed", [|Int|] -> Ispecific Irdtsc, args
       | "caml_rdpmc_unboxed", [|Int|] -> Ispecific Irdpmc, args
       | ("caml_int64_crc_unboxed", [|Int|]
@@ -263,12 +263,12 @@ method! select_operation op args dbg =
       | _ ->
           super#select_operation op args dbg
       end
-  | Cextcall { name = "caml_bswap16_direct"; } ->
+  | Cextcall { func = "caml_bswap16_direct"; } ->
       (Ispecific (Ibswap 16), args)
-  | Cextcall { name = "caml_int32_direct_bswap"; } ->
+  | Cextcall { func = "caml_int32_direct_bswap"; } ->
       (Ispecific (Ibswap 32), args)
-  | Cextcall { name = "caml_int64_direct_bswap"; }
-  | Cextcall { name = "caml_nativeint_direct_bswap"; } ->
+  | Cextcall { func = "caml_int64_direct_bswap"; }
+  | Cextcall { func = "caml_nativeint_direct_bswap"; } ->
       (Ispecific (Ibswap 64), args)
   (* Recognize sign extension *)
   | Casr ->

backend/cfg/cfg_intf.ml

@@ -43,6 +43,7 @@ module S = struct
     | External of
         { func_symbol : string;
           alloc : bool;
+          returns : bool;
           ty_res : Cmm.machtype; 
           ty_args : Cmm.exttype list
         }

backend/cfg/cfg_to_linear.ml

@@ -46,8 +46,8 @@ let from_basic (basic : Cfg.basic) : L.instruction_desc =
   | Call (F (Indirect)) -> Lop (Icall_ind)
   | Call (F (Direct { func_symbol; })) ->
       Lop (Icall_imm { func = func_symbol; })
-  | Call (P (External { func_symbol; alloc; ty_args; ty_res; })) ->
-      Lop (Iextcall { func = func_symbol; alloc; ty_args; ty_res; })
+  | Call (P (External { func_symbol; alloc; ty_args; ty_res; returns; })) ->
+      Lop (Iextcall { func = func_symbol; alloc; ty_args; ty_res; returns; })
   | Call
       (P
         (Checkbound { immediate = None; }))

backend/cfg/linear_to_cfg.ml

@@ -400,8 +400,8 @@ let to_basic (mop : Mach.operation) : C.basic =
   | Icall_ind -> Call (F Indirect)
   | Icall_imm { func; } ->
       Call (F (Direct { func_symbol = func; }))
-  | Iextcall { func; alloc; ty_args; ty_res; } ->
-      Call (P (External { func_symbol = func; alloc; ty_args; ty_res }))
+  | Iextcall { func; alloc; ty_args; ty_res; returns; } ->
+      Call (P (External { func_symbol = func; alloc; ty_args; ty_res; returns }))
   | Iintop Icheckbound ->
       Call
         (P

backend/cmm.ml

@@ -167,13 +167,14 @@ type memory_chunk =
 and operation =
     Capply of machtype
   | Cextcall of
-      { name: string;
-        ret: machtype;
+      { func: string;
+        ty: machtype;
+        ty_args : exttype list;
         alloc: bool;
         builtin: bool;
+        returns: bool;
         effects: effects;
         coeffects: coeffects;
-        ty_args : exttype list;
       }
   | Cload of memory_chunk * Asttypes.mutable_flag
   | Calloc

backend/cmm.mli

@@ -166,13 +166,14 @@ type memory_chunk =
 and operation =
     Capply of machtype
   | Cextcall of
-      { name: string;
-        ret: machtype;
+      { func: string;
+        ty: machtype;
+        ty_args : exttype list;
         alloc: bool;
         builtin: bool;
+        returns: bool;
         effects: effects;
         coeffects: coeffects;
-        ty_args : exttype list;
       }
       (** The [machtype] is the machine type of the result.
           The [exttype list] describes the unboxing types of the arguments.

backend/cmm_helpers.ml

@@ -612,7 +612,7 @@ let rec remove_unit = function
   | Cop(Capply _mty, args, dbg) ->
       Cop(Capply typ_void, args, dbg)
   | Cop(Cextcall c, args, dbg) ->
-      Cop(Cextcall {c with ret = typ_void; }, args, dbg)
+      Cop(Cextcall {c with ty = typ_void; }, args, dbg)
   | Cexit (_,_,_) as c -> c
   | Ctuple [] as c -> c
   | c -> Csequence(c, Ctuple [])
@@ -734,18 +734,20 @@ let float_array_ref arr ofs dbg =
   box_float dbg (unboxed_float_array_ref arr ofs dbg)
 
 let addr_array_set arr ofs newval dbg =
-  Cop(Cextcall { name = "caml_modify"; ret = typ_void; alloc = false;
+  Cop(Cextcall { func = "caml_modify"; ty = typ_void; alloc = false;
                  builtin = false;
+                 returns = true;
                  effects = Arbitrary_effects;
                  coeffects = Has_coeffects;
                  ty_args = []},
       [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
 let addr_array_initialize arr ofs newval dbg =
-  Cop(Cextcall { name = "caml_initialize";
+  Cop(Cextcall { func = "caml_initialize";
                  builtin = false;
+                 returns = true;
                  effects = Arbitrary_effects;
                  coeffects = Has_coeffects;
-                 ret = typ_void; alloc = false; ty_args = []},
+                 ty = typ_void; alloc = false; ty_args = []},
       [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
 let int_array_set arr ofs newval dbg =
   Cop(Cstore (Word_int, Lambda.Assignment),
@@ -781,8 +783,9 @@ let bigstring_length ba dbg =
 
 let lookup_tag obj tag dbg =
   bind "tag" tag (fun tag ->
-    Cop(Cextcall { name = "caml_get_public_method"; ret = typ_val;
+    Cop(Cextcall { func = "caml_get_public_method"; ty = typ_val;
                    builtin = false;
+                   returns = true;
                    effects = Arbitrary_effects;
                    coeffects = Has_coeffects;
                    alloc = false; ty_args = [] },
@@ -815,8 +818,9 @@ let make_alloc_generic set_fn dbg tag wordsize args =
     | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg,
                           fill_fields (idx + 2) el) in
     Clet(VP.create id,
-         Cop(Cextcall { name = "caml_alloc"; ret = typ_val; alloc = true;
+         Cop(Cextcall { func = "caml_alloc"; ty = typ_val; alloc = true;
                         builtin = false;
+                        returns = true;
                         effects = Arbitrary_effects;
                         coeffects = Has_coeffects;
                         ty_args = [] },
@@ -826,8 +830,9 @@ let make_alloc_generic set_fn dbg tag wordsize args =
 
 let make_alloc dbg tag args =
   let addr_array_init arr ofs newval dbg =
-    Cop(Cextcall { name = "caml_initialize"; ret = typ_void; alloc = false;
+    Cop(Cextcall { func = "caml_initialize"; ty = typ_void; alloc = false;
                    builtin = false;
+                   returns = true;
                    effects = Arbitrary_effects;
                    coeffects = Has_coeffects;
                    ty_args = [] },
@@ -2177,20 +2182,22 @@ let bbswap bi arg dbg =
     | Pint32 -> "int32", XInt32
     | Pint64 -> "int64", XInt64
   in
-  Cop(Cextcall { name = Printf.sprintf "caml_%s_direct_bswap" prim;
+  Cop(Cextcall { func = Printf.sprintf "caml_%s_direct_bswap" prim;
                  builtin = false;
+                 returns = true;
                  effects = Arbitrary_effects;
                  coeffects = Has_coeffects;
-                 ret = typ_int; alloc = false; ty_args = [tyarg]; },
+                 ty = typ_int; alloc = false; ty_args = [tyarg]; },
       [arg],
       dbg)
 
 let bswap16 arg dbg =
-  (Cop(Cextcall { name = "caml_bswap16_direct";
+  (Cop(Cextcall { func = "caml_bswap16_direct";
                   builtin = false;
+                  returns = true;
                   effects = Arbitrary_effects;
                   coeffects = Has_coeffects;
-                  ret = typ_int; alloc = false; ty_args = []; },
+                  ty = typ_int; alloc = false; ty_args = []; },
        [arg],
        dbg))
 
@@ -2251,19 +2258,21 @@ let assignment_kind
 let setfield n ptr init arg1 arg2 dbg =
   match assignment_kind ptr init with
   | Caml_modify ->
-      return_unit dbg (Cop(Cextcall { name = "caml_modify";
-                                      ret = typ_void; alloc = false;
+      return_unit dbg (Cop(Cextcall { func = "caml_modify";
+                                      ty = typ_void; alloc = false;
                                       builtin = false;
+                                      returns = true;
                                       effects = Arbitrary_effects;
                                       coeffects = Has_coeffects;
                                       ty_args = [] },
                       [field_address arg1 n dbg;
                        arg2],
                       dbg))
   | Caml_initialize ->
-      return_unit dbg (Cop(Cextcall { name = "caml_initialize";
-                                      ret = typ_void; alloc = false;
+      return_unit dbg (Cop(Cextcall { func = "caml_initialize";
+                                      ty = typ_void; alloc = false;
                                       builtin = false;
+                                      returns = true;
                                       effects = Arbitrary_effects;
                                       coeffects = Has_coeffects;
                                       ty_args = [] },
@@ -2723,13 +2732,14 @@ let transl_builtin name args dbg =
   | _ -> None
 
 (* [cextcall] is called from [Cmmgen.transl_ccall] *)
-let cextcall (prim : Primitive.description) args dbg ret ty_args =
+let cextcall (prim : Primitive.description) args dbg ret ty_args returns =
   let name = Primitive.native_name prim in
-  let default = Cop(Cextcall { name; ret;
+  let default = Cop(Cextcall { func = name; ty = ret;
                                builtin = prim.prim_c_builtin;
                                effects = Arbitrary_effects;
                                coeffects = Has_coeffects;
                                alloc = prim.prim_alloc;
+                               returns;
                                ty_args },
                     args, dbg)
   in

backend/cmm_helpers.mli

@@ -579,7 +579,7 @@ val send :
     that corresponds to [prim]. If [prim] is a C builtin supported on the
     target, returns [Cmm.operation] variant for [prim]'s intrinsics. *)
 val cextcall : Primitive.description -> expression list -> Debuginfo.t ->
-  machtype -> exttype list -> expression
+  machtype -> exttype list -> bool -> expression
 
 (** Generic Cmm fragments *)
 

backend/cmmgen.ml

@@ -764,11 +764,12 @@ and transl_catch env nfail ids body handler dbg =
 and transl_make_array dbg env kind args =
   match kind with
   | Pgenarray ->
-      Cop(Cextcall { name = "caml_make_array";
+      Cop(Cextcall { func = "caml_make_array";
                      builtin = false;
+                     returns = true;
                      effects = Arbitrary_effects;
                      coeffects = Has_coeffects;
-                     ret = typ_val; alloc = true; ty_args = []},
+                     ty = typ_val; alloc = true; ty_args = []},
           [make_alloc dbg 0 (List.map (transl env) args)], dbg)
   | Paddrarray | Pintarray ->
       make_alloc dbg 0 (List.map (transl env) args)
@@ -816,7 +817,7 @@ and transl_ccall env prim args dbg =
     | Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
   in
   let typ_args, args = transl_args prim.prim_native_repr_args args in
-  let op = cextcall prim args dbg typ_res typ_args in
+  let op = cextcall prim args dbg typ_res typ_args true in
   wrap_result op
 
 and transl_prim_1 env p arg dbg =
@@ -1359,8 +1360,9 @@ and transl_letrec env bindings cont =
       bindings
   in
   let op_alloc prim args =
-    Cop(Cextcall { name = prim; ret = typ_val; alloc = true;
+    Cop(Cextcall { func = prim; ty = typ_val; alloc = true;
                    builtin = false;
+                   returns = true;
                    effects = Arbitrary_effects;
                    coeffects = Has_coeffects;
                    ty_args = [] },
@@ -1390,8 +1392,9 @@ and transl_letrec env bindings cont =
     | [] -> cont
     | (id, exp, (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem ->
         let op =
-          Cop(Cextcall { name = "caml_update_dummy"; ret = typ_void;
+          Cop(Cextcall { func = "caml_update_dummy"; ty = typ_void;
                          builtin = false;
+                         returns = true;
                          effects = Arbitrary_effects;
                          coeffects = Has_coeffects;
                          alloc = false; ty_args = [] },

backend/linearize.ml

@@ -168,7 +168,8 @@ let linear i n contains_calls =
   let rec linear env i n =
     match i.Mach.desc with
       Iend -> n
-    | Iop(Itailcall_ind | Itailcall_imm _ as op) ->
+    | Iop(Itailcall_ind | Itailcall_imm _ as op)
+    | Iop((Iextcall { returns = false; _ }) as op) ->
         (* note: there cannot be deadcode in n *)
         copy_instr (Lop op) i (linear env i.Mach.next n)
     | Iop(Imove | Ireload | Ispill)

backend/liveness.ml

@@ -73,6 +73,9 @@ let rec live env i finally =
         let across_after = Reg.diff_set_array after i.res in
         let across =
           match op with
+          | Iextcall { returns = false; _ } ->
+              (* extcalls that never return can raise an exception *)
+              env.at_raise
           | Icall_ind | Icall_imm _ | Iextcall _ | Ialloc _
           | Iprobe _
           | Iintop (Icheckbound) | Iintop_imm(Icheckbound, _) ->

backend/mach.ml

@@ -57,7 +57,7 @@ type operation =
   | Itailcall_imm of { func : string; }
   | Iextcall of { func : string;
                   ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
-                  alloc : bool; }
+                  alloc : bool; returns : bool; }
   | Istackoffset of int
   | Iload of Cmm.memory_chunk * Arch.addressing_mode
   | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool

backend/mach.mli

@@ -60,7 +60,7 @@ type operation =
   | Itailcall_imm of { func : string; }
   | Iextcall of { func : string;
                   ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
-                  alloc : bool; }
+                  alloc : bool; returns : bool; }
   | Istackoffset of int
   | Iload of Cmm.memory_chunk * Arch.addressing_mode
   | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool

backend/printcmm.ml

@@ -52,7 +52,12 @@ let extcall_signature ppf (ty_res, ty_args) =
       exttype ppf ty_arg1;
       List.iter (fun ty -> fprintf ppf ",%a" exttype ty) ty_args
   end;
-  fprintf ppf "->%a" machtype ty_res
+  begin match ty_res with
+  | None ->
+      fprintf ppf "->."
+  | Some ty_res ->
+      fprintf ppf "->%a" machtype ty_res
+  end
 
 let integer_comparison = function
   | Ceq -> "=="
@@ -137,7 +142,7 @@ let trywith_kind ppf kind =
 
 let operation d = function
   | Capply _ty -> "app" ^ location d
-  | Cextcall { name = lbl; _ } ->
+  | Cextcall { func = lbl; _ } ->
       Printf.sprintf "extcall \"%s\"%s" lbl (location d)
   | Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
   | Cload (c, Asttypes.Mutable) -> Printf.sprintf "load_mut %s" (chunk c)
@@ -246,8 +251,9 @@ let rec expr ppf = function
       List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
       begin match op with
       | Capply mty -> fprintf ppf "@ %a" machtype mty
-      | Cextcall { ret; ty_args; alloc = _; name = _; } -> 
-        fprintf ppf "@ %a" extcall_signature (ret, ty_args)
+      | Cextcall { ty; ty_args; alloc = _; func = _; returns; } ->
+        let ty = if returns then Some ty else None in
+        fprintf ppf "@ %a" extcall_signature (ty, ty_args)
       | _ -> ()
       end;
       fprintf ppf ")@]"