Merge flambda-backend changes

stedolan · stedolan · commit ff4611e77974 · 2021-11-30T16:04:08.000Z
diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml
@@ -63,7 +63,8 @@ let rec combine i allocstate =
           i.arg i.res i.dbg next, allocstate)
       end
   | Iop(Icall_ind | Icall_imm _ | Iextcall _ |
-        Itailcall_ind | Itailcall_imm _ | Iprobe _) ->
+        Itailcall_ind | Itailcall_imm _ | Iprobe _ |
+        Iintop Icheckbound | Iintop_imm (Icheckbound, _)) ->
       let newnext = combine_restart i.next in
       (instr_cons_debug i.desc i.arg i.res i.dbg newnext,
        allocstate)
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
@@ -325,13 +325,14 @@ method is_simple_expr = function
   | Cop(op, args, _) ->
       begin match op with
         (* The following may have side effects *)
-      | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ | Cprobe _
-      | Cprobe_is_enabled _ | Copaque -> false
+      | Capply _ | Cextcall _ | Calloc | Cstore _
+      | Craise _ | Ccheckbound
+      | Cprobe _ | Cprobe_is_enabled _ | Copaque -> false
         (* The remaining operations are simple if their args are *)
       | Cload _ | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor
       | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf
       | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat
-      | Ccmpf _ | Ccheckbound -> List.for_all self#is_simple_expr args
+      | Ccmpf _ -> List.for_all self#is_simple_expr args
       end
   | Cassign _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _
   | Ctrywith _ -> false
diff --git a/driver/main_args.ml b/driver/main_args.ml
@@ -803,10 +803,6 @@ let mk_dcamlprimc f =
   "-dcamlprimc", Arg.Unit f, " (undocumented)"
 ;;
 
-let mk_dcfg f =
-  "-dcfg", Arg.Unit f, " (undocumented)"
-;;
-
 let mk_dcmm_invariants f =
   "-dcmm-invariants", Arg.Unit f, " Extra sanity checks on Cmm"
 ;;
@@ -1121,7 +1117,6 @@ module type Optcommon_options = sig
   val _dflambda_verbose : unit -> unit
   val _drawclambda : unit -> unit
   val _dclambda : unit -> unit
-  val _dcfg : unit -> unit
   val _dcmm_invariants : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
@@ -1496,7 +1491,6 @@ struct
     mk_dflambda_let F._dflambda_let;
     mk_dflambda_verbose F._dflambda_verbose;
 
-    mk_dcfg F._dcfg;
     mk_dcmm F._dcmm;
     mk_dsel F._dsel;
     mk_dcombine F._dcombine;
@@ -1606,7 +1600,6 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_dcmm_invariants F._dcmm_invariants;
     mk_drawflambda F._drawflambda;
     mk_dflambda F._dflambda;
-    mk_dcfg F._dcfg;
     mk_dcmm F._dcmm;
     mk_dsel F._dsel;
     mk_dcombine F._dcombine;
@@ -1787,7 +1780,6 @@ module Default = struct
     let _dalloc = set dump_regalloc
     let _davail () = dump_avail := true
     let _dclambda = set dump_clambda
-    let _dcfg = set dump_cfg
     let _dcmm = set dump_cmm
     let _dcmm_invariants = set cmm_invariants
     let _dcombine = set dump_combine
diff --git a/driver/main_args.mli b/driver/main_args.mli
@@ -205,7 +205,6 @@ module type Optcommon_options = sig
   val _dflambda_verbose : unit -> unit
   val _drawclambda : unit -> unit
   val _dclambda : unit -> unit
-  val _dcfg : unit -> unit
   val _dcmm_invariants : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
diff --git a/parsing/extensions.ml b/parsing/extensions.ml
@@ -43,7 +43,8 @@ let structure_item_of_expr ~loc expr =
     pstr_loc=loc;
   }
 
-let map_comprehension ~loc extension_name body comp_list : extension=
+let map_comprehension ~loc:orig_loc extension_name body comp_list : extension =
+  let loc = { orig_loc with Location.loc_ghost = true } in
   (*This is unreachable and just used as a place holder.*)
   let unreachable =
     {
@@ -86,7 +87,7 @@ let map_comprehension ~loc extension_name body comp_list : extension=
     ) comp_list
   in
   let payload = PStr((structure_item_of_expr ~loc body)::list) in
-  { txt=extension_name; loc; }, payload
+  { txt=extension_name; loc=orig_loc; }, payload
 
 let unwrap_expression ~loc = function
 | Pstr_eval(exp, _) -> exp
@@ -162,7 +163,7 @@ let report_error ~loc = function
   | Extension_not_existent extension_name ->
     Location.errorf ~loc "Extension %s does not exsist." extension_name
   | Illegal_comprehension_extension_construct ->
-    Location.errorf ~loc "Wrong extension sytax for comprehensions."
+    Location.errorf ~loc "Wrong extension syntax for comprehensions."
 
 let () =
   Location.register_error_of_exn
diff --git a/testsuite/tests/basic/combine_checkbound.ml b/testsuite/tests/basic/combine_checkbound.ml
@@ -0,0 +1,36 @@
+(* TEST
+   * native *)
+
+let glob = ref (1, 2)
+let[@inline never] combine1 x a =
+  begin try
+    glob := (2, x);
+    glob := (3, a.(4));
+  with
+  | Invalid_argument _ -> ()
+  end;
+  !glob
+
+let[@inline never] combine2 x a =
+  let loc = ref (1, 2) in
+  begin try
+    loc := (2, x);
+    loc := (3, a.(4));
+  with
+  | Invalid_argument _ -> ()
+  end;
+  !loc
+
+let[@inline never] measure f =
+  let empty_array = [| |] in
+  let prebefore = Gc.minor_words () in
+  let before = Gc.minor_words () in
+  let r = f 42 empty_array in
+  assert (r = (2, 42));
+  let after = Gc.minor_words () in
+  ((after -. before) -. (before -. prebefore))
+
+
+let () =
+  Printf.printf "%10s: %.0f\n" "combine1" (measure combine1);
+  Printf.printf "%10s: %.0f\n" "combine2" (measure combine2)
diff --git a/testsuite/tests/basic/combine_checkbound.reference b/testsuite/tests/basic/combine_checkbound.reference
@@ -0,0 +1,2 @@
+  combine1: 3
+  combine2: 3
diff --git a/utils/clflags.ml b/utils/clflags.ml
@@ -116,7 +116,6 @@ let optimize_for_speed = ref true       (* -compact *)
 and opaque = ref false                  (* -opaque *)
 
 and dump_cmm = ref false                (* -dcmm *)
-let dump_cfg = ref false                (* -dcfg *)
 let dump_selection = ref false          (* -dsel *)
 let dump_cse = ref false                (* -dcse *)
 let dump_live = ref false               (* -dlive *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
@@ -121,7 +121,6 @@ val dump_instr : bool ref
 val keep_camlprimc_file : bool ref
 val keep_asm_file : bool ref
 val optimize_for_speed : bool ref
-val dump_cfg : bool ref
 val dump_cmm : bool ref
 val dump_selection : bool ref
 val dump_cse : bool ref
