diff --git a/lispBM/lispBM/doc/lbmref.md b/lispBM/lispBM/doc/lbmref.md index f8d9f43d..6c7468aa 100644 --- a/lispBM/lispBM/doc/lbmref.md +++ b/lispBM/lispBM/doc/lbmref.md @@ -2,9 +2,9 @@ ## About Symbols -Symbols are very important and fundamental to LispBM and also perhaps +Symbols are very important and central to LispBM and also perhaps a bit different from identifiers/names used in languages such as C, so -a short intro could be good here. +a short intro on symbols could be good here. A symbol can be thought of as a name and can be used to give names to functions or values (variables). A symbol can also be treated and @@ -37,20 +37,20 @@ should not be able to redefine and trying to redefine them leads to an error. Symbols that start with `ext-` are special and reserved for use together with extensions that are loaded and bound at runtime. -Examples of symbols used as data are `nil` and `t`. `nil` is used the -represent nothing, the empty list or other similar things and `t` +Examples of symbols used as data are `nil` and `t`. `nil` representds +"nothing", the empty list or other similar things and `t` represents true. But any symbol can be used as data by quoting it `'`, see Quotes and Quasiquotation . ### Valid symbol names -A symbol is string of characters following the rules: +A symbol is a string of characters following the rules: 1. The first character is a one of 'a' - 'z' or 'A' - 'Z' or '+-*/=<>#!'. 2. The rest of the characters are in 'a' - 'z' or 'A' - 'Z' or '0' - '9' or '+-*/=<>!?_'. 3. At most 256 characters long. -Note that lower-case and upper-case alphabetical letters are considers identical +Note that lower-case and upper-case alphabetical letters are considered identical so the symbol `apa` is the same symbol as `APA`. examples of valid symbols @@ -386,7 +386,7 @@ the argument. ### nil Represents the empty list. The nil value is also considered to be false by -conditionals +conditionals. The example below creates a one element list by allocating a cons cell and putting a value (1) in the car field and nil in the cdr field. @@ -874,7 +874,6 @@ These two programs are thus equivalent: (define a 10) (define b 20) (+ a b)) - ``` And @@ -951,7 +950,7 @@ The code above evaluates to 11.

read-program

 -Parses a string containing multiple sequenced expressed. The resulting list of +Parses a string containing multiple sequenced expressions. The resulting list of expressions can be evaluated as a program using eval-program. The form of a read-program expression is `(read-program string)`. @@ -1170,7 +1169,7 @@ Example that combines to lists. ### ix -Index into a list using the `ix`. the form of an `ix` expression +Index into a list using the `ix` function. The form of an `ix` expression is `(ix list-expr index-expr)`. Indexing starts from 0 and if you index out of bounds the result is nil. Example that evaluates to 2. @@ -1365,9 +1364,9 @@ alist. The form of a `setassoc` expression is `(setassoc alist-expr key-expr val ### bufcreate Create an array of bytes. The -form of an `bufcreate` expression is `(bufcreate size-expr)` +form of a `bufcreate` expression is `(bufcreate size-expr)` -Example that creates a 10 element buffer caled data: +Example that creates a 10 element buffer called data: ```clj (define data (bufcreate 10)) @@ -1672,19 +1671,21 @@ An example that atomically perfoms operations a,b and c. ### exit-ok -The `exit-ok` function terminates the thread in a "successful" way and returnes a result -specified by the programmer. The form of an `exit-ok` expression is `(exit-ok value)`. -If the process that calls `exit-ok` was created using `spawn-trap` a message of the form +The `exit-ok` function terminates the thread in a "successful" way and +returnes a result specified by the programmer. The form of an +`exit-ok` expression is `(exit-ok value)`. If the process that calls +`exit-ok` was created using `spawn-trap` a message of the form `(exit-ok tid value)` is be sent to the parent of this process. --- ### exit-error -The `exit-error` function terminates the thread with an error specified by the programmer. -The form of an `exit-error` expression is `(exit-error err_val)`. If the process that -calls `exit-error` was created using `spawn-trap` a message of the form -`(exit-error tid err_val)` is sent to the parent of this process. +The `exit-error` function terminates the thread with an error +specified by the programmer. The form of an `exit-error` expression +is `(exit-error err_val)`. If the process that calls `exit-error` was +created using `spawn-trap` a message of the form `(exit-error tid +err_val)` is sent to the parent of this process. --- diff --git a/lispBM/lispBM/include/lbm_defines.h b/lispBM/lispBM/include/lbm_defines.h index 46cd5526..308988dc 100644 --- a/lispBM/lispBM/include/lbm_defines.h +++ b/lispBM/lispBM/include/lbm_defines.h @@ -199,102 +199,117 @@ #define SYM_LOOP 0x115 #define SPECIAL_FORMS_END 0x115 +// Fundamental built in operations that take their +// arguments on stack. Fundamentals do not handle +// their own GC and they are not allowed to create +// continuations. +#define SYM_ADD 0x20000 +#define SYM_SUB 0x20001 +#define SYM_MUL 0x20002 +#define SYM_DIV 0x20003 +#define SYM_MOD 0x20004 +#define SYM_EQ 0x20005 +#define SYM_NOT_EQ 0x20006 +#define SYM_NUMEQ 0x20007 +#define SYM_NUM_NOT_EQ 0x20008 +#define SYM_LT 0x20009 +#define SYM_GT 0x2000A +#define SYM_LEQ 0x2000B +#define SYM_GEQ 0x2000C +#define SYM_NOT 0x2000D +#define SYM_PERFORM_GC 0x2000E +#define SYM_SELF 0x2000F +#define SYM_SET_MAILBOX_SIZE 0x20010 +#define SYM_CONS 0x20011 +#define SYM_CAR 0x20012 +#define SYM_CDR 0x20013 +#define SYM_LIST 0x20014 +#define SYM_APPEND 0x20015 +#define SYM_UNDEFINE 0x20016 +#define SYM_ARRAY_CREATE 0x20017 +#define SYM_SYMBOL_TO_STRING 0x20018 +#define SYM_STRING_TO_SYMBOL 0x20019 +#define SYM_SYMBOL_TO_UINT 0x2001A +#define SYM_UINT_TO_SYMBOL 0x2001B +#define SYM_SET_CAR 0x2001C +#define SYM_SET_CDR 0x2001D +#define SYM_SET_IX 0x2001E +#define SYM_ASSOC 0x2001F +#define SYM_ACONS 0x20020 +#define SYM_SET_ASSOC 0x20021 +#define SYM_COSSA 0x20022 +#define SYM_IX 0x20023 +#define SYM_TO_I 0x20024 +#define SYM_TO_I32 0x20025 +#define SYM_TO_U 0x20026 +#define SYM_TO_U32 0x20027 +#define SYM_TO_FLOAT 0x20028 +#define SYM_TO_I64 0x20029 +#define SYM_TO_U64 0x2002A +#define SYM_TO_DOUBLE 0x2002B +#define SYM_TO_BYTE 0x2002C +#define SYM_SHL 0x2002D +#define SYM_SHR 0x2002E +#define SYM_BITWISE_AND 0x2002F +#define SYM_BITWISE_OR 0x20030 +#define SYM_BITWISE_XOR 0x20031 +#define SYM_BITWISE_NOT 0x20032 +#define SYM_CUSTOM_DESTRUCT 0x20033 +#define SYM_TYPE_OF 0x20034 +#define SYM_LIST_LENGTH 0x20035 +#define SYM_RANGE 0x20036 +#define SYM_REG_EVENT_HANDLER 0x20037 +#define SYM_TAKE 0x20038 +#define SYM_DROP 0x20039 + // Apply funs: -// Get their arguments in evaluated form. +// Get their arguments in evaluated form on the stack. // 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 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_FLATTEN 0x15F -#define SYM_UNFLATTEN 0x160 -#define SYM_KILL 0x161 -#define SYM_SLEEP 0x162 -#define SYM_MERGE 0x163 -#define SYM_SORT 0x164 -#define APPLY_FUNS_END 0x164 +// apply funs handle their own GC needs and can +// create continuations. +#define SYM_SETVAR 0x30000 +#define SYM_READ 0x30001 +#define SYM_READ_PROGRAM 0x30002 +#define SYM_READ_AND_EVAL_PROGRAM 0x30003 +#define SYM_SPAWN 0x30004 +#define SYM_SPAWN_TRAP 0x30005 +#define SYM_YIELD 0x30006 +#define SYM_WAIT 0x30007 +#define SYM_EVAL 0x30008 +#define SYM_EVAL_PROGRAM 0x30009 +#define SYM_SEND 0x3000A +#define SYM_EXIT_OK 0x3000B +#define SYM_EXIT_ERROR 0x3000C +#define SYM_MAP 0x3000D +#define SYM_REVERSE 0x3000E +#define SYM_FLATTEN 0x3000F +#define SYM_UNFLATTEN 0x30010 +#define SYM_KILL 0x30011 +#define SYM_SLEEP 0x30012 +#define SYM_MERGE 0x30013 +#define SYM_SORT 0x30014 -#define FUNDAMENTALS_START 0x20E -#define SYM_ADD 0x20E -#define SYM_SUB 0x20F -#define SYM_MUL 0x210 -#define SYM_DIV 0x211 -#define SYM_MOD 0x212 -#define SYM_EQ 0x213 -#define SYM_NOT_EQ 0x214 -#define SYM_NUMEQ 0x215 -#define SYM_NUM_NOT_EQ 0x216 -#define SYM_LT 0x217 -#define SYM_GT 0x218 -#define SYM_LEQ 0x219 -#define SYM_GEQ 0x21A -#define SYM_NOT 0x21B -#define SYM_PERFORM_GC 0x21C -#define SYM_SELF 0x21D -#define SYM_SET_MAILBOX_SIZE 0x21E -#define SYM_CONS 0x21F -#define SYM_CAR 0x220 -#define SYM_CDR 0x221 -#define SYM_LIST 0x222 -#define SYM_APPEND 0x223 -#define SYM_UNDEFINE 0x224 -#define SYM_ARRAY_CREATE 0x225 -#define SYM_SYMBOL_TO_STRING 0x226 -#define SYM_STRING_TO_SYMBOL 0x227 -#define SYM_SYMBOL_TO_UINT 0x228 -#define SYM_UINT_TO_SYMBOL 0x229 -#define SYM_SET_CAR 0x22A -#define SYM_SET_CDR 0x22B -#define SYM_SET_IX 0x22C -#define SYM_ASSOC 0x22D -#define SYM_ACONS 0x22E -#define SYM_SET_ASSOC 0x22F -#define SYM_COSSA 0x230 -#define SYM_IX 0x231 -#define SYM_TO_I 0x232 -#define SYM_TO_I32 0x233 -#define SYM_TO_U 0x234 -#define SYM_TO_U32 0x235 -#define SYM_TO_FLOAT 0x236 -#define SYM_TO_I64 0x237 -#define SYM_TO_U64 0x238 -#define SYM_TO_DOUBLE 0x239 -#define SYM_TO_BYTE 0x23A -#define SYM_SHL 0x23B -#define SYM_SHR 0x23C -#define SYM_BITWISE_AND 0x23D -#define SYM_BITWISE_OR 0x23E -#define SYM_BITWISE_XOR 0x23F -#define SYM_BITWISE_NOT 0x240 -#define SYM_CUSTOM_DESTRUCT 0x241 /* run the destructor of a custom type */ -#define SYM_TYPE_OF 0x242 -#define SYM_LIST_LENGTH 0x243 -#define SYM_RANGE 0x244 -#define SYM_REG_EVENT_HANDLER 0x245 -#define SYM_TAKE 0x246 -#define SYM_DROP 0x247 -#define FUNDAMENTALS_END 0x249 -#define SPECIAL_SYMBOLS_START 0 -#define SPECIAL_SYMBOLS_END 0xFFFF -#define EXTENSION_SYMBOLS_START 0x10000 -#define EXTENSION_SYMBOLS_END 0x1FFFF -#define VARIABLE_SYMBOLS_START 0x20000 -#define VARIABLE_SYMBOLS_END 0x2FFFF -#define RUNTIME_SYMBOLS_START 0x30000 -#define MAX_SYMBOL_VALUE 0x0FFFFFFF +#define SYMBOL_KIND(X) ((X) >> 16) +#define SYMBOL_KIND_SPECIAL 0 +#define SYMBOL_KIND_EXTENSION 1 +#define SYMBOL_KIND_FUNDAMENTAL 2 +#define SYMBOL_KIND_APPFUN 3 + +#define SYMBOL_IX(X) ((X) & 0xFFFF) + +#define SPECIAL_SYMBOLS_START 0 +#define SPECIAL_SYMBOLS_END 0xFFFF +#define EXTENSION_SYMBOLS_START 0x10000 +#define EXTENSION_SYMBOLS_END 0x1FFFF +#define FUNDAMENTAL_SYMBOLS_START 0x20000 +#define FUNDAMENTAL_SYMBOLS_END 0x2FFFF +#define APPFUN_SYMBOLS_START 0x30000 +#define APPFUN_SYMBOLS_END 0x3FFFF +#define RUNTIME_SYMBOLS_START 0x40000 +#define MAX_SYMBOL_VALUE 0x0FFFFFFF + +// This leaves 268173312 runtime symbols available. /* ------------------------------------------------------------ Encoded Symbols diff --git a/lispBM/lispBM/include/symrepr.h b/lispBM/lispBM/include/symrepr.h index 9f7c4a43..de7a1220 100644 --- a/lispBM/lispBM/include/symrepr.h +++ b/lispBM/lispBM/include/symrepr.h @@ -72,20 +72,6 @@ int lbm_add_symbol_flash(char *name, lbm_uint* id); \return 1 for success and 0 for failure. */ int lbm_str_to_symbol(char *name, lbm_uint *sym_id); -/** Add a variable-symbol to the symbol table. The symbol name string is copied to arrays and symbols memory. - * - * \param name String representation of the symbol. - * \param id Resulting id is returned through this argument. - * \return 1 for success and 0 for failure. - */ -int lbm_add_variable_symbol(char *name, lbm_uint* id); -/** Add a variable-symbol to the symbol table. The symbol name is - * considered to be a statically allocated constant. - * \param name String representation of the symbol. - * \param id Resulting id is returned through this argument. - * \return 1 for success and 0 for failure. - */ -int lbm_add_variable_symbol_const(char *name, lbm_uint* id); /** Add a symbol to the symbol table. The name is assumed to be a statically allocated string. * * \param name Statically allocated name string. @@ -113,8 +99,6 @@ int lbm_get_symbol_by_name(char *name, lbm_uint *id); */ const char* lbm_get_name_by_symbol(lbm_uint id); -lbm_uint lbm_get_num_variables(void); - /** * * \return The total amount of lbm_memory space occupied by the symbol table in bytes. diff --git a/lispBM/lispBM/src/eval_cps.c b/lispBM/lispBM/src/eval_cps.c index 10a6760a..844417e9 100644 --- a/lispBM/lispBM/src/eval_cps.c +++ b/lispBM/lispBM/src/eval_cps.c @@ -1,4 +1,4 @@ -/* + /* Copyright 2018, 2020 - 2024 Joel Svensson svenssonjoel@yahoo.se This program is free software: you can redistribute it and/or modify @@ -122,6 +122,24 @@ const char* lbm_error_str_variable_not_bound = "Variable not bound."; static lbm_value lbm_error_suspect; static bool lbm_error_has_suspect = false; +#ifdef LBM_ALWAYS_GC + +#define WITH_GC(y, x) \ + gc(); \ + (y) = (x); \ + if (lbm_is_symbol_merror((y))) { \ + error_ctx(ENC_SYM_MERROR); \ + } + +#define WITH_GC_RMBR_1(y, x, r) \ + lbm_gc_mark_phase(r); \ + gc(); \ + (y) = (x); \ + if (lbm_is_symbol_merror((y))) { \ + error_ctx(ENC_SYM_MERROR); \ + } + +#else #define WITH_GC(y, x) \ (y) = (x); \ @@ -145,6 +163,8 @@ static bool lbm_error_has_suspect = false; /* continue executing statements below */ \ } +#endif + typedef struct { eval_context_t *first; eval_context_t *last; @@ -377,6 +397,17 @@ 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_value roots[3] = {head, tail, remember}; + lbm_gc_mark_roots(roots, 3); + gc(); + lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail); + res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail); + if (lbm_is_symbol_merror(res)) { + error_ctx(ENC_SYM_MERROR); + } + return res; +#else lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail); if (lbm_is_symbol_merror(res)) { lbm_value roots[3] = {head, tail, remember}; @@ -388,6 +419,7 @@ static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember } } return res; +#endif } static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) { @@ -455,8 +487,10 @@ static void stack_push(lbm_stack_t *s, lbm_uint val) { static void stack_push_2(lbm_stack_t *s, lbm_uint v1, lbm_uint v2) { if (s->sp + 1 < s->size) { - s->data[s->sp++] = v1; - s->data[s->sp++] = v2; + lbm_uint *t = &s->data[s->sp]; + t[0] = v1; + t[1] = v2; + s->sp += 2; if (s->sp > s->max_sp) s->max_sp = s->sp; return; } @@ -465,9 +499,11 @@ static void stack_push_2(lbm_stack_t *s, lbm_uint v1, lbm_uint v2) { static void stack_push_3(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3) { if (s->sp + 2 < s->size) { - s->data[s->sp++] = v1; - s->data[s->sp++] = v2; - s->data[s->sp++] = v3; + lbm_uint *t = &s->data[s->sp]; + t[0] = v1; + t[1] = v2; + t[2] = v3; + s->sp += 3; if (s->sp > s->max_sp) s->max_sp = s->sp; return; } @@ -476,10 +512,12 @@ static void stack_push_3(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3) static void stack_push_4(lbm_stack_t *s, lbm_uint v1, lbm_uint v2, lbm_uint v3, lbm_uint v4) { if (s->sp + 3 < s->size) { - s->data[s->sp++] = v1; - s->data[s->sp++] = v2; - s->data[s->sp++] = v3; - s->data[s->sp++] = v4; + lbm_uint *t = &s->data[s->sp]; + t[0] = v1; + t[1] = v2; + t[2] = v3; + t[3] = v4; + s->sp += 4; if (s->sp > s->max_sp) s->max_sp = s->sp; return; } @@ -571,24 +609,34 @@ 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(); + if (lbm_heap_num_free() < 4) { + error_ctx(ENC_SYM_MERROR); + } +#else if (lbm_heap_num_free() < 4) { gc(); if (lbm_heap_num_free() < 4) { error_ctx(ENC_SYM_MERROR); } } +#endif + // The freelist will always contain just plain heap-cells. + // So dec_ptr is sufficient. lbm_value res = lbm_heap_state.freelist; if (lbm_type_of(res) == LBM_TYPE_CONS) { - lbm_cons_t *cell = lbm_ref_cell(res); - cell->car = ENC_SYM_CLOSURE; - cell = lbm_ref_cell(cell->cdr); - cell->car = params; - cell = lbm_ref_cell(cell->cdr); - cell->car = body; - cell = lbm_ref_cell(cell->cdr); - cell->car = env; - lbm_heap_state.freelist = cell->cdr; - cell->cdr = ENC_SYM_NIL; + lbm_cons_t *heap = lbm_heap_state.heap; + lbm_uint ix = lbm_dec_ptr(res); + heap[ix].car = ENC_SYM_CLOSURE; + ix = lbm_dec_ptr(heap[ix].cdr); + heap[ix].car = params; + ix = lbm_dec_ptr(heap[ix].cdr); + heap[ix].car = body; + ix = lbm_dec_ptr(heap[ix].cdr); + heap[ix].car = env; + lbm_heap_state.freelist = heap[ix].cdr; + heap[ix].cdr = ENC_SYM_NIL; lbm_heap_state.num_alloc+=4; } else { error_ctx(ENC_SYM_FATAL_ERROR); @@ -625,7 +673,7 @@ static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg res = fundamental_table[fundamental](args, arg_count, ctx); } if (lbm_is_error(res)) { - error_at_ctx(res, lbm_enc_sym(fundamental+FUNDAMENTALS_START)); + error_at_ctx(res, lbm_enc_sym(EXTENSION_SYMBOLS_START | fundamental)); } } lbm_stack_drop(&ctx->K, arg_count+1); @@ -1536,25 +1584,20 @@ int lbm_perform_gc(void) { static void eval_symbol(eval_context_t *ctx) { lbm_uint s = lbm_dec_sym(ctx->curr_exp); if (s >= RUNTIME_SYMBOLS_START) { - lbm_value res; + lbm_value res = ENC_SYM_NIL; if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) || lbm_global_env_lookup(&res, ctx->curr_exp)) { ctx->r = res; ctx->app_cont = true; return; } - } else if (s <= EXTENSION_SYMBOLS_END) { - //special symbols and extensions can be handled the same way. - ctx->r = ctx->curr_exp; - ctx->app_cont = true; - return; - } - // Dynamic load attempt - const char *sym_str = lbm_get_name_by_symbol(s); - const char *code_str = NULL; - if (!dynamic_load_callback(sym_str, &code_str)) { - error_at_ctx(ENC_SYM_NOT_FOUND, ctx->curr_exp); - } else { + // Dynamic load attempt + // Only symbols of kind RUNTIME can be dynamically loaded. + const char *sym_str = lbm_get_name_by_symbol(s); + const char *code_str = NULL; + if (!dynamic_load_callback(sym_str, &code_str)) { + error_at_ctx(ENC_SYM_NOT_FOUND, ctx->curr_exp); + } stack_push_3(&ctx->K, ctx->curr_exp, ctx->curr_env, RESUME); lbm_value chan; @@ -1575,6 +1618,10 @@ static void eval_symbol(eval_context_t *ctx) { loader), loader); ctx->curr_exp = evaluator; ctx->curr_env = ENC_SYM_NIL; // dynamics should be evaluable in empty local env + } else { + //special symbols and extensions can be handled the same way. + ctx->r = ctx->curr_exp; + ctx->app_cont = true; } } @@ -2701,19 +2748,11 @@ static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_c lbm_value fun = fun_args[0]; lbm_uint fun_val = lbm_dec_sym(fun); - lbm_uint apply_val = fun_val - APPLY_FUNS_START; - lbm_uint fund_val = fun_val - FUNDAMENTALS_START; + lbm_uint fun_kind = SYMBOL_KIND(fun_val); - if (apply_val <= (APPLY_FUNS_END - APPLY_FUNS_START)) { - fun_table[apply_val](&fun_args[1], arg_count, ctx); - } else if (fund_val <= (FUNDAMENTALS_END - FUNDAMENTALS_START)) { - call_fundamental(fund_val, &fun_args[1], arg_count, ctx); - } else { - // It may be an extension - extension_fptr f = lbm_get_extension(fun_val); - if (f == NULL) { - error_at_ctx(ENC_SYM_EERROR,fun); - } + switch (fun_kind) { + case SYMBOL_KIND_EXTENSION: { + extension_fptr f = extension_table[SYMBOL_IX(fun_val)].fptr; lbm_value ext_res; WITH_GC(ext_res, f(&fun_args[1], arg_count)); @@ -2735,6 +2774,16 @@ static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_c ctx->app_cont = true; ctx->r = ext_res; } + } break; + case SYMBOL_KIND_FUNDAMENTAL: + call_fundamental(SYMBOL_IX(fun_val), &fun_args[1], arg_count, ctx); + break; + case SYMBOL_KIND_APPFUN: + fun_table[SYMBOL_IX(fun_val)](&fun_args[1], arg_count, ctx); + break; + default: + error_ctx(ENC_SYM_FATAL_ERROR); + break; } } @@ -2756,20 +2805,20 @@ static void cont_closure_application_args(eval_context_t *ctx) { error_ctx(ENC_SYM_MERROR); } } + lbm_cons_t* heap = lbm_heap_state.heap; lbm_value cell0 = lbm_heap_state.freelist; - lbm_cons_t *cell0_r = lbm_ref_cell(cell0); - lbm_value cell1 = cell0_r->cdr; - lbm_cons_t *cell1_r = lbm_ref_cell(cell1); - lbm_heap_state.freelist = cell1_r->cdr; + lbm_uint cell0_ix = lbm_dec_ptr(cell0); + lbm_value cell1 = heap[cell0_ix].cdr; + lbm_uint cell1_ix = lbm_dec_ptr(cell1); + lbm_heap_state.freelist = heap[cell1_ix].cdr; lbm_heap_state.num_alloc += 2; - cell0_r->car = car_params; - cell0_r->cdr = ctx->r; - cell1_r->car = cell0; - cell1_r->cdr = clo_env; + heap[cell0_ix].car = car_params; + heap[cell0_ix].cdr = ctx->r; + heap[cell1_ix].car = cell0; + heap[cell1_ix].cdr = clo_env; clo_env = cell1; - // TODO: We are NOT going to implement a lazy sweep. bool a_nil = args == ENC_SYM_NIL; bool p_nil = cdr_params == ENC_SYM_NIL; @@ -2910,12 +2959,12 @@ static void cont_if(eval_context_t *ctx) { static void cont_match(eval_context_t *ctx) { lbm_value e = ctx->r; - lbm_value patterns; - lbm_value new_env; - lbm_value orig_env; bool do_gc = false; - lbm_pop_2(&ctx->K, &orig_env, &patterns); // restore enclosing environment - new_env = orig_env; + + lbm_uint *sptr = get_stack_ptr(ctx, 2); + lbm_value patterns = (lbm_value)sptr[0]; + lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment. + lbm_value new_env = orig_env; if (lbm_is_symbol_nil(patterns)) { // no more patterns @@ -2937,8 +2986,6 @@ static void cont_match(eval_context_t *ctx) { bool is_match = match(pattern, e, &new_env, &do_gc); if (do_gc) { - lbm_uint roots[3] = {orig_env, patterns, e}; - lbm_gc_mark_roots(roots, 3); gc(); do_gc = false; new_env = orig_env; @@ -2949,23 +2996,26 @@ static void cont_match(eval_context_t *ctx) { } if (is_match) { if (check_guard) { - lbm_value *sptr = stack_reserve(ctx,7); + lbm_value *rptr = stack_reserve(ctx,5); sptr[0] = get_cdr(patterns); sptr[1] = ctx->curr_env; - sptr[2] = MATCH; - sptr[3] = new_env; - sptr[4] = body; - sptr[5] = e; - sptr[6] = MATCH_GUARD; + rptr[0] = MATCH; + rptr[1] = new_env; + rptr[2] = body; + rptr[3] = e; + rptr[4] = MATCH_GUARD; ctx->curr_env = new_env; ctx->curr_exp = n1; // The guard } else { + lbm_stack_drop(&ctx->K, 2); ctx->curr_env = new_env; ctx->curr_exp = body; } } else { // set up for checking of next pattern - stack_push_3(&ctx->K, get_cdr(patterns),orig_env, MATCH); + sptr[0] = get_cdr(patterns); + sptr[1] = orig_env; + stack_push(&ctx->K, MATCH); // leave r unaltered ctx->app_cont = true; } @@ -3116,12 +3166,11 @@ static void cont_merge_rest(eval_context_t *ctx) { lbm_value cmp_env = sptr[6]; // Environment should be preallocated already at this point // and the operations below should never need GC. - // maybe rewrite this as a more efficient update and - // a fatal error if that is not possible. - lbm_value new_env0; - lbm_value new_env; - WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a))); - WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0); + lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a)); + lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b)); + if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) { + error_ctx(ENC_SYM_FATAL_ERROR); + } cmp_env = new_env; stack_push(&ctx->K, MERGE_REST); @@ -3233,12 +3282,11 @@ static void cont_merge_layer(eval_context_t *ctx) { lbm_value par2 = sptr[3]; // Environment should be preallocated already at this point // and the operations below should never need GC. - // maybe rewrite this as a more efficient update and - // a fatal error if that is not possible. - lbm_value new_env0; - lbm_value new_env; - WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a))); - WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0); + lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a)); + lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b)); + if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) { + error_ctx(ENC_SYM_FATAL_ERROR); + } cmp_env = new_env; lbm_uint *merge_cont = stack_reserve(ctx, 11); @@ -3576,7 +3624,7 @@ static void cont_read_next_token(eval_context_t *ctx) { if (!lbm_lookup_extension_id(ext_name, &ext_id)) { error_ctx(ENC_SYM_FATAL_ERROR); } - symbol_id = ext_id + EXTENSION_SYMBOLS_START; + symbol_id = ext_id; } else { error_ctx(ENC_SYM_MERROR); } @@ -4289,7 +4337,7 @@ lbm_value append(lbm_value front, lbm_value back) { lbm_value t0, t1; - t0 = cons_with_gc(back, ENC_SYM_NIL, ENC_SYM_NIL); + t0 = cons_with_gc(back, ENC_SYM_NIL, front); t1 = cons_with_gc(front, t0, ENC_SYM_NIL); return cons_with_gc(ENC_SYM_APPEND, t1, ENC_SYM_NIL); } @@ -4376,9 +4424,7 @@ static void cont_qq_expand_list(eval_context_t* ctx) { if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL && lbm_dec_sym(car_val) == SYM_COMMA) { lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL, ENC_SYM_NIL); - //WITH_GC(tl, lbm_cons(get_car(cdr_val), ENC_SYM_NIL)); lbm_value tmp = cons_with_gc(ENC_SYM_LIST, tl, ENC_SYM_NIL); - //WITH_GC_RMBR_1(tmp, lbm_cons(ENC_SYM_LIST, tl), tl); ctx->r = append(ctx->r, tmp); ctx->app_cont = true; return; diff --git a/lispBM/lispBM/src/extensions.c b/lispBM/lispBM/src/extensions.c index 869e9345..25035c72 100644 --- a/lispBM/lispBM/src/extensions.c +++ b/lispBM/lispBM/src/extensions.c @@ -25,7 +25,6 @@ #include "extensions.h" -static lbm_uint ext_offset = EXTENSION_SYMBOLS_START; static lbm_uint ext_max = 0; static lbm_uint ext_num = 0; static lbm_uint next_extension_ix = 0; @@ -64,7 +63,7 @@ lbm_uint lbm_get_num_extensions(void) { } extension_fptr lbm_get_extension(lbm_uint sym) { - lbm_uint ext_next = sym - ext_offset; + lbm_uint ext_next = sym - EXTENSION_SYMBOLS_START; if (ext_next >= ext_max) { return NULL; } @@ -72,7 +71,7 @@ extension_fptr lbm_get_extension(lbm_uint sym) { } bool lbm_clr_extension(lbm_uint sym_id) { - lbm_uint ext_id = sym_id - ext_offset; + lbm_uint ext_id = sym_id - EXTENSION_SYMBOLS_START; if (ext_id >= ext_max) { return false; } @@ -85,7 +84,7 @@ bool lbm_lookup_extension_id(char *sym_str, lbm_uint *ix) { for (lbm_uint i = 0; i < ext_max; i ++) { if(extension_table[i].name) { if (strcmp(extension_table[i].name, sym_str) == 0) { - *ix = i; + *ix = i + EXTENSION_SYMBOLS_START; return true; } } @@ -100,9 +99,9 @@ bool lbm_add_extension(char *sym_str, extension_fptr ext) { if (lbm_get_symbol_by_name(sym_str, &symbol)) { if (lbm_is_extension(lbm_enc_sym(symbol))) { // update the extension entry. - if (strcmp(extension_table[symbol - ext_offset].name, sym_str) == 0) { + if (strcmp(extension_table[symbol - EXTENSION_SYMBOLS_START].name, sym_str) == 0) { // Do not replace name ptr. - extension_table[symbol - ext_offset].fptr = ext; + extension_table[symbol - EXTENSION_SYMBOLS_START].fptr = ext; return true; } } diff --git a/lispBM/lispBM/src/heap.c b/lispBM/lispBM/src/heap.c index b35eb279..d6fb1b40 100644 --- a/lispBM/lispBM/src/heap.c +++ b/lispBM/lispBM/src/heap.c @@ -528,19 +528,19 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type, lbm_value car, lbm_value cdr res = lbm_heap_state.freelist; if (lbm_type_of(res) == LBM_TYPE_CONS) { - lbm_cons_t *rc = lbm_ref_cell(res); - lbm_heap_state.freelist = rc->cdr; + lbm_uint heap_ix = lbm_dec_ptr(res); + //lbm_cons_t *rc = lbm_ref_cell(res); + lbm_heap_state.freelist = lbm_heap_state.heap[heap_ix].cdr; lbm_heap_state.num_alloc++; - rc->car = car; - rc->cdr = cdr; - + lbm_heap_state.heap[heap_ix].car = car; + lbm_heap_state.heap[heap_ix].cdr = cdr; res = lbm_set_ptr_type(res, ptr_type); return res; } - else if ((lbm_type_of(lbm_heap_state.freelist) == LBM_TYPE_SYMBOL) && - (lbm_dec_sym(lbm_heap_state.freelist) == SYM_NIL)) { + else if ((lbm_type_of(res) == LBM_TYPE_SYMBOL) && + (lbm_dec_sym(res) == SYM_NIL)) { // all is as it should be (but no free cells) return ENC_SYM_MERROR; } @@ -691,6 +691,7 @@ void lbm_gc_mark_phase(lbm_value root) { } #else +extern eval_context_t *ctx_running; void lbm_gc_mark_phase(lbm_value root) { lbm_stack_t *s = &lbm_heap_state.gc_stack; @@ -867,7 +868,6 @@ int lbm_gc_sweep_phase(void) { lbm_heap_state.gc_recovered ++; } } - return 1; } @@ -1152,7 +1152,6 @@ int lbm_heap_allocate_array(lbm_value *res, lbm_uint size){ // Convert a C array into an lbm_array. // if the array is in LBM_MEMORY, the lifetime will be managed by the GC. -// TODO: Use lbm_malloc for header data int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt) { lbm_array_header_t *array = NULL; @@ -1165,13 +1164,15 @@ int lbm_lift_array(lbm_value *value, char *data, lbm_uint num_elt) { array = (lbm_array_header_t*)lbm_malloc(sizeof(lbm_array_header_t)); - if (array == NULL) return 0; + if (array == NULL) { + *value = ENC_SYM_MERROR; + return 0; + } array->data = (lbm_uint*)data; array->size = num_elt; lbm_set_car(cell, (lbm_uint)array); - //lbm_set_cdr(cell, lbm_enc_sym(SYM_ARRAY_TYPE)); cell = lbm_set_ptr_type(cell, LBM_TYPE_ARRAY); *value = cell; diff --git a/lispBM/lispBM/src/symrepr.c b/lispBM/lispBM/src/symrepr.c index af3876ac..054c86fa 100644 --- a/lispBM/lispBM/src/symrepr.c +++ b/lispBM/lispBM/src/symrepr.c @@ -1,5 +1,5 @@ /* - Copyright 2018, 2021 2022 Joel Svensson svenssonjoel@yahoo.se + Copyright 2018, 2021, 2022, 2024 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 @@ -227,7 +227,6 @@ special_sym const special_symbols[] = { static lbm_uint *symlist = NULL; static lbm_uint next_symbol_id = RUNTIME_SYMBOLS_START; -static lbm_uint next_variable_symbol_id = VARIABLE_SYMBOLS_START; static lbm_uint symbol_table_size_list = 0; static lbm_uint symbol_table_size_list_flash = 0; static lbm_uint symbol_table_size_strings = 0; @@ -239,7 +238,6 @@ lbm_value symbol_y = ENC_SYM_NIL; int lbm_symrepr_init(void) { symlist = NULL; next_symbol_id = RUNTIME_SYMBOLS_START; - next_variable_symbol_id = VARIABLE_SYMBOLS_START; symbol_table_size_list = 0; symbol_table_size_list_flash = 0; symbol_table_size_strings = 0; @@ -277,21 +275,28 @@ const char *lookup_symrepr_name_memory(lbm_uint id) { // Lookup symbol name given a symbol id const char *lbm_get_name_by_symbol(lbm_uint id) { - if (id < SPECIAL_SYMBOLS_END) { + lbm_uint sym_kind = SYMBOL_KIND(id); + switch (sym_kind) { + case SYMBOL_KIND_SPECIAL: /* fall through */ + case SYMBOL_KIND_FUNDAMENTAL: + case SYMBOL_KIND_APPFUN: for (unsigned int i = 0; i < NUM_SPECIAL_SYMBOLS; i ++) { if (id == special_symbols[i].id) { return (special_symbols[i].name); } } return NULL; - } else if (id - EXTENSION_SYMBOLS_START < EXTENSION_SYMBOLS_END) { + break; + case SYMBOL_KIND_EXTENSION: { unsigned int ext_id = id - EXTENSION_SYMBOLS_START; if (ext_id < lbm_get_max_extensions()) { - return extension_table[ext_id].name; + return extension_table[ext_id].name; } return NULL; + } break; + default: + return lookup_symrepr_name_memory(id); } - return lookup_symrepr_name_memory(id); } lbm_uint *lbm_get_symbol_list_entry_by_name(char *name) { @@ -465,10 +470,6 @@ lbm_uint lbm_get_symbol_table_size_names_flash(void) { return symbol_table_size_strings_flash * sizeof(lbm_uint); } -lbm_uint lbm_get_num_variables(void) { - return next_variable_symbol_id - VARIABLE_SYMBOLS_START; -} - bool lbm_symbol_in_flash(char *str) { return !lbm_memory_ptr_inside((lbm_uint*)str); } diff --git a/lispBM/lispBM/tests/Makefile b/lispBM/lispBM/tests/Makefile index 17143b27..50e88028 100644 --- a/lispBM/lispBM/tests/Makefile +++ b/lispBM/lispBM/tests/Makefile @@ -17,6 +17,11 @@ OBJ = obj SOURCES = $(wildcard *.c) EXECS = $(patsubst %.c, %.exe, $(SOURCES)) +gc: CCFLAGS += -m32 -DLBM_ALWAYS_GC +gc: $(EXECS) + mv test_lisp_code_cps.exe test_lisp_code_cps + + all: CCFLAGS += -m32 all: $(EXECS) mv test_lisp_code_cps.exe test_lisp_code_cps diff --git a/lispBM/lispBM/tests/run_tests_gc.sh b/lispBM/lispBM/tests/run_tests_gc.sh new file mode 100755 index 00000000..2f08327a --- /dev/null +++ b/lispBM/lispBM/tests/run_tests_gc.sh @@ -0,0 +1,147 @@ +#!/bin/bash + +echo "BUILDING" + +make clean +make gc + +echo "PERFORMING TESTS:" + +expected_fails=("test_lisp_code_cps -t 360 -h 1024 test_take_iota_0.lisp" + "test_lisp_code_cps -t 360 -s -h 1024 test_take_iota_0.lisp" + "test_lisp_code_cps -t 360 -h 512 test_take_iota_0.lisp" + "test_lisp_code_cps -t 360 -s -h 512 test_take_iota_0.lisp" + "test_lisp_code_cps -t 360 -i -h 1024 test_take_iota_0.lisp" + "test_lisp_code_cps -t 360 -i -s -h 1024 test_take_iota_0.lisp" + "test_lisp_code_cps -t 360 -i -h 512 test_take_iota_0.lisp" + "test_lisp_code_cps -t 360 -i -s -h 512 test_take_iota_0.lisp" + ) + + +success_count=0 +fail_count=0 +failing_tests=() +result=0 + +for exe in *.exe; do + + if [ "$exe" = "test_gensym.exe" ]; then + continue + fi + + ./$exe + + result=$? + + echo "------------------------------------------------------------" + if [ $result -eq 1 ] + then + success_count=$((success_count+1)) + echo $exe SUCCESS + else + + fail_count=$((fail_count+1)) + echo $exe FAILED + fi + echo "------------------------------------------------------------" +done + +test_config=("-t 360 -h 32768" + "-t 360 -i -h 32768" + "-t 360 -s -h 32768" + "-t 360 -i -s -h 32768" + "-t 360 -h 16384" + "-t 360 -i -h 16384" + "-t 360 -s -h 16384" + "-t 360 -i -s -h 16384" + "-t 360 -h 8192" + "-t 360 -i -h 8192" + "-t 360 -s -h 8192" + "-t 360 -i -s -h 8192" + "-t 360 -h 4096" + "-t 360 -i -h 4096" + "-t 360 -s -h 4096" + "-t 360 -i -s -h 4096" + "-t 360 -h 2048" + "-t 360 -i -h 2048" + "-t 360 -s -h 2048" + "-t 360 -i -s -h 2048" + "-t 360 -h 1024" + "-t 360 -i -h 1024" + "-t 360 -s -h 1024" + "-t 360 -i -s -h 1024" + "-t 360 -h 512" + "-t 360 -i -h 512" + "-t 360 -s -h 512" + "-t 360 -i -s -h 512") + +#"test_lisp_code_cps_nc" +for prg in "test_lisp_code_cps" ; do + for arg in "${test_config[@]}"; do + for lisp in *.lisp; do + + ./$prg $arg $lisp + + result=$? + + echo "------------------------------------------------------------" + #echo $arg + if [ $result -eq 1 ] + then + success_count=$((success_count+1)) + echo $lisp SUCCESS + else + + #!/bin/bash + # foo=('foo bar' 'foo baz' 'bar baz') + # bar=$(printf ",%s" "${foo[@]}") + # bar=${bar:1} + + # echo $bar + str=$(printf "%s " "$prg $arg $lisp") + #echo $str + + failing_tests+=("$prg $arg $lisp") + fail_count=$((fail_count+1)) + #echo $failing_tests + + echo $lisp FAILED + fi + echo "------------------------------------------------------------" + done + done +done + +# echo -e $failing_tests + +expected_count=0 + +for (( i = 0; i < ${#failing_tests[@]}; i++ )) +do + expected=false + for (( j = 0; j < ${#expected_fails[@]}; j++)) + do + + if [[ "${failing_tests[$i]}" == "${expected_fails[$j]}" ]] ; + then + expected=true + fi + done + if $expected ; then + expected_count=$((expected_count+1)) + echo "(OK - expected to fail)" ${failing_tests[$i]} + else + echo "(FAILURE)" ${failing_tests[$i]} + fi +done + + +echo Tests passed: $success_count +echo Tests failed: $fail_count +echo Expected fails: $expected_count +echo Actual fails: $((fail_count - expected_count)) + +if [ $((fail_count - expected_count)) -gt 0 ] +then + exit 1 +fi diff --git a/lispBM/lispBM/tests/test_lisp_code_cps.c b/lispBM/lispBM/tests/test_lisp_code_cps.c index 40647c06..8b401332 100644 --- a/lispBM/lispBM/tests/test_lisp_code_cps.c +++ b/lispBM/lispBM/tests/test_lisp_code_cps.c @@ -49,6 +49,7 @@ lbm_extension_t extensions[EXTENSION_STORAGE_SIZE]; lbm_uint constants_memory[CONSTANT_MEMORY_SIZE]; +static uint32_t timeout = 10; void const_heap_init(void) { for (int i = 0; i < CONSTANT_MEMORY_SIZE; i ++) { @@ -338,6 +339,7 @@ LBM_EXTENSION(ext_check, args, argn) { } int res = lbm_print_value(output, 128, t); + printf("Checking result value: %s\n", output); if (checks == 2) { experiment_done = true; @@ -401,8 +403,11 @@ int main(int argc, char **argv) { int c; opterr = 1; - while (( c = getopt(argc, argv, "igsch:")) != -1) { + while (( c = getopt(argc, argv, "igsch:t:")) != -1) { switch (c) { + case 't': + timeout = (uint32_t)atoi((char *)optarg); + break; case 'h': heap_size = (unsigned int)atoi((char *)optarg); break; @@ -752,15 +757,19 @@ int main(int argc, char **argv) { } } printf("Program loaded\n"); - int i = 0; + uint32_t i = 0; + bool timed_out = false; while (!experiment_done) { - if (i == 10000) break; + if (i >= timeout * 1000) { + timed_out = true; + break; + } sleep_callback(1000); i ++; } - if (i == 10000) { - printf ("experiment failed due to taking longer than 10 seconds\n"); + if (timed_out) { + printf ("experiment failed due to taking longer than %u seconds\n", timeout); experiment_success = false; return FAIL; } @@ -778,6 +787,7 @@ int main(int argc, char **argv) { free(heap_storage); printf("Experiment done: "); + printf("Check was executed %u times\n", checks); if (experiment_success) { printf("SUCCESS\n"); return 1; diff --git a/lispBM/lispBM/tests/test_match_guard_10.lisp b/lispBM/lispBM/tests/test_match_guard_10.lisp new file mode 100644 index 00000000..fb87e7dd --- /dev/null +++ b/lispBM/lispBM/tests/test_match_guard_10.lisp @@ -0,0 +1,19 @@ + +(defun larger ( x ) { + (gc) + (> x 10) + }) + +(defun smaller ( x ) { + (gc) + (< x 10) + }) + +(defun f (x) + (match x + ( ((? x) . ((? y) . _)) (smaller x) (list y 'smaller)) + ( ((? x) . ((? y) . _)) (larger x) (list y 'larger)) + ( _ 'whatever))) + +(check (and (eq (f '(0 1 2 3)) '(1 smaller)) + (eq (f '(11 9 8 7)) '(9 larger)))) diff --git a/lispBM/lispBM/tests/test_match_guard_11.lisp b/lispBM/lispBM/tests/test_match_guard_11.lisp new file mode 100644 index 00000000..6006460c --- /dev/null +++ b/lispBM/lispBM/tests/test_match_guard_11.lisp @@ -0,0 +1,21 @@ + +(defun larger ( x ) { + (gc) + (> x 10) + }) + +(defun smaller ( x ) { + (gc) + (< x 10) + }) + +(defun f (x) + (atomic + (var z "apa") + (match x + ( ((? x) . ((? y) . _)) (smaller z) (list y 'smaller)) + ( ((? x) . ((? y) . _)) (larger z) (list y 'larger)) + ( _ 'whatever)))) + +(check (and (eq (f '(0 1 2 3)) 'whatever) + (eq (f '(11 9 8 7)) 'whatever)))