From 219f29dd7a2215ce74919a8e5dcc45723ebddbed Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Sun, 2 Oct 2022 23:17:59 +0200 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from be53df12..82dd1b77 82dd1b77 removing old broken macro-expansion routine b888dc8e various tweaks and de-inlinings of functions git-subtree-dir: lispBM/lispBM git-subtree-split: 82dd1b77135220091118162c9032009948e6a4d8 --- include/heap.h | 210 ++++++++++++----------------------------- include/lbm_defines.h | 14 ++- src/eval_cps.c | 170 ++++++++++++--------------------- src/heap.c | 213 ++++++++++++++++++++++++++++++++++++------ src/symrepr.c | 1 - 5 files changed, 311 insertions(+), 297 deletions(-) diff --git a/include/heap.h b/include/heap.h index f5bd593f..11754eaf 100644 --- a/include/heap.h +++ b/include/heap.h @@ -317,7 +317,7 @@ char *lbm_dec_str(lbm_value val); */ lbm_char_channel_t *lbm_dec_channel(lbm_value val); /** Decode an lbm_value representing a custom type into a lbm_uint value. - * + * * \param val Value. * \return The custom type payload. */ @@ -542,99 +542,41 @@ static inline lbm_value lbm_enc_u(lbm_uint x) { return (x << LBM_VAL_SHIFT) | LBM_TYPE_U; } -static inline lbm_value lbm_enc_i32(int32_t x) { -#ifndef LBM64 - lbm_value i = lbm_cons((lbm_uint)x, lbm_enc_sym(SYM_RAW_I_TYPE)); - if (lbm_type_of(i) == LBM_TYPE_SYMBOL) return i; - return lbm_set_ptr_type(i, LBM_TYPE_I32); -#else - return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_I32; -#endif -} +/** Encode 32 bit integer into an lbm_value. + * \param x Value to encode. + * \return result encoded value. + */ +extern lbm_value lbm_enc_i32(int32_t x); -static inline lbm_value lbm_enc_u32(uint32_t x) { -#ifndef LBM64 - lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE)); - if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u; - return lbm_set_ptr_type(u, LBM_TYPE_U32); -#else - return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_U32; -#endif -} +/** Encode 32 bit unsigned integer into an lbm_value. + * \param x Value to encode. + * \return result encoded value. + */ +extern lbm_value lbm_enc_u32(uint32_t x); -static inline lbm_value lbm_enc_float(float x) { -#ifndef LBM64 - lbm_uint t; - memcpy(&t, &x, sizeof(lbm_float)); - lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE)); - if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f; - return lbm_set_ptr_type(f, LBM_TYPE_FLOAT); -#else - uint32_t t; - memcpy(&t, &x, sizeof(float)); /*TODO: Assumes something about storage here ?*/ - return (((lbm_uint)t) << LBM_VAL_SHIFT) | LBM_TYPE_FLOAT; -#endif -} +/** Encode a float into an lbm_value. + * \param x float value to encode. + * \return result encoded value. + */ +extern lbm_value lbm_enc_float(float x); -static inline lbm_value lbm_enc_i64(int64_t x) { -#ifndef LBM64 - lbm_value res = lbm_enc_sym(SYM_MERROR); - lbm_uint* storage = lbm_memory_allocate(2); - if (storage) { - res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_I_TYPE)); - if (lbm_type_of(res) != LBM_TYPE_SYMBOL) { - memcpy(storage,&x, 8); - res = lbm_set_ptr_type(res, LBM_TYPE_I64); - } - } - return res; -#else - lbm_value u = lbm_cons((uint64_t)x, lbm_enc_sym(SYM_RAW_I_TYPE)); - if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u; - return lbm_set_ptr_type(u, LBM_TYPE_I64); -#endif -} +/** Encode a 64 bit integer into an lbm_value. + * \param x 64 bit integer to encode. + * \return result encoded value. + */ +extern lbm_value lbm_enc_i64(int64_t x); -static inline lbm_value lbm_enc_u64(uint64_t x) { -#ifndef LBM64 - lbm_value res = lbm_enc_sym(SYM_MERROR); - lbm_uint* storage = lbm_memory_allocate(2); - if (storage) { - res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_U_TYPE)); - if (lbm_type_of(res) != LBM_TYPE_SYMBOL) { - memcpy(storage,&x, 8); - res = lbm_set_ptr_type(res, LBM_TYPE_U64); - } - } - return res; -#else - lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE)); - if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u; - return lbm_set_ptr_type(u, LBM_TYPE_U64); -#endif -} - -static inline lbm_value lbm_enc_double(double x) { -#ifndef LBM64 - lbm_value res = lbm_enc_sym(SYM_MERROR); - lbm_uint* storage = lbm_memory_allocate(2); - if (storage) { - res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_F_TYPE)); - if (lbm_type_of(res) != LBM_TYPE_SYMBOL) { - memcpy(storage,&x, 8); - res = lbm_set_ptr_type(res, LBM_TYPE_DOUBLE); - } - } - return res; -#else - lbm_uint t; - memcpy(&t, &x, sizeof(lbm_float)); - lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE)); - if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f; - return lbm_set_ptr_type(f, LBM_TYPE_DOUBLE); -#endif -} +/** Encode a 64 bit unsigned integer into an lbm_value. + * \param x 64 bit unsigned integer to encode. + * \return result encoded value. + */ +extern lbm_value lbm_enc_u64(uint64_t x); +/** Encode a double into an lbm_value. + * \param x double to encode. + * \return result encoded value. + */ +extern lbm_value lbm_enc_double(double x); static inline lbm_value lbm_enc_char(char x) { return ((lbm_uint)x << LBM_VAL_SHIFT) | LBM_TYPE_CHAR; @@ -656,34 +598,18 @@ static inline lbm_uint lbm_dec_sym(lbm_value x) { return x >> LBM_VAL_SHIFT; } -static inline float lbm_dec_float(lbm_value x) { -#ifndef LBM64 - float f_tmp; - lbm_uint tmp = lbm_car(x); - memcpy(&f_tmp, &tmp, sizeof(float)); - return f_tmp; -#else - uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT); - float f_tmp; - memcpy(&f_tmp, &tmp, sizeof(float)); - return f_tmp; -#endif -} +/** Decode an lbm_value representing a float. + * \param x Value to decode. + * \return decoded float. + */ +extern float lbm_dec_float(lbm_value x); + +/** Decode an lbm_value representing a double. + * \param x Value to decode. + * \return decoded float. + */ +extern double lbm_dec_double(lbm_value x); -static inline double lbm_dec_double(lbm_value x) { -#ifndef LBM64 - double d; - uint32_t *data = (uint32_t*)lbm_car(x); - if (data == NULL) return 0; // no good way to report error from here currently. - memcpy(&d, data, sizeof(double)); - return d; -#else - double f_tmp; - lbm_uint tmp = lbm_car(x); - memcpy(&f_tmp, &tmp, sizeof(double)); - return f_tmp; -#endif -} static inline uint32_t lbm_dec_u32(lbm_value x) { #ifndef LBM64 @@ -693,17 +619,11 @@ static inline uint32_t lbm_dec_u32(lbm_value x) { #endif } -static inline uint64_t lbm_dec_u64(lbm_value x) { -#ifndef LBM64 - uint64_t u; - uint32_t *data = (uint32_t*)lbm_car(x); - if (data == NULL) return 0; - memcpy(&u, data, 8); - return u; -#else - return (uint64_t)lbm_car(x); -#endif -} +/** Decode an lbm_value representing a 64 bit unsigned integer. + * \param x Value to decode. + * \return decoded uint64_t. + */ +extern uint64_t lbm_dec_u64(lbm_value x); static inline int32_t lbm_dec_i32(lbm_value x) { #ifndef LBM64 @@ -713,18 +633,11 @@ static inline int32_t lbm_dec_i32(lbm_value x) { #endif } -static inline int64_t lbm_dec_i64(lbm_value x) { -#ifndef LBM64 - int64_t i; - uint32_t *data = (uint32_t*)lbm_car(x); - if (data == NULL) return 0; - memcpy(&i, data, 8); - return i; -#else - return (int64_t)lbm_car(x); -#endif -} - +/** Decode an lbm_value representing a 64 bit integert. + * \param x Value to decode. + * \return decoded int64_t. + */ +extern int64_t lbm_dec_i64(lbm_value x); static inline lbm_value lbm_set_gc_mark(lbm_value x) { return x | LBM_GC_MARKED; @@ -746,18 +659,11 @@ static inline bool lbm_is_list(lbm_value x) { return (lbm_type_of(x) == LBM_TYPE_CONS); } -static inline bool lbm_is_number(lbm_value x) { - lbm_uint t = lbm_type_of(x); - return ((t == LBM_TYPE_I) || - (t == LBM_TYPE_U) || - (t == LBM_TYPE_CHAR) || - (t == LBM_TYPE_I32) || - (t == LBM_TYPE_U32) || - (t == LBM_TYPE_I64) || - (t == LBM_TYPE_U64) || - (t == LBM_TYPE_FLOAT) || - (t == LBM_TYPE_DOUBLE)); -} +/** Check if a value represents a number + * \param x Value to check. + * \return true is x represents a number and false otherwise. + */ +extern bool lbm_is_number(lbm_value x); static inline bool lbm_is_array(lbm_value x) { return (lbm_type_of(x) == LBM_TYPE_ARRAY && @@ -811,7 +717,7 @@ static inline bool lbm_is_match_binder(lbm_value exp) { (lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I32) || (lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_U32) || (lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_FLOAT) || - (lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I64) || + (lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I64) || (lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_U64) || (lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_DOUBLE) || (lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_CONS))); diff --git a/include/lbm_defines.h b/include/lbm_defines.h index 38007475..84434791 100644 --- a/include/lbm_defines.h +++ b/include/lbm_defines.h @@ -28,12 +28,12 @@ #define LBM_POINTER_TYPE_FIRST 0x10000000u #define LBM_TYPE_CONS 0x10000000u #define LBM_NON_CONS_POINTER_TYPE_FIRST 0x20000000u -#define LBM_TYPE_U32 0x20000000u -#define LBM_TYPE_I32 0x30000000u -#define LBM_TYPE_I64 0x40000000u -#define LBM_TYPE_U64 0x50000000u -#define LBM_TYPE_FLOAT 0x60000000u -#define LBM_TYPE_DOUBLE 0x70000000u +#define LBM_TYPE_U32 0x28000000u +#define LBM_TYPE_I32 0x38000000u +#define LBM_TYPE_I64 0x48000000u +#define LBM_TYPE_U64 0x58000000u +#define LBM_TYPE_FLOAT 0x68000000u +#define LBM_TYPE_DOUBLE 0x78000000u #define LBM_TYPE_ARRAY 0x80000000u #define LBM_TYPE_REF 0x90000000u #define LBM_TYPE_CHANNEL 0xA0000000u @@ -94,7 +94,6 @@ #define SYM_NIL 0x0 #define SYM_TRUE 0x2 #define SYM_DONTCARE 0x9 -#define SYM_MACRO_EXPAND 0xD // Consecutive value symbols for lookup-application #define APPLY_FUNS_START 0x10 @@ -307,7 +306,6 @@ #define ENC_SYM_CONT ((SYM_CONT << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL) #define ENC_SYM_CLOSURE ((SYM_CLOSURE << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL) #define ENC_SYM_MACRO ((SYM_MACRO << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL) -#define ENC_SYM_MACRO_EXPAND ((SYM_MACRO_EXPAND << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL) #define ENC_SYM_SETVAR ((SYM_SETVAR << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL) #define ENC_SYM_EXIT_OK ((SYM_EXIT_OK << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL) #define ENC_SYM_EXIT_ERROR ((SYM_EXIT_ERROR << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL) diff --git a/src/eval_cps.c b/src/eval_cps.c index a3eabbda..280f600d 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -36,38 +36,37 @@ #include "heap_vis.h" #endif -#define DONE ((0 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define SET_GLOBAL_ENV ((1 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define BIND_TO_KEY_REST ((2 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define IF ((3 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define PROGN_REST ((4 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define APPLICATION ((5 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define APPLICATION_ARGS ((6 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define AND ((7 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define OR ((8 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define WAIT ((9 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define MATCH ((10 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define MATCH_MANY ((11 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ ((12 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define APPLICATION_START ((13 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define EVAL_R ((14 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define SET_VARIABLE ((15 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define RESUME ((16 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define EXPAND_MACRO ((17 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define CLOSURE_ARGS ((18 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define EXIT_ATOMIC ((19 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_NEXT_TOKEN ((20 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_APPEND_CONTINUE ((21 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_EXPECT_CLOSEPAR ((22 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_DOT_TERMINATE ((23 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_DONE ((24 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_QUOTE_RESULT ((25 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_BACKQUOTE_RESULT ((26 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_COMMAAT_RESULT ((27 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_COMMA_RESULT ((28 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_START_ARRAY ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define READ_APPEND_ARRAY ((30 << LBM_VAL_SHIFT) | LBM_TYPE_U) -#define NUM_CONTINUATIONS 31 +#define DONE ((0 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define SET_GLOBAL_ENV ((1 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define BIND_TO_KEY_REST ((2 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define IF ((3 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define PROGN_REST ((4 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define APPLICATION ((5 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define APPLICATION_ARGS ((6 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define AND ((7 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define OR ((8 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define WAIT ((9 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define MATCH ((10 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define MATCH_MANY ((11 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ ((12 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define APPLICATION_START ((13 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define EVAL_R ((14 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define SET_VARIABLE ((15 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define RESUME ((16 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define CLOSURE_ARGS ((17 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define EXIT_ATOMIC ((18 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_NEXT_TOKEN ((19 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_APPEND_CONTINUE ((20 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_EXPECT_CLOSEPAR ((21 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_DOT_TERMINATE ((22 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_DONE ((23 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_QUOTE_RESULT ((24 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_BACKQUOTE_RESULT ((25 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_COMMAAT_RESULT ((26 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_COMMA_RESULT ((27 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_START_ARRAY ((28 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define READ_APPEND_ARRAY ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U) +#define NUM_CONTINUATIONS 30 static const char* parse_error_eof = "End of parse stream"; static const char* parse_error_token = "Malformed token"; @@ -101,7 +100,7 @@ static int gc(void); static void error_ctx(lbm_value); static eval_context_t *ctx_running = NULL; -static inline lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) { +static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) { lbm_value res = lbm_cons(head, tail); if (lbm_is_symbol_merror(res)) { lbm_gc_mark_phase(remember); @@ -1160,7 +1159,7 @@ int lbm_perform_gc(void) { /****************************************************/ /* Evaluation functions */ -static inline bool eval_symbol(eval_context_t *ctx, lbm_value *value) { +static bool eval_symbol(eval_context_t *ctx, lbm_value *value) { lbm_uint s = lbm_dec_sym(ctx->curr_exp); if (s < SPECIAL_SYMBOLS_END || @@ -1183,7 +1182,7 @@ static inline bool eval_symbol(eval_context_t *ctx, lbm_value *value) { } } -static inline void dynamic_load(eval_context_t *ctx) { +static void dynamic_load(eval_context_t *ctx) { const char *sym_str = lbm_get_name_by_symbol(lbm_dec_sym(ctx->curr_exp)); const char *code_str = NULL; @@ -1213,18 +1212,18 @@ static inline void dynamic_load(eval_context_t *ctx) { } -static inline void eval_quote(eval_context_t *ctx) { +static void eval_quote(eval_context_t *ctx) { ctx->r = lbm_cadr(ctx->curr_exp); ctx->app_cont = true; } -static inline void eval_selfevaluating(eval_context_t *ctx) { +static void eval_selfevaluating(eval_context_t *ctx) { ctx->r = ctx->curr_exp; ctx->app_cont = true; } -static inline void eval_atomic(eval_context_t *ctx) { +static void eval_atomic(eval_context_t *ctx) { if (is_atomic) { lbm_set_error_reason("Atomic blocks cannot be nested!"); error_ctx(ENC_SYM_EERROR); @@ -1238,7 +1237,7 @@ static inline void eval_atomic(eval_context_t *ctx) { } -static inline void eval_callcc(eval_context_t *ctx) { +static void eval_callcc(eval_context_t *ctx) { lbm_value cont_array; #ifndef LBM64 @@ -1275,7 +1274,7 @@ static inline void eval_callcc(eval_context_t *ctx) { ctx->app_cont = false; } -static inline void eval_define(eval_context_t *ctx) { +static void eval_define(eval_context_t *ctx) { lbm_value args = lbm_cdr(ctx->curr_exp); lbm_value key = lbm_car(args); lbm_value rest_args = lbm_cdr(args); @@ -1307,7 +1306,7 @@ static inline void eval_define(eval_context_t *ctx) { return; } -static inline void eval_progn(eval_context_t *ctx) { +static void eval_progn(eval_context_t *ctx) { lbm_value exps = lbm_cdr(ctx->curr_exp); lbm_value env = ctx->curr_env; @@ -1332,21 +1331,21 @@ static inline void eval_progn(eval_context_t *ctx) { } } -static inline lbm_value mk_closure(lbm_value env, lbm_value body, lbm_value params) { +static lbm_value mk_closure(lbm_value env, lbm_value body, lbm_value params) { lbm_value env_end = cons_with_gc( env, ENC_SYM_NIL, env); lbm_value exp = cons_with_gc(body, env_end, env_end); lbm_value par = cons_with_gc(params, exp, exp); return cons_with_gc(ENC_SYM_CLOSURE, par, par); } -static inline void eval_lambda(eval_context_t *ctx) { +static void eval_lambda(eval_context_t *ctx) { lbm_value closure = mk_closure(ctx->curr_env, lbm_cadr(lbm_cdr(ctx->curr_exp)), lbm_cadr(ctx->curr_exp)); ctx->app_cont = true; ctx->r = closure; return; } -static inline void eval_if(eval_context_t *ctx) { +static void eval_if(eval_context_t *ctx) { lbm_value cddr = lbm_cdr(lbm_cdr(ctx->curr_exp)); lbm_value then_branch = lbm_car(cddr); @@ -1364,7 +1363,7 @@ static inline void eval_if(eval_context_t *ctx) { ctx->curr_exp = lbm_cadr(ctx->curr_exp); } -static inline void eval_let(eval_context_t *ctx) { +static void eval_let(eval_context_t *ctx) { lbm_value orig_env = ctx->curr_env; lbm_value binds = lbm_cadr(ctx->curr_exp); // key value pairs. lbm_value exp = lbm_cadr(lbm_cdr(ctx->curr_exp)); // exp to evaluate in the new env. @@ -1408,7 +1407,7 @@ static inline void eval_let(eval_context_t *ctx) { return; } -static inline void eval_and(eval_context_t *ctx) { +static void eval_and(eval_context_t *ctx) { lbm_value rest = lbm_cdr(ctx->curr_exp); if (lbm_is_symbol_nil(rest)) { ctx->app_cont = true; @@ -1419,7 +1418,7 @@ static inline void eval_and(eval_context_t *ctx) { } } -static inline void eval_or(eval_context_t *ctx) { +static void eval_or(eval_context_t *ctx) { lbm_value rest = lbm_cdr(ctx->curr_exp); if (lbm_is_symbol_nil(rest)) { ctx->app_cont = true; @@ -1435,7 +1434,7 @@ static inline void eval_or(eval_context_t *ctx) { /* (match e (pattern body) */ /* (pattern body) */ /* ... ) */ -static inline void eval_match(eval_context_t *ctx) { +static void eval_match(eval_context_t *ctx) { lbm_value rest = lbm_cdr(ctx->curr_exp); if (lbm_type_of(rest) == LBM_TYPE_SYMBOL && @@ -1450,7 +1449,7 @@ static inline void eval_match(eval_context_t *ctx) { } } -static inline void eval_receive(eval_context_t *ctx) { +static void eval_receive(eval_context_t *ctx) { if (is_atomic) { lbm_set_error_reason("Cannot receive inside of an atomic block"); @@ -1541,44 +1540,6 @@ static void cont_resume(eval_context_t *ctx) { ctx->curr_exp = exp; } -static void cont_expand_macro(eval_context_t *ctx) { - - lbm_uint* sptr = lbm_get_stack_ptr(&ctx->K, 2); - if (!sptr) { - error_ctx(ENC_SYM_FATAL_ERROR); - return; - } - lbm_value env = (lbm_value)sptr[0]; - lbm_value args = (lbm_value)sptr[1]; - - if (lbm_is_macro(ctx->r)) { - - lbm_value m = ctx->r; - lbm_value curr_param = lbm_cadr(m); - lbm_value curr_arg = args; - lbm_value expand_env = env; - while (lbm_type_of(curr_param) == LBM_TYPE_CONS && - lbm_type_of(curr_arg) == LBM_TYPE_CONS) { - - lbm_value entry; - WITH_GC(entry,lbm_cons(lbm_car(curr_param),lbm_car(curr_arg)), expand_env,ENC_SYM_NIL); - - lbm_value aug_env; - WITH_GC(aug_env,lbm_cons(entry, expand_env),expand_env,entry); - expand_env = aug_env; - - curr_param = lbm_cdr(curr_param); - curr_arg = lbm_cdr(curr_arg); - } - lbm_stack_drop(&ctx->K, 2); - ctx->curr_exp = lbm_cadr(lbm_cdr(m)); - ctx->curr_env = expand_env; - ctx->app_cont = false; - return; - } - error_ctx(ENC_SYM_EERROR); -} - static void cont_progn_rest(eval_context_t *ctx) { lbm_value rest; lbm_value env; @@ -1637,7 +1598,7 @@ static void cont_wait(eval_context_t *ctx) { } } -static inline void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { if (nargs == 2 && lbm_is_symbol(args[1])) { lbm_uint s = lbm_dec_sym(args[1]); if (s >= VARIABLE_SYMBOLS_START && @@ -1678,7 +1639,7 @@ static inline void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t ctx->app_cont = true; } -static inline void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { if (nargs == 1) { lbm_value chan = ENC_SYM_NIL; if (lbm_type_of(args[1]) == LBM_TYPE_ARRAY) { @@ -1766,7 +1727,7 @@ static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ct apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP); } -static inline void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { if (is_atomic) { lbm_set_error_reason("Cannot yield inside of an atomic block"); error_ctx(ENC_SYM_EERROR); @@ -1781,7 +1742,7 @@ static inline void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t * } } -static inline void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { if (lbm_type_of(args[1]) == LBM_TYPE_I) { lbm_cid cid = (lbm_cid)lbm_dec_i(args[1]); lbm_stack_drop(&ctx->K, nargs+1); @@ -1794,12 +1755,12 @@ static inline void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *c } } -static inline void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { ctx->curr_exp = args[1]; lbm_stack_drop(&ctx->K, nargs+1); } -static inline void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { lbm_value prg = args[1]; prg = lbm_list_append(prg, ctx->program); @@ -1815,7 +1776,7 @@ static inline void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_cont ctx->curr_exp = lbm_car(prg); } -static inline void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { lbm_value status = ENC_SYM_EERROR; if (nargs == 2) { @@ -1832,7 +1793,7 @@ static inline void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *c ctx->app_cont = true; } -static inline void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { lbm_value ok_val = ENC_SYM_TRUE; if (nargs >= 1) { ok_val = args[1]; @@ -1841,7 +1802,7 @@ static inline void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx ok_ctx(); } -static inline void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { (void) ctx; lbm_value err_val = ENC_SYM_EERROR; if (nargs >= 1) { @@ -1850,7 +1811,7 @@ static inline void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t * error_ctx(err_val); } -static inline void apply_extension(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { +static void apply_extension(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) { extension_fptr f = lbm_get_extension(lbm_dec_sym(args[0])); if (f == NULL) { error_ctx(ENC_SYM_EERROR); @@ -1968,6 +1929,8 @@ static void cont_application(eval_context_t *ctx) { } } +// Caveat: Application of a closure to 0 arguments if +// the same as applying it to NIL. static void cont_closure_application_args(eval_context_t *ctx) { lbm_uint* sptr = lbm_get_stack_ptr(&ctx->K, 5); @@ -2695,13 +2658,6 @@ static void cont_application_start(eval_context_t *ctx) { if (lbm_type_of(ctx->r) == LBM_TYPE_CONS) { switch (lbm_car(ctx->r)) { - case ENC_SYM_MACRO_EXPAND: - /* (macro-expand (args + (list 1 2 3))) */ - sptr[1] = lbm_cdr(args); - CHECK_STACK(lbm_push(&ctx->K, - EXPAND_MACRO)); - ctx->curr_exp = lbm_car(lbm_car(args)); - break; case ENC_SYM_MACRO:{ /* * Perform macro expansion. @@ -2732,9 +2688,6 @@ static void cont_application_start(eval_context_t *ctx) { * Second to evaluate the resulting program. */ sptr[1] = EVAL_R; - /* CHECK_STACK(lbm_push_u32_2(&ctx->K, */ - /* env, */ - /* EVAL_R)); */ lbm_value exp = lbm_cadr(lbm_cdr(ctx->r)); ctx->curr_exp = exp; ctx->curr_env = expand_env; @@ -2777,7 +2730,7 @@ static void cont_application_start(eval_context_t *ctx) { } } -static inline void cont_eval_r(eval_context_t* ctx) { +static void cont_eval_r(eval_context_t* ctx) { lbm_value env; lbm_pop(&ctx->K, &env); @@ -2808,7 +2761,6 @@ static const cont_fun continuations[NUM_CONTINUATIONS] = cont_eval_r, cont_set_var, cont_resume, - cont_expand_macro, cont_closure_application_args, cont_exit_atomic, cont_read_next_token, diff --git a/src/heap.c b/src/heap.c index 32c9e46c..24db8126 100644 --- a/src/heap.c +++ b/src/heap.c @@ -33,6 +33,156 @@ lbm_heap_state_t lbm_heap_state; + +/****************************************************/ +/* ENCODERS DECODERS */ + +lbm_value lbm_enc_i32(int32_t x) { +#ifndef LBM64 + lbm_value i = lbm_cons((lbm_uint)x, lbm_enc_sym(SYM_RAW_I_TYPE)); + if (lbm_type_of(i) == LBM_TYPE_SYMBOL) return i; + return lbm_set_ptr_type(i, LBM_TYPE_I32); +#else + return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_I32; +#endif +} + +lbm_value lbm_enc_u32(uint32_t x) { +#ifndef LBM64 + lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE)); + if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u; + return lbm_set_ptr_type(u, LBM_TYPE_U32); +#else + return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_U32; +#endif +} + +lbm_value lbm_enc_float(float x) { +#ifndef LBM64 + lbm_uint t; + memcpy(&t, &x, sizeof(lbm_float)); + lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE)); + if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f; + return lbm_set_ptr_type(f, LBM_TYPE_FLOAT); +#else + uint32_t t; + memcpy(&t, &x, sizeof(float)); /*TODO: Assumes something about storage here ?*/ + return (((lbm_uint)t) << LBM_VAL_SHIFT) | LBM_TYPE_FLOAT; +#endif +} + +lbm_value lbm_enc_i64(int64_t x) { +#ifndef LBM64 + lbm_value res = lbm_enc_sym(SYM_MERROR); + lbm_uint* storage = lbm_memory_allocate(2); + if (storage) { + res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_I_TYPE)); + if (lbm_type_of(res) != LBM_TYPE_SYMBOL) { + memcpy(storage,&x, 8); + res = lbm_set_ptr_type(res, LBM_TYPE_I64); + } + } + return res; +#else + lbm_value u = lbm_cons((uint64_t)x, lbm_enc_sym(SYM_RAW_I_TYPE)); + if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u; + return lbm_set_ptr_type(u, LBM_TYPE_I64); +#endif +} + +lbm_value lbm_enc_u64(uint64_t x) { +#ifndef LBM64 + lbm_value res = lbm_enc_sym(SYM_MERROR); + lbm_uint* storage = lbm_memory_allocate(2); + if (storage) { + res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_U_TYPE)); + if (lbm_type_of(res) != LBM_TYPE_SYMBOL) { + memcpy(storage,&x, 8); + res = lbm_set_ptr_type(res, LBM_TYPE_U64); + } + } + return res; +#else + lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE)); + if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u; + return lbm_set_ptr_type(u, LBM_TYPE_U64); +#endif +} + +lbm_value lbm_enc_double(double x) { +#ifndef LBM64 + lbm_value res = lbm_enc_sym(SYM_MERROR); + lbm_uint* storage = lbm_memory_allocate(2); + if (storage) { + res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_F_TYPE)); + if (lbm_type_of(res) != LBM_TYPE_SYMBOL) { + memcpy(storage,&x, 8); + res = lbm_set_ptr_type(res, LBM_TYPE_DOUBLE); + } + } + return res; +#else + lbm_uint t; + memcpy(&t, &x, sizeof(lbm_float)); + lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE)); + if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f; + return lbm_set_ptr_type(f, LBM_TYPE_DOUBLE); +#endif +} + +float lbm_dec_float(lbm_value x) { +#ifndef LBM64 + float f_tmp; + lbm_uint tmp = lbm_car(x); + memcpy(&f_tmp, &tmp, sizeof(float)); + return f_tmp; +#else + uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT); + float f_tmp; + memcpy(&f_tmp, &tmp, sizeof(float)); + return f_tmp; +#endif +} + +double lbm_dec_double(lbm_value x) { +#ifndef LBM64 + double d; + uint32_t *data = (uint32_t*)lbm_car(x); + if (data == NULL) return 0; // no good way to report error from here currently. + memcpy(&d, data, sizeof(double)); + return d; +#else + double f_tmp; + lbm_uint tmp = lbm_car(x); + memcpy(&f_tmp, &tmp, sizeof(double)); + return f_tmp; +#endif +} + +uint64_t lbm_dec_u64(lbm_value x) { +#ifndef LBM64 + uint64_t u; + uint32_t *data = (uint32_t*)lbm_car(x); + if (data == NULL) return 0; + memcpy(&u, data, 8); + return u; +#else + return (uint64_t)lbm_car(x); +#endif +} + +int64_t lbm_dec_i64(lbm_value x) { +#ifndef LBM64 + int64_t i; + uint32_t *data = (uint32_t*)lbm_car(x); + if (data == NULL) return 0; + memcpy(&i, data, 8); + return i; +#else + return (int64_t)lbm_car(x); +#endif +} + char *lbm_dec_str(lbm_value val) { char *res = 0; if (lbm_type_of(val) == LBM_TYPE_ARRAY) { @@ -230,35 +380,44 @@ double lbm_dec_as_double(lbm_value a) { } return 0; } +/****************************************************/ +/* IS */ -static inline lbm_value read_car(lbm_cons_t *cell) { - return cell->car; +bool lbm_is_number(lbm_value x) { + lbm_uint t = lbm_type_of(x); +#ifndef LBM64 + return (t & 0xC || t & 0x08000000); + +#else + return ((t == LBM_TYPE_I) || + (t == LBM_TYPE_U) || + (t == LBM_TYPE_CHAR) || + (t == LBM_TYPE_I32) || + (t == LBM_TYPE_U32) || + (t == LBM_TYPE_I64) || + (t == LBM_TYPE_U64) || + (t == LBM_TYPE_FLOAT) || + (t == LBM_TYPE_DOUBLE)); +#endif } -static inline lbm_value read_cdr(lbm_cons_t *cell) { - return cell->cdr; -} -static inline void set_car_(lbm_cons_t *cell, lbm_value v) { - cell->car = v; -} -static inline void set_cdr_(lbm_cons_t *cell, lbm_value v) { - cell->cdr = v; -} +/****************************************************/ +/* HEAP MANAGEMENT */ static inline void set_gc_mark(lbm_cons_t *cell) { - lbm_value cdr = read_cdr(cell); - set_cdr_(cell, lbm_set_gc_mark(cdr)); + lbm_value cdr = cell->cdr; + cell->cdr = lbm_set_gc_mark(cdr); } static inline void clr_gc_mark(lbm_cons_t *cell) { - lbm_value cdr = read_cdr(cell); - set_cdr_(cell, lbm_clr_gc_mark(cdr)); + lbm_value cdr = cell->cdr; + cell->cdr = lbm_clr_gc_mark(cdr); } static inline bool get_gc_mark(lbm_cons_t* cell) { - lbm_value cdr = read_cdr(cell); + lbm_value cdr = cell->cdr; return lbm_get_gc_mark(cdr); } @@ -274,13 +433,13 @@ static int generate_freelist(size_t num_cells) { // Add all cells to free list for (i = 1; i < num_cells; i ++) { t = lbm_ref_cell(lbm_enc_cons_ptr(i-1)); - set_car_(t, ENC_SYM_RECOVERED); // all cars in free list are "RECOVERED" - set_cdr_(t, lbm_enc_cons_ptr(i)); + t->car = ENC_SYM_RECOVERED; // all cars in free list are "RECOVERED" + t->cdr = lbm_enc_cons_ptr(i); } // Replace the incorrect pointer at the last cell. t = lbm_ref_cell(lbm_enc_cons_ptr(num_cells-1)); - set_cdr_(t, ENC_SYM_NIL); + t->cdr = ENC_SYM_NIL; return 1; } @@ -367,8 +526,8 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type) { lbm_heap_state.num_alloc++; // set some ok initial values (nil . nil) - set_car_(lbm_ref_cell(res), ENC_SYM_NIL); - set_cdr_(lbm_ref_cell(res), ENC_SYM_NIL); + lbm_ref_cell(res)->car = ENC_SYM_NIL; + lbm_ref_cell(res)->cdr = ENC_SYM_NIL; // clear GC bit on allocated cell clr_gc_mark(lbm_ref_cell(res)); @@ -552,8 +711,8 @@ void lbm_gc_state_inc(void) { lbm_value lbm_cons(lbm_value car, lbm_value cdr) { lbm_value addr = lbm_heap_allocate_cell(LBM_TYPE_CONS); if ( lbm_is_ptr(addr)) { - set_car_(lbm_ref_cell(addr), car); - set_cdr_(lbm_ref_cell(addr), cdr); + lbm_ref_cell(addr)->car = car; + lbm_ref_cell(addr)->cdr = cdr; } // heap_allocate_cell returns MERROR if out of heap. @@ -569,7 +728,7 @@ lbm_value lbm_car(lbm_value c){ if (lbm_is_ptr(c) ){ lbm_cons_t *cell = lbm_ref_cell(c); - return read_car(cell); + return cell->car; } return ENC_SYM_TERROR; } @@ -601,7 +760,7 @@ lbm_value lbm_cdr(lbm_value c){ if (lbm_is_ptr(c)) { lbm_cons_t *cell = lbm_ref_cell(c); - return read_cdr(cell); + return cell->cdr; } return ENC_SYM_TERROR; } @@ -610,7 +769,7 @@ int lbm_set_car(lbm_value c, lbm_value v) { int r = 0; if (lbm_type_of(c) == LBM_TYPE_CONS) { lbm_cons_t *cell = lbm_ref_cell(c); - set_car_(cell,v); + cell->car = v; r = 1; } return r; @@ -620,7 +779,7 @@ int lbm_set_cdr(lbm_value c, lbm_value v) { int r = 0; if (lbm_type_of(c) == LBM_TYPE_CONS){ lbm_cons_t *cell = lbm_ref_cell(c); - set_cdr_(cell,v); + cell->cdr = v; r = 1; } return r; diff --git a/src/symrepr.c b/src/symrepr.c index 2bd6035c..8da5e8cf 100644 --- a/src/symrepr.c +++ b/src/symrepr.c @@ -53,7 +53,6 @@ special_sym const special_symbols[] = { {"send" , SYM_SEND}, {"recv" , SYM_RECEIVE}, {"macro" , SYM_MACRO}, - {"macro-expand" , SYM_MACRO_EXPAND}, {"call-cc" , SYM_CALLCC}, {"continuation" , SYM_CONT},