From b05519f16c44262ecba07f010de229dbcbe4e8f3 Mon Sep 17 00:00:00 2001
From: Stephen Dolan <stephen.dolan@cl.cam.ac.uk>
Date: Wed, 20 Apr 2022 11:32:37 +0100
Subject: [PATCH] Fix a GC bug in local stack scanning (#17)

The stack pointer was computed relative to the wrong local arena
---
 runtime/roots_nat.c                           |  2 +-
 testsuite/tests/typing-local/localgcbug.ml    | 20 +++++++++++++++++++
 .../tests/typing-local/localgcbug.reference   |  1 +
 3 files changed, 22 insertions(+), 1 deletion(-)
 create mode 100644 testsuite/tests/typing-local/localgcbug.ml
 create mode 100644 testsuite/tests/typing-local/localgcbug.reference

diff --git a/runtime/roots_nat.c b/runtime/roots_nat.c
index b7a24adc76e..8618d435d12 100644
--- a/runtime/roots_nat.c
+++ b/runtime/roots_nat.c
@@ -522,7 +522,7 @@ static void do_local_allocations(caml_local_arenas* loc,
       if (marked_local) {
         int ix = get_local_ix(loc, *p);
         struct caml_local_arena a = loc->arenas[ix];
-        intnat newsp = (char*)p - (a.base + a.length);
+        intnat newsp = (char*)*p - (a.base + a.length);
         if (sp <= newsp) {
           /* forwards pointer, common case */
           CAMLassert(ix <= arena_ix);
diff --git a/testsuite/tests/typing-local/localgcbug.ml b/testsuite/tests/typing-local/localgcbug.ml
new file mode 100644
index 00000000000..38b679d7d59
--- /dev/null
+++ b/testsuite/tests/typing-local/localgcbug.ml
@@ -0,0 +1,20 @@
+(* TEST
+   flags += "-extension local"
+   * native *)
+
+type n = Z | S of n
+
+let rec gen_locals (local_ n) depth _ = local_
+  if depth = 0
+  then
+    S n
+  else
+    let s = S n in
+    let m = gen_locals s (depth - 1) (ref 42) in
+    let _ = gen_locals m (depth - 1) (ref 42) in
+    S n
+
+let () =
+  match gen_locals Z 21 (ref 42) with
+  | S Z -> print_endline "ok"
+  | _ -> assert false
diff --git a/testsuite/tests/typing-local/localgcbug.reference b/testsuite/tests/typing-local/localgcbug.reference
new file mode 100644
index 00000000000..9766475a418
--- /dev/null
+++ b/testsuite/tests/typing-local/localgcbug.reference
@@ -0,0 +1 @@
+ok