From a435f69b1f7976f489ebe12bb7caeab1c2402dd2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Mon, 9 Dec 2024 12:10:54 +0100
Subject: [PATCH] memory: make it possible to configure the allocator

---
 src/c/boot.d      |  4 ++-
 src/c/escape.d    |  4 +--
 src/c/mem_bdwgc.d | 26 ++++++++++++++--
 src/c/memory.d    | 78 ++++++++++++++++++++++++++++++++++++++++++-----
 src/h/external.h  |  1 +
 src/h/internal.h  |  1 +
 src/h/nucleus.h   |  7 +++++
 src/h/object.h    |  9 +++++-
 8 files changed, 117 insertions(+), 13 deletions(-)

diff --git a/src/c/boot.d b/src/c/boot.d
index b1b43c652..bae0322e9 100644
--- a/src/c/boot.d
+++ b/src/c/boot.d
@@ -206,7 +206,7 @@ _ecl_alloc_env(cl_env_ptr parent)
 # endif
 #endif
   /* Initialize the structure with NULL data. */
-  memset(output, 0, sizeof(*output));
+  ecl_mset(output, 0, sizeof(*output));
 #ifdef ECL_THREADS
   add_env(output);
 #endif
@@ -247,6 +247,7 @@ struct ecl_core_struct ecl_core = {
   .default_sigmask_bytes = 0,
   .known_signals = ECL_NIL,
   /* allocation */
+  .allocator = NULL,
   .max_heap_size = 0,
   .bytes_consed = ECL_NIL,
   .gc_counter = ECL_NIL,
@@ -277,6 +278,7 @@ ecl_boot(void)
     }
     return 1;
   }
+  init_memory();
   init_modules();
   ecl_core.path_max = MAXPATHLEN;
   return 0;
diff --git a/src/c/escape.d b/src/c/escape.d
index fc7a028cb..cc50d6e4b 100644
--- a/src/c/escape.d
+++ b/src/c/escape.d
@@ -282,9 +282,9 @@ _ecl_dump_c_backtrace()
 # endif
     }
     fflush(stderr);
-    free(pointers);
+    ecl_free(pointers);
 # if defined(ECL_UNIX_BACKTRACE)
-    free(names);
+    ecl_free(names);
 # elif defined(ECL_WINDOWS_BACKTRACE)
     SymCleanup(process);
 # endif
diff --git a/src/c/mem_bdwgc.d b/src/c/mem_bdwgc.d
index 821c2612d..6c4cb4421 100644
--- a/src/c/mem_bdwgc.d
+++ b/src/c/mem_bdwgc.d
@@ -267,8 +267,8 @@ allocate_object_marked(struct ecl_type_information *type_info)
 }
 #endif
 
-cl_object
-ecl_alloc_object(cl_type t)
+static cl_object
+alloc_object(cl_type t)
 {
 #ifdef GBC_BOEHM_PRECISE
   struct ecl_type_information *ti;
@@ -1221,6 +1221,26 @@ si_gc_dump()
 
 /* -- module definition ------------------------------------------------------ */
 
+static void *
+alloc_memory(cl_index size)
+{
+  return GC_MALLOC(size);
+}
+
+static void
+free_object(cl_object o)
+{
+  standard_finalizer(o);
+  ecl_dealloc(o);
+}
+
+struct ecl_allocator_ops gc_ops = {
+  .allocate_memory = alloc_memory,
+  .allocate_object = alloc_object,
+  .free_memory = ecl_dealloc,
+  .free_object = free_object
+};
+
 static cl_object
 create_gc()
 {
@@ -1285,6 +1305,8 @@ create_gc()
   GC_set_oom_fn(out_of_memory);
   GC_set_warn_proc(no_warnings);
 
+  ecl_core.allocator = &gc_ops;
+
   return ECL_NIL;
 }
 
diff --git a/src/c/memory.d b/src/c/memory.d
index 9f5f66b93..da393f447 100644
--- a/src/c/memory.d
+++ b/src/c/memory.d
@@ -2,7 +2,7 @@
 /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
 
 /*
- * memory.c - manual memory managament
+ * memory.c - memory managament
  *
  * Copyright (c) 2024 Daniel Kochmański
  *
@@ -32,13 +32,12 @@ out_of_memory()
        goto AGAIN;
 
      For now let's crash with an appropriate error. */
-  ecl_internal_error("*** manual memory allocator: out of memory\n");
+  ecl_internal_error("*** memory allocator: out of memory\n");
 }
 
 void *
 ecl_malloc(cl_index n)
 {
-  /* GC-free equivalent of ecl_alloc_atomic. */
   const cl_env_ptr the_env = ecl_process_env_unsafe();
   void *ptr;
   if (!the_env) {
@@ -68,10 +67,16 @@ ecl_free(void *ptr)
 void *
 ecl_realloc(void *ptr, cl_index osize, cl_index nsize)
 {
-  void *p = ecl_malloc(nsize);
-  ecl_copy(p, ptr, (osize < nsize) ? osize : nsize);
-  ecl_free(ptr);
-  return p;
+  const cl_env_ptr the_env = ecl_process_env_unsafe();
+  if (!the_env) {
+    ptr = realloc(ptr, nsize);
+  } else {
+    ecl_disable_interrupts_env(the_env);
+    ptr = realloc(ptr, nsize);
+    ecl_enable_interrupts_env(the_env);
+  }
+  if (ptr == NULL) out_of_memory();
+  return ptr;
 }
 
 void
@@ -79,3 +84,62 @@ ecl_copy(void *dst, void *src, cl_index ndx)
 {
   memcpy(dst, src, ndx);
 }
+
+void
+ecl_mset(void *ptr, byte c, cl_index n)
+{
+  memset(ptr, c, n);
+}
+
+/* -- Constructors ---------------------------------------------------------- */
+
+cl_object
+ecl_alloc_object(cl_type t)
+{
+  return ecl_core.allocator->allocate_object(t);
+}
+
+void *
+ecl_alloc_memory(cl_index n)
+{
+  return ecl_core.allocator->allocate_memory(n);
+}
+
+void
+ecl_free_object(cl_object ptr)
+{
+  return ecl_core.allocator->free_object(ptr);
+}
+
+void
+ecl_free_memory(void *ptr)
+{
+  return ecl_core.allocator->free_memory(ptr);
+}
+
+/* -- Rudimentary manual memory allocator ----------------------------------- */
+
+static cl_object
+alloc_object(cl_type t)
+{
+  ecl_internal_error("*** memory: alloc_object not implemented.\n");
+}
+
+static void
+free_object(cl_object self)
+{
+  ecl_internal_error("*** memory: free_object not implemented.\n");
+}
+
+struct ecl_allocator_ops manual_allocator = {
+  .allocate_memory = ecl_malloc,
+  .allocate_object = alloc_object,
+  .free_memory = ecl_free,
+  .free_object = free_object
+};
+
+void
+init_memory ()
+{
+  ecl_core.allocator = &manual_allocator;
+}
diff --git a/src/h/external.h b/src/h/external.h
index 7dcb04061..d3b431e20 100755
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -221,6 +221,7 @@ extern ECL_API void *ecl_malloc(cl_index n);
 extern ECL_API void *ecl_realloc(void *ptr, cl_index o, cl_index n);
 extern ECL_API void ecl_free(void *ptr);
 extern ECL_API void ecl_copy(void *dst, void *src, cl_index ndx);
+extern ECL_API void ecl_mset(void *dst, byte val, cl_index ndx);
 #define ecl_free_unsafe(x) ecl_free(x);
 
 /* boot.c */
diff --git a/src/h/internal.h b/src/h/internal.h
index 573351dde..0d937b213 100755
--- a/src/h/internal.h
+++ b/src/h/internal.h
@@ -35,6 +35,7 @@ extern ECL_API cl_object ecl_module_bignum;
 extern ECL_API cl_object ecl_module_ffi;
 extern ECL_API cl_object ecl_module_aux;
 
+extern void init_memory(void);
 extern void init_all_symbols(void);
 extern void init_backq(void);
 extern void init_big();
diff --git a/src/h/nucleus.h b/src/h/nucleus.h
index c5d820191..6fcb668cc 100644
--- a/src/h/nucleus.h
+++ b/src/h/nucleus.h
@@ -17,6 +17,7 @@ struct ecl_core_struct {
   cl_index last_var_index;
   cl_object reused_indices;
 #endif
+  struct ecl_allocator_ops *allocator;
   size_t max_heap_size;
   cl_object bytes_consed;
   cl_object gc_counter;
@@ -73,4 +74,10 @@ cl_object ecl_raise(ecl_ex_type t, bool ret,
 #define ecl_cerror4(extype,a1,a2,a3) ecl_raise(extype, 1, a1, a2, a3, NULL)
 #define ecl_cerror5(extype,a1,a2,a3,p4) ecl_raise(extype, 1, a1, a2, a3, p4)
 
+/* memory.c */
+void *ecl_alloc_memory(cl_index n);
+cl_object ecl_alloc_object(cl_type t);
+void ecl_free_memory(void *ptr);
+void ecl_free_object(cl_object o);
+
 #endif  /* ECL_NUCLEUS_H */
diff --git a/src/h/object.h b/src/h/object.h
index c0b9bf0ad..5b6935c06 100644
--- a/src/h/object.h
+++ b/src/h/object.h
@@ -97,7 +97,6 @@ typedef enum {
         FREE = 127              /*  free object  */
 } cl_type;
 
-
 /*
         Definition of the type of LISP objects.
 */
@@ -110,6 +109,14 @@ typedef cl_object (*cl_objectfn_fixed)();
 typedef cl_object (*cl_objectfn_parse)(cl_object,cl_object,int);
 typedef cl_object (*cl_objectfn_envfn)(cl_env_ptr);
 
+/* Allocator interface */
+struct ecl_allocator_ops {
+  void *(*allocate_memory)(cl_index n);    /* low-level  alloc */
+  cl_object (*allocate_object)(cl_type t); /* high-level alloc */
+  void (*free_memory)(void*);              /* low-level  free */
+  void (*free_object)(cl_object);          /* high-level free */
+};
+
 /*
         OBJect NULL value.
         It should not coincide with any legal object value.