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)))