From 90a3a3165a4472177c2701817be7cd753db51b39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 1 Dec 2022 12:02:37 +0100 Subject: [PATCH] [needed?] implement software stack --- src/c/Makefile.in | 4 +- src/c/alloc_2.d | 6 ++- src/c/clos/instance.d | 3 ++ src/c/nucleus/auxiliary.c | 83 ++++++++++++++++++++++++++++++++++++++ src/c/printer/write_ugly.d | 7 ++++ src/c/stack.d | 65 +++++++++++++++++++++++++++++ src/c/symbols_list.h | 9 +++++ src/clos/hierarchy.lsp | 1 + src/h/external.h | 16 ++++++++ src/h/nucleus.h | 2 + src/h/object.h | 11 +++++ 11 files changed, 204 insertions(+), 3 deletions(-) create mode 100644 src/c/nucleus/auxiliary.c create mode 100644 src/c/stack.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 4be714f4d..3e39d315f 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = nucleus/error.o nucleus/runtime.o +NUCL_OBJS = nucleus/error.o nucleus/runtime.o nucleus/auxiliary.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o @@ -76,7 +76,7 @@ FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o \ compiler.o disassembler.o reference.o character.o file.o error.o \ - string.o cfun.o typespec.o assignment.o predicate.o array.o \ + string.o stack.o cfun.o typespec.o assignment.o predicate.o array.o \ vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o \ unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o \ load.o unixfsys.o unixsys.o serialize.o sse2.o threads/atomic.o \ diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index d4055b6e9..4e0dad43d 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -338,7 +338,8 @@ ecl_alloc_object(cl_type t) case t_mailbox: #endif case t_foreign: - case t_codeblock: { + case t_codeblock: + case t_stack: { cl_object obj; ecl_disable_interrupts_env(the_env); obj = (cl_object)GC_MALLOC(type_info[t].size); @@ -548,6 +549,7 @@ void init_type_info (void) #endif init_tm(t_codeblock, "CODEBLOCK", sizeof(struct ecl_codeblock), -1); init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); + init_tm(t_stack, "STACK", sizeof(struct ecl_stack), 2); init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 2); init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); #ifdef ECL_SSE2 @@ -702,6 +704,8 @@ void init_type_info (void) type_info[t_foreign].descriptor = to_bitmap(&o, &(o.foreign.data)) | to_bitmap(&o, &(o.foreign.tag)); + type_info[t_stack].descriptor = + to_bitmap(&o, &(o.stack.org)); type_info[t_frame].descriptor = to_bitmap(&o, &(o.frame.stack)) | to_bitmap(&o, &(o.frame.base)) | diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index 2618a332b..0bf27b260 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -382,6 +382,7 @@ enum ecl_built_in_classes { ECL_BUILTIN_READTABLE, ECL_BUILTIN_CODE_BLOCK, ECL_BUILTIN_FOREIGN_DATA, + ECL_BUILTIN_STACK, ECL_BUILTIN_FRAME, ECL_BUILTIN_WEAK_POINTER #ifdef ECL_THREADS @@ -503,6 +504,8 @@ cl_class_of(cl_object x) index = ECL_BUILTIN_CODE_BLOCK; break; case t_foreign: index = ECL_BUILTIN_FOREIGN_DATA; break; + case t_stack: + index = ECL_BUILTIN_STACK; break; case t_frame: index = ECL_BUILTIN_FRAME; break; case t_weak_pointer: diff --git a/src/c/nucleus/auxiliary.c b/src/c/nucleus/auxiliary.c new file mode 100644 index 000000000..fc16c7b5b --- /dev/null +++ b/src/c/nucleus/auxiliary.c @@ -0,0 +1,83 @@ + +/* -- imports ------------------------------------------------------- */ + +#include +#include + +/* -- Stack implementation ------------------------------------------ */ + +void +_ecl_stack_set_size(cl_object object, cl_index new_size, cl_index slip) +{ + cl_object *old_org = object->stack.org; + cl_object *new_org; + cl_index top = object->stack.top - object->stack.org; + cl_index old_size = object->stack.size; + cl_index _size = new_size + slip; + if (ecl_unlikely(top > new_size)) { + top = old_size = new_size; /* chop the excessive elements */ + } + /* It is the caller responsibility to disable interrupts if necessary. */ + new_org = (cl_object *)ecl_alloc_atomic(_size * sizeof(cl_object)); + memcpy(new_org, old_org, old_size * sizeof(cl_object)); + object->stack.slip = slip; + object->stack.size = new_size; + object->stack.org = new_org; + object->stack.top = new_org + top; + object->stack.end = new_org + new_size; + ecl_dealloc(old_org); +} + +void +_ecl_stack_grow(cl_object object) +{ + cl_index size = object->stack.size; + cl_index slip = object->stack.slip; + _ecl_stack_set_size(object, size + (size / 2), slip); +} + +void +_ecl_stack_push(cl_object object, cl_object value) +{ + if (ecl_unlikely(object->stack.top >= object->stack.end)) { + ecl_internal_error("_ecl_stack_push: stack overflow"); + } + *object->stack.top = value; + object->stack.top++; +} + +void +_ecl_stack_drop(cl_object object, cl_index n) +{ + if (ecl_unlikely(object->stack.top - n <= object->stack.org)) { + ecl_internal_error("_ecl_stack_pop: stack underflow"); + } + object->stack.top -= n; +} + +cl_object +_ecl_stack_pop(cl_object object) +{ + if (ecl_unlikely(object->stack.top <= object->stack.org)) { + ecl_internal_error("_ecl_stack_pop: stack underflow"); + } + return *(--object->stack.top); +} + +cl_object +_ecl_stack_top(cl_object object) +{ + if (ecl_unlikely(object->stack.top <= object->stack.org)) { + ecl_internal_error("_ecl_stack_top: stack underflow"); + } + return *(object->stack.top-1); +} + +cl_object +ecl_make_stack(cl_index size, cl_index slip) { + cl_object object = ecl_alloc_object(t_stack); + object->stack.org = object->stack.top = object->stack.end = NULL; + object->stack.size = 0; + _ecl_stack_set_size(object, size, slip); + return object; +} diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index d99672ee1..516778892 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -364,6 +364,12 @@ write_foreign(cl_object x, cl_object stream) ecl_write_char('>', stream); } +static void +write_stack(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "stack", ecl_make_fixnum(x->stack.size), stream); +} + static void write_frame(cl_object x, cl_object stream) { @@ -479,6 +485,7 @@ static printer dispatch[FREE+1] = { #endif write_codeblock, /* t_codeblock */ write_foreign, /* t_foreign */ + write_stack, /* t_stack */ write_frame, /* t_frame */ write_weak_pointer, /* t_weak_pointer */ #ifdef ECL_SSE2 diff --git a/src/c/stack.d b/src/c/stack.d new file mode 100644 index 000000000..8c94f3978 --- /dev/null +++ b/src/c/stack.d @@ -0,0 +1,65 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* + * stack.d - stack interface + * + * Copyright (c) 2022 Daniel Kochmański + * + */ + +#include + +static void +assert_type_stack(cl_object o) +{ + if (ecl_t_of(o) != t_stack) + FEwrong_type_argument(@[si::stack], o); +} + +cl_object +si_make_stack(cl_object size) +{ + cl_index ndx = ecl_to_size(size); + cl_object stack = ecl_make_stack(ndx, 0); + ecl_return1(ecl_process_env(), stack); +} + +cl_object +si_stack_size(cl_object o) +{ + cl_object integer; + assert_type_stack(o); + integer = ecl_make_integer(o->stack.size); + ecl_return1(ecl_process_env(), integer); +} + +cl_object +si_stack_push(cl_object o, cl_object v) +{ + assert_type_stack(o); + _ecl_stack_push(o, v); + ecl_return1(ecl_process_env(), v); +} + +cl_object +si_stack_drop(cl_object o, cl_object n) +{ + assert_type_stack(o); + _ecl_stack_drop(o, ecl_to_size(n)); + ecl_return1(ecl_process_env(), si_stack_top(o)); +} + +cl_object +si_stack_pop(cl_object o) +{ + assert_type_stack(o); + ecl_return1(ecl_process_env(), _ecl_stack_pop(o)); +} + +cl_object +si_stack_top(cl_object o) +{ + assert_type_stack(o); + ecl_return1(ecl_process_env(), _ecl_stack_top(o)); +} diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index c09b9e67c..8175a043a 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1336,6 +1336,15 @@ cl_symbols[] = { {SYS_ "DISPLAY-PROFILE" ECL_FUN("si_display_profile", IF_PROFILE(si_display_profile), -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, /* #endif PROFILE */ +/* stack */ +{SYS_ "STACK" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "MAKE-STACK" ECL_FUN("si_make_stack", si_make_stack, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "STACK-SIZE" ECL_FUN("si_stack_size", si_stack_size, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "STACK-PUSH" ECL_FUN("si_stack_push", si_stack_push, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "STACK-DROP" ECL_FUN("si_stack_drop", si_stack_drop, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "STACK-POP" ECL_FUN("si_stack_pop", si_stack_pop, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "STACK-TOP" ECL_FUN("si_stack_top", si_stack_top, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, + /* #ifdef ECL_TCP */ {SYS_ "*PROFILE-ARRAY*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, OBJNULL)}, {SYS_ "OPEN-CLIENT-STREAM" ECL_FUN("si_open_client_stream", IF_TCP(si_open_client_stream), 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp index 3a4c121ee..b67541cb8 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -234,6 +234,7 @@ (readtable) (si::code-block) (si::foreign-data) + (si::stack) (si::frame) (si::weak-pointer) #+threads (mp::process) diff --git a/src/h/external.h b/src/h/external.h index 27c711a8c..ee3ad2b7c 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -209,6 +209,22 @@ struct cl_core_struct { extern ECL_API struct ecl_core_struct ecl_core; extern ECL_API struct cl_core_struct cl_core; +/* auxiliary.c */ +extern ECL_API void _ecl_stack_set_size(cl_object object, cl_index new_size, cl_index slip); +extern ECL_API void _ecl_stack_grow(cl_object object); +extern ECL_API void _ecl_stack_push(cl_object object, cl_object value); +extern ECL_API void _ecl_stack_drop(cl_object object, cl_index count); +extern ECL_API cl_object _ecl_stack_pop(cl_object object); +extern ECL_API cl_object _ecl_stack_top(cl_object object); +extern ECL_API cl_object ecl_make_stack(cl_index size, cl_index slip); + +extern ECL_API cl_object si_make_stack(cl_object size); +extern ECL_API cl_object si_stack_size(cl_object stack); +extern ECL_API cl_object si_stack_push(cl_object stack, cl_object value); +extern ECL_API cl_object si_stack_drop(cl_object stack, cl_object n); +extern ECL_API cl_object si_stack_pop(cl_object stack); +extern ECL_API cl_object si_stack_top(cl_object stack); + /* runtime.c */ extern ECL_API const int ecl_boot(void); diff --git a/src/h/nucleus.h b/src/h/nucleus.h index a9f5e7fd8..bff82b1a8 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -4,6 +4,8 @@ #ifndef ECL_NUCLEUS_H #define ECL_NUCLEUS_H +/* auxiliary functions that do not depend on the environment */ + struct ecl_core_struct { #ifdef ECL_THREADS cl_object processes; diff --git a/src/h/object.h b/src/h/object.h index f462201ad..5b2357ee9 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -91,6 +91,7 @@ typedef enum { #endif t_codeblock, t_foreign, + t_stack, t_frame, t_weak_pointer, #ifdef ECL_SSE2 @@ -906,6 +907,15 @@ struct ecl_foreign { /* user defined datatype */ char *data; /* the data itself */ }; +struct ecl_stack { + _ECL_HDR; + cl_index slip; /* safety margin */ + cl_index size; /* end - org */ + cl_object *org; /* stack org */ + cl_object *top; /* stack top */ + cl_object *end; /* stack end */ +}; + struct ecl_stack_frame { _ECL_HDR; cl_object *stack; /* Is this relative to the lisp stack? */ @@ -1153,6 +1163,7 @@ union cl_lispunion { #endif struct ecl_codeblock cblock; /* codeblock */ struct ecl_foreign foreign; /* user defined data type */ + struct ecl_stack stack; /* stack */ struct ecl_stack_frame frame; /* stack frame */ struct ecl_weak_pointer weak; /* weak pointers */ #ifdef ECL_SSE2