Merge pull request #10831 from ocaml-multicore/multicore-pr

Multicore OCaml integration.
ocaml · 9 days ago · 001997e81342fd0d321fd877b73608150601e7d9 · 001997e
2 parents 263a2a4 + fdf5da2
commit 001997e81342fd0d321fd877b73608150601e7d9
Showing 573 changed files with 22,955 additions and 14,062 deletions.
diff --git a/.gitattributes b/.gitattributes
@@ -72,6 +72,9 @@ tools/mantis2gh_stripped.csv typo.missing-header
 .depend                  typo.prune
 /.depend.menhir          typo.prune
 
+# These can be fixed at some point
+/tools/*.py              typo.long-line
+
 # Makefiles may contain tabs
 Makefile*                typo.makefile-whitespace=may
 
@@ -183,6 +186,7 @@ tools/ocamlsize text eol=lf
 tools/pre-commit-githook text eol=lf
 tools/markdown-add-pr-links.sh text eol=lf
 runtime/caml/compatibility.h typo.long-line=may
+runtime/caml/sizeclasses.h typo.missing-header typo.white-at-eol
 
 # These are all Perl scripts, so may not actually require this
 manual/tools/caml-tex text eol=lf

diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
@@ -3,91 +3,101 @@ name: Build
 on: [push, pull_request]
 
 jobs:
-  no-naked-pointers:
+
-    runs-on: ubuntu-latest
+  build:
+    name: 'linux'
+    runs-on: 'ubuntu-latest'
     steps:
-    - name: Checkout
+      - name: Checkout
-      uses: actions/checkout@v2
+        uses: actions/checkout@v2
-    - name: configure tree
+      - name: configure tree
-      run: ./configure --disable-naked-pointers --disable-stdlib-manpages --disable-dependency-generation --enable-ocamltest
+        run: |
-    - name: Build
+          MAKE_ARG=-j XARCH=x64 bash -xe tools/ci/actions/runner.sh configure
-      run: |
+      - name: Build
-        make -j world.opt
+        run: |
-    - name: Run the testsuite
+          MAKE_ARG=-j bash -xe tools/ci/actions/runner.sh build
-      run: |
+      - name: Prepare Artifact
-        make -C testsuite USE_RUNTIME=d all
+        run: |
-  i386-static:
+          tar -czf /tmp/sources.tar.gz .
-    runs-on: ubuntu-latest
+      - uses: actions/upload-artifact@v2
+        with:
+          name: compiler
+          path: /tmp/sources.tar.gz
+          retention-days: 1
+
+  build-misc:
+    name: ${{ matrix.name }}
+    runs-on: ${{ matrix.os }}
+    strategy:
+      matrix:
+        include:
+          - name: linux-O0
+            os: ubuntu-latest
+            config_arg: CFLAGS='-O0'
+          - name: linux-debug
+            os: ubuntu-latest
+            env: OCAMLRUNPARAM=v=0,V=1 USE_RUNTIME=d
+          - name: macos
+            os: macos-latest
     steps:
-    - name: Checkout
+      - name: Checkout
-      uses: actions/checkout@v2
+        uses: actions/checkout@v2
-    - name: Packages
+      - name: configure tree
-      run: |
+        run: |
-        sudo apt-get update -y && sudo apt-get install -y gcc-multilib gfortran-multilib
+          CONFIG_ARG=${{ matrix.config_arg }} MAKE_ARG=-j XARCH=x64 bash -xe tools/ci/actions/runner.sh configure
-    - name: configure tree
+      - name: Build
-      run: |
+        run: |
-        XARCH=i386 CONFIG_ARG='--disable-stdlib-manpages --disable-shared --enable-cmm-invariants' bash -xe tools/ci/actions/runner.sh configure
+          MAKE_ARG=-j bash -xe tools/ci/actions/runner.sh build
-    - name: Build
+      - name: Run the testsuite
-      run: |
+        if: ${{ matrix.name != 'linux-O0' }}
-        bash -xe tools/ci/actions/runner.sh build
+        run: |
-    - name: Run the testsuite
+          bash -c 'SHOW_TIMINGS=1 tools/ci/actions/runner.sh test'
-      run: |
+      - name: Run the testsuite (linux-O0, parallel)
-        bash -xe tools/ci/actions/runner.sh test
+        if: ${{ matrix.name == 'linux-O0' }}
-    - name: Install
+        env:
-      run: |
+          OCAMLRUNPARAM: v=0,V=1
-        bash -xe tools/ci/actions/runner.sh install
+          USE_RUNTIME: d
-    - name: Other checks
+        run: |
-      run: |
+          bash -xe tools/ci/actions/runner.sh test_multicore 1 "parallel" "lib-threads" "lib-systhreads"
-        bash -xe tools/ci/actions/runner.sh other-checks
+
-  full-flambda:
+  testsuite:
+    needs: build
+    # https://docs.github.com/en/actions/reference/workflow-syntax-for-github-actions#jobsjob_idneeds    strategy:
     runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        id:
+          - debug-s4096
+          - taskset
+          - normal
+          - super
     steps:
-    - name: Checkout
+      - uses: actions/download-artifact@v2
-      uses: actions/checkout@v2
+        with:
-      with:
+          name: compiler
-        fetch-depth: 50
+      - name: Unpack Artifact
-    - name: Packages
+        run: |
-      run: |
+          tar xf sources.tar.gz
-        sudo apt-get update -y && sudo apt-get install -y texlive-latex-extra texlive-fonts-recommended hevea sass
+      - name: Run the testsuite
-  # Ensure that make distclean can be run from an empty tree
+        if: ${{ matrix.id == 'normal' }}
-    - name: distclean
+        run: |
-      run: |
+          bash -xe tools/ci/actions/runner.sh test
-        MAKE_ARG=-j make distclean
+      - name: Run the testsuite (Super Charged)
-    - name: configure tree
+        if: ${{ matrix.id == 'super' }}
-      run: |
+        run: |
-        MAKE_ARG=-j XARCH=x64 CONFIG_ARG='--enable-flambda --enable-cmm-invariants --enable-dependency-generation --enable-native-toplevel' OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh configure
+          bash -xe tools/ci/actions/runner.sh test_multicore 3 "parallel" \
-    - name: Build
+          "callback" "gc-roots" "lib-threads" "lib-systhreads" \
-      run: |
+          "weak-ephe-final"
-        MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh build
+      - name: Run the testsuite (s=4096, debug runtime)
-    - name: Run the testsuite
+        env:
-      run: |
+          OCAMLRUNPARAM: s=4096,v=0
-        MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh test
+          USE_RUNTIME: d
-    - name: Build API Documentation
+        if: ${{ matrix.id == 'debug-s4096' }}
-      run: |
+        run: |
-        MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh api-docs
+          bash -xe tools/ci/actions/runner.sh test_multicore 1 "parallel" \
-    - name: Install
+          "lib-threads" "lib-systhreads" "weak-ephe-final"
-      run: |
+      - name: Run the testsuite (taskset -c 0)
-        MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh install
+        if: ${{ matrix.id == 'taskset' }}
-    - name: Check for manual changes
+        run: |
-      id: manual
+          bash -xe tools/ci/actions/runner.sh test_multicore 1 "parallel" \
-      run: >-
+          "lib-threads" "lib-systhreads" "weak-ephe-final"
-        tools/ci/actions/check-manual-modified.sh
-        '${{ github.ref }}'
-        '${{ github.event_name }}'
-        '${{ github.event.pull_request.base.ref }}'
-        '${{ github.event.pull_request.base.sha }}'
-        '${{ github.event.pull_request.head.ref }}'
-        '${{ github.event.pull_request.head.sha }}'
-        '${{ github.event.ref }}'
-        '${{ github.event.before }}'
-        '${{ github.event.ref }}'
-        '${{ github.event.after }}'
-        '${{ github.event.repository.full_name }}'
-    - name: Build the manual
-      run: |
-        MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh manual
-      # Temporarily disabled 23-Apr-2021 while Dune isn't building
-      if: steps.manual.outputs.changed == 'disabled'
-    - name: Other checks
-      run: |
-        MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh other-checks
diff --git a/Changes b/Changes
@@ -4,6 +4,8 @@ Working version
 ### Language features:
 
 ### Runtime system:
+- #10831: Multicore OCaml
+  (The multicore team, caml-devel and more)
 
 ### Code generation and optimizations:
 

diff --git a/Makefile.config.in b/Makefile.config.in
@@ -181,6 +181,7 @@ OTHERLIBRARIES=@otherlibraries@
 # Needed for the "systhreads" package
 PTHREAD_LIBS=@PTHREAD_LIBS@
 PTHREAD_CAML_LIBS=$(addprefix -cclib ,$(PTHREAD_LIBS))
+PTHREAD_CFLAGS=@PTHREAD_CFLAGS@
 
 UNIX_OR_WIN32=@unix_or_win32@
 UNIXLIB=@unixlib@
@@ -236,11 +237,15 @@ ASM_CFI_SUPPORTED=@asm_cfi_supported@
 WITH_FRAME_POINTERS=@frame_pointers@
 WITH_PROFINFO=@profinfo@
 PROFINFO_WIDTH=@profinfo_width@
+LIBUNWIND_AVAILABLE=@libunwind_available@
+LIBUNWIND_INCLUDE_FLAGS=@libunwind_include_flags@
+LIBUNWIND_LINK_FLAGS=@libunwind_link_flags@
 WITH_FPIC=@fpic@
 TARGET=@target@
 HOST=@host@
 FLAMBDA=@flambda@
 WITH_FLAMBDA_INVARIANTS=@flambda_invariants@
+FORCE_INSTRUMENTED_RUNTIME=@force_instrumented_runtime@
 WITH_CMM_INVARIANTS=@cmm_invariants@
 FORCE_SAFE_STRING=@force_safe_string@
 DEFAULT_SAFE_STRING=@default_safe_string@
@@ -250,7 +255,7 @@ FLAT_FLOAT_ARRAY=@flat_float_array@
 FUNCTION_SECTIONS=@function_sections@
 AWK=@AWK@
 STDLIB_MANPAGES=@stdlib_manpages@
-NAKED_POINTERS=@naked_pointers@
+NAKED_POINTERS=false
 
 ### Native command to build ocamlrun.exe
 

diff --git a/api_docgen/Makefile.docfiles b/api_docgen/Makefile.docfiles
@@ -35,8 +35,8 @@ str_MLIS := str.mli
 unix_MLIS := unix.mli unixLabels.mli
 dynlink_MLIS := dynlink.mli
 thread_MLIS := \
-  thread.mli condition.mli mutex.mli event.mli \
+  thread.mli event.mli \
-  threadUnix.mli semaphore.mli
+  threadUnix.mli
 
 STDLIB=$(filter-out stdlib__Pervasives, $(STDLIB_MODULES))
 

diff --git a/appveyor.yml b/appveyor.yml
@@ -31,16 +31,17 @@ environment:
     FORCE_CYGWIN_UPGRADE: 0
     BUILD_MODE: world.opt
   matrix:
-    - PORT: mingw32
+    - PORT: mingw64
       BOOTSTRAP_FLEXDLL: true
-    - PORT: msvc64
+# OCaml 5.00 does not yet support MSVC
-      BOOTSTRAP_FLEXDLL: false
+#    - PORT: msvc64
-      BUILD_MODE: steps
+#      BOOTSTRAP_FLEXDLL: false
-    - PORT: msvc32
+#      BUILD_MODE: steps
-      BOOTSTRAP_FLEXDLL: false
+#    - PORT: msvc32
-      BUILD_MODE: C
+#      BOOTSTRAP_FLEXDLL: false
-      SDK: |-
+#      BUILD_MODE: C
-        "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86
+#      SDK: |-
+#        "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86
 
 matrix:
   fast_finish: true

diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml
@@ -236,9 +236,9 @@ method class_of_operation op =
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat -> Op_pure
   | Ispecific _ -> Op_other
+  | Idls_get -> Op_load Mutable
 
 (* Operations that are so cheap that it isn't worth factoring them. *)
-
 method is_cheap_operation op =
   match op with
   | Iconst_int _ -> true

diff --git a/asmcomp/afl_instrument.ml b/asmcomp/afl_instrument.ml
@@ -42,13 +42,19 @@ let rec with_afl_logging b dbg =
     let afl_area = V.create_local "shared_mem" in
     let op oper args = Cop (oper, args, dbg) in
     Clet(VP.create afl_area,
-      op (Cload (Word_int, Asttypes.Mutable)) [afl_area_ptr dbg],
+      op (Cload ({memory_chunk=Word_int;
-      Clet(VP.create cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable))
+                  mutability=Asttypes.Mutable;
+                  is_atomic=false})) [afl_area_ptr dbg],
+      Clet(VP.create cur_pos, op Cxor [op (Cload {memory_chunk=Word_int;
+                                                  mutability=Asttypes.Mutable;
+                                                  is_atomic=false})
         [afl_prev_loc dbg]; Cconst_int (cur_location, dbg)],
       Csequence(
         op (Cstore(Byte_unsigned, Assignment))
           [op Cadda [Cvar afl_area; Cvar cur_pos];
-            op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable))
+            op Cadda [op (Cload {memory_chunk=Byte_unsigned;
+                                 mutability=Asttypes.Mutable;
+                                 is_atomic=false})
                         [op Cadda [Cvar afl_area; Cvar cur_pos]];
                       Cconst_int (1, dbg)]],
         op (Cstore(Word_int, Assignment))

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
@@ -63,11 +63,22 @@ 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 () =
+  if Config.asm_cfi_supported then D.cfi_remember_state ()
+
+let cfi_restore_state () =
+  if Config.asm_cfi_supported then D.cfi_restore_state ()
+
+let cfi_def_cfa_register reg =
+  if Config.asm_cfi_supported then D.cfi_def_cfa_register reg
+
 let emit_debug_info dbg =
   emit_debug_info_gen dbg D.file D.loc
 
 let fp = Config.with_frame_pointers
 
+let stack_threshold_size = Config.stack_threshold * 8 (* bytes *)
+
 let frame_size env =                     (* includes return address *)
   if env.f.fun_frame_required then begin
     let sz =
@@ -525,26 +536,35 @@ let emit_instr env fallthrough i =
           end
         end
       end
-  | Lop(Iextcall { func; alloc; }) ->
+  | Lop(Iextcall { func; alloc; stack_ofs }) ->
       add_used_symbol func;
-      if alloc then begin
+      let base_stack_size =
+        if Arch.win64 then
+          32 (* Windows x64 rcx+rdx+r8+r9 shadow stack *)
+        else
+          0 in
+      if stack_ofs > base_stack_size then begin
+        I.lea (mem64 QWORD base_stack_size 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 func rax;
         emit_call "caml_c_call";
         record_frame env i.live (Dbg_other i.dbg);
-        if 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
-             it returns (note that this increases code size).
-
-             In amd64nt.asm (used for Win64), "caml_c_call" invokes the C
-             function via a regular call, and restores r15 itself, thus avoiding
-             the code size increase. *)
-
-          I.mov (domain_field Domainstate.Domain_young_ptr) r15
-        end
       end else begin
-        emit_call func
+        I.mov rsp rbp;
+        cfi_remember_state ();
+        cfi_def_cfa_register "rbp";
+        (* 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;
+
+        emit_call func;
+        I.mov rbp rsp;
+        cfi_restore_state ();
       end
   | Lop(Istackoffset n) ->
       if n < 0
@@ -720,6 +740,8 @@ let emit_instr env fallthrough i =
       I.movsxd (arg32 i 0) (res i 0)
   | Lop(Ispecific(Izextend32)) ->
       I.mov (arg32 i 0) (res32 i 0)
+  | Lop (Idls_get) ->
+      I.mov (domain_field Domainstate.Domain_dls_root) (res i 0)
   | Lreloadretaddr ->
       ()
   | Lreturn ->
@@ -820,28 +842,27 @@ let emit_instr env fallthrough i =
       load_label_addr lbl_handler r11;
       I.push r11;
       cfi_adjust_cfa_offset 8;
-      I.push (domain_field Domainstate.Domain_exception_pointer);
+      I.push (domain_field Domainstate.Domain_exn_handler);
       cfi_adjust_cfa_offset 8;
-      I.mov rsp (domain_field Domainstate.Domain_exception_pointer);
+      I.mov rsp (domain_field Domainstate.Domain_exn_handler);
       env.stack_offset <- env.stack_offset + 16;
   | Lpoptrap ->
-      I.pop (domain_field Domainstate.Domain_exception_pointer);
+      I.pop (domain_field Domainstate.Domain_exn_handler);
       cfi_adjust_cfa_offset (-8);
       I.add (int 8) rsp;
       cfi_adjust_cfa_offset (-8);
       env.stack_offset <- env.stack_offset - 16
   | Lraise k ->
       begin match k with
       | Lambda.Raise_regular ->
-          I.mov (int 0) (domain_field Domainstate.Domain_backtrace_pos);
           emit_call "caml_raise_exn";
           record_frame env Reg.Set.empty (Dbg_raise i.dbg)
       | Lambda.Raise_reraise ->
-          emit_call "caml_raise_exn";
+          emit_call "caml_reraise_exn";
           record_frame env Reg.Set.empty (Dbg_raise i.dbg)
       | Lambda.Raise_notrace ->
-          I.mov (domain_field Domainstate.Domain_exception_pointer) rsp;
+          I.mov (domain_field Domainstate.Domain_exn_handler) rsp;
-          I.pop (domain_field Domainstate.Domain_exception_pointer);
+          I.pop (domain_field Domainstate.Domain_exn_handler);
           I.pop r11;
           I.jmp r11
       end
@@ -855,6 +876,30 @@ let rec emit_all env fallthrough i =
 
 let all_functions = ref []
 
+type preproc_fun_result =
+  { max_stack_size : int;
+    contains_nontail_calls : bool }
+
+let preproc_fun env fun_body _fun_name =
+  let rec proc_instr r s i =
+    if i.desc = Lend then r else
+        let upd_size r delta =
+          {r with max_stack_size = max r.max_stack_size (s+delta)}
+        in
+        let (r',s') = match i.desc with
+          | Lop (Istackoffset n) -> (upd_size r n, s+n)
+          | Lpushtrap _ -> (upd_size r 16, s+16)
+          | Lpoptrap -> (r, s-16)
+          | Lop (Icall_ind | Icall_imm _ ) ->
+              ({r with contains_nontail_calls = true}, s)
+          | _ -> (r, s)
+        in
+        proc_instr r' s' i.next
+  in
+  let fs = frame_size env in
+  let r = {max_stack_size = fs; contains_nontail_calls = false} in
+  proc_instr r fs fun_body
+
 (* Emission of a function declaration *)
 
 let fundecl fundecl =
@@ -873,9 +918,38 @@ let fundecl fundecl =
   D.label (emit_symbol fundecl.fun_name);
   emit_debug_info fundecl.fun_dbg;
   cfi_startproc ();
+  if !Clflags.runtime_variant = "d" then
+    emit_call "caml_assert_stack_invariants";
+  let { max_stack_size; contains_nontail_calls} =
+    preproc_fun env fundecl.fun_body fundecl.fun_name
+  in
+  let handle_overflow = ref None in
+  if contains_nontail_calls || max_stack_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_stack_size + threshold_offset)) RSP) r10;
+    I.cmp (domain_field Domainstate.Domain_current_stack) r10;
+    I.jb (label overflow);
+    def_label ret;
+    handle_overflow := Some (overflow, ret)
+  end;
   emit_all env true fundecl.fun_body;
   List.iter emit_call_gc env.call_gc_sites;
   emit_call_bound_errors env;
+  begin match !handle_overflow with
+  | None -> ()
+  | Some (overflow,ret) -> begin
+      def_label overflow;
+      (* Pass the desired stack size on the stack, since all of the
+        argument-passing registers may be in use.
+        Also serves to align the stack properly before the call *)
+      I.push (int (Config.stack_threshold + max_stack_size / 8));
+        (* measured in words *)
+      emit_call "caml_call_realloc_stack";
+      I.pop r10; (* ignored *)
+      I.jmp (label ret)
+    end
+  end;
   if fundecl.fun_frame_required then begin
     let n = (frame_size env) - 8 - (if fp then 8 else 0) in
     if n <> 0

diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml
@@ -291,15 +291,18 @@ let regs_are_volatile _rs = false
 (* Registers destroyed by operations *)
 
 let destroyed_at_c_call =
+  (* C calling conventions preserve rbp, but it is clobbered
+     by the code sequence used for C calls in emit.mlp, so it
+     is marked as destroyed. *)
   if win64 then
-    (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *)
+    (* Win64: rbx, rsi, rdi, r12-r15, xmm6-xmm15 preserved *)
     Array.of_list(List.map phys_reg
-      [0;4;5;6;7;10;11;
+      [0;4;5;6;7;10;11;12;
        100;101;102;103;104;105])
   else
-    (* Unix: rbp, rbx, r12-r15 preserved *)
+    (* Unix: rbx, r12-r15 preserved *)
     Array.of_list(List.map phys_reg
-      [0;2;3;4;5;6;7;10;11;
+      [0;2;3;4;5;6;7;10;11;12;
        100;101;102;103;104;105;106;107;
        108;109;110;111;112;113;114;115])
 
@@ -310,9 +313,12 @@ let destroyed_at_alloc_or_poll =
     [| r11 |]
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall { alloc = true; }) ->
+    Iop(Icall_ind | Icall_imm _) ->
-    all_phys_regs
+      all_phys_regs
-  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
+  | Iop(Iextcall {alloc; stack_ofs; }) ->
+      assert (stack_ofs >= 0);
+      if alloc || stack_ofs > 0 then all_phys_regs
+      else destroyed_at_c_call
   | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _))
         -> [| rax; rdx |]
   | Iop(Istore(Single, _, _)) -> [| rxmm15 |]

diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml
@@ -203,7 +203,7 @@ method! select_operation op args dbg =
       self#select_floatarith false Idivf Ifloatdiv args
   | Cextcall("sqrt", _, _, false) ->
      begin match args with
-       [Cop(Cload ((Double as chunk), _), [loc], _dbg)] ->
+       [Cop(Cload {memory_chunk=(Double as chunk)}, [loc], _dbg)] ->
          let (addr, arg) = self#select_addressing chunk loc in
          (Ispecific(Ifloatsqrtf addr), [arg])
      | [arg] ->
@@ -251,11 +251,11 @@ method! select_operation op args dbg =
 
 method select_floatarith commutative regular_op mem_op args =
   match args with
-    [arg1; Cop(Cload ((Double as chunk), _), [loc2], _)] ->
+    [arg1; Cop(Cload {memory_chunk=(Double as chunk)}, [loc2], _)] ->
       let (addr, arg2) = self#select_addressing chunk loc2 in
       (Ispecific(Ifloatarithmem(mem_op, addr)),
                  [arg1; arg2])
-  | [Cop(Cload ((Double as chunk), _), [loc1], _); arg2]
+  | [Cop(Cload {memory_chunk=(Double as chunk)}, [loc1], _); arg2]
         when commutative ->
       let (addr, arg1) = self#select_addressing chunk loc1 in
       (Ispecific(Ifloatarithmem(mem_op, addr)),

diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml
@@ -53,6 +53,7 @@ exception Use_default
 let r1 = phys_reg 1
 let r6 = phys_reg 6
 let r7 = phys_reg 7
+let r12 = phys_reg 8
 
 let pseudoregs_for_operation op arg res =
   match op with
@@ -267,9 +268,11 @@ method private select_operation_softfp op args dbg =
        [Cop(Cextcall(func, typ_int, [XFloat;XFloat], false),
             args, dbg)])
   (* Add coercions around loads and stores of 32-bit floats *)
-  | (Cload (Single, mut), args) ->
+  | (Cload {memory_chunk=Single; mutability; is_atomic=false}, args) ->
       (self#iextcall "__aeabi_f2d" typ_float [XInt],
-        [Cop(Cload (Word_int, mut), args, dbg)])
+        [Cop(Cload {memory_chunk=Word_int;
+                    mutability;
+                    is_atomic=false}, args, dbg)])
   | (Cstore (Single, init), [arg1; arg2]) ->
       let arg2' =
         Cop(Cextcall("__aeabi_d2f", typ_int, [XFloat], false),

diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
@@ -150,7 +150,10 @@ type memory_chunk =
 and operation =
     Capply of machtype
   | Cextcall of string * machtype * exttype list * bool
-  | Cload of memory_chunk * Asttypes.mutable_flag
+  | Cload of
+      { memory_chunk: memory_chunk
+      ; mutability: Asttypes.mutable_flag
+      ; is_atomic: bool }
   | Calloc
   | Cstore of memory_chunk * Lambda.initialization_or_assignment
   | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
@@ -165,6 +168,7 @@ and operation =
   | Craise of Lambda.raise_kind
   | Ccheckbound
   | Copaque
+  | Cdls_get
 
 type expression =
     Cconst_int of int * Debuginfo.t

diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
@@ -144,7 +144,10 @@ and operation =
       (** 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
+  | Cload of
+      { memory_chunk: memory_chunk
+      ; mutability: Asttypes.mutable_flag
+      ; is_atomic: bool }
   | Calloc
   | Cstore of memory_chunk * Lambda.initialization_or_assignment
   | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
@@ -163,6 +166,7 @@ and operation =
                    It results in a bounds error if the index is greater than
                    or equal to the bound. *)
   | Copaque (* Sys.opaque_identity *)
+  | Cdls_get
 
 (** Every basic block should have a corresponding [Debuginfo.t] for its
     beginning. *)

diff --git a/asmcomp/cmm_helpers.ml b/asmcomp/cmm_helpers.ml
diff --git a/asmcomp/cmm_helpers.mli b/asmcomp/cmm_helpers.mli
@@ -188,6 +188,7 @@ val return_unit : Debuginfo.t -> expression -> expression
 val remove_unit : expression -> expression
 
 (** Blocks *)
+val mk_load_mut : memory_chunk -> operation
 
 (** [field_address ptr n dbg] returns an expression for the address of the
     [n]th field of the block pointed to by [ptr] *)

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
@@ -521,7 +521,7 @@ let rec transl env e =
             dbg)
       | (Pbigarraydim(n), [b]) ->
           let dim_ofs = 4 + n in
-          tag_int (Cop(Cload (Word_int, Mutable),
+          tag_int (Cop(mk_load_mut Word_int,
             [field_address (transl env b) dim_ofs dbg],
             dbg)) dbg
       | (p, [arg]) ->
@@ -537,6 +537,10 @@ let rec transl env e =
         ->
           fatal_error "Cmmgen.transl:prim, wrong arity"
       | ((Pfield_computed|Psequand
+         | Prunstack | Pperform | Presume | Preperform
+         | Pdls_get
+         | Patomic_load _ | Patomic_exchange
+         | Patomic_cas | Patomic_fetch_add
          | Psequor | Pnot | Pnegint | Paddint | Psubint
          | Pmulint | Pandint | Porint | Pxorint | Plslint
          | Plsrint | Pasrint | Pintoffloat | Pfloatofint
@@ -679,7 +683,7 @@ let rec transl env e =
       end
   | Uunreachable ->
       let dbg = Debuginfo.none in
-      Cop(Cload (Word_int, Mutable), [Cconst_int (0, dbg)], dbg)
+      Cop(mk_load_mut Word_int, [Cconst_int (0, dbg)], dbg)
 
 and transl_catch env nfail ids body handler dbg =
   let ids = List.map (fun (id, kind) -> (id, kind, ref No_result)) ids in
@@ -795,7 +799,7 @@ and transl_prim_1 env p arg dbg =
     Popaque ->
       opaque (transl env arg) dbg
   (* Heap operations *)
-  | Pfield n ->
+  | Pfield(n, _, _) ->
       get_field env (transl env arg) n dbg
   | Pfloatfield n ->
       let ptr = transl env arg in
@@ -852,7 +856,20 @@ and transl_prim_1 env p arg dbg =
   | Pbswap16 ->
       tag_int (bswap16 (ignore_high_bit_int (untag_int
         (transl env arg) dbg)) dbg) dbg
+  | Pperform ->
+      let cont = make_alloc dbg Obj.cont_tag [int_const dbg 0] in
+      Cop(Capply typ_val,
+       [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} ->
+      Cop(mk_load_mut Word_int, [transl env arg], dbg)
+  | Patomic_load {immediate_or_pointer = Pointer} ->
+      Cop(mk_load_mut Word_val, [transl env arg], dbg)
   | (Pfield_computed | Psequand | Psequor
+    | Prunstack | Presume | Preperform
+    | Patomic_exchange | Patomic_cas | Patomic_fetch_add
     | Paddint | Psubint | Pmulint | Pandint
     | Porint | Pxorint | Plslint | Plsrint | Pasrint
     | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
@@ -1036,6 +1053,14 @@ and transl_prim_2 env p arg1 arg2 dbg =
       tag_int (Cop(Ccmpi cmp,
                      [transl_unbox_int dbg env bi arg1;
                       transl_unbox_int dbg env bi arg2], dbg)) dbg
+  | Patomic_exchange ->
+     Cop (Cextcall ("caml_atomic_exchange", typ_val, [], false),
+          [transl env arg1; transl env arg2], dbg)
+  | Patomic_fetch_add ->
+     Cop (Cextcall ("caml_atomic_fetch_add", typ_int, [], false),
+          [transl env arg1; transl env arg2], dbg)
+  | Prunstack | Pperform | Presume | Preperform | Pdls_get
+  | Patomic_cas | Patomic_load _
   | Pnot | Pnegint | Pintoffloat | Pfloatofint | Pnegfloat
   | Pabsfloat | Pstringlength | Pbyteslength | Pbytessetu | Pbytessets
   | Pisint | Pbswap16 | Pint_as_pointer | Popaque | Pread_symbol _
@@ -1087,6 +1112,31 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
       bigstring_set size unsafe (transl env arg1) (transl env arg2)
         (transl_unbox_sized size dbg env arg3) dbg
 
+  | Patomic_cas ->
+     Cop (Cextcall ("caml_atomic_cas", typ_int, [], false),
+          [transl env arg1; transl env arg2; transl env arg3], dbg)
+
+  (* Effects *)
+  | Presume ->
+      Cop (Capply typ_val,
+           [Cconst_symbol ("caml_resume", dbg);
+           transl env arg1; transl env arg2; transl env arg3],
+           dbg)
+
+  | Prunstack ->
+      Cop (Capply typ_val,
+           [Cconst_symbol ("caml_runstack", dbg);
+           transl env arg1; transl env arg2; transl env arg3],
+           dbg)
+
+  | Preperform ->
+      Cop (Capply typ_val,
+           [Cconst_symbol ("caml_reperform", dbg);
+           transl env arg1; transl env arg2; transl env arg3],
+           dbg)
+
+  | Pperform | Pdls_get
+  | Patomic_exchange | Patomic_fetch_add | Patomic_load _
   | Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint
   | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint
   | Pintoffloat | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat

diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
@@ -312,12 +312,25 @@ let cfi_endproc () =
   if is_cfi_enabled () then
     emit_string "\t.cfi_endproc\n"
 
+let cfi_remember_state () =
+  if is_cfi_enabled () then
+    emit_string "\t.cfi_remember_state\n"
+
+let cfi_restore_state () =
+  if is_cfi_enabled () then
+    emit_string "\t.cfi_restore_state\n"
+
 let cfi_adjust_cfa_offset n =
   if is_cfi_enabled () then
   begin
     emit_string "\t.cfi_adjust_cfa_offset\t"; emit_int n; emit_string "\n";
   end
 
+let cfi_def_cfa_offset n =
+  if is_cfi_enabled () then begin
+    emit_string "\t.cfi_def_cfa_offset\t"; emit_int n; emit_string "\n";
+  end
+
 let cfi_offset ~reg ~offset =
   if is_cfi_enabled () then begin
     emit_string "\t.cfi_offset ";

diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
@@ -70,6 +70,9 @@ val cfi_startproc : unit -> unit
 val cfi_endproc : unit -> unit
 val cfi_adjust_cfa_offset : int -> unit
 val cfi_offset : reg:int -> offset:int -> unit
+val cfi_def_cfa_offset : int -> unit
+val cfi_remember_state : unit -> unit
+val cfi_restore_state : unit -> unit
 
 val binary_backend_available: bool ref
     (** Is a binary backend available.  If yes, we don't need

diff --git a/asmcomp/linear.ml b/asmcomp/linear.ml
@@ -49,6 +49,7 @@ let has_fallthrough = function
 
 type fundecl =
   { fun_name: string;
+    fun_args: Reg.Set.t;
     fun_body: instruction;
     fun_fast: bool;
     fun_dbg : Debuginfo.t;

diff --git a/asmcomp/linear.mli b/asmcomp/linear.mli
@@ -50,6 +50,7 @@ val invert_test: Mach.test -> Mach.test
 
 type fundecl =
   { fun_name: string;
+    fun_args: Reg.Set.t;
     fun_body: instruction;
     fun_fast: bool;
     fun_dbg : Debuginfo.t;

diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml
@@ -327,6 +327,7 @@ let fundecl f =
       fun_prologue_required
   in
   { fun_name = f.Mach.fun_name;
+    fun_args = Reg.set_of_array f.Mach.fun_args;
     fun_body;
     fun_fast = not (List.mem Cmm.Reduce_code_size f.Mach.fun_codegen_options);
     fun_dbg  = f.Mach.fun_dbg;

diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
@@ -49,7 +49,8 @@ type operation =
   | Itailcall_imm of { func : string; }
   | Iextcall of { func : string;
                   ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
-                  alloc : bool; }
+                  alloc : bool;
+                  stack_ofs : int; }
   | Istackoffset of int
   | Iload of Cmm.memory_chunk * Arch.addressing_mode * Asttypes.mutable_flag
   | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
@@ -61,6 +62,7 @@ type operation =
   | Iopaque
   | Ispecific of Arch.specific_operation
   | Ipoll of { return_label: Cmm.label option }
+  | Idls_get
 
 type instruction =
   { desc: instruction_desc;
@@ -148,6 +150,7 @@ let rec instr_iter f i =
 let operation_is_pure = function
   | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ | Ipoll _
+  | Idls_get
   | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) | Iopaque -> false
   | Ispecific sop -> Arch.operation_is_pure sop
   | _ -> true

diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
@@ -49,7 +49,8 @@ type operation =
   | Itailcall_imm of { func : string; }
   | Iextcall of { func : string;
                   ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
-                  alloc : bool; }
+                  alloc : bool;
+                  stack_ofs : int; }
   | Istackoffset of int
   | Iload of Cmm.memory_chunk * Arch.addressing_mode * Asttypes.mutable_flag
   | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
@@ -62,6 +63,7 @@ type operation =
   | Iopaque
   | Ispecific of Arch.specific_operation
   | Ipoll of { return_label: Cmm.label option }
+  | Idls_get
 
 type instruction =
   { desc: instruction_desc;

diff --git a/asmcomp/polling.ml b/asmcomp/polling.ml
@@ -259,7 +259,7 @@ let find_poll_alloc_or_calls instr =
             Iconst_symbol _ | Iextcall { alloc = false } | Istackoffset _ |
             Iload _ | Istore _ | Iintop _ | Iintop_imm _ | Ifloatofint |
             Iintoffloat | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf |
-            Iopaque | Ispecific _)-> None
+            Iopaque | Ispecific _ | Idls_get) -> None
       | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Icatch _ | Iexit _ |
         Itrywith _ | Iraise _ -> None
     in

diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
@@ -117,8 +117,10 @@ let operation d = function
   | Capply _ty -> "app" ^ location d
   | Cextcall(lbl, _ty_res, _ty_args, _alloc) ->
       Printf.sprintf "extcall \"%s\"%s" lbl (location d)
-  | Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
+  | Cload {memory_chunk; mutability} -> (
-  | Cload (c, Asttypes.Mutable) -> Printf.sprintf "load_mut %s" (chunk c)
+    match mutability with
+    | Asttypes.Immutable -> Printf.sprintf "load %s" (chunk memory_chunk)
+    | Asttypes.Mutable   -> Printf.sprintf "load_mut %s" (chunk memory_chunk))
   | Calloc -> "alloc" ^ location d
   | Cstore (c, init) ->
     let init =
@@ -156,6 +158,7 @@ let operation d = function
   | Craise k -> Lambda.raise_kind k ^ location d
   | Ccheckbound -> "checkbound" ^ location d
   | Copaque -> "opaque"
+  | Cdls_get -> "dls_get"
 
 let rec expr ppf = function
   | Cconst_int (n, _dbg) -> fprintf ppf "%i" n

diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
@@ -150,6 +150,7 @@ let operation op arg ppf res =
   | Iopaque -> fprintf ppf "opaque %a" reg arg.(0)
   | Ispecific op ->
       Arch.print_specific_operation reg op ppf arg
+  | Idls_get -> fprintf ppf "dls_get"
   | Ipoll { return_label } ->
       fprintf ppf "poll call";
       match return_label with

diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml
@@ -388,6 +388,7 @@ method schedule_fundecl f =
     let new_body = schedule f.fun_body 0 in
     clear_code_dag();
     { fun_name = f.fun_name;
+      fun_args = f.fun_args;
       fun_body = new_body;
       fun_fast = f.fun_fast;
       fun_dbg  = f.fun_dbg;

diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
@@ -67,14 +67,15 @@ let env_empty = {
 let oper_result_type = function
     Capply ty -> ty
   | Cextcall(_s, ty_res, _ty_args, _alloc) -> ty_res
-  | Cload (c, _) ->
+  | Cload {memory_chunk} ->
-      begin match c with
+      begin match memory_chunk with
       | Word_val -> typ_val
       | Single | Double -> typ_float
       | _ -> typ_int
       end
   | Calloc -> typ_val
   | Cstore (_c, _) -> typ_void
+  | Cdls_get -> typ_val
   | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi |
     Cand | Cor | Cxor | Clsl | Clsr | Casr |
     Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int
@@ -328,7 +329,8 @@ method is_simple_expr = function
       | 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 _ | Ccheckbound | Cdls_get ->
+          List.for_all self#is_simple_expr args
       end
   | Cassign _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _
   | Ctrywith _ -> false
@@ -366,8 +368,9 @@ method effects_of exp =
       | Calloc -> EC.none
       | Cstore _ -> EC.effect_only Effect.Arbitrary
       | Craise _ | Ccheckbound -> EC.effect_only Effect.Raise
-      | Cload (_, Asttypes.Immutable) -> EC.none
+      | Cload {mutability = Asttypes.Immutable} -> EC.none
-      | Cload (_, Asttypes.Mutable) -> EC.coeffect_only Coeffect.Read_mutable
+      | Cload {mutability = Asttypes.Mutable} | Cdls_get ->
+          EC.coeffect_only Coeffect.Read_mutable
       | 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 _ ->
@@ -425,8 +428,8 @@ method mark_instr = function
       | Lambda.Raise_regular
       | Lambda.Raise_reraise ->
           (* PR#6239 *)
-          (* caml_stash_backtrace; we #mark_call rather than
+        (* caml_stash_backtrace; we #mark_call rather than
-             #mark_c_tailcall to get a good stack backtrace *)
+           #mark_c_tailcall to get a good stack backtrace *)
           self#mark_call
     end
   | Itrywith _ ->
@@ -442,10 +445,10 @@ method select_operation op args _dbg =
   | (Capply _, _) ->
     (Icall_ind, args)
   | (Cextcall(func, ty_res, ty_args, alloc), _) ->
-    Iextcall { func; ty_res; ty_args; alloc; }, args
+    Iextcall { func; alloc; ty_res; ty_args; stack_ofs = -1}, args
-  | (Cload (chunk, mut), [arg]) ->
+  | (Cload {memory_chunk; mutability}, [arg]) ->
-      let (addr, eloc) = self#select_addressing chunk arg in
+      let (addr, eloc) = self#select_addressing memory_chunk arg in
-      (Iload(chunk, addr, mut), [eloc])
+      (Iload(memory_chunk, addr, mutability), [eloc])
   | (Cstore (chunk, init), [arg1; arg2]) ->
       let (addr, eloc) = self#select_addressing chunk arg1 in
       let is_assign =
@@ -461,6 +464,7 @@ method select_operation op args _dbg =
         (Istore(chunk, addr, is_assign), [arg2; eloc])
         (* Inversion addr/datum in Istore *)
       end
+  | (Cdls_get, _) -> Idls_get, args
   | (Calloc, _) -> (Ialloc {bytes = 0; dbginfo = []}), args
   | (Caddi, _) -> self#select_arith_comm Iadd args
   | (Csubi, _) -> self#select_arith Isub args
@@ -712,12 +716,13 @@ method emit_expr (env:environment) exp =
               self#insert_debug env (Iop new_op) dbg loc_arg loc_res;
               self#insert_move_results env loc_res rd stack_ofs;
               Some rd
-          | Iextcall { ty_args; _} ->
+          | Iextcall r ->
               let (loc_arg, stack_ofs) =
-                self#emit_extcall_args env ty_args new_args in
+                self#emit_extcall_args env r.ty_args new_args in
               let rd = self#regs_for ty in
               let loc_res =
-                self#insert_op_debug env new_op dbg
+                self#insert_op_debug env
+                  (Iextcall {r with stack_ofs = stack_ofs}) dbg
                   loc_arg (Proc.loc_external_results (Reg.typv rd)) in
               self#insert_move_results env loc_res rd stack_ofs;
               Some rd

diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml
@@ -76,7 +76,9 @@ module Make(I:I) = struct
   let mk_let_cell id str ind body =
     let dbg = Debuginfo.none in
     let cell =
-      Cop(Cload (Word_int, Asttypes.Mutable),
+      Cop(Cload {memory_chunk=Word_int;
+                 mutability=Asttypes.Mutable;
+                 is_atomic=false},
         [Cop(Cadda,[str;Cconst_int(Arch.size_int*ind, dbg)], dbg)],
         dbg) in
     Clet(id, cell, body)

diff --git a/asmcomp/x86_ast.mli b/asmcomp/x86_ast.mli
@@ -208,6 +208,10 @@ type asm_line =
   | Cfi_adjust_cfa_offset of int
   | Cfi_endproc
   | Cfi_startproc
+  | Cfi_remember_state
+  | Cfi_restore_state
+  | Cfi_def_cfa_register of string
+  | Cfi_def_cfa_offset of int
   | File of int * string (* (file_num, file_name) *)
   | Indirect_symbol of string
   | Loc of int * int * int (* (file_num, line, col) *)

diff --git a/asmcomp/x86_dsl.ml b/asmcomp/x86_dsl.ml
@@ -48,8 +48,10 @@ let ah  = Reg8H AH
 let cl  = Reg8L RCX
 let ax  = Reg16 RAX
 let rax = Reg64 RAX
+let rdx = Reg64 RDX
 let r10 = Reg64 R10
 let r11 = Reg64 R11
+let r12 = Reg64 R12
 let r13 = Reg64 R13
 let r14 = Reg64 R14
 let r15 = Reg64 R15
@@ -84,6 +86,10 @@ module D = struct
   let cfi_adjust_cfa_offset n = directive (Cfi_adjust_cfa_offset n)
   let cfi_endproc () = directive Cfi_endproc
   let cfi_startproc () = directive Cfi_startproc
+  let cfi_remember_state () = directive Cfi_remember_state
+  let cfi_restore_state () = directive Cfi_restore_state
+  let cfi_def_cfa_register reg = directive (Cfi_def_cfa_register reg)
+  let cfi_def_cfa_offset n = directive (Cfi_def_cfa_offset n)
   let comment s = directive (Comment s)
   let data () = section [ ".data" ] None []
   let extrn s ptr = directive (External (s, ptr))

diff --git a/asmcomp/x86_dsl.mli b/asmcomp/x86_dsl.mli
@@ -37,8 +37,10 @@ val ah: arg
 val cl: arg
 val ax: arg
 val rax: arg
+val rdx: arg
 val r10: arg
 val r11: arg
+val r12: arg
 val r13: arg
 val r14: arg
 val r15: arg
@@ -74,6 +76,10 @@ module D : sig
   val cfi_adjust_cfa_offset: int -> unit
   val cfi_endproc: unit -> unit
   val cfi_startproc: unit -> unit
+  val cfi_remember_state: unit -> unit
+  val cfi_restore_state: unit -> unit
+  val cfi_def_cfa_register: string -> unit
+  val cfi_def_cfa_offset: int -> unit
   val comment: string -> unit
   val data: unit -> unit
   val extrn: string -> data_type -> unit

diff --git a/asmcomp/x86_gas.ml b/asmcomp/x86_gas.ml
@@ -279,6 +279,10 @@ let print_line b = function
   | Cfi_adjust_cfa_offset n -> bprintf b "\t.cfi_adjust_cfa_offset %d" n
   | Cfi_endproc -> bprintf b "\t.cfi_endproc"
   | Cfi_startproc -> bprintf b "\t.cfi_startproc"
+  | Cfi_remember_state -> bprintf b "\t.cfi_remember_state"
+  | Cfi_restore_state -> bprintf b "\t.cfi_restore_state"
+  | Cfi_def_cfa_register reg -> bprintf b "\t.cfi_def_cfa_register %%%s" reg
+  | Cfi_def_cfa_offset n -> bprintf b "\t.cfi_def_cfa_offset %d" n
   | File (file_num, file_name) ->
       bprintf b "\t.file\t%d\t\"%s\""
         file_num (X86_proc.string_of_string_literal file_name)

diff --git a/asmcomp/x86_masm.ml b/asmcomp/x86_masm.ml
@@ -239,6 +239,10 @@ let print_line b = function
   | Cfi_adjust_cfa_offset _
   | Cfi_endproc
   | Cfi_startproc
+  | Cfi_def_cfa_register _
+  | Cfi_def_cfa_offset _
+  | Cfi_remember_state
+  | Cfi_restore_state
   | File _
   | Indirect_symbol _
   | Loc _

diff --git a/boot/ocamlc b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
@@ -109,7 +109,8 @@ let rec is_tailcall = function
    from the tail call optimization? *)
 
 let preserve_tailcall_for_prim = function
-  | Popaque | Psequor | Psequand ->
+  | Popaque | Psequor | Psequand
+  | Prunstack | Pperform | Presume | Preperform ->
       true
   | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _
   | Pmakeblock _ | Pfield _ | Pfield_computed | Psetfield _
@@ -130,7 +131,9 @@ let preserve_tailcall_for_prim = function
   | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_set_16 _ | Pbytes_set_32 _
   | Pbytes_set_64 _ | Pbigstring_load_16 _ | Pbigstring_load_32 _
   | Pbigstring_load_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _
-  | Pbigstring_set_64 _ | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer ->
+  | Pbigstring_set_64 _ | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer
+  | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
+  | Pdls_get ->
       false
 
 (* Add a Kpop N instruction in front of a continuation *)
@@ -369,6 +372,8 @@ let compunit_name = ref ""
 
 let max_stack_used = ref 0
 
+let check_stack sz =
+  if sz > !max_stack_used then max_stack_used := sz
 
 (* Sequence of string tests *)
 
@@ -383,21 +388,25 @@ let comp_bint_primitive bi suff args =
                 | Pint64 -> "caml_int64_" in
   Kccall(pref ^ suff, List.length args)
 
-let comp_primitive p args =
+let comp_primitive p sz args =
+  check_stack sz;
   match p with
     Pgetglobal id -> Kgetglobal id
   | Psetglobal id -> Ksetglobal id
   | Pintcomp cmp -> Kintcomp cmp
   | Pcompare_ints -> Kccall("caml_int_compare", 2)
   | Pcompare_floats -> Kccall("caml_float_compare", 2)
   | Pcompare_bints bi -> comp_bint_primitive bi "compare" args
-  | Pfield n -> Kgetfield n
+  | Pfield(n, _ptr, _mut) -> Kgetfield n
   | Pfield_computed -> Kgetvectitem
   | Psetfield(n, _ptr, _init) -> Ksetfield n
   | Psetfield_computed(_ptr, _init) -> Ksetvectitem
   | Psetfloatfield (n, _init) -> Ksetfloatfield n
   | Pduprecord _ -> Kccall("caml_obj_dup", 1)
   | Pccall p -> Kccall(p.prim_name, p.prim_arity)
+  | Pperform ->
+      check_stack (sz + 4);
+      Kperform
   | Pnegint -> Knegint
   | Paddint -> Kaddint
   | Psubint -> Ksubint
@@ -508,9 +517,15 @@ let comp_primitive p args =
   | Pint_as_pointer -> Kccall("caml_int_as_pointer", 1)
   | Pbytes_to_string -> Kccall("caml_string_of_bytes", 1)
   | Pbytes_of_string -> Kccall("caml_bytes_of_string", 1)
+  | Patomic_load _ -> Kccall("caml_atomic_load", 1)
+  | Patomic_exchange -> Kccall("caml_atomic_exchange", 2)
+  | Patomic_cas -> Kccall("caml_atomic_cas", 3)
+  | Patomic_fetch_add -> Kccall("caml_atomic_fetch_add", 2)
+  | Pdls_get -> Kccall("caml_domain_dls_get", 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. *)
+  | Prunstack | Presume | Preperform
   | Pignore | Popaque
   | Pnot | Psequand | Psequor
   | Praise _
@@ -538,7 +553,7 @@ module Storer =
    Result = list of instructions that evaluate exp, then perform cont. *)
 
 let rec comp_expr env exp sz cont =
-  if sz > !max_stack_used then max_stack_used := sz;
+  check_stack sz;
   match exp with
     Lvar id | Lmutvar id ->
       begin try
@@ -754,6 +769,25 @@ let rec comp_expr env exp sz cont =
                  (Kmakeblock(List.length args, 0) ::
                   Kccall("caml_make_array", 1) :: cont)
       end
+  | Lprim((Presume|Prunstack), args, _) ->
+      let nargs = List.length args - 1 in
+      assert (nargs = 2);
+      (* Resume itself only pushes 3 words, but perform adds another *)
+      check_stack (sz + 4);
+      if is_tailcall cont then
+        comp_args env args sz
+          (Kresumeterm(sz + nargs) :: discard_dead_code cont)
+      else
+        comp_args env args sz (Kresume :: cont)
+  | Lprim(Preperform, args, _) ->
+      let nargs = List.length args - 1 in
+      assert (nargs = 2);
+      check_stack (sz + 3);
+      if is_tailcall cont then
+        comp_args env args sz
+          (Kreperformterm(sz + nargs) :: discard_dead_code cont)
+      else
+        fatal_error "Reperform used in non-tail position"
   | Lprim (Pduparray (kind, mutability),
            [Lprim (Pmakearray (kind',_),args,_)], loc) ->
       assert (kind = kind');
@@ -769,7 +803,8 @@ let rec comp_expr env exp sz cont =
   | Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) ->
       let p = Pintcomp (swap_integer_comparison c)
       and args = [k ; arg] in
-      comp_args env args sz (comp_primitive p args :: cont)
+      let nargs = List.length args - 1 in
+      comp_args env args sz (comp_primitive p (sz + nargs - 1) args :: cont)
   | Lprim (Pfloatcomp cmp, args, _) ->
       let cont =
         match cmp with
@@ -792,7 +827,8 @@ let rec comp_expr env exp sz cont =
       let cont = add_pseudo_event loc !compunit_name cont in
       comp_args env args sz (Kgetfloatfield n :: cont)
   | Lprim(p, args, _) ->
-      comp_args env args sz (comp_primitive p args :: cont)
+      let nargs = List.length args - 1 in
+      comp_args env args sz (comp_primitive p (sz + nargs - 1) args :: cont)
   | Lstaticcatch (body, (i, vars) , handler) ->
       let vars = List.map fst vars in
       let nvars = List.length vars in

diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
@@ -300,6 +300,10 @@ let emit_instr = function
   | Kgetpubmet tag -> out opGETPUBMET; out_int tag; out_int 0
   | Kgetdynmet -> out opGETDYNMET
   | Kevent ev -> record_event ev
+  | Kperform -> out opPERFORM
+  | Kresume -> out opRESUME
+  | Kresumeterm n -> out opRESUMETERM; out_int n
+  | Kreperformterm n -> out opREPERFORMTERM; out_int n
   | Kstop -> out opSTOP
 
 (* Emission of a list of instructions. Include some peephole optimization. *)

diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
@@ -104,6 +104,10 @@ type instruction =
   | Kgetpubmet of int
   | Kgetdynmet
   | Kevent of debug_event
+  | Kperform
+  | Kresume
+  | Kresumeterm of int
+  | Kreperformterm of int
   | Kstop
 
 let immed_min = -0x40000000

diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
@@ -124,6 +124,10 @@ type instruction =
   | Kgetpubmet of int
   | Kgetdynmet
   | Kevent of debug_event
+  | Kperform
+  | Kresume
+  | Kresumeterm of int
+  | Kreperformterm of int
   | Kstop
 
 val immed_min: int

diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
@@ -100,6 +100,10 @@ let instruction ppf = function
   | Kgetmethod -> fprintf ppf "\tgetmethod"
   | Kgetpubmet n -> fprintf ppf "\tgetpubmet %i" n
   | Kgetdynmet -> fprintf ppf "\tgetdynmet"
+  | Kperform -> fprintf ppf "\tperform"
+  | Kresume -> fprintf ppf "\tresume"
+  | Kresumeterm n -> fprintf ppf "\tresumeterm %i" n
+  | Kreperformterm n -> fprintf ppf "\treperformterm %i" n
   | Kstop -> fprintf ppf "\tstop"
   | Kevent ev -> fprintf ppf "\tevent \"%s\" %i-%i"
                          ev.ev_loc.Location.loc_start.Lexing.pos_fname

diff --git a/configure b/configure
diff --git a/configure.ac b/configure.ac
@@ -55,7 +55,8 @@ toolchain="cc"
 profinfo=false
 profinfo_width=0
 extralibs=
-instrumented_runtime=false
+instrumented_runtime=true
+force_instrumented_runtime=false
 instrumented_runtime_libs=""
 bootstrapping_flexdll=false
 
@@ -168,8 +169,7 @@ AC_SUBST([flexlink_flags])
 AC_SUBST([PACKLD])
 AC_SUBST([stdlib_manpages])
 AC_SUBST([compute_deps])
-AC_SUBST([naked_pointers])
+AC_SUBST([force_instrumented_runtime])
-AC_SUBST([naked_pointers_checker])
 
 ## Generated files
 
@@ -300,13 +300,9 @@ AC_ARG_ENABLE([frame-pointers],
   [AS_HELP_STRING([--enable-frame-pointers],
     [use frame pointers in runtime and generated code])])
 
-AC_ARG_ENABLE([naked-pointers],
+AC_ARG_ENABLE([naked-pointers], [],
-  [AS_HELP_STRING([--disable-naked-pointers],
+  [AC_MSG_ERROR([Naked pointers are not allowed in OCaml Multicore.])],
-    [do not allow naked pointers])])
+  [AC_DEFINE([NO_NAKED_POINTERS])])
-
-AC_ARG_ENABLE([naked-pointers-checker],
-  [AS_HELP_STRING([--enable-naked-pointers-checker],
-    [enable the naked pointers checker])])
 
 AC_ARG_ENABLE([spacetime], [],
   [AC_MSG_ERROR([spacetime profiling was deleted in OCaml 4.12.])],
@@ -340,6 +336,10 @@ AC_ARG_ENABLE([flambda-invariants],
   [AS_HELP_STRING([--enable-flambda-invariants],
     [enable invariants checks in flambda])])
 
+AC_ARG_ENABLE([force-instrumented-runtime],
+  [AS_HELP_STRING([--force-instrumented-runtime],
+    [force the usage of the instrumented runtime])])
+
 AC_ARG_ENABLE([cmm-invariants],
   [AS_HELP_STRING([--enable-cmm-invariants],
     [enable invariants checks in Cmm])])
@@ -526,7 +526,9 @@ AS_CASE([$ocaml_cv_cc_vendor],
   [sunc-*],
     [CPP="$CC -E -Qn"], # suppress generation of Sun PRO ident string
   [msvc-*],
-    [CPP="$CC -nologo -EP"])
+    [CPP="$CC -nologo -EP"],
+#  TODO: why can we not use $CPP in multicore, fix this?
+  [CPP="$CC -E -P"])
 
 # Libraries to build depending on the host
 
@@ -875,6 +877,10 @@ AC_CHECK_HEADER([dirent.h], [AC_DEFINE([HAS_DIRENT])], [],
 AC_CHECK_HEADER([sys/select.h], [AC_DEFINE([HAS_SYS_SELECT_H])], [],
   [#include <sys/types.h>])
 
+AC_CHECK_HEADER([stdatomic.h], [AC_DEFINE([HAS_STDATOMIC_H])])
+
+AC_CHECK_HEADER([sys/mman.h], [AC_DEFINE([HAS_SYS_MMAN_H])])
+
 # Checks for types
 
 ## off_t
@@ -1351,6 +1357,10 @@ AS_CASE([$host],
   ]
 )
 
+AS_IF([test "x$enable_force_instrumented_runtime" = "xyes"],
+  [force_instrumented_runtime=true]
+)
+
 # The instrumented runtime is built by default
 # if the proper clock source is found.
 # If asked via --enable-instrumented-runtime, configuration fails if the proper
@@ -1804,6 +1814,7 @@ AS_CASE([$enable_systhreads,$enable_unix_lib],
     [*-*-mingw32|*-pc-windows],
       [systhread_support=true
       otherlibraries="$otherlibraries systhreads"
+      PTHREAD_LIBS="-lpthread"
       AC_MSG_NOTICE([the Win32 threads library is supported])],
     [AX_PTHREAD(
       [systhread_support=true
@@ -1845,30 +1856,6 @@ AS_IF([test x"$enable_frame_pointers" = "xyes"],
   [AC_MSG_NOTICE([not using frame pointers])
   frame_pointers=false])
 
-## No naked pointers
-
-AS_IF([test x"$enable_naked_pointers" = "xno" ],
-  [naked_pointers=false
-   AC_DEFINE([NO_NAKED_POINTERS])],
-  [naked_pointers=true])
-
-AS_IF([test x"$enable_naked_pointers_checker" = "xyes" ],
-  [AS_IF([test x"$enable_naked_pointers" = "xno" ],
-         [AC_MSG_ERROR(m4_normalize([
-               --enable-naked-pointers-checker and --disable-naked-pointers
-               are incompatible]))])
-   AS_CASE(["$arch","$system"],
-    [amd64,linux|amd64,macosx \
-    |amd64,openbsd|amd64,win64 \
-    |amd64,freebsd|amd64,solaris \
-    |arm64,linux|arm64,macosx],
-      [naked_pointers_checker=true
-      AC_DEFINE([NAKED_POINTERS_CHECKER])],
-    [*],
-      [AC_MSG_ERROR([naked pointers checker not supported on this platform])]
-  )],
-  [naked_pointers_checker=false])
-
 ## Check for mmap support for huge pages and contiguous heap
 OCAML_MMAP_SUPPORTS_HUGE_PAGES
 
@@ -1974,15 +1961,17 @@ ocamlc_cflags="$common_cflags $sharedlib_cflags \$(CFLAGS)"
 ocamlc_cppflags="$common_cppflags \$(CPPFLAGS)"
 cclibs="$cclibs $mathlib"
 
+AC_CHECK_LIB(execinfo, backtrace, cclibs="$cclibs -lexecinfo",[])
+
 AS_CASE([$host],
   [*-*-mingw32],
-    [bytecclibs="-lws2_32 -lversion"
+    [bytecclibs="-lws2_32 -lversion -lpthread -lgcc_eh -lDbgHelp"
-    nativecclibs="-lws2_32 -lversion"],
+    nativecclibs="-lws2_32 -lversion -lpthread -lgcc_eh -lDbgHelp"],
   [*-pc-windows],
     [bytecclibs="advapi32.lib ws2_32.lib version.lib"
     nativecclibs="advapi32.lib ws2_32.lib version.lib"],
   [bytecclibs="$cclibs $DLLIBS $PTHREAD_LIBS"
-  nativecclibs="$cclibs $DLLIBS"])
+  nativecclibs="$cclibs $DLLIBS $PTHREAD_LIBS"])
 
 AS_IF([test x"$libdir" = x'${exec_prefix}/lib'],
   [libdir="$libdir"/ocaml])

diff --git a/lambda/lambda.ml b/lambda/lambda.ml
@@ -48,14 +48,18 @@ type primitive =
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
-  | Pfield of int
+  | Pfield of int * immediate_or_pointer * mutable_flag
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
-  (* Force lazy values *)
+  (* Context switches *)
+  | Prunstack
+  | Pperform
+  | Presume
+  | Preperform
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
@@ -138,8 +142,15 @@ type primitive =
   | Pbbswap of boxed_integer
   (* Integer to external pointer *)
   | Pint_as_pointer
+  (* Atomic operations *)
+  | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
+  | Patomic_exchange
+  | Patomic_cas
+  | Patomic_fetch_add
   (* Inhibition of optimisation *)
   | Popaque
+  (* Fetching domain-local state *)
+  | Pdls_get
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge
@@ -649,7 +660,8 @@ let rec transl_address loc = function
       then Lprim(Pgetglobal id, [], loc)
       else Lvar id
   | Env.Adot(addr, pos) ->
-      Lprim(Pfield pos, [transl_address loc addr], loc)
+      Lprim(Pfield(pos, Pointer, Immutable),
+                   [transl_address loc addr], loc)
 
 let transl_path find loc env path =
   match find path env with

diff --git a/lambda/lambda.mli b/lambda/lambda.mli
@@ -54,13 +54,18 @@ type primitive =
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
-  | Pfield of int
+  | Pfield of int * immediate_or_pointer * mutable_flag
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
+  (* Context switches *)
+  | Prunstack
+  | Pperform
+  | Presume
+  | Preperform
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
@@ -147,8 +152,15 @@ type primitive =
   | Pbbswap of boxed_integer
   (* Integer to external pointer *)
   | Pint_as_pointer
+  (* Atomic operations *)
+  | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
+  | Patomic_exchange
+  | Patomic_cas
+  | Patomic_fetch_add
   (* Inhibition of optimisation *)
   | Popaque
+  (* Fetching domain-local state *)
+  | Pdls_get
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

diff --git a/lambda/matching.ml b/lambda/matching.ml
@@ -1766,7 +1766,8 @@ let get_expr_args_constr ~scopes head (arg, _mut) rem =
       if pos > last_pos then
         argl
       else
-        (Lprim (Pfield pos, [ arg ], loc), binding_kind) :: make_args (pos + 1)
+        (Lprim (Pfield (pos, Pointer, Immutable), [ arg ], loc),
+               binding_kind) :: make_args (pos + 1)
     in
     make_args first_pos
   in
@@ -1794,7 +1795,7 @@ let get_expr_args_variant_constant = drop_expr_arg
 
 let get_expr_args_variant_nonconst ~scopes head (arg, _mut) rem =
   let loc = head_loc ~scopes head in
-  (Lprim (Pfield 1, [ arg ], loc), Alias) :: rem
+  (Lprim (Pfield (1, Pointer, Immutable), [ arg ], loc), Alias) :: rem
 
 let divide_variant ~scopes row ctx { cases = cl; args; default = def } =
   let rec divide = function
@@ -1876,12 +1877,12 @@ let get_mod_field modname field =
 
 let code_force_lazy_block = get_mod_field "CamlinternalLazy" "force_lazy_block"
 
-let code_force_lazy = get_mod_field "CamlinternalLazy" "force"
+let code_force_lazy = get_mod_field "CamlinternalLazy" "force_gen"
 
 (* inline_lazy_force inlines the beginning of the code of Lazy.force. When
    the value argument is tagged as:
    - forward, take field 0
-   - lazy, call the primitive that forces (without testing again the tag)
+   - lazy || forcing, call the primitive that forces
    - anything else, return it
 
    Using Lswitch below relies on the fact that the GC does not shortcut
@@ -1892,8 +1893,11 @@ let inline_lazy_force_cond arg loc =
   let idarg = Ident.create_local "lzarg" in
   let varg = Lvar idarg in
   let tag = Ident.create_local "tag" in
-  let tag_var = Lvar tag in
   let force_fun = Lazy.force code_force_lazy_block in
+  let test_tag t =
+    Lprim(Pintcomp Ceq, [Lvar tag; Lconst(Const_base(Const_int t))], loc)
+  in
+
   Llet
     ( Strict,
       Pgenval,
@@ -1905,18 +1909,16 @@ let inline_lazy_force_cond arg loc =
           tag,
           Lprim (Pccall prim_obj_tag, [ varg ], loc),
           Lifthenelse
-            (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
+            ( (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
-            ( Lprim
+              test_tag Obj.forward_tag,
-                ( Pintcomp Ceq,
+              Lprim (Pfield (0, Pointer, Mutable), [ varg ], loc),
-                  [ tag_var; Lconst (Const_base (Const_int Obj.forward_tag)) ],
-                  loc ),
-              Lprim (Pfield 0, [ varg ], loc),
               Lifthenelse
-                (* if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
+                (
-                ( Lprim
+                  (* ... if tag == Obj.lazy_tag || tag == Obj.forcing_tag then
-                    ( Pintcomp Ceq,
+                         Lazy.force varg
-                      [ tag_var; Lconst (Const_base (Const_int Obj.lazy_tag)) ],
+                       else ... *)
-                      loc ),
+                  Lprim (Psequor,
+                       [test_tag Obj.lazy_tag; test_tag Obj.forcing_tag], loc),
                   Lapply
                     { ap_tailcall = Default_tailcall;
                       ap_loc = loc;
@@ -1941,14 +1943,26 @@ let inline_lazy_force_switch arg loc =
         ( Lprim (Pisint, [ varg ], loc),
           varg,
           Lswitch
-            ( varg,
+            ( Lprim (Pccall prim_obj_tag, [ varg ], loc),
-              { sw_numconsts = 0;
+              { sw_numblocks = 0;
-                sw_consts = [];
+                sw_blocks = [];
-                sw_numblocks = 256;
+                sw_numconsts = 256;
                 (* PR#6033 - tag ranges from 0 to 255 *)
-                sw_blocks =
+                sw_consts =
-                  [ (Obj.forward_tag, Lprim (Pfield 0, [ varg ], loc));
+                  [ (Obj.forward_tag, Lprim (Pfield(0, Pointer, Mutable),
-                    ( Obj.lazy_tag,
+                                             [ varg ], loc));
+
+                    (Obj.lazy_tag,
+                      Lapply
+                        { ap_tailcall = Default_tailcall;
+                          ap_loc = loc;
+                          ap_func = force_fun;
+                          ap_args = [varg];
+                          ap_inlined = Default_inline;
+                          ap_specialised = Default_specialise
+                        } );
+
+                    (Obj.forcing_tag,
                       Lapply
                         { ap_tailcall = Default_tailcall;
                           ap_loc = loc;
@@ -1972,7 +1986,7 @@ let inline_lazy_force arg loc =
       { ap_tailcall = Default_tailcall;
         ap_loc = loc;
         ap_func = Lazy.force code_force_lazy;
-        ap_args = [ arg ];
+        ap_args = [ Lconst (Const_base (Const_int 0)); arg ];
         ap_inlined = Default_inline;
         ap_specialised = Default_specialise
       }
@@ -2009,7 +2023,8 @@ let get_expr_args_tuple ~scopes head (arg, _mut) rem =
     if pos >= arity then
       rem
     else
-      (Lprim (Pfield pos, [ arg ], loc), Alias) :: make_args (pos + 1)
+      (Lprim (Pfield (pos, Pointer, Immutable), [ arg ], loc),
+             Alias) :: make_args (pos + 1)
   in
   make_args 0
 
@@ -2049,14 +2064,16 @@ let get_expr_args_record ~scopes head (arg, _mut) rem =
       rem
     else
       let lbl = all_labels.(pos) in
+      let ptr = Typeopt.maybe_pointer_type head.pat_env lbl.lbl_arg in
       let access =
         match lbl.lbl_repres with
         | Record_regular
         | Record_inlined _ ->
-            Lprim (Pfield lbl.lbl_pos, [ arg ], loc)
+            Lprim (Pfield (lbl.lbl_pos, ptr, lbl.lbl_mut), [ arg ], loc)
         | Record_unboxed _ -> arg
         | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [ arg ], loc)
-        | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [ arg ], loc)
+        | Record_extension _ ->
+            Lprim (Pfield (lbl.lbl_pos + 1, ptr, lbl.lbl_mut), [ arg ], loc)
       in
       let str =
         match lbl.lbl_mut with
@@ -2802,7 +2819,8 @@ let combine_constructor loc arg pat_env cstr partial ctx def
                       (Lprim (Pintcomp Ceq, [ Lvar tag; ext ], loc), act, rem))
                   nonconsts default
               in
-              Llet (Alias, Pgenval, tag, Lprim (Pfield 0, [ arg ], loc), tests)
+              Llet (Alias, Pgenval, tag,
+                    Lprim (Pfield (0, Pointer, Immutable), [ arg ], loc), tests)
         in
         List.fold_right
           (fun (path, act) rem ->
@@ -2897,7 +2915,7 @@ let call_switcher_variant_constr loc fail arg int_lambda_list =
     ( Alias,
       Pgenval,
       v,
-      Lprim (Pfield 0, [ arg ], loc),
+      Lprim (Pfield (0, Pointer, Immutable), [ arg ], loc),
       call_switcher loc fail (Lvar v) min_int max_int int_lambda_list )
 
 let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats)

diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml
@@ -156,7 +156,14 @@ let primitive ppf = function
       fprintf ppf "makeblock %i%a" tag block_shape shape
   | Pmakeblock(tag, Mutable, shape) ->
       fprintf ppf "makemutable %i%a" tag block_shape shape
-  | Pfield n -> fprintf ppf "field %i" n
+  | Pfield(n, ptr, mut) ->
+      let instr =
+        match ptr, mut with
+        | Immediate, _ -> "field_int "
+        | Pointer, Mutable -> "field_mut "
+        | Pointer, Immutable -> "field_imm "
+      in
+      fprintf ppf "%s%i" instr n
   | Pfield_computed -> fprintf ppf "field_computed"
   | Psetfield(n, ptr, init) ->
       let instr =
@@ -194,6 +201,10 @@ let primitive ppf = function
       in
       fprintf ppf "setfloatfield%s %i" init n
   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
+  | Prunstack -> fprintf ppf "runstack"
+  | Pperform -> fprintf ppf "perform"
+  | Presume -> fprintf ppf "resume"
+  | Preperform -> fprintf ppf "reperform"
   | Pccall p -> fprintf ppf "%s" p.prim_name
   | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
   | Psequand -> fprintf ppf "&&"
@@ -266,14 +277,14 @@ let primitive ppf = function
   | Paddbint bi -> print_boxed_integer "add" ppf bi
   | Psubbint bi -> print_boxed_integer "sub" ppf bi
   | Pmulbint bi -> print_boxed_integer "mul" ppf bi
-  | Pdivbint { size = bi; is_safe = Safe } ->
+  | Pdivbint { size; is_safe = Safe } ->
-      print_boxed_integer "div" ppf bi
+      print_boxed_integer "div" ppf size
-  | Pdivbint { size = bi; is_safe = Unsafe } ->
+  | Pdivbint { size; is_safe = Unsafe } ->
-      print_boxed_integer "div_unsafe" ppf bi
+      print_boxed_integer "div_unsafe" ppf size
-  | Pmodbint { size = bi; is_safe = Safe } ->
+  | Pmodbint { size; is_safe = Safe } ->
-      print_boxed_integer "mod" ppf bi
+      print_boxed_integer "mod" ppf size
-  | Pmodbint { size = bi; is_safe = Unsafe } ->
+  | Pmodbint { size; is_safe = Unsafe } ->
-      print_boxed_integer "mod_unsafe" ppf bi
+      print_boxed_integer "mod_unsafe" ppf size
   | Pandbint bi -> print_boxed_integer "and" ppf bi
   | Porbint bi -> print_boxed_integer "or" ppf bi
   | Pxorbint bi -> print_boxed_integer "xor" ppf bi
@@ -339,7 +350,15 @@ let primitive ppf = function
   | Pbswap16 -> fprintf ppf "bswap16"
   | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
   | Pint_as_pointer -> fprintf ppf "int_as_pointer"
+  | Patomic_load {immediate_or_pointer} ->
+      (match immediate_or_pointer with
+        | Immediate -> fprintf ppf "atomic_load_imm"
+        | Pointer -> fprintf ppf "atomic_load_ptr")
+  | Patomic_exchange -> fprintf ppf "atomic_exchange"
+  | Patomic_cas -> fprintf ppf "atomic_cas"
+  | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add"
   | Popaque -> fprintf ppf "opaque"
+  | Pdls_get -> fprintf ppf "dls_get"
 
 let name_of_primitive = function
   | Pbytes_of_string -> "Pbytes_of_string"
@@ -442,7 +461,19 @@ let name_of_primitive = function
   | Pbswap16 -> "Pbswap16"
   | Pbbswap _ -> "Pbbswap"
   | Pint_as_pointer -> "Pint_as_pointer"
+  | Patomic_load {immediate_or_pointer} ->
+      (match immediate_or_pointer with
+        | Immediate -> "atomic_load_imm"
+        | Pointer -> "atomic_load_ptr")
+  | Patomic_exchange -> "Patomic_exchange"
+  | Patomic_cas -> "Patomic_cas"
+  | Patomic_fetch_add -> "Patomic_fetch_add"
   | Popaque -> "Popaque"
+  | Prunstack -> "Prunstack"
+  | Presume -> "Presume"
+  | Pperform -> "Pperform"
+  | Preperform -> "Preperform"
+  | Pdls_get -> "Pdls_get"
 
 let function_attribute ppf t =
   if t.is_a_functor then

diff --git a/lambda/simplif.ml b/lambda/simplif.ml
@@ -42,7 +42,7 @@ let rec eliminate_ref id = function
   | Lletrec(idel, e2) ->
       Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
               eliminate_ref id e2)
-  | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id ->
+  | Lprim(Pfield (0, _, _), [Lvar v], _) when Ident.same v id ->
       Lmutvar id
   | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id ->
       Lassign(id, eliminate_ref id e)

diff --git a/lambda/tmc.ml b/lambda/tmc.ml
@@ -869,6 +869,12 @@ let rec choice ctx t =
     | Pignore
     | Pcompare_ints | Pcompare_floats | Pcompare_bints _
 
+    (* we don't handle effect or DLS primitives *)
+    | Prunstack | Pperform | Presume | Preperform | Pdls_get
+
+    (* we don't handle atomic primitives *)
+    | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
+
     (* we don't handle array indices as destinations yet *)
     | (Pmakearray _ | Pduparray _)
 

diff --git a/lambda/translclass.ml b/lambda/translclass.ml
@@ -62,7 +62,8 @@ let mkappl (func, args) =
 let lsequence l1 l2 =
   if l2 = lambda_unit then l1 else Lsequence(l1, l2)
 
-let lfield v i = Lprim(Pfield i, [Lvar v], Loc_unknown)
+let lfield v i = Lprim(Pfield (i, Pointer, Mutable),
+                       [Lvar v], Loc_unknown)
 
 let transl_label l = share (Const_immstring l)
 
@@ -133,7 +134,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl =
       let env =
         match envs with None -> []
         | Some envs ->
-            [Lprim(Pfield (List.length inh_init + 1),
+            [Lprim(Pfield (List.length inh_init + 1, Pointer, Mutable),
                    [Lvar envs],
                    Loc_unknown)]
       in
@@ -278,8 +279,10 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl =
       | (_, path_lam, obj_init)::inh_init ->
           (inh_init,
            Llet (Strict, Pgenval, obj_init,
-                 mkappl(Lprim(Pfield 1, [path_lam], Loc_unknown), Lvar cla ::
+                 mkappl(Lprim(Pfield (1, Pointer, Mutable),
-                        if top then [Lprim(Pfield 3, [path_lam], Loc_unknown)]
+                              [path_lam], Loc_unknown), Lvar cla ::
+                        if top then [Lprim(Pfield (3, Pointer, Mutable),
+                                     [path_lam], Loc_unknown)]
                         else []),
                  bind_super cla super cl_init))
       | _ ->
@@ -544,7 +547,7 @@ let rec builtin_meths self env env2 body =
     | p when const_path p -> "const", [p]
     | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
         "var", [Lvar n]
-    | Lprim(Pfield n, [Lvar e], _) when Ident.same e env ->
+    | Lprim(Pfield(n, _, _), [Lvar e], _) when Ident.same e env ->
         "env", [Lvar env2; Lconst(const_int n)]
     | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
         "meth", [met]
@@ -841,7 +844,8 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
           Loc_unknown)
   and linh_envs =
     List.map
-      (fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Loc_unknown))
+      (fun (_, path_lam, _) ->
+        Lprim(Pfield (3, Pointer, Mutable), [path_lam], Loc_unknown))
       (List.rev inh_init)
   in
   let make_envs lam =
@@ -861,7 +865,8 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
   in
   let inh_keys =
     List.map
-      (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Loc_unknown))
+      (fun (_, path_lam, _) ->
+        Lprim(Pfield (1, Pointer, Mutable), [path_lam], Loc_unknown))
       inh_paths
   in
   let lclass lam =

diff --git a/lambda/translcore.ml b/lambda/translcore.ml
@@ -373,14 +373,14 @@ and transl_exp0 ~in_new_scope ~scopes e =
       let targ = transl_exp ~scopes arg in
       begin match lbl.lbl_repres with
           Record_regular | Record_inlined _ ->
-          Lprim (Pfield lbl.lbl_pos, [targ],
+          Lprim (Pfield (lbl.lbl_pos, maybe_pointer e, lbl.lbl_mut), [targ],
                  of_location ~scopes e.exp_loc)
         | Record_unboxed _ -> targ
         | Record_float ->
           Lprim (Pfloatfield lbl.lbl_pos, [targ],
                  of_location ~scopes e.exp_loc)
         | Record_extension _ ->
-          Lprim (Pfield (lbl.lbl_pos + 1), [targ],
+          Lprim (Pfield (lbl.lbl_pos + 1, maybe_pointer e, lbl.lbl_mut), [targ],
                  of_location ~scopes e.exp_loc)
       end
   | Texp_setfield(arg, _, lbl, newval) ->
@@ -489,7 +489,8 @@ and transl_exp0 ~in_new_scope ~scopes e =
       Lapply{
         ap_loc=loc;
         ap_func=
-          Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc);
+          Lprim(Pfield (0, Pointer, Mutable),
+                [transl_class_path loc e.exp_env cl], loc);
         ap_args=[lambda_unit];
         ap_tailcall=Default_tailcall;
         ap_inlined=Default_inline;
@@ -622,7 +623,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
           let body, _ =
             List.fold_left (fun (body, pos) id ->
               Llet(Alias, Pgenval, id,
-                   Lprim(Pfield pos, [Lvar oid],
+                   Lprim(Pfield (pos, Pointer, Mutable), [Lvar oid],
                          of_location ~scopes od.open_loc), body),
               pos + 1
             ) (transl_exp ~scopes e, 0)
@@ -657,7 +658,7 @@ and transl_guard ~scopes guard rhs =
         (Lifthenelse(transl_exp ~scopes cond, expr, staticfail))
 
 and transl_case ~scopes {c_lhs; c_guard; c_rhs} =
-  c_lhs, transl_guard ~scopes c_guard c_rhs
+  (c_lhs, transl_guard ~scopes c_guard c_rhs)
 
 and transl_cases ~scopes cases =
   let cases =
@@ -951,13 +952,15 @@ and transl_record ~scopes loc env fields repres opt_init_expr =
       Array.mapi
         (fun i (_, definition) ->
            match definition with
-           | Kept typ ->
+           | Kept (typ, mut) ->
                let field_kind = value_kind env typ in
                let access =
                  match repres with
-                   Record_regular | Record_inlined _ -> Pfield i
+                   Record_regular | Record_inlined _ ->
+                     Pfield (i, maybe_pointer_type env typ, mut)
                  | Record_unboxed _ -> assert false
-                 | Record_extension _ -> Pfield (i + 1)
+                 | Record_extension _ ->
+                     Pfield (i + 1, maybe_pointer_type env typ, mut)
                  | Record_float -> Pfloatfield i in
                Lprim(access, [Lvar init_id],
                      of_location ~scopes loc),
@@ -1009,7 +1012,7 @@ and transl_record ~scopes loc env fields repres opt_init_expr =
     let copy_id = Ident.create_local "newrecord" in
     let update_field cont (lbl, definition) =
       match definition with
-      | Kept _type -> cont
+      | Kept _ -> cont
       | Overridden (_lid, expr) ->
           let upd =
             match repres with

diff --git a/lambda/translmod.ml b/lambda/translmod.ml
@@ -83,7 +83,7 @@ let rec apply_coercion loc strict restr arg =
       name_lambda strict arg (fun id ->
         let get_field pos =
           if pos < 0 then lambda_unit
-          else Lprim(Pfield pos,[Lvar id], loc)
+          else Lprim(Pfield (pos, Pointer, Mutable), [Lvar id], loc)
         in
         let lam =
           Lprim(Pmakeblock(0, Immutable, None),
@@ -720,8 +720,8 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
                   rebind_idents (pos + 1) (id :: newfields) ids
                 in
                 Llet(Alias, Pgenval, id,
-                     Lprim(Pfield pos, [Lvar mid],
+                     Lprim(Pfield (pos, Pointer, Mutable),
-                           of_location ~scopes incl.incl_loc), body),
+                        [Lvar mid], of_location ~scopes incl.incl_loc), body),
                 size
           in
           let body, size = rebind_idents 0 fields ids in
@@ -749,7 +749,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
                     rebind_idents (pos + 1) (id :: newfields) ids
                   in
                   Llet(Alias, Pgenval, id,
-                      Lprim(Pfield pos, [Lvar mid],
+                      Lprim(Pfield (pos, Pointer, Mutable), [Lvar mid],
                             of_location ~scopes od.open_loc), body),
                   size
               in
@@ -968,7 +968,8 @@ let transl_store_subst = ref Ident.Map.empty
 
 let nat_toplevel_name id =
   try match Ident.Map.find id !transl_store_subst with
-    | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos)
+    | Lprim(Pfield (pos, _, _),
+            [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos)
     | _ -> raise Not_found
   with Not_found ->
     fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)
@@ -1204,7 +1205,8 @@ let transl_store_structure ~scopes glob map prims aliases str =
               | [] -> transl_store
                         ~scopes rootpath (add_idents true ids subst) cont rem
               | id :: idl ->
-                  Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid],
+                  Llet(Alias, Pgenval, id,
+                       Lprim(Pfield (pos, Pointer, Mutable), [Lvar mid],
                                                  of_location ~scopes loc),
                        Lsequence(store_ident (of_location ~scopes loc) id,
                                  store_idents (pos + 1) idl))
@@ -1250,8 +1252,9 @@ let transl_store_structure ~scopes glob map prims aliases str =
                         [] -> transl_store ~scopes rootpath
                                 (add_idents true ids subst) cont rem
                       | id :: idl ->
-                          Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid],
+                          Llet(Alias, Pgenval, id,
-                                                         loc),
+                               Lprim(Pfield (pos, Pointer, Mutable),
+                                     [Lvar mid], loc),
                                Lsequence(store_ident loc id,
                                          store_idents (pos + 1) idl))
                     in
@@ -1285,7 +1288,7 @@ let transl_store_structure ~scopes glob map prims aliases str =
       match cc with
         Tcoerce_none ->
           Ident.Map.add id
-            (Lprim(Pfield pos,
+            (Lprim(Pfield (pos, Pointer, Immutable),
                    [Lprim(Pgetglobal glob, [], Loc_unknown)],
                    Loc_unknown))
             subst
@@ -1424,7 +1427,7 @@ let toplevel_name id =
 let toploop_getvalue id =
   Lapply{
     ap_loc=Loc_unknown;
-    ap_func=Lprim(Pfield toploop_getvalue_pos,
+    ap_func=Lprim(Pfield (toploop_getvalue_pos, Pointer, Mutable),
                   [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)],
                   Loc_unknown);
     ap_args=[Lconst(Const_base(
@@ -1437,7 +1440,7 @@ let toploop_getvalue id =
 let toploop_setvalue id lam =
   Lapply{
     ap_loc=Loc_unknown;
-    ap_func=Lprim(Pfield toploop_setvalue_pos,
+    ap_func=Lprim(Pfield (toploop_setvalue_pos, Pointer, Mutable),
                   [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)],
                   Loc_unknown);
     ap_args=
@@ -1522,7 +1525,8 @@ let transl_toplevel_item ~scopes item =
           lambda_unit
       | id :: ids ->
           Lsequence(toploop_setvalue id
-                      (Lprim(Pfield pos, [Lvar mid], Loc_unknown)),
+                      (Lprim(Pfield (pos, Pointer, Mutable),
+                             [Lvar mid], Loc_unknown)),
                     set_idents (pos + 1) ids) in
       Llet(Strict, Pgenval, mid,
            transl_module ~scopes Tcoerce_none None modl, set_idents 0 ids)
@@ -1545,7 +1549,8 @@ let transl_toplevel_item ~scopes item =
                 lambda_unit
             | id :: ids ->
                 Lsequence(toploop_setvalue id
-                            (Lprim(Pfield pos, [Lvar mid], Loc_unknown)),
+                            (Lprim(Pfield (pos, Pointer, Mutable),
+                                  [Lvar mid], Loc_unknown)),
                           set_idents (pos + 1) ids)
           in
           Llet(pure, Pgenval, mid,
@@ -1648,7 +1653,8 @@ let transl_store_package component_names target_name coercion =
                (fun pos _id ->
                  Lprim(Psetfield(pos, Pointer, Root_initialization),
                        [Lprim(Pgetglobal target_name, [], Loc_unknown);
-                        Lprim(Pfield pos, [Lvar blk], Loc_unknown)],
+                        Lprim(Pfield (pos, Pointer, Mutable),
+                              [Lvar blk], Loc_unknown)],
                        Loc_unknown))
                0 pos_cc_list))
   (*

diff --git a/lambda/translobj.ml b/lambda/translobj.ml
@@ -125,7 +125,8 @@ let transl_label_init_flambda f =
 let transl_store_label_init glob size f arg =
   assert(not Config.flambda);
   assert(!Clflags.native_code);
-  method_cache := Lprim(Pfield size,
+  method_cache := Lprim(Pfield (size, Pointer, Mutable),
+                        (* XXX KC: conservative *)
                         [Lprim(Pgetglobal glob, [], Loc_unknown)],
                         Loc_unknown);
   let expr = f arg in

diff --git a/lambda/translprim.ml b/lambda/translprim.ml
@@ -127,8 +127,8 @@ let primitives_table =
     "%loc_POS", Loc Loc_POS;
     "%loc_MODULE", Loc Loc_MODULE;
     "%loc_FUNCTION", Loc Loc_FUNCTION;
-    "%field0", Primitive ((Pfield 0), 1);
+    "%field0", Primitive (Pfield(0, Pointer, Mutable), 1);
-    "%field1", Primitive ((Pfield 1), 1);
+    "%field1", Primitive (Pfield(1, Pointer, Mutable), 1);
     "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2);
     "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1);
     "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1);
@@ -363,6 +363,16 @@ let primitives_table =
     "%greaterequal", Comparison(Greater_equal, Compare_generic);
     "%greaterthan", Comparison(Greater_than, Compare_generic);
     "%compare", Comparison(Compare, Compare_generic);
+    "%atomic_load",
+    Primitive ((Patomic_load {immediate_or_pointer=Pointer}), 1);
+    "%atomic_exchange", Primitive (Patomic_exchange, 2);
+    "%atomic_cas", Primitive (Patomic_cas, 3);
+    "%atomic_fetch_add", Primitive (Patomic_fetch_add, 2);
+    "%runstack", Primitive (Prunstack, 3);
+    "%reperform", Primitive (Preperform, 3);
+    "%perform", Primitive (Pperform, 1);
+    "%resume", Primitive (Presume, 3);
+    "%dls_get", Primitive (Pdls_get, 1);
   ]
 
 
@@ -427,6 +437,12 @@ let specialize_primitive env ty ~has_constant_constructor prim =
       | Pointer -> None
       | Immediate -> Some (Primitive (Psetfield(n, Immediate, init), arity))
     end
+  | Primitive (Pfield (n, Pointer, mut), arity), _ ->
+      (* try strength reduction based on the *result type* *)
+      let is_int = match is_function_type env ty with
+        | None -> Pointer
+        | Some (_p1, rhs) -> maybe_pointer_type env rhs in
+      Some (Primitive (Pfield (n, is_int, mut), arity))
   | Primitive (Parraylength t, arity), [p] -> begin
       let array_type = glb_array_type t (array_type_kind env p) in
       if t = array_type then None
@@ -472,6 +488,13 @@ let specialize_primitive env ty ~has_constant_constructor prim =
       if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape), arity))
       else None
     end
+  | Primitive (Patomic_load { immediate_or_pointer = Pointer },
+               arity), _ ->begin
+      let is_int = match is_function_type env ty with
+        | None -> Pointer
+        | Some (_p1, rhs) -> maybe_pointer_type env rhs in
+      Some (Primitive (Patomic_load {immediate_or_pointer = is_int}, arity))
+    end
   | Comparison(comp, Compare_generic), p1 :: _ ->
     if (has_constant_constructor
         && simplify_constant_constructor comp) then begin
@@ -788,6 +811,7 @@ let lambda_primitive_needs_event_after = function
   | Pbytes_load_64 _ | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _
   | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _
   | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _
+  | Prunstack | Pperform | Preperform | Presume
   | Pbbswap _ -> true
 
   | Pbytes_to_string | Pbytes_of_string | Pignore | Psetglobal _
@@ -800,7 +824,9 @@ let lambda_primitive_needs_event_after = function
   | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu
   | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _)
   | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint | Pisout
-  | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque -> false
+  | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
+  | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque | Pdls_get
+      -> false
 
 (* Determine if a primitive should be surrounded by an "after" debug event *)
 let primitive_needs_event_after = function

diff --git a/manual/src/library/libthreads.etex b/manual/src/library/libthreads.etex
@@ -28,8 +28,5 @@ the "-I +threads" option (see chapter~\ref{c:camlc}).
 
 \begin{linklist}
 \libdocitem{Thread}{lightweight threads}
-\libdocitem{Mutex}{locks for mutual exclusion}
-\libdocitem{Condition}{condition variables to synchronize between threads}
-\libdocitem{Semaphore}{semaphores, another thread synchronization mechanism}
 \libdocitem{Event}{first-class synchronous communication}
 \end{linklist}
diff --git a/manual/src/library/stdlib-blurb.etex b/manual/src/library/stdlib-blurb.etex
@@ -103,6 +103,14 @@ be called from C \\
 "Printexc" & p.~\stdpageref{Printexc} & a catch-all exception handler \\
 "Sys" & p.~\stdpageref{Sys} & system interface \\
 \end{tabular}
+\subsubsection*{sss:stdlib-multicore}{Multicore interface:}
+\begin{tabular}{lll}
+"Domain" & p.~\stdpageref{Domain} & domain spawn and join \\
+"Mutex" & p.~\stdpageref{Mutex} & mutual exclusion locks \\
+"Condition" & p.~\stdpageref{Condition} & condition variables \\
+"Semaphore" & p.~\stdpageref{Semaphore} & semaphores \\
+"EffectHandlers" & p.~\stdpageref{EffectHandlers} & deep and shallow effect handlers \\
+\end{tabular}
 \subsubsection*{sss:stdlib-misc}{Misc:}
 \begin{tabular}{lll}
 "Fun" & p.~\stdpageref{Fun} & function values \\
@@ -122,7 +130,10 @@ be called from C \\
 \stddocitem{Callback}{registering OCaml values with the C runtime}
 \stddocitem{Char}{character operations}
 \stddocitem{Complex}{complex numbers}
+\stddocitem{Condition}{condition variables to synchronize between threads}
+\stddocitem{Domain}{Domain spawn/join and domain local variables}
 \stddocitem{Digest}{MD5 message digest}
+\stddocitem{EffectHandlers}{deep and shallow effect handlers}
 \stddocitem{Either}{either values}
 \stddocitem{Ephemeron}{Ephemerons and weak hash table}
 \stddocitem{Filename}{operations on file names}
@@ -143,6 +154,7 @@ be called from C \\
 \stddocitem{Map}{association tables over ordered types}
 \stddocitem{Marshal}{marshaling of data structures}
 \stddocitem{MoreLabels}{include modules \texttt{Hashtbl}, \texttt{Map} and \texttt{Set} with labels}
+\stddocitem{Mutex}{locks for mutual exclusion}
 \stddocitem{Nativeint}{processor-native integers}
 \stddocitem{Oo}{object-oriented extension}
 \stddocitem{Option}{option values}
@@ -156,6 +168,7 @@ be called from C \\
 \stddocitem{Scanf}{formatted input functions}
 \stddocitem{Seq}{functional iterators}
 \stddocitem{Set}{sets over ordered types}
+\stddocitem{Semaphore}{semaphores, another thread synchronization mechanism}
 \stddocitem{Stack}{last-in first-out stacks}
 \stddocitem{StdLabels}{include modules \texttt{Array}, \texttt{List} and \texttt{String} with labels}
 \stddocitem{Stream}{streams and parsers}

diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml
@@ -34,13 +34,18 @@ type primitive =
   | Pread_symbol of string
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
-  | Pfield of int
+  | Pfield of int * immediate_or_pointer * mutable_flag
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
+  (* Context switches *)
+  | Prunstack
+  | Pperform
+  | Presume
+  | Preperform
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
@@ -114,8 +119,15 @@ type primitive =
   | Pbbswap of boxed_integer
   (* Integer to external pointer *)
   | Pint_as_pointer
+  (* Atomic operations *)
+  | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
+  | Patomic_exchange
+  | Patomic_cas
+  | Patomic_fetch_add
   (* Inhibition of optimisation *)
   | Popaque
+  (* Fetch domain-local state *)
+  | Pdls_get
 
 and integer_comparison = Lambda.integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli
@@ -34,13 +34,18 @@ type primitive =
   | Pread_symbol of string
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
-  | Pfield of int
+  | Pfield of int * immediate_or_pointer * mutable_flag
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
+  (* Context switches *)
+  | Prunstack
+  | Pperform
+  | Presume
+  | Preperform
   (* External call *)
   | Pccall of Primitive.description
   (* Exceptions *)
@@ -117,8 +122,16 @@ type primitive =
   | Pbbswap of boxed_integer
   (* Integer to external pointer *)
   | Pint_as_pointer
+  (* Atomic operations *)
+  | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
+  | Patomic_exchange
+  | Patomic_cas
+  | Patomic_fetch_add
   (* Inhibition of optimisation *)
   | Popaque
+  (* Fetch domain-local state *)
+  | Pdls_get
+
 
 and integer_comparison = Lambda.integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml
@@ -54,7 +54,8 @@ let rec build_closure_env env_param pos = function
     [] -> V.Map.empty
   | id :: rem ->
       V.Map.add id
-        (Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none))
+        (Uprim(P.Pfield(pos, Pointer, Immutable),
+              [Uvar env_param], Debuginfo.none))
           (build_closure_env env_param (pos+1) rem)
 
 (* Auxiliary for accessing globals.  We change the name of the global
@@ -479,10 +480,11 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
         (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs))
       end
   (* Field access *)
-  | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
+  | Pfield (n, _, _), _,
+            [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
     when n < List.length l ->
       make_const (List.nth l n)
-  | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
+  | Pfield(n, _, _), [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
     when n < List.length ul ->
       (* This case is particularly useful for removing allocations
          for optional parameters *)
@@ -849,7 +851,7 @@ let check_constant_result ulam approx =
           let glb =
             Uprim(P.Pread_symbol id, [], Debuginfo.none)
           in
-          Uprim(P.Pfield i, [glb], Debuginfo.none), approx
+          Uprim(P.Pfield(i, Pointer, Immutable), [glb], Debuginfo.none), approx
       end
   | _ -> (ulam, approx)
 
@@ -1102,10 +1104,10 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
       let dbg = Debuginfo.from_location loc in
       check_constant_result (getglobal dbg id)
                             (Compilenv.global_approx id)
-  | Lprim(Pfield n, [lam], loc) ->
+  | Lprim(Pfield (n, ptr, mut), [lam], loc) ->
       let (ulam, approx) = close env lam in
       let dbg = Debuginfo.from_location loc in
-      check_constant_result (Uprim(P.Pfield n, [ulam], dbg))
+      check_constant_result (Uprim(P.Pfield (n, ptr, mut), [ulam], dbg))
                             (field_approx n approx)
   | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->
       let (ulam, approx) = close env lam in

diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml
@@ -26,7 +26,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   match prim with
   | Pmakeblock (tag, mutability, shape) ->
       Pmakeblock (tag, mutability, shape)
-  | Pfield field -> Pfield field
+  | Pfield (field, imm_or_pointer, mutability) ->
+      Pfield (field, imm_or_pointer, mutability)
   | Pfield_computed -> Pfield_computed
   | Psetfield (field, imm_or_pointer, init_or_assign) ->
       Psetfield (field, imm_or_pointer, init_or_assign)
@@ -36,6 +37,10 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   | Psetfloatfield (field, init_or_assign) ->
       Psetfloatfield (field, init_or_assign)
   | Pduprecord (repr, size) -> Pduprecord (repr, size)
+  | Prunstack -> Prunstack
+  | Pperform -> Pperform
+  | Presume -> Presume
+  | Preperform -> Preperform
   | Pccall prim -> Pccall prim
   | Praise kind -> Praise kind
   | Psequand -> Psequand
@@ -139,8 +144,13 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   | Pbigarraydim dim -> Pbigarraydim dim
   | Pbswap16 -> Pbswap16
   | Pint_as_pointer -> Pint_as_pointer
+  | Patomic_load { immediate_or_pointer } ->
+      Patomic_load { immediate_or_pointer }
+  | Patomic_exchange -> Patomic_exchange
+  | Patomic_cas -> Patomic_cas
+  | Patomic_fetch_add -> Patomic_fetch_add
   | Popaque -> Popaque
-
+  | Pdls_get -> Pdls_get
   | Pbytes_to_string
   | Pbytes_of_string
   | Pctconst _

diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml
@@ -286,7 +286,7 @@ and descr_of_named (env : Env.t) (named : Flambda.named)
       Value_block (Tag.create_exn tag, Array.of_list approxs)
     in
     Value_id (Env.new_descr env descr)
-  | Prim (Pfield i, [arg], _) ->
+  | Prim (Pfield (i, _, _), [arg], _) ->
     begin match Env.get_descr env (Env.find_approx env arg) with
     | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
     | _ -> Value_unknown

diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml
@@ -91,7 +91,8 @@ let tupled_function_call_stub original_params unboxed_version ~closure_bound_var
   let _, body =
     List.fold_left (fun (pos, body) param ->
         let lam : Flambda.named =
-          Prim (Pfield pos, [tuple_param_var], Debuginfo.none)
+          Prim (Pfield (pos, Pointer, Mutable),
+                [tuple_param_var], Debuginfo.none)
         in
         pos + 1, Flambda.create_let param lam body)
       (0, call) params
@@ -698,9 +699,10 @@ let lambda_to_flambda ~backend ~module_ident ~size lam
       Flambda.create_let
         sym_v (Symbol block_symbol)
          (Flambda.create_let result_v
-            (Prim (Pfield 0, [sym_v], Debuginfo.none))
+            (Prim (Pfield (0, Pointer, Mutable), [sym_v], Debuginfo.none))
             (Flambda.create_let value_v
-              (Prim (Pfield pos, [result_v], Debuginfo.none))
+              (Prim (Pfield (pos, Pointer, Mutable),
+                     [result_v], Debuginfo.none))
               (Var value_v))))
   in
   let module_initializer : Flambda.program_body =

diff --git a/middle_end/flambda/extract_projections.ml b/middle_end/flambda/extract_projections.ml
@@ -124,7 +124,7 @@ let rec analyse_expr ~which_variables expr =
         when Variable.Map.mem move.closure which_variables ->
       projections :=
         Projection.Set.add (Move_within_set_of_closures move) !projections
-    | Prim (Pfield field_index, [var], _dbg)
+    | Prim (Pfield (field_index, _, _), [var], _dbg)
         when Variable.Map.mem var which_variables ->
       projections :=
         Projection.Set.add (Field (field_index, var)) !projections

diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml
@@ -369,7 +369,8 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
         Flambda.print_named named
     end
   | Read_symbol_field (symbol, field) ->
-    Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none)
+    Uprim (Pfield (field, Pointer, Mutable),
+           [to_clambda_symbol env symbol], Debuginfo.none)
   | Set_of_closures set_of_closures ->
     to_clambda_set_of_closures t env set_of_closures
   | Project_closure { set_of_closures; closure_id } ->
@@ -394,12 +395,13 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
     let fun_offset = get_fun_offset t closure_id in
     let var_offset = get_fv_offset t var in
     let pos = var_offset - fun_offset in
-    Uprim (Pfield pos,
+    Uprim (Pfield (pos, Pointer, Mutable),
       [check_field t (check_closure t ulam (Expr (Var closure)))
          pos (Some named)],
       Debuginfo.none)
-  | Prim (Pfield index, [block], dbg) ->
+  | Prim (Pfield (index, ptr, mut), [block], dbg) ->
-    Uprim (Pfield index, [check_field t (subst_var env block) index None], dbg)
+    Uprim (Pfield (index, ptr, mut),
+           [check_field t (subst_var env block) index None], dbg)
   | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
     Uprim (Psetfield (index, maybe_ptr, init), [
         check_field t (subst_var env block) index None;
@@ -512,7 +514,8 @@ and to_clambda_set_of_closures t env
         in
         let pos = var_offset - fun_offset in
         Env.add_subst env id
-          (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none))
+          (Uprim (Pfield (pos, Pointer, Mutable),
+                  [Clambda.Uvar env_var], Debuginfo.none))
       in
       let env = Variable.Map.fold add_env_free_variable free_vars env in
       (* Add the Clambda expressions for all functions defined in the current

diff --git a/middle_end/flambda/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml
@@ -546,7 +546,7 @@ let substitute_read_symbol_field_for_variables
           Expr (
             Flambda.create_let block (make_named t)
               (Flambda.create_let field
-                 (Prim (Pfield h, [block], Debuginfo.none))
+                 (Prim (Pfield (h, Pointer, Mutable), [block], Debuginfo.none))
                  (Var field)))
     in
     Flambda.create_let fresh_var (make_named path) expr
@@ -905,7 +905,7 @@ let projection_to_named (projection : Projection.t) : Flambda.named =
   | Project_closure project_closure -> Project_closure project_closure
   | Move_within_set_of_closures move -> Move_within_set_of_closures move
   | Field (field_index, var) ->
-    Prim (Pfield field_index, [var], Debuginfo.none)
+    Prim (Pfield (field_index, Pointer, Mutable), [var], Debuginfo.none)
 
 type specialised_to_same_as =
   | Not_specialised

diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml
@@ -991,7 +991,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
       let tree = Flambda.Prim (prim, args, dbg) in
       begin match prim, args, args_approxs with
       (* CR-someday mshinwell: Optimise [Pfield_computed]. *)
-      | Pfield field_index, [arg], [arg_approx] ->
+      | Pfield (field_index, _, _), [arg], [arg_approx] ->
         let projection : Projection.t = Field (field_index, arg) in
         begin match E.find_projection env ~projection with
         | Some var ->

diff --git a/middle_end/flambda/lift_constants.ml b/middle_end/flambda/lift_constants.ml
@@ -89,7 +89,7 @@ let assign_symbols_and_collect_constant_definitions
       | Project_closure ({ closure_id } as project_closure) ->
         assign_existing_symbol (closure_symbol ~backend  closure_id);
         record_definition (AA.Project_closure project_closure)
-      | Prim (Pfield index, [block], _) ->
+      | Prim (Pfield (index, _, _), [block], _) ->
         record_definition (AA.Field (block, index))
       | Prim (Pfield _, _, _) ->
         Misc.fatal_errorf "[Pfield] with the wrong number of arguments"

diff --git a/middle_end/flambda/ref_to_variables.ml b/middle_end/flambda/ref_to_variables.ml
@@ -155,7 +155,7 @@ let eliminate_ref_of_expr flam =
         flam
     and aux_named (named : Flambda.named) : Flambda.named =
       match named with
-      | Prim(Pfield field, [v], _)
+      | Prim(Pfield (field, _, _), [v], _)
         when convertible_variable v ->
         (match get_variable v field with
          | None -> Expr Proved_unreachable

diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml
@@ -169,6 +169,16 @@ let psubfloat = "Psubfloat"
 let psubint = "Psubint"
 let pxorbint = "Pxorbint"
 let pxorint = "Pxorint"
+let patomic_cas = "Patomic_cas"
+let patomic_exchange = "Patomic_exchange"
+let patomic_fetch_add = "Patomic_fetch_add"
+let patomic_load = "Patomic_load"
+let prunstack = "Prunstack"
+let pperform = "Pperform"
+let presume = "Presume"
+let preperform = "Preperform"
+let pdls_get = "Pdls_get"
+
 let pabsfloat_arg = "Pabsfloat_arg"
 let paddbint_arg = "Paddbint_arg"
 let paddfloat_arg = "Paddfloat_arg"
@@ -271,6 +281,16 @@ let psubfloat_arg = "Psubfloat_arg"
 let psubint_arg = "Psubint_arg"
 let pxorbint_arg = "Pxorbint_arg"
 let pxorint_arg = "Pxorint_arg"
+let patomic_cas_arg = "Patomic_cas_arg"
+let patomic_exchange_arg = "Patomic_exchange_arg"
+let patomic_fetch_add_arg = "Patomic_fetch_add_arg"
+let patomic_load_arg = "Patomic_load_arg"
+let prunstack_arg = "Prunstack_arg"
+let pperform_arg = "Pperform_arg"
+let presume_arg = "Presume_arg"
+let preperform_arg = "Preperform_arg"
+let pdls_get_arg = "Pdls_get_arg"
+
 let raise = "raise"
 let raise_arg = "raise_arg"
 let read_mutable = "read_mutable"
@@ -405,6 +425,15 @@ let of_primitive : Lambda.primitive -> string = function
   | Pbbswap _ -> pbbswap
   | Pint_as_pointer -> pint_as_pointer
   | Popaque -> popaque
+  | Patomic_cas -> patomic_cas
+  | Patomic_exchange -> patomic_exchange
+  | Patomic_fetch_add -> patomic_fetch_add
+  | Patomic_load _ -> patomic_load
+  | Prunstack -> prunstack
+  | Pperform -> pperform
+  | Presume -> presume
+  | Preperform -> preperform
+  | Pdls_get -> pdls_get
 
 let of_primitive_arg : Lambda.primitive -> string = function
   | Pbytes_of_string -> pbytes_of_string_arg
@@ -508,3 +537,12 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Pbbswap _ -> pbbswap_arg
   | Pint_as_pointer -> pint_as_pointer_arg
   | Popaque -> popaque_arg
+  | Patomic_cas -> patomic_cas_arg
+  | Patomic_exchange -> patomic_exchange_arg
+  | Patomic_fetch_add -> patomic_fetch_add_arg
+  | Patomic_load _ -> patomic_load_arg
+  | Prunstack -> prunstack_arg
+  | Pperform -> pperform_arg
+  | Presume -> presume_arg
+  | Preperform -> preperform_arg
+  | Pdls_get -> pdls_get_arg
diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml
@@ -61,7 +61,14 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
       fprintf ppf "makeblock %i%a" tag Printlambda.block_shape shape
   | Pmakeblock(tag, Mutable, shape) ->
       fprintf ppf "makemutable %i%a" tag Printlambda.block_shape shape
-  | Pfield n -> fprintf ppf "field %i" n
+  | Pfield(n, ptr, mut) ->
+      let instr =
+        match ptr, mut with
+        | Immediate, _ -> "field_int "
+        | Pointer, Mutable -> "field_mut "
+        | Pointer, Immutable -> "field_imm "
+      in
+      fprintf ppf "%s%i" instr n
   | Pfield_computed -> fprintf ppf "field_computed"
   | Psetfield(n, ptr, init) ->
       let instr =
@@ -100,6 +107,10 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
       fprintf ppf "setfloatfield%s %i" init n
   | Pduprecord (rep, size) ->
       fprintf ppf "duprecord %a %i" Printlambda.record_rep rep size
+  | Prunstack -> fprintf ppf "runstack"
+  | Pperform -> fprintf ppf "perform"
+  | Presume -> fprintf ppf "resume"
+  | Preperform -> fprintf ppf "reperform"
   | Pccall p -> fprintf ppf "%s" p.Primitive.prim_name
   | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
   | Psequand -> fprintf ppf "&&"
@@ -202,4 +213,12 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
   | Pbswap16 -> fprintf ppf "bswap16"
   | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
   | Pint_as_pointer -> fprintf ppf "int_as_pointer"
+  | Patomic_load {immediate_or_pointer} ->
+      (match immediate_or_pointer with
+        | Immediate -> fprintf ppf "atomic_load_imm"
+        | Pointer -> fprintf ppf "atomic_load_ptr")
+  | Patomic_exchange -> fprintf ppf "atomic_exchange"
+  | Patomic_cas -> fprintf ppf "atomic_cas"
+  | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add"
   | Popaque -> fprintf ppf "opaque"
+  | Pdls_get -> fprintf ppf "dls_get"
diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml
@@ -35,6 +35,8 @@ let for_primitive (prim : Clambda_primitives.primitive) =
       No_effects, No_coeffects
   | Pccall _ -> Arbitrary_effects, Has_coeffects
   | Praise _ -> Arbitrary_effects, No_coeffects
+  | Prunstack | Pperform | Presume | Preperform ->
+      Arbitrary_effects, Has_coeffects
   | Pnot
   | Pnegint
   | Paddint
@@ -115,6 +117,10 @@ let for_primitive (prim : Clambda_primitives.primitive) =
   | Psetfield _
   | Psetfield_computed _
   | Psetfloatfield _
+  | Patomic_load _
+  | Patomic_exchange
+  | Patomic_cas
+  | Patomic_fetch_add
   | Parraysetu _
   | Parraysets _
   | Pbytessetu
@@ -133,6 +139,9 @@ let for_primitive (prim : Clambda_primitives.primitive) =
   | Psequor ->
       (* Removed by [Closure_conversion] in the flambda pipeline. *)
       No_effects, No_coeffects
+  | Pdls_get ->
+      (* only read *)
+      No_effects, No_coeffects
 
 type return_type =
   | Float

diff --git a/ocaml-variants.opam b/ocaml-variants.opam
@@ -7,14 +7,57 @@ depends: [
   "base-unix" {post}
   "base-bigarray" {post}
   "base-threads" {post}
+  "base-domains" {post}
+  "ocaml-option-nnp"
 ]
 conflict-class: "ocaml-core-compiler"
 flags: compiler
 build: [
-  ["./configure" "--prefix=%{prefix}%" "--docdir=%{doc}%/ocaml"]
+  [
+    "./configure"
+    "--prefix=%{prefix}%"
+    "--docdir=%{doc}%/ocaml"
+    "--with-afl" {ocaml-option-afl:installed}
+    "--disable-native-compiler" {ocaml-option-bytecode-only:installed}
+    "--disable-force-safe-string" {ocaml-option-default-unsafe-string:installed}
+    "DEFAULT_STRING=unsafe" {ocaml-option-default-unsafe-string:installed}
+    "--disable-flat-float-array" {ocaml-option-no-flat-float-array:installed}
+    "--enable-flambda" {ocaml-option-flambda:installed}
+    "--enable-frame-pointers" {ocaml-option-fp:installed}
+    "CC=cc" {!ocaml-option-32bit:installed & !ocaml-option-musl:installed & (os="openbsd"|os="macos")}
+    "CC=musl-gcc" {ocaml-option-musl:installed & os-distribution!="alpine"}
+    "CFLAGS=-Os" {ocaml-option-musl:installed}
+    #"CC=gcc -m32" {ocaml-option-32bit:installed & os="linux"}
+    #"CC=gcc -Wl,-read_only_relocs,suppress -arch i386 -m32" {ocaml-option-32bit:installed & os="macos"}
+    "ASPP=cc -c" {!ocaml-option-32bit:installed & !ocaml-option-musl:installed & (os="openbsd"|os="macos")}
+    "ASPP=musl-gcc -c" {ocaml-option-musl:installed & os-distribution!="alpine"}
+    #"ASPP=gcc -m32 -c" {ocaml-option-32bit:installed & os="linux"}
+    #"ASPP=gcc -arch i386 -m32 -c" {ocaml-option-32bit:installed & os="macos"}
+    #"AS=as --32" {ocaml-option-32bit:installed & os="linux"}
+    #"AS=as -arch i386" {ocaml-option-32bit:installed & os="macos"}
+    #"--host=i386-linux" {ocaml-option-32bit:installed & os="linux"}
+    #"--host=i386-apple-darwin13.2.0" {ocaml-option-32bit:installed & os="macos"}
+    #"PARTIALLD=ld -r -melf_i386" {ocaml-option-32bit:installed & os="linux"}
+    # 32bit options above commented out just to reduce diff with ocaml-variants.4.12.0+options
+    "LIBS=-static" {ocaml-option-static:installed}
+  ]
   [make "-j%{jobs}%"]
 ]
 install: [make "install"]
+conflicts: [
+  "ocaml-option-32bit"      # Not yet implemented
+  "ocaml-option-nnpchecker" # Fundamentally not possible
+]
+depopts: [
+  "ocaml-option-afl"
+  "ocaml-option-bytecode-only"
+  "ocaml-option-default-unsafe-string"
+  "ocaml-option-no-flat-float-array"
+  "ocaml-option-flambda"
+  "ocaml-option-fp"
+  "ocaml-option-musl"
+  "ocaml-option-static"
+]
 maintainer: "caml-list@inria.fr"
 homepage: "https://github.com/ocaml/ocaml/"
 bug-reports: "https://github.com/ocaml/ocaml/issues"

diff --git a/ocamltest/main.ml b/ocamltest/main.ml
@@ -67,39 +67,41 @@ let tsl_block_of_file_safe test_filename =
 let print_usage () =
   Printf.printf "%s\n%!" Options.usage
 
-type result_summary = No_failure | Some_failure
+type result_summary = No_failure | Some_failure | All_skipped
+let join_result summary result =
+  let open Result in
+  match result.status, summary with
+  | Fail, _
+  | _, Some_failure -> Some_failure
+  | Skip, All_skipped -> All_skipped
+  | _ -> No_failure
+
 let join_summaries sa sb =
   match sa, sb with
-  | Some_failure, _ | _, Some_failure -> Some_failure
+  | Some_failure, _
-  | No_failure, No_failure -> No_failure
+  | _, Some_failure -> Some_failure
-
+  | All_skipped, All_skipped -> All_skipped
-let summary_of_result res =
+  | _ -> No_failure
-  let open Result in
-  match res.status with
-  | Pass -> No_failure
-  | Skip -> No_failure
-  | Fail -> Some_failure
 
 let rec run_test log common_prefix path behavior = function
   Node (testenvspec, test, env_modifiers, subtrees) ->
   Printf.printf "%s %s (%s) => %!" common_prefix path test.Tests.test_name;
-  let (msg, children_behavior, summary) = match behavior with
+  let (msg, children_behavior, result) = match behavior with
-    | Skip_all_tests -> "n/a", Skip_all_tests, No_failure
+    | Skip_all_tests -> "n/a", Skip_all_tests, Result.skip
     | Run env ->
       let testenv0 = interpret_environment_statements env testenvspec in
       let testenv = List.fold_left apply_modifiers testenv0 env_modifiers in
       let (result, newenv) = Tests.run log testenv test in
       let msg = Result.string_of_result result in
       let children_behavior =
         if Result.is_pass result then Run newenv else Skip_all_tests in
-      let summary = summary_of_result result in
+      (msg, children_behavior, result) in
-      (msg, children_behavior, summary) in
   Printf.printf "%s\n%!" msg;
-  join_summaries summary
+  join_result
-    (run_test_trees log common_prefix path children_behavior subtrees)
+    (run_test_trees log common_prefix path children_behavior subtrees) result
 
 and run_test_trees log common_prefix path behavior trees =
-  List.fold_left join_summaries No_failure
+  List.fold_left join_summaries All_skipped
     (List.mapi (run_test_i log common_prefix path behavior) trees)
 
 and run_test_i log common_prefix path behavior i test_tree =
@@ -127,6 +129,7 @@ let init_tests_to_skip () =
   tests_to_skip := String.words (Sys.safe_getenv "OCAMLTEST_SKIP_TESTS")
 
 let test_file test_filename =
+  let start = Unix.gettimeofday () in
   let skip_test = List.mem test_filename !tests_to_skip in
   let tsl_block = tsl_block_of_file_safe test_filename in
   let (rootenv_statements, test_trees) = test_trees_of_tsl_block tsl_block in
@@ -209,10 +212,14 @@ let test_file test_filename =
   | Some_failure ->
       if not Options.log_to_stderr then
         Sys.dump_file stderr ~prefix:"> " log_filename
-  | No_failure ->
+  | No_failure | All_skipped ->
       if not Options.keep_test_dir_on_success then
         clean_test_build_directory ()
-  end
+  end;
+  if Options.show_timings && summary = No_failure then
+    let wall_clock_duration = Unix.gettimeofday () -. start in
+    Printf.eprintf "Wall clock: %s took %.02fs\n%!"
+                   test_filename wall_clock_duration
 
 let is_test s =
   match tsl_block_of_file s with

@@ -40,12 +40,12 @@ class compiler
   method target = target
 
   method program_variable =
-    if Ocaml_backends.is_native host
+    if Ocaml_backends.is_native host && not Sys.win32
     then Builtin_variables.program2
     else Builtin_variables.program
 
   method program_output_variable =
-    if Ocaml_backends.is_native host
+    if Ocaml_backends.is_native host && not Sys.win32
     then None
     else Some Builtin_variables.output
 

@@ -20,38 +20,65 @@ open Builtin_actions
 open Ocaml_actions
 
 let bytecode =
-  let opt_actions =
+  let byte_build =
+  [
+    setup_ocamlc_byte_build_env;
+    ocamlc_byte;
+    check_ocamlc_byte_output
+  ] in
+  let opt_build =
   [
     setup_ocamlc_opt_build_env;
     ocamlc_opt;
-    check_ocamlc_opt_output;
+    check_ocamlc_opt_output
-    compare_bytecode_programs
   ] in
 {
   test_name = "bytecode";
   test_run_by_default = true;
   test_actions =
+  (if Sys.win32 && Ocamltest_config.arch<>"none" then
+    opt_build
+  else
+    byte_build) @
   [
-    setup_ocamlc_byte_build_env;
-    ocamlc_byte;
-    check_ocamlc_byte_output;
     run;
     check_program_output;
-  ] @ (if Ocamltest_config.native_compiler then opt_actions else [])
+  ] @
+  (if not Sys.win32 && Ocamltest_config.native_compiler then
+    opt_build @ [compare_bytecode_programs]
+  else
+    []
+  )
 }
 
 let native =
-  let opt_actions =
+  let byte_build =
   [
     setup_ocamlopt_byte_build_env;
     ocamlopt_byte;
     check_ocamlopt_byte_output;
-    run;
+  ] in
-    check_program_output;
+  let opt_build =
+  [
     setup_ocamlopt_opt_build_env;
     ocamlopt_opt;
     check_ocamlopt_opt_output;
   ] in
+  let opt_actions =
+  (if Sys.win32 then
+    opt_build
+  else
+    byte_build
+  ) @
+  [
+    run;
+    check_program_output;
+  ] @
+  (if not Sys.win32 then
+    opt_build
+  else
+    []
+  ) in
   {
     test_name = "native";
     test_run_by_default = true;

@@ -18,3 +18,4 @@
 val has_symlink : unit -> bool
 val symlink : ?to_dir:bool -> string -> string -> unit
 val chmod : string -> int -> unit
+val gettimeofday : unit -> float
@@ -16,3 +16,4 @@
 let has_symlink () = false
 let symlink ?to_dir:_ _ _ = invalid_arg "symlink not available"
 let chmod _ _ = invalid_arg "chmod not available"
+let gettimeofday () = invalid_arg "gettimeofday not available"
@@ -12,8 +12,9 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Unix.has_symlink never raises *)
+(* Unix.gettimeofday and Unix.has_symlink never raise *)
 let has_symlink = Unix.has_symlink
+let gettimeofday = Unix.gettimeofday
 
 (* Convert Unix_error to Sys_error *)
 let wrap f x =

@@ -57,6 +57,8 @@ let find_test_dirs = ref []
 
 let list_tests = ref []
 
+let show_timings = ref false
+
 let add_to_list r x =
   r := !r @ [x]
 
@@ -68,6 +70,8 @@ let commandline_options =
   ("-show-actions", Arg.Unit show_actions, " Show available actions.");
   ("-show-tests", Arg.Unit show_tests, " Show available tests.");
   ("-show-variables", Arg.Unit show_variables, " Show available variables.");
+  ("-show-timings", Arg.Set show_timings,
+   " Show the wall clock time taken for each test file.");
   ("-timeout",
      Arg.Int (fun t -> if t >= 0
                        then default_timeout := t
@@ -95,3 +99,4 @@ let default_timeout = !default_timeout
 let find_test_dirs = !find_test_dirs
 let list_tests = !list_tests
 let keep_test_dir_on_success = !keep_test_dir_on_success
+let show_timings = !show_timings
@@ -30,3 +30,5 @@ val find_test_dirs : string list
 val list_tests : string list
 
 val keep_test_dir_on_success : bool
+
+val show_timings : bool
@@ -20,6 +20,14 @@
 
 open! Dynlink_compilerlibs
 
+(* Dynlink is only allowed on the main domain.
+   Entrypoints to public functions should check for this. *)
+let is_dynlink_allowed () =
+  if not (Domain.is_main_domain ()) then
+    failwith "Dynlink can only be called from the main domain."
+  else
+    ()
+
 module String = struct
   include Misc.Stdlib.String
 
@@ -79,6 +87,7 @@ module Make (P : Dynlink_platform_intf.S) = struct
   let unsafe_allowed = ref false
 
   let allow_unsafe_modules b =
+    is_dynlink_allowed();
     unsafe_allowed := b
 
   let check_symbols_disjoint ~descr syms1 syms2 =
@@ -137,6 +146,7 @@ module Make (P : Dynlink_platform_intf.S) = struct
     global_state := state
 
   let init () =
+    is_dynlink_allowed();
     if not !inited then begin
       P.init ();
       default_available_units ();
@@ -270,6 +280,7 @@ module Make (P : Dynlink_platform_intf.S) = struct
     end
 
   let set_allowed_units allowed_units =
+    is_dynlink_allowed();
     let allowed_units = String.Set.of_list allowed_units in
     let state =
       let state = !global_state in
@@ -280,6 +291,7 @@ module Make (P : Dynlink_platform_intf.S) = struct
     global_state := state
 
   let allow_only units =
+    is_dynlink_allowed();
     let allowed_units =
       String.Set.inter (!global_state).allowed_units
         (String.Set.of_list units)
@@ -293,6 +305,7 @@ module Make (P : Dynlink_platform_intf.S) = struct
     global_state := state
 
   let prohibit units =
+    is_dynlink_allowed();
     let allowed_units =
       String.Set.diff (!global_state).allowed_units
         (String.Set.of_list units)

@@ -24,6 +24,8 @@ include ../Makefile.otherlibs.common
 str.cmo: str.cmi
 str.cmx: str.cmi
 
+LDOPTS = $(PTHREAD_LINK)
+
 .PHONY: depend
 depend:
 	$(OCAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash *.mli *.ml > .depend

@@ -595,51 +595,54 @@ external re_search_forward: regexp -> string -> int -> int array
 external re_search_backward: regexp -> string -> int -> int array
      = "re_search_backward"
 
-let last_search_result = ref [||]
+let last_search_result_key = Domain.DLS.new_key (fun () -> [||])
 
 let string_match re s pos =
   let res = re_string_match re s pos in
-  last_search_result := res;
+  Domain.DLS.set last_search_result_key res;
   Array.length res > 0
 
 let string_partial_match re s pos =
   let res = re_partial_match re s pos in
-  last_search_result := res;
+  Domain.DLS.set last_search_result_key res;
   Array.length res > 0
 
 let search_forward re s pos =
   let res = re_search_forward re s pos in
-  last_search_result := res;
+  Domain.DLS.set last_search_result_key res;
   if Array.length res = 0 then raise Not_found else res.(0)
 
 let search_backward re s pos =
   let res = re_search_backward re s pos in
-  last_search_result := res;
+  Domain.DLS.set last_search_result_key res;
   if Array.length res = 0 then raise Not_found else res.(0)
 
 let group_beginning n =
+  let last_search_result = Domain.DLS.get last_search_result_key in
   let n2 = n + n in
-  if n < 0 || n2 >= Array.length !last_search_result then
+  if n < 0 || n2 >= Array.length last_search_result then
     invalid_arg "Str.group_beginning"
   else
-    let pos = !last_search_result.(n2) in
+    let pos = last_search_result.(n2) in
     if pos = -1 then raise Not_found else pos
 
 let group_end n =
+  let last_search_result = Domain.DLS.get last_search_result_key in
   let n2 = n + n in
-  if n < 0 || n2 >= Array.length !last_search_result then
+  if n < 0 || n2 >= Array.length last_search_result then
     invalid_arg "Str.group_end"
   else
-    let pos = !last_search_result.(n2 + 1) in
+    let pos = last_search_result.(n2 + 1) in
     if pos = -1 then raise Not_found else pos
 
 let matched_group n txt =
+  let last_search_result = Domain.DLS.get last_search_result_key in
   let n2 = n + n in
-  if n < 0 || n2 >= Array.length !last_search_result then
+  if n < 0 || n2 >= Array.length last_search_result then
     invalid_arg "Str.matched_group"
   else
-    let b = !last_search_result.(n2)
+    let b = last_search_result.(n2)
-    and e = !last_search_result.(n2 + 1) in
+    and e = last_search_result.(n2 + 1) in
     if b = -1 then raise Not_found else String.sub txt b (e - b)
 
 let match_beginning () = group_beginning 0
@@ -652,7 +655,8 @@ external re_replacement_text: string -> int array -> string -> string
     = "re_replacement_text"
 
 let replace_matched repl matched =
-  re_replacement_text repl !last_search_result matched
+  let last_search_result = Domain.DLS.get last_search_result_key in
+  re_replacement_text repl last_search_result matched
 
 let substitute_first expr repl_fun text =
   try

@@ -1,34 +1,8 @@
-condition.cmo : \
-    mutex.cmi \
-    condition.cmi
-condition.cmx : \
-    mutex.cmx \
-    condition.cmi
-condition.cmi : \
-    mutex.cmi
 event.cmo : \
-    mutex.cmi \
-    condition.cmi \
     event.cmi
 event.cmx : \
-    mutex.cmx \
-    condition.cmx \
     event.cmi
 event.cmi :
-mutex.cmo : \
-    mutex.cmi
-mutex.cmx : \
-    mutex.cmi
-mutex.cmi :
-semaphore.cmo : \
-    mutex.cmi \
-    condition.cmi \
-    semaphore.cmi
-semaphore.cmx : \
-    mutex.cmx \
-    condition.cmx \
-    semaphore.cmi
-semaphore.cmi :
 thread.cmo : \
     thread.cmi
 thread.cmx : \

@@ -22,7 +22,7 @@ ifneq "$(CCOMPTYPE)" "msvc"
 OC_CFLAGS += -g
 endif
 
-OC_CFLAGS += $(SHAREDLIB_CFLAGS)
+OC_CFLAGS += $(SHAREDLIB_CFLAGS) $(PTHREAD_CFLAGS)
 
 OC_CPPFLAGS += -I$(ROOTDIR)/runtime
 
@@ -50,14 +50,12 @@ LIBNAME=threads
 BYTECODE_C_OBJS=st_stubs.b.$(O)
 NATIVECODE_C_OBJS=st_stubs.n.$(O)
 
-THREADS_SOURCES = thread.ml mutex.ml condition.ml event.ml threadUnix.ml \
+THREADS_SOURCES = thread.ml event.ml threadUnix.ml
-  semaphore.ml
 
 THREADS_BCOBJS = $(THREADS_SOURCES:.ml=.cmo)
 THREADS_NCOBJS = $(THREADS_SOURCES:.ml=.cmx)
 
-MLIFILES=thread.mli mutex.mli condition.mli event.mli threadUnix.mli \
+MLIFILES=thread.mli event.mli threadUnix.mli
-  semaphore.mli
 
 CMIFILES=$(MLIFILES:.mli=.cmi)
 

@@ -18,6 +18,8 @@
 type t
 
 external thread_initialize : unit -> unit = "caml_thread_initialize"
+external thread_initialize_domain : unit -> unit =
+            "caml_thread_initialize_domain"
 external thread_cleanup : unit -> unit = "caml_thread_cleanup"
 external thread_new : (unit -> unit) -> t = "caml_thread_new"
 external thread_uncaught_exception : exn -> unit =
@@ -84,6 +86,7 @@ let preempt_signal =
 
 let () =
   Sys.set_signal preempt_signal (Sys.Signal_handle preempt);
+  Domain.at_startup thread_initialize_domain;
   thread_initialize ();
   Callback.register "Thread.at_shutdown" (fun () ->
     thread_cleanup();

@@ -59,6 +59,8 @@ CAMLextern int caml_c_thread_unregister(void);
    functions.  Just call [caml_c_thread_register] once.
    Before the thread finishes, it must call [caml_c_thread_unregister].
    Both functions return 1 on success, 0 on error.
+   In multicore OCaml, note that threads created by C code will be registered
+   to the domain 0 threads chaining.
 */
 
 #ifdef __cplusplus

@@ -19,14 +19,21 @@
 #include <caml/debugger.h>
 #include <caml/eventlog.h>
 #include "unixsupport.h"
+#include <caml/domain.h>
+#include <caml/fail.h>
 
 CAMLprim value unix_fork(value unit)
 {
   int ret;
+  if (caml_domain_is_multicore()) {
+    caml_failwith
+      ("Unix.fork may not be called while other domains were created");
+  }
 
   CAML_EV_FLUSH();
 
   ret = fork();
+  if (ret == 0) caml_atfork_hook();
   if (ret == -1) uerror("fork", Nothing);
 
   CAML_EVENTLOG_DO({

@@ -27,6 +27,6 @@ CAMLprim value unix_kill(value pid, value signal)
   sig = caml_convert_signal_number(Int_val(signal));
   if (kill(Int_val(pid), sig) == -1)
     uerror("kill", Nothing);
-  caml_process_pending_actions();
+  caml_process_pending_signals();
   return Val_unit;
 }
@@ -49,9 +49,9 @@ static value encode_sigset(sigset_t * set)
   Begin_root(res)
     for (i = 1; i < NSIG; i++)
       if (sigismember(set, i) > 0) {
-        value newcons = caml_alloc_small(2, 0);
+        value newcons = caml_alloc_2(0,
-        Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i));
+          Val_int(caml_rev_convert_signal_number(i)),
-        Field(newcons, 1) = res;
+          res);
         res = newcons;
       }
   End_roots();
@@ -69,10 +69,10 @@ CAMLprim value unix_sigprocmask(value vaction, value vset)
   how = sigprocmask_cmd[Int_val(vaction)];
   decode_sigset(vset, &set);
   caml_enter_blocking_section();
-  retcode = caml_sigmask_hook(how, &set, &oldset);
+  retcode = sigprocmask(how, &set, &oldset);
   caml_leave_blocking_section();
   /* Run any handlers for just-unmasked pending signals */
-  caml_process_pending_actions();
+  caml_process_pending_signals();
   if (retcode != 0) unix_error(retcode, "sigprocmask", Nothing);
   return encode_sigset(&oldset);
 }
@@ -83,7 +83,7 @@ CAMLprim value unix_sigpending(value unit)
   int i;
   if (sigpending(&pending) == -1) uerror("sigpending", Nothing);
   for (i = 1; i < NSIG; i++)
-    if(caml_pending_signals[i])
+    if(atomic_load_explicit(&caml_pending_signals[i], memory_order_seq_cst))
       sigaddset(&pending, i);
   return encode_sigset(&pending);
 }

@@ -253,8 +253,6 @@ int error_table[] = {
   EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */
 };
 
-static const value * unix_error_exn = NULL;
-
 value unix_error_of_code (int errcode)
 {
   int errconstr;
@@ -288,18 +286,17 @@ int code_of_unix_error (value error)
 void unix_error(int errcode, const char *cmdname, value cmdarg)
 {
   value res;
+  const value * unix_error_exn;
   value name = Val_unit, err = Val_unit, arg = Val_unit;
 
   Begin_roots3 (name, err, arg);
     arg = cmdarg == Nothing ? caml_copy_string("") : cmdarg;
     name = caml_copy_string(cmdname);
     err = unix_error_of_code (errcode);
-    if (unix_error_exn == NULL) {
+    unix_error_exn = caml_named_value("Unix.Unix_error");
-      unix_error_exn = caml_named_value("Unix.Unix_error");
+    if (unix_error_exn == NULL)
-      if (unix_error_exn == NULL)
+      caml_invalid_argument("Exception Unix.Unix_error not initialized,"
-        caml_invalid_argument("Exception Unix.Unix_error not initialized,"
+                       " please link unix.cma");
-                         " please link unix.cma");
-    }
     res = caml_alloc_small(4, 0);
     Field(res, 0) = *unix_error_exn;
     Field(res, 1) = err;

@@ -20,22 +20,24 @@ include $(ROOTDIR)/Makefile.common
 # Lists of source files
 
 BYTECODE_C_SOURCES := $(addsuffix .c, \
-  interp misc stacks fix_code startup_aux startup_byt freelist major_gc \
+  interp misc fix_code startup_aux startup_byt major_gc \
-  minor_gc memory alloc roots_byt globroots fail_byt signals \
+  minor_gc memory alloc roots globroots fail_byt signals \
   signals_byt printexc backtrace_byt backtrace compare ints eventlog \
   floats str array io extern intern hash sys meta parsing gc_ctrl md5 obj \
-  lexing callback debugger weak compact finalise custom dynlink \
+  lexing callback debugger weak finalise custom dynlink \
-  afl $(UNIX_OR_WIN32) bigarray main memprof domain \
+  platform fiber shared_heap addrmap \
-  skiplist codefrag)
+  afl $(UNIX_OR_WIN32) bigarray main memprof domain sync \
+  skiplist lf_skiplist codefrag)
 
 NATIVE_C_SOURCES := $(addsuffix .c, \
-  startup_aux startup_nat main fail_nat roots_nat signals \
+  startup_aux startup_nat main fail_nat roots signals \
-  signals_nat misc freelist major_gc minor_gc memory alloc compare ints \
+  signals_nat misc major_gc minor_gc memory alloc compare ints \
   floats str array io extern intern hash sys parsing gc_ctrl eventlog md5 obj \
-  lexing $(UNIX_OR_WIN32) printexc callback weak compact finalise custom \
+  lexing $(UNIX_OR_WIN32) printexc callback weak finalise custom \
   globroots backtrace_nat backtrace dynlink_nat debugger meta \
+  platform fiber shared_heap addrmap frame_descriptors \
   dynlink clambda_checks afl bigarray \
-  memprof domain skiplist codefrag)
+  memprof domain sync skiplist lf_skiplist codefrag)
 
 # Header files generated by configure
 CONFIGURED_HEADERS := caml/m.h caml/s.h caml/version.h
@@ -99,9 +101,11 @@ libcamlrunpic_OBJECTS := $(BYTECODE_C_SOURCES:.c=.bpic.$(O))
 
 libasmrun_OBJECTS := $(NATIVE_C_SOURCES:.c=.n.$(O)) $(ASM_OBJECTS)
 
-libasmrund_OBJECTS := $(NATIVE_C_SOURCES:.c=.nd.$(O)) $(ASM_OBJECTS)
+libasmrund_OBJECTS := \
+  $(NATIVE_C_SOURCES:.c=.nd.$(O)) $(ASM_OBJECTS:.$(O)=.d.$(O))
 
-libasmruni_OBJECTS := $(NATIVE_C_SOURCES:.c=.ni.$(O)) $(ASM_OBJECTS)
+libasmruni_OBJECTS := \
+  $(NATIVE_C_SOURCES:.c=.ni.$(O)) $(ASM_OBJECTS:.$(O)=.i.$(O))
 
 libasmrunpic_OBJECTS := $(NATIVE_C_SOURCES:.c=.npic.$(O)) \
   $(ASM_OBJECTS:.$(O)=_libasmrunpic.$(O))
@@ -375,12 +379,19 @@ $(foreach object_type,$(subst %,,$(object_types)), \
 
 # Compilation of assembly files
 
-%.o: %.S
+ASPP_ERROR = \
-	$(ASPP) $(ASPPFLAGS) -o $@ $< || \
+  { echo "If your assembler produced syntax errors, it is probably";\
-	{ echo "If your assembler produced syntax errors, it is probably";\
           echo "unhappy with the preprocessor. Check your assembler, or";\
           echo "try producing $*.o by hand.";\
           exit 2; }
+%.o: %.S
+	$(ASPP) $(ASPPFLAGS) -o $@ $< || $(ASPP_ERROR)
+
+%.d.o: %.S
+	$(ASPP) $(ASPPFLAGS) $(OC_DEBUG_CPPFLAGS) -o $@ $< || $(ASPP_ERROR)
+
+%.i.o: %.S
+	$(ASPP) $(ASPPFLAGS) $(OC_INSTR_CPPFLAGS) -o $@ $< || $(ASPP_ERROR)
 
 %_libasmrunpic.o: %.S
 	$(ASPP) $(ASPPFLAGS) $(SHAREDLIB_CFLAGS) -o $@ $<
@@ -397,6 +408,18 @@ amd64nt.obj: amd64nt.asm domain_state64.inc
 i386nt.obj: i386nt.asm domain_state32.inc
 	$(ASM)$@ $(ASMFLAGS) $<
 
+amd64nt.d.obj: amd64nt.asm domain_state64.inc
+	$(ASM)$@ $(ASMFLAGS) $(OC_DEBUG_CPPFLAGS) $<
+
+i386nt.d.obj: i386nt.asm domain_state32.inc
+	$(ASM)$@ $(ASMFLAGS) $(OC_DEBUG_CPPFLAGS) $<
+
+amd64nt.i.obj: amd64nt.asm domain_state64.inc
+	$(ASM)$@ $(ASMFLAGS) $(OC_INSTR_CPPFLAGS) $<
+
+i386nt.i.obj: i386nt.asm domain_state32.inc
+	$(ASM)$@ $(ASMFLAGS) $(OC_INSTR_CPPFLAGS) $<
+
 %_libasmrunpic.obj: %.asm
 	$(ASM)$@ $(ASMFLAGS) $<
 

@@ -0,0 +1,134 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                 Stephen Dolan, University of Cambridge                 */
+/*                                                                        */
+/*   Copyright 2015 University of Cambridge                               */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include "caml/config.h"
+#include "caml/memory.h"
+#include "caml/addrmap.h"
+
+#define MAX_CHAIN 100
+
+Caml_inline uintnat pos_initial(struct addrmap* t, value key)
+{
+  uintnat pos = (uintnat)key;
+  pos *= 0xcc9e2d51;
+  pos ^= (pos >> 17);
+
+  CAMLassert(Is_power_of_2(t->size));
+  return pos & (t->size - 1);
+}
+
+Caml_inline uintnat pos_next(struct addrmap* t, uintnat pos)
+{
+  return (pos + 1) & (t->size - 1);
+}
+
+int caml_addrmap_contains(struct addrmap* t, value key)
+{
+  uintnat pos, i;
+
+  CAMLassert(Is_block(key));
+  if (!t->entries) return 0;
+
+  for (i = 0, pos = pos_initial(t, key);
+       i < MAX_CHAIN;
+       i++, pos = pos_next(t, pos)) {
+    if (t->entries[pos].key == ADDRMAP_INVALID_KEY) break;
+    if (t->entries[pos].key == key) return 1;
+  }
+  return 0;
+}
+
+value caml_addrmap_lookup(struct addrmap* t, value key)
+{
+  uintnat pos;
+
+  CAMLassert(Is_block(key));
+  CAMLassert(t->entries);
+
+  for (pos = pos_initial(t, key); ; pos = pos_next(t, pos)) {
+    CAMLassert(t->entries[pos].key != ADDRMAP_INVALID_KEY);
+    if (t->entries[pos].key == key)
+      return t->entries[pos].value;
+  }
+}
+
+static void addrmap_alloc(struct addrmap* t, uintnat sz)
+{
+  uintnat i;
+  CAMLassert(Is_power_of_2(sz));
+  t->entries = caml_stat_alloc(sizeof(struct addrmap_entry) * sz);
+  t->size = sz;
+  for (i = 0; i < sz; i++) {
+    t->entries[i].key = ADDRMAP_INVALID_KEY;
+    t->entries[i].value = ADDRMAP_NOT_PRESENT;
+  }
+}
+
+void caml_addrmap_clear(struct addrmap* t) {
+  caml_stat_free(t->entries);
+  t->entries = 0;
+  t->size = 0;
+}
+
+
+
+value* caml_addrmap_insert_pos(struct addrmap* t, value key) {
+  uintnat i, pos;
+  CAMLassert(Is_block(key));
+  if (!t->entries) {
+    /* first call, initialise table with a small initial size */
+    addrmap_alloc(t, 256);
+  }
+  for (i = 0, pos = pos_initial(t, key);
+       i < MAX_CHAIN;
+       i++,   pos = pos_next(t, pos)) {
+    if (t->entries[pos].key == ADDRMAP_INVALID_KEY) {
+      t->entries[pos].key = key;
+    }
+    if (t->entries[pos].key == key) {
+      return &t->entries[pos].value;
+    }
+  }
+  /* failed to insert, rehash and try again */
+  {
+    struct addrmap_entry* old_table = t->entries;
+    uintnat old_size = t->size;
+    addrmap_alloc(t, old_size * 2);
+    for (i = 0; i < old_size; i++) {
+      if (old_table[i].key != ADDRMAP_INVALID_KEY) {
+        value* p = caml_addrmap_insert_pos(t, old_table[i].key);
+        CAMLassert(*p == ADDRMAP_NOT_PRESENT);
+        *p = old_table[i].value;
+      }
+    }
+    caml_stat_free(old_table);
+  }
+  return caml_addrmap_insert_pos(t, key);
+}
+
+void caml_addrmap_insert(struct addrmap* t, value k, value v) {
+  value* p = caml_addrmap_insert_pos(t, k);
+  CAMLassert(*p == ADDRMAP_NOT_PRESENT);
+  *p = v;
+}
+
+void caml_addrmap_iter(struct addrmap* t, void (*f)(value, value)) {
+  addrmap_iterator i;
+  for (i = caml_addrmap_iterator(t);
+       caml_addrmap_iter_ok(t, i);
+       i = caml_addrmap_next(t, i)) {
+    f(caml_addrmap_iter_key(t, i),
+      caml_addrmap_iter_value(t, i));
+  }
+}
@@ -23,6 +23,7 @@ uintnat caml_afl_prev_loc;
 #if !defined(HAS_SYS_SHM_H) || !defined(HAS_SHMAT)
 
 #include "caml/mlvalues.h"
+#include "caml/domain.h"
 
 CAMLprim value caml_reset_afl_instrumentation(value full)
 {
@@ -113,10 +114,15 @@ CAMLexport value caml_setup_afl(value unit)
   }
   afl_read();
 
+  /* ensure that another module has not already spawned a domain */
+  if (!caml_domain_is_multicore())
+    caml_fatal_error("afl-fuzz: cannot fork with multiple domains running");
+
   while (1) {
     int child_pid = fork();
     if (child_pid < 0) caml_fatal_error("afl-fuzz: could not fork");
     else if (child_pid == 0) {
+      caml_atfork_hook();
       /* Run the program */
       close(FORKSRV_FD_READ);
       close(FORKSRV_FD_WRITE);

@@ -21,16 +21,14 @@
 */
 
 #include <string.h>
+#include <stdarg.h>
 #include "caml/alloc.h"
 #include "caml/custom.h"
 #include "caml/major_gc.h"
 #include "caml/memory.h"
 #include "caml/mlvalues.h"
-#include "caml/stacks.h"
+#include "caml/fiber.h"
-#include "caml/signals.h"
+#include "caml/domain.h"
-
-#define Setup_for_gc
-#define Restore_after_gc
 
 CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag)
 {
@@ -43,29 +41,134 @@ CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag)
     if (wosize == 0){
       result = Atom (tag);
     }else{
-      Alloc_small (result, wosize, tag);
+      Alloc_small (result, wosize, tag,
+                   { caml_handle_gc_interrupt_no_async_exceptions(); });
       if (tag < No_scan_tag){
         for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
       }
     }
-  }else{
+  } else {
     result = caml_alloc_shr (wosize, tag);
-    if (tag < No_scan_tag){
+    if (tag < No_scan_tag) {
       for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
     }
     result = caml_check_urgent_gc (result);
   }
   return result;
 }
 
+Caml_inline void enter_gc_preserving_vals(mlsize_t wosize, value* vals)
+{
+  mlsize_t i;
+  CAMLparam0();
+  /* Copy the values to be preserved to a different array.
+     The original vals array never escapes, generating better code in
+     the fast path. */
+  CAMLlocalN(vals_copy, wosize);
+  for (i = 0; i < wosize; i++) vals_copy[i] = vals[i];
+  caml_handle_gc_interrupt_no_async_exceptions();
+  for (i = 0; i < wosize; i++) vals[i] = vals_copy[i];
+  CAMLreturn0;
+}
+
+Caml_inline value do_alloc_small(mlsize_t wosize, tag_t tag, value* vals)
+{
+  value v;
+  mlsize_t i;
+  CAMLassert (tag < 256);
+  Alloc_small(v, wosize, tag,
+      { enter_gc_preserving_vals(wosize, vals); });
+  for (i = 0; i < wosize; i++) {
+    Field(v, i) = vals[i];
+  }
+  return v;
+}
+
+
+CAMLexport value caml_alloc_1 (tag_t tag, value a)
+{
+  value v[1] = {a};
+  return do_alloc_small(1, tag, v);
+}
+
+CAMLexport value caml_alloc_2 (tag_t tag, value a, value b)
+{
+  value v[2] = {a, b};
+  return do_alloc_small(2, tag, v);
+}
+
+CAMLexport value caml_alloc_3 (tag_t tag, value a, value b, value c)
+{
+  value v[3] = {a, b, c};
+  return do_alloc_small(3, tag, v);
+}
+
+CAMLexport value caml_alloc_4 (tag_t tag, value a, value b, value c, value d)
+{
+  value v[4] = {a, b, c, d};
+  return do_alloc_small(4, tag, v);
+}
+
+CAMLexport value caml_alloc_5 (tag_t tag, value a, value b, value c, value d,
+                               value e)
+{
+  value v[5] = {a, b, c, d, e};
+  return do_alloc_small(5, tag, v);
+}
+
+CAMLexport value caml_alloc_6 (tag_t tag, value a, value b, value c, value d,
+                               value e, value f)
+{
+  value v[6] = {a, b, c, d, e, f};
+  return do_alloc_small(6, tag, v);
+}
+
+CAMLexport value caml_alloc_7 (tag_t tag, value a, value b, value c, value d,
+                               value e, value f, value g)
+{
+  value v[7] = {a, b, c, d, e, f, g};
+  return do_alloc_small(7, tag, v);
+}
+
+CAMLexport value caml_alloc_8 (tag_t tag, value a, value b, value c, value d,
+                               value e, value f, value g, value h)
+{
+  value v[8] = {a, b, c, d, e, f, g, h};
+  return do_alloc_small(8, tag, v);
+}
+
+CAMLexport value caml_alloc_9 (tag_t tag, value a, value b, value c, value d,
+                               value e, value f, value g, value h, value i)
+{
+  value v[9] = {a, b, c, d, e, f, g, h, i};
+  return do_alloc_small(9, tag, v);
+}
+
+CAMLexport value caml_alloc_N (mlsize_t wosize, tag_t tag, ...)
+{
+  va_list args;
+  mlsize_t i;
+  value vals[wosize];
+  value ret;
+  va_start(args, tag);
+  for (i = 0; i < wosize; i++)
+    vals[i] = va_arg(args, value);
+  ret = do_alloc_small(wosize, tag, vals);
+  va_end(args);
+  return ret;
+}
+
+
 CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag)
 {
   value result;
 
   CAMLassert (wosize > 0);
   CAMLassert (wosize <= Max_young_wosize);
   CAMLassert (tag < 256);
-  Alloc_small (result, wosize, tag);
+  CAMLassert (tag != Infix_tag);
+  Alloc_small (result, wosize, tag,
+               { caml_handle_gc_interrupt_no_async_exceptions(); });
   return result;
 }
 
@@ -83,7 +186,8 @@ CAMLexport value caml_alloc_string (mlsize_t len)
   mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
 
   if (wosize <= Max_young_wosize) {
-    Alloc_small (result, wosize, String_tag);
+    Alloc_small (result, wosize, String_tag,
+                 { caml_handle_gc_interrupt_no_async_exceptions(); });
   }else{
     result = caml_alloc_shr (wosize, String_tag);
     result = caml_check_urgent_gc (result);
@@ -123,7 +227,7 @@ CAMLexport value caml_copy_string(char const *s)
 }
 
 CAMLexport value caml_alloc_array(value (*funct)(char const *),
-                                  char const ** arr)
+                                  char const * const* arr)
 {
   CAMLparam0 ();
   mlsize_t nbr, n;
@@ -155,8 +259,9 @@ value caml_alloc_float_array(mlsize_t len)
     if (wosize == 0)
       return Atom(0);
     else
-      Alloc_small (result, wosize, Double_array_tag);
+      Alloc_small (result, wosize, Double_array_tag,
-  }else {
+                   { caml_handle_gc_interrupt_no_async_exceptions(); });
+  } else {
     result = caml_alloc_shr (wosize, Double_array_tag);
     result = caml_check_urgent_gc (result);
   }
@@ -167,12 +272,12 @@ value caml_alloc_float_array(mlsize_t len)
 }
 
 
-CAMLexport value caml_copy_string_array(char const ** arr)
+CAMLexport value caml_copy_string_array(char const * const * arr)
 {
   return caml_alloc_array(caml_copy_string, arr);
 }
 
-CAMLexport int caml_convert_flag_list(value list, int *flags)
+CAMLexport int caml_convert_flag_list(value list, const int *flags)
 {
   int res;
   res = 0;
@@ -218,7 +323,7 @@ CAMLprim value caml_alloc_dummy_infix(value vsize, value voffset)
   Closinfo_val(v) = Make_closinfo(0, wosize);
   if (offset > 0) {
     v += Bsize_wsize(offset);
-    Hd_val(v) = Make_header(offset, Infix_tag, Caml_white);
+    (((header_t *) (v)) [-1]) = Make_header(offset, Infix_tag, 0);
   }
   return v;
 }

@@ -68,11 +68,8 @@ CAMLprim value caml_floatarray_get(value array, value index)
   if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
     caml_array_bound_error();
   d = Double_flat_field(array, idx);
-#define Setup_for_gc
+  Alloc_small(res, Double_wosize, Double_tag,
-#define Restore_after_gc
+    { caml_handle_gc_interrupt_no_async_exceptions(); });
-  Alloc_small(res, Double_wosize, Double_tag);
-#undef Setup_for_gc
-#undef Restore_after_gc
   Store_double_val(res, d);
   return res;
 }
@@ -131,11 +128,8 @@ CAMLprim value caml_floatarray_unsafe_get(value array, value index)
 
   CAMLassert (Tag_val(array) == Double_array_tag);
   d = Double_flat_field(array, idx);
-#define Setup_for_gc
+  Alloc_small(res, Double_wosize, Double_tag,
-#define Restore_after_gc
+    { caml_handle_gc_interrupt_no_async_exceptions(); });
-  Alloc_small(res, Double_wosize, Double_tag);
-#undef Setup_for_gc
-#undef Restore_after_gc
   Store_double_val(res, d);
   return res;
 }
@@ -161,6 +155,10 @@ static value caml_array_unsafe_set_addr(value array, value index,value newval)
 }
 
 /* [ floatarray -> int -> float -> unit ] */
+/* [MM]: [caml_array_unsafe_set_addr] has a fence for enforcing the OCaml
+   memory model through its use of [caml_modify].
+   [MM] [TODO]: [caml_floatarray_unsafe_set] will also need a similar fence in
+   [Store_double_flat_field]. */
 CAMLprim value caml_floatarray_unsafe_set(value array, value index,value newval)
 {
   intnat idx = Long_val(index);
@@ -191,18 +189,15 @@ CAMLprim value caml_floatarray_create(value len)
     if (wosize == 0)
       return Atom(0);
     else
-#define Setup_for_gc
+      Alloc_small (result, wosize, Double_array_tag,
-#define Restore_after_gc
+        { caml_handle_gc_interrupt_no_async_exceptions(); });
-      Alloc_small (result, wosize, Double_array_tag);
-#undef Setup_for_gc
-#undef Restore_after_gc
   }else if (wosize > Max_wosize)
     caml_invalid_argument("Float.Array.create");
   else {
     result = caml_alloc_shr (wosize, Double_array_tag);
   }
-  // Give the GC a chance to run, and run memprof callbacks
+  /* Give the GC a chance to run */
-  return caml_process_pending_actions_with_root (result);
+  return caml_check_urgent_gc (result);
 }
 
 /* [len] is a [value] representing number of words or floats */
@@ -217,8 +212,7 @@ CAMLprim value caml_make_vect(value len, value init)
     res = Atom(0);
 #ifdef FLAT_FLOAT_ARRAY
   } else if (Is_block(init)
-           && Is_in_value_area(init)
+             && Tag_val(init) == Double_tag) {
-           && Tag_val(init) == Double_tag) {
     mlsize_t wsize;
     double d;
     d = Double_val(init);
@@ -249,7 +243,7 @@ CAMLprim value caml_make_vect(value len, value init)
       for (i = 0; i < size; i++) Field(res, i) = init;
     }
   }
-  // Give the GC a chance to run, and run memprof callbacks
+  /* Give the GC a chance to run */
   caml_process_pending_actions ();
   CAMLreturn (res);
 }
@@ -289,7 +283,6 @@ CAMLprim value caml_make_array(value init)
   } else {
     v = Field(init, 0);
     if (Is_long(v)
-        || ! Is_in_value_area(v)
         || Tag_val(v) != Double_tag) {
       CAMLreturn (init);
     } else {
@@ -303,7 +296,6 @@ CAMLprim value caml_make_array(value init)
         double d = Double_val(Field(init, i));
         Store_double_flat_field(res, i, d);
       }
-      // run memprof callbacks
       caml_process_pending_actions();
       CAMLreturn (res);
     }
@@ -315,9 +307,48 @@ CAMLprim value caml_make_array(value init)
 
 /* Blitting */
 
+/* [wo_memmove] copies [nvals] values from [src] to [dst]. If there is a single
+   domain running, then we use [memmove]. Otherwise, we copy one word at a
+   time.
+
+   Since the [memmove] implementation does not guarantee that the writes are
+   always word-sized, we explicitly perform word-sized writes of the release
+   kind to avoid mixed-mode accesses. Performing release writes should be
+   sufficient to prevent smart compilers from coalesing the writes into vector
+   writes, and hence prevent mixed-mode accesses. [MM].
+   */
+static void wo_memmove (value* const dst, const value* const src,
+                        mlsize_t nvals)
+{
+  mlsize_t i;
+
+  if (caml_domain_alone ()) {
+    memmove (dst, src, nvals * sizeof (value));
+  } else {
+    /* See memory model [MM] notes in memory.c */
+    atomic_thread_fence(memory_order_acquire);
+    if (dst < src) {
+      /* copy ascending */
+      for (i = 0; i < nvals; i++)
+        atomic_store_explicit(&((atomic_value*)dst)[i], src[i],
+                              memory_order_release);
+
+    } else {
+      /* copy descending */
+      for (i = nvals; i > 0; i--)
+        atomic_store_explicit(&((atomic_value*)dst)[i-1], src[i-1],
+                              memory_order_release);
+    }
+  }
+}
+
+/* [MM] [TODO]: Not consistent with the memory model. See the discussion in
+   https://github.com/ocaml-multicore/ocaml-multicore/pull/822. */
 CAMLprim value caml_floatarray_blit(value a1, value ofs1, value a2, value ofs2,
                                     value n)
 {
+  /* See memory model [MM] notes in memory.c */
+  atomic_thread_fence(memory_order_acquire);
   memmove((double *)a2 + Long_val(ofs2),
           (double *)a1 + Long_val(ofs1),
           Long_val(n) * sizeof(double));
@@ -339,10 +370,10 @@ CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2,
     /* Arrays of values, destination is in young generation.
        Here too we can do a direct copy since this cannot create
        old-to-young pointers, nor mess up with the incremental major GC.
-       Again, memmove takes care of overlap. */
+       Again, wo_memmove takes care of overlap. */
-    memmove(&Field(a2, Long_val(ofs2)),
+    wo_memmove(&Field(a2, Long_val(ofs2)),
-            &Field(a1, Long_val(ofs1)),
+               &Field(a1, Long_val(ofs1)),
-            Long_val(n) * sizeof(value));
+               Long_val(n));
     return Val_unit;
   }
   /* Array of values, destination is in old generation.
@@ -406,6 +437,8 @@ static value caml_array_gather(intnat num_arrays,
     wsize = size * Double_wosize;
     res = caml_alloc(wsize, Double_array_tag);
     for (i = 0, pos = 0; i < num_arrays; i++) {
+      /* [res] is freshly allocated, and no other domain has a reference to it.
+         Hence, a plain [memcpy] is sufficient. */
       memcpy((double *)res + pos,
              (double *)arrays[i] + offsets[i],
              lengths[i] * sizeof(double));
@@ -419,6 +452,8 @@ static value caml_array_gather(intnat num_arrays,
        We can use memcpy directly. */
     res = caml_alloc_small(size, 0);
     for (i = 0, pos = 0; i < num_arrays; i++) {
+      /* [res] is freshly allocated, and no other domain has a reference to it.
+         Hence, a plain [memcpy] is sufficient. */
       memcpy(&Field(res, pos),
              &Field(arrays[i], offsets[i]),
              lengths[i] * sizeof(value));
@@ -445,7 +480,7 @@ static value caml_array_gather(intnat num_arrays,
     /* Many caml_initialize in a row can create a lot of old-to-young
        refs.  Give the minor GC a chance to run if it needs to.
        Run memprof callbacks for the major allocation. */
-    res = caml_process_pending_actions_with_root (res);
+    res = caml_check_urgent_gc(res);
   }
   CAMLreturn (res);
 }
@@ -539,17 +574,16 @@ CAMLprim value caml_array_fill(value array,
     for (; len > 0; len--, fp++) *fp = val;
   } else {
     int is_val_young_block = Is_block(val) && Is_young(val);
-    CAMLassert(Is_in_heap(fp));
     for (; len > 0; len--, fp++) {
       value old = *fp;
       if (old == val) continue;
       *fp = val;
       if (Is_block(old)) {
         if (Is_young(old)) continue;
-        if (caml_gc_phase == Phase_mark) caml_darken(old, NULL);
+        caml_darken(NULL, old, NULL);
       }
       if (is_val_young_block)
-        add_to_ref_table (Caml_state->ref_table, fp);
+        Ref_table_add(&Caml_state->minor_tables->major_ref, fp);
     }
     if (is_val_young_block) caml_check_urgent_gc (Val_unit);
   }

@@ -29,23 +29,14 @@
 #include "caml/debugger.h"
 #include "caml/startup.h"
 
-void caml_init_backtrace(void)
-{
-  caml_register_global_root(&Caml_state->backtrace_last_exn);
-}
-
 /* Start or stop the backtrace machinery */
 CAMLexport void caml_record_backtraces(int flag)
 {
   if (flag != Caml_state->backtrace_active) {
     Caml_state->backtrace_active = flag;
     Caml_state->backtrace_pos = 0;
-    Caml_state->backtrace_last_exn = Val_unit;
+    caml_modify_generational_global_root(&Caml_state->backtrace_last_exn,
-    /* Note: We do lazy initialization of Caml_state->backtrace_buffer when
+                                         Val_unit);
-       needed in order to simplify the interface with the thread
-       library (thread creation doesn't need to allocate
-       Caml_state->backtrace_buffer). So we don't have to allocate it here.
-    */
   }
   return;
 }
@@ -166,17 +157,35 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit)
   CAMLparam0();
   CAMLlocal1(res);
 
+  /* Beware: the allocations below may cause finalizers to be run, and another
+     backtrace---possibly of a different length---to be stashed (for example
+     if the finalizer raises then catches an exception).  We choose to ignore
+     any such finalizer backtraces and return the original one. */
+
   if (!Caml_state->backtrace_active ||
       Caml_state->backtrace_buffer == NULL ||
       Caml_state->backtrace_pos == 0) {
     res = caml_alloc(0, 0);
   }
   else {
-    intnat i, len = Caml_state->backtrace_pos;
+    backtrace_slot saved_caml_backtrace_buffer[BACKTRACE_BUFFER_SIZE];
+    int saved_caml_backtrace_pos;
+    intnat i;
+
+    saved_caml_backtrace_pos = Caml_state->backtrace_pos;
+
+    if (saved_caml_backtrace_pos > BACKTRACE_BUFFER_SIZE) {
+      saved_caml_backtrace_pos = BACKTRACE_BUFFER_SIZE;
+    }
+
+    memcpy(saved_caml_backtrace_buffer, Caml_state->backtrace_buffer,
+           saved_caml_backtrace_pos * sizeof(backtrace_slot));
 
-    res = caml_alloc(len, 0);
+    res = caml_alloc(saved_caml_backtrace_pos, 0);
-    for (i = 0; i < len; i++)
+    for (i = 0; i < saved_caml_backtrace_pos; i++) {
-      Field(res, i) = Val_backtrace_slot(Caml_state->backtrace_buffer[i]);
+      caml_initialize(&Field(res, i),
+                      Val_backtrace_slot(saved_caml_backtrace_buffer[i]));
+    }
   }
 
   CAMLreturn(res);
@@ -190,7 +199,9 @@ CAMLprim value caml_restore_raw_backtrace(value exn, value backtrace)
   intnat i;
   mlsize_t bt_size;
 
-  Caml_state->backtrace_last_exn = exn;
+  caml_domain_state* domain_state = Caml_state;
+
+  caml_modify_generational_global_root (&domain_state->backtrace_last_exn, exn);
 
   bt_size = Wosize_val(backtrace);
   if(bt_size > BACKTRACE_BUFFER_SIZE){
@@ -200,19 +211,19 @@ CAMLprim value caml_restore_raw_backtrace(value exn, value backtrace)
   /* We don't allocate if the backtrace is empty (no -g or backtrace
      not activated) */
   if(bt_size == 0){
-    Caml_state->backtrace_pos = 0;
+    domain_state->backtrace_pos = 0;
     return Val_unit;
   }
 
   /* Allocate if needed and copy the backtrace buffer */
-  if (Caml_state->backtrace_buffer == NULL &&
+  if (domain_state->backtrace_buffer == NULL
-      caml_alloc_backtrace_buffer() == -1) {
+      && caml_alloc_backtrace_buffer() == -1){
     return Val_unit;
   }
 
-  Caml_state->backtrace_pos = bt_size;
+  domain_state->backtrace_pos = bt_size;
-  for(i=0; i < Caml_state->backtrace_pos; i++){
+  for(i=0; i < domain_state->backtrace_pos; i++){
-    Caml_state->backtrace_buffer[i] = Backtrace_slot_val(Field(backtrace, i));
+    domain_state->backtrace_buffer[i] = Backtrace_slot_val(Field(backtrace, i));
   }
 
   return Val_unit;
@@ -358,23 +369,9 @@ CAMLprim value caml_get_exception_backtrace(value unit)
       Store_field(arr, i, caml_convert_debuginfo(dbg));
     }
 
-    res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
+    res = caml_alloc_small(1, 0);
+    Field(res, 0) = arr; /* Some */
   }
 
   CAMLreturn(res);
 }
-
-CAMLprim value caml_get_current_callstack(value max_frames_value)
-{
-  CAMLparam1(max_frames_value);
-  CAMLlocal1(res);
-  value* callstack = NULL;
-  intnat callstack_alloc_len = 0;
-  intnat callstack_len =
-    caml_collect_current_callstack(&callstack, &callstack_alloc_len,
-                                   Long_val(max_frames_value), -1);
-  res = caml_alloc(callstack_len, 0);
-  memcpy(Op_val(res), callstack, sizeof(value) * callstack_len);
-  caml_stat_free(callstack);
-  CAMLreturn(res);
-}
@@ -37,7 +37,7 @@
 #include "caml/fix_code.h"
 #include "caml/memory.h"
 #include "caml/startup.h"
-#include "caml/stacks.h"
+#include "caml/fiber.h"
 #include "caml/sys.h"
 #include "caml/backtrace.h"
 #include "caml/fail.h"
@@ -257,7 +257,8 @@ value caml_remove_debug_info(code_t start)
   CAMLreturn(Val_unit);
 }
 
-int caml_alloc_backtrace_buffer(void){
+int caml_alloc_backtrace_buffer (void)
+{
   CAMLassert(Caml_state->backtrace_pos == 0);
   Caml_state->backtrace_buffer =
     caml_stat_alloc_noexc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
@@ -270,9 +271,11 @@ int caml_alloc_backtrace_buffer(void){
 
 void caml_stash_backtrace(value exn, value * sp, int reraise)
 {
+  value *trap_sp;
+
   if (exn != Caml_state->backtrace_last_exn || !reraise) {
     Caml_state->backtrace_pos = 0;
-    Caml_state->backtrace_last_exn = exn;
+    caml_modify_generational_global_root(&Caml_state->backtrace_last_exn, exn);
   }
 
   if (Caml_state->backtrace_buffer == NULL &&
@@ -281,7 +284,8 @@ void caml_stash_backtrace(value exn, value * sp, int reraise)
 
   /* Traverse the stack and put all values pointing into bytecode
      into the backtrace buffer. */
-  for (/*nothing*/; sp < Caml_state->trapsp; sp++) {
+  trap_sp = Stack_high(Caml_state->current_stack) + Caml_state->trap_sp_off;
+  for (/*nothing*/; sp < trap_sp; sp++) {
     code_t p;
     if (Is_long(*sp)) continue;
     p = (code_t) *sp;
@@ -292,18 +296,19 @@ void caml_stash_backtrace(value exn, value * sp, int reraise)
 }
 
 /* returns the next frame pointer (or NULL if none is available);
-   updates *sp to point to the following one, and *trsp to the next
+   updates *sp to point to the following one, and *trap_spoff to the next
    trap frame, which we will skip when we reach it  */
 
-code_t caml_next_frame_pointer(value ** sp, value ** trsp)
+code_t caml_next_frame_pointer(value* stack_high, value ** sp,
+                          intnat * trap_spoff)
 {
-  while (*sp < Caml_state->stack_high) {
+  while (*sp < stack_high) {
     value *spv = (*sp)++;
     code_t *p;
     if (Is_long(*spv)) continue;
     p = (code_t*) spv;
-    if(&Trap_pc(*trsp) == p) {
+    if((code_t*)&Trap_pc(stack_high + *trap_spoff) == p) {
-      *trsp = *trsp + Long_val(Trap_link_offset(*trsp));
+      *trap_spoff = Trap_link(stack_high + *trap_spoff);
       continue;
     }
 
@@ -313,40 +318,110 @@ code_t caml_next_frame_pointer(value ** sp, value ** trsp)
   return NULL;
 }
 
-#define Default_callstack_size 32
+/* Stores upto [max_frames_value] frames of the current call stack to
-intnat caml_collect_current_callstack(value** ptrace, intnat* plen,
+   return to the user. This is used not in an exception-raising context, but
-                                      intnat max_frames, int alloc_idx)
+   only when the user requests to save the trace (hopefully less often).
+   Instead of using a bounded buffer as [Caml_state->stash_backtrace], we first
+   traverse the stack to compute the right size, then allocate space for the
+   trace. */
+
+static void get_callstack(value* sp, intnat trap_spoff,
+                          struct stack_info* stack,
+                          intnat max_frames,
+                          code_t** trace, intnat* trace_size)
 {
-  value * sp = Caml_state->extern_sp;
+  struct stack_info* parent = Stack_parent(stack);
-  value * trsp = Caml_state->trapsp;
+  value *stack_high = Stack_high(stack);
-  intnat trace_pos = 0;
+  value* saved_sp = sp;
-  CAMLassert(alloc_idx == 0 || alloc_idx == -1);
+  intnat saved_trap_spoff = trap_spoff;
-
+
-  if (max_frames <= 0) return 0;
+  CAMLnoalloc;
-  if (*plen == 0) {
+
-    value* trace =
+  /* first compute the size of the trace */
-      caml_stat_alloc_noexc(Default_callstack_size * sizeof(value));
+  {
-    if (trace == NULL) return 0;
+    *trace_size = 0;
-    *ptrace = trace;
+    while (*trace_size < max_frames) {
-    *plen = Default_callstack_size;
+      code_t p = caml_next_frame_pointer(stack_high, &sp, &trap_spoff);
+      if (p == NULL) {
+        if (parent == NULL) break;
+        sp = parent->sp;
+        trap_spoff = Long_val(sp[0]);
+        stack_high = Stack_high(parent);
+        parent = Stack_parent(parent);
+      } else {
+        ++*trace_size;
+      }
+    }
   }
 
-  while (trace_pos < max_frames) {
+  *trace = caml_stat_alloc(sizeof(code_t*) * *trace_size);
-    code_t p = caml_next_frame_pointer(&sp, &trsp);
+
-    if (p == NULL) break;
+  sp = saved_sp;
-    if (trace_pos == *plen) {
+  parent = Stack_parent(stack);
-      intnat new_len = *plen * 2;
+  stack_high = Stack_high(stack);
-      value * trace = caml_stat_resize_noexc(*ptrace, new_len * sizeof(value));
+  trap_spoff = saved_trap_spoff;
-      if (trace == NULL) break;
+
-      *ptrace = trace;
+  /* then collect the trace */
-      *plen = new_len;
+  {
+    uintnat trace_pos = 0;
+
+    while (trace_pos < *trace_size) {
+      code_t p = caml_next_frame_pointer(stack_high, &sp, &trap_spoff);
+      if (p == NULL) {
+        sp = parent->sp;
+        trap_spoff = Long_val(sp[0]);
+        stack_high = Stack_high(parent);
+        parent = Stack_parent(parent);
+      } else {
+        (*trace)[trace_pos] = p;
+        ++trace_pos;
+      }
     }
-    (*ptrace)[trace_pos++] = Val_backtrace_slot(p);
   }
+}
 
-  return trace_pos;
+static value alloc_callstack(code_t* trace, intnat trace_len)
+{
+  CAMLparam0();
+  CAMLlocal1(callstack);
+  int i;
+  callstack = caml_alloc(trace_len, 0);
+  for (i = 0; i < trace_len; i++)
+    Store_field(callstack, i, Val_backtrace_slot(trace[i]));
+  caml_stat_free(trace);
+  CAMLreturn(callstack);
+}
+
+CAMLprim value caml_get_current_callstack (value max_frames_value)
+{
+  code_t* trace;
+  intnat trace_len;
+  get_callstack(Caml_state->current_stack->sp, Caml_state->trap_sp_off,
+                Caml_state->current_stack, Long_val(max_frames_value),
+                &trace, &trace_len);
+  return alloc_callstack(trace, trace_len);
 }
 
+CAMLprim value caml_get_continuation_callstack (value cont, value max_frames)
+{
+  code_t* trace;
+  intnat trace_len;
+  struct stack_info *stack;
+  value *sp;
+
+  stack = Ptr_val(caml_continuation_use(cont));
+  {
+    CAMLnoalloc; /* GC must not see the stack outside the cont */
+    sp = stack->sp;
+    get_callstack(sp, Long_val(sp[0]), stack, Long_val(max_frames),
+                  &trace, &trace_len);
+    caml_continuation_replace(cont, stack);
+  }
+
+  return alloc_callstack(trace, trace_len);
+}
+
+
 /* Read the debugging info contained in the current bytecode executable. */
 
 static void read_main_debug_info(struct debug_info *di)
@@ -366,13 +441,13 @@ static void read_main_debug_info(struct debug_info *di)
 
      See  https://github.com/ocaml/ocaml/issues/9344 for details.
   */
-  if (caml_cds_file == NULL && caml_byte_program_mode == COMPLETE_EXE)
+  if (caml_params->cds_file == NULL && caml_byte_program_mode == COMPLETE_EXE)
     CAMLreturn0;
 
-  if (caml_cds_file != NULL) {
+  if (caml_params->cds_file != NULL) {
-    exec_name = caml_cds_file;
+    exec_name = (char_os*) caml_params->cds_file;
   } else {
-    exec_name = caml_exe_name;
+    exec_name = (char_os*) caml_params->exe_name;
   }
 
   fd = caml_attempt_open(&exec_name, &trail, 1);
@@ -397,7 +472,7 @@ static void read_main_debug_info(struct debug_info *di)
       /* Relocate events in event list */
       for (l = evl; l != Val_int(0); l = Field(l, 1)) {
         value ev = Field(l, 0);
-        Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
+        Store_field (ev, EV_POS, Val_long(Long_val(Field(ev, EV_POS)) + orig));
       }
       /* Record event list */
       Store_field(events, i, evl);
@@ -422,7 +497,7 @@ CAMLexport void caml_init_debug_info(void)
 
 CAMLexport void caml_load_main_debug_info(void)
 {
-  if (Caml_state->backtrace_active > 1) {
+  if (caml_params->backtrace_enabled > 1) {
     read_main_debug_info(caml_debug_info.contents[0]);
   }
 }

@@ -24,43 +24,46 @@
 #include "caml/alloc.h"
 #include "caml/backtrace.h"
 #include "caml/backtrace_prim.h"
+#include "caml/frame_descriptors.h"
+#include "caml/stack.h"
 #include "caml/memory.h"
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
-#include "caml/stack.h"
+#include "caml/fiber.h"
+#include "caml/fail.h"
 
 /* Returns the next frame descriptor (or NULL if none is available),
    and updates *pc and *sp to point to the following one.  */
-frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
+frame_descr * caml_next_frame_descriptor
+    (caml_frame_descrs fds, uintnat * pc, char ** sp, struct stack_info* stack)
 {
   frame_descr * d;
-  uintnat h;
 
   while (1) {
-    h = Hash_retaddr(*pc);
+    d = caml_find_frame_descr(fds, *pc);
-    while (1) {
+
-      d = caml_frame_descriptors[h];
+    if( d == NULL ) {
-      if (d == NULL) return NULL; /* happens if some code compiled without -g */
+      return NULL;
-      if (d->retaddr == *pc) break;
-      h = (h+1) & caml_frame_descriptors_mask;
     }
+
     /* Skip to next frame */
     if (d->frame_size != 0xFFFF) {
       /* Regular frame, update sp/pc and return the frame descriptor */
       *sp += (d->frame_size & 0xFFFC);
       *pc = Saved_return_address(*sp);
-#ifdef Mask_already_scanned
-      *pc = Mask_already_scanned(*pc);
-#endif
       return d;
     } else {
-      /* Special frame marking the top of a stack chunk for an ML callback.
+      /* This marks the top of an ML stack chunk. Move sp to the previous stack
-         Skip C portion of stack and continue with next ML stack chunk. */
+       chunk. This includes skipping over the DWARF link & trap frame
-      struct caml_context * next_context = Callback_link(*sp);
+       (4 words). */
-      *sp = next_context->bottom_of_stack;
+      *sp += 4 * sizeof(value);
-      *pc = next_context->last_retaddr;
+      if (*sp == (char*)Stack_high(stack)) {
-      /* A null sp means no more ML stack chunks; stop here. */
+        /* We've reached the top of stack. No more frames. */
-      if (*sp == NULL) return NULL;
+        *pc = 0;
+        return NULL;
+      }
+      *pc = **(uintnat**)sp;
+      *sp += sizeof(value); /* return address */
     }
   }
 }
@@ -79,91 +82,139 @@ int caml_alloc_backtrace_buffer(void){
    preserved the global, statically bounded buffer of the old
    implementation -- before the more flexible
    [caml_get_current_callstack] was implemented. */
-void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
+void caml_stash_backtrace(value exn, uintnat pc, char * sp, char* trapsp)
 {
-  if (exn != Caml_state->backtrace_last_exn) {
+  caml_domain_state* domain_state = Caml_state;
-    Caml_state->backtrace_pos = 0;
+  caml_frame_descrs fds;
-    Caml_state->backtrace_last_exn = exn;
+
+  if (exn != domain_state->backtrace_last_exn) {
+    domain_state->backtrace_pos = 0;
+    caml_modify_generational_global_root
+      (&domain_state->backtrace_last_exn, exn);
   }
 
   if (Caml_state->backtrace_buffer == NULL &&
       caml_alloc_backtrace_buffer() == -1)
     return;
 
+  fds = caml_get_frame_descrs();
   /* iterate on each frame  */
   while (1) {
-    frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+    frame_descr * descr = caml_next_frame_descriptor
+                                (fds, &pc, &sp, domain_state->current_stack);
     if (descr == NULL) return;
     /* store its descriptor in the backtrace buffer */
-    if (Caml_state->backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
+    if (domain_state->backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
-    Caml_state->backtrace_buffer[Caml_state->backtrace_pos++] =
+    domain_state->backtrace_buffer[domain_state->backtrace_pos++] =
       (backtrace_slot) descr;
 
     /* Stop when we reach the current exception handler */
     if (sp > trapsp) return;
   }
 }
 
-/* A backtrace_slot is either a debuginfo or a frame_descr* */
+/* Stores upto [max_frames_value] frames of the current call stack to
-#define Slot_is_debuginfo(s) ((uintnat)(s) & 2)
+   return to the user. This is used not in an exception-raising
-#define Debuginfo_slot(s) ((debuginfo)((uintnat)(s) - 2))
+   context, but only when the user requests to save the trace
-#define Slot_debuginfo(d) ((backtrace_slot)((uintnat)(d) + 2))
+   (hopefully less often). Instead of using a bounded buffer as
-#define Frame_descr_slot(s) ((frame_descr*)(s))
+   [caml_stash_backtrace], we first traverse the stack to compute the
-#define Slot_frame_descr(f) ((backtrace_slot)(f))
+   right size, then allocate space for the trace. */
-static debuginfo debuginfo_extract(frame_descr* d, int alloc_idx);
+static void get_callstack(struct stack_info* orig_stack, intnat max_frames,
-
+                          frame_descr*** trace, intnat* trace_size)
-#define Default_callstack_size 32
-intnat caml_collect_current_callstack(value** ptrace, intnat* plen,
-                                      intnat max_frames, int alloc_idx)
 {
-  uintnat pc = Caml_state->last_return_address;
+  intnat trace_pos;
-  char * sp = Caml_state->bottom_of_stack;
+  char *sp;
-  intnat trace_pos = 0;
+  uintnat pc;
-
+  caml_frame_descrs fds;
-  if (max_frames <= 0) return 0;
+  CAMLnoalloc;
-  if (*plen == 0) {
-    value* trace =
-      caml_stat_alloc_noexc(Default_callstack_size * sizeof(value));
-    if (trace == NULL) return 0;
-    *ptrace = trace;
-    *plen = Default_callstack_size;
-  }
 
-  if (alloc_idx >= 0) {
+  fds = caml_get_frame_descrs();
-    /* First frame has a Comballoc selector */
+
-    frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+  /* first compute the size of the trace */
-    debuginfo info;
+  {
-    if (descr == NULL) return 0;
+    struct stack_info* stack = orig_stack;
-    info = debuginfo_extract(descr, alloc_idx);
+    caml_get_stack_sp_pc(stack, &sp, &pc);
-    if (info != NULL) {
+    trace_pos = 0;
-      CAMLassert(((uintnat)info & 3) == 0);
+
-      (*ptrace)[trace_pos++] = Val_backtrace_slot(Slot_debuginfo(info));
+    while(1) {
-    } else {
+      frame_descr *descr = caml_next_frame_descriptor(fds, &pc, &sp, stack);
-      (*ptrace)[trace_pos++] = Val_backtrace_slot(Slot_frame_descr(descr));
+      if (trace_pos >= max_frames) break;
+      if (descr == NULL) {
+        stack = Stack_parent(stack);
+        if (stack == NULL) break;
+        caml_get_stack_sp_pc(stack, &sp, &pc);
+      } else {
+        ++trace_pos;
+      }
     }
   }
 
-  while (trace_pos < max_frames) {
+  *trace_size = trace_pos;
-    frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
+  *trace = caml_stat_alloc(sizeof(frame_descr*) * trace_pos);
-    if (descr == NULL) break;
+
-    CAMLassert(((uintnat)descr & 3) == 0);
+  /* then collect the trace */
-    if (trace_pos == *plen) {
+  {
-      intnat new_len = *plen * 2;
+    struct stack_info* stack = orig_stack;
-      value * trace = caml_stat_resize_noexc(*ptrace, new_len * sizeof(value));
+    caml_get_stack_sp_pc(stack, &sp, &pc);
-      if (trace == NULL) break;
+    trace_pos = 0;
-      *ptrace = trace;
+
-      *plen = new_len;
+    while(1) {
+      frame_descr *descr = caml_next_frame_descriptor(fds, &pc, &sp, stack);
+      if (trace_pos >= max_frames) break;
+      if (descr == NULL) {
+        stack = Stack_parent(stack);
+        if (stack == NULL) break;
+        caml_get_stack_sp_pc(stack, &sp, &pc);
+      } else {
+        (*trace)[trace_pos] = descr;
+        ++trace_pos;
+      }
     }
-    (*ptrace)[trace_pos++] = Val_backtrace_slot(Slot_frame_descr(descr));
+  }
+}
+
+static value alloc_callstack(frame_descr** trace, intnat trace_len)
+{
+  CAMLparam0();
+  CAMLlocal1(callstack);
+  int i;
+  callstack = caml_alloc(trace_len, 0);
+  for (i = 0; i < trace_len; i++)
+    Store_field(callstack, i, Val_backtrace_slot(trace[i]));
+  caml_stat_free(trace);
+  CAMLreturn(callstack);
+}
+
+CAMLprim value caml_get_current_callstack (value max_frames_value) {
+  frame_descr** trace;
+  intnat trace_len;
+  get_callstack(Caml_state->current_stack, Long_val(max_frames_value),
+                &trace, &trace_len);
+  return alloc_callstack(trace, trace_len);
+}
+
+CAMLprim value caml_get_continuation_callstack (value cont, value max_frames)
+{
+  frame_descr** trace;
+  intnat trace_len;
+  struct stack_info* stack;
+
+  stack = Ptr_val(caml_continuation_use(cont));
+  {
+    CAMLnoalloc;
+    get_callstack(stack, max_frames,
+                  &trace, &trace_len);
+    caml_continuation_replace(cont, stack);
   }
 
-  return trace_pos;
+  return alloc_callstack(trace, trace_len);
 }
 
-static debuginfo debuginfo_extract(frame_descr* d, int alloc_idx)
+debuginfo caml_debuginfo_extract(backtrace_slot slot)
 {
   unsigned char* infoptr;
   uint32_t debuginfo_offset;
+  frame_descr * d = (frame_descr *)slot;
 
   /* The special frames marking the top of an ML stack chunk are never
      returned by caml_next_frame_descriptor, so should never reach here. */
@@ -175,46 +226,24 @@ static debuginfo debuginfo_extract(frame_descr* d, int alloc_idx)
   /* Recover debugging info */
   infoptr = (unsigned char*)&d->live_ofs[d->num_live];
   if (d->frame_size & 2) {
-    CAMLassert(alloc_idx == -1 || (0 <= alloc_idx && alloc_idx < *infoptr));
     /* skip alloc_lengths */
     infoptr += *infoptr + 1;
     /* align to 32 bits */
     infoptr = Align_to(infoptr, uint32_t);
-    /* select the right debug info for this allocation */
+    /* we know there's at least one valid debuginfo,
-    if (alloc_idx != -1) {
+       but it may not be the one for the first alloc */
-      infoptr += alloc_idx * sizeof(uint32_t);
+    while (*(uint32_t*)infoptr == 0) {
-      if (*(uint32_t*)infoptr == 0) {
+      infoptr += sizeof(uint32_t);
-        /* No debug info for this particular allocation */
-        return NULL;
-      }
-    } else {
-      /* We don't care which alloc_idx we use, so use the first
-         that has debug info. (e.g. this is a backtrace through a
-         finaliser/signal handler triggered via a Comballoc alloc) */
-      while (*(uint32_t*)infoptr == 0) {
-        infoptr += sizeof(uint32_t);
-      }
     }
   } else {
     /* align to 32 bits */
     infoptr = Align_to(infoptr, uint32_t);
-    CAMLassert(alloc_idx == -1);
   }
+  /* read offset to debuginfo */
   debuginfo_offset = *(uint32_t*)infoptr;
-  CAMLassert(debuginfo_offset != 0 && (debuginfo_offset & 3) == 0);
   return (debuginfo)(infoptr + debuginfo_offset);
 }
 
-debuginfo caml_debuginfo_extract(backtrace_slot slot)
-{
-  if (Slot_is_debuginfo(slot)) {
-    /* already a decoded debuginfo */
-    return Debuginfo_slot(slot);
-  } else {
-    return debuginfo_extract(Frame_descr_slot(slot), -1);
-  }
-}
-
 debuginfo caml_debuginfo_next(debuginfo dbg)
 {
   uint32_t * infoptr;

@@ -66,7 +66,7 @@ CAMLexport uintnat caml_ba_byte_size(struct caml_ba_array * b)
 
 /* Operation table for bigarrays */
 
-CAMLexport struct custom_operations caml_ba_ops = {
+CAMLexport const struct custom_operations caml_ba_ops = {
   "_bigarr02",
   caml_ba_finalize,
   caml_ba_compare,

@@ -19,26 +19,49 @@
 
 #include <string.h>
 #include "caml/callback.h"
-#include "caml/domain.h"
+#include "caml/codefrag.h"
 #include "caml/fail.h"
+#include "caml/fiber.h"
 #include "caml/memory.h"
 #include "caml/mlvalues.h"
+#include "caml/platform.h"
+
+/*
+ * These functions are to ensure effects are handled correctly inside
+ * callbacks. There are two aspects:
+ *  - we clear the stack parent for a callback to force an Unhandled
+ *  exception rather than effects being passed over the callback
+ *  - we register the stack parent as a local root while the callback
+ * is executing to ensure that the garbage collector follows the
+ * stack parent
+ */
+Caml_inline value save_and_clear_stack_parent(caml_domain_state* domain_state) {
+  struct stack_info* parent_stack = Stack_parent(domain_state->current_stack);
+  value cont = caml_alloc_1(Cont_tag, Val_ptr(parent_stack));
+  Stack_parent(domain_state->current_stack) = NULL;
+  return cont;
+}
+
+Caml_inline void restore_stack_parent(caml_domain_state* domain_state,
+                                      value cont) {
+  struct stack_info* parent_stack = Ptr_val(Op_val(cont)[0]);
+  CAMLassert(Stack_parent(domain_state->current_stack) == NULL);
+  Stack_parent(domain_state->current_stack) = parent_stack;
+}
+
 
 #ifndef NATIVE_CODE
 
 /* Bytecode callbacks */
 
-#include "caml/codefrag.h"
 #include "caml/interp.h"
 #include "caml/instruct.h"
 #include "caml/fix_code.h"
-#include "caml/stacks.h"
+#include "caml/fiber.h"
-
-CAMLexport int caml_callback_depth = 0;
 
-static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP };
+static __thread opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP };
 
-static int callback_code_inited = 0;
+static __thread int callback_code_inited = 0;
 
 static void init_callback_code(void)
 {
@@ -53,23 +76,38 @@ static void init_callback_code(void)
 
 CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
 {
-  int i;
+  CAMLparam1(closure);
+  CAMLxparamN(args, narg);
+  CAMLlocal1(cont);
   value res;
+  int i;
+  caml_domain_state* domain_state = Caml_state;
 
   CAMLassert(narg + 4 <= 256);
+  domain_state->current_stack->sp -= narg + 4;
+  for (i = 0; i < narg; i++)
+    domain_state->current_stack->sp[i] = args[i]; /* arguments */
 
-  Caml_state->extern_sp -= narg + 4;
-  for (i = 0; i < narg; i++) Caml_state->extern_sp[i] = args[i]; /* arguments */
-  Caml_state->extern_sp[narg] = (value)(callback_code + 4); /* return address */
-  Caml_state->extern_sp[narg + 1] = Val_unit;    /* environment */
-  Caml_state->extern_sp[narg + 2] = Val_long(0); /* extra args */
-  Caml_state->extern_sp[narg + 3] = closure;
   if (!callback_code_inited) init_callback_code();
+
   callback_code[1] = narg + 3;
   callback_code[3] = narg;
+
+  domain_state->current_stack->sp[narg] =
+                     (value)(callback_code + 4); /* return address */
+  domain_state->current_stack->sp[narg + 1] = Val_unit;    /* environment */
+  domain_state->current_stack->sp[narg + 2] = Val_long(0); /* extra args */
+  domain_state->current_stack->sp[narg + 3] = closure;
+
+  cont = save_and_clear_stack_parent(domain_state);
+
   res = caml_interprete(callback_code, sizeof(callback_code));
-  if (Is_exception_result(res)) Caml_state->extern_sp += narg + 4; /* PR#3419 */
+  if (Is_exception_result(res))
-  return res;
+    domain_state->current_stack->sp += narg + 4; /* PR#3419 */
+
+  restore_stack_parent(domain_state, cont);
+
+  CAMLreturn (res);
 }
 
 CAMLexport value caml_callback_exn(value closure, value arg1)
@@ -97,33 +135,82 @@ CAMLexport value caml_callback3_exn(value closure,
   return caml_callbackN_exn(closure, 3, arg);
 }
 
-#else
+#else /* Nativecode callbacks */
 
-/* Native-code callbacks. */
+static void init_callback_code(void)
+{
+}
 
-typedef value (callback_stub)(caml_domain_state* state, value closure,
+typedef value (callback_stub)(caml_domain_state* state,
+                              value closure,
                               value* args);
 
 callback_stub caml_callback_asm, caml_callback2_asm, caml_callback3_asm;
 
 CAMLexport value caml_callback_exn(value closure, value arg)
 {
-  return caml_callback_asm(Caml_state, closure, &arg);
+  caml_domain_state* domain_state = Caml_state;
+  caml_maybe_expand_stack();
+
+  if (Stack_parent(domain_state->current_stack)) {
+    CAMLparam2 (closure, arg);
+    CAMLlocal1 (cont);
+    value res;
+
+    cont = save_and_clear_stack_parent(domain_state);
+    res = caml_callback_asm(domain_state, closure, &arg);
+    restore_stack_parent(domain_state, cont);
+
+    CAMLreturn (res);
+  } else {
+    return caml_callback_asm(domain_state, closure, &arg);
+  }
 }
 
 CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2)
 {
   value args[] = {arg1, arg2};
-  return caml_callback2_asm(Caml_state, closure, args);
+  caml_domain_state* domain_state = Caml_state;
+  caml_maybe_expand_stack();
+
+  if (Stack_parent(domain_state->current_stack)) {
+    CAMLparam3 (closure, arg1, arg2);
+    CAMLlocal1 (cont);
+    value res;
+
+    cont = save_and_clear_stack_parent(domain_state);
+    res = caml_callback2_asm(domain_state, closure, args);
+    restore_stack_parent(domain_state, cont);
+
+    CAMLreturn (res);
+  } else {
+    return caml_callback2_asm(domain_state, closure, args);
+  }
 }
 
 CAMLexport value caml_callback3_exn(value closure,
                                     value arg1, value arg2, value arg3)
 {
   value args[] = {arg1, arg2, arg3};
-  return caml_callback3_asm(Caml_state, closure, args);
+  caml_domain_state* domain_state = Caml_state;
+  caml_maybe_expand_stack();
+
+  if (Stack_parent(domain_state->current_stack))  {
+    CAMLparam4 (closure, arg1, arg2, arg3);
+    CAMLlocal1 (cont);
+    value res;
+
+    cont = save_and_clear_stack_parent(domain_state);
+    res = caml_callback3_asm(domain_state, closure, args);
+    restore_stack_parent(domain_state, cont);
+
+    CAMLreturn (res);
+  } else {
+    return caml_callback3_asm(domain_state, closure, args);
+  }
 }
 
+/* Native-code callbacks.  caml_callback[123]_asm are implemented in asm. */
 
 CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
 {
@@ -192,6 +279,12 @@ struct named_value {
 #define Named_value_size 13
 
 static struct named_value * named_value_table[Named_value_size] = { NULL, };
+static caml_plat_mutex named_value_lock = CAML_PLAT_MUTEX_INITIALIZER;
+
+void caml_init_callbacks(void)
+{
+  init_callback_code();
+}
 
 static unsigned int hash_value_name(char const *name)
 {
@@ -206,31 +299,42 @@ CAMLprim value caml_register_named_value(value vname, value val)
   const char * name = String_val(vname);
   size_t namelen = strlen(name);
   unsigned int h = hash_value_name(name);
+  int found = 0;
 
+  caml_plat_lock(&named_value_lock);
   for (nv = named_value_table[h]; nv != NULL; nv = nv->next) {
     if (strcmp(name, nv->name) == 0) {
       caml_modify_generational_global_root(&nv->val, val);
-      return Val_unit;
+      found = 1;
+      break;
     }
   }
-  nv = (struct named_value *)
+  if (!found) {
-          caml_stat_alloc(sizeof(struct named_value) + namelen);
+    nv = (struct named_value *)
-  memcpy(nv->name, name, namelen + 1);
+      caml_stat_alloc(sizeof(struct named_value) + namelen);
-  nv->val = val;
+    memcpy(nv->name, name, namelen + 1);
-  nv->next = named_value_table[h];
+    nv->val = val;
-  named_value_table[h] = nv;
+    nv->next = named_value_table[h];
-  caml_register_generational_global_root(&nv->val);
+    named_value_table[h] = nv;
+    caml_register_generational_global_root(&nv->val);
+  }
+  caml_plat_unlock(&named_value_lock);
   return Val_unit;
 }
 
-CAMLexport const value * caml_named_value(char const *name)
+CAMLexport const value* caml_named_value(char const *name)
 {
   struct named_value * nv;
+  caml_plat_lock(&named_value_lock);
   for (nv = named_value_table[hash_value_name(name)];
        nv != NULL;
        nv = nv->next) {
-    if (strcmp(name, nv->name) == 0) return &nv->val;
+    if (strcmp(name, nv->name) == 0){
+      caml_plat_unlock(&named_value_lock);
+      return &nv->val;
+    }
   }
+  caml_plat_unlock(&named_value_lock);
   return NULL;
 }
 
@@ -240,7 +344,7 @@ CAMLexport void caml_iterate_named_values(caml_named_action f)
   for(i = 0; i < Named_value_size; i++){
     struct named_value * nv;
     for (nv = named_value_table[i]; nv != NULL; nv = nv->next) {
-      f( &nv->val, nv->name );
+      f( Op_val(nv->val), nv->name );
     }
   }
 }
@@ -15,44 +15,25 @@
 
 /* Classification of addresses for GC and runtime purposes. */
 
-/* The current runtime supports two different configurations that
+/* Multicore runtime supports only the "no naked pointers" mode where any
-   correspond to two different value models, depending on whether
+   out-of-heap pointers are not observable by the GC. The out-of-heap pointers
-   "naked pointers", that do not point to a well-formed OCaml block,
+   are either:
-   are allowed (considered valid values).
 
-   In "classic mode", naked pointers are allowed, and the
+   - wrapped in Abstract_tag or Custom_tag objects, or
-   implementation uses a page table. A valid value is then either:
+   - have a valid header with colour `NOT_MARKABLE`, or
-   - a tagged integer (Is_long or !Is_block from mlvalues.h)
+   - made to look like immediate values by tagging the least significant bit so
-   - a pointer to the minor heap (Is_young)
+     that the GC does not follow it. This strategy has the downside that
-   - a pointer to the major heap (Is_in_heap)
+     out-of-heap pointers may not point to odd addresses.
-   - a pointer to a constant block statically-allocated by OCaml code
-     or the OCaml runtime (Is_in_static_data)
-   - a "foreign" pointer, which is none of the above; the destination
-     of those pointers may be a well-formed OCaml blocks, but it may
-     also be a naked pointer.
 
-   The macros and functions below give access to a global page table
+   A valid value is either:
-   to classify addresses to be able to implement Is_in_heap,
-   In_static_data (or their disjunction Is_in_value_area) and thus
-   detect values which may be naked pointers. The runtime
-   conservatively assumes that all foreign pointers may be naked
-   pointers, and uses the page table to not dereference/follow them.
-
-   In "no naked pointers" mode (when NO_NAKED_POINTERS is defined),
-   naked pointers are illegal, so pointers that are values can always
-   be assumed to point to well-formed blocks.
-
-   To support an implementation without a global page table, runtime
-   code should not rely on Is_in_heap and Is_in_static_data. This
-   corresponds to a simpler model where a valid value is either:
    - a tagged integer (Is_long)
-   - a pointer to the minor heap (Is_young)
+   - a pointer to the minor heap
-   - a pointer to a well-formed block outside the minor heap
+   - a pointer to a well-formed block outside the minor heap. It may be in the
-     (it may be in the major heap, or static, or a foreign pointer,
+     major heap, or static data allocated by the OCaml code or the OCaml
-      without a check to distinguish the various cases).
+     runtime, or a foreign pointer.
 
-   (To create a well-formed block outside the heap that the GC will
+   To create a well-formed block outside the heap that the GC will not scan,
-   not scan, one can use the Caml_out_of_heap_header from mlvalues.h.)
+   one can use the Caml_out_of_heap_header from mlvalues.h.
 */
 
 #ifndef CAML_ADDRESS_CLASS_H
@@ -62,65 +43,8 @@
 #include "misc.h"
 #include "mlvalues.h"
 
-/* Use the following macros to test an address for the different classes
+/* These definitions are retained for backwards compatibility */
-   it might belong to. */
-
-#define Is_young(val) \
-  (CAMLassert (Is_block (val)), \
-   (char *)(val) < (char *)Caml_state_field(young_end) && \
-   (char *)(val) > (char *)Caml_state_field(young_start))
-
-#define Is_in_heap(a) (Classify_addr(a) & In_heap)
-
-#ifdef NO_NAKED_POINTERS
-
 #define Is_in_heap_or_young(a) 1
 #define Is_in_value_area(a) 1
 
-#else
-
-#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young))
-
-#define Is_in_value_area(a)                                     \
-  (Classify_addr(a) & (In_heap | In_young | In_static_data))
-
-#define Is_in_static_data(a) (Classify_addr(a) & In_static_data)
-
-#endif
-
-/***********************************************************************/
-/* The rest of this file is private and may change without notice. */
-
-#define Not_in_heap 0
-#define In_heap 1
-#define In_young 2
-#define In_static_data 4
-
-#ifdef ARCH_SIXTYFOUR
-
-/* 64 bits: Represent page table as a sparse hash table */
-int caml_page_table_lookup(void * addr);
-#define Classify_addr(a) (caml_page_table_lookup((void *)(a)))
-
-#else
-
-/* 32 bits: Represent page table as a 2-level array */
-#define Pagetable2_log 11
-#define Pagetable2_size (1 << Pagetable2_log)
-#define Pagetable1_log (Page_log + Pagetable2_log)
-#define Pagetable1_size (1 << (32 - Pagetable1_log))
-CAMLextern unsigned char * caml_page_table[Pagetable1_size];
-
-#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log)
-#define Pagetable_index2(a) \
-  ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1))
-#define Classify_addr(a) \
-  caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)]
-
-#endif
-
-int caml_page_table_add(int kind, void * start, void * end);
-int caml_page_table_remove(int kind, void * start, void * end);
-int caml_page_table_initialize(mlsize_t bytesize);
-
 #endif /* CAML_ADDRESS_CLASS_H */
@@ -0,0 +1,97 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                 Stephen Dolan, University of Cambridge                 */
+/*                                                                        */
+/*   Copyright 2015 University of Cambridge                               */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+#include "mlvalues.h"
+
+#ifndef CAML_ADDRMAP_H
+#define CAML_ADDRMAP_H
+
+/* An addrmap is a value -> value hashmap, where
+   the values are blocks */
+
+struct addrmap_entry { value key, value; };
+struct addrmap {
+  struct addrmap_entry* entries;
+  uintnat size;
+};
+
+#define ADDRMAP_INIT {0,0}
+
+int caml_addrmap_contains(struct addrmap* t, value k);
+value caml_addrmap_lookup(struct addrmap* t, value k);
+
+#define ADDRMAP_NOT_PRESENT ((value)(0))
+#define ADDRMAP_INVALID_KEY ((value)(0))
+
+value* caml_addrmap_insert_pos(struct addrmap* t, value k);
+
+/* must not already be present */
+void caml_addrmap_insert(struct addrmap* t, value k, value v);
+
+void caml_addrmap_clear(struct addrmap* t);
+
+void caml_addrmap_iter(struct addrmap* t, void (*f)(value, value));
+
+/* iteration */
+typedef uintnat addrmap_iterator;
+Caml_inline addrmap_iterator caml_addrmap_iter_ok(struct addrmap* t,
+                                                  addrmap_iterator i)
+{
+  if (i < t->size) {
+    CAMLassert(t->entries[i].key != ADDRMAP_INVALID_KEY);
+    return 1;
+  } else {
+    return 0;
+  }
+}
+
+Caml_inline addrmap_iterator caml_addrmap_next(struct addrmap* t,
+                                               addrmap_iterator i)
+{
+  if (!t->entries) return (uintnat)(-1);
+  i++;
+  while (i < t->size && t->entries[i].key == ADDRMAP_INVALID_KEY) {
+    i++;
+  }
+  caml_addrmap_iter_ok(t, i); /* just for assert-checks */
+  return i;
+}
+
+Caml_inline value caml_addrmap_iter_key(struct addrmap* t,
+                                        addrmap_iterator i)
+{
+  CAMLassert(caml_addrmap_iter_ok(t, i));
+  return t->entries[i].key;
+}
+
+Caml_inline value caml_addrmap_iter_value(struct addrmap* t,
+                                          addrmap_iterator i)
+{
+  CAMLassert(caml_addrmap_iter_ok(t, i));
+  return t->entries[i].value;
+}
+
+Caml_inline value* caml_addrmap_iter_val_pos(struct addrmap* t,
+                                             addrmap_iterator i)
+{
+  CAMLassert(caml_addrmap_iter_ok(t, i));
+  return &t->entries[i].value;
+}
+
+Caml_inline addrmap_iterator caml_addrmap_iterator(struct addrmap* t)
+{
+  return caml_addrmap_next(t, (uintnat)(-1));
+}
+
+
+#endif
@@ -27,23 +27,35 @@
 extern "C" {
 #endif
 
-/* It is guaranteed that these allocation functions will not trigger
+CAMLextern value caml_alloc (mlsize_t, tag_t);
-   any OCaml callback such as finalizers or signal handlers. */
+CAMLextern value caml_alloc_N(mlsize_t, tag_t, ...);
-
+CAMLextern value caml_alloc_1(tag_t, value);
-CAMLextern value caml_alloc (mlsize_t wosize, tag_t);
+CAMLextern value caml_alloc_2(tag_t, value, value);
-CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t);
+CAMLextern value caml_alloc_3(tag_t, value, value, value);
-CAMLextern value caml_alloc_tuple (mlsize_t wosize);
+CAMLextern value caml_alloc_4(tag_t, value, value, value, value);
+CAMLextern value caml_alloc_5(tag_t, value, value, value, value,
+                              value);
+CAMLextern value caml_alloc_6(tag_t, value, value, value, value,
+                              value, value);
+CAMLextern value caml_alloc_7(tag_t, value, value, value, value,
+                              value, value, value);
+CAMLextern value caml_alloc_8(tag_t, value, value, value, value,
+                              value, value, value, value);
+CAMLextern value caml_alloc_9(tag_t, value, value, value, value,
+                              value, value, value, value, value);
+CAMLextern value caml_alloc_small (mlsize_t, tag_t);
+CAMLextern value caml_alloc_tuple (mlsize_t);
 CAMLextern value caml_alloc_float_array (mlsize_t len);
 CAMLextern value caml_alloc_string (mlsize_t len);  /* len in bytes (chars) */
 CAMLextern value caml_alloc_initialized_string (mlsize_t len, const char *);
 CAMLextern value caml_copy_string (char const *);
-CAMLextern value caml_copy_string_array (char const **);
+CAMLextern value caml_copy_string_array (char const * const*);
 CAMLextern value caml_copy_double (double);
 CAMLextern value caml_copy_int32 (int32_t);       /* defined in [ints.c] */
 CAMLextern value caml_copy_int64 (int64_t);       /* defined in [ints.c] */
 CAMLextern value caml_copy_nativeint (intnat);  /* defined in [ints.c] */
 CAMLextern value caml_alloc_array (value (*funct) (char const *),
-                                   char const ** array);
+                                   char const * const * array);
 CAMLextern value caml_alloc_sprintf(const char * format, ...)
 #ifdef __GNUC__
   __attribute__ ((format (printf, 1, 2)))
@@ -52,12 +64,12 @@ CAMLextern value caml_alloc_sprintf(const char * format, ...)
 CAMLextern value caml_alloc_some(value);
 
 typedef void (*final_fun)(value);
-CAMLextern value caml_alloc_final (mlsize_t wosize,
+CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/
                                    final_fun, /*finalization function*/
                                    mlsize_t, /*resources consumed*/
                                    mlsize_t  /*max resources*/);
 
-CAMLextern int caml_convert_flag_list (value, int *);
+CAMLextern int caml_convert_flag_list (value, const int *);
 
 /* Convenience functions to deal with unboxable types. */
 Caml_inline value caml_alloc_unboxed (value arg) { return arg; }

@@ -96,10 +96,11 @@ CAMLextern void caml_record_backtraces(int);
  * raise and re-raise are distinguished by:
  * - passing reraise = 1 to [caml_stash_backtrace] (see below) in the bytecode
  *   interpreter;
- * - directly resetting [Caml_state->backtrace_pos] to 0 in native
+ * - directly resetting [Caml_state->backtrace_pos] to 0 in native runtimes for
-     runtimes for raise.
+ *   raise.
  */
 
+
 #ifndef NATIVE_CODE
 
 /* Path to the file containing debug information, if any, or NULL. */

@@ -97,21 +97,10 @@ value caml_remove_debug_info(code_t start);
  * It defines the [caml_stash_backtrace] function, which is called to quickly
  * fill the backtrace buffer by walking the stack when an exception is raised.
  *
- * It also defines [caml_collect_current_callstack], which stores up
+ * It also defines the [caml_get_current_callstack] OCaml primitive, which also
- * to [max_frames] frames of the current call stack into the
+ * walks the stack but directly turns it into a [raw_backtrace] and is called
- * statically allocated buffer [*pbuffer] of length [*plen]. If the
+ * explicitly.
- * buffer is not long enough, it will be reallocated. The number of
+ */
- * frames collected is returned.
- *
- * The alloc_idx parameter is used to select between the backtraces of
- * different allocation sites which were combined by Comballoc.
- * Passing -1 here means the caller doesn't care which is chosen.
- *
- * We use `intnat` for max_frames because, were it only `int`, passing
- * `max_int` from the OCaml side would overflow on 64bits machines. */
-
-intnat caml_collect_current_callstack(value** pbuffer, intnat* plen,
-                                      intnat max_frames, int alloc_idx);
 
 #endif /* CAML_INTERNALS */
 

@@ -22,11 +22,14 @@
 #include "compatibility.h"
 #endif
 #include "mlvalues.h"
+#include "memory.h"
 
 #ifdef __cplusplus
 extern "C" {
 #endif
 
+void caml_init_callbacks (void);
+
 CAMLextern value caml_callback (value closure, value arg);
 CAMLextern value caml_callback2 (value closure, value arg1, value arg2);
 CAMLextern value caml_callback3 (value closure, value arg1, value arg2,
@@ -50,8 +53,6 @@ CAMLextern void caml_startup_pooled (char_os ** argv);
 CAMLextern value caml_startup_pooled_exn (char_os ** argv);
 CAMLextern void caml_shutdown (void);
 
-CAMLextern int caml_callback_depth;
-
 #ifdef __cplusplus
 }
 #endif

@@ -0,0 +1,87 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*      KC Sivaramakrishnan, Indian Institute of Technology, Madras       */
+/*                Stephen Dolan, University of Cambridge                  */
+/*                                                                        */
+/*   Copyright 2018 Indian Institute of Technology, Madras                */
+/*   Copyright 2018 University of Cambridge                               */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+#ifndef CAML_ATOMIC_H
+#define CAML_ATOMIC_H
+
+#ifndef CAML_NAME_SPACE
+#include "compatibility.h"
+#endif
+#include "config.h"
+#include "misc.h"
+
+/* On platforms supporting C11 atomics, this file just includes <stdatomic.h>.
+
+   On other platforms, this file includes platform-specific stubs for
+   the subset of C11 atomics needed by the OCaml runtime
+ */
+
+#ifdef __cplusplus
+
+extern "C++" {
+#include <atomic>
+#define ATOMIC_UINTNAT_INIT(x) (x)
+typedef std::atomic<uintnat> atomic_uintnat;
+typedef std::atomic<intnat> atomic_intnat;
+using std::memory_order_relaxed;
+using std::memory_order_acquire;
+using std::memory_order_release;
+using std::memory_order_acq_rel;
+using std::memory_order_seq_cst;
+}
+
+#elif defined(HAS_STDATOMIC_H)
+
+#include <stdatomic.h>
+#define ATOMIC_UINTNAT_INIT(x) (x)
+typedef _Atomic uintnat atomic_uintnat;
+typedef _Atomic intnat atomic_intnat;
+
+#elif defined(__GNUC__)
+
+/* Support for versions of gcc which have built-in atomics but do not
+   expose stdatomic.h (e.g. gcc 4.8) */
+typedef enum memory_order {
+  memory_order_relaxed = __ATOMIC_RELAXED,
+  memory_order_acquire = __ATOMIC_ACQUIRE,
+  memory_order_release = __ATOMIC_RELEASE,
+  memory_order_acq_rel = __ATOMIC_ACQ_REL,
+  memory_order_seq_cst = __ATOMIC_SEQ_CST
+} memory_order;
+
+#define ATOMIC_UINTNAT_INIT(x) { (x) }
+typedef struct { uintnat repr; } atomic_uintnat;
+typedef struct { intnat repr; } atomic_intnat;
+
+#define atomic_load_explicit(x, m) __atomic_load_n(&(x)->repr, (m))
+#define atomic_load(x) atomic_load_explicit((x), memory_order_seq_cst)
+#define atomic_store_explicit(x, v, m) __atomic_store_n(&(x)->repr, (v), (m))
+#define atomic_store(x, v) atomic_store_explicit((x), (v), memory_order_seq_cst)
+#define atomic_compare_exchange_strong(x, oldv, newv) \
+  __atomic_compare_exchange_n( \
+    &(x)->repr, \
+    (oldv), (newv), 0, \
+    memory_order_seq_cst, memory_order_seq_cst)
+#define atomic_exchange(x, newv) \
+  __atomic_exchange_n(&(x)->repr, (newv), memory_order_seq_cst)
+#define atomic_fetch_add(x, n) \
+  __atomic_fetch_add(&(x)->repr, (n), memory_order_seq_cst)
+#define atomic_thread_fence __atomic_thread_fence
+
+#else
+#error "C11 atomics are unavailable on this platform. See camlatomic.h"
+#endif
+
+#endif /* CAML_ATOMIC_H */
@@ -36,6 +36,10 @@ struct code_fragment {
   enum digest_status digest_status;
 };
 
+/* Initialise codefrag. This must be done before any of the other
+   operations in codefrag. */
+void caml_init_codefrag(void);
+
 /* Register a code fragment for addresses [start] (included)
    to [end] (excluded).  This range of addresses is assumed
    disjoint from all currently-registered code fragments.
@@ -75,6 +79,10 @@ extern struct code_fragment *
    Returns NULL if the code fragment was registered with [DIGEST_IGNORE]. */
 extern unsigned char * caml_digest_of_code_fragment(struct code_fragment *);
 
+/* Cleans up (and frees) removed code fragments. Must be called from a stop the
+   world pause by only a single thread. */
+extern void caml_code_fragment_cleanup(void);
+
 #endif
 
 #endif
@@ -56,10 +56,6 @@
 /* **** array.c */
 
 /* **** backtrace.c */
-#define backtrace_active CAML_DEPRECATED("backtrace_active", "caml_backtrace_active") caml_backtrace_active
-#define backtrace_pos CAML_DEPRECATED("backtrace_pos", "caml_backtrace_pos") caml_backtrace_pos
-#define backtrace_buffer CAML_DEPRECATED("backtrace_buffer", "caml_backtrace_buffer") caml_backtrace_buffer
-#define backtrace_last_exn CAML_DEPRECATED("backtrace_last_exn", "caml_backtrace_last_exn") caml_backtrace_last_exn
 #define print_exception_backtrace CAML_DEPRECATED("print_exception_backtrace", "caml_print_exception_backtrace") caml_print_exception_backtrace
 
 /* **** callback.c */
@@ -76,7 +72,6 @@
 /* **** compact.c */
 
 /* **** compare.c */
-#define compare_unordered CAML_DEPRECATED("compare_unordered", "caml_compare_unordered") caml_compare_unordered
 
 /* **** custom.c */
 #define alloc_custom CAML_DEPRECATED("alloc_custom", "caml_alloc_custom") caml_alloc_custom
@@ -103,7 +98,6 @@
 #define serialize_block_float_8 CAML_DEPRECATED("serialize_block_float_8", "caml_serialize_block_float_8") caml_serialize_block_float_8
 
 /* **** fail.c */
-#define external_raise CAML_DEPRECATED("external_raise", "caml_external_raise") caml_external_raise
 #define mlraise CAML_DEPRECATED("mlraise", "caml_raise") caml_raise /*SP*/
 #define raise_constant CAML_DEPRECATED("raise_constant", "caml_raise_constant") caml_raise_constant
 #define raise_with_arg CAML_DEPRECATED("raise_with_arg", "caml_raise_with_arg") caml_raise_with_arg
@@ -226,23 +220,13 @@
 
 /* **** memory.c */
 #define alloc_shr CAML_DEPRECATED("alloc_shr", "caml_alloc_shr") caml_alloc_shr
-#define initialize CAML_DEPRECATED("initialize", "caml_initialize") caml_initialize
 #define modify CAML_DEPRECATED("modify", "caml_modify") caml_modify
 #define stat_alloc CAML_DEPRECATED("stat_alloc", "caml_stat_alloc") caml_stat_alloc
 #define stat_free CAML_DEPRECATED("stat_free", "caml_stat_free") caml_stat_free
 #define stat_resize CAML_DEPRECATED("stat_resize", "caml_stat_resize") caml_stat_resize
 
 /* **** meta.c */
 
-/* **** minor_gc.c */
-#define young_start CAML_DEPRECATED("young_start", "caml_young_start") caml_young_start
-#define young_end CAML_DEPRECATED("young_end", "caml_young_end") caml_young_end
-#define young_ptr CAML_DEPRECATED("young_ptr", "caml_young_ptr") caml_young_ptr
-#define young_limit CAML_DEPRECATED("young_limit", "caml_young_limit") caml_young_limit
-#define ref_table CAML_DEPRECATED("ref_table", "caml_ref_table") caml_ref_table
-#define minor_collection CAML_DEPRECATED("minor_collection", "caml_minor_collection") caml_minor_collection
-#define check_urgent_gc CAML_DEPRECATED("check_urgent_gc", "caml_check_urgent_gc") caml_check_urgent_gc
-
 /* **** misc.c */
 
 /* **** obj.c */
@@ -255,32 +239,20 @@
 #define format_caml_exception CAML_DEPRECATED("format_caml_exception", "caml_format_exception") caml_format_exception /*SP*/
 
 /* **** roots.c */
-#define local_roots CAML_DEPRECATED("local_roots", "caml_local_roots") caml_local_roots
-#define scan_roots_hook CAML_DEPRECATED("scan_roots_hook", "caml_scan_roots_hook") caml_scan_roots_hook
 #define do_local_roots CAML_DEPRECATED("do_local_roots", "caml_do_local_roots") caml_do_local_roots
 
 /* **** signals.c */
 #define pending_signals CAML_DEPRECATED("pending_signals", "caml_pending_signals") caml_pending_signals
-#define something_to_do CAML_DEPRECATED("something_to_do", "caml_something_to_do") caml_something_to_do
-#define enter_blocking_section_hook CAML_DEPRECATED("enter_blocking_section_hook", "caml_enter_blocking_section_hook") caml_enter_blocking_section_hook
-#define leave_blocking_section_hook CAML_DEPRECATED("leave_blocking_section_hook", "caml_leave_blocking_section_hook") caml_leave_blocking_section_hook
 #define enter_blocking_section CAML_DEPRECATED("enter_blocking_section", "caml_enter_blocking_section") caml_enter_blocking_section
 #define leave_blocking_section CAML_DEPRECATED("leave_blocking_section", "caml_leave_blocking_section") caml_leave_blocking_section
 #define convert_signal_number CAML_DEPRECATED("convert_signal_number", "caml_convert_signal_number") caml_convert_signal_number
 
 /* **** runtime/signals.c */
-#define garbage_collection CAML_DEPRECATED("garbage_collection", "caml_garbage_collection") caml_garbage_collection
 
 /* **** stacks.c */
-#define stack_low CAML_DEPRECATED("stack_low", "caml_stack_low") caml_stack_low
-#define stack_high CAML_DEPRECATED("stack_high", "caml_stack_high") caml_stack_high
-#define stack_threshold CAML_DEPRECATED("stack_threshold", "caml_stack_threshold") caml_stack_threshold
-#define extern_sp CAML_DEPRECATED("extern_sp", "caml_extern_sp") caml_extern_sp
-#define trapsp CAML_DEPRECATED("trapsp", "caml_trapsp") caml_trapsp
-#define trap_barrier CAML_DEPRECATED("trap_barrier", "caml_trap_barrier") caml_trap_barrier
 
 /* **** startup.c */
-#define atom_table CAML_DEPRECATED("atom_table", "caml_atom_table") caml_atom_table
+
 /* **** runtime/startup_nat.c */
 #define static_data_start CAML_DEPRECATED("static_data_start", "caml_static_data_start") caml_static_data_start
 #define static_data_end CAML_DEPRECATED("static_data_end", "caml_static_data_end") caml_static_data_end

@@ -153,6 +153,8 @@ typedef uint64_t uintnat;
 #error "No integer type available to represent pointers"
 #endif
 
+#define UINTNAT_MAX ((uintnat)-1)
+
 #endif /* CAML_CONFIG_H_NO_TYPEDEFS */
 
 /* Endianness of floats */
@@ -190,10 +192,19 @@ typedef uint64_t uintnat;
 #define Page_size (1 << Page_log)
 
 /* Initial size of stack (bytes). */
+#ifdef DEBUG
+#define Stack_size (32 * sizeof(value))
+#else
 #define Stack_size (4096 * sizeof(value))
+#endif
 
 /* Minimum free size of stack (bytes); below that, it is reallocated. */
-#define Stack_threshold (256 * sizeof(value))
+#define Stack_threshold_words 16
+#define Stack_threshold (Stack_threshold_words * sizeof(value))
+
+/* Number of words used in the control structure at the start of a stack
+   (see fiber.h) */
+#define Stack_ctx_words 5
 
 /* Default maximum size of the stack (words). */
 #define Max_stack_def (1024 * 1024)
@@ -206,8 +217,8 @@ typedef uint64_t uintnat;
 
 
 /* Minimum size of the minor zone (words).
-   This must be at least [2 * Max_young_whsize]. */
+   This must be at least [Max_young_wosize + 1]. */
-#define Minor_heap_min 4096
+#define Minor_heap_min (Max_young_wosize + 1)
 
 /* Maximum size of the minor zone (words).
    Must be greater than or equal to [Minor_heap_min].
@@ -245,6 +256,9 @@ typedef uint64_t uintnat;
  */
 #define Max_percent_free_def 500
 
+/* Maximum number of domains */
+#define Max_domains 128
+
 /* Default setting for the major GC slice smoothing window: 1
    (i.e. no smoothing)
 */

@@ -48,23 +48,24 @@ struct custom_operations {
 #define custom_compare_ext_default NULL
 #define custom_fixed_length_default NULL
 
-#define Custom_ops_val(v) (*((struct custom_operations **) (v)))
+#define Custom_ops_val(v) (*((const struct custom_operations **) (v)))
 
 #ifdef __cplusplus
 extern "C" {
 #endif
 
 
-CAMLextern value caml_alloc_custom(struct custom_operations * ops,
+CAMLextern value caml_alloc_custom(const struct custom_operations * ops,
                                    uintnat size, /*size in bytes*/
                                    mlsize_t mem, /*resources consumed*/
                                    mlsize_t max  /*max resources*/);
 
-CAMLextern value caml_alloc_custom_mem(struct custom_operations * ops,
+CAMLextern value caml_alloc_custom_mem(const struct custom_operations * ops,
                                        uintnat size, /*size in bytes*/
                                        mlsize_t mem  /*memory consumed*/);
 
-CAMLextern void caml_register_custom_operations(struct custom_operations * ops);
+CAMLextern void
+          caml_register_custom_operations(const struct custom_operations * ops);
 
 /* Global variable moved to Caml_state in 4.10 */
 #define caml_compare_unordered (Caml_state_field(compare_unordered))
@@ -76,10 +77,10 @@ extern struct custom_operations *
 
 extern void caml_init_custom_operations(void);
 
-extern struct custom_operations caml_nativeint_ops;
+extern const struct custom_operations caml_nativeint_ops;
-extern struct custom_operations caml_int32_ops;
+extern const struct custom_operations caml_int32_ops;
-extern struct custom_operations caml_int64_ops;
+extern const struct custom_operations caml_int64_ops;
-extern struct custom_operations caml_ba_ops;
+extern const struct custom_operations caml_ba_ops;
 #endif /* CAML_INTERNALS */
 
 #ifdef __cplusplus

@@ -23,9 +23,78 @@ extern "C" {
 
 #ifdef CAML_INTERNALS
 
+#include "config.h"
+#include "mlvalues.h"
 #include "domain_state.h"
+#include "platform.h"
 
-void caml_init_domain(void);
+#define Caml_check_gc_interrupt(dom_st)   \
+  (CAMLalloc_point_here, \
+   CAMLunlikely((uintnat)(dom_st)->young_ptr < (dom_st)->young_limit))
+
+asize_t caml_norm_minor_heap_size (intnat);
+int caml_reallocate_minor_heap(asize_t);
+
+int caml_incoming_interrupts_queued(void);
+
+void caml_handle_gc_interrupt(void);
+void caml_handle_gc_interrupt_no_async_exceptions(void);
+void caml_handle_incoming_interrupts(void);
+
+CAMLextern void caml_interrupt_self(void);
+
+CAMLextern void caml_reset_domain_lock(void);
+CAMLextern int caml_bt_is_in_blocking_section(void);
+CAMLextern intnat caml_domain_is_multicore (void);
+CAMLextern void caml_bt_enter_ocaml(void);
+CAMLextern void caml_bt_exit_ocaml(void);
+CAMLextern void caml_acquire_domain_lock(void);
+CAMLextern void caml_release_domain_lock(void);
+
+CAMLextern void (*caml_atfork_hook)(void);
+
+CAMLextern void (*caml_domain_start_hook)(void);
+CAMLextern void (*caml_domain_stop_hook)(void);
+CAMLextern void (*caml_domain_external_interrupt_hook)(void);
+
+CAMLextern void caml_init_domains(uintnat minor_heap_size);
+CAMLextern void caml_init_domain_self(int);
+
+CAMLextern atomic_uintnat caml_num_domains_running;
+CAMLextern uintnat caml_minor_heaps_base;
+CAMLextern uintnat caml_minor_heaps_end;
+
+Caml_inline intnat caml_domain_alone(void)
+{
+  return atomic_load_acq(&caml_num_domains_running) == 1;
+}
+
+#ifdef DEBUG
+int caml_domain_is_in_stw(void);
+#endif
+
+int caml_try_run_on_all_domains_with_spin_work(
+  void (*handler)(caml_domain_state*, void*, int, caml_domain_state**),
+  void* data,
+  void (*leader_setup)(caml_domain_state*),
+  void (*enter_spin_callback)(caml_domain_state*, void*),
+  void* enter_spin_data);
+int caml_try_run_on_all_domains(
+  void (*handler)(caml_domain_state*, void*, int, caml_domain_state**),
+  void*,
+  void (*leader_setup)(caml_domain_state*));
+
+/* barriers */
+typedef uintnat barrier_status;
+void caml_global_barrier(void);
+barrier_status caml_global_barrier_begin(void);
+int caml_global_barrier_is_final(barrier_status);
+void caml_global_barrier_end(barrier_status);
+int caml_global_barrier_num_domains(void);
+
+int caml_domain_is_terminating(void);
+
+CAMLextern void caml_domain_set_name(char*);
 
 #endif /* CAML_INTERNALS */