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),
+       (Cop (Cextcall { name = "caml_setup_afl";
+                        ret = typ_int; alloc = false; ty_args = []; },
              [Cconst_int (0, dbg ())],
              dbg ()),
         c))

backend/amd64/selection.ml

@@ -142,7 +142,7 @@ method is_immediate_test _cmp n = is_immediate n
 
 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
@@ -151,7 +151,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)
   (* Recognize sign extension *)
   | Casr ->

backend/cmm.ml

@@ -150,7 +150,12 @@ type memory_chunk =
 
 and operation =
     Capply of machtype
-  | Cextcall of string * machtype * exttype list * bool
+  | Cextcall of
+      { name : string; 
+        ret : machtype;
+        ty_args : exttype list;
+        alloc : bool;
+      }
   | Cload of memory_chunk * Asttypes.mutable_flag
   | Calloc
   | Cstore of memory_chunk * Lambda.initialization_or_assignment

backend/cmm.mli

@@ -140,10 +140,15 @@ type memory_chunk =
 
 and operation =
     Capply of machtype
-  | Cextcall of string * machtype * exttype list * bool
-      (** The [machtype] is the machine type of the result.
-          The [exttype list] describes the unboxing types of the arguments.
-          An empty list means "all arguments are machine words [XInt]". *)
+  | Cextcall of
+    { name : string;
+      ret : machtype;
+      ty_args : exttype list;
+      alloc : bool;
+    }
+    (** The [machtype] is the machine type of the result.
+        The [exttype list] describes the unboxing types of the arguments.
+        An empty list means "all arguments are machine words [XInt]". *)
   | Cload of memory_chunk * Asttypes.mutable_flag
   | Calloc
   | Cstore of memory_chunk * Lambda.initialization_or_assignment

backend/cmm_helpers.ml

@@ -611,8 +611,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, _ty_res, ty_args, alloc), args, dbg) ->
-      Cop(Cextcall(proc, typ_void, ty_args, alloc), 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 [])
@@ -734,10 +734,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),
+  Cop(Cextcall { name = "caml_modify"; ret = typ_void; alloc = false;
+                 ty_args = []},
       [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),
+  Cop(Cextcall { name = "caml_initialize";
+                 ret = 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),
@@ -773,7 +775,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),
+    Cop(Cextcall { name = "caml_get_public_method"; ret = typ_val;
+                   alloc = false; ty_args = [] },
         [obj; tag],
         dbg))
 
@@ -803,14 +806,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),
+         Cop(Cextcall { name = "caml_alloc"; ret = typ_val; alloc = true;
+                        ty_args = [] },
                  [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),
+    Cop(Cextcall { name = "caml_initialize"; ret = typ_void; alloc = false;
+                   ty_args = [] },
         [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
   in
   make_alloc_generic addr_array_init dbg tag (List.length args) args
@@ -2152,13 +2157,14 @@ let bbswap bi arg dbg =
     | Pint32 -> "int32", XInt32
     | Pint64 -> "int64", XInt64
   in
-  Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
-               typ_int, [tyarg], false),
+  Cop(Cextcall { name = Printf.sprintf "caml_%s_direct_bswap" prim;
+                 ret = typ_int; alloc = false; ty_args = [tyarg]; },
       [arg],
       dbg)
 
 let bswap16 arg dbg =
-  (Cop(Cextcall("caml_bswap16_direct", typ_int, [], false),
+  (Cop(Cextcall { name = "caml_bswap16_direct";
+                  ret = typ_int; alloc = false; ty_args = []; },
        [arg],
        dbg))
 
@@ -2183,15 +2189,19 @@ 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),
-             [field_address arg1 n dbg; arg2],
-             dbg))
+      return_unit dbg (Cop(Cextcall { name = "caml_modify";
+                                      ret = typ_void; alloc = false;
+                                      ty_args = [] },
+                      [field_address arg1 n dbg;
+                       arg2],
+                      dbg))
   | Caml_initialize ->
-      return_unit dbg
-        (Cop(Cextcall("caml_initialize", typ_void, [], false),
-             [field_address arg1 n dbg; arg2],
-             dbg))
+      return_unit dbg (Cop(Cextcall { name = "caml_initialize";
+                                      ret = typ_void; alloc = false;
+                                      ty_args = [] },
+                      [field_address arg1 n dbg;
+                       arg2],
+                      dbg))
   | Simple ->
       return_unit dbg (set_field arg1 n arg2 init dbg)
 

backend/cmmgen.ml

@@ -736,7 +736,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),
+      Cop(Cextcall { name = "caml_make_array";
+                     ret = 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)
@@ -785,8 +786,10 @@ and transl_ccall env prim args dbg =
   in
   let typ_args, args = transl_args prim.prim_native_repr_args args in
   wrap_result
-    (Cop(Cextcall(Primitive.native_name prim,
-                  typ_res, typ_args, prim.prim_alloc), args, dbg))
+    (Cop(Cextcall { name = Primitive.native_name prim;
+                    ret = typ_res; alloc = prim.prim_alloc;
+                    ty_args = typ_args },
+     args, dbg))
 
 and transl_prim_1 env p arg dbg =
   match p with
@@ -1328,7 +1331,9 @@ and transl_letrec env bindings cont =
       bindings
   in
   let op_alloc prim args =
-    Cop(Cextcall(prim, typ_val, [], true), args, dbg) in
+    Cop(Cextcall { name = prim; ret = typ_val; alloc = true;
+                   ty_args = [] },
+        args, dbg) in
   let rec init_blocks = function
     | [] -> fill_nonrec bsz
     | (id, _exp, RHS_block sz) :: rem ->
@@ -1354,7 +1359,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),
+          Cop(Cextcall { name = "caml_update_dummy"; ret = typ_void;
+                         alloc = false; ty_args = [] },
               [Cvar (VP.var id); transl env exp], dbg) in
         Csequence(op, fill_blocks rem)
     | (_id, _exp, RHS_nonrec) :: rem ->

backend/printcmm.ml

@@ -116,7 +116,7 @@ let location d =
 
 let operation d = function
   | Capply _ty -> "app" ^ location d
-  | Cextcall(lbl, _ty_res, _ty_args, _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)
@@ -222,8 +222,8 @@ 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(_, ty_res, ty_args, _) ->
-          fprintf ppf "@ %a" extcall_signature (ty_res, ty_args)
+      | Cextcall { ret; ty_args; alloc = _; name = _; } -> 
+        fprintf ppf "@ %a" extcall_signature (ret, ty_args)
       | _ -> ()
       end;
       fprintf ppf ")@]"

backend/selectgen.ml

@@ -66,7 +66,7 @@ let env_empty = {
 
 let oper_result_type = function
     Capply ty -> ty
-  | Cextcall(_s, ty_res, _ty_args, _alloc) -> ty_res
+  | Cextcall { ret = ty; ty_args = _; alloc = _; name = _; } -> ty
   | Cload (c, _) ->
       begin match c with
       | Word_val -> typ_val
@@ -444,8 +444,8 @@ method select_operation op args _dbg =
     (Icall_imm { func; }, rem)
   | (Capply _, _) ->
     (Icall_ind, args)
-  | (Cextcall(func, ty_res, ty_args, alloc), _) ->
-    Iextcall { func; ty_res; ty_args; alloc; }, args
+  | (Cextcall { name = func; alloc; ret; ty_args }, _) ->
+    Iextcall { func; alloc; ty_res = ret; ty_args }, args
   | (Cload (chunk, _mut), [arg]) ->
       let (addr, eloc) = self#select_addressing chunk arg in
       (Iload(chunk, addr), [eloc])

ocaml/testsuite/tools/parsecmm.mly

@@ -218,8 +218,8 @@ 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),
-                    List.rev $4, debuginfo ())}
+               {Cop(Cextcall {name=$3; ret=$5; alloc=false; ty_args=[];},
+                     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 ()) }