From 9e7900e2f92864e315bf5dde7c9d69ed64331625 Mon Sep 17 00:00:00 2001
From: dyb <dyb@scheme.com>
Date: Mon, 2 Jul 2018 07:43:02 -0600
Subject: [PATCH] reworked the S_call_help/S_return CCHAIN handling to fix a
 bug in which the signal handler could trip over the NULL jumpbuf in a CCHAIN
 record.   schlib.c remade boot files

cherry picked from cisco/ChezScheme#d8c2704031

original commit: f03e2535577df3e3b5d8ad7349c46d4c2e89b507
---
 LOG         |  3 +++
 c/externs.h |  2 +-
 c/scheme.c  |  2 +-
 c/schlib.c  | 31 ++++++++++++++++++++++---------
 4 files changed, 27 insertions(+), 11 deletions(-)

diff --git a/LOG b/LOG
index 90300b4f7b..9f9135dc51 100644
--- a/LOG
+++ b/LOG
@@ -763,6 +763,9 @@
     schlib.c, prim.c, externs.h
     mats/foreign4.c, mats/foreign.ms mats/Mf-*
     foreign.stex, release_notes.stex
+- reworked the S_call_help/S_return CCHAIN handling to fix a bug in which
+  the signal handler could trip over the NULL jumpbuf in a CCHAIN record.  
+    schlib.c
 - added box-cas! and vector-cas!
     prims.ss, cpnanopass.ss, np-languages.ss,
     cmacros.ss, library.ss, primdata.ss
diff --git a/c/externs.h b/c/externs.h
index b51fa8182d..4c5649950c 100644
--- a/c/externs.h
+++ b/c/externs.h
@@ -343,7 +343,7 @@ extern void S_machine_init PROTO((void));
 extern void S_initframe PROTO((ptr tc, iptr n));
 extern void S_put_arg PROTO((ptr tc, iptr i, ptr x));
 extern void S_return PROTO((void));
-extern void S_call_help PROTO((ptr tc, IBOOL singlep));
+extern void S_call_help PROTO((ptr tc, IBOOL singlep, IBOOL lock_ts));
 extern void S_call_one_result PROTO((void));
 extern void S_call_any_results PROTO((void));
 
diff --git a/c/scheme.c b/c/scheme.c
index 980224c03c..2d6c38b9ca 100644
--- a/c/scheme.c
+++ b/c/scheme.c
@@ -320,7 +320,7 @@ static ptr boot_call(tc, p, n) ptr tc; ptr p; INT n; {
     CP(tc) = Svoid; /* don't have calling code object */
 
     AC0(tc) = (ptr)(uptr)n;
-    S_call_help(tc, 0);
+    S_call_help(tc, 0, 0);
     check_ap(tc);
 
     CP(tc) = Svoid; /* leave clean so direct Scall won't choke */
diff --git a/c/schlib.c b/c/schlib.c
index 7ee50b3b61..33250c71c3 100644
--- a/c/schlib.c
+++ b/c/schlib.c
@@ -199,14 +199,16 @@ ptr Scall(cp, argcnt) ptr cp; iptr argcnt; {
 static ptr S_call(tc, cp, argcnt) ptr tc; ptr cp; iptr argcnt; {
     AC0(tc) = (ptr)argcnt;
     AC1(tc) = cp;
-    S_call_help(tc, 1);
+    S_call_help(tc, 1, 0);
     return AC0(tc);
 }
 
 /* args are set up, argcnt in ac0, closure in ac1 */
-void S_call_help(tc, singlep) ptr tc; IBOOL singlep; {
-  /* declaring code volatile should be unnecessary, but it quiets gcc */
-    void *jb; volatile ptr code;
+void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_ts; {
+  /* declaring code and tc volatile should be unnecessary, but it quiets gcc
+     and avoids occasional invalid memory violations on Windows */
+  void *jb; volatile ptr code;
+  volatile ptr tc = tc_in;
 
   /* lock caller's code object, since his return address is sitting in
      the C stack and we may end up in a garbage collection */
@@ -219,7 +221,16 @@ void S_call_help(tc, singlep) ptr tc; IBOOL singlep; {
     jb = CREATEJMPBUF();
     if (jb == NULL)
       S_error_abort("unable to allocate memory for jump buffer");
-    FRAME(tc, -1) = CCHAIN(tc) = Scons(Scons(jb, code), CCHAIN(tc));
+    if (lock_ts) {
+      /* Lock a code object passed in TS, which is a more immediate
+         caller whose return address is on the C stack */
+      Slock_object(TS(tc));
+      CCHAIN(tc) = Scons(Scons(jb, Scons(code,TS(tc))), CCHAIN(tc));
+    } else {
+      CCHAIN(tc) = Scons(Scons(jb, Scons(code,Sfalse)), CCHAIN(tc));
+    }
+
+    FRAME(tc, -1) = CCHAIN(tc);
 
     switch (SETJMP(jb)) {
         case 0: /* first time */
@@ -254,15 +265,15 @@ void S_call_help(tc, singlep) ptr tc; IBOOL singlep; {
 
 void S_call_one_result() {
     ptr tc = get_thread_context();
-    S_call_help(tc, 1);
+    S_call_help(tc, 1, 1);
 }
 
 void S_call_any_results() {
     ptr tc = get_thread_context();
-    S_call_help(tc, 0);
+    S_call_help(tc, 0, 1);
 }
 
-/* cchain = ((jb . co) ...) */
+/* cchain = ((jb . (co . maybe-co)) ...) */
 void S_return() {
     ptr tc = get_thread_context();
     ptr xp, yp;
@@ -279,7 +290,9 @@ void S_return() {
 
   /* error checks are done; now unlock affected code objects */
     for (xp = CCHAIN(tc); ; xp = Scdr(xp)) {
-        Sunlock_object(CDAR(xp));
+        ptr p = CDAR(xp);
+        Sunlock_object(Scar(p));
+        if (Scdr(p) != Sfalse) Sunlock_object(Scdr(p));
         if (xp == yp) break;
         FREEJMPBUF(CAAR(xp));
     }