Merge branch 'layered-persistent_env' into as-argument-for

Author: lukemaurer

.github/workflows/build.yml

@@ -13,28 +13,16 @@ jobs:
       fail-fast: false
       matrix:
         include:
-          - name: closure
-            config: --enable-middle-end=closure
-            os: ubuntu-latest
-            build_ocamlparam: ''
-            check_arch: true
-            use_runtime: d
-            ocamlrunparam: "v=0,V=1"
-
-          - name: flambda1
-            config: --enable-middle-end=flambda
-            os: ubuntu-latest
-            build_ocamlparam: ''
-
-          - name: flambda1_frame_pointers
-            config: --enable-middle-end=flambda --enable-frame-pointers --enable-poll-insertion
+          - name: flambda2_runtime5
+            config: --enable-middle-end=flambda2 --enable-runtime5
             os: ubuntu-latest
-            build_ocamlparam: ''
 
-          - name: flambda2_runtime5
+          - name: flambda2_debug_runtime5
             config: --enable-middle-end=flambda2 --enable-runtime5
             os: ubuntu-latest
-            expected_fail: true
+            build_ocamlparam: ''
+            use_runtime: d
+            ocamlrunparam: "v=0,V=1"
 
           - name: flambda2_debug_runtime
             config: --enable-middle-end=flambda2

backend/CSEgen.ml

@@ -238,8 +238,12 @@ method class_of_operation op =
   | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
   | Iextcall _ | Iprobe _ | Iopaque -> assert false  (* treated specially *)
   | Istackoffset _ -> Op_other
-  | Iload { mutability = Mutable } -> Op_load Mutable
-  | Iload { mutability = Immutable } -> Op_load Immutable
+  | Iload { mutability; is_atomic } ->
+    (* #12173: disable CSE for atomic loads. *)
+    if is_atomic then Op_other
+    else Op_load (match mutability with
+      | Mutable -> Mutable
+      | Immutable -> Immutable)
   | Istore(_,_,asg) -> Op_store asg
   | Ialloc _ | Ipoll _ -> assert false     (* treated specially *)
   | Iintop(Icheckbound|Icheckalign _) -> Op_checkbound

backend/amd64/emit.mlp

@@ -74,13 +74,13 @@ let cfi_endproc () =
 let cfi_adjust_cfa_offset n =
   if Config.asm_cfi_supported then D.cfi_adjust_cfa_offset n
 
-let _cfi_remember_state () =
+let cfi_remember_state () =
   if Config.asm_cfi_supported then D.cfi_remember_state ()
 
-let _cfi_restore_state () =
+let cfi_restore_state () =
   if Config.asm_cfi_supported then D.cfi_restore_state ()
 
-let _cfi_def_cfa_register reg =
+let cfi_def_cfa_register reg =
   if Config.asm_cfi_supported then D.cfi_def_cfa_register reg
 
 let emit_debug_info ?discriminator dbg =
@@ -94,7 +94,7 @@ let emit_debug_info_linear i =
 
 let fp = Config.with_frame_pointers
 
-let _stack_threshold_size = Config.stack_threshold * 8 (* bytes *)
+let stack_threshold_size = Config.stack_threshold * 8 (* bytes *)
 
 (* Tradeoff between code size and code speed *)
 
@@ -1034,6 +1034,10 @@ let emit_simd_instr op i =
   | SSE2 Avg_unsigned_i8 -> I.pavgb (arg i 1) (res i 0)
   | SSE2 Avg_unsigned_i16 -> I.pavgw (arg i 1) (res i 0)
   | SSE2 SAD_unsigned_i8 -> I.psadbw (arg i 1) (res i 0)
+  | SSE2 Mulhi_i16 -> I.pmulhw (arg i 1) (res i 0)
+  | SSE2 Mulhi_unsigned_i16 -> I.pmulhuw (arg i 1) (res i 0)
+  | SSE2 Mullo_i16 -> I.pmullw (arg i 1) (res i 0)
+  | SSE2 Mul_hadd_i16_to_i32 -> I.pmaddwd (arg i 1) (res i 0)
   | SSE2 And_bits -> I.pand (arg i 1) (res i 0)
   | SSE2 Andnot_bits -> I.pandnot (arg i 1) (res i 0)
   | SSE2 Or_bits -> I.por (arg i 1) (res i 0)
@@ -1108,6 +1112,8 @@ let emit_simd_instr op i =
   | SSSE3 Mulsign_i32 -> I.psignd (arg i 1) (res i 0)
   | SSSE3 Alignr_i8 n -> I.palignr (X86_dsl.int n) (arg i 1) (res i 0)
   | SSSE3 Shuffle_8 -> I.pshufb (arg i 1) (res i 0)
+  | SSSE3 Mul_unsigned_hadd_saturating_i8_to_i16 ->
+    I.pmaddubsw (arg i 1) (res i 0)
   | SSE41 (Blend_16 n) -> I.pblendw (X86_dsl.int n) (arg i 1) (res i 0)
   | SSE41 (Blend_32 n) -> I.blendps (X86_dsl.int n) (arg i 1) (res i 0)
   | SSE41 (Blend_64 n) -> I.blendpd (X86_dsl.int n) (arg i 1) (res i 0)
@@ -1160,6 +1166,7 @@ let emit_simd_instr op i =
   | SSE41 (Round_f32 n) -> I.roundps n (arg i 0) (res i 0)
   | SSE41 (Multi_sad_unsigned_i8 n) -> I.mpsadbw (X86_dsl.int n) (arg i 1) (res i 0)
   | SSE41 Minpos_unsigned_i16 -> I.phminposuw (arg i 0) (res i 0)
+  | SSE41 Mullo_i32 -> I.pmulld (arg i 1) (res i 0)
   | SSE42 Cmpgt_i64 -> I.pcmpgtq (arg i 1) (res i 0)
   | SSE42 Crc32_64 -> I.crc32 (arg i 1) (res i 0)
   | SSE42 (Cmpestrm n) -> I.pcmpestrm (X86_dsl.int n) (arg i 1) (arg i 0)
@@ -1269,25 +1276,19 @@ let emit_instr fallthrough i =
           end
         end
       end
-  | Lop(Iextcall { func; alloc; stack_ofs
-      (* BACKPORT BEGIN *)
-      = _
-      (* BACKPORT END *)
-      }) ->
+  | Lop(Iextcall { func; alloc; stack_ofs }) ->
       add_used_symbol func;
-(* BEGIN BACKPORT
-      if stack_ofs > 0 then begin
+      if Config.runtime5 && stack_ofs > 0 then begin
         I.mov rsp r13;
         I.lea (mem64 QWORD stack_ofs RSP) r12;
-        load_symbol_addr func rax;
-        emit_call "caml_c_call_stack_args";
-        record_frame env i.live (Dbg_other i.dbg);
-      end else *) if alloc then begin
+        load_symbol_addr (Cmm.global_symbol func) rax;
+        emit_call (Cmm.global_symbol "caml_c_call_stack_args");
+        record_frame i.live (Dbg_other i.dbg);
+      end else if alloc then begin
         load_symbol_addr (Cmm.global_symbol func) rax;
         emit_call (Cmm.global_symbol "caml_c_call");
         record_frame i.live (Dbg_other i.dbg);
-(* BEGIN BACKPORT *)
-        if system <> S_win64 then begin
+        if not Config.runtime5 && system <> S_win64 then begin
 
           (* In amd64.S, "caml_c_call" tail-calls the C function (in order to
              produce nicer backtraces), so we need to restore r15 manually after
@@ -1299,24 +1300,21 @@ let emit_instr fallthrough i =
 
           I.mov (domain_field Domainstate.Domain_young_ptr) r15
         end
-(* END BACKPORT *)
       end else begin
-(* BEGIN BACKPORT
-        I.mov rsp rbx;
-        cfi_remember_state ();
-        cfi_def_cfa_register "rbx";
-        (* NB: gdb has asserts on contiguous stacks that mean it
-           will not unwind through this unless we were to tag this
-           calling frame with cfi_signal_frame in it's definition. *)
-        I.mov (domain_field Domainstate.Domain_c_stack) rsp; *)
-(* END BACKPORT *)
-        emit_call (Cmm.global_symbol func)
-(* BEGIN BACKPORT
-        ;
-        I.mov rbx rsp;
-        cfi_restore_state ();
-*)
-(* END BACKPORT *)
+        if Config.runtime5 then begin
+          I.mov rsp rbx;
+          cfi_remember_state ();
+          cfi_def_cfa_register "rbx";
+          (* NB: gdb has asserts on contiguous stacks that mean it
+            will not unwind through this unless we were to tag this
+            calling frame with cfi_signal_frame in it's definition. *)
+          I.mov (domain_field Domainstate.Domain_c_stack) rsp;
+        end;
+        emit_call (Cmm.global_symbol func);
+        if Config.runtime5 then begin
+          I.mov rbx rsp;
+          cfi_restore_state ();
+        end;
       end
   | Lop(Istackoffset n) ->
       emit_stack_offset n
@@ -1690,8 +1688,9 @@ let emit_instr fallthrough i =
     I.set (cond (Iunsigned Cne)) (res8 i 0);
     I.movzx (res8 i 0) (res i 0)
   | Lop (Idls_get) ->
-      Misc.fatal_error "Dls is currently not supported";
-      (* I.mov (domain_field Domainstate.Domain_dls_root) (res i 0) *)
+    if Config.runtime5
+    then I.mov (domain_field Domainstate.Domain_dls_root) (res i 0)
+    else Misc.fatal_error "Dls is not supported in runtime4.";
   | Lreloadretaddr ->
       ()
   | Lreturn ->
@@ -1775,16 +1774,12 @@ let emit_instr fallthrough i =
   | Lraise k ->
       begin match k with
       | Lambda.Raise_regular ->
-          (* BACKPORT BEGIN *)
           I.mov (int 0) (domain_field Domainstate.Domain_backtrace_pos);
-          (* BACKPORT END *)
           emit_call (Cmm.global_symbol "caml_raise_exn");
           record_frame Reg.Set.empty (Dbg_raise i.dbg)
       | Lambda.Raise_reraise ->
-          (* BACKPORT BEGIN *)
-          (* emit_call (Cmm.global_symbol "caml_reraise_exn"); *)
-          emit_call (Cmm.global_symbol "caml_raise_exn");
-          (* BACKPORT END *)
+          emit_call (Cmm.global_symbol
+            (if Config.runtime5 then "caml_reraise_exn" else "caml_raise_exn"));
           record_frame Reg.Set.empty (Dbg_raise i.dbg)
       | Lambda.Raise_notrace ->
           I.mov (domain_field Domainstate.Domain_exn_handler) rsp;
@@ -1853,33 +1848,40 @@ let fundecl fundecl =
   D.label (label_name (emit_symbol fundecl.fun_name));
   emit_debug_info fundecl.fun_dbg;
   cfi_startproc ();
-  (* BACKPORT BEGIN *)
-  (* if !Clflags.runtime_variant = "d" then
-    emit_call (Cmm.global_symbol "caml_assert_stack_invariants");
-  let { max_frame_size; contains_nontail_calls} =
-    preproc_stack_check
-      ~fun_body:fundecl.fun_body ~frame_size:(frame_size ()) ~trap_size:16
+  let handle_overflow_and_max_frame_size =
+    (* CR mshinwell: this should be conditionalized on a specific
+       "stack checks enabled" config option, so we can backport to 4.x *)
+    if not Config.runtime5 then None
+    else (
+      if !Clflags.runtime_variant = "d" then
+        emit_call (Cmm.global_symbol "caml_assert_stack_invariants");
+      let { max_frame_size; contains_nontail_calls} =
+        preproc_stack_check
+          ~fun_body:fundecl.fun_body ~frame_size:(frame_size ()) ~trap_size:16
+      in
+      let handle_overflow =
+        if contains_nontail_calls || max_frame_size >= stack_threshold_size then begin
+          let overflow = new_label () and ret = new_label () in
+          let threshold_offset = Domainstate.stack_ctx_words * 8 + stack_threshold_size in
+          I.lea (mem64 NONE (-(max_frame_size + threshold_offset)) RSP) r10;
+          I.cmp (domain_field Domainstate.Domain_current_stack) r10;
+          I.jb (label overflow);
+          def_label ret;
+          Some (overflow, ret)
+        end else None
+      in
+      match handle_overflow with
+      | None -> None
+      | Some handle_overflow -> Some (handle_overflow, max_frame_size)
+    )
   in
-  let handle_overflow =
-    if contains_nontail_calls || max_frame_size >= stack_threshold_size then begin
-      let overflow = new_label () and ret = new_label () in
-      let threshold_offset = Domainstate.stack_ctx_words * 8 + stack_threshold_size in
-      I.lea (mem64 NONE (-(max_frame_size + threshold_offset)) RSP) r10;
-      I.cmp (domain_field Domainstate.Domain_current_stack) r10;
-      I.jb (label overflow);
-      def_label ret;
-      Some (overflow, ret)
-    end else None
-  in*)
-  (* BACKPORT END *)
   emit_all true fundecl.fun_body;
   List.iter emit_call_gc !call_gc_sites;
   List.iter emit_local_realloc !local_realloc_sites;
   emit_call_safety_errors ();
-  (* BACKPORT BEGIN *)
-  (*begin match handle_overflow with
+  begin match handle_overflow_and_max_frame_size with
     | None -> ()
-    | Some (overflow,ret) -> begin
+    | Some ((overflow,ret), max_frame_size) -> begin
         def_label overflow;
         (* Pass the desired frame size on the stack, since all of the
            argument-passing registers may be in use.
@@ -1892,8 +1894,7 @@ let fundecl fundecl =
         cfi_adjust_cfa_offset (-8);
         I.jmp (label ret)
       end
-  end;*)
-  (* BACKPORT END *)
+  end;
   if !frame_required then begin
     let n = frame_size() - 8 - (if fp then 8 else 0) in
     if n <> 0

backend/amd64/proc.ml

@@ -309,10 +309,7 @@ let win64_float_external_arguments =
 let win64_loc_external_arguments arg =
   let loc = Array.make (Array.length arg) Reg.dummy in
   let reg = ref 0
-  (* BACKPORT BEGIN *)
-  (* and ofs = ref 0 in *)
-  and ofs = ref 32 in
-  (* BACKPORT END *)
+  and ofs = ref (if Config.runtime5 then 0 else 32) in
   for i = 0 to Array.length arg - 1 do
     match arg.(i) with
     | Val | Int | Addr as ty ->
@@ -374,10 +371,16 @@ let domainstate_ptr_dwarf_register_number = 14
 
 (* Registers destroyed by operations *)
 
+let int_regs_destroyed_at_c_call_win64 =
+  if Config.runtime5 then [|0;1;4;5;6;7;10;11;12|] else [|0;4;5;6;7;10;11|]
+
+let int_regs_destroyed_at_c_call =
+  if Config.runtime5 then [|0;1;2;3;4;5;6;7;10;11|] else [|0;2;3;4;5;6;7;10;11|]
+
 let destroyed_at_c_call_win64 =
   (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *)
   let basic_regs = Array.append
-    (Array.map (phys_reg Int) [|0;4;5;6;7;10;11|]  )
+    (Array.map (phys_reg Int) int_regs_destroyed_at_c_call_win64)
     (Array.sub hard_float_reg 0 6)
   in
   fun () -> if simd_regalloc_disabled ()
@@ -387,7 +390,7 @@ let destroyed_at_c_call_win64 =
 let destroyed_at_c_call_unix =
   (* Unix: rbx, rbp, r12-r15 preserved *)
   let basic_regs = Array.append
-      (Array.map (phys_reg Int) [|0;2;3;4;5;6;7;10;11|])
+      (Array.map (phys_reg Int) int_regs_destroyed_at_c_call)
     hard_float_reg
   in
   fun () -> if simd_regalloc_disabled ()