Upgrade to OCaml 4.14

backend/cfg/cfg_dataflow.ml

@@ -1,4 +1,4 @@
-[@@@ocaml.warning "+a-4-30-40-41-42"]
+[@@@ocaml.warning "+a-4-30-40-41-42-69"]
 
 open! Int_replace_polymorphic_compare
 module Instr = Numbers.Int

backend/cfg/cfg_regalloc_validate.ml

@@ -9,7 +9,7 @@
     function call are specified as preassigned registers instead of
     reconstructing the argument locations from the function type. *)
 
-[@@@ocaml.warning "+a-4-30-40-41-42"]
+[@@@ocaml.warning "+a-4-30-40-41-42-69"]
 
 include Cfg_intf.S
 

backend/cmm_helpers.ml

@@ -1879,6 +1879,10 @@ module SArgBlocks = struct
 
   let gtint = Ccmpi Cgt
 
+  type arg = expression
+
+  type test = expression
+
   type act = expression
 
   type loc = Debuginfo.t
@@ -1897,6 +1901,10 @@ module SArgBlocks = struct
 
   let make_isin h arg = Cop (Ccmpa Cge, [h; arg], Debuginfo.none)
 
+  let make_is_nonzero arg = arg
+
+  let arg_as_test arg = arg
+
   let make_if value_kind cond ifso ifnot =
     Cifthenelse
       ( cond,
@@ -2837,15 +2845,17 @@ type binary_primitive = expression -> expression -> Debuginfo.t -> expression
 type assignment_kind =
   | Caml_modify
   | Caml_modify_local
+  | Caml_initialize (* never local *)
   | Simple of initialization_or_assignment
 
 let assignment_kind (ptr : Lambda.immediate_or_pointer)
     (init : Lambda.initialization_or_assignment) =
   match init, ptr with
   | Assignment Alloc_heap, Pointer -> Caml_modify
-  | Assignment Alloc_local, Pointer -> Caml_modify_local
-  | Heap_initialization, _ ->
-    Misc.fatal_error "Cmm_helpers: Lambda.Heap_initialization unsupported"
+  | Assignment Alloc_local, Pointer ->
+    assert Config.stack_allocation;
+    Caml_modify_local
+  | Heap_initialization, _ -> Caml_initialize
   | Assignment _, Immediate -> Simple Assignment
   | Root_initialization, (Immediate | Pointer) -> Simple Initialization
 
@@ -2881,6 +2891,21 @@ let setfield n ptr init arg1 arg2 dbg =
              },
            [arg1; Cconst_int (n, dbg); arg2],
            dbg ))
+  | Caml_initialize ->
+    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 = []
+             },
+           [field_address arg1 n dbg; arg2],
+           dbg ))
   | Simple init -> return_unit dbg (set_field arg1 n arg2 init dbg)
 
 let setfloatfield n init arg1 arg2 dbg =
@@ -3083,6 +3108,8 @@ let setfield_computed ptr init arg1 arg2 arg3 dbg =
   | Caml_modify -> return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
   | Caml_modify_local ->
     return_unit dbg (addr_array_set_local arg1 arg2 arg3 dbg)
+  | Caml_initialize ->
+    return_unit dbg (addr_array_initialize arg1 arg2 arg3 dbg)
   | Simple _ -> return_unit dbg (int_array_set arg1 arg2 arg3 dbg)
 
 let bytesset_unsafe arg1 arg2 arg3 dbg =

backend/debug/available_regs.ml

@@ -368,7 +368,7 @@ and join branches ~avail_before =
   None, avail_after
 
 let fundecl (f : M.fundecl) =
-  if !Clflags.debug && !Clflags.debug_runavail
+  if false (* !Clflags.debug && !Clflags.debug_runavail *)
   then (
     assert (Hashtbl.length avail_at_exit = 0);
     avail_at_raise := RAS.Unreachable;

backend/debug/dwarf/dwarf_high/proto_die.ml

@@ -15,7 +15,7 @@
 open Asm_targets
 open Dwarf_low
 
-[@@@ocaml.warning "+a-4-30-40-41-42"]
+[@@@ocaml.warning "+a-4-30-40-41-42-69"]
 
 module ASS = Dwarf_attributes.Attribute_specification.Sealed
 module AV = Dwarf_attribute_values.Attribute_value

backend/printmach.ml

@@ -223,6 +223,7 @@ let rec instr ppf i =
     fprintf ppf "@[<1>{%a" regsetaddr i.live;
     if Array.length i.arg > 0 then fprintf ppf "@ +@ %a" regs i.arg;
     fprintf ppf "}@]@,";
+    (* CR-someday mshinwell: to use for gdb work
     if !Clflags.dump_avail then begin
       let module RAS = Reg_availability_set in
       fprintf ppf "@[<1>AB={%a}" (RAS.print ~print_reg:reg) i.available_before;
@@ -232,7 +233,7 @@ let rec instr ppf i =
         fprintf ppf ",AA={%a}" (RAS.print ~print_reg:reg) available_across
       end;
       fprintf ppf "@]@,"
-    end
+    end *)
   end;
   begin match i.desc with
   | Iend -> ()

backend/x86_binary_emitter.ml

@@ -12,7 +12,7 @@
   * Fabrice LE FESSANT (INRIA/OCamlPro)
 *)
 
-[@@@ocaml.warning "+A-4-9"]
+[@@@ocaml.warning "+A-4-9-69"]
 
 open X86_ast
 open X86_proc
@@ -1677,7 +1677,7 @@ let assemble_section arch section =
   let icount = ref 0 in
   ArrayLabels.iter section.sec_instrs ~f:(function
     | NewLabel (lbl, _) ->
-        String.Tbl.add local_labels lbl !icount 
+        String.Tbl.add local_labels lbl !icount
     | Ins _ -> incr icount
     | _ -> ());
 

driver/optcompile.ml

@@ -126,8 +126,9 @@ let emit unix i =
 
 let implementation unix ~backend ~flambda2 ~start_from ~source_file
     ~output_prefix ~keep_symbol_tables =
-  let backend info typed =
+  let backend info ({ structure; coercion; _ } : Typedtree.implementation) =
     reset_compilenv ~module_name:info.module_name;
+    let typed = structure, coercion in
     if Config.flambda
     then flambda unix info backend typed
     else if Config.flambda2
@@ -139,7 +140,9 @@ let implementation unix ~backend ~flambda2 ~start_from ~source_file
   | Parsing ->
     Compile_common.implementation
       ~hook_parse_tree:(Compiler_hooks.execute Compiler_hooks.Parse_tree_impl)
-      ~hook_typed_tree:(Compiler_hooks.execute Compiler_hooks.Typed_tree_impl)
+      ~hook_typed_tree:(fun (impl : Typedtree.implementation) ->
+        Compiler_hooks.execute Compiler_hooks.Typed_tree_impl
+          (impl.structure, impl.coercion))
       info ~backend
   | Emit -> emit unix info ~ppf_dump:info.ppf_dump
   | _ -> Misc.fatal_errorf "Cannot start from %s"

driver/optmaindriver.ml

@@ -67,7 +67,7 @@ let main unix argv ppf ~flambda2 =
        "<options> Compute dependencies \
         (use 'ocamlopt -depend -help' for details)"];
     Clflags.Opt_flag_handler.set Flambda_backend_flags.opt_flag_handler;
-    Clflags.parse_arguments argv Compenv.anonymous usage;
+    Compenv.parse_arguments (ref argv) Compenv.anonymous "ocamlopt";
     Compmisc.read_clflags_from_env ();
     if !Clflags.plugin then
       Compenv.fatal "-plugin is only supported up to OCaml 4.08.0";

dune

@@ -58,7 +58,7 @@
  ; We should change the code so this "-open" can be removed.
  ; Likewise fix occurrences of warning 9.
  (flags
-  (:standard -principal -w -9))
+  (:standard -principal -w -9-69-70))
  (ocamlopt_flags
   (:include %{project_root}/ocamlopt_flags.sexp))
  (instrumentation
@@ -490,7 +490,8 @@
    compiler-libs/libcompiler_owee_stubs.a)
   (external/owee/libcompiler_owee_stubs.a
    as
-   compiler-libs/libcompiler_owee_stubs_native.a) ; for special_dune compat
+   compiler-libs/libcompiler_owee_stubs_native.a)
+  ; for special_dune compat
   (ocamloptcomp_with_flambda2.cma as compiler-libs/ocamloptcomp.cma)
   (ocamloptcomp_with_flambda2.cmxa as compiler-libs/ocamloptcomp.cmxa)
   (ocamloptcomp_with_flambda2.a as compiler-libs/ocamloptcomp.a))
@@ -1230,19 +1231,18 @@
   (.ocamloptcomp.objs/byte/cfg_regalloc_utils.cmti
    as
    compiler-libs/cfg_regalloc_utils.cmti)
-
   (.ocamloptcomp.objs/byte/cfg_regalloc_validate.cmi
    as
    compiler-libs/cfg_regalloc_validate.cmi)
   (.ocamloptcomp.objs/byte/cfg_regalloc_validate.cmo
    as
    compiler-libs/cfg_regalloc_validate.cmo)
   (.ocamloptcomp.objs/byte/cfg_regalloc_validate.cmt
-    as
-    compiler-libs/cfg_regalloc_validate.cmt)
+   as
+   compiler-libs/cfg_regalloc_validate.cmt)
   (.ocamloptcomp.objs/byte/cfg_regalloc_validate.cmti
-    as
-    compiler-libs/cfg_regalloc_validate.cmti)
+   as
+   compiler-libs/cfg_regalloc_validate.cmti)
   (.ocamloptcomp.objs/byte/cfg_stack_operands.cmi
    as
    compiler-libs/cfg_stack_operands.cmi)
@@ -1540,8 +1540,8 @@
    as
    compiler-libs/cfg_regalloc_utils.cmx)
   (.ocamloptcomp.objs/native/cfg_regalloc_validate.cmx
-    as
-    compiler-libs/cfg_regalloc_validate.cmx)
+   as
+   compiler-libs/cfg_regalloc_validate.cmx)
   (.ocamloptcomp.objs/native/cfg_stack_operands.cmx
    as
    compiler-libs/cfg_stack_operands.cmx)
@@ -2434,10 +2434,18 @@
   (.ocamloptcomp.objs/byte/static_exception.cmti
    as
    compiler-libs/static_exception.cmti)
-  (.ocamloptcomp.objs/byte/symbol_utils.cmi as compiler-libs/symbol_utils.cmi)
-  (.ocamloptcomp.objs/byte/symbol_utils.cmo as compiler-libs/symbol_utils.cmo)
-  (.ocamloptcomp.objs/byte/symbol_utils.cmt as compiler-libs/symbol_utils.cmt)
-  (.ocamloptcomp.objs/byte/symbol_utils.cmti as compiler-libs/symbol_utils.cmti)
+  (.ocamloptcomp.objs/byte/symbol_utils.cmi
+   as
+   compiler-libs/symbol_utils.cmi)
+  (.ocamloptcomp.objs/byte/symbol_utils.cmo
+   as
+   compiler-libs/symbol_utils.cmo)
+  (.ocamloptcomp.objs/byte/symbol_utils.cmt
+   as
+   compiler-libs/symbol_utils.cmt)
+  (.ocamloptcomp.objs/byte/symbol_utils.cmti
+   as
+   compiler-libs/symbol_utils.cmti)
   (.ocamloptcomp.objs/byte/tag.cmi as compiler-libs/tag.cmi)
   (.ocamloptcomp.objs/byte/tag.cmo as compiler-libs/tag.cmo)
   (.ocamloptcomp.objs/byte/tag.cmt as compiler-libs/tag.cmt)
@@ -2687,7 +2695,9 @@
   (.ocamloptcomp.objs/native/static_exception.cmx
    as
    compiler-libs/static_exception.cmx)
-  (.ocamloptcomp.objs/native/symbol_utils.cmx as compiler-libs/symbol_utils.cmx)
+  (.ocamloptcomp.objs/native/symbol_utils.cmx
+   as
+   compiler-libs/symbol_utils.cmx)
   (.ocamloptcomp.objs/native/tag.cmx as compiler-libs/tag.cmx)
   (.ocamloptcomp.objs/native/traverse_for_exported_symbols.cmx
    as

middle_end/closure/closure.ml

@@ -518,13 +518,19 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
       make_const (List.nth l n)
   | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
     when n < List.length ul ->
+      (* This case is particularly useful for removing allocations
+         for optional parameters *)
       (List.nth ul n, field_approx n approx)
   (* Strings *)
   | (Pstringlength | Pbyteslength),
      _,
      [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->
       make_const_int (String.length s)
   (* Kind test *)
+  | Pisint, [ Uprim(P.Pmakeblock _, _, _) ], _ ->
+      (* This case is particularly useful for removing allocations
+         for optional parameters *)
+      make_const_bool false
   | Pisint, _, [a1] ->
       begin match a1 with
       | Value_const(Uconst_int _) -> make_const_bool true
@@ -706,8 +712,6 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam =
             substitute loc st sb rn u2
           else
             substitute loc st sb rn u3
-      | Uprim(P.Pmakeblock _, _, _) ->
-          substitute loc st sb rn u2
       | su1 ->
           Uifthenelse(su1, substitute loc st sb rn u2,
                            substitute loc st sb rn u3, kind)
@@ -792,8 +796,12 @@ let bind_params { backend; mutable_vars; _ } loc fdesc params args funct body =
           let p1' = VP.rename p1 in
           let u1, u2 =
             match VP.name p1, a1 with
-            | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind, mode),
-                             [a], dbg) ->
+            | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind, mode), [a], dbg) ->
+                (* This parameter corresponds to an optional parameter,
+                   and although it is used twice pushing the expression down
+                   actually allows us to remove the allocation as it will
+                   appear once under a Pisint primitive and once under a Pfield
+                   primitive (see [simplif_prim_pure]) *)
                 a, Uprim(P.Pmakeblock(0, Immutable, kind, mode),
                          [Uvar (VP.var p1')], dbg)
             | _ ->
@@ -820,9 +828,6 @@ let bind_params { backend; mutable_vars; _ } loc fdesc params args funct body =
   in
   aux V.Map.empty params args body
 
-(* Check if a lambda term is ``pure'',
-   that is without side-effects *and* not containing function definitions *)
-
 let warning_if_forced_inlined ~loc ~attribute warning =
   if attribute = Always_inlined then
     Location.prerr_warning (Debuginfo.Scoped_location.to_location loc)
@@ -1057,11 +1062,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
         if is_local_mode clos_mode then assert (is_local_mode new_clos_mode);
         let ret_mode = if fundesc.fun_region then alloc_heap else alloc_local in
         let (new_fun, approx) = close { backend; fenv; cenv; mutable_vars }
-          (Lfunction{
-               kind;
-               return = Pgenval;
-               params = List.map (fun v -> v, Pgenval) final_args;
-               body = Lapply{
+          (lfunction
+               ~kind
+               ~return:Pgenval
+               ~params:(List.map (fun v -> v, Pgenval) final_args)
+               ~body:(Lapply{
                  ap_loc=loc;
                  ap_func=(Lvar funct_var);
                  ap_args=internal_args;
@@ -1071,11 +1076,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
                  ap_inlined=Default_inlined;
                  ap_specialised=Default_specialise;
                  ap_probe=None;
-               };
-               loc;
-               mode = new_clos_mode;
-               region = fundesc.fun_region;
-               attr = default_function_attribute})
+               })
+               ~loc
+               ~mode:new_clos_mode
+               ~region:fundesc.fun_region
+               ~attr:default_function_attribute)
         in
         let new_fun =
           iter first_args
@@ -1208,23 +1213,9 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
   | Lprim(Pignore, [arg], _loc) ->
       let expr, approx = make_const_int 0 in
       Usequence(fst (close env arg), expr), approx
-  | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string | Pobj_magic),
+  | Lprim(( Pbytes_to_string | Pbytes_of_string | Pobj_magic),
           [arg], _loc) ->
       close env arg
-  | Lprim(Pdirapply pos,[funct;arg], loc)
-  | Lprim(Prevapply pos,[arg;funct], loc) ->
-      close env
-        (Lapply{
-           ap_loc=loc;
-           ap_func=funct;
-           ap_args=[arg];
-           ap_region_close=pos;
-           ap_mode=alloc_heap;
-           ap_tailcall=Default_tailcall;
-           ap_inlined=Default_inlined;
-           ap_specialised=Default_specialise;
-           ap_probe=None;
-         })
   | Lprim(Pgetglobal cu, [], loc) ->
       let id = Compilation_unit.to_global_ident_for_legacy_code cu in
       let dbg = Debuginfo.from_location loc in
@@ -1402,9 +1393,8 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
   let uncurried_defs =
     List.map
       (function
-          (id, Lfunction({kind; params; return; body; attr; loc; mode; region}
-                         as funct)) ->
-            Lambda.check_lfunction funct;
+          (id, Lfunction(
+              {kind; params; return; body; attr; loc; mode; region})) ->
             let attrib = attr.check in
             let label =
               Symbol_utils.for_fun_ident ~compilation_unit:None loc id

middle_end/convert_primitives.ml

@@ -159,9 +159,6 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   | Pbytes_of_string
   | Pctconst _
   | Pignore
-  | Prevapply _
-  | Pdirapply _
-  | Pidentity
   | Pgetglobal _
   | Psetglobal _
   | Pgetpredef _