Squashed 'lispBM/lispBM/' changes from 90b18761..be981ff1

be981ff1 added setix to refman and a way to block a context from a c extension together with a way to later unblock such a blocked context from C
8d4ec0e3 small tweak to the main evaluation case (function application).
289c69a6 a small tweak for closure argument evaluation efficiency
664347f4 added the lbm_stack_reserve function for allocation of multiple words on the stack in one go

git-subtree-dir: lispBM/lispBM
git-subtree-split: be981ff1f8e40b40dfa1dcbc43075e9e8ec9fa9c

doc/lbmref.md

@@ -852,6 +852,19 @@ Example that evaluates to 2.
 
 ---
 
+### setix
+
+Destructively update an element in a list. The form of a `setix` expression
+is `(setix list-expr index-extr value-expr)`. Indexing starts from 0 and
+if you index out of bounds the result is nil.
+
+```lisp
+# (setix (list 1 2 3 4 5) 2 77)
+> (1 2 77 4 5)
+```
+
+---
+
 ### setcar
 
 The `setcar` is a destructive update of the car field

include/eval_cps.h

@@ -162,6 +162,16 @@ extern int lbm_set_error_reason(char *error_str);
  * \return
  */
 extern lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size);
+/** Block a context from an extension
+ */
+extern void lbm_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
+ * \param cid Lisp process to wake up.
+ * \param result Value passed to the lisp process as the result from the blocking function.
+ */
+extern bool lbm_unblock_ctx(lbm_cid cid, lbm_value result);
 /**  Iterate over all ready contexts and apply function on each context.
  *
  * \param f Function to apply to each context.
@@ -221,6 +231,12 @@ extern void lbm_set_dynamic_load_callback(bool (*fptr)(const char *, const char
  *  within a context
  */
 extern void lbm_set_reader_done_callback(void (*fptr)(lbm_cid));
+/** Get the CID of the currently executing context.
+ *  Should be called from an extension where there is
+ *  a guarantee that a context is running
+ */
+extern lbm_cid lbm_get_current_cid(void);
+
 /** Create a token stream for parsing for code
  *
  * \param str character stream to convert into a token stream.

include/lbm_version.h

@@ -29,6 +29,9 @@
 
 /*! \page changelog Changelog
 
+May 1 2022: Version 0.5.2
+ - Added lbm_stack_reserve for allocating multiple words on stack
+   in one function call (and one check on stack limits).
 
 Apr 19 2022: Version 0.5.2
  - Added a reader_done_callback that is run when a context is done

include/stack.h

@@ -73,6 +73,15 @@ extern lbm_uint *lbm_get_stack_ptr(lbm_stack_t *s, lbm_uint n);
  * \return 1 on Success and 0 on failure.
  */
 extern int lbm_stack_drop(lbm_stack_t *s, lbm_uint n);
+
+/** Reserve place for n elements on the stack and
+ *  move the stack pointer to the new top.
+ * \param s Stack to reserve values on
+ * \param n Number of values to reserve
+ * \return Pointer into stack position of reserver value 0 or NULL
+ *         on failure
+ */
+extern lbm_uint *lbm_stack_reserve(lbm_stack_t *s, lbm_uint n);
 /** Push an element onto a stack.
  *
  * \param s Stack to push a value onto.

repl/repl.c

@@ -322,6 +322,12 @@ bool dyn_load(const char *str, const char **code) {
   return res;
 }
 
+lbm_value ext_block(lbm_value *args, lbm_uint argn) {
+
+  printf("blocking CID: %d\n", lbm_get_current_cid());
+  lbm_block_ctx_from_extension();
+  return lbm_enc_sym(SYM_TRUE);
+}
 
 lbm_value ext_print(lbm_value *args, lbm_uint argn) {
   erase();
@@ -524,6 +530,11 @@ int main(int argc, char **argv) {
     printf("Loading math extensions failed\n");
   }
 
+  res = lbm_add_extension("block", ext_block);
+  if (res)
+    printf("Extension added.\n");
+  else
+    printf("Error adding extension.\n");
 
   res = lbm_add_extension("print", ext_print);
   if (res)
@@ -640,6 +651,11 @@ int main(int argc, char **argv) {
       printf("****** Done contexts ******\n");
       lbm_done_iterator(print_ctx_info, NULL, NULL);
       free(str);
+    } else if (strncmp(str, ":unblock", 8) == 0) {
+      int id = atoi(str + 8);
+      printf("Unblocking: %d\n", id);
+      lbm_unblock_ctx(id, lbm_enc_i(42));
+      free(str);
     } else if (strncmp(str, ":wait", 5) == 0) {
       int id = atoi(str + 5);
       bool exists = false;
@@ -696,6 +712,12 @@ int main(int argc, char **argv) {
           printf("Loading math extensions failed\n");
         }
 
+        res = lbm_add_extension("block", ext_block);
+        if (res)
+          printf("Extension added.\n");
+        else
+          printf("Error adding extension.\n");
+
         lbm_add_extension("print", ext_print);
         free(str);
       }

src/eval_cps.c

@@ -141,6 +141,8 @@ volatile uint32_t eval_cps_next_state_arg = 0;
 static bool     eval_running = false;
 static uint32_t next_ctx_id = 1;
 
+static volatile bool     blocking_extension = false;
+
 typedef struct {
   eval_context_t *first;
   eval_context_t *last;
@@ -196,6 +198,13 @@ void lbm_set_reader_done_callback(void (*fptr)(lbm_cid)) {
   reader_done_callback = fptr;
 }
 
+lbm_cid lbm_get_current_cid(void) {
+  if (ctx_running)
+    return ctx_running->id;
+  else
+    return -1;
+}
+
 void done_reading(lbm_cid cid) {
   if (reader_done_callback != NULL) {
     reader_done_callback(cid);
@@ -689,6 +698,24 @@ static void advance_ctx(void) {
   }
 }
 
+bool lbm_unblock_ctx(lbm_cid cid, lbm_value result) {
+ eval_context_t *found = NULL;
+
+  found = lookup_ctx(&blocked, cid);
+
+  if (found == NULL)
+    return false;
+
+  drop_ctx(&blocked,found);
+  found->r = result;
+  enqueue_ctx(&queue,found);
+  return true;
+}
+
+void lbm_block_ctx_from_extension(void) {
+  blocking_extension = true;
+}
+
 lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
   eval_context_t *found = NULL;
 
@@ -1159,16 +1186,24 @@ static inline void eval_define(eval_context_t *ctx) {
   lbm_value rest_args = lbm_cdr(args);
   lbm_value val_exp = lbm_car(rest_args);
 
+  lbm_uint *sptr = lbm_stack_reserve(&ctx->K, 2);
+  if (!sptr) {
+    error_ctx(lbm_enc_sym(SYM_STACK_ERROR));
+    return;
+  }
+
   if (lbm_is_symbol(key) && lbm_is_symbol_nil(lbm_cdr(rest_args))) {
     lbm_uint sym_val = lbm_dec_sym(key);
 
+    sptr[0] = key;
+
     if ((sym_val >= VARIABLE_SYMBOLS_START) &&
         (sym_val <  VARIABLE_SYMBOLS_END)) {
-      CHECK_STACK(lbm_push_2(&ctx->K, key, SET_VARIABLE));
+      sptr[1] = SET_VARIABLE;
       ctx->curr_exp = val_exp;
       return;
     } else if (sym_val >= RUNTIME_SYMBOLS_START) {
-      CHECK_STACK(lbm_push_2(&ctx->K, key, SET_GLOBAL_ENV));
+      sptr[1] = SET_GLOBAL_ENV;
       ctx->curr_exp = val_exp;
       return;
     }
@@ -1183,7 +1218,14 @@ static inline void eval_progn(eval_context_t *ctx) {
   lbm_value env  = ctx->curr_env;
 
   if (lbm_is_list(exps)) {
-    CHECK_STACK(lbm_push_3(&ctx->K, env, lbm_cdr(exps), PROGN_REST));
+    lbm_uint *sptr = lbm_stack_reserve(&ctx->K, 3);
+    if (!sptr) {
+      error_ctx(lbm_enc_sym(SYM_STACK_ERROR));
+      return;
+    }
+    sptr[0] = env;
+    sptr[1] = lbm_cdr(exps);
+    sptr[2] = PROGN_REST;
     ctx->curr_exp = lbm_car(exps);
     ctx->curr_env = env;
   } else if (lbm_is_symbol_nil(exps)) {
@@ -1217,11 +1259,15 @@ static inline void eval_if(eval_context_t *ctx) {
   lbm_value then_branch = lbm_car(cddr);
   lbm_value else_branch = lbm_cadr(cddr);
 
-  CHECK_STACK(lbm_push_4(&ctx->K,
-                         else_branch,
-                         then_branch,
-                         ctx->curr_env,
-                         IF));
+  lbm_uint *sptr = lbm_stack_reserve(&ctx->K, 4);
+  if (!sptr) {
+    error_ctx(lbm_enc_sym(SYM_STACK_ERROR));
+    return;
+  }
+  sptr[0] = else_branch;
+  sptr[1] = then_branch;
+  sptr[2] = ctx->curr_env;
+  sptr[3] = IF;
   ctx->curr_exp = lbm_cadr(ctx->curr_exp);
 }
 
@@ -1254,8 +1300,16 @@ static inline void eval_let(eval_context_t *ctx) {
   lbm_value key0 = lbm_car(lbm_car(binds));
   lbm_value val0_exp = lbm_cadr(lbm_car(binds));
 
-  CHECK_STACK(lbm_push_5(&ctx->K, exp, lbm_cdr(binds), new_env,
-                         key0, BIND_TO_KEY_REST));
+  lbm_uint *sptr = lbm_stack_reserve(&ctx->K, 5);
+  if (!sptr) {
+    error_ctx(lbm_enc_sym(SYM_STACK_ERROR));
+    return;
+  }
+  sptr[0] = exp;
+  sptr[1] = lbm_cdr(binds);
+  sptr[2] = new_env;
+  sptr[3] = key0;
+  sptr[4] = BIND_TO_KEY_REST;
   ctx->curr_exp = val0_exp;
   ctx->curr_env = new_env;
   return;
@@ -1738,6 +1792,15 @@ static inline void cont_application(eval_context_t *ctx) {
         }
         lbm_stack_drop(&ctx->K, lbm_dec_u(count) + 1);
 
+        if (blocking_extension) {
+          blocking_extension = false;
+          ctx->timestamp = timestamp_us_callback();
+          ctx->sleep_us = 0;
+          ctx->app_cont = true;
+          enqueue_ctx(&blocked,ctx);
+          ctx_running = NULL;
+          break;
+        }
         ctx->app_cont = true;
         ctx->r = ext_res;
         break;
@@ -2311,11 +2374,15 @@ static inline void cont_application_start(eval_context_t *ctx) {
     lbm_value clo_env = lbm_car(cdddr_fun);
     lbm_value arg_env = (lbm_value)sptr[0];
     sptr[1] = exp;
-    CHECK_STACK(lbm_push_4(&ctx->K,
-                           clo_env,
-                           params,
-                           lbm_cdr(args),
-                           CLOSURE_ARGS));
+    lbm_value *reserved = lbm_stack_reserve(&ctx->K, 4);
+    if (!reserved) {
+      error_ctx(lbm_enc_sym(SYM_STACK_ERROR));
+      return;
+    }
+    reserved[0] = clo_env;
+    reserved[1] = params;
+    reserved[2] = lbm_cdr(args);
+    reserved[3] = CLOSURE_ARGS;
     ctx->curr_exp = lbm_car(args);
     ctx->curr_env = arg_env;
     ctx->app_cont = false;
@@ -2446,11 +2513,14 @@ static void evaluation_step(void){
      * At this point head can be a closure, fundamental, extension or a macro.
      * Anything else would be an error.
      */
-
-    CHECK_STACK(lbm_push_3(&ctx->K,
-                               ctx->curr_env,
-                               lbm_cdr(ctx->curr_exp),
-                               APPLICATION_START));
+    lbm_value *reserved = lbm_stack_reserve(&ctx->K, 3);
+    if (!reserved) {
+      error_ctx(lbm_enc_sym(SYM_STACK_ERROR));
+      return;
+    }
+    reserved[0] = ctx->curr_env;
+    reserved[1] = lbm_cdr(ctx->curr_exp);
+    reserved[2] = APPLICATION_START;
 
     ctx->curr_exp = head; // evaluate the function
     break;

src/stack.c

@@ -65,6 +65,16 @@ int lbm_stack_drop(lbm_stack_t *s, lbm_uint n) {
   return 1;
 }
 
+lbm_uint *lbm_stack_reserve(lbm_stack_t *s, lbm_uint n) {
+
+  if (s->sp + n >= s->size) {
+    return NULL;
+  }
+  lbm_uint *ptr = &s->data[s->sp];
+  s->sp += n;
+  return ptr;
+}
+
 int lbm_push(lbm_stack_t *s, lbm_uint val) {
   int res = 1;
   if (s->sp == s->size) {