From 7a4589ff7ffb5000a3cd79e9a177c08bef2cc83a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 12 Mar 2026 21:46:01 +0100 Subject: [PATCH] lwp: add new types CONTINUATION and THREAD --- src/c/Makefile.in | 2 +- src/c/clos/instance.d | 6 ++++++ src/c/lwp.d | 34 ++++++++++++++++++++++++++++++++++ src/c/memory.d | 7 +++++++ src/c/printer/write_ugly.d | 14 ++++++++++++++ src/c/serialize.d | 2 ++ src/c/symbols_list.h | 6 ++++++ src/c/typespec.d | 4 ++++ src/clos/hierarchy.lsp | 2 ++ src/h/external.h | 3 +++ src/h/object.h | 24 ++++++++++++++++++++++++ 11 files changed, 103 insertions(+), 1 deletion(-) create mode 100644 src/c/lwp.d diff --git a/src/c/Makefile.in b/src/c/Makefile.in index e934bd91e..2088ff6e0 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -89,7 +89,7 @@ OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o \ vector_push.o sequence.o cmpaux.o macros.o backq.o stack2.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 atomic.o process.o \ + load.o unixfsys.o unixsys.o serialize.o sse2.o atomic.o process.o lwp.o \ $(BOOT_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(STREAM_OBJS) \ $(CLOS_OBJS) $(FFI_OBJS) $(THREAD_OBJS) $(UNICODE_OBJS) @EXTRA_OBJS@ diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index 79901ccae..f9112ab93 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -413,6 +413,8 @@ enum ecl_built_in_classes { ECL_BUILTIN_HASH_TABLE, ECL_BUILTIN_RANDOM_STATE, ECL_BUILTIN_READTABLE, + ECL_BUILTIN_CONTINUATION, + ECL_BUILTIN_THREAD, ECL_BUILTIN_CODE_BLOCK, ECL_BUILTIN_FOREIGN_DATA, ECL_BUILTIN_FRAME, @@ -530,6 +532,10 @@ cl_class_of(cl_object x) case t_mailbox: index = ECL_BUILTIN_MAILBOX; break; #endif + case t_cont: + index = ECL_BUILTIN_CONTINUATION; break; + case t_thread: + index = ECL_BUILTIN_THREAD; break; case t_codeblock: index = ECL_BUILTIN_CODE_BLOCK; break; case t_foreign: diff --git a/src/c/lwp.d b/src/c/lwp.d new file mode 100644 index 000000000..00fd76def --- /dev/null +++ b/src/c/lwp.d @@ -0,0 +1,34 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* + * lwp.c - light-weight processes and delimited continuations + * + * Copyright (c) 1990, Giuseppe Attardi. + * Copyright (c) 2001, Juan Jose Garcia Ripoll. + * Copyright (c) 2026, Daniel Kochmański + * + * See file 'LICENSE' for the copyright details. + * + */ + +#include + +cl_object +si_make_thread(cl_object fun) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object o = ecl_alloc_object(t_thread); + o->thread.fun = fun; + o->thread.cont = ECL_NIL; + ecl_return1(the_env, o); +} + +cl_object +si_make_continuation(cl_object thread) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object o = ecl_alloc_object(t_cont); + o->cont.thread = thread; + ecl_return1(the_env, o); +} diff --git a/src/c/memory.d b/src/c/memory.d index 484944cfe..162e5a890 100644 --- a/src/c/memory.d +++ b/src/c/memory.d @@ -262,6 +262,13 @@ init_type_info_database(void) to_bitmap(&o, &(o.mailbox.name)) | to_bitmap(&o, &(o.mailbox.data))); #endif + init_tm(t_cont, "CONTINUATION", ecl_cont, + to_bitmap(&o, &(o.cont.thread)) | + to_bitmap(&o, &(o.cont.stack)) | + to_bitmap(&o, &(o.cont.env))); + init_tm(t_thread, "THREAD", ecl_thread, + to_bitmap(&o, &(o.thread.fun)) | + to_bitmap(&o, &(o.thread.cont))); init_tm(t_codeblock, "CODEBLOCK", ecl_codeblock, to_bitmap(&o, &(o.cblock.data)) | to_bitmap(&o, &(o.cblock.temp_data)) | diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index cf34c4097..f96c81747 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -335,6 +335,18 @@ write_cfun(cl_object x, cl_object stream) _ecl_write_unreadable(x, "compiled-function", x->cfun.name, stream); } +static void +write_cont(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "continuation", ECL_NIL, stream); +} + +static void +write_thread(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "thread", ECL_NIL, stream); +} + static void write_codeblock(cl_object x, cl_object stream) { @@ -495,6 +507,8 @@ static printer dispatch[FREE+1] = { write_barrier, /* t_barrier */ write_mailbox, /* t_mailbox */ #endif + write_cont, /* t_cont */ + write_thread, /* t_thread */ write_codeblock, /* t_codeblock */ write_foreign, /* t_foreign */ write_frame, /* t_frame */ diff --git a/src/c/serialize.d b/src/c/serialize.d index 52e441343..ea412037b 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -73,6 +73,8 @@ static cl_index object_size[] = { ROUNDED_SIZE(ecl_barrier), /* t_barrier */ ROUNDED_SIZE(ecl_mailbox), /* t_mailbox */ #endif + ROUNDED_SIZE(ecl_cont), /* t_cont */ + ROUNDED_SIZE(ecl_thread), /* t_thread */ ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ ROUNDED_SIZE(ecl_foreign), /* t_foreign */ ROUNDED_SIZE(ecl_stack_frame), /* t_frame */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 2007a8987..1a081b8fe 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1848,6 +1848,12 @@ cl_symbols[] = { {SYS_ "CODE-BLOCK" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "CONTINUATION" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "THREAD" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, + +{SYS_ "MAKE-CONTINUATION" ECL_FUN("si_make_continuation", ECL_NAME(si_make_continuation), 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{SYS_ "MAKE-THREAD" ECL_FUN("si_make_thread", ECL_NAME(si_make_thread), 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, + {SYS_ "TOKEN" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "MODULE" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "EXCEPTION" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, diff --git a/src/c/typespec.d b/src/c/typespec.d index cf8efb63a..e9b6c5af8 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -175,6 +175,10 @@ ecl_type_to_symbol(cl_type t) case t_mailbox: return @'mp::mailbox'; #endif + case t_cont: + return @'si::continuation'; + case t_thread: + return @'si::thread'; case t_codeblock: return @'si::code-block'; case t_foreign: diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp index d21d356fb..c68280947 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -225,6 +225,8 @@ (hash-table) (random-state) (readtable) + (si::continuation) + (si::thread) (si::code-block) (si::foreign-data) (si::frame) diff --git a/src/h/external.h b/src/h/external.h index 554ad8358..5aa042a48 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1811,6 +1811,9 @@ extern ECL_API cl_object si_lookup_host_entry(cl_object host_or_address); extern ECL_API void ecl_tcp_close_all(void); #endif +/* lwp.c */ +extern ECL_API cl_object si_make_thread(cl_object fun); +extern ECL_API cl_object si_make_continuation(cl_object thread); /* threads.c */ diff --git a/src/h/object.h b/src/h/object.h index 186cba933..ceec9cc48 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -81,6 +81,8 @@ typedef enum { t_barrier, t_mailbox, #endif + t_cont, + t_thread, t_codeblock, t_foreign, t_frame, @@ -1059,6 +1061,26 @@ struct ecl_dummy { _ECL_HDR; }; +/* + coroutines + */ + +struct ecl_cont { + /* already resumed */ + /* timed out */ + _ECL_HDR2(resumed, timed_out); + cl_object thread; /* its thread */ + ucontext_t uc; + char stack[16*1024]; + cl_env_ptr env; +}; + +struct ecl_thread { + _ECL_HDR; + cl_object fun; /* initial function */ + cl_object cont; /* its continuation */ +}; + #ifdef ECL_THREADS #ifdef ECL_WINDOWS_THREADS @@ -1283,6 +1305,8 @@ union cl_lispunion { struct ecl_barrier barrier; /* barrier */ struct ecl_mailbox mailbox; /* mailbox */ #endif + struct ecl_cont cont; /* continuation */ + struct ecl_thread thread; /* green thread */ struct ecl_codeblock cblock; /* codeblock */ struct ecl_foreign foreign; /* user defined data type */ struct ecl_stack_frame frame; /* stack frame */