mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-05 18:30:24 -08:00
Code Issues Projects Releases Packages Wiki Activity

[needed?] implement software stack

Browse source
This commit is contained in:
Daniel Kochmański 2022-12-01 12:02:37 +01:00
parent 2367aa2e48
commit 90a3a3165a
11 changed files with 204 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/c/Makefile.in
View file

@ -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 \

6
src/c/alloc_2.d
View file

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

3
src/c/clos/instance.d
View file

@ -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:

83
src/c/nucleus/auxiliary.c Normal file
View file

@ -0,0 +1,83 @@
/* -- imports ------------------------------------------------------- */
#include <string.h>
#include <ecl/ecl.h>
/* -- 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;
}

7
src/c/printer/write_ugly.d
View file

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

65
src/c/stack.d Normal file
View file

@ -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 <ecl/ecl.h>
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));
}

9
src/c/symbols_list.h
View file

@ -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)},

1
src/clos/hierarchy.lsp
View file

@ -234,6 +234,7 @@
(readtable)
(si::code-block)
(si::foreign-data)
(si::stack)
(si::frame)
(si::weak-pointer)
#+threads (mp::process)

16
src/h/external.h
View file

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

2
src/h/nucleus.h
View file

@ -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;

11
src/h/object.h
View file

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