Squashed 'lispBM/lispBM/' changes from 20e97c4b..07baa883

07baa883 small tweak to flatten/unflatten
3baa1619 flat values now contain a copy of arrays rather than a pointer to an array
c582416d improvement in lbm_lift_array
f4229a43 changes to find_receiver_and_send
d04a77dd switched to lbm_malloc in lbm_create_ctx
4e2e8ad4 fix buf in lbm_create_ctx thatcould potentially have allocated too little memory for a context
01f3c746 bux fix get_event_value, freed already freed lbm_memory array
2ed2560a bug in unflatten_value
7971a6eb change granularity of locks
51058b80 added an undo_block_ctx_from_extension function and resolved an issue with test_memory_3 on 64 bit platforms

git-subtree-dir: lispBM/lispBM
git-subtree-split: 07baa883ab18d2f12d69f36cf22aaf9f86954624

include/eval_cps.h

@@ -222,6 +222,9 @@ lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size);
 /** Block a context from an extension
  */
 void lbm_block_ctx_from_extension(void);
+  /** Undo a previous call to lbm_block_ctx_from_extension.
+   */
+  void lbm_undo_block_ctx_from_extension(void);
 /** Unblock a context that has been blocked by a C extension
  *  Trying to unblock a context that is waiting on a message
  *  in a mailbox is not encouraged

include/heap.h

@@ -88,7 +88,7 @@ value 4: 0000 0018
 
 Means bits 0,1,2 will always be empty in a valid address.
 
-Cons cells also need to be have room for 2 pointers. So each allocated cell from
+Cons cells also need to be have room for 2 pointers. So each ted cell from
 memory should be 8bytes.
 
 Things that needs to be represented within these bits:
@@ -565,6 +565,11 @@ int lbm_lift_array(lbm_value *value, char *data, lbm_type type, lbm_uint num_elt
  * \param arr Array value.
  */
 int lbm_heap_explicit_free_array(lbm_value arr);
+/** Query the size in bytes of an lbm_type.
+ * \param t Type
+ * \return Size in bytes of type or 0 if the type represents a composite.
+ */
+lbm_uint lbm_size_of(lbm_type t);
 
 /** Query the type information of a value.
  *

include/lbm_version.h

@@ -27,13 +27,18 @@ extern "C" {
 /** LBM major version */
 #define LBM_MAJOR_VERSION 0
 /** LBM minor version */
-#define LBM_MINOR_VERSION 8
+#define LBM_MINOR_VERSION 9
 /** LBM patch revision */
-#define LBM_PATCH_VERSION 1
+#define LBM_PATCH_VERSION 0
 
 /*! \page changelog Changelog
 
-Feb 5 2023: Version 0.8.1
+Feb 18 2023: Version 0.9.0
+  - Arrays in flat_value are stored verbatim, not as ptr.
+  - Mutex locking granularity changed in multiple places.
+
+Feb 10 2023: Version 0.8.1
+  - Flat representation of heap values added.
   - Added queue locking to GC
   - As an experiment blocked contexts are unblocked by the evaluator in a safe state.
 

src/eval_cps.c

@@ -560,12 +560,12 @@ static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
   return NULL;
 }
 
-static eval_context_t *lookup_ctx(eval_context_queue_t *q, lbm_cid cid) {
-  mutex_lock(&qmutex);
-  eval_context_t *res = lookup_ctx_nm(q,cid);
-  mutex_unlock(&qmutex);
-  return res;
-}
+/* static eval_context_t *lookup_ctx(eval_context_queue_t *q, lbm_cid cid) { */
+/*   mutex_lock(&qmutex); */
+/*   eval_context_t *res = lookup_ctx_nm(q,cid); */
+/*   mutex_unlock(&qmutex); */
+/*   return res; */
+/* } */
 
 static bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
 
@@ -609,12 +609,12 @@ static bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
 }
 
 /* Returns true if the context was dropped from the queue */
-static bool drop_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
-  mutex_lock(&qmutex);
-  bool res = drop_ctx_nm(q,ctx);
-  mutex_unlock(&qmutex);
-  return res;
-}
+/* static bool drop_ctx(eval_context_queue_t *q, eval_context_t *ctx) { */
+/*   mutex_lock(&qmutex); */
+/*   bool res = drop_ctx_nm(q,ctx); */
+/*   mutex_unlock(&qmutex); */
+/*   return res; */
+/* } */
 
 /* End execution of the running context and add it to the
    list of finished contexts. */
@@ -625,7 +625,6 @@ static void finish_ctx(void) {
   }
   /* Drop the continuation stack immediately to free up lbm_memory */
   lbm_stack_free(&ctx_running->K);
-
   if (ctx_done_callback) {
     ctx_done_callback(ctx_running);
   }
@@ -806,11 +805,11 @@ static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint
   if (lbm_type_of(program) != LBM_TYPE_CONS) return -1;
 
   eval_context_t *ctx = NULL;
-  ctx = (eval_context_t*)lbm_memory_allocate(sizeof(eval_context_t) / (sizeof(lbm_uint)));
+  ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
   if (ctx == NULL) {
     lbm_gc_mark_phase(2, program, env);
     gc();
-    ctx = (eval_context_t*)lbm_memory_allocate(sizeof(eval_context_t) / (sizeof(lbm_uint)));
+    ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
   }
   if (ctx == NULL) return -1;
 
@@ -968,43 +967,53 @@ void lbm_block_ctx_from_extension(void) {
   blocking_extension = true;
 }
 
+void lbm_undo_block_ctx_from_extension(void) {
+  blocking_extension = false;
+  mutex_unlock(&blocking_extension_mutex);
+}
+
 lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
+  mutex_lock(&qmutex);
   eval_context_t *found = NULL;
   bool found_blocked = false;
 
-  found = lookup_ctx(&blocked, cid);
+  found = lookup_ctx_nm(&blocked, cid);
   if (found) found_blocked = true;
 
   if (found == NULL) {
-    found = lookup_ctx(&queue, cid);
+    found = lookup_ctx_nm(&queue, cid);
   }
 
   if (found == NULL) {
-    found = lookup_ctx(&sleeping, cid);
+    found = lookup_ctx_nm(&sleeping, cid);
   }
 
   if (found) {
     if (!mailbox_add_mail(found, msg)) {
+      mutex_unlock(&qmutex);
       return ENC_SYM_NIL;
     }
 
     if (found_blocked){
-      drop_ctx(&blocked,found);
-      drop_ctx(&queue,found);
+      drop_ctx_nm(&blocked,found);
+      //drop_ctx_nm(&queue,found);  ????
 
-      enqueue_ctx(&queue,found);
+      enqueue_ctx_nm(&queue,found);
     }
+    mutex_unlock(&qmutex);
     return ENC_SYM_TRUE;
   }
 
   /* check the current context */
   if (ctx_running && ctx_running->id == cid) {
     if (!mailbox_add_mail(ctx_running, msg)) {
+      mutex_unlock(&qmutex);
       return ENC_SYM_NIL;
     }
+    mutex_unlock(&qmutex);
     return ENC_SYM_TRUE;
   }
-
+  mutex_unlock(&qmutex);
   return ENC_SYM_NIL;
 }
 
@@ -3238,14 +3247,15 @@ uint32_t lbm_get_eval_state(void) {
 
 static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
   eval_context_t *found = NULL;
+  mutex_lock(&qmutex);
 
-  found = lookup_ctx(&blocked, cid);
+  found = lookup_ctx_nm(&blocked, cid);
   if (found) {
-    drop_ctx(&blocked,found);
+    drop_ctx_nm(&blocked,found);
     found->r = v;
-    enqueue_ctx(&queue,found);
-    return;
+    enqueue_ctx_nm(&queue,found);
   }
+  mutex_unlock(&qmutex);
 }
 
 static lbm_value get_event_value(lbm_event_t *e) {
@@ -3259,7 +3269,6 @@ static lbm_value get_event_value(lbm_event_t *e) {
       lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED);
       v = ENC_SYM_EERROR;
     }
-    lbm_free(fv.buf);
   } else {
     v = (lbm_value)e->buf_ptr;
   }
@@ -3407,13 +3416,15 @@ bool lbm_eval_init_events(unsigned int num_events) {
 
   mutex_lock(&lbm_events_mutex);
   lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
-
-  if (!lbm_events) return false;
+  bool r = false;
+  if (lbm_events) {
     lbm_events_max = num_events;
     lbm_events_head = 0;
     lbm_events_tail = 0;
     lbm_events_full = false;
     lbm_event_handler_pid = -1;
+    r = true;
+  }
   mutex_unlock(&lbm_events_mutex);
-  return true;
+  return r;
 }

src/fundamental.c

@@ -569,7 +569,6 @@ static lbm_value cossa_lookup(lbm_value key, lbm_value assoc) {
 
 static lbm_value fundamental_add(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
   (void) ctx;
-
   lbm_uint sum = lbm_enc_u(0);
   for (lbm_uint i = 0; i < nargs; i ++) {
     sum = add2(sum, args[i]);

src/heap.c

@@ -1067,7 +1067,7 @@ int lbm_lift_array(lbm_value *value, char *data, lbm_type type, lbm_uint num_elt
     return 0;
   }
 
-  array = (lbm_array_header_t*)lbm_memory_allocate(sizeof(lbm_array_header_t) / 4);
+  array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t));
 
   if (array == NULL) return 0;
 
@@ -1120,3 +1120,32 @@ int lbm_heap_explicit_free_array(lbm_value arr) {
 
   return r;
 }
+
+lbm_uint lbm_size_of(lbm_type t) {
+  lbm_uint s = 0;
+  switch(t) {
+  case LBM_TYPE_BYTE:
+    s = 1;
+    break;
+  case LBM_TYPE_I: /* fall through */
+  case LBM_TYPE_U:
+  case LBM_TYPE_SYMBOL:
+#ifndef LBM64
+    s = 4;
+#else
+    s = 8;
+#endif
+    break;
+  case LBM_TYPE_I32: /* fall through */
+  case LBM_TYPE_U32:
+  case LBM_TYPE_FLOAT:
+    s = 4;
+    break;
+  case LBM_TYPE_I64: /* fall through */
+  case LBM_TYPE_U64:
+  case LBM_TYPE_DOUBLE:
+    s = 8;
+    break;
+  }
+  return s;
+}

src/lbm_flat_value.c

@@ -1,5 +1,6 @@
 /*
     Copyright 2023 Joel Svensson    svenssonjoel@yahoo.se
+              2023 Benjamin Vedder
 
     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
@@ -19,6 +20,7 @@
 #include <eval_cps.h>
 #include <stack.h>
 
+
 // ------------------------------------------------------------
 // Access to GC from eval_cps
 int lbm_perform_gc(void);
@@ -156,18 +158,23 @@ bool f_u64(lbm_flat_value_t *v, uint64_t w) {
   return res;
 }
 
-
 bool f_lbm_array(lbm_flat_value_t *v, uint32_t num_elts, lbm_uint t, uint8_t *data) {
   bool res = true;
   res = res && write_byte(v, S_LBM_ARRAY);
   res = res && write_word(v, num_elts);
 #ifndef LBM64
   res = res && write_word(v, t);
-  res = res && write_word(v, (lbm_uint)data);
 #else
   res = res && write_dword(v, t);
-  res = res && write_dword(v, (lbm_uint)data);
 #endif
+  uint32_t num_bytes = num_elts;
+  num_bytes *= lbm_size_of(t);
+  if (res && v->buf_size >= v->buf_pos + num_bytes) {
+    memcpy(v->buf + v->buf_pos, data, num_bytes);
+    v->buf_pos += num_bytes;
+  } else {
+    res = false;
+  }
   return res;
 }
 
@@ -210,7 +217,7 @@ static bool extract_dword(lbm_flat_value_t *v, uint64_t *r) {
 
 /* Recursive and potentially stack hungry for large flat values */
 static int lbm_unflatten_value_internal(lbm_flat_value_t *v, lbm_value *res) {
-  if (v->buf_size == v->buf_pos) return false;
+  if (v->buf_size == v->buf_pos) return UNFLATTEN_MALFORMED;
   uint8_t curr = v->buf[v->buf_pos++];
 
   switch(curr) {
@@ -345,13 +352,13 @@ static int lbm_unflatten_value_internal(lbm_flat_value_t *v, lbm_value *res) {
       b = extract_dword(v,&t);
 #endif
       if (b) {
-        lbm_uint ptr;
-#ifndef LBM64
-        b = extract_word(v,&ptr);
-#else
-        b = extract_dword(v,&ptr);
-#endif
-        if (!lbm_lift_array(res, (char*)ptr, t, num_elt)) {
+        if (lbm_heap_allocate_array(res, num_elt, t)) {
+          lbm_array_header_t *arr = (lbm_array_header_t*)lbm_car(*res);
+          lbm_uint num_bytes = num_elt;
+          num_bytes *= lbm_size_of(t);
+          memcpy(arr->data, v->buf + v->buf_pos, num_bytes);
+          v->buf_pos += num_bytes;
+        } else {
           return UNFLATTEN_GC_RETRY;
         }
         return UNFLATTEN_OK;

src/lbm_memory.c

@@ -323,10 +323,6 @@ static lbm_uint *lbm_memory_allocate_internal(lbm_uint num_words) {
 }
 
 lbm_uint *lbm_memory_allocate(lbm_uint num_words) {
- if (memory_num_free < num_words) {
-    lbm_request_gc();
-    return NULL;
-  }
   if (memory_num_free - num_words < memory_reserve_level) {
     lbm_request_gc();
     return NULL;

tests/test_lisp_code_cps.c

@@ -264,24 +264,12 @@ LBM_EXTENSION(ext_event_list_of_float, args, argn) {
 LBM_EXTENSION(ext_event_array, args, argn) {
   lbm_value res = ENC_SYM_EERROR;
   if (argn == 1 && lbm_is_symbol(args[0])) {
-    char *array = lbm_malloc(12);
-    array[0] = 'h';
-    array[1] = 'e';
-    array[2] = 'l';
-    array[3] = 'l';
-    array[4] = 'o';
-    array[5] = ' ';
-    array[6] = 'w';
-    array[7] = 'o';
-    array[8] = 'r';
-    array[9] = 'l';
-    array[10] = 'd';
-    array[11] = 0;
+    char *hello = "hello world";
     lbm_flat_value_t v;
     if (lbm_start_flatten(&v, 100)) {
       f_cons(&v);
       f_sym(&v,lbm_dec_sym(args[0]));
-      f_lbm_array(&v, 12, LBM_TYPE_CHAR, (uint8_t*)array);
+      f_lbm_array(&v, 12, LBM_TYPE_CHAR, (uint8_t*)hello);
       lbm_finish_flatten(&v);
       lbm_event(&v);
       res = ENC_SYM_TRUE;
@@ -382,14 +370,24 @@ int main(int argc, char **argv) {
     return 0;
   }
 
-  lbm_uint *memory = malloc(sizeof(lbm_uint) * LBM_MEMORY_SIZE_14K);
+  lbm_uint *memory = NULL;
+  lbm_uint *bitmap = NULL;
+  if (sizeof(lbm_uint) == 4) { 
+    memory = malloc(sizeof(lbm_uint) * LBM_MEMORY_SIZE_14K);
     if (memory == NULL) return 0;
-  lbm_uint *bitmap = malloc(sizeof(lbm_uint) * LBM_MEMORY_BITMAP_SIZE_14K);
+    bitmap = malloc(sizeof(lbm_uint) * LBM_MEMORY_BITMAP_SIZE_14K);
     if (bitmap == NULL) return 0;
-
-
     res = lbm_memory_init(memory, LBM_MEMORY_SIZE_14K,
                           bitmap, LBM_MEMORY_BITMAP_SIZE_14K);
+  } else {
+    memory = malloc(sizeof(lbm_uint) * LBM_MEMORY_SIZE_1M);
+    if (memory == NULL) return 0;
+    bitmap = malloc(sizeof(lbm_uint) * LBM_MEMORY_BITMAP_SIZE_1M);
+    if (bitmap == NULL) return 0;
+    res = lbm_memory_init(memory, LBM_MEMORY_SIZE_1M,
+                          bitmap, LBM_MEMORY_BITMAP_SIZE_1M);
+  }
+
   if (res)
     printf("Memory initialized.\n");
   else {

tests/test_memory_3.lisp

@@ -2,16 +2,19 @@
 
 (def n (* (word-size) (mem-longest-free)))
 
-(def a (array-create (- n 1500)))
+(def a (array-create (/ n 2)))
 
-(defun f () (array-create 1500)) ;; Should not succeed
+(defun f ()
+  (progn
+    (+ 1 2)
+    (array-create (/ n 2)))) ;; Should not succeed
 
 
 (spawn-trap f)
 
 
-(def err (recv ((exit-error (? tid) (? e)) e)
+(def res (recv ((exit-error (? tid) (? e)) e)
                ((exit-ok    (? tid) (? r)) r)))
 
-(and (eq err out_of_memory) ;; error caught
+(and (eq res out_of_memory) ;; error caught
      (= (+ 1 2) 3))        ;; eval is alive

tests/test_memory_4.lisp

@@ -0,0 +1,18 @@
+
+
+(def n (* (word-size) (mem-longest-free)))
+
+(def a (array-create (/ n 4)))
+
+(defun f ()
+    (array-create (/ n 4))) ;; probably fine
+
+
+(spawn-trap f)
+
+
+(def res (recv ((exit-error (? tid) (? e)) e)
+               ((exit-ok    (? tid) (? r)) r)))
+
+(and (eq (type-of res) 'type-array ) ;; OK status cought
+     (= (+ 1 2) 3))        ;; eval is alive