Merge flambda-backend changes

This has been committed with conflicts:
	both modified:   asmcomp/cmmgen.ml
	both modified:   bytecomp/bytegen.ml
	deleted by us:   compilerlibs/Makefile.compilerlibs
	both modified:   dune
	both modified:   lambda/lambda.ml
	both modified:   lambda/lambda.mli
	both modified:   lambda/translprim.ml
	both modified:   ocamltest/dune
	both modified:   ocamltest/main.ml
	both modified:   otherlibs/systhreads/st_stubs.c
	both modified:   stdlib/stdlib.ml
	both modified:   stdlib/stdlib.mli
	both modified:   testsuite/tests/basic/patmatch_for_multiple.ml
	both modified:   testsuite/tests/lazy/minor_major_force.ml
	both modified:   testsuite/tests/lf_skiplist/test.ml
	both modified:   testsuite/tests/lib-runtime-events/test_caml.ml
	both modified:   testsuite/tests/shape-index/index_aliases.reference
	both modified:   testsuite/tests/statmemprof/callstacks.ml
	both modified:   testsuite/tests/typing-immediate/immediate.ml
	both modified:   tools/objinfo.ml
	both modified:   typing/env.ml
	both modified:   typing/env.mli
	both modified:   typing/oprint.ml
	both modified:   typing/persistent_env.ml
	both modified:   typing/typedtree.mli
	both modified:   typing/typemod.ml

Author: mshinwell

Makefile.common-jst

@@ -60,7 +60,8 @@ boot_targets = \
   $(boot_ocamlopt) \
   $(boot_ocamlmklib) \
   $(boot_ocamldep) \
-  $(boot_ocamlobjinfo)
+  $(boot_ocamlobjinfo) \
+  ocaml/ocamltest/ocamltest.byte
 
 boot-compiler: _build/_bootinstall
 	RUNTIME_DIR=$(RUNTIME_DIR) $(dune) build $(ws_boot) $(coverage_dune_flags) $(boot_targets)

asmcomp/cmmgen.ml

@@ -1097,11 +1097,19 @@ and transl_prim_1 env p arg dbg =
       box_int dbg Pnativeint m (get_header (transl env arg) dbg)
   | Pperform ->
 <<<<<<< HEAD
+<<<<<<< HEAD
+      Misc.fatal_error "Effects-related primitives not yet supported"
+      (* CR mshinwell: use [Runtimetags] once available
+||||||| 2572783060
       Misc.fatal_error "Effects-related primitives not yet supported"
       (* CR mshinwell: use [Runtimetags] once available
+=======
+>>>>>>> ocaml-jst/flambda-patches
       let cont =
-        make_alloc dbg cont_tag [int_const dbg 0] ~mode:Lambda.alloc_heap
+        make_alloc dbg Runtimetags.cont_tag [int_const dbg 0]
+          ~mode:Lambda.alloc_heap
       in
+<<<<<<< HEAD
       (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
          to be in production by then *)
       Cop(Capply (typ_val, Rc_normal),
@@ -1114,9 +1122,17 @@ and transl_prim_1 env p arg dbg =
       in
       Cop(Capply typ_val,
 >>>>>>> 5.2.0
+||||||| 2572783060
+      (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
+         to be in production by then *)
+      Cop(Capply (typ_val, Rc_normal),
+=======
+      (* Rc_normal means "allow tailcalls".  Preventing them here by using
+         Rc_nontail improves backtraces of paused fibers. *)
+      Cop(Capply (typ_val, Rc_nontail),
+>>>>>>> ocaml-jst/flambda-patches
        [Cconst_symbol ("caml_perform", dbg); transl env arg; cont],
        dbg)
-      *)
   | Pdls_get ->
       Cop(Cdls_get, [transl env arg], dbg)
   | Patomic_load {immediate_or_pointer = Immediate} ->
@@ -1416,14 +1432,14 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
   (* Effects *)
 <<<<<<< HEAD
   | Presume ->
-      Misc.fatal_error "Effects-related primitives not yet supported"
-      (*
-      (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
-         to be in production by then *)
+      (* Rc_normal is required here, because there are some usages of effects
+         with repeated resumes, and these should consume O(1) stack space by
+         tail-calling caml_resume. *)
       Cop (Capply (typ_val, Rc_normal),
            [Cconst_symbol ("caml_resume", dbg);
            transl env arg1; transl env arg2; transl env arg3],
            dbg)
+<<<<<<< HEAD
       *)
 ||||||| 121bedcfd2
   | Presume ->
@@ -1435,26 +1451,25 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
 =======
 
 >>>>>>> 5.2.0
+||||||| 2572783060
+      *)
+=======
+>>>>>>> ocaml-jst/flambda-patches
   | Prunstack ->
-      Misc.fatal_error "Effects-related primitives not yet supported"
-      (*
-      (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
-         to be in production by then *)
-      Cop (Capply (typ_val, Rc_normal),
+      (* Rc_normal is fine here but unlikely to ever be a tail call (usages
+         of this primitive shouldn't be generated in tail position), so
+         we use Rc_nontail for clarity. *)
+      Cop (Capply (typ_val, Rc_nontail),
            [Cconst_symbol ("caml_runstack", dbg);
            transl env arg1; transl env arg2; transl env arg3],
            dbg)
-      *)
   | Preperform ->
-      Misc.fatal_error "Effects-related primitives not yet supported"
-      (*
-      (* CR mshinwell: Rc_normal may be wrong, but this code is unlikely
-         to be in production by then *)
+      (* Rc_normal is required here, this is used in tail position and should
+         tail call. *)
       Cop (Capply (typ_val, Rc_normal),
            [Cconst_symbol ("caml_reperform", dbg);
            transl env arg1; transl env arg2; transl env arg3],
            dbg)
-      *)
 
   | Pperform | Pdls_get | Presume
   | Patomic_exchange | Patomic_fetch_add | Patomic_load _

bytecomp/bytegen.ml

@@ -173,22 +173,29 @@ let preserve_tailcall_for_prim = function
   | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
   | Pasrbint _ | Pbintcomp _ | Punboxed_int_comp _
   | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _
-  | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _ | Pstring_load_128 _
-  | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_load_128 _
-  | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _
-  | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _
-  | Pbigstring_load_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _
+  | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_f32 _
+  | Pstring_load_64 _ | Pstring_load_128 _
+  | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_f32 _
+  | Pbytes_load_64 _ | Pbytes_load_128 _
+  | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_f32 _
+  | Pbytes_set_64 _ | Pbytes_set_128 _
+  | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_f32 _
+  | Pbigstring_load_64 _ | Pbigstring_load_128 _
+  | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_f32 _
   | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ | Pint_array_load_128 _
-  | Punboxed_float_array_load_128 _ | Punboxed_int32_array_load_128 _
-  | Punboxed_int64_array_load_128 _ | Punboxed_nativeint_array_load_128 _
+  | Punboxed_float_array_load_128 _ | Punboxed_float32_array_load_128 _
+  | Punboxed_int32_array_load_128 _ | Punboxed_int64_array_load_128 _
+  | Punboxed_nativeint_array_load_128 _
   | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ | Pint_array_set_128 _
-  | Punboxed_float_array_set_128 _ | Punboxed_int32_array_set_128 _
-  | Punboxed_int64_array_set_128 _ | Punboxed_nativeint_array_set_128 _
+  | Punboxed_float_array_set_128 _ | Punboxed_float32_array_set_128 _
+  | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _
+  | Punboxed_nativeint_array_set_128 _
   | Pbigstring_set_64 _ | Pbigstring_set_128 _
   | Pprobe_is_enabled _ | Pobj_dup
   | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _
   | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
-  | Pdls_get ->
+  | Pdls_get | Preinterpret_tagged_int63_as_unboxed_int64
+  | Preinterpret_unboxed_int64_as_tagged_int63 ->
       false
 
 (* Add a Kpop N instruction in front of a continuation *)
@@ -471,12 +478,15 @@ let comp_primitive stack_info p sz args =
   | Pbytessetu -> Ksetbyteschar
   | Pstring_load_16(_) -> Kccall("caml_string_get16", 2)
   | Pstring_load_32(_) -> Kccall("caml_string_get32", 2)
+  | Pstring_load_f32(_) -> Kccall("caml_string_getf32", 2)
   | Pstring_load_64(_) -> Kccall("caml_string_get64", 2)
   | Pbytes_set_16(_) -> Kccall("caml_bytes_set16", 3)
   | Pbytes_set_32(_) -> Kccall("caml_bytes_set32", 3)
+  | Pbytes_set_f32(_) -> Kccall("caml_bytes_setf32", 3)
   | Pbytes_set_64(_) -> Kccall("caml_bytes_set64", 3)
   | Pbytes_load_16(_) -> Kccall("caml_bytes_get16", 2)
   | Pbytes_load_32(_) -> Kccall("caml_bytes_get32", 2)
+  | Pbytes_load_f32(_) -> Kccall("caml_bytes_getf32", 2)
   | Pbytes_load_64(_) -> Kccall("caml_bytes_get64", 2)
   | Parraylength _ -> Kvectlength
   (* In bytecode, nothing is ever actually stack-allocated, so we ignore the
@@ -566,14 +576,18 @@ let comp_primitive stack_info p sz args =
   | Pbintcomp(_, Cgt) | Punboxed_int_comp(_, Cgt) -> Kccall("caml_greaterthan", 2)
   | Pbintcomp(_, Cle) | Punboxed_int_comp(_, Cle) -> Kccall("caml_lessequal", 2)
   | Pbintcomp(_, Cge) | Punboxed_int_comp(_, Cge) -> Kccall("caml_greaterequal", 2)
+  | Pbigarrayref(_, n, Pbigarray_float32_t, _) -> Kccall("caml_ba_float32_get_" ^ Int.to_string n, n + 1)
+  | Pbigarrayset(_, n, Pbigarray_float32_t, _) -> Kccall("caml_ba_float32_set_" ^ Int.to_string n, n + 2)
   | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ Int.to_string n, n + 1)
   | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ Int.to_string n, n + 2)
   | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ Int.to_string n, 1)
   | Pbigstring_load_16(_) -> Kccall("caml_ba_uint8_get16", 2)
   | Pbigstring_load_32(_) -> Kccall("caml_ba_uint8_get32", 2)
+  | Pbigstring_load_f32(_) -> Kccall("caml_ba_uint8_getf32", 2)
   | Pbigstring_load_64(_) -> Kccall("caml_ba_uint8_get64", 2)
   | Pbigstring_set_16(_) -> Kccall("caml_ba_uint8_set16", 3)
   | Pbigstring_set_32(_) -> Kccall("caml_ba_uint8_set32", 3)
+  | Pbigstring_set_f32(_) -> Kccall("caml_ba_uint8_setf32", 3)
   | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3)
   | Pbswap16 -> Kccall("caml_bswap16", 1)
   | Pbbswap(bi,_) -> comp_bint_primitive bi "bswap" args
@@ -592,12 +606,28 @@ let comp_primitive stack_info p sz args =
   | Pstring_load_128 _ | Pbytes_load_128 _ | Pbytes_set_128 _
   | Pbigstring_load_128 _ | Pbigstring_set_128 _
   | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ | Pint_array_load_128 _
-  | Punboxed_float_array_load_128 _ | Punboxed_int32_array_load_128 _
-  | Punboxed_int64_array_load_128 _ | Punboxed_nativeint_array_load_128 _
+  | Punboxed_float_array_load_128 _ | Punboxed_float32_array_load_128 _
+  | Punboxed_int32_array_load_128 _ | Punboxed_int64_array_load_128 _
+  | Punboxed_nativeint_array_load_128 _
   | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ | Pint_array_set_128 _
-  | Punboxed_float_array_set_128 _ | Punboxed_int32_array_set_128 _
-  | Punboxed_int64_array_set_128 _ | Punboxed_nativeint_array_set_128 _ ->
+  | Punboxed_float_array_set_128 _ | Punboxed_float32_array_set_128 _
+  | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _
+  | Punboxed_nativeint_array_set_128 _ ->
     fatal_error "128-bit load/store is not supported in bytecode mode."
+  | Preinterpret_tagged_int63_as_unboxed_int64 ->
+    if not (Target_system.is_64_bit ())
+    then
+      Misc.fatal_error
+        "Preinterpret_tagged_int63_as_unboxed_int64 can only be used on 64-bit \
+         targets";
+    Kccall("caml_reinterpret_tagged_int63_as_unboxed_int64", 1)
+  | Preinterpret_unboxed_int64_as_tagged_int63 ->
+    if not (Target_system.is_64_bit ())
+    then
+      Misc.fatal_error
+        "Preinterpret_unboxed_int64_as_tagged_int63 can only be used on 64-bit \
+         targets";
+    Kccall("caml_reinterpret_unboxed_int64_as_tagged_int63", 1)
   (* The cases below are handled in [comp_expr] before the [comp_primitive] call
      (in the order in which they appear below),
      so they should never be reached in this function. *)
@@ -1265,4 +1295,19 @@ let compile_implementation modulename expr =
   fst (compile_gen ~modulename ~init_stack:0 expr)
 
 let compile_phrase expr =
+<<<<<<< HEAD
   compile_gen ~init_stack:1 expr
+||||||| 2572783060
+  reset ();
+  Fun.protect ~finally:reset (fun () ->
+  let init_code = comp_block empty_env expr 1 [Kreturn 1] in
+  let fun_code = comp_remainder [] in
+  (init_code, fun_code))
+=======
+  reset ();
+  Fun.protect ~finally:reset (fun () ->
+  let init_code = comp_block empty_env expr 1 [Kreturn 1] in
+  let fun_code = comp_remainder [] in
+  (init_code, fun_code))
+
+>>>>>>> ocaml-jst/flambda-patches

bytecomp/emitcode.ml

@@ -212,6 +212,10 @@ and emit_branch_comp = function
 | Clt -> out opBLTINT | Cle -> out opBLEINT
 | Cgt -> out opBGTINT | Cge -> out opBGEINT
 
+let runtime5_only () =
+  if not Config.runtime5 then
+    Misc.fatal_error "Effect primitives are only supported on runtime5"
+
 let emit_instr = function
     Klabel lbl -> define_label lbl
   | Kacc n ->
@@ -319,17 +323,11 @@ let emit_instr = function
   | Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0
   | Kgetdynmet -> out opGETDYNMET
   | Kevent ev -> record_event ev
-  (* CR mshinwell: enable for effects support
-  | Kperform -> out opPERFORM
-  | Kresume -> out opRESUME
-  | Kresumeterm n -> out opRESUMETERM; out_int n
-  | Kreperformterm n -> out opREPERFORMTERM; out_int n
-  | Kstop -> out opSTOP *)
-  | Kperform
-  | Kresume
-  | Kresumeterm _
-  | Kreperformterm _
-  | Kstop -> Misc.fatal_error "No effects support provided yet"
+  | Kperform -> runtime5_only (); out opPERFORM
+  | Kresume -> runtime5_only (); out opRESUME
+  | Kresumeterm n -> runtime5_only (); out opRESUMETERM; out_int n
+  | Kreperformterm n -> runtime5_only (); out opREPERFORMTERM; out_int n
+  | Kstop -> out opSTOP
 
 (* Emission of a list of instructions. Include some peephole optimization. *)
 

bytecomp/symtable.ml

@@ -214,6 +214,12 @@ let rec transl_const = function
       in
       List.iteri transl_field fields;
       block
+  | Const_mixed_block _ ->
+      (* CR layouts v5.9: Support constant mixed blocks in bytecode, either by
+         dynamically allocating them once at top-level, or by supporting
+         marshaling into the cmo format for mixed blocks in bytecode.
+      *)
+      Misc.fatal_error "[Const_mixed_block] not supported in bytecode."
   | Const_float_block fields | Const_float_array fields ->
       let res = Array.Floatarray.create (List.length fields) in
       List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))