From 19f3c85fe2570e6c783e111d095bb799bb22fd57 Mon Sep 17 00:00:00 2001
From: dyb <dyb@scheme.com>
Date: Fri, 5 Oct 2018 09:03:30 -0700
Subject: [PATCH] attempted partial fix for github issue 352 - when
 thread_get_room exhausts the local allocation area, it now   goes through a
 common path with S_get_more_room to allocate a new   local allocation area
 when appropriate.  this can greatly reduce   the use of global allocation
 (and the number of tc mutex acquires   in threaded builds) when a lot of
 small objects are allocated by   C code with no intervening Scheme-side
 allocation or dirty writes.     alloc.c, types.h, externs.h

original commit: 93dfa7674a95837e5a22bc622fecc50b0224f60d
---
 LOG         |  7 +++++++
 c/alloc.c   | 41 ++++++++++++++++++++---------------------
 c/externs.h |  2 +-
 c/types.h   |  2 +-
 4 files changed, 29 insertions(+), 23 deletions(-)

diff --git a/LOG b/LOG
index 43b282d86c..a8a2ecdf60 100644
--- a/LOG
+++ b/LOG
@@ -1009,3 +1009,10 @@
     c/*nt, wininstall/*nt.wxs
 - use uuid_generate on unix-like systems for S_unique_id
     BUILDING, c/Mf-*le, stats.c, objects.stex, release_notes.stex
+- when thread_get_room exhausts the local allocation area, it now
+  goes through a common path with S_get_more_room to allocate a new
+  local allocation area when appropriate.  this can greatly reduce
+  the use of global allocation (and the number of tc mutex acquires
+  in threaded builds) when a lot of small objects are allocated by
+  C code with no intervening Scheme-side allocation or dirty writes.
+    alloc.c, types.h, externs.h
diff --git a/c/alloc.c b/c/alloc.c
index 84da3678ad..efdd268969 100644
--- a/c/alloc.c
+++ b/c/alloc.c
@@ -150,14 +150,6 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; {
   return Sunsigned(n);
 }
 
-ptr S_thread_get_more_room(t, n) iptr t; iptr n; {
-   ptr x;
-   tc_mutex_acquire()
-   find_room(space_new, 0, t, n, x);
-   tc_mutex_release()
-   return x;
-}
-
 static void maybe_fire_collector() {
   ISPC s;
   uptr bytes, fudge;
@@ -369,24 +361,29 @@ void S_scan_remembered_set() {
 
 void S_get_more_room() {
   ptr tc = get_thread_context();
-  ptr xp; uptr ap, eap, real_eap, type, size;
-
-  tc_mutex_acquire()
-
-  ap = (uptr)AP(tc);
-  eap = (uptr)EAP(tc);
-  real_eap = (uptr)REAL_EAP(tc);
+  ptr xp; uptr ap, type, size;
 
   xp = XP(tc);
   if ((type = TYPEBITS(xp)) == 0) type = typemod;
-  size = ap - (iptr)UNTYPE(xp,type);
-  ap -= size;
+  ap = (uptr)UNTYPE(xp, type);
+  size = (uptr)((iptr)AP(tc) - (iptr)ap);
+
+  XP(tc) = S_get_more_room_help(tc, ap, type, size);
+}
+
+ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) {
+  ptr x; uptr eap, real_eap;
+
+  eap = (uptr)EAP(tc);
+  real_eap = (uptr)REAL_EAP(tc);
+
+  tc_mutex_acquire()
 
   S_scan_dirty((ptr **)eap, (ptr **)real_eap);
   eap = real_eap;
 
   if (eap - ap >= size) {
-    XP(tc) = TYPE(ap, type);
+    x = TYPE(ap, type);
     ap += size;
     if (eap - ap > alloc_waste_maximum) {
       AP(tc) = (ptr)ap;
@@ -398,20 +395,22 @@ void S_get_more_room() {
   } else if (eap - ap > alloc_waste_maximum) {
     AP(tc) = (ptr)ap;
     EAP(tc) = (ptr)eap;
-    find_room(space_new, 0, type, size, XP(tc));
+    find_room(space_new, 0, type, size, x);
   } else {
     S_G.bytes_of_space[space_new][0] -= eap - ap;
     S_reset_allocation_pointer(tc);
     ap = (uptr)AP(tc);
     if (size + alloc_waste_maximum <= (uptr)EAP(tc) - ap) {
-      XP(tc) = TYPE(ap, type);
+      x = TYPE(ap, type);
       AP(tc) = (ptr)(ap + size);
     } else {
-      find_room(space_new, 0, type, size, XP(tc));
+      find_room(space_new, 0, type, size, x);
     }
   }
 
   tc_mutex_release()
+
+  return x;
 }
 
 /* S_cons_in is always called with mutex */
diff --git a/c/externs.h b/c/externs.h
index 692712e357..778db3b85b 100644
--- a/c/externs.h
+++ b/c/externs.h
@@ -59,6 +59,7 @@ extern void S_dirty_set PROTO((ptr *loc, ptr x));
 extern void S_scan_dirty PROTO((ptr **p, ptr **endp));
 extern void S_scan_remembered_set PROTO((void));
 extern void S_get_more_room PROTO((void));
+extern ptr S_get_more_room_help PROTO((ptr tc, uptr ap, uptr type, uptr size));
 extern ptr S_cons_in PROTO((ISPC s, IGEN g, ptr car, ptr cdr));
 extern ptr S_symbol PROTO((ptr name));
 extern ptr S_rational PROTO((ptr n, ptr d));
@@ -88,7 +89,6 @@ extern ptr S_string PROTO((const char *s, iptr n));
 extern ptr S_bignum PROTO((iptr n, IBOOL sign));
 extern ptr S_code PROTO((ptr tc, iptr type, iptr n));
 extern ptr S_relocation_table PROTO((iptr n));
-extern ptr S_thread_get_more_room PROTO((iptr t, iptr n));
 
 /* fasl.c */
 extern void S_fasl_init PROTO((void));
diff --git a/c/types.h b/c/types.h
index ca4e582070..872dc17671 100644
--- a/c/types.h
+++ b/c/types.h
@@ -96,7 +96,7 @@ typedef int IFASLCODE;      /* fasl type codes */
   ptr _tc = tc;\
   uptr _ap = (uptr)AP(_tc);\
   if ((uptr)n > ((uptr)EAP(_tc) - _ap)) {\
-    (x) = S_thread_get_more_room(t, n);\
+    (x) = S_get_more_room_help(_tc, _ap, t, n);\
   } else {\
     (x) = TYPE(_ap,t);\
     AP(_tc) = (ptr)(_ap + n);\