diff --git a/benchmarks/bench_chibi/Makefile b/benchmarks/bench_chibi/Makefile
index a5489274..f2e2e8b4 100644
--- a/benchmarks/bench_chibi/Makefile
+++ b/benchmarks/bench_chibi/Makefile
@@ -129,7 +129,6 @@ LBMSRC = ../../src/env.c \
../../src/heap.c \
../../src/lbm_memory.c \
../../src/print.c \
- ../../src/qq_expand.c \
../../src/stack.c \
../../src/symrepr.c \
../../src/tokpar.c \
@@ -139,6 +138,7 @@ LBMSRC = ../../src/env.c \
../../src/lbm_custom_type.c \
../../src/lbm_channel.c \
../../src/lbm_flags.c \
+ ../../src/lbm_flat_value.c \
../../platform/chibios/src/platform_mutex.c
CSRC = $(ALLCSRC) \
diff --git a/benchmarks/bench_chibi/main.c b/benchmarks/bench_chibi/main.c
index 1800ea78..778da511 100644
--- a/benchmarks/bench_chibi/main.c
+++ b/benchmarks/bench_chibi/main.c
@@ -371,9 +371,9 @@ int main(void) {
lbm_get_heap_state(&heap_state);
chprintf(chp, "gc invocations: %d\r\n", heap_state.gc_num);
- chprintf(chp, "gc time avg: %f\r\n", (float)heap_state.gc_time_acc / (float)heap_state.gc_num);
- chprintf(chp, "gc min time: %u\r\n", heap_state.gc_min_duration);
- chprintf(chp, "gc max time: %u\r\n", heap_state.gc_max_duration);
+ chprintf(chp, "gc time avg: %f\r\n", 0.0);
+ chprintf(chp, "gc min time: %u\r\n", 0);
+ chprintf(chp, "gc max time: %u\r\n", 0);
chprintf(chp, "gc least free: %u\r\n", heap_state.gc_least_free);
}
} else {
diff --git a/doc/lbmref.md b/doc/lbmref.md
index 9502f3d5..b45331bb 100644
--- a/doc/lbmref.md
+++ b/doc/lbmref.md
@@ -1513,10 +1513,8 @@ atomic read-modify-write sequences to global data.
### spawn
Use `spawn` to launch a concurrent process. Spawn takes a closure and
-and arguments to pass to that closure as its arguments: `(spawn
-closure arg1 ... argN)`. Optionally you can provide a numerical first
-argument that specifies stack size that the runtime system should
-allocate to run the process in: `(spawn stack-size closure args1
+arguments to pass to that closure as its arguments. The form of a
+spawn expression is `(spawn opt-name opt-stack-size closure arg1
... argN)`.
Each process has a runtime-stack which is used for the evaluation of
@@ -1538,11 +1536,11 @@ fine with a lot less stack. You can find a good size by trial and error.
Use `spawn-trap` to spawn a child process and enable trapping of exit
conditions for that child. The form of a `spawn-trap` expression is
-`(spawn-trap closure arg1 .. argN)`. If the child process is
-terminated because of an error, a message is sent to the parent
-process of the form `(exit-error tid err-val)`. If the child process
-terminates successfully a message of the form `(exit-ok tid value)` is
-sent to the parent.
+`(spawn-trap opt-name opt-stack-size closure arg1 .. argN)`. If the
+child process is terminated because of an error, a message is sent to
+the parent process of the form `(exit-error tid err-val)`. If the
+child process terminates successfully a message of the form `(exit-ok
+tid value)` is sent to the parent.
Example:
```clj
@@ -1631,6 +1629,32 @@ Example where a process waits for an integer `?i`.
---
+### recv-to
+
+Like [recv](./lbmref.md#recv), `recv-to` is used to receive
+messages but `recv-to` takes an extra timeout argument.
+
+The form of an `recv-to` expression is
+```
+(recv-to timeout-secs
+ (pattern1 exp1)
+ ...
+ (patternN expN))
+```
+
+If no message is received before the timout, the message `timeout` is
+delivered to the waiting process. This `timeout` message can be handled
+in one of the receive patterns.
+
+Example
+```
+(recv-to 0.5
+ ( timeout (handle-timeout))
+ ( _ (do-something-else)))
+```
+
+---
+
### set-mailbox-size
Change the size of the mailbox in the current process.
diff --git a/include/eval_cps.h b/include/eval_cps.h
index 596f28ab..dbd99053 100644
--- a/include/eval_cps.h
+++ b/include/eval_cps.h
@@ -43,6 +43,12 @@ extern "C" {
/** The eval_context_t struct represents a lispbm process.
*
*/
+#define LBM_THREAD_STATE_READY (uint32_t)0
+#define LBM_THREAD_STATE_BLOCKED (uint32_t)1
+#define LBM_THREAD_STATE_TIMEOUT (uint32_t)2
+#define LBM_THREAD_STATE_SLEEPING (uint32_t)3
+#define LBM_THREAD_STATE_GC_BIT (uint32_t)(1 << 31)
+
typedef struct eval_context_s{
lbm_value program;
lbm_value curr_exp;
@@ -57,6 +63,8 @@ typedef struct eval_context_s{
lbm_stack_t K;
lbm_uint timestamp;
lbm_uint sleep_us;
+ uint32_t state;
+ char *name;
lbm_cid id;
lbm_cid parent;
lbm_uint wait_mask;
@@ -233,9 +241,13 @@ 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);
+/** Block a context from an extension with a timeout.
+ * \param s Timeout in seconds.
+ */
+void lbm_block_ctx_from_extension_timeout(float s);
+/** 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
@@ -265,13 +277,6 @@ void lbm_running_iterator(ctx_fun f, void*, void*);
* \param arg2 Same as above
*/
void lbm_blocked_iterator(ctx_fun f, void*, void*);
-/** Iterate over all done contexts and apply function on each context.
- *
- * \param f Function to apply to each context.
- * \param arg1 Pointer argument that can be used to convey information back to user.
- * \param arg2 Same as above
- */
-void lbm_sleeping_iterator(ctx_fun f, void *, void *);
/** toggle verbosity level of error messages
*/
void lbm_toggle_verbose(void);
diff --git a/include/heap.h b/include/heap.h
index 3d840876..f671971e 100644
--- a/include/heap.h
+++ b/include/heap.h
@@ -256,10 +256,6 @@ typedef struct {
lbm_uint gc_least_free; // The smallest length of the freelist.
lbm_uint gc_last_free; // Number of elements on the freelist
// after most recent GC.
-
- lbm_uint gc_time_acc;
- lbm_uint gc_min_duration;
- lbm_uint gc_max_duration;
} lbm_heap_state_t;
extern lbm_heap_state_t lbm_heap_state;
@@ -560,12 +556,9 @@ void lbm_nil_freelist(void);
int lbm_gc_mark_freelist(void);
/** Mark heap cells reachable from the lbm_value v.
*
- * \param m Number of Root nodes to start marking from.
- * \param ... list of root nodes.
* \return 1 on success and 0 if the stack used internally is full.
*/
-//int lbm_gc_mark_phase(lbm_value v);
-int lbm_gc_mark_phase(int num, ... );
+int lbm_gc_mark_phase(void);
/** Performs lbm_gc_mark_phase on all the values of an array.
*
* \param data Array of roots to traverse from.
@@ -598,6 +591,16 @@ int lbm_heap_allocate_array(lbm_value *res, lbm_uint size);
* \return 1 for success and 0 for failure.
*/
int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt);
+/** Get the size of an array value.
+ * \param arr lbm_value array to get size of.
+ * \return -1 for failure or length of array.
+ */
+lbm_int lbm_heap_array_get_size(lbm_value arr);
+/** Get a pointer to the data of an array.
+ * \param arr lbm_value array to get pointer from.
+ * \return NULL or valid pointer.
+ */
+uint8_t *lbm_heap_array_get_data(lbm_value arr);
/** Explicitly free an array.
* This function needs to be used with care and knowledge.
* \param arr Array value.
@@ -835,7 +838,7 @@ static inline bool lbm_is_macro(lbm_value exp) {
}
static inline bool lbm_is_match_binder(lbm_value exp) {
- return ((lbm_type_of(exp) == LBM_TYPE_CONS) &&
+ return (lbm_is_cons(exp) &&
(lbm_type_of(lbm_car(exp)) == LBM_TYPE_SYMBOL) &&
((lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_ANY)));
}
diff --git a/include/lbm_defines.h b/include/lbm_defines.h
index 2938aa6d..600ec979 100644
--- a/include/lbm_defines.h
+++ b/include/lbm_defines.h
@@ -37,7 +37,8 @@
#define LBM_TYPE_DOUBLE 0x78000000u
#define LBM_TYPE_ARRAY 0x80000000u
#define LBM_TYPE_CHANNEL 0x90000000u
-#define LBM_TYPE_CUSTOM 0xA0000000u
+#define LBM_TYPE_FLATVAL 0xA0000000u
+#define LBM_TYPE_CUSTOM 0xB0000000u
#define LBM_NON_CONS_POINTER_TYPE_LAST 0xBC000000u
#define LBM_POINTER_TYPE_LAST 0xBC000000u
@@ -67,8 +68,9 @@
#define LBM_TYPE_ARRAY (lbm_uint)0x5000000000000000
#define LBM_TYPE_CHANNEL (lbm_uint)0x7000000000000000
#define LBM_TYPE_CUSTOM (lbm_uint)0x8000000000000000
-#define LBM_NON_CONS_POINTER_TYPE_LAST (lbm_uint)0x8000000000000000
-#define LBM_POINTER_TYPE_LAST (lbm_uint)0x8000000000000000
+#define LBM_TYPE_FLATVAL (lbm_uint)0x9000000000000000
+#define LBM_NON_CONS_POINTER_TYPE_LAST (lbm_uint)0x9000000000000000
+#define LBM_POINTER_TYPE_LAST (lbm_uint)0x9000000000000000
#define LBM_CONTINUATION_INTERNAL (lbm_uint)0xF800000000000001
#define LBM_CONTINUATION_INTERNAL_TYPE (lbm_uint)0xF800000000000000
@@ -98,6 +100,7 @@
#define SYM_NIL 0x0
#define SYM_TRUE 0x2
#define SYM_DONTCARE 0x9
+#define SYM_TIMEOUT 0xA
// 0x20 - 0x2F are errors
#define SYM_RERROR 0x20 /* READ ERROR */
@@ -122,7 +125,8 @@
#define SYM_IND_F_TYPE 0x36
#define SYM_CHANNEL_TYPE 0x37
#define SYM_CUSTOM_TYPE 0x38
-#define TYPE_CLASSIFIER_ENDS 0x38
+#define SYM_FLATVAL_TYPE 0x39
+#define TYPE_CLASSIFIER_ENDS 0x39
#define SYM_NONSENSE 0x3A
#define SYM_NO_MATCH 0x40
@@ -143,6 +147,7 @@
#define SYM_TYPE_CHAR 0x5B
#define SYM_TYPE_BYTE 0x5C
#define SYM_TYPE_CHANNEL 0x5E
+#define SYM_TYPE_FLATVAL 0x5F
//Relevant for the tokenizer and reader
#define TOKENIZER_SYMBOLS_START 0x70
@@ -179,39 +184,43 @@
#define SYM_OR 0x107
#define SYM_MATCH 0x108
#define SYM_RECEIVE 0x109
-#define SYM_CALLCC 0x10A
-#define SYM_ATOMIC 0x10B
-#define SYM_MACRO 0x10C
-#define SYM_CONT 0x10D
-#define SYM_CLOSURE 0x10E
-#define SYM_COND 0x10F
-#define SYM_APP_CONT 0x110
-#define SYM_PROGN_VAR 0x111
-#define SYM_SETQ 0x112
-#define SYM_MOVE_TO_FLASH 0x113
-#define SPECIAL_FORMS_END 0x113
+#define SYM_RECEIVE_TIMEOUT 0x10A
+#define SYM_CALLCC 0x10B
+#define SYM_ATOMIC 0x10C
+#define SYM_MACRO 0x10D
+#define SYM_CONT 0x10E
+#define SYM_CLOSURE 0x10F
+#define SYM_COND 0x110
+#define SYM_APP_CONT 0x111
+#define SYM_PROGN_VAR 0x112
+#define SYM_SETQ 0x113
+#define SYM_MOVE_TO_FLASH 0x114
+#define SPECIAL_FORMS_END 0x114
// Apply funs:
// Get their arguments in evaluated form.
// Consecutive value symbols for lookup-application
-#define APPLY_FUNS_START 0x150
-#define SYM_SETVAR 0x150
-#define SYM_READ 0x151
-#define SYM_READ_PROGRAM 0x152
+#define APPLY_FUNS_START 0x150
+#define SYM_SETVAR 0x150
+#define SYM_READ 0x151
+#define SYM_READ_PROGRAM 0x152
#define SYM_READ_AND_EVAL_PROGRAM 0x153
-#define SYM_SPAWN 0x154
-#define SYM_SPAWN_TRAP 0x155
-#define SYM_YIELD 0x156
-#define SYM_WAIT 0x157
-#define SYM_EVAL 0x158
-#define SYM_EVAL_PROGRAM 0x159
-#define SYM_SEND 0x15A
-#define SYM_EXIT_OK 0x15B
-#define SYM_EXIT_ERROR 0x15C
-#define SYM_MAP 0x15D
-#define SYM_REVERSE 0x15E
-#define SYM_WAIT_FOR 0x15F
-#define APPLY_FUNS_END 0x15F
+#define SYM_SPAWN 0x154
+#define SYM_SPAWN_TRAP 0x155
+#define SYM_YIELD 0x156
+#define SYM_WAIT 0x157
+#define SYM_EVAL 0x158
+#define SYM_EVAL_PROGRAM 0x159
+#define SYM_SEND 0x15A
+#define SYM_EXIT_OK 0x15B
+#define SYM_EXIT_ERROR 0x15C
+#define SYM_MAP 0x15D
+#define SYM_REVERSE 0x15E
+#define SYM_WAIT_FOR 0x15F
+#define SYM_FLATTEN 0x160
+#define SYM_UNFLATTEN 0x161
+#define SYM_KILL 0x162
+#define APPLY_FUNS_END 0x162
#define FUNDAMENTALS_START 0x20E
#define SYM_ADD 0x20E
@@ -274,8 +283,6 @@
#define SYM_DROP 0x247
#define FUNDAMENTALS_END 0x247
-
-
#define SPECIAL_SYMBOLS_START 0
#define SPECIAL_SYMBOLS_END 0xFFFF
#define EXTENSION_SYMBOLS_START 0x10000
@@ -294,6 +301,7 @@
#define ENC_SYM_NIL ENC_SYM(SYM_NIL)
#define ENC_SYM_TRUE ENC_SYM(SYM_TRUE)
#define ENC_SYM_DONTCARE ENC_SYM(SYM_DONTCARE)
+#define ENC_SYM_TIMEOUT ENC_SYM(SYM_TIMEOUT)
#define ENC_SYM_RERROR ENC_SYM(SYM_RERROR)
#define ENC_SYM_TERROR ENC_SYM(SYM_TERROR)
@@ -315,6 +323,7 @@
#define ENC_SYM_IND_F_TYPE ENC_SYM(SYM_IND_F_TYPE)
#define ENC_SYM_CHANNEL_TYPE ENC_SYM(SYM_CHANNEL_TYPE)
#define ENC_SYM_CUSTOM_TYPE ENC_SYM(SYM_CUSTOM_TYPE)
+#define ENC_SYM_FLATVAL_TYPE ENC_SYM(SYM_FLATVAL_TYPE)
#define ENC_SYM_NONSENSE ENC_SYM(SYM_NONSENSE)
#define ENC_SYM_NO_MATCH ENC_SYM(SYM_NO_MATCH)
@@ -334,6 +343,7 @@
#define ENC_SYM_TYPE_CHAR ENC_SYM(SYM_TYPE_CHAR)
#define ENC_SYM_TYPE_BYTE ENC_SYM(SYM_TYPE_BYTE)
#define ENC_SYM_TYPE_CHANNEL ENC_SYM(SYM_TYPE_CHANNEL)
+#define ENC_SYM_TYPE_FLATVAL ENC_SYM(SYM_TYPE_FLATVAL)
#define ENC_SYM_OPENPAR ENC_SYM(SYM_OPENPAR)
#define ENC_SYM_CLOSEPAR ENC_SYM(SYM_CLOSEPAR)
@@ -361,6 +371,7 @@
#define ENC_SYM_OR ENC_SYM(SYM_OR)
#define ENC_SYM_MATCH ENC_SYM(SYM_MATCH)
#define ENC_SYM_RECEIVE ENC_SYM(SYM_RECEIVE)
+#define ENC_SYM_RECEIVE_TIMEOUT ENC_SYM(SYM_RECEIVE_TIMEOUT)
#define ENC_SYM_CALLCC ENC_SYM(SYM_CALLCC)
#define ENC_SYM_ATOMIC ENC_SYM(SYM_ATOMIC)
#define ENC_SYM_MACRO ENC_SYM(SYM_MACRO)
@@ -373,25 +384,25 @@
#define ENC_SYM_MOVE_TO_FLASH ENC_SYM(SYM_MOVE_TO_FLASH)
#define ENC_SYM_IN_ENV ENC_SYM(SYM_IN_ENV)
-#define ENC_SYM_SETVAR ENC_SYM(SYM_SETVAR)
-#define ENC_SYM_READ ENC_SYM(SYM_READ)
-#define ENC_SYM_READ_PROGRAM ENC_SYM(SYM_READ_PROGRAM)
+#define ENC_SYM_SETVAR ENC_SYM(SYM_SETVAR)
+#define ENC_SYM_READ ENC_SYM(SYM_READ)
+#define ENC_SYM_READ_PROGRAM ENC_SYM(SYM_READ_PROGRAM)
#define ENC_SYM_READ_AND_EVAL_PROGRAM ENC_SYM(SYM_READ_AND_EVAL_PROGRAM)
-#define ENC_SYM_SPAWN ENC_SYM(SYM_SPAWN)
-#define ENC_SYM_SPAWN_TRAP ENC_SYM(SYM_SPAWN_TRAP)
-#define ENC_SYM_YIELD ENC_SYM(SYM_YIELD)
-#define ENC_SYM_WAIT ENC_SYM(SYM_WAIT)
-#define ENC_SYM_EVAL ENC_SYM(SYM_EVAL)
-#define ENC_SYM_EVAL_PROGRAM ENC_SYM(SYM_EVAL_PROGRAM)
-#define ENC_SYM_SEND ENC_SYM(SYM_SEND)
-#define ENC_SYM_EXIT_OK ENC_SYM(SYM_EXIT_OK)
-#define ENC_SYM_EXIT_ERROR ENC_SYM(SYM_EXIT_ERROR)
-#define ENC_SYM_MAP ENC_SYM(SYM_MAP)
-#define ENC_SYM_REVERSE ENC_SYM(SYM_REVERSE)
-#define ENC_SYM_WAIT_FOR ENC_SYM(SYM_WAIT_FOR)
-#define ENC_SYM_GET_ENV ENC_SYM(SYM_GET_ENV)
-#define ENC_SYM_SET_ENV ENC_SYM(SYM_SET_ENV)
-
+#define ENC_SYM_SPAWN ENC_SYM(SYM_SPAWN)
+#define ENC_SYM_SPAWN_TRAP ENC_SYM(SYM_SPAWN_TRAP)
+#define ENC_SYM_YIELD ENC_SYM(SYM_YIELD)
+#define ENC_SYM_WAIT ENC_SYM(SYM_WAIT)
+#define ENC_SYM_EVAL ENC_SYM(SYM_EVAL)
+#define ENC_SYM_EVAL_PROGRAM ENC_SYM(SYM_EVAL_PROGRAM)
+#define ENC_SYM_SEND ENC_SYM(SYM_SEND)
+#define ENC_SYM_EXIT_OK ENC_SYM(SYM_EXIT_OK)
+#define ENC_SYM_EXIT_ERROR ENC_SYM(SYM_EXIT_ERROR)
+#define ENC_SYM_MAP ENC_SYM(SYM_MAP)
+#define ENC_SYM_REVERSE ENC_SYM(SYM_REVERSE)
+#define ENC_SYM_WAIT_FOR ENC_SYM(SYM_WAIT_FOR)
+#define ENC_SYM_FLATTEN ENC_SYM(SYM_FLATTEN)
+#define ENC_SYM_UNFLATTEN ENC_SYM(SYM_UNFLATTEN)
+#define ENC_SYM_KILL ENC_SYM(SYM_KILL)
#define ENC_SYM_ADD ENC_SYM(SYM_ADD)
#define ENC_SYM_SUB ENC_SYM(SYM_SUB)
diff --git a/include/lbm_flat_value.h b/include/lbm_flat_value.h
index 19733d78..1544cd01 100644
--- a/include/lbm_flat_value.h
+++ b/include/lbm_flat_value.h
@@ -27,25 +27,40 @@ typedef struct {
lbm_uint buf_size;
lbm_uint buf_pos;
} lbm_flat_value_t;
- // Arity
+ // Arity
#define S_CONS 0x1 // 2 car, cdr
#define S_SYM_VALUE 0x2 // 1 value
-#define S_BYTE_VALUE 0x3
-#define S_I_VALUE 0x4
-#define S_U_VALUE 0x5
-#define S_I32_VALUE 0x6
-#define S_U32_VALUE 0x7
-#define S_FLOAT_VALUE 0x8
-#define S_I64_VALUE 0x9
-#define S_U64_VALUE 0xA
-#define S_DOUBLE_VALUE 0xB
-#define S_LBM_ARRAY 0xC // 3 size, type, ptr
+#define S_SYM_STRING 0x3
+#define S_BYTE_VALUE 0x4
+#define S_I_VALUE 0x5
+#define S_U_VALUE 0x6
+#define S_I32_VALUE 0x7
+#define S_U32_VALUE 0x8
+#define S_FLOAT_VALUE 0x9
+#define S_I64_VALUE 0xA
+#define S_U64_VALUE 0xB
+#define S_DOUBLE_VALUE 0xC
+#define S_LBM_ARRAY 0xD
+
+// Maximum number of recursive calls
+#define FLATTEN_VALUE_MAXIMUM_DEPTH 2000
+
+#define FLATTEN_VALUE_OK 0
+#define FLATTEN_VALUE_ERROR_CANNOT_BE_FLATTENED -1
+#define FLATTEN_VALUE_ERROR_BUFFER_TOO_SMALL -2
+#define FLATTEN_VALUE_ERROR_ARRAY -3
+#define FLATTEN_VALUE_ERROR_CIRCULAR -4
+#define FLATTEN_VALUE_ERROR_MAXIMUM_DEPTH -5
+#define FLATTEN_VALUE_ERROR_NOT_ENOUGH_MEMORY -6
+#define FLATTEN_VALUE_ERROR_FATAL -7
bool lbm_start_flatten(lbm_flat_value_t *v, size_t buffer_size);
bool lbm_finish_flatten(lbm_flat_value_t *v);
bool f_cons(lbm_flat_value_t *v);
bool f_sym(lbm_flat_value_t *v, lbm_uint sym);
+bool f_sym_string(lbm_flat_value_t *v, lbm_uint sym);
bool f_i(lbm_flat_value_t *v, lbm_int i);
+bool f_u(lbm_flat_value_t *v, lbm_uint u);
bool f_b(lbm_flat_value_t *v, uint8_t b);
bool f_i32(lbm_flat_value_t *v, int32_t w);
bool f_u32(lbm_flat_value_t *v, uint32_t w);
@@ -53,12 +68,14 @@ bool f_float(lbm_flat_value_t *v, float f);
bool f_i64(lbm_flat_value_t *v, int64_t w);
bool f_u64(lbm_flat_value_t *v, uint64_t w);
bool f_lbm_array(lbm_flat_value_t *v, uint32_t num_bytes, uint8_t *data);
+lbm_value flatten_value(lbm_value v);
+void lbm_set_max_flatten_depth(int depth);
/** Unflatten a flat value stored in an lbm_memory array onto the heap
- *
- * \param v Flat value to unflatten.
- * \param res Pointer to where the result lbm_value should be stored.
+ *
+ * \param v Flat value to unflatten.
+ * \param res Pointer to where the result lbm_value should be stored.
* \return True on success and false otherwise.
- */
+ */
bool lbm_unflatten_value(lbm_flat_value_t *v, lbm_value *res);
#endif
diff --git a/include/lbm_prof.h b/include/lbm_prof.h
new file mode 100644
index 00000000..fc16c6b2
--- /dev/null
+++ b/include/lbm_prof.h
@@ -0,0 +1,43 @@
+/*
+ Copyright 2023 Joel Svensson svenssonjoel@yahoo.se
+
+ 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
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+*/
+
+#ifndef LBM_PROF_H_
+#define LBM_PROF_H_
+
+#include "heap.h"
+#include "eval_cps.h"
+
+#define LBM_PROF_MAX_NAME_SIZE 20
+
+typedef struct {
+ lbm_cid cid;
+ bool has_name;
+ char name[LBM_PROF_MAX_NAME_SIZE];
+ lbm_uint count;
+ lbm_uint gc_count;
+} lbm_prof_t;
+
+bool lbm_prof_init(void (*usleep_fptr)(uint32_t),
+ lbm_uint sample_interval,
+ lbm_prof_t *prof_data_buf,
+ lbm_uint prof_data_buf_num);
+lbm_uint lbm_prof_get_num_samples(void);
+lbm_uint lbm_prof_get_num_sleep_samples(void);
+lbm_uint lbm_prof_stop(void);
+bool lbm_prof_is_running(void);
+void lbm_prof_run(void);
+#endif
diff --git a/include/lbm_version.h b/include/lbm_version.h
index a777b1fc..3e6b163f 100644
--- a/include/lbm_version.h
+++ b/include/lbm_version.h
@@ -27,12 +27,24 @@ extern "C" {
/** LBM major version */
#define LBM_MAJOR_VERSION 0
/** LBM minor version */
-#define LBM_MINOR_VERSION 15
+#define LBM_MINOR_VERSION 17
/** LBM patch revision */
#define LBM_PATCH_VERSION 0
/*! \page changelog Changelog
+JUL 29 2023: Version 0.17.0
+ - Addition of a timeout functionality to blocked contexts.
+ - recv-to special form added for receives with a timeout.
+ - block_context_from_extension_timeout function added.
+ - Unified sleeping and blocked queues.
+ - Added a new optional argument to spawn and spawn-trap that can be used to provide a name for the thread.
+ - Added profiler functionality.
+
+JUL 16 2023: Version 0.16.0
+ - Addition of flat values as a type in the language.
+ - Addition of kill function for termination of threads.
+
JUN 29 2023: version 0.15.0
- Bug fix in lift_array_flash.
- Bug fix in map.
diff --git a/include/symrepr.h b/include/symrepr.h
index c886924e..4174f371 100644
--- a/include/symrepr.h
+++ b/include/symrepr.h
@@ -1,4 +1,4 @@
-/*
+ /*
Copyright 2018, 2021, 2022 Joel Svensson svenssonjoel@yahoo.se
2022 Benjamin Vedder
diff --git a/lispbm.mk b/lispbm.mk
index 63c442e6..9554df0a 100644
--- a/lispbm.mk
+++ b/lispbm.mk
@@ -17,6 +17,7 @@ LISPBM_SRC = $(LISPBM)/src/env.c \
$(LISPBM)/src/lbm_channel.c \
$(LISPBM)/src/lbm_flat_value.c\
$(LISPBM)/src/lbm_flags.c\
+ $(LISPBM)/src/lbm_prof.c\
$(LISPBM)/src/extensions/array_extensions.c \
$(LISPBM)/src/extensions/string_extensions.c \
$(LISPBM)/src/extensions/math_extensions.c \
diff --git a/repl/repl.c b/repl/repl.c
index 20b6df04..da0f1914 100644
--- a/repl/repl.c
+++ b/repl/repl.c
@@ -28,6 +28,7 @@
#include "lispbm.h"
#include "lbm_flat_value.h"
+#include "lbm_prof.h"
#include "extensions/array_extensions.h"
#include "extensions/string_extensions.h"
#include "extensions/math_extensions.h"
@@ -45,12 +46,14 @@
#define WAIT_TIMEOUT 2500
#define STR_SIZE 1024
#define CONSTANT_MEMORY_SIZE 32*1024
+#define PROF_DATA_NUM 100
lbm_uint gc_stack_storage[GC_STACK_SIZE];
lbm_uint print_stack_storage[PRINT_STACK_SIZE];
extension_fptr extension_storage[EXTENSION_STORAGE_SIZE];
lbm_value variable_storage[VARIABLE_STORAGE_SIZE];
lbm_uint constants_memory[CONSTANT_MEMORY_SIZE];
+lbm_prof_t prof_data[100];
bool const_heap_write(lbm_uint ix, lbm_uint w) {
if (ix >= CONSTANT_MEMORY_SIZE) return false;
@@ -174,6 +177,11 @@ void *eval_thd_wrapper(void *v) {
return NULL;
}
+void *prof_thd_wrapper(void *v) {
+ lbm_prof_run();
+ return NULL;
+}
+
void done_callback(eval_context_t *ctx) {
erase();
@@ -490,7 +498,7 @@ int main(int argc, char **argv) {
int res = 0;
pthread_t lispbm_thd;
-
+
lbm_heap_state_t heap_state;
unsigned int heap_size = 2048;
lbm_cons_t *heap_storage = NULL;
@@ -589,12 +597,6 @@ int main(int argc, char **argv) {
else
printf("Error adding extension.\n");
- res = lbm_add_extension("unflatten", ext_unflatten);
- if (res)
- printf("Extension added.\n");
- else
- printf("Error adding extension.\n");
-
res = lbm_add_extension("trigger", ext_trigger);
if (res)
printf("Extension added.\n");
@@ -644,7 +646,44 @@ int main(int argc, char **argv) {
printf("Symbol table size FLASH: %"PRI_UINT" Bytes\n", lbm_get_symbol_table_size_flash());
printf("Symbol names size FLASH: %"PRI_UINT" Bytes\n", lbm_get_symbol_table_size_names_flash());
free(str);
- } else if (strncmp(str, ":env", 4) == 0) {
+ } else if (strncmp(str, ":prof start", 11) == 0) {
+ lbm_prof_init(sleep_callback,
+ 200,
+ prof_data,
+ PROF_DATA_NUM);
+ pthread_t prof_thd; // just forget this id.
+ if (pthread_create(&prof_thd, NULL, prof_thd_wrapper, NULL)) {
+ printf("Error creating profiler thread\n");
+ free(str);
+ continue;
+ }
+ printf("Profiler started\n");
+ free(str);
+ } else if (strncmp(str, ":prof stop", 10) == 0) {
+ printf("Profiler stopped. Issue command ':prof report' for statistics\n.");
+ lbm_prof_stop();
+ free(str);
+ } else if (strncmp(str, ":prof report", 12) == 0) {
+ lbm_uint num_sleep = lbm_prof_get_num_sleep_samples();
+ lbm_uint tot_samples = lbm_prof_get_num_samples();
+ lbm_uint tot_gc = 0;
+ printf("CID\tName\tSamples\t%%Load\t%%GC\n");
+ for (int i = 0; i < PROF_DATA_NUM; i ++) {
+ if (prof_data[i].cid == -1) break;
+ tot_gc += prof_data[i].gc_count;
+ printf("%d\t%s\t%u\t%f\t%f\n",
+ prof_data[i].cid,
+ prof_data[i].name,
+ prof_data[i].count,
+ 100.0 * ((float)prof_data[i].count) / (float) tot_samples,
+ 100.0 * ((float)prof_data[i].gc_count) / (float)prof_data[i].count);
+ }
+ printf("\n");
+ printf("GC:\t%u\t%f%%\n", tot_gc, 100.0 * (float)tot_gc/(float)tot_samples);
+ printf("sleep:\t%u\t%f%%\n", num_sleep, 100.0 * (float)num_sleep/(float)tot_samples);
+ printf("total:\t%u samples\n", tot_samples);
+ free(str);
+ } else if (strncmp(str, ":env", 4) == 0) {
lbm_value curr = *lbm_get_env_ptr();
printf("Environment:\r\n");
while (lbm_type_of(curr) == LBM_TYPE_CONS) {
@@ -701,8 +740,6 @@ int main(int argc, char **argv) {
lbm_running_iterator(print_ctx_info, NULL, NULL);
printf("****** Blocked contexts ******\n");
lbm_blocked_iterator(print_ctx_info, NULL, NULL);
- printf("****** Sleeping contexts *****\n");
- lbm_sleeping_iterator(print_ctx_info, NULL, NULL);
free(str);
} else if (n >= 5 && strncmp(str, ":quit", 5) == 0) {
free(str);
diff --git a/src/eval_cps.c b/src/eval_cps.c
index e6484185..16df7312 100644
--- a/src/eval_cps.c
+++ b/src/eval_cps.c
@@ -42,6 +42,8 @@
static jmp_buf error_jmp_buf;
+#define S_TO_US(X) (lbm_uint)((X) * 1000000)
+
#define DEC_CONTINUATION(x) (((x) & ~LBM_CONTINUATION_INTERNAL) >> LBM_ADDRESS_SHIFT)
#define IS_CONTINUATION(x) (((x) & LBM_CONTINUATION_INTERNAL) == LBM_CONTINUATION_INTERNAL)
#define CONTINUATION(x) (((x) << LBM_ADDRESS_SHIFT) | LBM_CONTINUATION_INTERNAL)
@@ -89,7 +91,8 @@ static jmp_buf error_jmp_buf;
#define QQ_APPEND CONTINUATION(40)
#define QQ_EXPAND_LIST CONTINUATION(41)
#define QQ_LIST CONTINUATION(42)
-#define NUM_CONTINUATIONS 43
+#define KILL CONTINUATION(43)
+#define NUM_CONTINUATIONS 44
#define FM_NEED_GC -1
#define FM_NO_MATCH -2
@@ -116,32 +119,7 @@ const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash
const char* lbm_error_str_flash_error = "Error writing to flash";
const char* lbm_error_str_flash_full = "Flash memory is full";
-#ifdef LBM_ALWAYS_GC
-#define WITH_GC(y, x) \
- gc(); \
- (y) = (x); \
- if (lbm_is_symbol_merror((y))) { \
- gc(); \
- (y) = (x); \
- if (lbm_is_symbol_merror((y))) { \
- error_ctx(ENC_SYM_MERROR); \
- } \
- /* continue executing statements below */ \
- }
-#define WITH_GC_RMBR(y, x, n, ...) \
- lbm_gc_mark_phase((n), __VA_ARGS__); \
- gc(); \
- (y) = (x); \
- if (lbm_is_symbol_merror((y))) { \
- lbm_gc_mark_phase((n), __VA_ARGS__); \
- gc(); \
- (y) = (x); \
- if (lbm_is_symbol_merror((y))) { \
- error_ctx(ENC_SYM_MERROR); \
- } \
- /* continue executing statements below */ \
- }
-#else
+
#define WITH_GC(y, x) \
(y) = (x); \
if (lbm_is_symbol_merror((y))) { \
@@ -152,10 +130,11 @@ const char* lbm_error_str_flash_full = "Flash memory is full";
} \
/* continue executing statements below */ \
}
-#define WITH_GC_RMBR(y, x, n, ...) \
+#define WITH_GC_RMBR_1(y, x, r) \
(y) = (x); \
if (lbm_is_symbol_merror((y))) { \
- lbm_gc_mark_phase((n), __VA_ARGS__); \
+ add_roots_1(r); \
+ lbm_gc_mark_phase(); \
gc(); \
(y) = (x); \
if (lbm_is_symbol_merror((y))) { \
@@ -163,7 +142,6 @@ const char* lbm_error_str_flash_full = "Flash memory is full";
} \
/* continue executing statements below */ \
}
-#endif
typedef struct {
eval_context_t *first;
@@ -173,6 +151,7 @@ typedef struct {
static int gc(void);
void error_ctx(lbm_value);
static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
+static bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);
// The currently executing context.
eval_context_t *ctx_running = NULL;
@@ -182,15 +161,21 @@ void lbm_request_gc(void) {
gc_requested = true;
}
-#define DEFAULT_SLEEP_US 1000
+/*
+ On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
+ resolution of the timer used for sleep operations. If this is set
+ to 10KHz the resolution is 100us.
+
+ The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
+ can be safely specified in a timeout directive (wonder if that
+ means sleep-period). The timedelta is set to 2.
+
+ If I have understood these correctly it means that the minimum
+ sleep duration possible is 2 * 100us = 200us.
+*/
#define EVAL_CPS_DEFAULT_STACK_SIZE 256
-
-/* 768 us -> ~128000 "ticks" at 168MHz I assume this means also roughly 128000 instructions */
-#define EVAL_CPS_QUANTA_US 768
-#define EVAL_CPS_WAIT_US 1536
#define EVAL_CPS_MIN_SLEEP 200
-
#define EVAL_STEPS_QUOTA 10
static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA;
@@ -333,23 +318,13 @@ static bool lbm_event_pop(lbm_event_t *event) {
return true;
}
-/*
- On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
- resolution of the timer used for sleep operations. If this is set
- to 10KHz the resolution is 100us.
-
- The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
- can be safely specified in a timeout directive (wonder if that
- means sleep-period). The timedelta is set to 2.
-
- If I have understood these correctly it means that the minimum
- sleep duration possible is 2 * 100us = 200us.
-*/
-
static bool eval_running = false;
static volatile bool blocking_extension = false;
-mutex_t blocking_extension_mutex;
-bool blocking_extension_mutex_initialized = false;
+static mutex_t blocking_extension_mutex;
+static bool blocking_extension_mutex_initialized = false;
+static lbm_uint blocking_extension_timeout_us = 0;
+static bool blocking_extension_timeout = false;
+
static uint32_t is_atomic = 0;
static volatile uint32_t wait_for = 0; // wake-up mask
@@ -359,7 +334,6 @@ void lbm_trigger_flags(uint32_t wait_for_flags) {
/* Process queues */
static eval_context_queue_t blocked = {NULL, NULL};
-static eval_context_queue_t sleeping = {NULL, NULL};
static eval_context_queue_t queue = {NULL, NULL};
/* one mutex for all queue operations */
@@ -392,15 +366,26 @@ eval_context_t *lbm_get_current_context(void) {
/****************************************************/
/* Utilities used locally in this file */
-static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
- #ifdef LBM_ALWAYS_GC
- lbm_gc_mark_phase(3, head, tail,remember);
- gc();
- #endif
+static void add_roots_1(lbm_value r1) {
+ lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r1;
+}
+static void add_roots_2(lbm_value r1, lbm_value r2) {
+ lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r1;
+ lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r2;
+}
+
+static void add_roots_3(lbm_value r1, lbm_value r2, lbm_value r3) {
+ lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r1;
+ lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r2;
+ lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r3;
+}
+
+static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
if (lbm_is_symbol_merror(res)) {
- lbm_gc_mark_phase(3, head, tail,remember);
+ add_roots_3(head, tail, remember);
+ lbm_gc_mark_phase();
gc();
res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
if (lbm_is_symbol_merror(res)) {
@@ -588,9 +573,6 @@ static lbm_value get_cddr(lbm_value a) {
static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {
- #ifdef LBM_ALWAYS_GC
- gc();
- #endif
if (lbm_heap_num_free() < 4) {
gc();
@@ -629,9 +611,6 @@ static void extract_closure(lbm_value closure, lbm_value *res) {
}
static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
- #ifdef LBM_ALWAYS_GC
- gc();
- #endif
lbm_value res;
res = fundamental_table[fundamental](args, arg_count, ctx);
if (lbm_is_error(res)) {
@@ -648,9 +627,12 @@ static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg
ctx->r = res;
}
-static void block_current_ctx(lbm_uint sleep_us, uint32_t wait_mask, bool do_cont) {
+// block_current_ctx blocks a context until it is
+// woken up externally of a timeout period of time passes.
+static void block_current_ctx(uint32_t state, lbm_uint sleep_us, uint32_t wait_mask, bool do_cont) {
ctx_running->timestamp = timestamp_us_callback();
ctx_running->sleep_us = sleep_us;
+ ctx_running->state = state;
ctx_running->wait_mask = wait_mask;
ctx_running->app_cont = do_cont;
enqueue_ctx(&blocked, ctx_running);
@@ -830,12 +812,6 @@ void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
mutex_unlock(&qmutex);
}
-void lbm_sleeping_iterator(ctx_fun f, void *arg1, void *arg2){
- mutex_lock(&qmutex);
- queue_iterator_nm(&sleeping, f, arg1, arg2);
- mutex_unlock(&qmutex);
-}
-
static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
if (q->last == NULL) {
ctx->prev = NULL;
@@ -856,33 +832,6 @@ static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
mutex_unlock(&qmutex);
}
-static eval_context_t *enqueue_dequeue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
- mutex_lock(&qmutex);
- if (q->last == NULL) { // queue is empty, dequeue the enqueue
- mutex_unlock(&qmutex);
- return ctx;
- }
-
- eval_context_t *res = q->first;
-
- if (q->first == q->last) { // nothing in q or 1 thing
- q->first = ctx;
- q->last = ctx;
- } else {
- q->first = q->first->next;
- q->first->prev = NULL;
- if (ctx != NULL) {
- q->last->next = ctx;
- ctx->prev = q->last;
- q->last = ctx;
- }
- }
- res->prev = NULL;
- res->next = NULL;
- mutex_unlock(&qmutex);
- return res;
-}
-
static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
eval_context_t *curr;
curr = q->first;
@@ -945,6 +894,9 @@ static void finish_ctx(void) {
/* Drop the continuation stack immediately to free up lbm_memory */
lbm_stack_free(&ctx_running->K);
ctx_done_callback(ctx_running);
+ if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->name)) {
+ lbm_free(ctx_running->name);
+ }
if (lbm_memory_ptr_inside((lbm_uint*)ctx_running->error_reason)) {
lbm_memory_free((lbm_uint*)ctx_running->error_reason);
}
@@ -968,7 +920,6 @@ bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
exists = false;
lbm_blocked_iterator(context_exists, &cid, &exists);
lbm_running_iterator(context_exists, &cid, &exists);
- lbm_sleeping_iterator(context_exists, &cid, &exists);
if (ctx_running &&
ctx_running->id == cid) {
@@ -1044,11 +995,27 @@ static void ok_ctx(void) {
finish_ctx();
}
-static eval_context_t *dequeue_ctx(eval_context_queue_t *q, uint32_t *us) {
- lbm_uint min_us = DEFAULT_SLEEP_US;
- lbm_uint t_now;
+static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
+ if (q->last == NULL) {
+ return NULL;
+ }
+ // q->first should only be NULL if q->last is.
+ eval_context_t *res = q->first;
- mutex_lock(&qmutex);
+ if (q->first == q->last) { // One thing in queue
+ q->first = NULL;
+ q->last = NULL;
+ } else {
+ q->first = q->first->next;
+ q->first->prev = NULL;
+ }
+ res->prev = NULL;
+ res->next = NULL;
+ return res;
+}
+
+static void wake_up_ctxs_nm(void) {
+ lbm_uint t_now;
if (timestamp_us_callback) {
t_now = timestamp_us_callback();
@@ -1056,95 +1023,91 @@ static eval_context_t *dequeue_ctx(eval_context_queue_t *q, uint32_t *us) {
t_now = 0;
}
- eval_context_t *curr = q->first; //ctx_queue;
+ eval_context_queue_t *q = &blocked;
+ eval_context_t *curr = q->first;
while (curr != NULL) {
lbm_uint t_diff;
- if ( curr->timestamp > t_now) {
- /* There was an overflow on the counter */
- #ifndef LBM64
- t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
- #else
- t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
- #endif
- } else {
- t_diff = t_now - curr->timestamp;
- }
-
- if (t_diff >= curr->sleep_us) {
- eval_context_t *result = curr;
- if (curr == q->last) {
- if (curr->prev) {
- q->last = curr->prev;
- q->last->next = NULL;
- } else {
- q->first = NULL;
- q->last = NULL;
- }
- } else if (curr->prev == NULL) {
- q->first = curr->next;
- if (q->first) {
- q->first->prev = NULL;
- }
+ eval_context_t *next = curr->next;
+ if (curr->state != LBM_THREAD_STATE_BLOCKED) {
+ if ( curr->timestamp > t_now) {
+ /* There was an overflow on the counter */
+#ifndef LBM64
+ t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
+#else
+ t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
+#endif
} else {
- curr->prev->next = curr->next;
- if (curr->next) {
- curr->next->prev = curr->prev;
- }
+ t_diff = t_now - curr->timestamp;
+ }
+
+ if (t_diff >= curr->sleep_us) {
+ eval_context_t *wake_ctx = curr;
+ if (curr == q->last) {
+ if (curr->prev) {
+ q->last = curr->prev;
+ q->last->next = NULL;
+ } else {
+ q->first = NULL;
+ q->last = NULL;
+ }
+ } else if (curr->prev == NULL) {
+ q->first = curr->next;
+ q->first->prev = NULL;
+ } else {
+ curr->prev->next = curr->next;
+ if (curr->next) {
+ curr->next->prev = curr->prev;
+ }
+ }
+ wake_ctx->next = NULL;
+ wake_ctx->prev = NULL;
+ if (curr->state == LBM_THREAD_STATE_TIMEOUT) {
+ mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT);
+ wake_ctx->r = ENC_SYM_TIMEOUT;
+ }
+ wake_ctx->state = LBM_THREAD_STATE_READY;
+ enqueue_ctx_nm(&queue, wake_ctx);
}
- mutex_unlock(&qmutex);
- return result;
}
- if (min_us > t_diff) min_us = t_diff;
- curr = curr->next;
+ curr = next;
}
- /* ChibiOS does not like a sleep time of 0 */
- /* TODO: Make sure that does not happen. */
- *us = EVAL_CPS_MIN_SLEEP;
- mutex_unlock(&qmutex);
- return NULL;
}
static void yield_ctx(lbm_uint sleep_us) {
if (timestamp_us_callback) {
ctx_running->timestamp = timestamp_us_callback();
ctx_running->sleep_us = sleep_us;
+ ctx_running->state = LBM_THREAD_STATE_SLEEPING;
} else {
ctx_running->timestamp = 0;
ctx_running->sleep_us = 0;
+ ctx_running->state = LBM_THREAD_STATE_SLEEPING;
}
ctx_running->r = ENC_SYM_TRUE;
ctx_running->app_cont = true;
- enqueue_ctx(&sleeping,ctx_running);
+ enqueue_ctx(&blocked,ctx_running);
ctx_running = NULL;
}
-static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags) {
+static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {
if (!lbm_is_cons(program)) return -1;
eval_context_t *ctx = NULL;
-#ifdef LBM_ALWAYS_GC
- lbm_gc_mark_phase(2, program, env);
- gc();
-#endif
-
ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
if (ctx == NULL) {
- lbm_gc_mark_phase(2, program, env);
+ add_roots_2(program, env);
+ lbm_gc_mark_phase();
gc();
ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
}
if (ctx == NULL) return -1;
-#ifdef LBM_ALWAYS_GC
- lbm_gc_mark_phase(2, program, env);
- gc();
-#endif
-
if (!lbm_stack_allocate(&ctx->K, stack_size)) {
- lbm_gc_mark_phase(2, program, env);
+ add_roots_2(program, env);
+ lbm_gc_mark_phase();
gc();
if (!lbm_stack_allocate(&ctx->K, stack_size)) {
lbm_memory_free((lbm_uint*)ctx);
@@ -1152,15 +1115,11 @@ static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint
}
}
-#ifdef LBM_ALWAYS_GC
- lbm_gc_mark_phase(2, program, env);
- gc();
-#endif
-
lbm_value *mailbox = NULL;
mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
if (mailbox == NULL) {
- lbm_gc_mark_phase(2, program, env);
+ add_roots_2(program, env);
+ lbm_gc_mark_phase();
gc();
mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
}
@@ -1170,6 +1129,27 @@ static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint
return -1;
}
+ // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
+ if (name) {
+ lbm_uint name_len = strlen(name) + 1;
+ ctx->name = lbm_malloc(strlen(name) + 1);
+ if (ctx->name == NULL) {
+ add_roots_2(program, env);
+ lbm_gc_mark_phase();
+ gc();
+ ctx->name = lbm_malloc(strlen(name) + 1);
+ }
+ if (ctx->name == NULL) {
+ lbm_stack_free(&ctx->K);
+ lbm_memory_free((lbm_uint*)mailbox);
+ lbm_memory_free((lbm_uint*)ctx);
+ return -1;
+ }
+ memcpy(ctx->name, name, name_len+1);
+ } else {
+ ctx->name = NULL;
+ }
+
lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);
ctx->program = lbm_cdr(program);
@@ -1184,6 +1164,7 @@ static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint
ctx->app_cont = false;
ctx->timestamp = 0;
ctx->sleep_us = 0;
+ ctx->state = LBM_THREAD_STATE_READY;
ctx->prev = NULL;
ctx->next = NULL;
@@ -1212,14 +1193,12 @@ lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size) {
env,
stack_size,
-1,
- EVAL_CPS_CONTEXT_FLAG_NOTHING);
+ EVAL_CPS_CONTEXT_FLAG_NOTHING,
+ NULL);
}
bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {
-#ifdef LBM_ALWAYS_GC
- gc();
-#endif
lbm_value *mailbox = NULL;
mailbox = (lbm_value*)lbm_memory_allocate(new_size);
if (mailbox == NULL) {
@@ -1300,13 +1279,23 @@ bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
return r;
}
+void lbm_block_ctx_from_extension_timeout(float s) {
+ mutex_lock(&blocking_extension_mutex);
+ blocking_extension = true;
+ blocking_extension_timeout_us = S_TO_US(s);
+ blocking_extension_timeout = true;
+}
void lbm_block_ctx_from_extension(void) {
mutex_lock(&blocking_extension_mutex);
blocking_extension = true;
+ blocking_extension_timeout_us = 0;
+ blocking_extension_timeout = false;
}
void lbm_undo_block_ctx_from_extension(void) {
blocking_extension = false;
+ blocking_extension_timeout_us = 0;
+ blocking_extension_timeout = false;
mutex_unlock(&blocking_extension_mutex);
}
@@ -1322,10 +1311,6 @@ lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
found = lookup_ctx_nm(&queue, cid);
}
- if (found == NULL) {
- found = lookup_ctx_nm(&sleeping, cid);
- }
-
if (found) {
if (!mailbox_add_mail(found, msg)) {
mutex_unlock(&qmutex);
@@ -1334,8 +1319,6 @@ lbm_value lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
if (found_blocked){
drop_ctx_nm(&blocked,found);
- //drop_ctx_nm(&queue,found); ????
-
enqueue_ctx_nm(&queue,found);
}
mutex_unlock(&qmutex);
@@ -1453,21 +1436,16 @@ static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value
static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
(void) arg1;
(void) arg2;
- lbm_gc_mark_phase(4,
- ctx->curr_env,
- ctx->curr_exp,
- ctx->program,
- ctx->r);
+ lbm_value roots[4] = { ctx->curr_env, ctx->curr_exp, ctx->program, ctx->r };
+ lbm_gc_mark_aux(roots, 4);
lbm_gc_mark_aux(ctx->mailbox, ctx->num_mail);
lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
}
static int gc(void) {
-
- lbm_uint tstart = 0;
- lbm_uint tend = 0;
-
- tstart = timestamp_us_callback();
+ if (ctx_running) {
+ ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT;
+ }
gc_requested = false;
lbm_gc_state_inc();
@@ -1475,28 +1453,23 @@ static int gc(void) {
lbm_value *variables = lbm_get_variable_table();
if (variables) {
for (int i = 0; i < lbm_get_num_variables(); i ++) {
- lbm_gc_mark_phase(1, variables[i]);
+ add_roots_1(variables[i]);
+ lbm_gc_mark_phase();
}
}
// The freelist should generally be NIL when GC runs.
lbm_nil_freelist();
- lbm_gc_mark_phase(1, *lbm_get_env_ptr());
+ add_roots_1(lbm_get_env());
+ lbm_gc_mark_phase();
mutex_lock(&qmutex); // Lock the queues.
// Any concurrent messing with the queues
// while doing GC cannot possibly be good.
queue_iterator_nm(&queue, mark_context, NULL, NULL);
- queue_iterator_nm(&sleeping, mark_context, NULL, NULL);
queue_iterator_nm(&blocked, mark_context, NULL, NULL);
if (ctx_running) {
- lbm_gc_mark_phase(4,
- ctx_running->curr_env,
- ctx_running->curr_exp,
- ctx_running->program,
- ctx_running->r);
- lbm_gc_mark_aux(ctx_running->mailbox, ctx_running->num_mail);
- lbm_gc_mark_aux(ctx_running->K.data, ctx_running->K.sp);
+ mark_context(ctx_running, NULL, NULL);
}
mutex_unlock(&qmutex);
@@ -1505,15 +1478,10 @@ static int gc(void) {
#endif
int r = lbm_gc_sweep_phase();
-
lbm_heap_new_freelist_length();
- tend = timestamp_us_callback();
-
- lbm_uint dur = 0;
- if (tend > tstart) {
- dur = tend - tstart;
- lbm_heap_new_gc_time(dur); // 0us is not a valid GC time.
+ if (ctx_running) {
+ ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT;
}
return r;
}
@@ -1527,32 +1495,26 @@ int lbm_perform_gc(void) {
static void eval_symbol(eval_context_t *ctx) {
lbm_uint s = lbm_dec_sym(ctx->curr_exp);
- if (s < SPECIAL_SYMBOLS_END) {
- ctx->r = ctx->curr_exp;
- ctx->app_cont = true;
- return;
- }
- if (s >= EXTENSION_SYMBOLS_START &&
- s < EXTENSION_SYMBOLS_END) {
- if (lbm_get_extension(s) != NULL) {
+ if (s >= RUNTIME_SYMBOLS_START) {
+ lbm_value res;
+ if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
+ lbm_env_lookup_b(&res, ctx->curr_exp, lbm_get_env())) {
+ ctx->r = res;
+ ctx->app_cont = true;
+ return;
+ }
+ } else {
+ //special symbols and extensions can be handled the same way.
+ if (s <= EXTENSION_SYMBOLS_END) {
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
return;
}
- error_ctx(ENC_SYM_NOT_FOUND);
- }
- if (s >= VARIABLE_SYMBOLS_START &&
- s < VARIABLE_SYMBOLS_END) {
- ctx->r = lbm_get_var(s);
- ctx->app_cont = true;
- return;
- }
- lbm_value res;
- if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
- lbm_env_lookup_b(&res, ctx->curr_exp, *lbm_get_env_ptr())) {
- ctx->r = res;
- ctx->app_cont = true;
- return;
+ if (s <= VARIABLE_SYMBOLS_END) {
+ ctx->r = lbm_get_var(s);
+ ctx->app_cont = true;
+ return;
+ }
}
// Dynamic load attempt
const char *sym_str = lbm_get_name_by_symbol(s);
@@ -1562,9 +1524,6 @@ static void eval_symbol(eval_context_t *ctx) {
} else {
stack_push_3(&ctx->K, ctx->curr_env, ctx->curr_exp, RESUME);
-#ifdef LBM_ALWAYS_GC
- gc();
-#endif
lbm_value chan;
if (!create_string_channel((char *)code_str, &chan)) {
gc();
@@ -1574,13 +1533,13 @@ static void eval_symbol(eval_context_t *ctx) {
}
lbm_value loader = ENC_SYM_NIL;
- WITH_GC_RMBR(loader, lbm_heap_allocate_list_init(2,
- ENC_SYM_READ,
- chan),1, chan);
+ WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,
+ ENC_SYM_READ,
+ chan), chan);
lbm_value evaluator = ENC_SYM_NIL;
- WITH_GC_RMBR(evaluator, lbm_heap_allocate_list_init(2,
- ENC_SYM_EVAL,
- loader),1 ,loader);
+ WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,
+ ENC_SYM_EVAL,
+ loader), loader);
ctx->curr_exp = evaluator;
ctx->curr_env = ENC_SYM_NIL; // dynamics should be evaluable in empty local env
}
@@ -1628,9 +1587,6 @@ static void eval_atomic(eval_context_t *ctx) {
static void eval_callcc(eval_context_t *ctx) {
-#ifdef LBM_ALWAYS_GC
- gc();
-#endif
lbm_value cont_array;
if (!lbm_heap_allocate_array(&cont_array, ctx->K.sp * sizeof(lbm_uint))) {
gc();
@@ -1646,9 +1602,9 @@ static void eval_callcc(eval_context_t *ctx) {
/* Create an application */
lbm_value fun_arg = get_cadr(ctx->curr_exp);
lbm_value app = ENC_SYM_NIL;
- WITH_GC_RMBR(app, lbm_heap_allocate_list_init(2,
- fun_arg,
- acont), 1, acont);
+ WITH_GC_RMBR_1(app, lbm_heap_allocate_list_init(2,
+ fun_arg,
+ acont), acont);
ctx->curr_exp = app;
ctx->app_cont = false;
@@ -1807,15 +1763,12 @@ static void eval_let(eval_context_t *ctx) {
while (lbm_is_cons(curr)) {
lbm_value new_env_tmp = new_env;
lbm_value key = get_caar(curr);
-#ifdef LBM_ALWAYS_GC
- lbm_gc_mark_phase(1, new_env);
- gc();
-#endif
int r = create_binding_location(key, &new_env_tmp);
if (r < 0) {
if (r == BL_NO_MEMORY) {
new_env_tmp = new_env;
- lbm_gc_mark_phase(1, new_env);
+ add_roots_1(new_env);
+ lbm_gc_mark_phase();
gc();
r = create_binding_location(key, &new_env_tmp);
}
@@ -1889,17 +1842,14 @@ static void eval_match(eval_context_t *ctx) {
}
}
-static void eval_receive(eval_context_t *ctx) {
-
- if (is_atomic) {
- lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
- error_ctx(ENC_SYM_EERROR);
- }
-
- if (ctx->num_mail == 0) {
- block_current_ctx(0,0,false);
+static void receive_base(eval_context_t *ctx, lbm_value pats, float timeout_time, bool timeout) {
+ if (ctx->num_mail == 0) {
+ if (timeout) {
+ block_current_ctx(LBM_THREAD_STATE_TIMEOUT, S_TO_US(timeout_time), 0, false);
+ } else {
+ block_current_ctx(LBM_THREAD_STATE_BLOCKED,0,0, false);
+ }
} else {
- lbm_value pats = ctx->curr_exp;
lbm_value *msgs = ctx->mailbox;
lbm_uint num = ctx->num_mail;
@@ -1911,14 +1861,11 @@ static void eval_receive(eval_context_t *ctx) {
/* The common case */
lbm_value e;
lbm_value new_env = ctx->curr_env;
-#ifdef LBM_ALWAYS_GC
- gc();
-#endif
- int n = find_match(get_cdr(pats), msgs, num, &e, &new_env);
+ int n = find_match(pats, msgs, num, &e, &new_env);
if (n == FM_NEED_GC) {
gc();
new_env = ctx->curr_env;
- n = find_match(get_cdr(pats), msgs, num, &e, &new_env);
+ n = find_match(pats, msgs, num, &e, &new_env);
if (n == FM_NEED_GC) {
error_ctx(ENC_SYM_MERROR);
}
@@ -1932,13 +1879,41 @@ static void eval_receive(eval_context_t *ctx) {
ctx->curr_exp = e;
} else { /* No match go back to sleep */
ctx->r = ENC_SYM_NO_MATCH;
- block_current_ctx(0,0, false);
+ if (timeout) {
+ block_current_ctx(LBM_THREAD_STATE_TIMEOUT,S_TO_US(timeout_time),0,false);
+ } else {
+ block_current_ctx(LBM_THREAD_STATE_BLOCKED, 0, 0, false);
+ }
}
}
}
return;
}
+static void eval_receive_timeout(eval_context_t *ctx) {
+ if (is_atomic) {
+ lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
+ error_ctx(ENC_SYM_EERROR);
+ }
+ lbm_value timeout_val = get_car(get_cdr(ctx->curr_exp));
+ if (!lbm_is_number(timeout_val)) {
+ error_ctx(ENC_SYM_EERROR);
+ }
+ float timeout_time = lbm_dec_as_float(timeout_val);
+ lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
+ receive_base(ctx, pats, timeout_time, true);
+}
+
+static void eval_receive(eval_context_t *ctx) {
+
+ if (is_atomic) {
+ lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
+ error_ctx(ENC_SYM_EERROR);
+ }
+ lbm_value pats = get_cdr(ctx->curr_exp);
+ receive_base(ctx, pats, 0, false);
+}
+
/*********************************************************/
/* Continuation functions */
@@ -2012,7 +1987,6 @@ static void cont_wait(eval_context_t *ctx) {
lbm_blocked_iterator(context_exists, &cid, &exists);
lbm_running_iterator(context_exists, &cid, &exists);
- lbm_sleeping_iterator(context_exists, &cid, &exists);
if (ctx_running->id == cid) {
exists = true;
@@ -2070,9 +2044,6 @@ static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx
if (nargs == 1) {
lbm_value chan = ENC_SYM_NIL;
if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY) {
-#ifdef LBM_ALWAYS_GC
- gc();
-#endif
if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
gc();
if (!create_string_channel(lbm_dec_str(args[0]), &chan)) {
@@ -2120,12 +2091,25 @@ static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ct
lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE;
lbm_uint closure_pos = 0;
+ char *name = NULL;
if (nargs >= 2 &&
lbm_is_number(args[0]) &&
lbm_is_closure(args[1])) {
stack_size = lbm_dec_as_u32(args[0]);
closure_pos = 1;
+ } else if (nargs >= 2 &&
+ lbm_is_array_r(args[0]) &&
+ lbm_is_closure(args[1])) {
+ name = lbm_dec_str(args[0]);
+ closure_pos = 1;
+ }else if (nargs >= 3 &&
+ lbm_is_array_r(args[0]) &&
+ lbm_is_number(args[1]) &&
+ lbm_is_closure(args[2])) {
+ stack_size = lbm_dec_as_u32(args[1]);
+ closure_pos = 2;
+ name = lbm_dec_str(args[0]);
}
if (!lbm_is_closure(args[closure_pos]) ||
@@ -2154,7 +2138,8 @@ static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ct
clo_env,
stack_size,
lbm_get_current_cid(),
- context_flags);
+ context_flags,
+ name);
ctx->r = lbm_enc_i(cid);
ctx->app_cont = true;
}
@@ -2199,7 +2184,7 @@ static void apply_wait_for(lbm_value *args, lbm_uint nargs, eval_context_t *ctx)
uint32_t w = lbm_dec_as_u32(args[0]);
lbm_stack_drop(&ctx->K, nargs+1);
if (w != 0) {
- block_current_ctx(0, w, true);
+ block_current_ctx(LBM_THREAD_STATE_BLOCKED, 0, w, true);
} else {
ctx->r = ENC_SYM_NIL;
ctx->app_cont = true;
@@ -2287,6 +2272,7 @@ static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
error_ctx(err_val);
}
+// (map f arg-list)
static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
if (nargs == 2 && lbm_is_list(args[1])) {
if (lbm_is_symbol_nil(args[1])) {
@@ -2304,7 +2290,7 @@ static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
lbm_value appli_1;
lbm_value appli;
WITH_GC(appli_1, lbm_heap_allocate_list(2));
- WITH_GC_RMBR(appli, lbm_heap_allocate_list(2),1,appli_1);
+ WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1);
lbm_value appli_0 = get_cdr(appli_1);
@@ -2361,6 +2347,86 @@ static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx)
}
}
+static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
+ if (nargs == 1) {
+
+ lbm_value v = flatten_value(args[0]);
+ if ( v == ENC_SYM_MERROR) {
+ gc();
+ v = flatten_value(args[0]);
+ }
+
+ if (lbm_is_symbol(v)) {
+ error_ctx(v);
+ } else {
+ lbm_stack_drop(&ctx->K, 2);
+ ctx->r = v;
+ ctx->app_cont = true;
+ }
+ return;
+ }
+ error_ctx(ENC_SYM_TERROR);
+}
+
+static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
+ if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_FLATVAL) {
+ lbm_array_header_t *array;
+ array = (lbm_array_header_t *)lbm_car(args[0]);
+
+ lbm_flat_value_t fv;
+ fv.buf = (uint8_t*)array->data;
+ fv.buf_size = array->size;
+ fv.buf_pos = 0;
+
+ lbm_value res;
+
+ ctx->r = ENC_SYM_NIL;
+ if (lbm_unflatten_value(&fv, &res)) {
+ ctx->r = res;
+ }
+ lbm_stack_drop(&ctx->K, 2);
+ ctx->app_cont = true;
+ return;
+ }
+ error_ctx(ENC_SYM_TERROR);
+}
+
+static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
+ if (nargs == 2 && lbm_is_number(args[0])) {
+ lbm_cid cid = lbm_dec_as_i32(args[0]);
+
+ if (ctx->id == cid) {
+ ctx->r = args[1];
+ finish_ctx();
+ return;
+ }
+ mutex_lock(&qmutex);
+ eval_context_t *found = NULL;
+ found = lookup_ctx_nm(&blocked, cid);
+ if (found)
+ drop_ctx_nm(&blocked, found);
+ else
+ found = lookup_ctx_nm(&queue, cid);
+ if (found)
+ drop_ctx_nm(&queue, found);
+
+ if (found) {
+ found->K.data[found->K.sp - 1] = KILL;
+ found->r = args[1];
+ found->app_cont = true;
+ enqueue_ctx_nm(&queue,found);
+ ctx->r = ENC_SYM_TRUE;
+ } else {
+ ctx->r = ENC_SYM_NIL;
+ }
+ lbm_stack_drop(&ctx->K, 3);
+ ctx->app_cont = true;
+ mutex_unlock(&qmutex);
+ return;
+ }
+ error_ctx(ENC_SYM_TERROR);
+}
+
/***************************************************/
/* Application lookup table */
@@ -2383,6 +2449,9 @@ static const apply_fun fun_table[] =
apply_map,
apply_reverse,
apply_wait_for,
+ apply_flatten,
+ apply_unflatten,
+ apply_kill,
};
/***************************************************/
@@ -2420,7 +2489,11 @@ static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_c
if (blocking_extension) {
blocking_extension = false;
- block_current_ctx(0,0,true);
+ if (blocking_extension_timeout) {
+ block_current_ctx(LBM_THREAD_STATE_TIMEOUT, blocking_extension_timeout_us, 0, true);
+ } else {
+ block_current_ctx(LBM_THREAD_STATE_BLOCKED, 0, 0, true);
+ }
mutex_unlock(&blocking_extension_mutex);
} else {
ctx->app_cont = true;
@@ -2492,10 +2565,9 @@ static void cont_application_args(eval_context_t *ctx) {
lbm_value env = sptr[0];
lbm_value rest = sptr[1];
lbm_value count = sptr[2];
- lbm_value arg = ctx->r;
ctx->curr_env = env;
- sptr[0] = arg;
+ sptr[0] = ctx->r; // Function 1st then Arguments
if (lbm_is_cons(rest)) {
lbm_cons_t *cell = lbm_ref_cell(rest);
sptr[1] = env;
@@ -2663,14 +2735,10 @@ static void cont_match(eval_context_t *ctx) {
body = n2;
check_guard = true;
}
-#ifdef LBM_ALWAYS_GC
- lbm_gc_mark_phase(2, patterns, e);
- gc();
-#endif
bool is_match = match(pattern, e, &new_env, &do_gc);
if (do_gc) {
- lbm_gc_mark_phase(2, patterns, e);
+ add_roots_2(patterns, e);
gc();
do_gc = false;
new_env = ctx->curr_env;
@@ -2718,7 +2786,7 @@ static void cont_map_first(eval_context_t *ctx) {
lbm_value ls = sptr[0];
lbm_value env = sptr[1];
- lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL,ENC_SYM_NIL);
+ lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
sptr[2] = elt; // head of result list
sptr[3] = elt; // tail of result list
if (lbm_is_cons(ls)) {
@@ -2743,9 +2811,9 @@ static void cont_map_rest(eval_context_t *ctx) {
lbm_value ls = sptr[0];
lbm_value env = sptr[1];
lbm_value t = sptr[3];
-
lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
lbm_set_cdr(t, elt);
+
sptr[3] = elt; // update tail of result list.
if (lbm_is_cons(ls)) {
lbm_value next, rest;
@@ -2753,6 +2821,7 @@ static void cont_map_rest(eval_context_t *ctx) {
sptr[0] = rest;
stack_push(&ctx->K, MAP_REST);
lbm_set_car(sptr[5], next); // new arguments
+
ctx->curr_exp = sptr[4];
ctx->curr_env = env;
} else {
@@ -3000,9 +3069,6 @@ static void cont_read_next_token(eval_context_t *ctx) {
*/
n = tok_string(chan, &string_len);
if (n >= 2) {
-#ifdef LBM_ALWAYS_GC
- gc();
-#endif
lbm_channel_drop(chan, (unsigned int)n);
if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
gc();
@@ -3155,9 +3221,6 @@ static void cont_read_start_array(eval_context_t *ctx) {
error_ctx(ENC_SYM_FATAL_ERROR);
}
-#ifdef LBM_ALWAYS_GC
- gc();
-#endif
lbm_uint num_free = lbm_memory_longest_free();
lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
if (initial_size == 0) {
@@ -3390,7 +3453,7 @@ static void cont_read_done(eval_context_t *ctx) {
read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
}
}
-
+
ctx->row0 = -1;
ctx->row1 = -1;
ctx->app_cont = true;
@@ -3828,9 +3891,9 @@ lbm_value append(lbm_value front, lbm_value back) {
(else `',x)))
*/
static void cont_qq_expand(eval_context_t *ctx) {
- lbm_value qquoted;
+ lbm_value qquoted;
lbm_pop(&ctx->K, &qquoted);
-
+
switch(lbm_type_of(qquoted)) {
case LBM_TYPE_CONS: {
lbm_value car_val = lbm_car(qquoted);
@@ -3896,7 +3959,7 @@ static void cont_qq_expand_list(eval_context_t* ctx) {
lbm_value tl;
WITH_GC(tl, lbm_cons(lbm_car(cdr_val), ENC_SYM_NIL));
lbm_value tmp;
- WITH_GC_RMBR(tmp, lbm_cons(ENC_SYM_LIST, tl), 1, tl);
+ WITH_GC_RMBR_1(tmp, lbm_cons(ENC_SYM_LIST, tl), tl);
ctx->r = append(ctx->r, tmp);
ctx->app_cont = true;
return;
@@ -3906,14 +3969,14 @@ static void cont_qq_expand_list(eval_context_t* ctx) {
ctx->app_cont = true;
return;
} else {
- stack_push(&ctx->K, QQ_LIST);
+ stack_push(&ctx->K, QQ_LIST);
stack_push_2(&ctx->K, ctx->r, QQ_APPEND);
stack_push_2(&ctx->K, cdr_val, QQ_EXPAND);
stack_push_2(&ctx->K, car_val, QQ_EXPAND_LIST);
ctx->app_cont = true;
ctx->r = ENC_SYM_NIL;
}
-
+
} break;
default: {
lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL, ENC_SYM_NIL);
@@ -3933,6 +3996,11 @@ static void cont_qq_list(eval_context_t *ctx) {
ctx->app_cont = true;
}
+static void cont_kill(eval_context_t *ctx) {
+ (void) ctx;
+ finish_ctx();
+}
+
/*********************************************************/
/* Continuations table */
typedef void (*cont_fun)(eval_context_t *);
@@ -3981,6 +4049,7 @@ static const cont_fun continuations[NUM_CONTINUATIONS] =
cont_qq_append,
cont_qq_expand_list,
cont_qq_list,
+ cont_kill,
};
/*********************************************************/
@@ -3999,6 +4068,7 @@ static const evaluator_fun evaluators[] =
eval_or,
eval_match,
eval_receive,
+ eval_receive_timeout,
eval_callcc,
eval_atomic,
eval_selfevaluating, // macro
@@ -4096,6 +4166,8 @@ uint32_t lbm_get_eval_state(void) {
return eval_cps_run_state;
}
+// Will wake up thread that is sleeping as well.
+// Not sure this is good behavior.
static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
eval_context_t *found = NULL;
mutex_lock(&qmutex);
@@ -4153,14 +4225,13 @@ static void process_events(void) {
}
}
-static void process_waiting(void) {
+static void process_waiting_nm(void) {
uint32_t wait_flags = wait_for; // Should ideally be atomic
wait_for = wait_flags ^ wait_for; //
eval_context_queue_t *q = &blocked;
- mutex_lock(&qmutex);
eval_context_t *curr = q->first;
while (curr != NULL) {
eval_context_t *next = curr->next; // grab here
@@ -4187,11 +4258,10 @@ static void process_waiting(void) {
}
ctx->wait_mask = 0;
ctx->r = ENC_SYM_TRUE; // woken up task receives true.
- enqueue_ctx_nm(&queue, ctx); // changes meaing of curr->next.
+ enqueue_ctx_nm(&queue, ctx); // changes meaning of curr->next.
}
curr = next;
}
- mutex_unlock(&qmutex);
}
/* eval_cps_run can be paused
@@ -4222,21 +4292,15 @@ void lbm_run_eval(void){
eval_cps_run_state = eval_cps_next_state;
break;
}
-
while (true) {
- eval_context_t *next_to_run = NULL;
if (eval_steps_quota && ctx_running) {
eval_steps_quota--;
evaluation_step();
} else {
if (eval_cps_state_changed) break;
- uint32_t us = EVAL_CPS_MIN_SLEEP;
-
+ eval_steps_quota = eval_steps_refill;
if (is_atomic) {
- if (ctx_running) {
- next_to_run = ctx_running;
- ctx_running = NULL;
- } else {
+ if (!ctx_running) {
lbm_set_flags(LBM_FLAG_ATOMIC_MALFUNCTION);
is_atomic = 0;
}
@@ -4244,25 +4308,22 @@ void lbm_run_eval(void){
if (gc_requested) {
gc();
}
- if (wait_for) {
- process_waiting();
- }
process_events();
- next_to_run = dequeue_ctx(&sleeping, &us);
- }
-
- if (!next_to_run) {
- next_to_run = enqueue_dequeue_ctx(&queue, ctx_running);
- } else if (ctx_running) {
- enqueue_ctx(&queue, ctx_running);
- }
-
- eval_steps_quota = eval_steps_refill;
- ctx_running = next_to_run;
-
- if (!ctx_running) {
- usleep_callback(us);
- continue;
+ mutex_lock(&qmutex);
+ if (wait_for) {
+ process_waiting_nm();
+ }
+ if (ctx_running) {
+ enqueue_ctx_nm(&queue, ctx_running);
+ ctx_running = NULL;
+ }
+ wake_up_ctxs_nm();
+ ctx_running = dequeue_ctx_nm(&queue);
+ mutex_unlock(&qmutex);
+ if (!ctx_running) {
+ //Fixed sleep interval to poll events regularly.
+ usleep_callback(EVAL_CPS_MIN_SLEEP);
+ }
}
}
}
@@ -4298,8 +4359,6 @@ int lbm_eval_init() {
blocked.first = NULL;
blocked.last = NULL;
- sleeping.first = NULL;
- sleeping.last = NULL;
queue.first = NULL;
queue.last = NULL;
ctx_running = NULL;
diff --git a/src/extensions/runtime_extensions.c b/src/extensions/runtime_extensions.c
index b8449f52..e88d1f7c 100644
--- a/src/extensions/runtime_extensions.c
+++ b/src/extensions/runtime_extensions.c
@@ -33,9 +33,6 @@ static lbm_uint sym_num_gc_recovered_cells;
static lbm_uint sym_num_gc_recovered_arrays;
static lbm_uint sym_num_least_free;
static lbm_uint sym_num_last_free;
-static lbm_uint sym_gc_time_acc;
-static lbm_uint sym_gc_time_min;
-static lbm_uint sym_gc_time_max;
lbm_value ext_eval_set_quota(lbm_value *args, lbm_uint argn) {
LBM_CHECK_ARGN_NUMBER(1);
@@ -111,12 +108,6 @@ lbm_value ext_lbm_heap_state(lbm_value *args, lbm_uint argn) {
res = lbm_enc_u(hs.gc_least_free);
} else if (s == sym_num_last_free) {
res = lbm_enc_u(hs.gc_last_free);
- } else if (s == sym_gc_time_acc) {
- res = lbm_enc_u(hs.gc_time_acc);
- } else if (s == sym_gc_time_min) {
- res = lbm_enc_u(hs.gc_min_duration);
- } else if (s == sym_gc_time_max) {
- res = lbm_enc_u(hs.gc_max_duration);
} else {
res = ENC_SYM_NIL;
}
@@ -150,9 +141,6 @@ bool lbm_runtime_extensions_init(bool minimal) {
lbm_add_symbol_const("get-gc-num-recovered-arrays", &sym_num_gc_recovered_arrays);
lbm_add_symbol_const("get-gc-num-least-free", &sym_num_least_free);
lbm_add_symbol_const("get-gc-num-last-free", &sym_num_last_free);
- lbm_add_symbol_const("get-gc-time-acc", &sym_gc_time_acc);
- lbm_add_symbol_const("get-gc-min-dur", &sym_gc_time_min);
- lbm_add_symbol_const("get-gc-max-dur", &sym_gc_time_max);
}
bool res = true;
diff --git a/src/fundamental.c b/src/fundamental.c
index 5b1f411d..f910e1db 100644
--- a/src/fundamental.c
+++ b/src/fundamental.c
@@ -1128,6 +1128,7 @@ static lbm_value fundamental_type_of(lbm_value *args, lbm_uint nargs, eval_conte
case LBM_TYPE_U: return ENC_SYM_TYPE_U;
case LBM_TYPE_CHAR: return ENC_SYM_TYPE_CHAR;
case LBM_TYPE_SYMBOL: return ENC_SYM_TYPE_SYMBOL;
+ case LBM_TYPE_FLATVAL: return ENC_SYM_TYPE_FLATVAL;
}
return ENC_SYM_TERROR;
}
diff --git a/src/heap.c b/src/heap.c
index 5bf75f5a..d9a00f7f 100644
--- a/src/heap.c
+++ b/src/heap.c
@@ -458,18 +458,6 @@ static void heap_init_state(lbm_cons_t *addr, lbm_uint num_cells,
lbm_heap_state.gc_recovered_arrays = 0;
lbm_heap_state.gc_least_free = num_cells;
lbm_heap_state.gc_last_free = num_cells;
-
- lbm_heap_state.gc_time_acc = 0;
- lbm_heap_state.gc_max_duration = 0;
- lbm_heap_state.gc_min_duration = UINT32_MAX;
-}
-
-void lbm_heap_new_gc_time(lbm_uint dur) {
- lbm_heap_state.gc_time_acc += dur;
- if (dur > lbm_heap_state.gc_max_duration)
- lbm_heap_state.gc_max_duration = dur;
- if (dur < lbm_heap_state.gc_min_duration)
- lbm_heap_state.gc_min_duration = dur;
}
void lbm_heap_new_freelist_length(void) {
@@ -598,20 +586,9 @@ void lbm_get_heap_state(lbm_heap_state_t *res) {
*res = lbm_heap_state;
}
-int lbm_gc_mark_phase(int num, ... ) { //lbm_value env) {
+int lbm_gc_mark_phase() {
lbm_stack_t *s = &lbm_heap_state.gc_stack;
-
- va_list valist;
- va_start(valist, num);
- lbm_value root;
- for (int i = 0; i < num; i++) {
- root = va_arg(valist, lbm_value);
- if (lbm_is_ptr(root)) {
- lbm_push(s, root);
- }
- }
- va_end(valist);
int res = 1;
while (!lbm_stack_is_empty(s)) {
@@ -683,7 +660,8 @@ int lbm_gc_mark_aux(lbm_uint *aux_data, lbm_uint aux_size) {
if( pt_t >= LBM_POINTER_TYPE_FIRST &&
pt_t <= LBM_POINTER_TYPE_LAST &&
pt_v < lbm_heap_state.heap_size) {
- lbm_gc_mark_phase(1,aux_data[i]);
+ lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = aux_data[i];
+ lbm_gc_mark_phase();
}
}
}
@@ -710,7 +688,7 @@ int lbm_gc_sweep_phase(void) {
case SYM_IND_F_TYPE:
lbm_memory_free((lbm_uint*)heap[i].car);
break;
-
+ case SYM_FLATVAL_TYPE:
case SYM_ARRAY_TYPE:{
lbm_array_header_t *arr = (lbm_array_header_t*)heap[i].car;
if (lbm_memory_ptr_inside((lbm_uint*)arr->data)) {
@@ -1055,6 +1033,32 @@ int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt) {
return 1;
}
+lbm_int lbm_heap_array_get_size(lbm_value arr) {
+
+ int r = -1;
+ if (lbm_is_array_rw(arr)) {
+ lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
+ if (header == NULL) {
+ return r;
+ }
+ r = (lbm_int)header->size;
+ }
+ return r;
+}
+
+uint8_t *lbm_heap_array_get_data(lbm_value arr) {
+ uint8_t *r = NULL;
+ if (lbm_is_array_rw(arr)) {
+ lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr);
+ if (header == NULL) {
+ return r;
+ }
+ r = (uint8_t*)header->data;
+ }
+ return r;
+}
+
+
/* Explicitly freeing an array.
This is a highly unsafe operation and can only be safely
@@ -1207,4 +1211,3 @@ lbm_flash_status write_const_car(lbm_value cell, lbm_value val) {
lbm_uint lbm_flash_memory_usage(void) {
return lbm_const_heap_state->next;
}
-
diff --git a/src/lbm_flat_value.c b/src/lbm_flat_value.c
index 3087a1e3..c9b26de9 100644
--- a/src/lbm_flat_value.c
+++ b/src/lbm_flat_value.c
@@ -20,6 +20,9 @@
#include
#include
+#include
+
+static jmp_buf flatten_value_result_jmp_buf;
// ------------------------------------------------------------
// Access to GC from eval_cps
@@ -49,6 +52,7 @@ bool lbm_finish_flatten(lbm_flat_value_t *v) {
} else {
size_words = (v->buf_pos / sizeof(lbm_uint)) + 1;
}
+ v->buf_size = size_words * sizeof(lbm_uint);
return (lbm_memory_shrink((lbm_uint*)v->buf, size_words) >= 0);
}
@@ -107,6 +111,39 @@ bool f_sym(lbm_flat_value_t *v, lbm_uint sym) {
return res;
}
+bool f_sym_string(lbm_flat_value_t *v, lbm_uint sym) {
+ bool res = true;
+ char *sym_str;
+ if (lbm_is_symbol(sym)) {
+ lbm_uint s = lbm_dec_sym(sym);
+ sym_str = (char*)lbm_get_name_by_symbol(s);
+ if (sym_str) {
+ lbm_uint sym_bytes = strlen(sym_str) + 1;
+ res = res && write_byte(v, S_SYM_STRING);
+ if (res && v->buf_size >= v->buf_pos + sym_bytes) {
+ for (lbm_uint i = 0; i < sym_bytes; i ++ ) {
+ res = res && write_byte(v, (uint8_t)sym_str[i]);
+ }
+ return res;
+ }
+ }
+ }
+ return false;
+}
+
+int f_sym_string_bytes(lbm_uint sym) {
+ char *sym_str;
+ if (lbm_is_symbol(sym)) {
+ lbm_uint s = lbm_dec_sym(sym);
+ sym_str = (char*)lbm_get_name_by_symbol(s);
+ if (sym_str) {
+ lbm_uint sym_bytes = strlen(sym_str) + 1;
+ return (lbm_int)sym_bytes;
+ }
+ }
+ return FLATTEN_VALUE_ERROR_FATAL;
+}
+
bool f_i(lbm_flat_value_t *v, lbm_int i) {
bool res = true;
res = res && write_byte(v,S_I_VALUE);
@@ -114,6 +151,13 @@ bool f_i(lbm_flat_value_t *v, lbm_int i) {
return res;
}
+bool f_u(lbm_flat_value_t *v, lbm_uint u) {
+ bool res = true;
+ res = res && write_byte(v,S_U_VALUE);
+ res = res && write_word(v,(uint32_t)u);
+ return res;
+}
+
bool f_b(lbm_flat_value_t *v, uint8_t b) {
bool res = true;
res = res && write_byte(v,S_BYTE_VALUE);
@@ -144,6 +188,15 @@ bool f_float(lbm_flat_value_t *v, float f) {
return res;
}
+bool f_double(lbm_flat_value_t *v, double d) {
+ bool res = true;
+ res = res && write_byte(v, S_DOUBLE_VALUE);
+ uint64_t u;
+ memcpy(&u, &d, sizeof(uint64_t));
+ res = res && write_dword(v, u);
+ return res;
+}
+
bool f_i64(lbm_flat_value_t *v, int64_t w) {
bool res = true;
res = res && write_byte(v, S_I64_VALUE);
@@ -171,9 +224,228 @@ bool f_lbm_array(lbm_flat_value_t *v, uint32_t num_bytes, uint8_t *data) {
return res;
}
+static int flatten_value_result = FLATTEN_VALUE_OK;
+static int flatten_maximum_depth = FLATTEN_VALUE_MAXIMUM_DEPTH;
+
+void lbm_set_max_flatten_depth(int depth) {
+ flatten_maximum_depth = depth;
+}
+
+void flatten_set_result(int val) {
+ flatten_value_result = val;
+ longjmp(flatten_value_result_jmp_buf, 1);
+}
+
+int flatten_value_size(lbm_value v, int depth, int n_cons, int max_cons) {
+ if (depth > flatten_maximum_depth) {
+ flatten_set_result(FLATTEN_VALUE_ERROR_MAXIMUM_DEPTH);
+ }
+ if (n_cons > max_cons) {
+ flatten_set_result(FLATTEN_VALUE_ERROR_CIRCULAR);
+ }
+
+ switch (lbm_type_of(v)) {
+ case LBM_TYPE_CONS: /* fall through */
+ case LBM_TYPE_CONS_CONST: {
+ int s2 = 0;
+ int s1 = flatten_value_size(lbm_car(v), depth + 1, n_cons+1, max_cons);
+ if (s1 > 0) {
+ s2 = flatten_value_size(lbm_cdr(v), depth + 1, n_cons+1, max_cons);
+ if (s2 > 0) {
+ return (1 + s1 + s2);
+ }
+ }
+ return 0; // already terminated with error
+ }
+ case LBM_TYPE_BYTE:
+ return 1;
+ case LBM_TYPE_U: /* fall through */
+ case LBM_TYPE_I:
+#ifndef LBM64
+ return 1 + 4;
+#else
+ return 1 + 8;
+#endif
+ case LBM_TYPE_U32: /* fall through */
+ case LBM_TYPE_I32:
+ case LBM_TYPE_FLOAT:
+ return 1 + 4;
+ case LBM_TYPE_U64: /* fall through */
+ case LBM_TYPE_I64:
+ case LBM_TYPE_DOUBLE:
+ return 1 + 8;
+ case LBM_TYPE_SYMBOL: {
+ int s = f_sym_string_bytes(v);
+ if (s > 0) return 1 + s;
+ flatten_set_result(s);
+ } return 0; // already terminated with error
+ case LBM_TYPE_ARRAY: {
+ lbm_int s = lbm_heap_array_get_size(v);
+ if (s > 0)
+ return 1 + 4 + s;
+ flatten_set_result(s);
+ } return 0; // already terminated with error
+ default:
+ return FLATTEN_VALUE_ERROR_CANNOT_BE_FLATTENED;
+ }
+}
+
+int flatten_value_internal(lbm_flat_value_t *fv, lbm_value v) {
+ switch (lbm_type_of(v)) {
+ case LBM_TYPE_CONS: /* fall through */
+ case LBM_TYPE_CONS_CONST: {
+ bool res = true;
+ res = res && f_cons(fv);
+ if (res) {
+ int fv_r = flatten_value_internal(fv, lbm_car(v));
+ if (fv_r == FLATTEN_VALUE_OK) {
+ fv_r = flatten_value_internal(fv, lbm_cdr(v));
+ }
+ return fv_r;
+ }
+ }break;
+ case LBM_TYPE_BYTE:
+ if (f_b(fv, (uint8_t)lbm_dec_as_char(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_U:
+ if (f_u(fv, lbm_dec_u(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_I:
+ if (f_i(fv, lbm_dec_i(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_U32:
+ if (f_u32(fv, lbm_dec_as_u32(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_I32:
+ if (f_i32(fv, lbm_dec_as_i32(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_U64:
+ if (f_u64(fv, lbm_dec_as_u64(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_I64:
+ if (f_i64(fv, lbm_dec_as_i64(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_FLOAT:
+ if (f_float(fv, lbm_dec_as_float(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_DOUBLE:
+ if (f_double(fv, lbm_dec_as_double(v))) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_SYMBOL:
+ if (f_sym_string(fv, v)) {
+ return FLATTEN_VALUE_OK;
+ }
+ break;
+ case LBM_TYPE_ARRAY: {
+ lbm_int s = lbm_heap_array_get_size(v);
+ uint8_t *d = lbm_heap_array_get_data(v);
+ if (s > 0 && d != NULL) {
+ if (f_lbm_array(fv, (lbm_uint)s, d)) {
+ return FLATTEN_VALUE_OK;
+ }
+ } else {
+ return FLATTEN_VALUE_ERROR_ARRAY;
+ }
+ }break;
+ default:
+ return FLATTEN_VALUE_ERROR_CANNOT_BE_FLATTENED;
+ }
+ return FLATTEN_VALUE_ERROR_BUFFER_TOO_SMALL;
+}
+
+lbm_value handle_flatten_error(int err_val) {
+ switch (err_val) {
+ case FLATTEN_VALUE_ERROR_CANNOT_BE_FLATTENED:
+ return ENC_SYM_EERROR;
+ case FLATTEN_VALUE_ERROR_BUFFER_TOO_SMALL: /* fall through */
+ case FLATTEN_VALUE_ERROR_FATAL:
+ return ENC_SYM_FATAL_ERROR;
+ case FLATTEN_VALUE_ERROR_CIRCULAR: /* fall through */
+ case FLATTEN_VALUE_ERROR_MAXIMUM_DEPTH:
+ return ENC_SYM_EERROR;
+ case FLATTEN_VALUE_ERROR_NOT_ENOUGH_MEMORY:
+ return ENC_SYM_MERROR;
+ }
+ return ENC_SYM_NIL;
+}
+
+lbm_value flatten_value( lbm_value v) {
+
+ lbm_array_header_t *array = NULL;
+ lbm_value array_cell = lbm_heap_allocate_cell(LBM_TYPE_CONS, ENC_SYM_NIL, ENC_SYM_FLATVAL_TYPE);
+ if (lbm_type_of(array_cell) == LBM_TYPE_SYMBOL) {
+ lbm_set_car_and_cdr(array_cell, ENC_SYM_NIL, ENC_SYM_NIL);
+ return ENC_SYM_MERROR;
+ }
+
+ lbm_flat_value_t fv;
+ if (setjmp(flatten_value_result_jmp_buf) > 0) {
+ lbm_set_car_and_cdr(array_cell, ENC_SYM_NIL, ENC_SYM_NIL);
+ return handle_flatten_error(flatten_value_result);
+ }
+
+ int required_mem = flatten_value_size(v, 0, 0, (int)lbm_heap_size());
+ if (required_mem > 0) {
+ array = (lbm_array_header_t *)lbm_malloc(sizeof(lbm_array_header_t));
+ if (array == NULL) {
+ flatten_set_result(FLATTEN_VALUE_ERROR_NOT_ENOUGH_MEMORY);
+ }
+
+ bool r = lbm_start_flatten(&fv, (lbm_uint)required_mem);
+ if (!r) {
+ lbm_free(array);
+ flatten_set_result(FLATTEN_VALUE_ERROR_NOT_ENOUGH_MEMORY);
+ }
+
+ if (flatten_value_internal(&fv, v) == FLATTEN_VALUE_OK) {
+ r = lbm_finish_flatten(&fv);
+ }
+
+ if (r) {
+ // lift flat_value
+ array->data = (lbm_uint*)fv.buf;
+ array->size = fv.buf_size;
+ lbm_set_car(array_cell, (lbm_uint)array);
+ array_cell = lbm_set_ptr_type(array_cell, LBM_TYPE_FLATVAL);
+ return array_cell;
+ } else {
+ flatten_set_result(FLATTEN_VALUE_ERROR_FATAL);
+ }
+ }
+
+ lbm_set_car_and_cdr(array_cell, ENC_SYM_NIL, ENC_SYM_NIL);
+ lbm_free(array);
+ return handle_flatten_error(required_mem);
+}
// ------------------------------------------------------------
// Unflattening
+static bool extract_byte(lbm_flat_value_t *v, uint8_t *r) {
+ if (v->buf_size >= v->buf_pos + 1) {
+ *r = v->buf[v->buf_pos++];
+ return true;
+ }
+ return false;
+}
+
static bool extract_word(lbm_flat_value_t *v, uint32_t *r) {
if (v->buf_size >= v->buf_pos + 4) {
uint32_t tmp = 0;
@@ -244,6 +516,15 @@ static int lbm_unflatten_value_internal(lbm_flat_value_t *v, lbm_value *res) {
}
return UNFLATTEN_MALFORMED;
}
+ case S_BYTE_VALUE: {
+ uint8_t tmp;
+ bool b = extract_byte(v, &tmp);
+ if (b) {
+ *res = lbm_enc_char((char)tmp);
+ return UNFLATTEN_OK;
+ }
+ return UNFLATTEN_MALFORMED;
+ }
case S_I_VALUE: {
lbm_uint tmp;
bool b;
@@ -292,6 +573,22 @@ static int lbm_unflatten_value_internal(lbm_flat_value_t *v, lbm_value *res) {
}
return UNFLATTEN_MALFORMED;
}
+ case S_DOUBLE_VALUE: {
+ uint64_t tmp;
+ bool b;
+ b = extract_dword(v, &tmp);
+ if (b) {
+ double f;
+ memcpy(&f, &tmp, sizeof(uint64_t));
+ lbm_value im = lbm_enc_double(f);
+ if (lbm_is_symbol_merror(im)) {
+ return UNFLATTEN_GC_RETRY;
+ }
+ *res = im;
+ return UNFLATTEN_OK;
+ }
+ return UNFLATTEN_MALFORMED;
+ }
case S_I32_VALUE: {
uint32_t tmp;
if (extract_word(v, &tmp)) {
@@ -355,6 +652,20 @@ static int lbm_unflatten_value_internal(lbm_flat_value_t *v, lbm_value *res) {
}
return UNFLATTEN_MALFORMED;
}
+ case S_SYM_STRING: {
+ lbm_uint sym_id;
+ int r = lbm_get_symbol_by_name((char *)(v->buf + v->buf_pos), &sym_id);
+ if (!r) {
+ r = lbm_add_symbol((char *)(v->buf + v->buf_pos), &sym_id);
+ }
+ if (r) {
+ lbm_uint num_bytes = strlen((char*)(v->buf + v->buf_pos)) + 1;
+ v->buf_pos += num_bytes;
+ *res = lbm_enc_sym(sym_id);
+ return UNFLATTEN_OK;
+ }
+ return UNFLATTEN_MALFORMED;
+ }
default:
return UNFLATTEN_MALFORMED;
}
diff --git a/src/lbm_prof.c b/src/lbm_prof.c
new file mode 100644
index 00000000..bc8849a1
--- /dev/null
+++ b/src/lbm_prof.c
@@ -0,0 +1,131 @@
+/*
+ Copyright 2023 Joel Svensson svenssonjoel@yahoo.se
+
+ 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
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see .
+*/
+
+#include "lbm_prof.h"
+#include "platform_mutex.h"
+
+static lbm_uint sample_interval_us = 200;
+static bool lbm_prof_running = false;
+static lbm_uint num_samples = 0;
+static lbm_uint num_sleep_samples = 0;
+static void (*usleep_callback)(uint32_t) = NULL;
+extern eval_context_t *ctx_running;
+extern mutex_t qmutex;
+extern bool qmutex_initialized;
+
+static lbm_prof_t *prof_data;
+static lbm_uint prof_data_num;
+
+#define TRUNC_SIZE(N) (((N) > LBM_PROF_MAX_NAME_SIZE -1) ? LBM_PROF_MAX_NAME_SIZE-1 : N)
+
+bool lbm_prof_init(void (*usleep_fptr)(uint32_t),
+ lbm_uint sample_interval,
+ lbm_prof_t *prof_data_buf,
+ lbm_uint prof_data_buf_num) {
+ if (qmutex_initialized && prof_data_buf && prof_data_buf_num > 0) {
+ usleep_callback = usleep_fptr;
+ sample_interval_us = sample_interval;
+ num_samples = 0;
+ num_sleep_samples = 0;
+ prof_data_num = prof_data_buf_num;
+ prof_data = prof_data_buf;
+ for (lbm_uint i = 0; i < prof_data_num; i ++) {
+ prof_data_buf[i].cid = -1;
+ prof_data[i].has_name = false;
+ memset(&prof_data_buf[i].name, 0, LBM_PROF_MAX_NAME_SIZE);
+ prof_data_buf[i].count = 0;
+ }
+ if (usleep_callback != NULL) {
+ lbm_prof_running = true;
+ return true;
+ }
+ }
+ return false;
+}
+
+lbm_uint lbm_prof_get_num_samples(void) {
+ return num_samples;
+}
+
+lbm_uint lbm_prof_get_num_sleep_samples(void) {
+ return num_sleep_samples;
+}
+
+lbm_uint lbm_prof_stop(void) {
+ lbm_prof_running = false;
+ return num_samples;
+}
+
+bool lbm_prof_is_running(void) {
+ return lbm_prof_running;
+}
+
+// start in an OS thread.
+void lbm_prof_run(void) {
+ while (lbm_prof_running) {
+ num_samples ++;
+
+ // Lock mutex so context cannot be destroyed until
+ // we are done storing a sample.
+ mutex_lock(&qmutex);
+ eval_context_t *curr = ctx_running;
+ if (curr != NULL) {
+ lbm_cid id = curr->id;
+ char *name = curr->name;
+ lbm_uint name_len = 0;
+ bool doing_gc = false;
+ if (curr->state & LBM_THREAD_STATE_GC_BIT) {
+ doing_gc = true;
+ }
+ if (name) name_len = strlen(name) + 1;
+ for (lbm_uint i = 0; i < prof_data_num; i ++) {
+ if (prof_data[i].cid == -1) {
+ // add new sample:
+ prof_data[i].cid = id;
+ prof_data[i].count = 1;
+ prof_data[i].gc_count = doing_gc ? 1 : 0;
+ if (name) {
+ memcpy(&prof_data[i].name, name, TRUNC_SIZE(name_len));
+ prof_data[i].name[LBM_PROF_MAX_NAME_SIZE - 1] = 0;
+ prof_data[i].has_name = true;
+ }
+ break;
+ }
+ if (prof_data[i].cid == id &&
+ prof_data[i].has_name &&
+ name != NULL &&
+ strncmp(prof_data[i].name, name, TRUNC_SIZE(name_len)) == 0) {
+ // found a named existing measurement.
+ prof_data[i].count ++;
+ prof_data[i].gc_count += doing_gc ? 1 : 0;
+ break;
+ }
+ if (prof_data[i].cid == id &&
+ !prof_data[i].has_name &&
+ name == NULL) {
+ prof_data[i].count ++;
+ prof_data[i].gc_count += doing_gc ? 1 : 0;
+ break;
+ }
+ }
+ } else {
+ num_sleep_samples ++;
+ }
+ mutex_unlock(&qmutex);
+ usleep_callback(sample_interval_us);
+ }
+}
diff --git a/src/print.c b/src/print.c
index 2ea1b1c4..8de62915 100644
--- a/src/print.c
+++ b/src/print.c
@@ -212,6 +212,11 @@ int print_emit_channel(lbm_char_channel_t *chan, lbm_value v) {
return print_emit_string(chan, "~CHANNEL~");
}
+int print_emit_flatval(lbm_char_channel_t *chan, lbm_value v) {
+ (void) v;
+ return print_emit_string(chan, "~FLATVAL~");
+}
+
int print_emit_array_data(lbm_char_channel_t *chan, lbm_array_header_t *array) {
int r = print_emit_char(chan, '[');
@@ -397,6 +402,9 @@ int lbm_print_internal(lbm_char_channel_t *chan, lbm_value v) {
case LBM_TYPE_CHANNEL:
r = print_emit_channel(chan, curr);
break;
+ case LBM_TYPE_FLATVAL:
+ r = print_emit_flatval(chan, curr);
+ break;
case LBM_TYPE_ARRAY:
r = print_emit_array(chan, curr);
break;
diff --git a/src/symrepr.c b/src/symrepr.c
index 79ca37ef..f7f7bfa2 100644
--- a/src/symrepr.c
+++ b/src/symrepr.c
@@ -55,10 +55,12 @@ special_sym const special_symbols[] = {
{"_" , SYM_DONTCARE},
{"send" , SYM_SEND},
{"recv" , SYM_RECEIVE},
+ {"recv-to" , SYM_RECEIVE_TIMEOUT},
{"macro" , SYM_MACRO},
{"call-cc" , SYM_CALLCC},
{"continuation" , SYM_CONT},
{"var" , SYM_PROGN_VAR},
+ {"timeout" , SYM_TIMEOUT},
{"set" , SYM_SETVAR},
{"setq" , SYM_SETQ},
@@ -68,6 +70,9 @@ special_sym const special_symbols[] = {
{"map" , SYM_MAP},
{"reverse" , SYM_REVERSE},
{"wait-for" , SYM_WAIT_FOR},
+ {"flatten" , SYM_FLATTEN},
+ {"unflatten" , SYM_UNFLATTEN},
+ {"kill" , SYM_KILL},
{"gc" , SYM_PERFORM_GC},
// pattern matching
@@ -96,6 +101,7 @@ special_sym const special_symbols[] = {
{"$channel" , SYM_CHANNEL_TYPE},
{"$recovered" , SYM_RECOVERED},
{"$custom" , SYM_CUSTOM_TYPE},
+ {"$flatval" , SYM_FLATVAL_TYPE},
{"$nonsense" , SYM_NONSENSE},
// tokenizer symbols with unparsable names
@@ -129,6 +135,8 @@ special_sym const special_symbols[] = {
{"type-char" , SYM_TYPE_CHAR},
{"type-byte" , SYM_TYPE_BYTE},
{"type-channel" , SYM_TYPE_CHANNEL},
+ {"type-flatval" , SYM_TYPE_FLATVAL},
+
// Fundamental operations
{"+" , SYM_ADD},
{"-" , SYM_SUB},
diff --git a/tests/test_arith_stress_4.lisp b/tests/test_arith_stress_4.lisp
new file mode 100644
index 00000000..6b557929
--- /dev/null
+++ b/tests/test_arith_stress_4.lisp
@@ -0,0 +1,16 @@
+
+(defun apply (f args)
+ (eval (cons f args)))
+
+(defun test-it (n c args res acc)
+ (if (= n 0) acc
+ (progn
+ (define acc (and acc (= (apply c args) res)))
+ (test-it (- n 1) c args res acc))))
+
+(defun arith (a b c d e f g h i j)
+ (+ a b c d e f g h i j))
+
+(def res (test-it 10000 arith '(1u64 2u64 3u64 4u64 5u64 6u64 7u64 8u64 9u64 10u64) 55u64 t))
+
+(check res)
diff --git a/tests/test_arith_stress_5.lisp b/tests/test_arith_stress_5.lisp
new file mode 100644
index 00000000..4724f47a
--- /dev/null
+++ b/tests/test_arith_stress_5.lisp
@@ -0,0 +1,16 @@
+
+(defun apply (f args)
+ (eval (cons f args)))
+
+(defun test-it (n c args res acc)
+ (if (= n 0) acc
+ (progn
+ (define acc (and acc (= (apply c args) res)))
+ (test-it (- n 1) c args res acc))))
+
+(defun arith (a b c d e f g h i j)
+ (+ a b c d e f g h i j))
+
+(def res (test-it 10000 arith '(1i64 2i64 3i64 4i64 5i64 6i64 7i64 8i64 9i64 10i64) 55i64 t))
+
+(check res)
diff --git a/tests/test_arith_stress_6.lisp b/tests/test_arith_stress_6.lisp
new file mode 100644
index 00000000..de61a8a9
--- /dev/null
+++ b/tests/test_arith_stress_6.lisp
@@ -0,0 +1,16 @@
+
+(defun apply (f args)
+ (eval (cons f args)))
+
+(defun test-it (n c args res acc)
+ (if (= n 0) acc
+ (progn
+ (define acc (and acc (= (apply c args) res)))
+ (test-it (- n 1) c args res acc))))
+
+(defun arith (a b c d e f g h i j)
+ (+ a b c d e f g h i j))
+
+(def res (test-it 10000 arith '(1 2 3 4 5 6 7i64 8 9 10) 55i64 t))
+
+(check res)
diff --git a/tests/test_arith_stress_7.lisp b/tests/test_arith_stress_7.lisp
new file mode 100644
index 00000000..6a7214d9
--- /dev/null
+++ b/tests/test_arith_stress_7.lisp
@@ -0,0 +1,27 @@
+
+(defun apply (f args)
+ (eval (cons f args)))
+
+(defun test-it (n c args res acc)
+ (if (= n 0) acc
+ (progn
+ (define acc (and acc (= (apply c args) res)))
+ (test-it (- n 1) c args res acc))))
+
+(defun arith (a b c d e f g h i j)
+ (+ a b c d e f g h i j))
+
+(def res (test-it 10000 arith (list
+ (str-to-i "1")
+ (str-to-i "2")
+ (str-to-i "3")
+ (str-to-i "4")
+ (str-to-i "5")
+ (str-to-i "6")
+ (str-to-i "7")
+ (str-to-i "8")
+ (str-to-i "9")
+ (str-to-i "10"))
+ (str-to-i "55") t))
+
+(check res)
diff --git a/tests/test_flat_unflat_1.lisp b/tests/test_flat_unflat_1.lisp
new file mode 100644
index 00000000..cd5afbaf
--- /dev/null
+++ b/tests/test_flat_unflat_1.lisp
@@ -0,0 +1,4 @@
+
+(define a (flatten '(1 2u32 3i32 3.0)))
+
+(check (eq (unflatten a) '(1 2u32 3i32 3.0)))
diff --git a/tests/test_flat_unflat_2.lisp b/tests/test_flat_unflat_2.lisp
new file mode 100644
index 00000000..9fd2614b
--- /dev/null
+++ b/tests/test_flat_unflat_2.lisp
@@ -0,0 +1,4 @@
+
+(define a (flatten 1))
+
+(check (= (unflatten a) 1))
diff --git a/tests/test_flat_unflat_3.lisp b/tests/test_flat_unflat_3.lisp
new file mode 100644
index 00000000..b0ea8b86
--- /dev/null
+++ b/tests/test_flat_unflat_3.lisp
@@ -0,0 +1,4 @@
+
+(define a (flatten "hej"))
+
+(check (eq (unflatten a) "hej"))
diff --git a/tests/test_flat_unflat_4.lisp b/tests/test_flat_unflat_4.lisp
new file mode 100644
index 00000000..27bdf0fb
--- /dev/null
+++ b/tests/test_flat_unflat_4.lisp
@@ -0,0 +1,6 @@
+
+(define tree '((1 2) (3 4)))
+
+(define a (flatten tree))
+
+(check (eq (unflatten a) tree))
diff --git a/tests/test_flat_unflat_5.lisp b/tests/test_flat_unflat_5.lisp
new file mode 100644
index 00000000..62c3d91f
--- /dev/null
+++ b/tests/test_flat_unflat_5.lisp
@@ -0,0 +1,6 @@
+
+(define tree '(("hello" "kurt") ("russel" "rules")))
+
+(define a (flatten tree))
+
+(check (eq (unflatten a) tree))
diff --git a/tests/test_match_16.lisp b/tests/test_match_16.lisp
new file mode 100644
index 00000000..84eee579
--- /dev/null
+++ b/tests/test_match_16.lisp
@@ -0,0 +1,11 @@
+
+@const-start
+(define f (lambda (ls)
+ (match ls
+ ( nil 0 )
+ ( ( (? c) . (? cd)) (+ c (f c)))
+ ( _ 'error-not-a-list))))
+@const-end
+
+(check (and (eq (f 'kurt) 'error-not-a-list)
+ (eq (f nil) 0)))