Replace tuple with record in Cextcall (#10)

Author: gretay-js

backend/afl_instrument.ml

@@ -103,7 +103,8 @@ let instrument_initialiser c dbg =
      calls *)
   with_afl_logging
     (Csequence
-       (Cop (Cextcall ("caml_setup_afl", typ_int, false, None),
+       (Cop (Cextcall { name = "caml_setup_afl";
+                        ret = typ_int; alloc = false; label_after = None; },
              [Cconst_int (0, dbg ())],
              dbg ()),
         c))

backend/amd64/selection.ml

@@ -135,7 +135,7 @@ method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
 
 method! is_simple_expr e =
   match e with
-  | Cop(Cextcall (fn, _, _, _), args, _)
+  | Cop(Cextcall { name = fn; }, args, _)
     when List.mem fn inline_ops ->
       (* inlined ops are simple if their arguments are *)
       List.for_all self#is_simple_expr args
@@ -144,7 +144,7 @@ method! is_simple_expr e =
 
 method! effects_of e =
   match e with
-  | Cop(Cextcall(fn, _, _, _), args, _)
+  | Cop(Cextcall { name = fn; }, args, _)
     when List.mem fn inline_ops ->
       Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
   | _ ->
@@ -201,7 +201,7 @@ method! select_operation op args dbg =
       self#select_floatarith true Imulf Ifloatmul args
   | Cdivf ->
       self#select_floatarith false Idivf Ifloatdiv args
-  | Cextcall("sqrt", _, false, _) ->
+  | Cextcall { name = "sqrt"; alloc = false; } ->
      begin match args with
        [Cop(Cload ((Double|Double_u as chunk), _), [loc], _dbg)] ->
          let (addr, arg) = self#select_addressing chunk loc in
@@ -221,12 +221,12 @@ method! select_operation op args dbg =
       | _ ->
           super#select_operation op args dbg
       end
-  | Cextcall("caml_bswap16_direct", _, _, _) ->
+  | Cextcall { name = "caml_bswap16_direct"; } ->
       (Ispecific (Ibswap 16), args)
-  | Cextcall("caml_int32_direct_bswap", _, _, _) ->
+  | Cextcall { name = "caml_int32_direct_bswap"; } ->
       (Ispecific (Ibswap 32), args)
-  | Cextcall("caml_int64_direct_bswap", _, _, _)
-  | Cextcall("caml_nativeint_direct_bswap", _, _, _) ->
+  | Cextcall { name = "caml_int64_direct_bswap"; }
+  | Cextcall { name = "caml_nativeint_direct_bswap"; } ->
       (Ispecific (Ibswap 64), args)
   (* AMD64 does not support immediate operands for multiply high signed *)
   | Cmulhi ->

backend/cmm.ml

@@ -135,9 +135,14 @@ type memory_chunk =
 
 and operation =
     Capply of machtype
-  | Cextcall of string * machtype * bool * label option
-    (** If specified, the given label will be placed immediately after the
-        call (at the same place as any frame descriptor would reference). *)
+  | Cextcall of
+      { name: string;
+        ret: machtype;
+        alloc: bool;
+        label_after: label option;
+        (** If specified, the given label will be placed immediately after the
+            call (at the same place as any frame descriptor would reference). *)
+      }
   | Cload of memory_chunk * Asttypes.mutable_flag
   | Calloc
   | Cstore of memory_chunk * Lambda.initialization_or_assignment

backend/cmm.mli

@@ -129,7 +129,14 @@ type memory_chunk =
 
 and operation =
     Capply of machtype
-  | Cextcall of string * machtype * bool * label option
+  | Cextcall of
+      { name: string;
+        ret: machtype;
+        alloc: bool;
+        label_after: label option;
+        (** If specified, the given label will be placed immediately after the
+            call (at the same place as any frame descriptor would reference). *)
+      }
   | Cload of memory_chunk * Asttypes.mutable_flag
   | Calloc
   | Cstore of memory_chunk * Lambda.initialization_or_assignment

backend/cmm_helpers.ml

@@ -604,8 +604,8 @@ let rec remove_unit = function
       Clet(id, c1, remove_unit c2)
   | Cop(Capply _mty, args, dbg) ->
       Cop(Capply typ_void, args, dbg)
-  | Cop(Cextcall(proc, _mty, alloc, label_after), args, dbg) ->
-      Cop(Cextcall(proc, typ_void, alloc, label_after), args, dbg)
+  | Cop(Cextcall c, args, dbg) ->
+      Cop(Cextcall {c with ret = typ_void}, args, dbg)
   | Cexit (_,_) as c -> c
   | Ctuple [] as c -> c
   | c -> Csequence(c, Ctuple [])
@@ -727,10 +727,12 @@ 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("caml_modify", typ_void, false, None),
+  Cop(Cextcall { name = "caml_modify"; ret = typ_void; alloc = false;
+                 label_after = None},
       [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
 let addr_array_initialize arr ofs newval dbg =
-  Cop(Cextcall("caml_initialize", typ_void, false, None),
+  Cop(Cextcall { name = "caml_initialize";
+                 ret = typ_void; alloc = false; label_after = None},
       [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
 let int_array_set arr ofs newval dbg =
   Cop(Cstore (Word_int, Lambda.Assignment),
@@ -766,7 +768,8 @@ let bigstring_length ba dbg =
 
 let lookup_tag obj tag dbg =
   bind "tag" tag (fun tag ->
-    Cop(Cextcall("caml_get_public_method", typ_val, false, None),
+    Cop(Cextcall { name = "caml_get_public_method"; ret = typ_val;
+                   alloc = false; label_after = None },
         [obj; tag],
         dbg))
 
@@ -796,14 +799,16 @@ 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("caml_alloc", typ_val, true, None),
+         Cop(Cextcall { name = "caml_alloc"; ret = typ_val; alloc = true;
+                        label_after = None },
                  [Cconst_int (wordsize, dbg); Cconst_int (tag, dbg)], dbg),
          fill_fields 1 args)
   end
 
 let make_alloc dbg tag args =
   let addr_array_init arr ofs newval dbg =
-    Cop(Cextcall("caml_initialize", typ_void, false, None),
+    Cop(Cextcall { name = "caml_initialize"; ret = typ_void; alloc = false;
+                   label_after = None },
         [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
   in
   make_alloc_generic addr_array_init dbg tag (List.length args) args
@@ -2141,13 +2146,14 @@ let bbswap bi arg dbg =
     | Pint32 -> "int32"
     | Pint64 -> "int64"
   in
-  Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
-               typ_int, false, None),
+  Cop(Cextcall { name = Printf.sprintf "caml_%s_direct_bswap" prim;
+                 ret = typ_int; alloc = false; label_after = None; },
       [arg],
       dbg)
 
 let bswap16 arg dbg =
-  (Cop(Cextcall("caml_bswap16_direct", typ_int, false, None),
+  (Cop(Cextcall { name = "caml_bswap16_direct";
+                  ret = typ_int; alloc = false; label_after = None; },
        [arg],
        dbg))
 
@@ -2172,12 +2178,16 @@ let assignment_kind
 let setfield n ptr init arg1 arg2 dbg =
   match assignment_kind ptr init with
   | Caml_modify ->
-      return_unit dbg (Cop(Cextcall("caml_modify", typ_void, false, None),
+      return_unit dbg (Cop(Cextcall { name = "caml_modify";
+                                      ret = typ_void; alloc = false;
+                                      label_after = None },
                       [field_address arg1 n dbg;
                        arg2],
                       dbg))
   | Caml_initialize ->
-      return_unit dbg (Cop(Cextcall("caml_initialize", typ_void, false, None),
+      return_unit dbg (Cop(Cextcall { name = "caml_initialize";
+                                      ret = typ_void; alloc = false;
+                                      label_after = None },
                       [field_address arg1 n dbg;
                        arg2],
                       dbg))

backend/cmmgen.ml

@@ -735,7 +735,8 @@ and transl_catch env nfail ids body handler dbg =
 and transl_make_array dbg env kind args =
   match kind with
   | Pgenarray ->
-      Cop(Cextcall("caml_make_array", typ_val, true, None),
+      Cop(Cextcall { name = "caml_make_array";
+                     ret = typ_val; alloc = true; label_after = None},
           [make_alloc dbg 0 (List.map (transl env) args)], dbg)
   | Paddrarray | Pintarray ->
       make_alloc dbg 0 (List.map (transl env) args)
@@ -772,8 +773,10 @@ and transl_ccall env prim args dbg =
   in
   let args = transl_args prim.prim_native_repr_args args in
   wrap_result
-    (Cop(Cextcall(Primitive.native_name prim,
-                  typ_res, prim.prim_alloc, None), args, dbg))
+    (Cop(Cextcall { name = Primitive.native_name prim;
+                    ret = typ_res; alloc = prim.prim_alloc;
+                    label_after = None },
+     args, dbg))
 
 and transl_prim_1 env p arg dbg =
   match p with
@@ -1315,7 +1318,9 @@ and transl_letrec env bindings cont =
       bindings
   in
   let op_alloc prim args =
-    Cop(Cextcall(prim, typ_val, true, None), args, dbg) in
+    Cop(Cextcall { name = prim; ret = typ_val; alloc = true;
+                   label_after = None },
+        args, dbg) in
   let rec init_blocks = function
     | [] -> fill_nonrec bsz
     | (id, _exp, RHS_block sz) :: rem ->
@@ -1341,7 +1346,8 @@ and transl_letrec env bindings cont =
     | [] -> cont
     | (id, exp, (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem ->
         let op =
-          Cop(Cextcall("caml_update_dummy", typ_void, false, None),
+          Cop(Cextcall { name = "caml_update_dummy"; ret = typ_void;
+                         alloc = false; label_after = None },
               [Cvar (VP.var id); transl env exp], dbg) in
         Csequence(op, fill_blocks rem)
     | (_id, _exp, RHS_nonrec) :: rem ->

backend/printcmm.ml

@@ -101,7 +101,7 @@ let location d =
 
 let operation d = function
   | Capply _ty -> "app" ^ location d
-  | Cextcall(lbl, _ty, _alloc, _) ->
+  | Cextcall { name = 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)
@@ -212,7 +212,7 @@ 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(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty
+      | Cextcall { ret=mty } -> fprintf ppf "@ %a" machtype mty
       | _ -> ()
       end;
       fprintf ppf ")@]"

backend/selectgen.ml

@@ -66,7 +66,7 @@ let env_empty = {
 
 let oper_result_type = function
     Capply ty -> ty
-  | Cextcall(_s, ty, _alloc, _) -> ty
+  | Cextcall { ret = ty; } -> ty
   | Cload (c, _) ->
       begin match c with
       | Word_val -> typ_val
@@ -451,7 +451,7 @@ method select_operation op args _dbg =
   | (Capply _, _) ->
     let label_after = Cmm.new_label () in
     (Icall_ind { label_after; }, args)
-  | (Cextcall(func, _ty, alloc, label_after), _) ->
+  | (Cextcall { name = func; alloc; label_after; }, _) ->
     let label_after =
       match label_after with
       | None -> Cmm.new_label ()

backend/spacetime_profiling.ml

@@ -110,8 +110,10 @@ let code_for_function_prologue ~function_name ~fun_dbg:dbg ~node_hole =
           dbg,
           Clet (VP.create is_new_node,
             Clet (VP.create pc, cconst_symbol function_name,
-              Cop (Cextcall ("caml_spacetime_allocate_node",
-                  [| Int |], false, None),
+                  Cop (Cextcall { name = "caml_spacetime_allocate_node";
+                                  ret = [| Int |];
+                                  alloc = false;
+                                  label_after = None},
                 [cconst_int (1 (* header *) + !index_within_node);
                 Cvar pc;
                 Cvar node_hole;
@@ -151,8 +153,9 @@ let code_for_blockheader ~value's_header ~node ~dbg =
        the latter table to be used for resolving a program counter at such
        a point to a location.
     *)
-    Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |],
-        false, Some label),
+    Cop (Cextcall { name = "caml_spacetime_generate_profinfo";
+                    ret = [| Int |];
+                    alloc = false; label_after = Some label },
       [Cvar address_of_profinfo;
        cconst_int (index_within_node + 1)],
       dbg)
@@ -271,8 +274,8 @@ let code_for_call ~node ~callee ~is_tail ~label dbg =
         if is_tail then node
         else cconst_int 1  (* [Val_unit] *)
       in
-      Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr",
-          [| Int |], false, None),
+      Cop (Cextcall { name = "caml_spacetime_indirect_node_hole_ptr";
+                      ret = [| Int |]; alloc = false; label_after = None },
         [callee; Cvar place_within_node; caller_node],
         dbg))
 

ocaml/testsuite/tools/parsecmm.mly

@@ -220,7 +220,9 @@ expr:
   | LPAREN APPLY location expr exprlist machtype RPAREN
                 { Cop(Capply $6, $4 :: List.rev $5, debuginfo ?loc:$3 ()) }
   | LPAREN EXTCALL STRING exprlist machtype RPAREN
-               {Cop(Cextcall($3, $5, false, None), List.rev $4, debuginfo ())}
+               {Cop(Cextcall {name=$3; ret=$5; alloc=false;
+                              label_after=None},
+                     List.rev $4, debuginfo ())}
   | LPAREN ALLOC exprlist RPAREN { Cop(Calloc, List.rev $3, debuginfo ()) }
   | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3], debuginfo ()) }
   | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4], debuginfo ()) }