From e4d00d6dab0850d29462b3e92cab3a2593b38978 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Wed, 24 Dec 2025 06:27:46 -0600 Subject: [PATCH 1/9] Added reentrancy support --- Makefile | 9 +- README.md | 66 ++--- README2.md | 53 ++++ doc/CODEBASE_ANALYSIS.md | 153 ++++++++++++ doc/REENTRANT.md | 259 ++++++++++++++++++++ doc/THREADING_DESIGN.md | 510 +++++++++++++++++++++++++++++++++++++++ doc/api.md | 86 +++++++ include/xlcompat.h | 211 ++++++++++++++++ include/xlcontext.h | 373 ++++++++++++++++++++++++++++ include/xlisp.h | 30 ++- include/xlthread.h | 280 +++++++++++++++++++++ src/CMakeLists.txt | 9 +- src/unstuff.c | 2 + src/xlansi.c | 2 + src/xlapi.c | 2 + src/xlcom.c | 7 + src/xlcontext.c | 432 +++++++++++++++++++++++++++++++++ src/xldmem.c | 15 +- src/xlfasl.c | 2 + src/xlfun1.c | 2 + src/xlfun2.c | 4 + src/xlfun3.c | 4 + src/xlimage.c | 2 + src/xlinit.c | 7 + src/xlint.c | 11 +- src/xlio.c | 2 + src/xlitersq.c | 2 + src/xlmain.c | 22 +- src/xlobj.c | 2 + src/xlosint.c | 73 ++++-- src/xlprint.c | 17 +- src/xlread.c | 36 ++- src/xlsym.c | 7 + xlisp/CMakeLists.txt | 2 +- 34 files changed, 2600 insertions(+), 94 deletions(-) create mode 100644 README2.md create mode 100644 doc/CODEBASE_ANALYSIS.md create mode 100644 doc/REENTRANT.md create mode 100644 doc/THREADING_DESIGN.md create mode 100644 include/xlcompat.h create mode 100644 include/xlcontext.h create mode 100644 include/xlthread.h create mode 100644 src/xlcontext.c diff --git a/Makefile b/Makefile index 3aa3d6d..49a5a41 100755 --- a/Makefile +++ b/Makefile @@ -45,7 +45,12 @@ endif ECHO=echo MKDIR=mkdir -CFLAGS=-Wall -DUNIX -I$(HDRDIR) +CFLAGS=-Wall -DUNIX -I$(HDRDIR) -fPIC + +# Reentrant/threading support: make REENTRANT=1 +ifdef REENTRANT + CFLAGS += -DXLISP_USE_CONTEXT +endif INC=$(HDRDIR)/xlisp.h @@ -67,6 +72,7 @@ clean: rm -f -r $(OBJDIR) rm -f -r $(LIBDIR) rm -f -r $(BINDIR) + rm -f -r build ######### # XLISP # @@ -99,6 +105,7 @@ $(LIBOBJDIR)/xlansi.o \ $(LIBOBJDIR)/xlapi.o \ $(LIBOBJDIR)/xlcobj.o \ $(LIBOBJDIR)/xlcom.o \ +$(LIBOBJDIR)/xlcontext.o \ $(LIBOBJDIR)/xldbg.o \ $(LIBOBJDIR)/xldmem.o \ $(LIBOBJDIR)/xlfasl.o \ diff --git a/README.md b/README.md index fac510a..27f6529 100644 --- a/README.md +++ b/README.md @@ -1,53 +1,39 @@ -# xlisp -## An object-oriented LISP +# XLISP 3 -Version 3.0 +XLISP3 is a fork of David Betz's XLISP3. -February 18, 2006 +The home for this fork is at -## Building with CMake -We've added the ability to build with CMake to simplify building XLisp on your -system. The way that we expect this to work on Linux systems using `make` would -be to first make a build directory. For this walkthrough we'll say that we -start _in_ the xlisp directory: +XLISP3 is better described as Scheme than Lisp since it more closely follows Scheme. -```bash -cd .. -mkdir build -cd build -ccmake ../xlisp -``` -So, now we have made a build directory outside of xlisp, so that the build -products don't get strewn all over our pristine source. The `ccmake` command is -a curses front end to CMake that I like. From there you can pick the type of -build, then type "g" for generate. This drops you out in a shell prompt, where -it has made makefiles for you (on other platforms, you may have other types of -build files generated). After that you can: +It has some really nice features as follows: -```bash -make -# and then, either: -make install -# or -make package -``` +1. It has a byte-code compiler (to FASL files) so code runs reasonably fast. +2. It can load Lisp source files or compiled FASL files. +3. It has an object system with classes, methods, inheritance, and `super` calls. +4. The macro system is traditional Lisp-style (not Scheme's hygienic macros). +5. It can be used as an extension language embedded in C programs. +6. It can save/load workspace images. +7. It correctly handles tail recursion (proper tail call optimization). +8. It has a Common Lisp-style package system. +9. It supports multiple return values. +10. It has first-class continuations (call/cc). -With the CMake file we have in there, it also has a "package" target, which -will most likely result in a gzipped tar file of the build products. It is also -possible to alter the `CMakeLists.txt` file to generate other package types, -such as `*.rpm`, `*.deb`, etc. +## To all of this, I have added: -#### David Michael Betz +A. When used as an extension language, it is now reentrant and can handle multiple simultaneous threads. -18 Garrison Drive -Bedford, US, NH 03110 +To this, I would like to add native thread support at some time. -(603) 472-2389 (home) +## Building -#### Copyright (c) 1984-2006, by David Michael Betz + make # standard build + make REENTRANT=1 # thread-safe build + make clean # remove build artifacts -All Rights Reserved +## The original README file is located at README2.md + +Blake McBride +blake@mcbridemail.com -See the included file LICENSE for the full license. -Updated 11/8/24 to test 2FA. diff --git a/README2.md b/README2.md new file mode 100644 index 0000000..fac510a --- /dev/null +++ b/README2.md @@ -0,0 +1,53 @@ +# xlisp +## An object-oriented LISP + +Version 3.0 + +February 18, 2006 + +## Building with CMake +We've added the ability to build with CMake to simplify building XLisp on your +system. The way that we expect this to work on Linux systems using `make` would +be to first make a build directory. For this walkthrough we'll say that we +start _in_ the xlisp directory: + +```bash +cd .. +mkdir build +cd build +ccmake ../xlisp +``` +So, now we have made a build directory outside of xlisp, so that the build +products don't get strewn all over our pristine source. The `ccmake` command is +a curses front end to CMake that I like. From there you can pick the type of +build, then type "g" for generate. This drops you out in a shell prompt, where +it has made makefiles for you (on other platforms, you may have other types of +build files generated). After that you can: + +```bash +make +# and then, either: +make install +# or +make package +``` + +With the CMake file we have in there, it also has a "package" target, which +will most likely result in a gzipped tar file of the build products. It is also +possible to alter the `CMakeLists.txt` file to generate other package types, +such as `*.rpm`, `*.deb`, etc. + +#### David Michael Betz + +18 Garrison Drive +Bedford, US, NH 03110 + +(603) 472-2389 (home) + +#### Copyright (c) 1984-2006, by David Michael Betz + +All Rights Reserved + +See the included file LICENSE for the full license. + +Updated 11/8/24 to test 2FA. diff --git a/doc/CODEBASE_ANALYSIS.md b/doc/CODEBASE_ANALYSIS.md new file mode 100644 index 0000000..152c618 --- /dev/null +++ b/doc/CODEBASE_ANALYSIS.md @@ -0,0 +1,153 @@ +# XLISP Codebase Analysis + +## Overview + +**XLISP** is an object-oriented LISP interpreter/compiler (v3.3) by David Michael Betz (1983-2017). Licensed under MIT. It compiles Lisp to bytecodes rather than interpreting directly, making it faster than traditional interpreters. + +## Project Structure + +``` +xlisp/ +├── src/ # Core C source (27 files, ~18.8K lines) +├── include/ # Header files +├── xlisp/ # REPL executable source +├── ext/ # Extension module +├── doc/ # Documentation (Markdown) +├── *.lsp # 14 Lisp initialization/library files +├── CMakeLists.txt # Modern build system +└── Makefile # Legacy build +``` + +## Key Components + +| Module | Purpose | +|--------|---------| +| `xlcom.c` | Bytecode compiler | +| `xlint.c` | Bytecode interpreter/VM | +| `xldmem.c` | Memory management & GC | +| `xlobj.c` | Object-oriented system | +| `xlread.c` / `xlprint.c` | Reader/printer | +| `xlapi.c` | C embedding API | +| `xlfun1.c`, `xlfun2.c`, `xlfun3.c` | Built-in functions | +| `xlftab.c` | Function table registry | +| `xlmath.c` | Mathematical functions | +| `xlsym.c` | Symbol and package management | +| `xlimage.c` | Memory image/workspace management | +| `xlfasl.c` | Fast loading (compiled bytecode) | +| `xldbg.c` | Debugging support | +| `msstuff.c` | Windows-specific code | +| `unstuff.c` | Unix-specific code | + +## Lisp Library Files + +| File | Purpose | +|------|---------| +| `xlisp.lsp` | Main initialization | +| `xlinit.lsp` | System initialization | +| `macros.lsp` | Macro system | +| `objects.lsp` | Object system utilities | +| `qquote.lsp` | Quasiquote/unquote support | +| `clisp.lsp` | Common Lisp compatibility | +| `pp.lsp` | Pretty printer | +| `math.lsp` | Math utilities | +| `compile.lsp` | Compilation utilities | +| `fasl.lsp` | Fast loading utilities | +| `crec.lsp` | C records (FFI) | + +## Architecture + +### Execution Flow + +``` +Lisp Source Code + ↓ + Reader (xlread.c) + ↓ + S-Expressions + ↓ + Compiler (xlcom.c) + ↓ + Bytecodes + ↓ + Interpreter (xlint.c) + ↓ + Execution Results +``` + +### Memory Layout + +- **Node Space**: Lisp values with free list and protected pointers +- **Vector Space**: Strings and arrays with automatic expansion +- **Generational garbage collection** + +### VM Registers + +- `xlFun` - current function +- `xlEnv` - environment +- `xlVal` - last value +- `xlSP` - value stack pointer +- `xlCSP` - control stack pointer + +## Notable Features + +- **Bytecode compilation** - not direct interpretation +- **Generational garbage collection** with protected pointers +- **Class-based OOP** with inheritance and method dispatch +- **Scheme influences** - lexical scoping, proper tail recursion +- **Common Lisp elements** - packages, keywords, multiple values +- **Cross-platform** (Windows, Linux, macOS) via ANSI C +- **Extensible** via C API and extension modules +- **FASL support** - fast loading of pre-compiled bytecode + +## Build System + +### CMake (Recommended) + +```bash +mkdir build && cd build +cmake .. +make +make install # or make package +``` + +Requires CMake 3.14+. Supports link-time optimization (IPO). + +### Build Targets + +1. **xlisp** (library) - Core interpreter/compiler +2. **ext** (shared library) - Extension module +3. **xlisp-repl** (executable) - Interactive REPL + +### Legacy Support + +- `Makefile` - Traditional make-based build +- `.dsp/.dsw` - Historical Visual Studio project files + +## Type System + +- `xlValue` - Universal Lisp value pointer (node-based) +- `xlFIXTYPE` - Fixed-point integers (long) +- `xlFLOTYPE` - Floating-point (double) +- `xlCHRTYPE` - Character (int) + +## C API Patterns + +```c +// Argument fetching +xlGetArg() +xlGetArgFixnum() +xlLastArg() // Detects too many args + +// Return values +xlMakeFixnum() +xlCons() + +// Class definition +xlClass() +``` + +## Platform Abstraction + +- `msstuff.c` - Windows-specific implementation +- `unstuff.c` - Unix-specific implementation +- ANSI C for maximum portability diff --git a/doc/REENTRANT.md b/doc/REENTRANT.md new file mode 100644 index 0000000..5b70180 --- /dev/null +++ b/doc/REENTRANT.md @@ -0,0 +1,259 @@ +# XLISP Reentrant/Thread-Safe Mode + +## Overview + +XLISP can be built in a reentrant mode that allows it to be safely called from multiple threads. Each thread gets its own independent interpreter context with completely separate: + +- Value and control stacks +- Heap memory (nodes and vectors) +- Symbol tables and packages +- Garbage collector state +- VM registers + +**Important:** Lisp data cannot be shared between threads. Each context is a fully isolated interpreter instance. + +## Building + +To build XLISP with reentrant support: + +```bash +make clean +make REENTRANT=1 +``` + +This defines `XLISP_USE_CONTEXT` which enables thread-local storage for the interpreter state. + +To verify the build has reentrant support: + +```bash +nm lib/libxlisp.a | grep xlCreateContext +``` + +You should see `T xlCreateContext` in the output. + +## Thread-Local Storage + +The reentrant build uses thread-local storage (TLS) to maintain a per-thread interpreter context pointer. The implementation uses: + +- `__thread` keyword on GCC/Clang (Linux, macOS) +- `__declspec(thread)` on MSVC (Windows) +- pthread keys as a fallback + +## API + +### Headers + +```c +#include "xlisp.h" +#include "xlthread.h" +``` + +### Functions + +#### xlCreateContext + +```c +xlContext *xlCreateContext(void) +``` + +Allocates a new interpreter context. Returns NULL on failure. + +The context is allocated but not initialized. You must call `xlInitContext()` before using it. + +#### xlInitContext + +```c +int xlInitContext(xlContext *ctx, xlCallbacks *callbacks, + int argc, const char *argv[], const char *workspace) +``` + +Initializes a context for use. Returns 0 on success, -1 on failure. + +Parameters: +- `ctx` - Context created by `xlCreateContext()` +- `callbacks` - Callback structure from `xlDefaultCallbacks()` +- `argc`, `argv` - Command line arguments (can be 0, NULL) +- `workspace` - Workspace image file to restore, or NULL for fresh start + +This function: +1. Sets the context as the current thread's active context +2. Initializes memory management (stack, heap) +3. Creates the standard packages and symbols +4. Optionally restores a workspace image + +#### xlSetCurrentContext + +```c +void xlSetCurrentContext(xlContext *ctx) +``` + +Sets the current thread's active context. This is called automatically by `xlInitContext()`, but can be used to switch between multiple contexts in the same thread. + +#### xlGetCurrentContext + +```c +xlContext *xlGetCurrentContext(void) +``` + +Returns the current thread's active context, or NULL if none is set. + +#### xlDestroyContext + +```c +void xlDestroyContext(xlContext *ctx) +``` + +Frees all memory associated with a context: +- Node segments +- Vector segments +- Stack +- Protected pointer blocks +- The context structure itself + +Call this when a thread is finished using the interpreter. + +## Usage Examples + +### Single Thread (Main Program) + +For single-threaded use, the standard `xlInit()` function works as before. In reentrant mode, it automatically creates and initializes a default context: + +```c +#include "xlisp.h" + +int main(int argc, char *argv[]) +{ + xlCallbacks *callbacks = xlDefaultCallbacks(argc, argv); + + if (!xlInit(callbacks, argc, argv, NULL)) { + fprintf(stderr, "Failed to initialize XLISP\n"); + return 1; + } + + xlInfo("%s\n", xlBanner()); + xlCallFunctionByName(NULL, 0, "*TOPLEVEL*", 0); + return 0; +} +``` + +### Multiple Threads + +Each thread must create and initialize its own context: + +```c +#include +#include "xlisp.h" +#include "xlthread.h" + +void *worker_thread(void *arg) +{ + xlContext *ctx; + xlCallbacks *callbacks; + + /* Create a new context for this thread */ + ctx = xlCreateContext(); + if (ctx == NULL) { + fprintf(stderr, "Failed to create context\n"); + return NULL; + } + + /* Initialize the context */ + callbacks = xlDefaultCallbacks(0, NULL); + if (xlInitContext(ctx, callbacks, 0, NULL, NULL) != 0) { + fprintf(stderr, "Failed to initialize context\n"); + xlDestroyContext(ctx); + return NULL; + } + + /* Now use the interpreter */ + xlLoadFile("worker.lsp"); + xlCallFunctionByName(NULL, 0, "DO-WORK", 0); + + /* Clean up */ + xlDestroyContext(ctx); + return NULL; +} + +int main(int argc, char *argv[]) +{ + pthread_t threads[4]; + int i; + + for (i = 0; i < 4; i++) + pthread_create(&threads[i], NULL, worker_thread, NULL); + + for (i = 0; i < 4; i++) + pthread_join(threads[i], NULL); + + return 0; +} +``` + +### Multiple Contexts in One Thread + +A single thread can manage multiple contexts by switching between them: + +```c +#include "xlisp.h" +#include "xlthread.h" + +int main(void) +{ + xlContext *ctx1, *ctx2; + xlCallbacks *callbacks = xlDefaultCallbacks(0, NULL); + + /* Create two contexts */ + ctx1 = xlCreateContext(); + ctx2 = xlCreateContext(); + + /* Initialize first context */ + xlInitContext(ctx1, callbacks, 0, NULL, NULL); + xlLoadFile("program1.lsp"); + + /* Initialize second context */ + xlInitContext(ctx2, callbacks, 0, NULL, NULL); + xlLoadFile("program2.lsp"); + + /* Switch between them */ + xlSetCurrentContext(ctx1); + xlCallFunctionByName(NULL, 0, "FUNC1", 0); + + xlSetCurrentContext(ctx2); + xlCallFunctionByName(NULL, 0, "FUNC2", 0); + + /* Clean up */ + xlDestroyContext(ctx1); + xlDestroyContext(ctx2); + + return 0; +} +``` + +## Limitations + +1. **No data sharing:** Lisp values cannot be passed between contexts. Each context has its own heap, so pointers are not valid across contexts. + +2. **No cross-thread calls:** You cannot call a function in one context from another thread. Each thread must use its own context. + +3. **Callbacks:** The callback structure can be shared between contexts (it contains function pointers, not Lisp data), but be careful with any state in your callback implementations. + +4. **Memory overhead:** Each context has its own complete interpreter state, including separate heaps. Memory usage scales linearly with the number of contexts. + +5. **Initialization time:** Creating and initializing a context takes time (building symbol tables, etc.). For best performance, create contexts once and reuse them. + +## Implementation Details + +The reentrant mode works by: + +1. Moving all global variables into an `xlContext` structure +2. Using a thread-local pointer (`xl_current_context`) to the current context +3. Providing compatibility macros that redirect global variable access through the context pointer + +For example, the global `xlVal` becomes: +```c +#define xlVal (xlCtx()->val) +``` + +Where `xlCtx()` returns the current thread's context pointer. + +The context structure is defined in `include/xlcontext.h` and contains all interpreter state including VM registers, stack pointers, memory management state, symbol caches, and package pointers. diff --git a/doc/THREADING_DESIGN.md b/doc/THREADING_DESIGN.md new file mode 100644 index 0000000..20d4ad7 --- /dev/null +++ b/doc/THREADING_DESIGN.md @@ -0,0 +1,510 @@ +# XLISP Threading Support Design + +## Overview + +This document describes the design for adding multi-threading support to XLISP using **thread-local interpreter instances**. Each thread gets its own complete interpreter state with no sharing of Lisp data between threads. + +## Architecture + +### Current Problem: Global State + +The current implementation uses extensive global variables: + +```c +// VM Registers (xldmem.c) +xlValue xlFun; // current function +xlValue xlEnv; // current environment +xlValue xlVal; // value of most recent instruction +xlValue *xlSP; // value stack pointer +xlValue *xlCSP; // control stack pointer +int xlArgC; // argument count + +// Stack (xldmem.c) +xlValue *xlStkBase; // stack base +xlValue *xlStkTop; // stack top + +// Memory Management (xldmem.c) +xlNodeSegment *xlNSegments; +xlVectorSegment *xlVSegments; +xlValue *xlVFree, *xlVTop; +xlValue xlFNodes; +xlFIXTYPE xlNFree, xlNNodes, xlTotal, xlGCCalls; +xlProtectedPtrBlk *xlPPointers; + +// Interpreter State (xlint.c) +xlErrorTarget *xlerrtarget; +xlValue *xlcatch; +int xlTraceBytecodes; +void (*xlNext)(void); +static unsigned char *base, *pc; // bytecode pointers + +// Important Values +xlValue xlTrue, xlFalse, xlPackages; +xlValue xlUnboundObject, xlDefaultObject, xlEofObject; + +// Symbols (xlinit.c) - ~30+ cached symbols +xlValue s_quote, s_function, s_package, ... + +// I/O +FILE *xlTranscriptFP; +xlCallbacks *callbacks; +``` + +### Solution: Interpreter Context Structure + +All global state is encapsulated into a single context structure: + +```c +/* include/xlcontext.h */ + +#ifndef __XLCONTEXT_H__ +#define __XLCONTEXT_H__ + +#include "xlisp.h" + +/* Interpreter context - contains all per-thread state */ +typedef struct xlContext { + + /* === VM Registers === */ + xlValue fun; /* current function */ + xlValue env; /* current environment */ + xlValue val; /* value of most recent instruction */ + int argc; /* argument count */ + void (*next)(void); /* next function to call */ + + /* === Stacks === */ + xlValue *sp; /* value stack pointer */ + xlValue *csp; /* control stack pointer */ + xlValue *stkBase; /* stack base */ + xlValue *stkTop; /* stack top */ + + /* === Bytecode Interpreter === */ + unsigned char *pc; /* program counter */ + unsigned char *pcBase; /* code base pointer */ + xlErrorTarget *errTarget; + xlValue *catchFrame; + int traceBytecodes; + int sample; /* control char sample counter */ + + /* === Memory: Node Space === */ + xlNodeSegment *nSegments; + xlNodeSegment *nsLast; + xlValue fNodes; /* free node list */ + xlFIXTYPE nsSize; + xlFIXTYPE nNodes; + xlFIXTYPE nFree; + int nsCount; + + /* === Memory: Vector Space === */ + xlVectorSegment *vSegments; + xlVectorSegment *vsCurrent; + xlValue *vFree; + xlValue *vTop; + xlFIXTYPE vsSize; + int vsCount; + + /* === Memory: Protected Pointers === */ + xlProtectedPtrBlk *pPointers; + + /* === Memory: Statistics === */ + xlFIXTYPE total; + xlFIXTYPE gcCalls; + + /* === Important Values === */ + xlValue vTrue; + xlValue vFalse; + xlValue packages; + xlValue unboundObject; + xlValue defaultObject; + xlValue eofObject; + + /* === Cached Symbols === */ + struct { + xlValue quote, function, quasiquote, unquote, unquoteSplicing; + xlValue dot, package, eval, load; + xlValue print, printCase, eql; + xlValue stdin_, stdout_, stderr_; + xlValue stackPointer, error; + xlValue fixfmt, hexfmt, flofmt, freeptr, backtrace; + /* Lambda list keywords */ + xlValue lk_optional, lk_rest, lk_key, lk_aux, lk_allow_other_keys; + xlValue slk_optional, slk_rest; + /* Keyword symbols */ + xlValue k_upcase, k_downcase; + xlValue k_internal, k_external, k_inherited; + xlValue k_key, k_uses, k_test, k_testnot; + xlValue k_start, k_end, k_1start, k_1end, k_2start, k_2end; + xlValue k_count, k_fromend; + } sym; + + /* === Packages === */ + xlValue lispPackage; + xlValue xlispPackage; + xlValue keywordPackage; + + /* === Reader State === */ + xlValue symReadTable; + xlValue symNMacro, symTMacro, symWSpace; + xlValue symConst, symSEscape, symMEscape; + + /* === Printer State === */ + int prBreadth; + int prDepth; + + /* === I/O === */ + FILE *transcriptFP; + + /* === Callbacks === */ + xlCallbacks *callbacks; + + /* === Initialization Flag === */ + int initialized; + + /* === Command Line === */ + int cmdLineArgC; + const char **cmdLineArgV; + + /* === C Classes === */ + xlCClass *cClasses; + +} xlContext; + +/* Thread-local context access */ +#if defined(_WIN32) + #define XLISP_TLS __declspec(thread) +#elif defined(__GNUC__) + #define XLISP_TLS __thread +#else + /* Fall back to pthread_getspecific */ + #define XLISP_USE_PTHREAD_TLS 1 +#endif + +#ifndef XLISP_USE_PTHREAD_TLS + extern XLISP_TLS xlContext *xlCurrentContext; + #define xlCtx() xlCurrentContext +#else + xlContext *xlCtx(void); +#endif + +/* Context management API */ +xlContext *xlCreateContext(void); +void xlDestroyContext(xlContext *ctx); +void xlSetCurrentContext(xlContext *ctx); +xlContext *xlGetCurrentContext(void); + +/* Initialize a context */ +int xlInitContext(xlContext *ctx, xlCallbacks *callbacks, + int argc, const char *argv[], const char *workspace); + +#endif /* __XLCONTEXT_H__ */ +``` + +## Compatibility Macros + +To minimize code changes, provide macros that redirect old globals to context fields: + +```c +/* include/xlcompat.h - Compatibility layer for threading */ + +#ifndef __XLCOMPAT_H__ +#define __XLCOMPAT_H__ + +#include "xlcontext.h" + +/* VM Registers */ +#define xlFun (xlCtx()->fun) +#define xlEnv (xlCtx()->env) +#define xlVal (xlCtx()->val) +#define xlArgC (xlCtx()->argc) +#define xlNext (xlCtx()->next) + +/* Stacks */ +#define xlSP (xlCtx()->sp) +#define xlCSP (xlCtx()->csp) +#define xlStkBase (xlCtx()->stkBase) +#define xlStkTop (xlCtx()->stkTop) + +/* Memory - Node Space */ +#define xlNSegments (xlCtx()->nSegments) +#define xlNSLast (xlCtx()->nsLast) +#define xlFNodes (xlCtx()->fNodes) +#define xlNSSize (xlCtx()->nsSize) +#define xlNNodes (xlCtx()->nNodes) +#define xlNFree (xlCtx()->nFree) +#define xlNSCount (xlCtx()->nsCount) + +/* Memory - Vector Space */ +#define xlVSegments (xlCtx()->vSegments) +#define xlVSCurrent (xlCtx()->vsCurrent) +#define xlVFree (xlCtx()->vFree) +#define xlVTop (xlCtx()->vTop) +#define xlVSSize (xlCtx()->vsSize) +#define xlVSCount (xlCtx()->vsCount) + +/* Memory - Other */ +#define xlPPointers (xlCtx()->pPointers) +#define xlTotal (xlCtx()->total) +#define xlGCCalls (xlCtx()->gcCalls) + +/* Important Values */ +#define xlTrue (xlCtx()->vTrue) +#define xlFalse (xlCtx()->vFalse) +#define xlPackages (xlCtx()->packages) +#define xlUnboundObject (xlCtx()->unboundObject) +#define xlDefaultObject (xlCtx()->defaultObject) +#define xlEofObject (xlCtx()->eofObject) + +/* Packages */ +#define xlLispPackage (xlCtx()->lispPackage) +#define xlXLispPackage (xlCtx()->xlispPackage) +#define xlKeywordPackage (xlCtx()->keywordPackage) + +/* Interpreter State */ +#define xlerrtarget (xlCtx()->errTarget) +#define xlcatch (xlCtx()->catchFrame) +#define xlTraceBytecodes (xlCtx()->traceBytecodes) + +/* I/O */ +#define xlTranscriptFP (xlCtx()->transcriptFP) + +/* Symbols - accessed via xlCtx()->sym.XXX */ +#define s_quote (xlCtx()->sym.quote) +#define s_function (xlCtx()->sym.function) +#define s_package (xlCtx()->sym.package) +/* ... etc for all cached symbols ... */ + +/* Printer */ +#define xlPRBreadth (xlCtx()->prBreadth) +#define xlPRDepth (xlCtx()->prDepth) + +/* Command line */ +#define xlCmdLineArgC (xlCtx()->cmdLineArgC) +#define xlCmdLineArgV (xlCtx()->cmdLineArgV) + +/* Initialization */ +#define xlInitializedP (xlCtx()->initialized) + +#endif /* __XLCOMPAT_H__ */ +``` + +## New Public API + +```c +/* include/xlthread.h - Thread-safe API */ + +#ifndef __XLTHREAD_H__ +#define __XLTHREAD_H__ + +#include "xlcontext.h" + +/* + * Thread-Safe XLISP API + * + * Each thread must: + * 1. Create its own context with xlCreateContext() + * 2. Initialize it with xlInitContext() + * 3. Set it as current with xlSetCurrentContext() + * 4. Use standard xl* functions (they use xlCtx() internally) + * 5. Destroy with xlDestroyContext() when done + */ + +/* Create a new interpreter context */ +xlEXPORT xlContext *xlCreateContext(void); + +/* Destroy an interpreter context */ +xlEXPORT void xlDestroyContext(xlContext *ctx); + +/* Set the current thread's context */ +xlEXPORT void xlSetCurrentContext(xlContext *ctx); + +/* Get the current thread's context */ +xlEXPORT xlContext *xlGetCurrentContext(void); + +/* Initialize a context (replaces xlInit for multi-threaded use) */ +xlEXPORT int xlInitContext( + xlContext *ctx, + xlCallbacks *callbacks, + int argc, + const char *argv[], + const char *workspace +); + +/* Thread-safe versions of key API functions */ +/* (These explicitly take a context parameter) */ + +xlEXPORT int xlCallFunctionCtx( + xlContext *ctx, + xlValue *values, int vmax, + xlValue fun, int argc, ... +); + +xlEXPORT int xlEvaluateCtx( + xlContext *ctx, + xlValue *values, int vmax, + xlValue expr +); + +xlEXPORT int xlEvaluateCStringCtx( + xlContext *ctx, + xlValue *values, int vmax, + const char *str +); + +#endif /* __XLTHREAD_H__ */ +``` + +## Usage Example + +```c +/* example_threaded.c - Multi-threaded XLISP usage */ + +#include +#include "xlthread.h" + +void *worker_thread(void *arg) { + int thread_id = *(int *)arg; + xlContext *ctx; + xlValue result; + char expr[256]; + + /* Create and initialize context for this thread */ + ctx = xlCreateContext(); + if (!ctx) { + fprintf(stderr, "Thread %d: Failed to create context\n", thread_id); + return NULL; + } + + /* Initialize with default callbacks */ + if (xlInitContext(ctx, xlDefaultCallbacks(NULL), 0, NULL, NULL) != 0) { + fprintf(stderr, "Thread %d: Failed to initialize\n", thread_id); + xlDestroyContext(ctx); + return NULL; + } + + /* Set as current context for this thread */ + xlSetCurrentContext(ctx); + + /* Now we can use standard XLISP functions */ + snprintf(expr, sizeof(expr), "(+ %d 100)", thread_id); + + if (xlEvaluateCString(&result, 1, expr) == 1) { + printf("Thread %d: %s = %ld\n", + thread_id, expr, xlGetFixnum(result)); + } + + /* Can also use explicit context version */ + xlEvaluateCStringCtx(ctx, &result, 1, "(* 6 7)"); + + /* Cleanup */ + xlDestroyContext(ctx); + return NULL; +} + +int main(void) { + pthread_t threads[4]; + int ids[4] = {1, 2, 3, 4}; + + /* Launch worker threads */ + for (int i = 0; i < 4; i++) { + pthread_create(&threads[i], NULL, worker_thread, &ids[i]); + } + + /* Wait for completion */ + for (int i = 0; i < 4; i++) { + pthread_join(threads[i], NULL); + } + + return 0; +} +``` + +## Implementation Plan + +### Phase 1: Create Context Structure +1. Define `xlContext` struct in new `include/xlcontext.h` +2. Add thread-local storage for current context pointer +3. Implement `xlCreateContext()`, `xlDestroyContext()`, `xlSetCurrentContext()` + +### Phase 2: Add Compatibility Macros +1. Create `include/xlcompat.h` with macro redirects +2. Include xlcompat.h in xlisp.h (after xlcontext.h) +3. All existing code continues to work via macros + +### Phase 3: Refactor Initialization +1. Create `xlInitContext()` that initializes a specific context +2. Modify `xlInit()` to create a default context and call `xlInitContext()` +3. Move all initialization from static to context-based + +### Phase 4: Refactor Memory Management +1. Move all memory globals into context (`xldmem.c`) +2. GC now operates on context's memory segments +3. Each context has independent heap + +### Phase 5: Refactor Interpreter +1. Move interpreter state into context (`xlint.c`) +2. Move bytecode state (pc, base) into context +3. Error handling uses context's error target + +### Phase 6: Refactor Symbols and Packages +1. Move symbol cache into context +2. Move package list into context +3. Each context has its own symbol table + +### Phase 7: Testing and Validation +1. Single-threaded regression tests +2. Multi-threaded stress tests +3. Memory leak testing with valgrind + +## Files Requiring Modification + +| File | Changes | +|------|---------| +| `include/xlisp.h` | Include xlcontext.h, xlcompat.h | +| `include/xlcontext.h` | **NEW** - Context structure | +| `include/xlcompat.h` | **NEW** - Compatibility macros | +| `include/xlthread.h` | **NEW** - Thread-safe API | +| `src/xldmem.c` | Remove globals, use xlCtx() | +| `src/xlint.c` | Remove globals, use xlCtx() | +| `src/xlinit.c` | Remove globals, use xlCtx() | +| `src/xlsym.c` | Remove globals, use xlCtx() | +| `src/xlmain.c` | Add context creation in xlInit() | +| `src/xlapi.c` | Add xlInitContext(), context API | +| `src/xlcom.c` | Use xlCtx() for compiler state | +| `src/xlread.c` | Use xlCtx() for reader state | +| `src/xlprint.c` | Use xlCtx() for printer state | +| `src/xlio.c` | Use xlCtx() for I/O state | +| `src/xlobj.c` | Use xlCtx() for object symbols | +| `src/xlfun1.c` | No changes (uses macros) | +| `src/xlfun2.c` | No changes (uses macros) | +| `src/xlfun3.c` | No changes (uses macros) | + +## Considerations + +### What This Design Does NOT Support +- Sharing Lisp objects between threads (each thread has isolated heap) +- Concurrent GC (each thread GCs independently) +- Cross-thread message passing at Lisp level + +### If You Need Shared Data +For inter-thread communication, use C-level mechanisms: +- Serialize Lisp data to strings, pass via queue +- Use foreign pointers to shared C structures with your own locking +- Implement a Lisp-level channel/queue using C primitives + +### Performance Notes +- Thread-local storage access is very fast (single instruction on most platforms) +- Independent heaps mean no GC coordination overhead +- Memory usage scales linearly with thread count + +## Estimated Effort + +| Phase | Effort | +|-------|--------| +| Phase 1: Context Structure | 1-2 days | +| Phase 2: Compatibility Macros | 1 day | +| Phase 3: Refactor Init | 2-3 days | +| Phase 4: Refactor Memory | 3-4 days | +| Phase 5: Refactor Interpreter | 2-3 days | +| Phase 6: Refactor Symbols | 2-3 days | +| Phase 7: Testing | 3-5 days | +| **Total** | **~2-3 weeks** | diff --git a/doc/api.md b/doc/api.md index b8b24a1..f5f6c02 100644 --- a/doc/api.md +++ b/doc/api.md @@ -1,6 +1,22 @@ # xlisp ## The API +### Building + +Standard build: +```bash +make +``` + +Reentrant/thread-safe build: +```bash +make REENTRANT=1 +``` + +The reentrant build enables thread-local interpreter contexts, allowing XLISP to be safely called from multiple threads. + +### Basic Usage + Here is the basic form of a C program that uses `xlisp.dll`. ```cpp @@ -29,6 +45,76 @@ void main(int argc,char *argv[]) xlCallFunctionByName(NULL,0,"*TOPLEVEL*",0); } ``` + +### Multi-threaded Usage + +When built with `REENTRANT=1`, each thread must create and initialize its own interpreter context. Contexts are completely independent - no Lisp data is shared between threads. + +```cpp +#include "xlisp.h" +#include "xlthread.h" + +void *thread_func(void *arg) +{ + xlCallbacks *callbacks; + xlContext *ctx; + + /* create a new interpreter context for this thread */ + ctx = xlCreateContext(); + if (ctx == NULL) + return NULL; + + /* get default callbacks and initialize the context */ + callbacks = xlDefaultCallbacks(0, NULL); + if (xlInitContext(ctx, callbacks, 0, NULL, NULL) != 0) { + xlDestroyContext(ctx); + return NULL; + } + + /* use the interpreter */ + xlLoadFile("mycode.lsp"); + xlCallFunctionByName(NULL, 0, "MY-FUNCTION", 0); + + /* clean up when done */ + xlDestroyContext(ctx); + return NULL; +} +``` + +#### Context API Functions + +```cpp +xlContext *xlCreateContext(void) +``` +Allocates a new interpreter context. Returns NULL on failure. + +```cpp +int xlInitContext(xlContext *ctx, xlCallbacks *callbacks, + int argc, const char *argv[], const char *workspace) +``` +Initializes a context for use. Returns 0 on success, -1 on failure. +- `ctx` - context created by `xlCreateContext()` +- `callbacks` - callback structure (use `xlDefaultCallbacks()`) +- `argc`, `argv` - command line arguments (can be 0, NULL) +- `workspace` - workspace image file to restore (or NULL) + +```cpp +void xlSetCurrentContext(xlContext *ctx) +``` +Sets the current thread's active context. Called automatically by `xlInitContext()`. + +```cpp +void xlDestroyContext(xlContext *ctx) +``` +Frees all memory associated with a context. Call when the thread is done with the interpreter. + +```cpp +xlContext *xlGetCurrentContext(void) +``` +Returns the current thread's active context. + +### Defining External Functions + External functions should be declared as functions taking no arguments and returning an xlValue which is the result. Arguments should be fetched by using the routines below. For functions that take optional arguments, call the predicate `xlMoreArgsP()` to determine if more arguments are present before diff --git a/include/xlcompat.h b/include/xlcompat.h new file mode 100644 index 0000000..7038267 --- /dev/null +++ b/include/xlcompat.h @@ -0,0 +1,211 @@ +/* xlcompat.h - compatibility macros for multi-threading support */ +/* Copyright (c) 1984-2002, by David Michael Betz + All Rights Reserved + See the included file 'license.txt' for the full license. +*/ + +#ifndef __XLCOMPAT_H__ +#define __XLCOMPAT_H__ + +#include "xlcontext.h" + +/* + * Compatibility Layer for XLISP Threading + * + * These macros redirect all global variable accesses to the current + * thread's context. This allows existing code to work unchanged while + * supporting multiple interpreter instances. + * + * IMPORTANT: Do not use these macros in xlcontext.c where the actual + * context management is implemented. Define XLISP_CONTEXT_IMPL before + * including this header to disable the macros. + */ + +#ifndef XLISP_CONTEXT_IMPL + +/* ==================================================================== + * VM Registers + * ==================================================================== */ +#define xlFun (xlCtx()->fun) +#define xlEnv (xlCtx()->env) +#define xlVal (xlCtx()->val) +#define xlArgC (xlCtx()->argc) +#define xlNext (xlCtx()->next) + +/* ==================================================================== + * Stacks + * ==================================================================== */ +#define xlSP (xlCtx()->sp) +#define xlCSP (xlCtx()->csp) +#define xlStkBase (xlCtx()->stkBase) +#define xlStkTop (xlCtx()->stkTop) + +/* ==================================================================== + * Bytecode Interpreter State + * ==================================================================== */ +#define xlerrtarget (xlCtx()->errTarget) +#define xlcatch (xlCtx()->catchFrame) +#define xlTraceBytecodes (xlCtx()->traceBytecodes) + +/* Note: pc and pcBase are static in xlint.c, handled separately */ + +/* ==================================================================== + * Memory Management - Node Space + * ==================================================================== */ +#define xlNSegments (xlCtx()->nSegments) +#define xlNSLast (xlCtx()->nsLast) +#define xlFNodes (xlCtx()->fNodes) +#define xlNSSize (xlCtx()->nsSize) +#define xlNNodes (xlCtx()->nNodes) +#define xlNFree (xlCtx()->nFree) +#define xlNSCount (xlCtx()->nsCount) + +/* ==================================================================== + * Memory Management - Vector Space + * ==================================================================== */ +#define xlVSegments (xlCtx()->vSegments) +#define xlVSCurrent (xlCtx()->vsCurrent) +#define xlVFree (xlCtx()->vFree) +#define xlVTop (xlCtx()->vTop) +#define xlVSSize (xlCtx()->vsSize) +#define xlVSCount (xlCtx()->vsCount) + +/* ==================================================================== + * Memory Management - Other + * ==================================================================== */ +#define xlPPointers (xlCtx()->pPointers) +#define xlTotal (xlCtx()->total) +#define xlGCCalls (xlCtx()->gcCalls) + +/* ==================================================================== + * Important Singleton Values + * ==================================================================== */ +#define xlTrue (xlCtx()->vTrue) +#define xlFalse (xlCtx()->vFalse) +#define xlUnboundObject (xlCtx()->unboundObject) +#define xlDefaultObject (xlCtx()->defaultObject) +#define xlEofObject (xlCtx()->eofObject) + +/* ==================================================================== + * Package System + * ==================================================================== */ +#define xlPackages (xlCtx()->packages) +#define xlLispPackage (xlCtx()->lispPackage) +#define xlXLispPackage (xlCtx()->xlispPackage) +#define xlKeywordPackage (xlCtx()->keywordPackage) + +/* ==================================================================== + * Cached Symbols - Special Forms + * ==================================================================== */ +#define s_quote (xlCtx()->sym.quote) +#define s_function (xlCtx()->sym.function) +#define s_quasiquote (xlCtx()->sym.quasiquote) +#define s_unquote (xlCtx()->sym.unquote) +#define s_unquotesplicing (xlCtx()->sym.unquoteSplicing) +#define s_dot (xlCtx()->sym.dot) + +/* ==================================================================== + * Cached Symbols - System + * ==================================================================== */ +#define s_package (xlCtx()->sym.package) +#define s_eval (xlCtx()->sym.eval) +#define s_load (xlCtx()->sym.load) +#define s_print (xlCtx()->sym.print) +#define s_printcase (xlCtx()->sym.printCase) +#define s_eql (xlCtx()->sym.eql) +#define s_error (xlCtx()->sym.error) +#define s_stackpointer (xlCtx()->sym.stackPointer) +#define s_backtrace (xlCtx()->sym.backtrace) +#define s_unassigned (xlCtx()->sym.unassigned) + +/* ==================================================================== + * Cached Symbols - Standard Streams + * ==================================================================== */ +#define s_stdin (xlCtx()->sym.stdin_) +#define s_stdout (xlCtx()->sym.stdout_) +#define s_stderr (xlCtx()->sym.stderr_) + +/* ==================================================================== + * Cached Symbols - Format Strings + * ==================================================================== */ +#define s_fixfmt (xlCtx()->sym.fixfmt) +#define s_hexfmt (xlCtx()->sym.hexfmt) +#define s_flofmt (xlCtx()->sym.flofmt) +#define s_freeptr (xlCtx()->sym.freeptr) + +/* ==================================================================== + * Cached Symbols - Lambda List Keywords + * ==================================================================== */ +#define lk_optional (xlCtx()->sym.lk_optional) +#define lk_rest (xlCtx()->sym.lk_rest) +#define lk_key (xlCtx()->sym.lk_key) +#define lk_aux (xlCtx()->sym.lk_aux) +#define lk_allow_other_keys (xlCtx()->sym.lk_allow_other_keys) +#define slk_optional (xlCtx()->sym.slk_optional) +#define slk_rest (xlCtx()->sym.slk_rest) + +/* ==================================================================== + * Cached Symbols - Keywords + * ==================================================================== */ +#define k_upcase (xlCtx()->sym.k_upcase) +#define k_downcase (xlCtx()->sym.k_downcase) +#define k_internal (xlCtx()->sym.k_internal) +#define k_external (xlCtx()->sym.k_external) +#define k_inherited (xlCtx()->sym.k_inherited) +#define k_key (xlCtx()->sym.k_key) +#define k_uses (xlCtx()->sym.k_uses) +#define k_test (xlCtx()->sym.k_test) +#define k_testnot (xlCtx()->sym.k_testnot) +#define k_start (xlCtx()->sym.k_start) +#define k_end (xlCtx()->sym.k_end) +#define k_1start (xlCtx()->sym.k_1start) +#define k_1end (xlCtx()->sym.k_1end) +#define k_2start (xlCtx()->sym.k_2start) +#define k_2end (xlCtx()->sym.k_2end) +#define k_count (xlCtx()->sym.k_count) +#define k_fromend (xlCtx()->sym.k_fromend) + +/* ==================================================================== + * Reader State + * ==================================================================== */ +#define xlSymReadTable (xlCtx()->symReadTable) +#define xlSymNMacro (xlCtx()->symNMacro) +#define xlSymTMacro (xlCtx()->symTMacro) +#define xlSymWSpace (xlCtx()->symWSpace) +#define xlSymConst (xlCtx()->symConst) +#define xlSymSEscape (xlCtx()->symSEscape) +#define xlSymMEscape (xlCtx()->symMEscape) + +/* ==================================================================== + * Printer State + * ==================================================================== */ +#define xlPRBreadth (xlCtx()->prBreadth) +#define xlPRDepth (xlCtx()->prDepth) + +/* ==================================================================== + * I/O State + * ==================================================================== */ +#define xlTranscriptFP (xlCtx()->transcriptFP) + +/* ==================================================================== + * Initialization and Command Line + * ==================================================================== */ +#define xlInitializedP (xlCtx()->initialized) +#define xlCmdLineArgC (xlCtx()->cmdLineArgC) +#define xlCmdLineArgV (xlCtx()->cmdLineArgV) + +/* ==================================================================== + * Compiler State + * ==================================================================== */ +#define xlDebugModeP (xlCtx()->debugModeP) + +/* ==================================================================== + * Object System + * ==================================================================== */ +#define c_class (xlCtx()->c_class) +#define c_object (xlCtx()->c_object) +#define k_initialize (xlCtx()->k_initialize) + +#endif /* XLISP_CONTEXT_IMPL */ + +#endif /* __XLCOMPAT_H__ */ diff --git a/include/xlcontext.h b/include/xlcontext.h new file mode 100644 index 0000000..ce593b0 --- /dev/null +++ b/include/xlcontext.h @@ -0,0 +1,373 @@ +/* xlcontext.h - xlisp interpreter context for multi-threading support */ +/* Copyright (c) 1984-2002, by David Michael Betz + All Rights Reserved + See the included file 'license.txt' for the full license. +*/ + +#ifndef __XLCONTEXT_H__ +#define __XLCONTEXT_H__ + +#include /* for FILE* */ + +/* + * Forward declarations - only if xlisp.h hasn't been included yet. + * If xlisp.h is included first, these types are already defined. + */ +#ifndef __XLISP_H__ +typedef struct xlNode xlNode, *xlValue; +typedef struct xlNodeSegment xlNodeSegment; +typedef struct xlVectorSegment xlVectorSegment; +typedef struct xlProtectedPtrBlk xlProtectedPtrBlk; +typedef struct xlErrorTarget xlErrorTarget; +typedef struct xlCClass xlCClass; +typedef struct xlCallbacks xlCallbacks; +#endif + +/* Type definitions matching xlisp.h defaults */ +#ifndef xlFIXTYPE +#define xlFIXTYPE long +#endif + +#ifndef xlOFFTYPE +#define xlOFFTYPE long +#endif + +/* + * xlContext - Per-thread interpreter state + * + * This structure contains all state that was previously stored in global + * variables. Each thread that uses XLISP must have its own context. + * + * Usage: + * xlContext *ctx = xlCreateContext(); + * xlInitContext(ctx, callbacks, argc, argv, workspace); + * xlSetCurrentContext(ctx); + * // ... use XLISP API ... + * xlDestroyContext(ctx); + */ +typedef struct xlContext { + + /* ================================================================ + * VM Registers + * ================================================================ */ + xlValue fun; /* current function being executed */ + xlValue env; /* current lexical environment */ + xlValue val; /* value of most recent instruction */ + int argc; /* argument count for current call */ + void (*next)(void); /* next function to call (xlApply or NULL) */ + + /* ================================================================ + * Value and Control Stacks + * ================================================================ */ + xlValue *sp; /* value stack pointer (grows down) */ + xlValue *csp; /* control stack pointer (grows up) */ + xlValue *stkBase; /* base of stack allocation */ + xlValue *stkTop; /* top of stack allocation */ + + /* ================================================================ + * Bytecode Interpreter State + * ================================================================ */ + unsigned char *pc; /* program counter */ + unsigned char *pcBase; /* base of current code object */ + xlErrorTarget *errTarget; /* error/abort target chain */ + xlValue *catchFrame; /* current catch frame pointer */ + int traceBytecodes; /* bytecode tracing enabled */ + int sample; /* control character sample counter */ + + /* ================================================================ + * Memory Management - Node Space + * ================================================================ */ + xlNodeSegment *nSegments; /* list of node segments */ + xlNodeSegment *nsLast; /* last node segment (for appending) */ + xlValue fNodes; /* head of free node list */ + xlFIXTYPE nsSize; /* default nodes per segment */ + xlFIXTYPE nNodes; /* total number of nodes allocated */ + xlFIXTYPE nFree; /* number of nodes in free list */ + int nsCount; /* number of node segments */ + + /* ================================================================ + * Memory Management - Vector Space + * ================================================================ */ + xlVectorSegment *vSegments; /* list of vector segments */ + xlVectorSegment *vsCurrent; /* current vector segment */ + xlValue *vFree; /* next free location in vector space */ + xlValue *vTop; /* top of current vector segment */ + xlFIXTYPE vsSize; /* default size of vector segments */ + int vsCount; /* number of vector segments */ + + /* ================================================================ + * Memory Management - Protected Pointers + * ================================================================ */ + xlProtectedPtrBlk *pPointers; /* protected pointer blocks */ + + /* ================================================================ + * Memory Management - Statistics + * ================================================================ */ + xlFIXTYPE total; /* total bytes of memory in use */ + xlFIXTYPE gcCalls; /* number of GC invocations */ + + /* ================================================================ + * Important Singleton Values + * ================================================================ */ + xlValue vTrue; /* #t */ + xlValue vFalse; /* #f */ + xlValue unboundObject; /* marker for unbound variables */ + xlValue defaultObject; /* default object for methods */ + xlValue eofObject; /* end-of-file object */ + + /* ================================================================ + * Package System + * ================================================================ */ + xlValue packages; /* list of all packages */ + xlValue lispPackage; /* the LISP package */ + xlValue xlispPackage; /* the XLISP package */ + xlValue keywordPackage; /* the KEYWORD package */ + + /* ================================================================ + * Cached Symbols - Frequently Used + * ================================================================ */ + struct { + /* Special forms and core */ + xlValue quote; + xlValue function; + xlValue quasiquote; + xlValue unquote; + xlValue unquoteSplicing; + xlValue dot; + + /* System symbols */ + xlValue package; + xlValue eval; + xlValue load; + xlValue print; + xlValue printCase; + xlValue eql; + xlValue error; + xlValue stackPointer; + xlValue backtrace; + xlValue unassigned; + + /* Standard streams */ + xlValue stdin_; + xlValue stdout_; + xlValue stderr_; + + /* Format strings */ + xlValue fixfmt; + xlValue hexfmt; + xlValue flofmt; + xlValue freeptr; + + /* Lambda list keywords */ + xlValue lk_optional; + xlValue lk_rest; + xlValue lk_key; + xlValue lk_aux; + xlValue lk_allow_other_keys; + + /* Scheme-style lambda keywords */ + xlValue slk_optional; + xlValue slk_rest; + + /* Keyword symbols for functions */ + xlValue k_upcase; + xlValue k_downcase; + xlValue k_internal; + xlValue k_external; + xlValue k_inherited; + xlValue k_key; + xlValue k_uses; + xlValue k_test; + xlValue k_testnot; + xlValue k_start; + xlValue k_end; + xlValue k_1start; + xlValue k_1end; + xlValue k_2start; + xlValue k_2end; + xlValue k_count; + xlValue k_fromend; + + } sym; + + /* ================================================================ + * Reader State + * ================================================================ */ + xlValue symReadTable; /* read table symbol */ + xlValue symNMacro; /* non-terminating macro */ + xlValue symTMacro; /* terminating macro */ + xlValue symWSpace; /* whitespace */ + xlValue symConst; /* constituent */ + xlValue symSEscape; /* single escape */ + xlValue symMEscape; /* multiple escape */ + + /* ================================================================ + * Printer State + * ================================================================ */ + int prBreadth; /* print breadth limit (-1 = unlimited) */ + int prDepth; /* print depth limit (-1 = unlimited) */ + + /* ================================================================ + * I/O State + * ================================================================ */ + FILE *transcriptFP; /* transcript file pointer */ + + /* ================================================================ + * Callbacks + * ================================================================ */ + xlCallbacks *callbacks; /* host application callbacks */ + + /* ================================================================ + * Compiler State + * ================================================================ */ + int debugModeP; /* true to turn off tail recursion */ + + /* ================================================================ + * Initialization State + * ================================================================ */ + int initialized; /* non-zero if fully initialized */ + + /* ================================================================ + * Command Line + * ================================================================ */ + int cmdLineArgC; /* argument count */ + const char **cmdLineArgV; /* argument vector */ + + /* ================================================================ + * C Class Registry + * ================================================================ */ + xlCClass *cClasses; /* linked list of C classes */ + + /* ================================================================ + * Object System + * ================================================================ */ + xlValue c_class; /* the Class class */ + xlValue c_object; /* the Object class */ + xlValue k_initialize; /* :initialize keyword */ + +} xlContext; + + +/* ==================================================================== + * Thread-Local Storage Configuration + * ==================================================================== */ + +#if defined(_WIN32) || defined(_WIN64) + /* Windows: use __declspec(thread) */ + #define XLISP_TLS __declspec(thread) + #define XLISP_TLS_NATIVE 1 +#elif defined(__GNUC__) || defined(__clang__) + /* GCC/Clang: use __thread */ + #define XLISP_TLS __thread + #define XLISP_TLS_NATIVE 1 +#else + /* Fallback: use pthread_getspecific */ + #define XLISP_TLS + #define XLISP_TLS_PTHREAD 1 +#endif + + +/* ==================================================================== + * Context Access + * ==================================================================== */ + +#ifdef XLISP_TLS_NATIVE + /* Fast path: native thread-local storage */ + extern XLISP_TLS xlContext *xl_current_context; + #define xlCtx() xl_current_context +#else + /* Slow path: pthread TLS */ + xlContext *xlGetCurrentContext(void); + #define xlCtx() xlGetCurrentContext() +#endif + + +/* ==================================================================== + * Context Management API + * ==================================================================== */ + +#ifndef xlEXPORT +#define xlEXPORT +#endif + +/* + * xlCreateContext - Allocate a new interpreter context + * + * Returns a newly allocated context structure, or NULL on failure. + * The context is not initialized; call xlInitContext() before use. + */ +xlEXPORT xlContext *xlCreateContext(void); + +/* + * xlDestroyContext - Free an interpreter context + * + * Releases all memory associated with the context, including: + * - Node segments + * - Vector segments + * - Stack space + * - Protected pointer blocks + * + * The context must not be in use by any thread when destroyed. + */ +xlEXPORT void xlDestroyContext(xlContext *ctx); + +/* + * xlSetCurrentContext - Set the current thread's context + * + * This must be called before using any XLISP functions. + * Each thread should have its own context. + */ +xlEXPORT void xlSetCurrentContext(xlContext *ctx); + +/* + * xlGetCurrentContext - Get the current thread's context + * + * Returns the context set by xlSetCurrentContext(), or NULL if none. + */ +#ifndef XLISP_TLS_NATIVE +xlEXPORT xlContext *xlGetCurrentContext(void); +#else +#define xlGetCurrentContext() xl_current_context +#endif + +/* + * xlInitContext - Initialize an interpreter context + * + * This performs the same initialization as xlInit(), but for a + * specific context. The context must have been created with + * xlCreateContext(). + * + * Parameters: + * ctx - Context to initialize + * callbacks - Host application callbacks (or NULL for defaults) + * argc - Command line argument count + * argv - Command line argument vector + * workspace - Workspace file to load (or NULL) + * + * Returns 0 on success, non-zero on failure. + */ +xlEXPORT int xlInitContext( + xlContext *ctx, + xlCallbacks *callbacks, + int argc, + const char *argv[], + const char *workspace +); + +/* + * xlContextInitMemory - Initialize memory management for a context + * + * Called internally by xlInitContext(). Allocates the initial + * stack space and prepares the memory allocator. + */ +void xlContextInitMemory(xlContext *ctx, xlFIXTYPE stackSize); + +/* + * xlContextInitSymbols - Initialize symbols for a context + * + * Called internally by xlInitContext(). Creates the initial + * packages and interns the standard symbols. + */ +void xlContextInitSymbols(xlContext *ctx); + +#endif /* __XLCONTEXT_H__ */ diff --git a/include/xlisp.h b/include/xlisp.h index 63100cd..bb821e0 100755 --- a/include/xlisp.h +++ b/include/xlisp.h @@ -499,6 +499,12 @@ struct xlVectorSegment { xlValue vs_data[1]; /* segment data */ }; +/* + * When XLISP_USE_CONTEXT is defined, these are macros in xlcompat.h. + * Otherwise, they are extern declarations for traditional globals. + */ +#ifndef XLISP_USE_CONTEXT + /* node space */ extern xlFIXTYPE xlNSSize; /* node segment size */ extern xlNodeSegment *xlNSegments; /* list of node segments */ @@ -521,6 +527,8 @@ extern xlFIXTYPE xlGCCalls; /* number of calls to the garbage collec extern const char **xlCmdLineArgV; extern int xlCmdLineArgC; +#endif /* !XLISP_USE_CONTEXT */ + /* subr definition structure */ typedef struct { const char *name; @@ -622,7 +630,8 @@ typedef struct { void (*exit)(int sts); } xlCallbacks; -/* external variables */ +/* external variables - wrapped for context mode */ +#ifndef XLISP_USE_CONTEXT xlEXPORT extern int xlInitializedP; /* true if initialization is done */ xlEXPORT extern FILE *xlTranscriptFP; /* transcript file pointer */ xlEXPORT extern xlValue *xlStkBase; /* base of value stack */ @@ -650,6 +659,7 @@ xlEXPORT extern xlValue xlSymWSpace; xlEXPORT extern xlValue xlSymConst; xlEXPORT extern xlValue xlSymSEscape; xlEXPORT extern xlValue xlSymMEscape; +#endif /* !XLISP_USE_CONTEXT */ /* API status codes */ #define xlsSuccess 0 @@ -1313,5 +1323,23 @@ void xlosEnter(void); /* setup default callbacks */ xlEXPORT xlCallbacks *xlDefaultCallbacks(const char *programPath); +/* ==================================================================== + * Threading Support + * + * When XLISP_USE_CONTEXT is defined, all global variables are replaced + * with macros that access the current thread's context. This allows + * multiple interpreter instances in different threads. + * + * To enable threading: + * #define XLISP_USE_CONTEXT + * #include "xlisp.h" + * + * Or compile with -DXLISP_USE_CONTEXT + * ==================================================================== */ +#ifdef XLISP_USE_CONTEXT +#include "xlcompat.h" +#include "xlthread.h" +#endif + #endif diff --git a/include/xlthread.h b/include/xlthread.h new file mode 100644 index 0000000..3d0476d --- /dev/null +++ b/include/xlthread.h @@ -0,0 +1,280 @@ +/* xlthread.h - thread-safe XLISP API */ +/* Copyright (c) 1984-2002, by David Michael Betz + All Rights Reserved + See the included file 'license.txt' for the full license. +*/ + +#ifndef __XLTHREAD_H__ +#define __XLTHREAD_H__ + +#include "xlcontext.h" + +/* + * Thread-Safe XLISP API + * + * This header provides the public API for using XLISP in a multi-threaded + * application. Each thread that needs to use XLISP must have its own + * interpreter context. + * + * Basic usage pattern: + * + * void *worker_thread(void *arg) { + * xlContext *ctx; + * xlValue result; + * + * // Create and initialize context for this thread + * ctx = xlCreateContext(); + * if (!ctx) return NULL; + * + * if (xlInitContext(ctx, xlDefaultCallbacks(NULL), 0, NULL, NULL)) { + * xlDestroyContext(ctx); + * return NULL; + * } + * + * // Set as current context for this thread + * xlSetCurrentContext(ctx); + * + * // Now standard XLISP API can be used + * xlEvaluateCString(&result, 1, "(+ 1 2)"); + * + * // Or use explicit context versions + * xlEvaluateCStringCtx(ctx, &result, 1, "(* 6 7)"); + * + * // Cleanup when done + * xlDestroyContext(ctx); + * return NULL; + * } + * + * IMPORTANT NOTES: + * + * 1. Each thread MUST have its own context. Contexts are NOT thread-safe + * and must not be shared between threads. + * + * 2. Lisp objects (xlValue) belong to their context's heap. Do NOT pass + * xlValue objects between threads - they will become invalid or cause + * memory corruption. + * + * 3. For inter-thread communication, serialize Lisp data to strings or + * use C-level data structures with your own synchronization. + * + * 4. Each context has its own garbage collector. GC in one thread does + * not affect other threads. + */ + + +/* ==================================================================== + * Context Management (re-exported from xlcontext.h) + * ==================================================================== */ + +/* These are declared in xlcontext.h but re-listed here for convenience */ + +/* + * xlCreateContext - Create a new interpreter context + * + * Allocates and returns a new context structure. The context is not + * initialized; you must call xlInitContext() before use. + * + * Returns NULL on allocation failure. + */ +/* xlEXPORT xlContext *xlCreateContext(void); */ + +/* + * xlDestroyContext - Destroy an interpreter context + * + * Frees all memory associated with the context. The context must not + * be in use when destroyed. If this is the current context, you should + * call xlSetCurrentContext(NULL) first. + */ +/* xlEXPORT void xlDestroyContext(xlContext *ctx); */ + +/* + * xlSetCurrentContext - Set the current thread's context + * + * Sets the context that will be used by all standard XLISP API calls + * in the current thread. Pass NULL to clear the current context. + */ +/* xlEXPORT void xlSetCurrentContext(xlContext *ctx); */ + +/* + * xlGetCurrentContext - Get the current thread's context + * + * Returns the context set by xlSetCurrentContext(), or NULL if none. + */ +/* xlEXPORT xlContext *xlGetCurrentContext(void); */ + +/* + * xlInitContext - Initialize an interpreter context + * + * Initializes a context for use. This sets up memory management, + * creates the initial packages and symbols, and optionally loads + * a workspace image. + * + * Parameters: + * ctx - Context created by xlCreateContext() + * callbacks - Application callbacks, or NULL for defaults + * argc - Command line argument count + * argv - Command line arguments + * workspace - Workspace file to load, or NULL + * + * Returns 0 on success, non-zero on failure. + */ +/* xlEXPORT int xlInitContext(xlContext *ctx, xlCallbacks *callbacks, + int argc, const char *argv[], + const char *workspace); */ + + +/* ==================================================================== + * Thread-Safe API Functions (Explicit Context Parameter) + * + * These functions take an explicit context parameter instead of using + * the thread-local current context. They are useful when you need to + * operate on a context that is not the current thread's context. + * ==================================================================== */ + +/* Forward declaration of xlValue - full definition in xlisp.h */ +#ifndef __XLISP_H__ +typedef struct xlNode *xlValue; +#endif + +/* + * xlCallFunctionCtx - Call a Lisp function with explicit context + * + * Same as xlCallFunction() but uses the specified context. + */ +xlEXPORT int xlCallFunctionCtx( + xlContext *ctx, + xlValue *values, + int vmax, + xlValue fun, + int argc, + ... +); + +/* + * xlCallFunctionByNameCtx - Call a named function with explicit context + * + * Same as xlCallFunctionByName() but uses the specified context. + */ +xlEXPORT int xlCallFunctionByNameCtx( + xlContext *ctx, + xlValue *values, + int vmax, + const char *fname, + int argc, + ... +); + +/* + * xlEvaluateCtx - Evaluate an expression with explicit context + * + * Same as xlEvaluate() but uses the specified context. + */ +xlEXPORT int xlEvaluateCtx( + xlContext *ctx, + xlValue *values, + int vmax, + xlValue expr +); + +/* + * xlEvaluateCStringCtx - Evaluate a C string with explicit context + * + * Same as xlEvaluateCString() but uses the specified context. + */ +xlEXPORT int xlEvaluateCStringCtx( + xlContext *ctx, + xlValue *values, + int vmax, + const char *str +); + +/* + * xlEvaluateStringCtx - Evaluate a string with explicit context + * + * Same as xlEvaluateString() but uses the specified context. + */ +xlEXPORT int xlEvaluateStringCtx( + xlContext *ctx, + xlValue *values, + int vmax, + const char *str, + xlFIXTYPE len +); + +/* + * xlLoadFileCtx - Load a file with explicit context + * + * Same as xlLoadFile() but uses the specified context. + */ +xlEXPORT int xlLoadFileCtx( + xlContext *ctx, + const char *fname +); + +/* + * xlReadFromCStringCtx - Read from a C string with explicit context + * + * Same as xlReadFromCString() but uses the specified context. + */ +xlEXPORT int xlReadFromCStringCtx( + xlContext *ctx, + const char *str, + xlValue *pval +); + +/* + * xlGCCtx - Force garbage collection with explicit context + * + * Triggers garbage collection for the specified context. + */ +xlEXPORT void xlGCCtx(xlContext *ctx); + + +/* ==================================================================== + * Utility Functions + * ==================================================================== */ + +/* + * xlContextIsInitialized - Check if a context is initialized + * + * Returns non-zero if the context has been successfully initialized. + */ +#define xlContextIsInitialized(ctx) ((ctx)->initialized) + +/* + * xlContextMemoryUsage - Get memory usage for a context + * + * Returns the total bytes of memory allocated by the context. + */ +#define xlContextMemoryUsage(ctx) ((ctx)->total) + +/* + * xlContextGCCount - Get GC count for a context + * + * Returns the number of garbage collections performed by the context. + */ +#define xlContextGCCount(ctx) ((ctx)->gcCalls) + + +/* ==================================================================== + * Thread Safety Utilities + * ==================================================================== */ + +/* + * xlWithContext - Execute code with a specific context + * + * This macro temporarily sets a context as current, executes the + * given code block, and restores the previous context. + * + * Usage: + * xlWithContext(ctx) { + * // code using ctx as current context + * } + */ +#define xlWithContext(ctx) \ + for (xlContext *_xl_saved_ctx = xlGetCurrentContext(), \ + *_xl_once = (xlSetCurrentContext(ctx), (xlContext*)1); \ + _xl_once; \ + xlSetCurrentContext(_xl_saved_ctx), _xl_once = NULL) + +#endif /* __XLTHREAD_H__ */ diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index d2869e3..56e4cf7 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -4,6 +4,7 @@ set(xlisp_sources xlbcode.h xlcobj.c xlcom.c + xlcontext.c xldbg.c xldmem.c xlfasl.c @@ -23,7 +24,10 @@ set(xlisp_sources xlprint.c xlread.c xlsym.c - "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlisp.h") + "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlisp.h" + "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlcontext.h" + "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlcompat.h" + "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlthread.h") if(${CMAKE_SYSTEM} STREQUAL Windows) list(APPEND xlisp_sources msstuff.c) @@ -33,3 +37,6 @@ endif() target_sources(xlisp PRIVATE ${xlisp_sources}) target_include_directories(xlisp PUBLIC ${CMAKE_CURRENT_SOURCE_DIR}/../include) + +# Enable position-independent code for TLS compatibility with shared libraries +set_target_properties(xlisp PROPERTIES POSITION_INDEPENDENT_CODE ON) diff --git a/src/unstuff.c b/src/unstuff.c index 0642078..9f89638 100755 --- a/src/unstuff.c +++ b/src/unstuff.c @@ -11,8 +11,10 @@ #endif #include "xlisp.h" +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue s_unbound; +#endif /* local variables */ #define LBSIZE 100 diff --git a/src/xlansi.c b/src/xlansi.c index 8b08fb5..4270639 100755 --- a/src/xlansi.c +++ b/src/xlansi.c @@ -104,7 +104,9 @@ xlEXPORT void xlosCheck(void) /* xlosInfo - show information on control-t */ xlEXPORT void xlosInfo(void) { +#ifndef XLISP_USE_CONTEXT extern xlFIXTYPE xlNFree,xlGCCalls,xlTotal; +#endif char buf[80]; sprintf(buf,"\n[ Free: %ld, GC calls: %ld, Total: %ld ]",xlNFree,xlGCCalls,xlTotal); xlErrPutStr(buf); diff --git a/src/xlapi.c b/src/xlapi.c index c35354c..86156a1 100755 --- a/src/xlapi.c +++ b/src/xlapi.c @@ -10,8 +10,10 @@ static void (*idleHandler)(void *data) = NULL; static void *idleData; +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue *xlcatch,s_eval,s_load,xlUnboundObject,xlEofObject; +#endif /* prototypes */ static const char *PrintToString(xlValue expr,char *buf,xlFIXTYPE len,int escFlag); diff --git a/src/xlcom.c b/src/xlcom.c index 43ca7a2..df0f100 100755 --- a/src/xlcom.c +++ b/src/xlcom.c @@ -26,12 +26,14 @@ #define slambdakey(x) ((x) == slk_optional \ || (x) == slk_rest) +#ifndef XLISP_USE_CONTEXT /* global variables */ xlEXPORT int xlDebugModeP = FALSE; /* external variables */ extern xlValue lk_optional,lk_rest,lk_key,lk_allow_other_keys,lk_aux; extern xlValue slk_optional,slk_rest; +#endif /* local variables */ static xlValue info; /* compiler info */ @@ -393,6 +395,7 @@ static void do_method(xlValue form,int cont) selector = xlCar(xlCdr(form)); fargs = xlCar(xlCdr(xlCdr(form))); body = xlCdr(xlCdr(xlCdr(form))); + (void)object; (void)selector; (void)fargs; (void)body; cd_fundefinition(xlCar(form),xlCar(xlCdr(form)),xlCdr(xlCdr(form))); @@ -717,7 +720,9 @@ static void add_extra_arguments(xlValue fargs) /* parse_optional_arguments - parse the &optional arguments */ static void parse_optional_arguments(xlValue key,xlValue *pfargs,int base) { +#ifndef XLISP_USE_CONTEXT extern xlValue xlDefaultObject; +#endif int patch,patch2,chain,off,oargc=0; xlValue fargs,arg,def,svar; @@ -871,7 +876,9 @@ static void parse_key_arguments(xlValue *pfargs,int base) /* parse_key_argument - parse a single &key argument */ static void parse_key_argument(xlValue form,xlValue *parg,xlValue *pkey,xlValue *pdef,xlValue *psvar) { +#ifndef XLISP_USE_CONTEXT extern xlValue xlKeywordPackage; +#endif xlValue key; *pkey = *pdef = *psvar = xlNil; if (xlConsP(form)) { diff --git a/src/xlcontext.c b/src/xlcontext.c new file mode 100644 index 0000000..4b0a626 --- /dev/null +++ b/src/xlcontext.c @@ -0,0 +1,432 @@ +/* xlcontext.c - xlisp interpreter context management */ +/* Copyright (c) 1984-2002, by David Michael Betz + All Rights Reserved + See the included file 'license.txt' for the full license. +*/ + +/* + * This file must be compiled WITHOUT the compatibility macros, + * since it implements the actual context management. + */ +#define XLISP_CONTEXT_IMPL 1 + +#include "xlisp.h" +#include "xlcontext.h" + +#include +#include + +/* ==================================================================== + * Thread-Local Storage + * ==================================================================== */ + +#ifdef XLISP_TLS_NATIVE +/* Native thread-local storage */ +XLISP_TLS xlContext *xl_current_context = NULL; + +#else +/* Pthread-based thread-local storage */ +#include + +static pthread_key_t xl_context_key; +static pthread_once_t xl_context_key_once = PTHREAD_ONCE_INIT; + +static void xl_create_key(void) { + pthread_key_create(&xl_context_key, NULL); +} + +xlEXPORT xlContext *xlGetCurrentContext(void) { + pthread_once(&xl_context_key_once, xl_create_key); + return (xlContext *)pthread_getspecific(xl_context_key); +} + +static void xl_set_context_pthread(xlContext *ctx) { + pthread_once(&xl_context_key_once, xl_create_key); + pthread_setspecific(xl_context_key, ctx); +} +#endif + + +/* ==================================================================== + * Context Creation and Destruction + * ==================================================================== */ + +/* + * xlCreateContext - Allocate a new interpreter context + */ +xlEXPORT xlContext *xlCreateContext(void) { + xlContext *ctx; + + /* Allocate the context structure */ + ctx = (xlContext *)malloc(sizeof(xlContext)); + if (ctx == NULL) + return NULL; + + /* Zero-initialize the entire structure */ + memset(ctx, 0, sizeof(xlContext)); + + /* Set default sizes */ + ctx->nsSize = xlNSSIZE; + ctx->vsSize = xlVSSIZE; + + /* Initialize printer limits */ + ctx->prBreadth = -1; + ctx->prDepth = -1; + + return ctx; +} + +/* + * xlDestroyContext - Free an interpreter context + */ +xlEXPORT void xlDestroyContext(xlContext *ctx) { + xlNodeSegment *nseg, *next_nseg; + xlVectorSegment *vseg, *next_vseg; + xlProtectedPtrBlk *ppb, *next_ppb; + + if (ctx == NULL) + return; + + /* Free node segments */ + for (nseg = ctx->nSegments; nseg != NULL; nseg = next_nseg) { + next_nseg = nseg->ns_next; + free(nseg); + } + + /* Free vector segments */ + for (vseg = ctx->vSegments; vseg != NULL; vseg = next_vseg) { + next_vseg = vseg->vs_next; + free(vseg); + } + + /* Free protected pointer blocks */ + for (ppb = ctx->pPointers; ppb != NULL; ppb = next_ppb) { + next_ppb = ppb->next; + free(ppb); + } + + /* Free the stack */ + if (ctx->stkBase != NULL) + free(ctx->stkBase); + + /* Free the context structure itself */ + free(ctx); +} + + +/* ==================================================================== + * Context Selection + * ==================================================================== */ + +/* + * xlSetCurrentContext - Set the current thread's context + */ +xlEXPORT void xlSetCurrentContext(xlContext *ctx) { +#ifdef XLISP_TLS_NATIVE + xl_current_context = ctx; +#else + xl_set_context_pthread(ctx); +#endif +} + + +/* ==================================================================== + * Context Initialization + * ==================================================================== */ + +/* + * xlContextInitMemory - Initialize memory management for a context + * + * This allocates the stack and prepares the memory allocator. + * It does NOT allocate node/vector segments yet - that happens on demand. + */ +void xlContextInitMemory(xlContext *ctx, xlFIXTYPE stackSize) { + xlFIXTYPE n; + + /* Initialize basic values */ + ctx->vTrue = NULL; + ctx->vFalse = NULL; + ctx->unboundObject = NULL; + ctx->defaultObject = NULL; + ctx->eofObject = NULL; + ctx->packages = NULL; + + /* Initialize VM registers */ + ctx->fun = NULL; + ctx->env = NULL; + ctx->val = NULL; + ctx->argc = 0; + ctx->next = NULL; + + /* Initialize statistics */ + ctx->gcCalls = 0; + ctx->total = 0; + + /* Initialize node space */ + ctx->nSegments = NULL; + ctx->nsLast = NULL; + ctx->nsCount = 0; + ctx->nNodes = 0; + ctx->nFree = 0; + ctx->fNodes = NULL; + + /* Initialize vector space */ + ctx->vSegments = NULL; + ctx->vsCurrent = NULL; + ctx->vsCount = 0; + ctx->vFree = NULL; + ctx->vTop = NULL; + + /* Initialize protected pointers */ + ctx->pPointers = NULL; + + /* Allocate the stack */ + n = stackSize * sizeof(xlValue); + ctx->stkBase = (xlValue *)malloc(n); + if (ctx->stkBase == NULL) { + /* Caller should check for initialization failure */ + return; + } + ctx->total += n; + + /* Initialize stack pointers */ + ctx->stkTop = ctx->stkBase + stackSize; + ctx->sp = ctx->stkTop; /* value stack starts at top, grows down */ + ctx->csp = ctx->stkBase; /* control stack starts at base, grows up */ +} + +/* + * xlInitContext - Initialize an interpreter context + * + * This is the main initialization function that sets up a context + * for use. It must be called after xlCreateContext() and before + * using the context. + * + * This performs the same initialization as xlInit(), including: + * - Setting up callbacks + * - Initializing memory management + * - Creating packages and symbols (via xlInitWorkspace) + * - Optionally restoring a workspace image + */ +xlEXPORT int xlInitContext( + xlContext *ctx, + xlCallbacks *callbacks, + int argc, + const char *argv[], + const char *workspace +) { + xlContext *saved_ctx; + xlErrorTarget target; + + if (ctx == NULL) + return -1; + + /* Save current context and set this one as active */ + saved_ctx = xlGetCurrentContext(); + xlSetCurrentContext(ctx); + + /* Store callbacks and set them via xlSetCallbacks */ + ctx->callbacks = callbacks; + xlSetCallbacks(callbacks); + + /* Store command line */ + ctx->cmdLineArgC = argc; + ctx->cmdLineArgV = argv; + + /* Set default segment sizes */ + ctx->nsSize = xlNSSIZE; + ctx->vsSize = xlVSSIZE; + + /* Setup an initialization error handler */ + xlPushTarget(&target); + if (setjmp(target.target)) { + xlPopTarget(); + xlSetCurrentContext(saved_ctx); + return -1; + } + + /* + * Initialize the workspace. This calls xlInitMemory() which + * sets up the stack, then creates packages and symbols. + * Since the context is now current, all the macros (xlSP, xlEnv, etc.) + * will access this context's fields. + */ + if (!workspace || !xlRestoreImage(workspace)) + xlInitWorkspace(xlSTACKSIZE); + + /* Done with initialization */ + xlPopTarget(); + + /* Mark as initialized */ + ctx->initialized = 1; + + /* Keep this context as current (don't restore saved) */ + /* xlSetCurrentContext(saved_ctx); */ + + return 0; +} + + +/* ==================================================================== + * Explicit Context API Functions + * + * These functions operate on an explicit context parameter. + * They temporarily set the context as current, perform the operation, + * and restore the previous context. + * + * NOTE: Full implementation requires the rest of the XLISP system + * to be integrated with the context system. For Phase 1, these + * are stub implementations. + * ==================================================================== */ + +/* + * Helper macro to wrap operations with context switching + */ +#define WITH_CONTEXT(ctx, code) do { \ + xlContext *_saved = xlGetCurrentContext(); \ + xlSetCurrentContext(ctx); \ + code; \ + xlSetCurrentContext(_saved); \ +} while (0) + +/* + * xlGCCtx - Force garbage collection for a specific context + */ +xlEXPORT void xlGCCtx(xlContext *ctx) { + WITH_CONTEXT(ctx, { + /* xlGC() will be called here once integrated */ + /* For now, this is a placeholder */ + }); +} + +/* + * The remaining *Ctx functions are stubs for Phase 1. + * They will be fully implemented when the interpreter + * is integrated with the context system. + * + * xlCallFunctionCtx + * xlCallFunctionByNameCtx + * xlEvaluateCtx + * xlEvaluateCStringCtx + * xlEvaluateStringCtx + * xlLoadFileCtx + * xlReadFromCStringCtx + */ + +/* Stub implementations - to be completed in later phases */ + +xlEXPORT int xlEvaluateCStringCtx( + xlContext *ctx, + xlValue *values, + int vmax, + const char *str +) { + int result = -1; + WITH_CONTEXT(ctx, { + /* result = xlEvaluateCString(values, vmax, str); */ + /* Stub: not yet integrated */ + (void)values; + (void)vmax; + (void)str; + }); + return result; +} + +xlEXPORT int xlEvaluateStringCtx( + xlContext *ctx, + xlValue *values, + int vmax, + const char *str, + xlFIXTYPE len +) { + int result = -1; + WITH_CONTEXT(ctx, { + /* result = xlEvaluateString(values, vmax, str, len); */ + (void)values; + (void)vmax; + (void)str; + (void)len; + }); + return result; +} + +xlEXPORT int xlEvaluateCtx( + xlContext *ctx, + xlValue *values, + int vmax, + xlValue expr +) { + int result = -1; + WITH_CONTEXT(ctx, { + /* result = xlEvaluate(values, vmax, expr); */ + (void)values; + (void)vmax; + (void)expr; + }); + return result; +} + +xlEXPORT int xlLoadFileCtx( + xlContext *ctx, + const char *fname +) { + int result = -1; + WITH_CONTEXT(ctx, { + /* result = xlLoadFile(fname); */ + (void)fname; + }); + return result; +} + +xlEXPORT int xlReadFromCStringCtx( + xlContext *ctx, + const char *str, + xlValue *pval +) { + int result = -1; + WITH_CONTEXT(ctx, { + /* result = xlReadFromCString(str, pval); */ + (void)str; + (void)pval; + }); + return result; +} + +/* + * Variadic functions require special handling. + * These will be implemented using va_list versions in later phases. + */ + +xlEXPORT int xlCallFunctionCtx( + xlContext *ctx, + xlValue *values, + int vmax, + xlValue fun, + int argc, + ... +) { + (void)ctx; + (void)values; + (void)vmax; + (void)fun; + (void)argc; + /* Stub - requires va_list integration */ + return -1; +} + +xlEXPORT int xlCallFunctionByNameCtx( + xlContext *ctx, + xlValue *values, + int vmax, + const char *fname, + int argc, + ... +) { + (void)ctx; + (void)values; + (void)vmax; + (void)fname; + (void)argc; + /* Stub - requires va_list integration */ + return -1; +} diff --git a/src/xldmem.c b/src/xldmem.c index 0112738..ff1e170 100755 --- a/src/xldmem.c +++ b/src/xldmem.c @@ -8,6 +8,17 @@ #undef DEBUG_GC +/* + * When XLISP_USE_CONTEXT is defined, all these "globals" become macros + * that access xlCtx()->field. The actual storage is in the xlContext + * structure, managed by xlcontext.c. + * + * When not defined, we use traditional global variables for backward + * compatibility with single-threaded use. + */ + +#ifndef XLISP_USE_CONTEXT + /* virtual machine registers */ xlEXPORT xlValue xlFun; /* current function */ xlEXPORT xlValue xlEnv; /* current environment */ @@ -48,12 +59,14 @@ int xlVSCount; /* number of vector segments */ xlValue *xlVFree; /* next free location in vector space */ xlValue *xlVTop; /* top of vector space */ -/* external variables */ +/* external variables - only needed in legacy mode */ extern xlValue xlPackages; /* list of packages */ extern xlValue xlUnboundObject; /* unbound indicator */ extern xlValue xlDefaultObject; /* default object */ extern xlValue xlEofObject; /* eof object */ +#endif /* !XLISP_USE_CONTEXT */ + /* forward declarations */ static xlValue allocnode(int); static void findmemory(void); diff --git a/src/xlfasl.c b/src/xlfasl.c index 856a54d..96a9aa3 100755 --- a/src/xlfasl.c +++ b/src/xlfasl.c @@ -6,8 +6,10 @@ #include "xlisp.h" +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue xlEofObject; +#endif /* prototypes */ static int faslwritecode(xlValue fptr,xlValue code); diff --git a/src/xlfun1.c b/src/xlfun1.c index d7e4478..715b30d 100755 --- a/src/xlfun1.c +++ b/src/xlfun1.c @@ -10,10 +10,12 @@ static char gsprefix[xlSTRMAX+1] = { 'G',0 }; /* gensym prefix string */ static xlFIXTYPE gsnumber = 1; /* gensym number */ +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue xlEnv,xlVal,xlDefaultObject; extern xlValue xlUnboundObject,s_package,s_eql,k_uses,k_test,k_testnot,k_key; extern xlValue xlPackages,xlLispPackage,xlLispPackage,xlLispPackage; +#endif /* forward declarations */ static xlValue cxr(const char *adstr); diff --git a/src/xlfun2.c b/src/xlfun2.c index f73bc8d..8d04154 100755 --- a/src/xlfun2.c +++ b/src/xlfun2.c @@ -11,11 +11,13 @@ #define TLEFT 1 #define TRIGHT 2 +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue xlEofObject,s_hexfmt; extern xlValue s_stdin,s_stdout,s_stderr,s_error; extern xlValue k_start,k_end,k_1start,k_1end,k_2start,k_2end,k_fromend; extern int xlPRBreadth,xlPRDepth; +#endif /* forward declarations */ static xlValue setit(int *pvar); @@ -44,7 +46,9 @@ xlValue xsymstr(void) /* xstrsym - built-in function 'string->symbol' */ xlValue xstrsym(void) { +#ifndef XLISP_USE_CONTEXT extern xlValue s_package; +#endif xlValue key; xlVal = xlGetArgString(); xlLastArg(); diff --git a/src/xlfun3.c b/src/xlfun3.c index 20d5e4b..3df6cd6 100755 --- a/src/xlfun3.c +++ b/src/xlfun3.c @@ -6,8 +6,10 @@ #include "xlisp.h" +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue s_package; +#endif /* forward declarations */ static const char *showstring(const char *str,int bch); @@ -298,7 +300,9 @@ xlCContinuation load_cc = { load_continuation,load_unwind,4,"Load:package,env,fi /* do_loadloop - read the next expression and setup to evaluate it */ static void do_loadloop(xlValue print,xlValue oldpack) { +#ifndef XLISP_USE_CONTEXT extern xlValue s_eval; +#endif xlValue expr; /* try to read the next expression from the file */ diff --git a/src/xlimage.c b/src/xlimage.c index bcbd533..7fed342 100755 --- a/src/xlimage.c +++ b/src/xlimage.c @@ -6,9 +6,11 @@ #include "xlisp.h" +#ifndef XLISP_USE_CONTEXT /* global variables */ extern xlValue xlLispPackage,xlLispPackage,xlKeywordPackage,xlLispPackage; extern xlValue xlPackages,xlEofObject,xlDefaultObject; +#endif /* local variables */ static xlOFFTYPE off,foff; diff --git a/src/xlinit.c b/src/xlinit.c index 616dd32..40b1eab 100755 --- a/src/xlinit.c +++ b/src/xlinit.c @@ -13,6 +13,11 @@ /* shorthand for xlFIRSTENV */ #define FE xlFIRSTENV +/* + * When XLISP_USE_CONTEXT is defined, globals become macros to xlCtx(). + */ +#ifndef XLISP_USE_CONTEXT + /* global variables */ xlEXPORT xlValue xlSymConst,xlSymMEscape,xlSymSEscape,xlSymWSpace; xlEXPORT xlValue xlSymTMacro,xlSymNMacro,xlSymReadTable; @@ -29,6 +34,8 @@ xlValue s_fixfmt,s_hexfmt,s_flofmt,s_freeptr,s_backtrace; /* external variables */ extern xlValue xlLispPackage; +#endif /* !XLISP_USE_CONTEXT */ + /* local functions */ static xlValue getloadpath(void); diff --git a/src/xlint.c b/src/xlint.c index 8bb0d80..3baacf6 100755 --- a/src/xlint.c +++ b/src/xlint.c @@ -10,6 +10,11 @@ /* macro to call a xlSUBR */ #define callsubr(x,c) (xlArgC = (c), (x)()) +/* + * When XLISP_USE_CONTEXT is defined, globals become macros to xlCtx(). + */ +#ifndef XLISP_USE_CONTEXT + /* globals */ xlErrorTarget *xlerrtarget = NULL; /* error target */ xlValue *xlcatch = NULL; /* catch frame pointer */ @@ -17,11 +22,13 @@ int xlTraceBytecodes = FALSE; /* trace enable */ xlEXPORT int xlArgC; /* number of arguments remaining */ xlEXPORT void (*xlNext)(void); /* next function to call (xlApply or NULL) */ -/* external variables */ +/* external variables - only in legacy mode */ extern xlValue s_package,s_stdin,s_stdout,xlUnboundObject; extern xlValue s_unassigned,xlDefaultObject,s_error; extern xlValue s_stackpointer; +#endif /* !XLISP_USE_CONTEXT */ + /* error target (and bytecode dispatch target) */ #define BCD_START 0 /* must be zero */ #define BCD_RETURN 1 @@ -593,7 +600,9 @@ static void opLIT(void) /* opGREF - handler for opcode GREF */ static void opGREF(void) { +#ifndef XLISP_USE_CONTEXT extern xlValue s_package; +#endif register xlValue tmp; xlValue key; tmp = xlGetElement(xlFun,*pc++); diff --git a/src/xlio.c b/src/xlio.c index 7221ce4..36d9410 100755 --- a/src/xlio.c +++ b/src/xlio.c @@ -9,8 +9,10 @@ /* global variables */ xlFIXTYPE xlfsize; +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue s_stdin,s_stdout,s_stderr,xlUnboundObject; +#endif /* forward declarations */ static int fstream_getc(xlValue fptr); diff --git a/src/xlitersq.c b/src/xlitersq.c index b85c2ca..22adb8a 100755 --- a/src/xlitersq.c +++ b/src/xlitersq.c @@ -34,8 +34,10 @@ typedef xlValue (*MACTION)(xlValue val,xlValue *d); #define IS_FETCH 1 #define IS_UPDATE 2 +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue xlVal,k_key,k_count,k_start,k_end; +#endif static void iterseq1(xlValue ivalue,xlValue tresult,ACTION action); static void iterlist1(xlValue ivalue,xlValue tresult,ACTION action); diff --git a/src/xlmain.c b/src/xlmain.c index 907edc5..1469814 100755 --- a/src/xlmain.c +++ b/src/xlmain.c @@ -11,9 +11,14 @@ #define BANNER "\ XLISP 3.3, September 6, 2002 Copyright (c) 1984-2002, by David Betz" +/* + * When XLISP_USE_CONTEXT is defined, globals become macros to xlCtx(). + */ +#ifndef XLISP_USE_CONTEXT + /* global variables */ int xlCmdLineArgC = 0; /* command line argument count */ -const char **xlCmdLineArgV = NULL; /* array of command line arguments */ +const char **xlCmdLineArgV = NULL; /* array of command line arguments */ xlEXPORT int xlInitializedP = FALSE; /* true if initialization is done */ xlEXPORT FILE *xlTranscriptFP = NULL; /* trace file pointer */ @@ -22,6 +27,8 @@ extern xlValue s_package,xlUnboundObject,s_stderr,s_error,s_backtrace; extern xlFIXTYPE xlNSSize,xlVSSize; extern int xlTraceBytecodes; +#endif /* !XLISP_USE_CONTEXT */ + /* local prototypes */ static void fmterror(const char *tag,const char *fmt,va_list ap); @@ -30,7 +37,18 @@ xlEXPORT int xlInit(xlCallbacks *callbacks,int argc,const char *argv[],const cha { xlErrorTarget target; int src,dst; - + +#ifdef XLISP_USE_CONTEXT + /* In threaded mode, create and set up the default context */ + { + xlContext *ctx = xlCreateContext(); + if (ctx == NULL) + return FALSE; + xlSetCurrentContext(ctx); + ctx->callbacks = callbacks; + } +#endif + /* store the callback structure pointer */ xlSetCallbacks(callbacks); diff --git a/src/xlobj.c b/src/xlobj.c index 8a17c3e..3be057c 100755 --- a/src/xlobj.c +++ b/src/xlobj.c @@ -6,12 +6,14 @@ #include "xlisp.h" +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue s_stdout; /* local variables */ static xlValue k_initialize; static xlValue c_class,c_object; +#endif /* local prototypes */ static int FindIVarOffset(xlValue cls,xlValue sym,int *pOffset); diff --git a/src/xlosint.c b/src/xlosint.c index 0b71b85..6d578d8 100755 --- a/src/xlosint.c +++ b/src/xlosint.c @@ -6,32 +6,52 @@ #include "xlisp.h" -/* global variables */ +#ifndef XLISP_USE_CONTEXT +/* global variables - only in legacy mode */ static xlCallbacks *callbacks = NULL; +#endif /* xlSetCallbacks - initialize xlisp */ void xlSetCallbacks(xlCallbacks *cb) { +#ifdef XLISP_USE_CONTEXT + /* In context mode, store in the current context */ + xlCtx()->callbacks = cb; +#else /* save the pointer to the callbacks */ callbacks = cb; +#endif +} + +/* Helper to get callbacks pointer */ +static xlCallbacks *getCallbacks(void) +{ +#ifdef XLISP_USE_CONTEXT + return xlCtx()->callbacks; +#else + return callbacks; +#endif } /* xlosLoadPath - return the load path */ xlEXPORT const char *xlosLoadPath(void) { - return callbacks->loadPath ? (*callbacks->loadPath)() : NULL; + xlCallbacks *cb = getCallbacks(); + return cb && cb->loadPath ? (*cb->loadPath)() : NULL; } /* xlosParsePath - return the load path */ xlEXPORT const char *xlosParsePath(const char **pp) { - return callbacks->parsePath ? (*callbacks->parsePath)(pp) : NULL; + xlCallbacks *cb = getCallbacks(); + return cb && cb->parsePath ? (*cb->parsePath)(pp) : NULL; } /* xlosDirectorySeparator - return the directory separator character */ xlEXPORT int xlosDirectorySeparator(void) { - return callbacks->directorySeparator ? (*callbacks->directorySeparator)() : '\\'; + xlCallbacks *cb = getCallbacks(); + return cb && cb->directorySeparator ? (*cb->directorySeparator)() : '\\'; } /* xlosEnter - enter o/s specific functions */ @@ -60,29 +80,33 @@ xlEXPORT xlValue (*xlosFindSubr(const char *name))(void) return (xlValue (*)(void))xsdp->subr; /* call the user handler */ - return callbacks->findSubr ? (*callbacks->findSubr)(name) : NULL; + xlCallbacks *cb = getCallbacks(); + return cb && cb->findSubr ? (*cb->findSubr)(name) : NULL; } /* xlosError - print an error message */ xlEXPORT void xlosError(const char *msg) { - if (callbacks->error) - (*callbacks->error)(msg); + xlCallbacks *cb = getCallbacks(); + if (cb && cb->error) + (*cb->error)(msg); } /* xlosFileModTime - return the modification time of a file */ xlEXPORT int xlosFileModTime(const char *fname,xlFIXTYPE *pModTime) -{ - return callbacks->fileModTime ? (*callbacks->fileModTime)(fname,pModTime) : FALSE; +{ + xlCallbacks *cb = getCallbacks(); + return cb && cb->fileModTime ? (*cb->fileModTime)(fname,pModTime) : FALSE; } /* xlosConsoleGetC - get a character from the terminal */ xlEXPORT int xlosConsoleGetC(void) { + xlCallbacks *cb = getCallbacks(); int ch; - + /* get the next character */ - ch = callbacks->consoleGetC ? (*callbacks->consoleGetC)() : EOF; + ch = cb && cb->consoleGetC ? (*cb->consoleGetC)() : EOF; /* output the character to the transcript file */ if (xlTranscriptFP && ch != EOF) @@ -95,12 +119,14 @@ xlEXPORT int xlosConsoleGetC(void) /* xlosConsolePutC - put a character to the terminal */ xlEXPORT void xlosConsolePutC(int ch) { + xlCallbacks *cb = getCallbacks(); + /* check for control characters */ xlosCheck(); /* output the character */ - if (callbacks->consolePutC) - (*callbacks->consolePutC)(ch); + if (cb && cb->consolePutC) + (*cb->consolePutC)(ch); /* output the character to the transcript file */ if (xlTranscriptFP) @@ -117,32 +143,37 @@ xlEXPORT void xlosConsolePutS(const char *str) /* xlosConsoleAtBOLP - are we at the beginning of a line? */ xlEXPORT int xlosConsoleAtBOLP(void) { - return callbacks->consoleAtBOLP ? (*callbacks->consoleAtBOLP)() : FALSE; + xlCallbacks *cb = getCallbacks(); + return cb && cb->consoleAtBOLP ? (*cb->consoleAtBOLP)() : FALSE; } /* xlosConsoleFlush - flush the terminal input buffer */ xlEXPORT void xlosConsoleFlush(void) { - if (callbacks->consoleFlushInput) - (*callbacks->consoleFlushInput)(); + xlCallbacks *cb = getCallbacks(); + if (cb && cb->consoleFlushInput) + (*cb->consoleFlushInput)(); } /* xlosConsoleCheck - check for control characters during execution */ xlEXPORT int xlosConsoleCheck(void) { - return callbacks->consoleCheck ? (*callbacks->consoleCheck)() : 0; + xlCallbacks *cb = getCallbacks(); + return cb && cb->consoleCheck ? (*cb->consoleCheck)() : 0; } /* xlosFlushOutput - flush the output buffer */ xlEXPORT void xlosFlushOutput(void) { - if (callbacks->consoleFlushOutput) - (*callbacks->consoleFlushOutput)(); + xlCallbacks *cb = getCallbacks(); + if (cb && cb->consoleFlushOutput) + (*cb->consoleFlushOutput)(); } /* xlosExit - exit from XLISP */ xlEXPORT void xlosExit(int sts) { - if (callbacks->exit) - (*callbacks->exit)(sts); + xlCallbacks *cb = getCallbacks(); + if (cb && cb->exit) + (*cb->exit)(sts); } diff --git a/src/xlprint.c b/src/xlprint.c index 6b1b1e5..48d9354 100755 --- a/src/xlprint.c +++ b/src/xlprint.c @@ -6,17 +6,24 @@ #include "xlisp.h" +/* + * When XLISP_USE_CONTEXT is defined, globals become macros to xlCtx(). + */ +#ifndef XLISP_USE_CONTEXT + /* global variables */ int xlPRBreadth = -1; int xlPRDepth = -1; -/* local variables */ -static char buf[200]; - /* external variables */ extern xlValue s_printcase,k_downcase; extern xlValue s_fixfmt,s_flofmt,xlUnboundObject; +#endif /* !XLISP_USE_CONTEXT */ + +/* local variables */ +static char buf[200]; + static void print(xlValue fptr,xlValue vptr,int escflag,int depth); static void putatm(xlValue fptr,const char *tag,xlValue val); static void putfstream(xlValue fptr,xlValue val); @@ -312,7 +319,9 @@ static void putqstring(xlValue fptr,xlValue str) /* putsymbol - output a symbol */ static void putsymbol(xlValue fptr,xlValue sym) { +#ifndef XLISP_USE_CONTEXT extern xlValue s_package,xlKeywordPackage,k_internal; +#endif xlValue package,key; if ((package = xlGetPackage(sym)) == xlNil) xlPutStr(fptr,"#:"); @@ -430,7 +439,9 @@ static void putcharacter(xlValue fptr,int ch) /* putobject - output an object value */ static void putobject(xlValue fptr,xlValue obj) { +#ifndef XLISP_USE_CONTEXT extern xlValue s_print; +#endif xlInternalCall(&obj,1,obj,2,s_print,fptr); } diff --git a/src/xlread.c b/src/xlread.c index 8c4ddd4..365a390 100755 --- a/src/xlread.c +++ b/src/xlread.c @@ -17,9 +17,11 @@ #define RO_COMMENT 2 #define RO_EOF 3 +#ifndef XLISP_USE_CONTEXT /* external variables */ extern xlValue s_package,s_quote,s_function,s_quasiquote,s_unquote,s_unquotesplicing,s_dot; extern xlValue xlEofObject; +#endif /* forward declarations */ static int readone(xlValue fptr,xlValue *pval); @@ -192,11 +194,9 @@ void xrmhash(void) /* xrmquote - read macro %RM-QUOTE */ void xrmquote(void) { - xlValue mch; - /* parse the argument list */ xlVal = xlGetInputPort(); - mch = xlGetArgChar(); + (void)xlGetArgChar(); xlLastArg(); /* return the result */ @@ -207,11 +207,9 @@ void xrmquote(void) /* xrmdquote - read macro %RM-DOUBLE-QUOTE */ void xrmdquote(void) { - xlValue mch; - /* parse the argument list */ xlVal = xlGetInputPort(); - mch = xlGetArgChar(); + (void)xlGetArgChar(); xlLastArg(); /* return the result */ @@ -222,11 +220,9 @@ void xrmdquote(void) /* xrmbquote - read macro %RM-BACKQUOTE */ void xrmbquote(void) { - xlValue mch; - /* parse the argument list */ xlVal = xlGetInputPort(); - mch = xlGetArgChar(); + (void)xlGetArgChar(); xlLastArg(); /* return the result */ @@ -237,11 +233,9 @@ void xrmbquote(void) /* xrmcomma - read macro %RM-COMMA */ void xrmcomma(void) { - xlValue mch; - /* parse the argument list */ xlVal = xlGetInputPort(); - mch = xlGetArgChar(); + (void)xlGetArgChar(); xlLastArg(); /* return the result */ @@ -252,11 +246,9 @@ void xrmcomma(void) /* xrmlparen - read macro %RM-LEFT-PAREN */ void xrmlparen(void) { - xlValue mch; - /* parse the argument list */ xlVal = xlGetInputPort(); - mch = xlGetArgChar(); + (void)xlGetArgChar(); xlLastArg(); /* return the result */ @@ -267,11 +259,9 @@ void xrmlparen(void) /* xrmrparen - read macro %RM-RIGHT-PAREN */ void xrmrparen(void) { - xlValue mch; - /* parse the argument list */ xlVal = xlGetInputPort(); - mch = xlGetArgChar(); + (void)xlGetArgChar(); xlLastArg(); /* illegal in this context */ @@ -281,11 +271,9 @@ void xrmrparen(void) /* xrmsemi - read macro %RM-SEMICOLON */ void xrmsemi(void) { - xlValue mch; - /* parse the argument list */ xlVal = xlGetInputPort(); - mch = xlGetArgChar(); + (void)xlGetArgChar(); xlLastArg(); /* skip over the comment */ @@ -407,7 +395,9 @@ static xlValue read_quote(xlValue fptr,xlValue sym) /* read_symbol - parse a symbol (or a number) */ static xlValue read_symbol(xlValue fptr) { +#ifndef XLISP_USE_CONTEXT extern xlValue xlKeywordPackage,k_external; +#endif char buf[xlSTRMAX+1],*sname; xlValue package,val,key; @@ -518,7 +508,7 @@ static xlValue read_string(xlValue fptr) } /* return the new string */ - return xlTop() == xlNil ? xlPop(), xlMakeString(buf,len) : xlGetStrOutput(xlPop()); + return xlTop() == xlNil ? (void)xlPop(), xlMakeString(buf,len) : xlGetStrOutput(xlPop()); } /* read_special - parse an atom starting with '#' */ @@ -790,7 +780,9 @@ xlEXPORT xlValue xlCharType(int ch) /* tentry - get readtable entry for a character */ static xlValue tentry(int ch) { +#ifndef XLISP_USE_CONTEXT extern xlValue xlSymReadTable; +#endif xlValue rtable = xlGetValue(xlSymReadTable); if (xlVectorP(rtable) && ch >= 0 && ch < xlGetSize(rtable)) return xlGetElement(rtable,ch); diff --git a/src/xlsym.c b/src/xlsym.c index c8547e5..cc35f86 100755 --- a/src/xlsym.c +++ b/src/xlsym.c @@ -6,12 +6,19 @@ #include "xlisp.h" +/* + * When XLISP_USE_CONTEXT is defined, globals become macros to xlCtx(). + */ +#ifndef XLISP_USE_CONTEXT + /* global variables */ xlValue xlPackages,xlLispPackage,xlXLispPackage,xlKeywordPackage; /* external variables */ extern xlValue xlPackages,s_package,k_internal,k_external,k_inherited; +#endif /* !XLISP_USE_CONTEXT */ + /* forward declarations */ static xlValue addtolist(xlValue list,xlValue val); static xlValue removefromlist(xlValue list,xlValue val); diff --git a/xlisp/CMakeLists.txt b/xlisp/CMakeLists.txt index a67ef0b..24a0ed5 100644 --- a/xlisp/CMakeLists.txt +++ b/xlisp/CMakeLists.txt @@ -3,6 +3,6 @@ target_sources(xlisp-repl PRIVATE "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlisp.h") target_include_directories(xlisp-repl PUBLIC ${CMAKE_CURRENT_SOURCE_DIR}/../include) -target_link_libraries(xlisp-repl xlisp) +target_link_libraries(xlisp-repl xlisp m) set_target_properties(xlisp-repl PROPERTIES PUBLIC_HEADER ${CMAKE_CURRENT_SOURCE_DIR}/../include/xlisp.h) From e7d8d16d0035465c112767f5aef27a15f6e3524e Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Wed, 25 Mar 2026 20:19:26 -0500 Subject: [PATCH 2/9] Added native thread support --- CMakeLists.txt | 16 +- Makefile | 11 +- README.md | 7 +- doc/CODEBASE_ANALYSIS.md | 38 ++- doc/REENTRANT.md | 259 --------------- doc/THREADING_DESIGN.md | 510 ------------------------------ doc/ThreadEnhancementPlan.md | 219 +++++++++++++ doc/Threads.md | 388 +++++++++++++++++++++++ doc/api.md | 4 +- doc/xlisp.md | 287 +++++++++++++++++ include/xlcompat.h | 15 +- include/xlcontext.h | 5 + include/xlisp.h | 20 ++ src/CMakeLists.txt | 2 + src/xlcom.c | 11 + src/xlftab.c | 20 ++ src/xlint.c | 17 +- src/xlmain.c | 2 +- src/xlnthread.c | 297 +++++++++++++++++ src/xlsync.c | 597 +++++++++++++++++++++++++++++++++++ tests/test_sync.lsp | 174 ++++++++++ 21 files changed, 2115 insertions(+), 784 deletions(-) delete mode 100644 doc/REENTRANT.md delete mode 100644 doc/THREADING_DESIGN.md create mode 100644 doc/ThreadEnhancementPlan.md create mode 100644 doc/Threads.md create mode 100644 src/xlnthread.c create mode 100644 src/xlsync.c create mode 100644 tests/test_sync.lsp diff --git a/CMakeLists.txt b/CMakeLists.txt index b47a765..3c759ac 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,10 +1,24 @@ cmake_minimum_required(VERSION 3.14) project(XLisp - VERSION 3.3 + VERSION 10.0.0 DESCRIPTION "XLISP - an object-oriented LISP" LANGUAGES C) +# Threading support option +option(XLISP_THREADS "Build with threading support" OFF) + +# Find threads package +find_package(Threads) + add_library(xlisp "") + +if(XLISP_THREADS) + target_compile_definitions(xlisp PUBLIC XLISP_USE_CONTEXT) + if(Threads_FOUND) + target_link_libraries(xlisp PUBLIC Threads::Threads) + endif() +endif() + add_subdirectory(src) add_library(ext SHARED "") diff --git a/Makefile b/Makefile index 49a5a41..6f025c4 100755 --- a/Makefile +++ b/Makefile @@ -47,9 +47,12 @@ MKDIR=mkdir CFLAGS=-Wall -DUNIX -I$(HDRDIR) -fPIC -# Reentrant/threading support: make REENTRANT=1 -ifdef REENTRANT +# Threading support: make THREADS=1 +ifdef THREADS CFLAGS += -DXLISP_USE_CONTEXT + THREADLIBS = -lpthread +else + THREADLIBS = endif INC=$(HDRDIR)/xlisp.h @@ -89,7 +92,7 @@ $(XLISPOBJDIR)/%.o: %.c $(INC) @$(ECHO) $@ $(BINDIR)/xlisp$(EXT): $(XLISPOBJDIR) $(XLISPOBJS) library - @$(CC) $(CFLAGS) $(XLISPOBJS) -L$(LIBDIR) -lxlisp -lm -o $@ + @$(CC) $(CFLAGS) $(XLISPOBJS) -L$(LIBDIR) -lxlisp -lm $(THREADLIBS) -o $@ @$(ECHO) $@ ########### @@ -120,6 +123,8 @@ $(LIBOBJDIR)/xlio.o \ $(LIBOBJDIR)/xlmain.o \ $(LIBOBJDIR)/xlitersq.o \ $(LIBOBJDIR)/xlmath.o \ +$(LIBOBJDIR)/xlnthread.o \ +$(LIBOBJDIR)/xlsync.o \ $(LIBOBJDIR)/xlobj.o \ $(LIBOBJDIR)/xlosint.o \ $(LIBOBJDIR)/xlprint.o \ diff --git a/README.md b/README.md index 27f6529..9efb592 100644 --- a/README.md +++ b/README.md @@ -22,13 +22,14 @@ It has some really nice features as follows: ## To all of this, I have added: A. When used as an extension language, it is now reentrant and can handle multiple simultaneous threads. - -To this, I would like to add native thread support at some time. +B. Native thread creation and joining from Lisp (`thread-create`, `thread-join`, `thread?`). +C. Synchronization primitives: mutexes and condition variables with cross-thread sharing via named registries. +D. Updated version to 10.0.0. ## Building make # standard build - make REENTRANT=1 # thread-safe build + make THREADS=1 # thread-safe build make clean # remove build artifacts ## The original README file is located at README2.md diff --git a/doc/CODEBASE_ANALYSIS.md b/doc/CODEBASE_ANALYSIS.md index 152c618..3f70b52 100644 --- a/doc/CODEBASE_ANALYSIS.md +++ b/doc/CODEBASE_ANALYSIS.md @@ -2,17 +2,18 @@ ## Overview -**XLISP** is an object-oriented LISP interpreter/compiler (v3.3) by David Michael Betz (1983-2017). Licensed under MIT. It compiles Lisp to bytecodes rather than interpreting directly, making it faster than traditional interpreters. +**XLISP** is an object-oriented LISP interpreter/compiler (v10.0.0) by David Michael Betz (1983-2017). Licensed under MIT. It compiles Lisp to bytecodes rather than interpreting directly, making it faster than traditional interpreters. Supports native multi-threading with per-thread interpreter contexts when built in reentrant mode. ## Project Structure ``` xlisp/ -├── src/ # Core C source (27 files, ~18.8K lines) -├── include/ # Header files +├── src/ # Core C source (29 files, ~19.5K lines) +├── include/ # Header files (xlisp.h, xlcontext.h, xlcompat.h, xlthread.h) ├── xlisp/ # REPL executable source ├── ext/ # Extension module ├── doc/ # Documentation (Markdown) +├── tests/ # Lisp test scripts ├── *.lsp # 14 Lisp initialization/library files ├── CMakeLists.txt # Modern build system └── Makefile # Legacy build @@ -35,6 +36,9 @@ xlisp/ | `xlimage.c` | Memory image/workspace management | | `xlfasl.c` | Fast loading (compiled bytecode) | | `xldbg.c` | Debugging support | +| `xlcontext.c` | Per-thread interpreter context management | +| `xlnthread.c` | Native thread creation/join | +| `xlsync.c` | Synchronization primitives (mutexes, condition variables) | | `msstuff.c` | Windows-specific code | | `unstuff.c` | Unix-specific code | @@ -88,6 +92,20 @@ Lisp Source Code - `xlSP` - value stack pointer - `xlCSP` - control stack pointer +### Threading Architecture + +When built with `THREADS=1`: + +- All global interpreter state is encapsulated in an `xlContext` structure + (`include/xlcontext.h`) +- A thread-local pointer (`xl_current_context`) tracks the active context +- Compatibility macros in `include/xlcompat.h` redirect global variable + accesses through the context pointer (e.g., `#define xlVal (xlCtx()->val)`) +- Each thread gets independent stacks, heap, GC, symbols, and packages +- The bytecode dispatch table (`optab`) is shared and immutable +- Synchronization objects (mutexes, condition variables) are shared at the + C level via a named registry with reference counting + ## Notable Features - **Bytecode compilation** - not direct interpretation @@ -95,6 +113,8 @@ Lisp Source Code - **Class-based OOP** with inheritance and method dispatch - **Scheme influences** - lexical scoping, proper tail recursion - **Common Lisp elements** - packages, keywords, multiple values +- **Native threading** - per-thread interpreter contexts with mutexes and + condition variables for synchronization - **Cross-platform** (Windows, Linux, macOS) via ANSI C - **Extensible** via C API and extension modules - **FASL support** - fast loading of pre-compiled bytecode @@ -118,6 +138,16 @@ Requires CMake 3.14+. Supports link-time optimization (IPO). 2. **ext** (shared library) - Extension module 3. **xlisp-repl** (executable) - Interactive REPL +### Reentrant/Threading Build + +```bash +make clean +make THREADS=1 +``` + +Defines `XLISP_USE_CONTEXT` and links with `-lpthread` (on Unix). +Enables `thread-create`, `thread-join`, mutexes, and condition variables. + ### Legacy Support - `Makefile` - Traditional make-based build @@ -151,3 +181,5 @@ xlClass() - `msstuff.c` - Windows-specific implementation - `unstuff.c` - Unix-specific implementation - ANSI C for maximum portability +- Thread-local storage: `__thread` (GCC/Clang), `__declspec(thread)` (MSVC), pthread keys (fallback) +- Threading: pthreads (Unix), Win32 threads (Windows) diff --git a/doc/REENTRANT.md b/doc/REENTRANT.md deleted file mode 100644 index 5b70180..0000000 --- a/doc/REENTRANT.md +++ /dev/null @@ -1,259 +0,0 @@ -# XLISP Reentrant/Thread-Safe Mode - -## Overview - -XLISP can be built in a reentrant mode that allows it to be safely called from multiple threads. Each thread gets its own independent interpreter context with completely separate: - -- Value and control stacks -- Heap memory (nodes and vectors) -- Symbol tables and packages -- Garbage collector state -- VM registers - -**Important:** Lisp data cannot be shared between threads. Each context is a fully isolated interpreter instance. - -## Building - -To build XLISP with reentrant support: - -```bash -make clean -make REENTRANT=1 -``` - -This defines `XLISP_USE_CONTEXT` which enables thread-local storage for the interpreter state. - -To verify the build has reentrant support: - -```bash -nm lib/libxlisp.a | grep xlCreateContext -``` - -You should see `T xlCreateContext` in the output. - -## Thread-Local Storage - -The reentrant build uses thread-local storage (TLS) to maintain a per-thread interpreter context pointer. The implementation uses: - -- `__thread` keyword on GCC/Clang (Linux, macOS) -- `__declspec(thread)` on MSVC (Windows) -- pthread keys as a fallback - -## API - -### Headers - -```c -#include "xlisp.h" -#include "xlthread.h" -``` - -### Functions - -#### xlCreateContext - -```c -xlContext *xlCreateContext(void) -``` - -Allocates a new interpreter context. Returns NULL on failure. - -The context is allocated but not initialized. You must call `xlInitContext()` before using it. - -#### xlInitContext - -```c -int xlInitContext(xlContext *ctx, xlCallbacks *callbacks, - int argc, const char *argv[], const char *workspace) -``` - -Initializes a context for use. Returns 0 on success, -1 on failure. - -Parameters: -- `ctx` - Context created by `xlCreateContext()` -- `callbacks` - Callback structure from `xlDefaultCallbacks()` -- `argc`, `argv` - Command line arguments (can be 0, NULL) -- `workspace` - Workspace image file to restore, or NULL for fresh start - -This function: -1. Sets the context as the current thread's active context -2. Initializes memory management (stack, heap) -3. Creates the standard packages and symbols -4. Optionally restores a workspace image - -#### xlSetCurrentContext - -```c -void xlSetCurrentContext(xlContext *ctx) -``` - -Sets the current thread's active context. This is called automatically by `xlInitContext()`, but can be used to switch between multiple contexts in the same thread. - -#### xlGetCurrentContext - -```c -xlContext *xlGetCurrentContext(void) -``` - -Returns the current thread's active context, or NULL if none is set. - -#### xlDestroyContext - -```c -void xlDestroyContext(xlContext *ctx) -``` - -Frees all memory associated with a context: -- Node segments -- Vector segments -- Stack -- Protected pointer blocks -- The context structure itself - -Call this when a thread is finished using the interpreter. - -## Usage Examples - -### Single Thread (Main Program) - -For single-threaded use, the standard `xlInit()` function works as before. In reentrant mode, it automatically creates and initializes a default context: - -```c -#include "xlisp.h" - -int main(int argc, char *argv[]) -{ - xlCallbacks *callbacks = xlDefaultCallbacks(argc, argv); - - if (!xlInit(callbacks, argc, argv, NULL)) { - fprintf(stderr, "Failed to initialize XLISP\n"); - return 1; - } - - xlInfo("%s\n", xlBanner()); - xlCallFunctionByName(NULL, 0, "*TOPLEVEL*", 0); - return 0; -} -``` - -### Multiple Threads - -Each thread must create and initialize its own context: - -```c -#include -#include "xlisp.h" -#include "xlthread.h" - -void *worker_thread(void *arg) -{ - xlContext *ctx; - xlCallbacks *callbacks; - - /* Create a new context for this thread */ - ctx = xlCreateContext(); - if (ctx == NULL) { - fprintf(stderr, "Failed to create context\n"); - return NULL; - } - - /* Initialize the context */ - callbacks = xlDefaultCallbacks(0, NULL); - if (xlInitContext(ctx, callbacks, 0, NULL, NULL) != 0) { - fprintf(stderr, "Failed to initialize context\n"); - xlDestroyContext(ctx); - return NULL; - } - - /* Now use the interpreter */ - xlLoadFile("worker.lsp"); - xlCallFunctionByName(NULL, 0, "DO-WORK", 0); - - /* Clean up */ - xlDestroyContext(ctx); - return NULL; -} - -int main(int argc, char *argv[]) -{ - pthread_t threads[4]; - int i; - - for (i = 0; i < 4; i++) - pthread_create(&threads[i], NULL, worker_thread, NULL); - - for (i = 0; i < 4; i++) - pthread_join(threads[i], NULL); - - return 0; -} -``` - -### Multiple Contexts in One Thread - -A single thread can manage multiple contexts by switching between them: - -```c -#include "xlisp.h" -#include "xlthread.h" - -int main(void) -{ - xlContext *ctx1, *ctx2; - xlCallbacks *callbacks = xlDefaultCallbacks(0, NULL); - - /* Create two contexts */ - ctx1 = xlCreateContext(); - ctx2 = xlCreateContext(); - - /* Initialize first context */ - xlInitContext(ctx1, callbacks, 0, NULL, NULL); - xlLoadFile("program1.lsp"); - - /* Initialize second context */ - xlInitContext(ctx2, callbacks, 0, NULL, NULL); - xlLoadFile("program2.lsp"); - - /* Switch between them */ - xlSetCurrentContext(ctx1); - xlCallFunctionByName(NULL, 0, "FUNC1", 0); - - xlSetCurrentContext(ctx2); - xlCallFunctionByName(NULL, 0, "FUNC2", 0); - - /* Clean up */ - xlDestroyContext(ctx1); - xlDestroyContext(ctx2); - - return 0; -} -``` - -## Limitations - -1. **No data sharing:** Lisp values cannot be passed between contexts. Each context has its own heap, so pointers are not valid across contexts. - -2. **No cross-thread calls:** You cannot call a function in one context from another thread. Each thread must use its own context. - -3. **Callbacks:** The callback structure can be shared between contexts (it contains function pointers, not Lisp data), but be careful with any state in your callback implementations. - -4. **Memory overhead:** Each context has its own complete interpreter state, including separate heaps. Memory usage scales linearly with the number of contexts. - -5. **Initialization time:** Creating and initializing a context takes time (building symbol tables, etc.). For best performance, create contexts once and reuse them. - -## Implementation Details - -The reentrant mode works by: - -1. Moving all global variables into an `xlContext` structure -2. Using a thread-local pointer (`xl_current_context`) to the current context -3. Providing compatibility macros that redirect global variable access through the context pointer - -For example, the global `xlVal` becomes: -```c -#define xlVal (xlCtx()->val) -``` - -Where `xlCtx()` returns the current thread's context pointer. - -The context structure is defined in `include/xlcontext.h` and contains all interpreter state including VM registers, stack pointers, memory management state, symbol caches, and package pointers. diff --git a/doc/THREADING_DESIGN.md b/doc/THREADING_DESIGN.md deleted file mode 100644 index 20d4ad7..0000000 --- a/doc/THREADING_DESIGN.md +++ /dev/null @@ -1,510 +0,0 @@ -# XLISP Threading Support Design - -## Overview - -This document describes the design for adding multi-threading support to XLISP using **thread-local interpreter instances**. Each thread gets its own complete interpreter state with no sharing of Lisp data between threads. - -## Architecture - -### Current Problem: Global State - -The current implementation uses extensive global variables: - -```c -// VM Registers (xldmem.c) -xlValue xlFun; // current function -xlValue xlEnv; // current environment -xlValue xlVal; // value of most recent instruction -xlValue *xlSP; // value stack pointer -xlValue *xlCSP; // control stack pointer -int xlArgC; // argument count - -// Stack (xldmem.c) -xlValue *xlStkBase; // stack base -xlValue *xlStkTop; // stack top - -// Memory Management (xldmem.c) -xlNodeSegment *xlNSegments; -xlVectorSegment *xlVSegments; -xlValue *xlVFree, *xlVTop; -xlValue xlFNodes; -xlFIXTYPE xlNFree, xlNNodes, xlTotal, xlGCCalls; -xlProtectedPtrBlk *xlPPointers; - -// Interpreter State (xlint.c) -xlErrorTarget *xlerrtarget; -xlValue *xlcatch; -int xlTraceBytecodes; -void (*xlNext)(void); -static unsigned char *base, *pc; // bytecode pointers - -// Important Values -xlValue xlTrue, xlFalse, xlPackages; -xlValue xlUnboundObject, xlDefaultObject, xlEofObject; - -// Symbols (xlinit.c) - ~30+ cached symbols -xlValue s_quote, s_function, s_package, ... - -// I/O -FILE *xlTranscriptFP; -xlCallbacks *callbacks; -``` - -### Solution: Interpreter Context Structure - -All global state is encapsulated into a single context structure: - -```c -/* include/xlcontext.h */ - -#ifndef __XLCONTEXT_H__ -#define __XLCONTEXT_H__ - -#include "xlisp.h" - -/* Interpreter context - contains all per-thread state */ -typedef struct xlContext { - - /* === VM Registers === */ - xlValue fun; /* current function */ - xlValue env; /* current environment */ - xlValue val; /* value of most recent instruction */ - int argc; /* argument count */ - void (*next)(void); /* next function to call */ - - /* === Stacks === */ - xlValue *sp; /* value stack pointer */ - xlValue *csp; /* control stack pointer */ - xlValue *stkBase; /* stack base */ - xlValue *stkTop; /* stack top */ - - /* === Bytecode Interpreter === */ - unsigned char *pc; /* program counter */ - unsigned char *pcBase; /* code base pointer */ - xlErrorTarget *errTarget; - xlValue *catchFrame; - int traceBytecodes; - int sample; /* control char sample counter */ - - /* === Memory: Node Space === */ - xlNodeSegment *nSegments; - xlNodeSegment *nsLast; - xlValue fNodes; /* free node list */ - xlFIXTYPE nsSize; - xlFIXTYPE nNodes; - xlFIXTYPE nFree; - int nsCount; - - /* === Memory: Vector Space === */ - xlVectorSegment *vSegments; - xlVectorSegment *vsCurrent; - xlValue *vFree; - xlValue *vTop; - xlFIXTYPE vsSize; - int vsCount; - - /* === Memory: Protected Pointers === */ - xlProtectedPtrBlk *pPointers; - - /* === Memory: Statistics === */ - xlFIXTYPE total; - xlFIXTYPE gcCalls; - - /* === Important Values === */ - xlValue vTrue; - xlValue vFalse; - xlValue packages; - xlValue unboundObject; - xlValue defaultObject; - xlValue eofObject; - - /* === Cached Symbols === */ - struct { - xlValue quote, function, quasiquote, unquote, unquoteSplicing; - xlValue dot, package, eval, load; - xlValue print, printCase, eql; - xlValue stdin_, stdout_, stderr_; - xlValue stackPointer, error; - xlValue fixfmt, hexfmt, flofmt, freeptr, backtrace; - /* Lambda list keywords */ - xlValue lk_optional, lk_rest, lk_key, lk_aux, lk_allow_other_keys; - xlValue slk_optional, slk_rest; - /* Keyword symbols */ - xlValue k_upcase, k_downcase; - xlValue k_internal, k_external, k_inherited; - xlValue k_key, k_uses, k_test, k_testnot; - xlValue k_start, k_end, k_1start, k_1end, k_2start, k_2end; - xlValue k_count, k_fromend; - } sym; - - /* === Packages === */ - xlValue lispPackage; - xlValue xlispPackage; - xlValue keywordPackage; - - /* === Reader State === */ - xlValue symReadTable; - xlValue symNMacro, symTMacro, symWSpace; - xlValue symConst, symSEscape, symMEscape; - - /* === Printer State === */ - int prBreadth; - int prDepth; - - /* === I/O === */ - FILE *transcriptFP; - - /* === Callbacks === */ - xlCallbacks *callbacks; - - /* === Initialization Flag === */ - int initialized; - - /* === Command Line === */ - int cmdLineArgC; - const char **cmdLineArgV; - - /* === C Classes === */ - xlCClass *cClasses; - -} xlContext; - -/* Thread-local context access */ -#if defined(_WIN32) - #define XLISP_TLS __declspec(thread) -#elif defined(__GNUC__) - #define XLISP_TLS __thread -#else - /* Fall back to pthread_getspecific */ - #define XLISP_USE_PTHREAD_TLS 1 -#endif - -#ifndef XLISP_USE_PTHREAD_TLS - extern XLISP_TLS xlContext *xlCurrentContext; - #define xlCtx() xlCurrentContext -#else - xlContext *xlCtx(void); -#endif - -/* Context management API */ -xlContext *xlCreateContext(void); -void xlDestroyContext(xlContext *ctx); -void xlSetCurrentContext(xlContext *ctx); -xlContext *xlGetCurrentContext(void); - -/* Initialize a context */ -int xlInitContext(xlContext *ctx, xlCallbacks *callbacks, - int argc, const char *argv[], const char *workspace); - -#endif /* __XLCONTEXT_H__ */ -``` - -## Compatibility Macros - -To minimize code changes, provide macros that redirect old globals to context fields: - -```c -/* include/xlcompat.h - Compatibility layer for threading */ - -#ifndef __XLCOMPAT_H__ -#define __XLCOMPAT_H__ - -#include "xlcontext.h" - -/* VM Registers */ -#define xlFun (xlCtx()->fun) -#define xlEnv (xlCtx()->env) -#define xlVal (xlCtx()->val) -#define xlArgC (xlCtx()->argc) -#define xlNext (xlCtx()->next) - -/* Stacks */ -#define xlSP (xlCtx()->sp) -#define xlCSP (xlCtx()->csp) -#define xlStkBase (xlCtx()->stkBase) -#define xlStkTop (xlCtx()->stkTop) - -/* Memory - Node Space */ -#define xlNSegments (xlCtx()->nSegments) -#define xlNSLast (xlCtx()->nsLast) -#define xlFNodes (xlCtx()->fNodes) -#define xlNSSize (xlCtx()->nsSize) -#define xlNNodes (xlCtx()->nNodes) -#define xlNFree (xlCtx()->nFree) -#define xlNSCount (xlCtx()->nsCount) - -/* Memory - Vector Space */ -#define xlVSegments (xlCtx()->vSegments) -#define xlVSCurrent (xlCtx()->vsCurrent) -#define xlVFree (xlCtx()->vFree) -#define xlVTop (xlCtx()->vTop) -#define xlVSSize (xlCtx()->vsSize) -#define xlVSCount (xlCtx()->vsCount) - -/* Memory - Other */ -#define xlPPointers (xlCtx()->pPointers) -#define xlTotal (xlCtx()->total) -#define xlGCCalls (xlCtx()->gcCalls) - -/* Important Values */ -#define xlTrue (xlCtx()->vTrue) -#define xlFalse (xlCtx()->vFalse) -#define xlPackages (xlCtx()->packages) -#define xlUnboundObject (xlCtx()->unboundObject) -#define xlDefaultObject (xlCtx()->defaultObject) -#define xlEofObject (xlCtx()->eofObject) - -/* Packages */ -#define xlLispPackage (xlCtx()->lispPackage) -#define xlXLispPackage (xlCtx()->xlispPackage) -#define xlKeywordPackage (xlCtx()->keywordPackage) - -/* Interpreter State */ -#define xlerrtarget (xlCtx()->errTarget) -#define xlcatch (xlCtx()->catchFrame) -#define xlTraceBytecodes (xlCtx()->traceBytecodes) - -/* I/O */ -#define xlTranscriptFP (xlCtx()->transcriptFP) - -/* Symbols - accessed via xlCtx()->sym.XXX */ -#define s_quote (xlCtx()->sym.quote) -#define s_function (xlCtx()->sym.function) -#define s_package (xlCtx()->sym.package) -/* ... etc for all cached symbols ... */ - -/* Printer */ -#define xlPRBreadth (xlCtx()->prBreadth) -#define xlPRDepth (xlCtx()->prDepth) - -/* Command line */ -#define xlCmdLineArgC (xlCtx()->cmdLineArgC) -#define xlCmdLineArgV (xlCtx()->cmdLineArgV) - -/* Initialization */ -#define xlInitializedP (xlCtx()->initialized) - -#endif /* __XLCOMPAT_H__ */ -``` - -## New Public API - -```c -/* include/xlthread.h - Thread-safe API */ - -#ifndef __XLTHREAD_H__ -#define __XLTHREAD_H__ - -#include "xlcontext.h" - -/* - * Thread-Safe XLISP API - * - * Each thread must: - * 1. Create its own context with xlCreateContext() - * 2. Initialize it with xlInitContext() - * 3. Set it as current with xlSetCurrentContext() - * 4. Use standard xl* functions (they use xlCtx() internally) - * 5. Destroy with xlDestroyContext() when done - */ - -/* Create a new interpreter context */ -xlEXPORT xlContext *xlCreateContext(void); - -/* Destroy an interpreter context */ -xlEXPORT void xlDestroyContext(xlContext *ctx); - -/* Set the current thread's context */ -xlEXPORT void xlSetCurrentContext(xlContext *ctx); - -/* Get the current thread's context */ -xlEXPORT xlContext *xlGetCurrentContext(void); - -/* Initialize a context (replaces xlInit for multi-threaded use) */ -xlEXPORT int xlInitContext( - xlContext *ctx, - xlCallbacks *callbacks, - int argc, - const char *argv[], - const char *workspace -); - -/* Thread-safe versions of key API functions */ -/* (These explicitly take a context parameter) */ - -xlEXPORT int xlCallFunctionCtx( - xlContext *ctx, - xlValue *values, int vmax, - xlValue fun, int argc, ... -); - -xlEXPORT int xlEvaluateCtx( - xlContext *ctx, - xlValue *values, int vmax, - xlValue expr -); - -xlEXPORT int xlEvaluateCStringCtx( - xlContext *ctx, - xlValue *values, int vmax, - const char *str -); - -#endif /* __XLTHREAD_H__ */ -``` - -## Usage Example - -```c -/* example_threaded.c - Multi-threaded XLISP usage */ - -#include -#include "xlthread.h" - -void *worker_thread(void *arg) { - int thread_id = *(int *)arg; - xlContext *ctx; - xlValue result; - char expr[256]; - - /* Create and initialize context for this thread */ - ctx = xlCreateContext(); - if (!ctx) { - fprintf(stderr, "Thread %d: Failed to create context\n", thread_id); - return NULL; - } - - /* Initialize with default callbacks */ - if (xlInitContext(ctx, xlDefaultCallbacks(NULL), 0, NULL, NULL) != 0) { - fprintf(stderr, "Thread %d: Failed to initialize\n", thread_id); - xlDestroyContext(ctx); - return NULL; - } - - /* Set as current context for this thread */ - xlSetCurrentContext(ctx); - - /* Now we can use standard XLISP functions */ - snprintf(expr, sizeof(expr), "(+ %d 100)", thread_id); - - if (xlEvaluateCString(&result, 1, expr) == 1) { - printf("Thread %d: %s = %ld\n", - thread_id, expr, xlGetFixnum(result)); - } - - /* Can also use explicit context version */ - xlEvaluateCStringCtx(ctx, &result, 1, "(* 6 7)"); - - /* Cleanup */ - xlDestroyContext(ctx); - return NULL; -} - -int main(void) { - pthread_t threads[4]; - int ids[4] = {1, 2, 3, 4}; - - /* Launch worker threads */ - for (int i = 0; i < 4; i++) { - pthread_create(&threads[i], NULL, worker_thread, &ids[i]); - } - - /* Wait for completion */ - for (int i = 0; i < 4; i++) { - pthread_join(threads[i], NULL); - } - - return 0; -} -``` - -## Implementation Plan - -### Phase 1: Create Context Structure -1. Define `xlContext` struct in new `include/xlcontext.h` -2. Add thread-local storage for current context pointer -3. Implement `xlCreateContext()`, `xlDestroyContext()`, `xlSetCurrentContext()` - -### Phase 2: Add Compatibility Macros -1. Create `include/xlcompat.h` with macro redirects -2. Include xlcompat.h in xlisp.h (after xlcontext.h) -3. All existing code continues to work via macros - -### Phase 3: Refactor Initialization -1. Create `xlInitContext()` that initializes a specific context -2. Modify `xlInit()` to create a default context and call `xlInitContext()` -3. Move all initialization from static to context-based - -### Phase 4: Refactor Memory Management -1. Move all memory globals into context (`xldmem.c`) -2. GC now operates on context's memory segments -3. Each context has independent heap - -### Phase 5: Refactor Interpreter -1. Move interpreter state into context (`xlint.c`) -2. Move bytecode state (pc, base) into context -3. Error handling uses context's error target - -### Phase 6: Refactor Symbols and Packages -1. Move symbol cache into context -2. Move package list into context -3. Each context has its own symbol table - -### Phase 7: Testing and Validation -1. Single-threaded regression tests -2. Multi-threaded stress tests -3. Memory leak testing with valgrind - -## Files Requiring Modification - -| File | Changes | -|------|---------| -| `include/xlisp.h` | Include xlcontext.h, xlcompat.h | -| `include/xlcontext.h` | **NEW** - Context structure | -| `include/xlcompat.h` | **NEW** - Compatibility macros | -| `include/xlthread.h` | **NEW** - Thread-safe API | -| `src/xldmem.c` | Remove globals, use xlCtx() | -| `src/xlint.c` | Remove globals, use xlCtx() | -| `src/xlinit.c` | Remove globals, use xlCtx() | -| `src/xlsym.c` | Remove globals, use xlCtx() | -| `src/xlmain.c` | Add context creation in xlInit() | -| `src/xlapi.c` | Add xlInitContext(), context API | -| `src/xlcom.c` | Use xlCtx() for compiler state | -| `src/xlread.c` | Use xlCtx() for reader state | -| `src/xlprint.c` | Use xlCtx() for printer state | -| `src/xlio.c` | Use xlCtx() for I/O state | -| `src/xlobj.c` | Use xlCtx() for object symbols | -| `src/xlfun1.c` | No changes (uses macros) | -| `src/xlfun2.c` | No changes (uses macros) | -| `src/xlfun3.c` | No changes (uses macros) | - -## Considerations - -### What This Design Does NOT Support -- Sharing Lisp objects between threads (each thread has isolated heap) -- Concurrent GC (each thread GCs independently) -- Cross-thread message passing at Lisp level - -### If You Need Shared Data -For inter-thread communication, use C-level mechanisms: -- Serialize Lisp data to strings, pass via queue -- Use foreign pointers to shared C structures with your own locking -- Implement a Lisp-level channel/queue using C primitives - -### Performance Notes -- Thread-local storage access is very fast (single instruction on most platforms) -- Independent heaps mean no GC coordination overhead -- Memory usage scales linearly with thread count - -## Estimated Effort - -| Phase | Effort | -|-------|--------| -| Phase 1: Context Structure | 1-2 days | -| Phase 2: Compatibility Macros | 1 day | -| Phase 3: Refactor Init | 2-3 days | -| Phase 4: Refactor Memory | 3-4 days | -| Phase 5: Refactor Interpreter | 2-3 days | -| Phase 6: Refactor Symbols | 2-3 days | -| Phase 7: Testing | 3-5 days | -| **Total** | **~2-3 weeks** | diff --git a/doc/ThreadEnhancementPlan.md b/doc/ThreadEnhancementPlan.md new file mode 100644 index 0000000..d3eb17f --- /dev/null +++ b/doc/ThreadEnhancementPlan.md @@ -0,0 +1,219 @@ +# Thread Enhancement Plan: Message Channels + +## Status + +Threads, mutexes, and condition variables are implemented and tested. +This document covers the remaining planned enhancement: message channels +for inter-thread communication. + +## Motivation + +Since threads have independent Lisp heaps, they cannot share Lisp objects +directly. Mutexes and condition variables provide synchronization but not +data exchange. Channels provide a thread-safe queue for passing +string-serialized data between threads. + +## Channel API + +| Function | Signature | Returns | +|---|---|---| +| `CHANNEL-CREATE` | `(channel-create [name] [capacity])` | channel handle | +| `CHANNEL-SEND` | `(channel-send channel string)` | `#t` | +| `CHANNEL-RECEIVE` | `(channel-receive channel)` | string, or `#f` on closed empty channel | +| `CHANNEL-CLOSE` | `(channel-close channel)` | `#t` | +| `CHANNEL-DESTROY` | `(channel-destroy channel)` | `#t` | +| `CHANNEL-LOOKUP` | `(channel-lookup name)` | channel handle or `#f` | +| `CHANNEL-OPEN?` | `(channel-open? channel)` | `#t` / `#f` | +| `CHANNEL?` | `(channel? obj)` | `#t` / `#f` | + +Total: 8 new built-in functions. + +### Semantics + +- **`channel-create`**: Creates a channel. An optional *name* registers + it globally for cross-thread lookup. An optional *capacity* (integer) + limits the queue size; 0 or omitted means unbounded. + +- **`channel-send`**: Enqueues a string. Blocks if the channel is + bounded and full. Signals an error if the channel is closed. + +- **`channel-receive`**: Dequeues a string. Blocks if the channel is + empty and still open. Returns `#f` if the channel is closed and empty + (no more data will arrive). + +- **`channel-close`**: Marks the channel as closed. Pending messages can + still be received. Wakes all blocked receivers so they can see the + closed state. + +- **`channel-destroy`**: Frees the underlying resources. Decrements the + reference count; actual cleanup occurs when all references are released. + +- **`channel-lookup`**: Finds a named channel in the global registry. + Returns `#f` if not found. + +## C Data Structure + +```c +typedef struct xlChannelNode { + char *data; /* C string (malloc'd copy) */ + struct xlChannelNode *next; +} xlChannelNode; + +typedef struct xlChannelHandle { +#ifdef _WIN32 + CRITICAL_SECTION lock; + CONDITION_VARIABLE notEmpty; + CONDITION_VARIABLE notFull; +#else + pthread_mutex_t lock; + pthread_cond_t notEmpty; + pthread_cond_t notFull; +#endif + xlChannelNode *head; /* dequeue from head */ + xlChannelNode *tail; /* enqueue at tail */ + int count; /* current messages in queue */ + int capacity; /* max messages (0 = unbounded) */ + int closed; /* non-zero after channel-close */ + int destroyed; +} xlChannelHandle; +``` + +Tagged with a static `xlCClass channelTag` sentinel for type +discrimination via `channel?`, consistent with the existing mutex and +condition variable tagging. + +## Cross-Thread Sharing + +Channels use the same named-registry pattern already implemented for +mutexes and condition variables: + +1. Creating thread calls `(channel-create "name")` — allocates the OS + objects, registers globally by name. +2. Child thread calls `(channel-lookup "name")` — finds the C struct in + the registry, wraps it in a new foreign pointer in the child's heap. +3. Both threads' foreign pointers point to the **same** underlying + `xlChannelHandle`. +4. Reference counting prevents use-after-free. + +## Usage Examples + +### Simple Producer/Consumer + +```lisp +(define ch (channel-create "work-queue")) + +;; Producer thread +(define h (thread-create + "(begin + (define ch (channel-lookup \"work-queue\")) + (channel-send ch \"hello from thread\") + (channel-send ch \"another message\") + (channel-close ch))" + #f)) + +;; Consumer (main thread) +(display (channel-receive ch)) ; => "hello from thread" +(display (channel-receive ch)) ; => "another message" +(display (channel-receive ch)) ; => #f (closed, empty) + +(thread-join h) +(channel-destroy ch) +``` + +### Bounded Channel (Backpressure) + +```lisp +(define ch (channel-create "bounded" 10)) ; max 10 pending messages + +;; Fast producer blocks when queue is full +(define h (thread-create + "(begin + (define ch (channel-lookup \"bounded\")) + (define (produce n) + (if (<= n 100) + (begin + (channel-send ch (number->string n)) + (produce (+ n 1))))) + (produce 1) + (channel-close ch))" + #f)) + +;; Slow consumer +(define (consume) + (let ((msg (channel-receive ch))) + (if msg + (begin (display msg) (newline) (consume))))) +(consume) + +(thread-join h) +(channel-destroy ch) +``` + +### Multiple Producers + +```lisp +(define ch (channel-create "results")) + +(define h1 (thread-create + "(begin + (define ch (channel-lookup \"results\")) + (channel-send ch \"result-from-1\"))" #f)) + +(define h2 (thread-create + "(begin + (define ch (channel-lookup \"results\")) + (channel-send ch \"result-from-2\"))" #f)) + +(display (channel-receive ch)) (newline) +(display (channel-receive ch)) (newline) + +(thread-join h1) +(thread-join h2) +(channel-destroy ch) +``` + +## File Changes + +All changes are in existing files — no new source files needed. + +| File | Change | +|------|--------| +| `src/xlsync.c` | Add channel implementation (8 functions) | +| `include/xlisp.h` | Add 8 function declarations | +| `src/xlftab.c` | Add 8 entries to `subrtab` | +| `doc/xlisp.md` | Add channel documentation section | +| `doc/Threads.md` | Update with channel information | + +## Implementation Notes + +- Channels are implemented entirely in `src/xlsync.c`, extending the + existing synchronization module. +- The named registry, reference counting, and type-tagging infrastructure + already exists and will be reused. +- The `notEmpty` / `notFull` condition variables are internal to the + channel (not exposed to Lisp). They implement blocking send/receive + without requiring the user to manage separate mutexes and condvars. +- All send/receive operations copy data as C strings (`malloc`/`free`), + since the sender's and receiver's Lisp heaps are independent. + +## Error Handling + +Follows existing XLISP conventions: + +- Wrong argument type: `xlBadType(arg)` +- Wrong argument count: `xlLastArg()` / `xlGetArg*()` macros +- Operational errors: `xlFmtError("channel-xxx: description")` +- Non-reentrant build: `xlFmtError("channel-xxx: requires reentrant build (THREADS=1)")` +- Use after destroy: `xlFmtError("channel-xxx: channel has been destroyed")` +- Send to closed channel: `xlFmtError("channel-send: channel is closed")` + +## Testing Plan + +- Single-producer, single-consumer +- Multiple producers, single consumer +- Single producer, multiple consumers +- Bounded channel with backpressure +- Close while receivers are blocked (should unblock and return `#f`) +- Close while senders are blocked on full bounded channel (should error) +- Destroy while other threads hold references (refcount prevents crash) +- 50+ iteration stress runs diff --git a/doc/Threads.md b/doc/Threads.md new file mode 100644 index 0000000..0cdd86d --- /dev/null +++ b/doc/Threads.md @@ -0,0 +1,388 @@ +# XLISP Threading Support + +## Overview + +XLISP supports native multi-threading through per-thread interpreter +contexts. Each thread gets a completely independent interpreter instance +with its own stacks, heap, symbol tables, garbage collector, and VM +registers. Lisp data cannot be shared between threads directly. + +Threads coordinate through synchronization primitives (mutexes and +condition variables) that are shared at the C level via a named registry. +Data is exchanged between threads as strings. + +Threading requires a reentrant build (`make THREADS=1`). + +## Building + +```bash +make clean +make THREADS=1 +``` + +This defines `XLISP_USE_CONTEXT`, which enables thread-local storage for +the interpreter state. To verify: + +```bash +nm lib/libxlisp.a | grep xlCreateContext +``` + +You should see `T xlCreateContext` in the output. + +## Architecture + +### Thread-Local Interpreter Contexts + +All interpreter state that was previously stored in global variables is +encapsulated in an `xlContext` structure (defined in +`include/xlcontext.h`). This includes: + +- VM registers (`fun`, `env`, `val`, `argc`, `next`) +- Value and control stacks +- Bytecode interpreter state (`pc`, `pcBase`, error targets, catch frames) +- Memory management (node segments, vector segments, free lists, GC state) +- Singleton values (`#t`, `#f`, unbound, default, eof) +- Package system (package list, LISP/XLISP/KEYWORD packages) +- Cached symbols (~40 frequently-used symbols) +- Reader, printer, and I/O state +- Compiler state (code buffer, compiler info) +- Initialization flag and command line + +### Thread-Local Storage + +A thread-local pointer to the current context is maintained using: + +- `__thread` keyword on GCC/Clang (Linux, macOS) +- `__declspec(thread)` on MSVC (Windows) +- `pthread_getspecific` as a fallback + +### Compatibility Macros + +The header `include/xlcompat.h` provides macros that redirect all former +global variable accesses through the context pointer. For example: + +```c +#define xlVal (xlCtx()->val) +#define xlSP (xlCtx()->sp) +#define xlTrue (xlCtx()->vTrue) +#define s_quote (xlCtx()->sym.quote) +``` + +This allows all existing code to work unchanged. File-static variables in +`xlint.c` (bytecode interpreter) and `xlcom.c` (compiler) are similarly +redirected when `XLISP_USE_CONTEXT` is defined. + +### Dispatch Table + +The bytecode `optab[256]` dispatch table is shared and immutable. It is +initialized once (protected by an `optabInitialized` flag) and read-only +thereafter, making it safe for concurrent access. + +## Lisp-Level Threading API + +### Thread Creation + +```lisp +(THREAD-CREATE expr-string [init-file]) +``` + +Creates a new native OS thread that evaluates *expr-string* (a string +containing a Lisp expression) in its own interpreter context. + +- *init-file*: optional string naming an initialization file to load + before evaluating the expression. Default is `"xlisp.lsp"`. Pass `#f` + to skip loading any init file. +- Returns a thread handle (foreign pointer). + +**Important:** `THREAD-CREATE` evaluates only the **first** expression +in the string. To execute multiple statements, wrap them in `(begin ...)`: + +```lisp +(define h (thread-create + "(begin + (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) + (fib 30))" + #f)) +``` + +### Thread Join + +```lisp +(THREAD-JOIN handle) +``` + +Waits for the thread to complete. Returns `#t` on success. Signals an +error if the thread terminated with an error or was already joined. Each +handle must be joined exactly once. + +### Thread Predicate + +```lisp +(THREAD? obj) +``` + +Returns `#t` if *obj* is a live (not yet joined) thread handle. + +## Synchronization Primitives + +Synchronization objects are shared across threads through a global +**named registry**. The creating thread registers an object by name; child +threads look it up by the same name. Both threads' Lisp-level handles +point to the same underlying C structure. Reference counting prevents +use-after-free. + +### Mutexes + +```lisp +(MUTEX-CREATE [name]) ; create a mutex, optionally named +(MUTEX-LOCK mutex) ; acquire the mutex (blocking) +(MUTEX-UNLOCK mutex) ; release the mutex +(MUTEX-DESTROY mutex) ; destroy the mutex +(MUTEX-LOOKUP name) ; look up a named mutex => handle or #f +(MUTEX? obj) ; type predicate +``` + +Cross-thread example: + +```lisp +;; Main thread +(define m (mutex-create "my-lock")) +(mutex-lock m) + +;; Child thread (all in one expression) +(define h (thread-create + "(begin + (define m (mutex-lookup \"my-lock\")) + (mutex-lock m) + ;; ... critical section ... + (mutex-unlock m))" + #f)) + +(mutex-unlock m) +(thread-join h) +(mutex-destroy m) +``` + +### Condition Variables + +```lisp +(CONDITION-CREATE [name]) ; create a condition variable +(CONDITION-WAIT cond mutex) ; atomically unlock mutex and wait +(CONDITION-SIGNAL cond) ; wake one waiting thread +(CONDITION-BROADCAST cond) ; wake all waiting threads +(CONDITION-DESTROY cond) ; destroy the condition variable +(CONDITION-LOOKUP name) ; look up by name => handle or #f +(CONDITION? obj) ; type predicate +``` + +Signal/wait example: + +```lisp +(define m (mutex-create "m")) +(define cv (condition-create "cv")) + +;; Main locks before spawning child, ensuring child blocks on mutex-lock +;; until main enters condition-wait (which releases the mutex). +(mutex-lock m) + +(define h (thread-create + "(begin + (define m (mutex-lookup \"m\")) + (define c (condition-lookup \"cv\")) + (mutex-lock m) + (condition-signal c) + (mutex-unlock m))" + #f)) + +(condition-wait cv m) ; releases m, blocks, reacquires m on wake +(mutex-unlock m) +(thread-join h) +``` + +Broadcast with ready-signaling: + +```lisp +(define m (mutex-create "m")) +(define bc (condition-create "bc")) +(define r1 (condition-create "r1")) +(define r2 (condition-create "r2")) + +(mutex-lock m) + +;; Child 1: signal ready, then wait for broadcast +(define h1 (thread-create + "(begin + (define m (mutex-lookup \"m\")) + (define bc (condition-lookup \"bc\")) + (define r (condition-lookup \"r1\")) + (mutex-lock m) + (condition-signal r) + (condition-wait bc m) + (mutex-unlock m))" #f)) +(condition-wait r1 m) ; wait until child 1 is ready + +;; Child 2: same pattern +(define h2 (thread-create + "(begin + (define m (mutex-lookup \"m\")) + (define bc (condition-lookup \"bc\")) + (define r (condition-lookup \"r2\")) + (mutex-lock m) + (condition-signal r) + (condition-wait bc m) + (mutex-unlock m))" #f)) +(condition-wait r2 m) ; wait until child 2 is ready + +;; Both children are now in condition-wait on bc +(condition-broadcast bc) +(mutex-unlock m) + +(thread-join h1) +(thread-join h2) +``` + +### Type Discrimination + +Mutexes, condition variables, and thread handles are all foreign pointers +but are tagged with distinct `xlCClass` type markers. The predicates +`mutex?`, `condition?`, and `thread?` correctly distinguish between them: + +```lisp +(define m (mutex-create)) +(define cv (condition-create)) +(mutex? m) ; => #t +(mutex? cv) ; => #f +(condition? cv) ; => #t +(condition? m) ; => #f +``` + +## C-Level API + +### Headers + +```c +#include "xlisp.h" +#include "xlcontext.h" +``` + +### Context Management + +```c +xlContext *xlCreateContext(void); +int xlInitContext(xlContext *ctx, xlCallbacks *callbacks, + int argc, const char *argv[], const char *workspace); +void xlSetCurrentContext(xlContext *ctx); +xlContext *xlGetCurrentContext(void); +void xlDestroyContext(xlContext *ctx); +``` + +### Single-Thread Usage + +For single-threaded use, the standard `xlInit()` works as before. In +reentrant mode it automatically creates a default context: + +```c +int main(int argc, char *argv[]) { + xlCallbacks *callbacks = xlDefaultCallbacks(argc, argv); + if (!xlInit(callbacks, argc, argv, NULL)) { + fprintf(stderr, "Failed to initialize XLISP\n"); + return 1; + } + xlCallFunctionByName(NULL, 0, "*TOPLEVEL*", 0); + return 0; +} +``` + +### Multi-Thread Usage + +Each thread must create and initialize its own context: + +```c +#include +#include "xlisp.h" + +void *worker_thread(void *arg) { + xlContext *ctx = xlCreateContext(); + xlCallbacks *callbacks = xlDefaultCallbacks(NULL); + + if (xlInitContext(ctx, callbacks, 0, NULL, NULL) != 0) { + xlDestroyContext(ctx); + return NULL; + } + + xlLoadFile("worker.lsp"); + xlCallFunctionByName(NULL, 0, "DO-WORK", 0); + + xlDestroyContext(ctx); + return NULL; +} +``` + +### Multiple Contexts in One Thread + +A single thread can manage multiple contexts: + +```c +xlContext *ctx1 = xlCreateContext(); +xlContext *ctx2 = xlCreateContext(); + +xlInitContext(ctx1, callbacks, 0, NULL, NULL); +xlLoadFile("program1.lsp"); + +xlInitContext(ctx2, callbacks, 0, NULL, NULL); +xlLoadFile("program2.lsp"); + +xlSetCurrentContext(ctx1); +xlCallFunctionByName(NULL, 0, "FUNC1", 0); + +xlSetCurrentContext(ctx2); +xlCallFunctionByName(NULL, 0, "FUNC2", 0); + +xlDestroyContext(ctx1); +xlDestroyContext(ctx2); +``` + +## Implementation Files + +| File | Role | +|------|------| +| `include/xlcontext.h` | Context structure and TLS configuration | +| `include/xlcompat.h` | Compatibility macros redirecting globals to context | +| `include/xlthread.h` | Thread-safe API declarations | +| `src/xlcontext.c` | Context creation, destruction, initialization | +| `src/xlnthread.c` | `thread-create`, `thread-join`, `thread?` | +| `src/xlsync.c` | Mutexes, condition variables, named registry | + +## Limitations + +1. **No data sharing.** Lisp values cannot be passed between contexts. + Each context has its own heap; pointers are not valid across contexts. + +2. **String-only communication.** Data crosses thread boundaries as C + strings (used by `thread-create` and the named registry). + +3. **Memory overhead.** Each context has a full interpreter instance. + Memory scales linearly with context count. + +4. **Initialization serialization.** Context initialization uses OS + callbacks with static buffers that are not thread-safe. A global mutex + serializes `xlInitContext` and `xlLoadFile` calls in child threads. + +5. **Known thread-unsafe statics (low risk).** Several file-static + variables remain shared but are low-risk: + - `gsprefix`/`gsnumber` in `xlfun1.c` (gensym counter) + - `buf[200]` in `xlprint.c` (number formatting) + - `lposition` in `unstuff.c` (console output tracking) + - `rseed` in `xlansi.c` (random number seed) + + These affect output formatting and gensym uniqueness but do not cause + crashes. + +## Platform Support + +| Component | POSIX | Windows | +|-----------|-------|---------| +| TLS | `__thread` | `__declspec(thread)` | +| Thread creation | `pthread_create` | `_beginthreadex` | +| Mutex | `pthread_mutex_t` | `CRITICAL_SECTION` | +| Condition variable | `pthread_cond_t` | `CONDITION_VARIABLE` (Vista+) | diff --git a/doc/api.md b/doc/api.md index f5f6c02..d4dd450 100644 --- a/doc/api.md +++ b/doc/api.md @@ -10,7 +10,7 @@ make Reentrant/thread-safe build: ```bash -make REENTRANT=1 +make THREADS=1 ``` The reentrant build enables thread-local interpreter contexts, allowing XLISP to be safely called from multiple threads. @@ -48,7 +48,7 @@ void main(int argc,char *argv[]) ### Multi-threaded Usage -When built with `REENTRANT=1`, each thread must create and initialize its own interpreter context. Contexts are completely independent - no Lisp data is shared between threads. +When built with `THREADS=1`, each thread must create and initialize its own interpreter context. Contexts are completely independent - no Lisp data is shared between threads. ```cpp #include "xlisp.h" diff --git a/doc/xlisp.md b/doc/xlisp.md index 41e745f..d6e4088 100644 --- a/doc/xlisp.md +++ b/doc/xlisp.md @@ -2382,3 +2382,290 @@ frame. The symbol values start at offset 1. - Objects are represented as vectors. The element at offset 0 is the class of the object. The remaining elements are the object's instance variable values. + +# 49. Threading Functions + +XLISP supports native thread creation when built in reentrant mode +(`make THREADS=1`). Each spawned thread gets its own independent +interpreter context -- it does not share any Lisp-level state with the +calling thread. The thread evaluates a string expression in a fresh +environment. + +If the system was not built with `THREADS=1`, calling these functions +signals an error. + +**Important:** `THREAD-CREATE` evaluates only the *first* expression in +the string. To execute multiple statements, wrap them in `(begin ...)`. + +## THREAD-CREATE + +```lisp +(THREAD-CREATE expr-string [init-file]) +``` + +Creates a new native thread that evaluates *expr-string* (a string +containing a Lisp expression) in its own interpreter context. + +*init-file* is an optional string naming an initialization file to load +before evaluating the expression. The default is `"xlisp.lsp"`. Pass +`#f` to skip loading any initialization file. + +Returns a thread handle (a foreign-pointer object) that can be passed to +`THREAD-JOIN`. + +Example: +```lisp +;; Spawn a thread that computes fib(30) +(define h (thread-create + "(begin + (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) + (fib 30))")) + +;; Wait for it to finish +(thread-join h) ; => #t +``` + +Example with no init file (faster startup): +```lisp +(define h (thread-create "(+ 1 2)" #f)) +(thread-join h) ; => #t +``` + +## THREAD-JOIN + +```lisp +(THREAD-JOIN handle) +``` + +Waits for the thread identified by *handle* to complete. Returns `#t` +if the thread finished successfully. Signals an error if the thread +terminated with an error or if the handle has already been joined. + +Each thread handle must be joined exactly once. + +## THREAD? + +```lisp +(THREAD? obj) +``` + +Returns `#t` if *obj* is a live (not yet joined) thread handle, `#f` +otherwise. + +# 50. Synchronization Primitives + +These functions provide mutexes and condition variables for coordinating +between threads. They require a reentrant build (`make THREADS=1`). + +Since each thread has an independent Lisp heap, synchronization objects +are shared across threads through a **named registry**. The creating +thread passes an optional name to the create function; other threads +look up the object by that name. Both threads' handles point to the +same underlying OS synchronization object. + +## Mutexes + +### MUTEX-CREATE + +```lisp +(MUTEX-CREATE [name]) +``` + +Creates a new mutex. If *name* (a string) is provided, the mutex is +registered globally so other threads can find it with `MUTEX-LOOKUP`. + +### MUTEX-LOCK + +```lisp +(MUTEX-LOCK mutex) +``` + +Acquires the mutex, blocking if it is already held by another thread. +Returns `#t`. + +### MUTEX-UNLOCK + +```lisp +(MUTEX-UNLOCK mutex) +``` + +Releases the mutex. Returns `#t`. + +### MUTEX-DESTROY + +```lisp +(MUTEX-DESTROY mutex) +``` + +Destroys the mutex and releases its resources. Returns `#t`. Signals +an error if already destroyed. + +### MUTEX-LOOKUP + +```lisp +(MUTEX-LOOKUP name) +``` + +Looks up a named mutex in the global registry. Returns a mutex handle, +or `#f` if no mutex with that name exists. + +### MUTEX? + +```lisp +(MUTEX? obj) +``` + +Returns `#t` if *obj* is a live (not yet destroyed) mutex handle. + +### Mutex Example + +```lisp +;; Create a named mutex +(define m (mutex-create "my-lock")) + +;; Lock before spawning child so it blocks until main releases +(mutex-lock m) + +(define h (thread-create + "(begin + (define m (mutex-lookup \"my-lock\")) + (mutex-lock m) + ;; critical section + (mutex-unlock m))" + #f)) + +(mutex-unlock m) +(thread-join h) +(mutex-destroy m) +``` + +## Condition Variables + +### CONDITION-CREATE + +```lisp +(CONDITION-CREATE [name]) +``` + +Creates a new condition variable. If *name* is provided, it is +registered globally for cross-thread lookup. + +### CONDITION-WAIT + +```lisp +(CONDITION-WAIT cond mutex) +``` + +Atomically unlocks *mutex* and blocks until *cond* is signaled. +When the thread wakes, *mutex* is reacquired before returning. +Returns `#t`. + +### CONDITION-SIGNAL + +```lisp +(CONDITION-SIGNAL cond) +``` + +Wakes one thread waiting on *cond*. Returns `#t`. + +### CONDITION-BROADCAST + +```lisp +(CONDITION-BROADCAST cond) +``` + +Wakes all threads waiting on *cond*. Returns `#t`. + +### CONDITION-DESTROY + +```lisp +(CONDITION-DESTROY cond) +``` + +Destroys the condition variable. Returns `#t`. + +### CONDITION-LOOKUP + +```lisp +(CONDITION-LOOKUP name) +``` + +Looks up a named condition variable. Returns a handle, or `#f` if not +found. + +### CONDITION? + +```lisp +(CONDITION? obj) +``` + +Returns `#t` if *obj* is a live condition variable handle. + +### Condition Variable Example + +```lisp +(define m (mutex-create "m")) +(define cv (condition-create "cv")) + +;; Lock before spawning -- child blocks on mutex-lock until +;; main enters condition-wait (which releases the mutex). +(mutex-lock m) + +(define h (thread-create + "(begin + (define m (mutex-lookup \"m\")) + (define c (condition-lookup \"cv\")) + (mutex-lock m) + (condition-signal c) + (mutex-unlock m))" + #f)) + +(condition-wait cv m) ; releases m, blocks, reacquires m +(mutex-unlock m) +(thread-join h) +(mutex-destroy m) +(condition-destroy cv) +``` + +### Broadcast Example + +To broadcast reliably, have each child signal a "ready" condition +variable before entering the broadcast wait: + +```lisp +(define m (mutex-create "m")) +(define bc (condition-create "bc")) +(define r1 (condition-create "r1")) +(define r2 (condition-create "r2")) + +(mutex-lock m) + +(define h1 (thread-create + "(begin + (define m (mutex-lookup \"m\")) + (define bc (condition-lookup \"bc\")) + (define r (condition-lookup \"r1\")) + (mutex-lock m) + (condition-signal r) + (condition-wait bc m) + (mutex-unlock m))" #f)) +(condition-wait r1 m) + +(define h2 (thread-create + "(begin + (define m (mutex-lookup \"m\")) + (define bc (condition-lookup \"bc\")) + (define r (condition-lookup \"r2\")) + (mutex-lock m) + (condition-signal r) + (condition-wait bc m) + (mutex-unlock m))" #f)) +(condition-wait r2 m) + +;; Both children are now waiting on bc +(condition-broadcast bc) +(mutex-unlock m) + +(thread-join h1) +(thread-join h2) +``` diff --git a/include/xlcompat.h b/include/xlcompat.h index 7038267..3a00b5d 100644 --- a/include/xlcompat.h +++ b/include/xlcompat.h @@ -47,7 +47,14 @@ #define xlcatch (xlCtx()->catchFrame) #define xlTraceBytecodes (xlCtx()->traceBytecodes) -/* Note: pc and pcBase are static in xlint.c, handled separately */ +/* + * Bytecode interpreter locals (were file-static in xlint.c). + * These MUST be per-thread for correct concurrent execution. + */ +#define xlint_base (xlCtx()->pcBase) +#define xlint_pc (xlCtx()->pc) +#define xlint_xltarget (xlCtx()->throwTarget) +#define xlint_sample (xlCtx()->sample) /* ==================================================================== * Memory Management - Node Space @@ -199,6 +206,12 @@ * ==================================================================== */ #define xlDebugModeP (xlCtx()->debugModeP) +/* Compiler locals (were file-static in xlcom.c) */ +#define xlcom_cbuff (xlCtx()->cbuff) +#define xlcom_cbase (xlCtx()->cbase) +#define xlcom_cptr (xlCtx()->cptr) +#define xlcom_info (xlCtx()->compilerInfo) + /* ==================================================================== * Object System * ==================================================================== */ diff --git a/include/xlcontext.h b/include/xlcontext.h index ce593b0..a5306ed 100644 --- a/include/xlcontext.h +++ b/include/xlcontext.h @@ -71,6 +71,7 @@ typedef struct xlContext { unsigned char *pcBase; /* base of current code object */ xlErrorTarget *errTarget; /* error/abort target chain */ xlValue *catchFrame; /* current catch frame pointer */ + xlValue *throwTarget; /* current throw target */ int traceBytecodes; /* bytecode tracing enabled */ int sample; /* control character sample counter */ @@ -221,6 +222,10 @@ typedef struct xlContext { * Compiler State * ================================================================ */ int debugModeP; /* true to turn off tail recursion */ + unsigned char *cbuff; /* compiler code buffer */ + int cbase; /* compiler base for current function */ + int cptr; /* compiler code buffer pointer */ + xlValue compilerInfo; /* compiler info during compilation */ /* ================================================================ * Initialization State diff --git a/include/xlisp.h b/include/xlisp.h index bb821e0..0025148 100755 --- a/include/xlisp.h +++ b/include/xlisp.h @@ -1223,6 +1223,26 @@ void xsendsuper(void); void xlObSymbols(void); void xlInitObjects(void); +/* xlnthread.c */ +xlValue xthreadcreate(void); +xlValue xthreadjoin(void); +xlValue xthreadp(void); + +/* xlsync.c - synchronization primitives */ +xlValue xmutexcreate(void); +xlValue xmutexlock(void); +xlValue xmutexunlock(void); +xlValue xmutexdestroy(void); +xlValue xmutexlookup(void); +xlValue xmutexp(void); +xlValue xcondcreate(void); +xlValue xcondwait(void); +xlValue xcondsignal(void); +xlValue xcondbroadcast(void); +xlValue xconddestroy(void); +xlValue xcondlookup(void); +xlValue xcondp(void); + /* xlcobj.c */ xlEXPORT xlCClass *xlMakeCClass(xlCClassDef *def,xlValue super); xlEXPORT void *xlGetArgUninitializedCInstance(xlCClass *ccls); diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 56e4cf7..3f195fc 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -19,6 +19,8 @@ set(xlisp_sources xlitersq.c xlmain.c xlmath.c + xlnthread.c + xlsync.c xlobj.c xlosint.c xlprint.c diff --git a/src/xlcom.c b/src/xlcom.c index df0f100..71bd516 100755 --- a/src/xlcom.c +++ b/src/xlcom.c @@ -36,12 +36,23 @@ extern xlValue slk_optional,slk_rest; #endif /* local variables */ +#ifdef XLISP_USE_CONTEXT +#define info xlcom_info +#else static xlValue info; /* compiler info */ +#endif /* code buffer */ +#ifdef XLISP_USE_CONTEXT +/* In context mode, these are per-thread via the context structure */ +#define cbuff xlcom_cbuff +#define cbase xlcom_cbase +#define cptr xlcom_cptr +#else static unsigned char *cbuff = NULL; /* base of code buffer */ static int cbase; /* base for current function */ static int cptr; /* code buffer pointer */ +#endif /* forward declarations */ static void do_expr(xlValue expr,int cont); diff --git a/src/xlftab.c b/src/xlftab.c index ee31c29..7f8f5ef 100755 --- a/src/xlftab.c +++ b/src/xlftab.c @@ -398,6 +398,26 @@ static xlSubrDef subrtab[] = { { "%GET-STACK-POINTER", xGetStackPointer }, #endif + /* threading functions */ +{ "THREAD-CREATE", xthreadcreate }, +{ "THREAD-JOIN", xthreadjoin }, +{ "THREAD?", xthreadp }, + + /* synchronization primitives */ +{ "MUTEX-CREATE", xmutexcreate }, +{ "MUTEX-LOCK", xmutexlock }, +{ "MUTEX-UNLOCK", xmutexunlock }, +{ "MUTEX-DESTROY", xmutexdestroy }, +{ "MUTEX-LOOKUP", xmutexlookup }, +{ "MUTEX?", xmutexp }, +{ "CONDITION-CREATE", xcondcreate }, +{ "CONDITION-WAIT", xcondwait }, +{ "CONDITION-SIGNAL", xcondsignal }, +{ "CONDITION-BROADCAST", xcondbroadcast }, +{ "CONDITION-DESTROY", xconddestroy }, +{ "CONDITION-LOOKUP", xcondlookup }, +{ "CONDITION?", xcondp }, + {0,0} /* end of table marker */ }; diff --git a/src/xlint.c b/src/xlint.c index 3baacf6..215c552 100755 --- a/src/xlint.c +++ b/src/xlint.c @@ -36,9 +36,17 @@ extern xlValue s_stackpointer; #define BCD_ABORT 3 /* local variables */ +#ifdef XLISP_USE_CONTEXT +/* In context mode, these are per-thread via the context structure */ +#define base xlint_base +#define pc xlint_pc +#define xltarget xlint_xltarget +#define sample xlint_sample +#else static unsigned char *base,*pc; static xlValue *xltarget; /* current throw target */ static int sample=xlSRATE; +#endif /* local prototypes */ static void show_call(xlValue code,xlValue frame); @@ -1213,12 +1221,17 @@ static void opBAD(void) /* opcode dispatch table */ static void (*optab[256])(void); +static int optabInitialized = 0; /* xlInitInterpreter - initialize the interpreter */ void xlInitInterpreter(void) { int i; - + + /* optab is shared and immutable after first init - skip if done */ + if (optabInitialized) + return; + /* first fill in the default opcode handler */ for (i = 0; i < 256; ++i) optab[i] = opBAD; @@ -1277,6 +1290,8 @@ void xlInitInterpreter(void) optab[xlopPROTECT] = opPROTECT; optab[xlopUNPROTECT] = opUNPROTECT; optab[xlopENV] = opENV; + + optabInitialized = 1; } /* xlInternalCall - call a function */ diff --git a/src/xlmain.c b/src/xlmain.c index 1469814..cd723b1 100755 --- a/src/xlmain.c +++ b/src/xlmain.c @@ -9,7 +9,7 @@ /* the program banner */ #define BANNER "\ -XLISP 3.3, September 6, 2002 Copyright (c) 1984-2002, by David Betz" +XLISP 10.0.0 Copyright (c) 1984-2002, by David Betz" /* * When XLISP_USE_CONTEXT is defined, globals become macros to xlCtx(). diff --git a/src/xlnthread.c b/src/xlnthread.c new file mode 100644 index 0000000..5320c99 --- /dev/null +++ b/src/xlnthread.c @@ -0,0 +1,297 @@ +/* xlnthread.c - native thread creation for xlisp */ +/* Copyright (c) 1984-2002, by David Michael Betz + All Rights Reserved + See the included file 'license.txt' for the full license. +*/ + +#include "xlisp.h" + +#ifdef _WIN32 +#include +#include +#else +#include +#endif + +#include + +/* thread info structure - tracks a spawned thread */ +typedef struct xlThreadInfo { + char *expr; /* expression to evaluate (C string copy) */ + char *initFile; /* initialization file to load, or NULL */ + int status; /* 0=running, 1=success, -1=error */ + int joined; /* whether thread-join has been called */ +#ifdef _WIN32 + HANDLE thread; +#else + pthread_t thread; + int threadValid; /* whether pthread_t has been set */ +#endif +} xlThreadInfo; + +#ifdef XLISP_USE_CONTEXT + +/* + * Mutex to serialize context initialization. + * Some underlying OS callbacks (osparsepath, etc.) use static buffers + * that are not thread-safe. We serialize initialization and file loading + * to avoid corruption. + */ +#ifdef _WIN32 +static CRITICAL_SECTION initMutex; +static int initMutexReady = 0; +static void ensureInitMutex(void) { + if (!initMutexReady) { + InitializeCriticalSection(&initMutex); + initMutexReady = 1; + } +} +#define INIT_LOCK() do { ensureInitMutex(); EnterCriticalSection(&initMutex); } while(0) +#define INIT_UNLOCK() LeaveCriticalSection(&initMutex) +#else +static pthread_mutex_t initMutex = PTHREAD_MUTEX_INITIALIZER; +#define INIT_LOCK() pthread_mutex_lock(&initMutex) +#define INIT_UNLOCK() pthread_mutex_unlock(&initMutex) +#endif + +/* worker thread function */ +#ifdef _WIN32 +static unsigned __stdcall threadWorker(void *arg) +#else +static void *threadWorker(void *arg) +#endif +{ + xlThreadInfo *info = (xlThreadInfo *)arg; + xlContext *ctx = NULL; + xlCallbacks *callbacks = NULL; + xlValue result; + + /* create a new interpreter context for this thread */ + ctx = xlCreateContext(); + if (ctx == NULL) { + info->status = -1; +#ifdef _WIN32 + return 1; +#else + return NULL; +#endif + } + + /* + * Serialize initialization: xlInitContext and xlLoadFile use + * OS callbacks with static buffers that aren't thread-safe. + */ + INIT_LOCK(); + + /* get default callbacks and initialize the context */ + callbacks = xlDefaultCallbacks(NULL); + if (xlInitContext(ctx, callbacks, 0, NULL, NULL) != 0) { + INIT_UNLOCK(); + xlDestroyContext(ctx); + info->status = -1; +#ifdef _WIN32 + return 1; +#else + return NULL; +#endif + } + + /* load the initialization file if specified */ + if (info->initFile != NULL) + xlLoadFile(info->initFile); + + INIT_UNLOCK(); + + /* evaluate the expression */ + if (xlEvaluateCString(&result, 1, info->expr) >= 0) + info->status = 1; + else + info->status = -1; + + /* clean up the context */ + xlDestroyContext(ctx); + +#ifdef _WIN32 + return 0; +#else + return NULL; +#endif +} + +#endif /* XLISP_USE_CONTEXT */ + +/* xthreadcreate - built-in function 'thread-create' */ +/* (thread-create expr-string [init-file]) => thread-handle */ +xlValue xthreadcreate(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue strval, initval; + const char *str, *initStr; + xlThreadInfo *info; + xlValue handle; + + /* get the expression string argument */ + strval = xlGetArgString(); + + /* get optional init file argument (default: "xlisp.lsp") */ + if (xlMoreArgsP()) { + initval = xlGetArg(); + if (initval == xlNil || initval == xlFalse) + initStr = NULL; /* #f or nil means no init file */ + else if (xlStringP(initval)) + initStr = xlGetString(initval); + else { + xlBadType(initval); + return xlNil; /* not reached */ + } + } + else { + initStr = "xlisp.lsp"; /* default: load standard init */ + } + + xlLastArg(); + + str = xlGetString(strval); + + /* allocate thread info */ + info = (xlThreadInfo *)malloc(sizeof(xlThreadInfo)); + if (info == NULL) + xlFmtError("thread-create: out of memory"); + + memset(info, 0, sizeof(xlThreadInfo)); + + /* copy the expression string (it may be GC'd in the calling thread) */ + info->expr = (char *)malloc(strlen(str) + 1); + if (info->expr == NULL) { + free(info); + xlFmtError("thread-create: out of memory"); + } + strcpy(info->expr, str); + + /* copy the init file name if specified */ + if (initStr != NULL) { + info->initFile = (char *)malloc(strlen(initStr) + 1); + if (info->initFile == NULL) { + free(info->expr); + free(info); + xlFmtError("thread-create: out of memory"); + } + strcpy(info->initFile, initStr); + } + else { + info->initFile = NULL; + } + + info->status = 0; /* running */ + info->joined = 0; + + /* create the thread handle as a foreign pointer */ + handle = xlMakeForeignPtr(NULL, info); + + /* create the OS thread */ +#ifdef _WIN32 + info->thread = (HANDLE)_beginthreadex(NULL, 0, threadWorker, info, 0, NULL); + if (info->thread == 0) { + free(info->expr); + free(info); + xlFmtError("thread-create: failed to create thread"); + } +#else + { + int rc = pthread_create(&info->thread, NULL, threadWorker, info); + if (rc != 0) { + free(info->expr); + free(info); + xlFmtError("thread-create: failed to create thread"); + } + info->threadValid = 1; + } +#endif + + return handle; +#else + xlGetArgString(); + if (xlMoreArgsP()) xlGetArg(); + xlLastArg(); + xlFmtError("thread-create: requires threaded build (THREADS=1)"); + return xlNil; /* not reached */ +#endif +} + +/* xthreadjoin - built-in function 'thread-join' */ +/* (thread-join handle) => #t on success, signals error on failure */ +xlValue xthreadjoin(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue arg; + xlThreadInfo *info; + + /* get the thread handle argument */ + arg = xlGetArgForeignPtr(); + xlLastArg(); + + info = (xlThreadInfo *)xlGetFPtr(arg); + if (info == NULL) + xlFmtError("thread-join: invalid thread handle"); + + if (info->joined) + xlFmtError("thread-join: thread already joined"); + + /* wait for the thread to finish */ +#ifdef _WIN32 + WaitForSingleObject(info->thread, INFINITE); + CloseHandle(info->thread); + info->thread = NULL; +#else + if (info->threadValid) { + pthread_join(info->thread, NULL); + info->threadValid = 0; + } +#endif + + info->joined = 1; + + /* free the expression and init file strings */ + if (info->expr != NULL) { + free(info->expr); + info->expr = NULL; + } + if (info->initFile != NULL) { + free(info->initFile); + info->initFile = NULL; + } + + /* check status */ + if (info->status == 1) { + /* clean up the info structure */ + free(info); + xlSetFPtr(arg, NULL); + return xlTrue; + } + else { + free(info); + xlSetFPtr(arg, NULL); + xlFmtError("thread-join: thread terminated with error"); + return xlNil; /* not reached */ + } +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("thread-join: requires threaded build (THREADS=1)"); + return xlNil; /* not reached */ +#endif +} + +/* xthreadp - built-in function 'thread?' */ +/* (thread? obj) => #t if obj is a thread handle */ +xlValue xthreadp(void) +{ + xlValue arg; + arg = xlGetArg(); + xlLastArg(); + + /* a thread handle is a foreign pointer with non-null data */ + if (xlForeignPtrP(arg) && xlGetFPtr(arg) != NULL) + return xlTrue; + return xlFalse; +} diff --git a/src/xlsync.c b/src/xlsync.c new file mode 100644 index 0000000..31ccbb4 --- /dev/null +++ b/src/xlsync.c @@ -0,0 +1,597 @@ +/* xlsync.c - synchronization primitives for xlisp threads */ +/* Copyright (c) 1984-2002, by David Michael Betz + All Rights Reserved + See the included file 'license.txt' for the full license. +*/ + +#include "xlisp.h" + +#ifdef _WIN32 +#include +#else +#include +#endif + +#include +#include + +/* ==================================================================== + * Type tags for foreign pointer discrimination + * ==================================================================== */ + +/* + * We use static xlCClass structs as type tags. Only their addresses + * matter -- no fields are used. This lets mutex?, condition?, channel? + * distinguish their handles from other foreign pointers. + */ +static xlCClass mutexTag = { NULL, NULL, NULL }; +static xlCClass condTag = { NULL, NULL, NULL }; + +/* ==================================================================== + * Named-object registry + * + * Synchronization objects can be shared across threads by name. + * A creating thread calls (mutex-create "name"), and a child thread + * calls (mutex-lookup "name") to obtain a handle to the same OS object. + * + * The registry itself is protected by its own mutex. + * ==================================================================== */ + +typedef struct xlSyncEntry { + char *name; /* registry name (malloc'd) */ + void *obj; /* pointer to the handle struct */ + xlCClass *tag; /* &mutexTag or &condTag */ + int refCount; /* number of live references */ + struct xlSyncEntry *next; +} xlSyncEntry; + +#ifdef XLISP_USE_CONTEXT + +static xlSyncEntry *registryHead = NULL; + +#ifdef _WIN32 +static CRITICAL_SECTION registryLock; +static int registryLockReady = 0; +static void ensureRegistryLock(void) { + if (!registryLockReady) { + InitializeCriticalSection(®istryLock); + registryLockReady = 1; + } +} +#define REG_LOCK() do { ensureRegistryLock(); EnterCriticalSection(®istryLock); } while(0) +#define REG_UNLOCK() LeaveCriticalSection(®istryLock) +#else +static pthread_mutex_t registryLock = PTHREAD_MUTEX_INITIALIZER; +#define REG_LOCK() pthread_mutex_lock(®istryLock) +#define REG_UNLOCK() pthread_mutex_unlock(®istryLock) +#endif + +/* register a named object; returns 1 on success, 0 if name already taken */ +static int registryAdd(const char *name, void *obj, xlCClass *tag) +{ + xlSyncEntry *e; + REG_LOCK(); + for (e = registryHead; e != NULL; e = e->next) { + if (strcmp(e->name, name) == 0) { + REG_UNLOCK(); + return 0; /* name already exists */ + } + } + e = (xlSyncEntry *)malloc(sizeof(xlSyncEntry)); + if (e == NULL) { REG_UNLOCK(); return 0; } + e->name = (char *)malloc(strlen(name) + 1); + if (e->name == NULL) { free(e); REG_UNLOCK(); return 0; } + strcpy(e->name, name); + e->obj = obj; + e->tag = tag; + e->refCount = 1; + e->next = registryHead; + registryHead = e; + REG_UNLOCK(); + return 1; +} + +/* look up a named object; increments refCount if found */ +static void *registryLookup(const char *name, xlCClass *tag) +{ + xlSyncEntry *e; + void *result = NULL; + REG_LOCK(); + for (e = registryHead; e != NULL; e = e->next) { + if (e->tag == tag && strcmp(e->name, name) == 0) { + e->refCount++; + result = e->obj; + break; + } + } + REG_UNLOCK(); + return result; +} + +/* decrement refCount for an object; returns new refCount */ +static int registryRelease(void *obj, xlCClass *tag) +{ + xlSyncEntry *e, **pp; + int rc = 0; + REG_LOCK(); + for (pp = ®istryHead; *pp != NULL; pp = &(*pp)->next) { + e = *pp; + if (e->obj == obj && e->tag == tag) { + e->refCount--; + rc = e->refCount; + if (rc <= 0) { + *pp = e->next; + free(e->name); + free(e); + } + break; + } + } + REG_UNLOCK(); + return rc; +} + +#endif /* XLISP_USE_CONTEXT */ + + +/* ==================================================================== + * Mutex implementation + * ==================================================================== */ + +#ifdef XLISP_USE_CONTEXT + +typedef struct xlMutexHandle { +#ifdef _WIN32 + CRITICAL_SECTION cs; +#else + pthread_mutex_t mutex; +#endif + int destroyed; +} xlMutexHandle; + +static xlMutexHandle *allocMutex(void) +{ + xlMutexHandle *m = (xlMutexHandle *)malloc(sizeof(xlMutexHandle)); + if (m == NULL) return NULL; + memset(m, 0, sizeof(xlMutexHandle)); +#ifdef _WIN32 + InitializeCriticalSection(&m->cs); +#else + pthread_mutex_init(&m->mutex, NULL); +#endif + m->destroyed = 0; + return m; +} + +static void freeMutex(xlMutexHandle *m) +{ + if (m == NULL) return; +#ifdef _WIN32 + DeleteCriticalSection(&m->cs); +#else + pthread_mutex_destroy(&m->mutex); +#endif + free(m); +} + +#endif /* XLISP_USE_CONTEXT */ + + +/* xmutexcreate - (mutex-create [name]) => mutex handle */ +xlValue xmutexcreate(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue nameArg = xlNil; + const char *name = NULL; + xlMutexHandle *m; + xlValue handle; + + /* optional name argument */ + if (xlMoreArgsP()) { + nameArg = xlGetArgString(); + name = xlGetString(nameArg); + } + xlLastArg(); + + m = allocMutex(); + if (m == NULL) + xlFmtError("mutex-create: out of memory"); + + handle = xlMakeForeignPtr(&mutexTag, m); + + if (name != NULL) { + if (!registryAdd(name, m, &mutexTag)) { + freeMutex(m); + xlSetFPtr(handle, NULL); + xlFmtError("mutex-create: name already in use"); + } + } else { + /* anonymous: add to registry with empty name for refcounting */ + /* Actually, for anonymous objects we just track them without registry */ + } + + return handle; +#else + if (xlMoreArgsP()) xlGetArgString(); + xlLastArg(); + xlFmtError("mutex-create: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xmutexlock - (mutex-lock mutex) => #t */ +xlValue xmutexlock(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue arg; + xlMutexHandle *m; + + arg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(arg) != &mutexTag) + xlFmtError("mutex-lock: not a mutex"); + m = (xlMutexHandle *)xlGetFPtr(arg); + if (m == NULL || m->destroyed) + xlFmtError("mutex-lock: mutex has been destroyed"); + +#ifdef _WIN32 + EnterCriticalSection(&m->cs); +#else + pthread_mutex_lock(&m->mutex); +#endif + return xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("mutex-lock: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xmutexunlock - (mutex-unlock mutex) => #t */ +xlValue xmutexunlock(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue arg; + xlMutexHandle *m; + + arg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(arg) != &mutexTag) + xlFmtError("mutex-unlock: not a mutex"); + m = (xlMutexHandle *)xlGetFPtr(arg); + if (m == NULL || m->destroyed) + xlFmtError("mutex-unlock: mutex has been destroyed"); + +#ifdef _WIN32 + LeaveCriticalSection(&m->cs); +#else + pthread_mutex_unlock(&m->mutex); +#endif + return xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("mutex-unlock: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xmutexdestroy - (mutex-destroy mutex) => #t */ +xlValue xmutexdestroy(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue arg; + xlMutexHandle *m; + + arg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(arg) != &mutexTag) + xlFmtError("mutex-destroy: not a mutex"); + m = (xlMutexHandle *)xlGetFPtr(arg); + if (m == NULL || m->destroyed) + xlFmtError("mutex-destroy: already destroyed"); + + m->destroyed = 1; + + /* check refcount via registry; if not registered just free */ + if (registryRelease(m, &mutexTag) <= 0) + freeMutex(m); + + xlSetFPtr(arg, NULL); + return xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("mutex-destroy: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xmutexlookup - (mutex-lookup name) => mutex handle or #f */ +xlValue xmutexlookup(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue nameArg; + const char *name; + xlMutexHandle *m; + + nameArg = xlGetArgString(); + xlLastArg(); + name = xlGetString(nameArg); + + m = (xlMutexHandle *)registryLookup(name, &mutexTag); + if (m == NULL || m->destroyed) + return xlFalse; + + return xlMakeForeignPtr(&mutexTag, m); +#else + xlGetArgString(); + xlLastArg(); + xlFmtError("mutex-lookup: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xmutexp - (mutex? obj) => #t / #f */ +xlValue xmutexp(void) +{ + xlValue arg; + arg = xlGetArg(); + xlLastArg(); + if (xlForeignPtrP(arg) && xlGetFPType(arg) == &mutexTag && xlGetFPtr(arg) != NULL) + return xlTrue; + return xlFalse; +} + + +/* ==================================================================== + * Condition variable implementation + * ==================================================================== */ + +#ifdef XLISP_USE_CONTEXT + +typedef struct xlCondHandle { +#ifdef _WIN32 + CONDITION_VARIABLE cond; +#else + pthread_cond_t cond; +#endif + int destroyed; +} xlCondHandle; + +static xlCondHandle *allocCond(void) +{ + xlCondHandle *c = (xlCondHandle *)malloc(sizeof(xlCondHandle)); + if (c == NULL) return NULL; + memset(c, 0, sizeof(xlCondHandle)); +#ifdef _WIN32 + InitializeConditionVariable(&c->cond); +#else + pthread_cond_init(&c->cond, NULL); +#endif + c->destroyed = 0; + return c; +} + +static void freeCond(xlCondHandle *c) +{ + if (c == NULL) return; +#ifdef _WIN32 + /* Windows CONDITION_VARIABLE doesn't need explicit destruction */ +#else + pthread_cond_destroy(&c->cond); +#endif + free(c); +} + +#endif /* XLISP_USE_CONTEXT */ + + +/* xcondcreate - (condition-create [name]) => condition handle */ +xlValue xcondcreate(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue nameArg = xlNil; + const char *name = NULL; + xlCondHandle *c; + xlValue handle; + + if (xlMoreArgsP()) { + nameArg = xlGetArgString(); + name = xlGetString(nameArg); + } + xlLastArg(); + + c = allocCond(); + if (c == NULL) + xlFmtError("condition-create: out of memory"); + + handle = xlMakeForeignPtr(&condTag, c); + + if (name != NULL) { + if (!registryAdd(name, c, &condTag)) { + freeCond(c); + xlSetFPtr(handle, NULL); + xlFmtError("condition-create: name already in use"); + } + } + + return handle; +#else + if (xlMoreArgsP()) xlGetArgString(); + xlLastArg(); + xlFmtError("condition-create: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xcondwait - (condition-wait cond mutex) => #t */ +xlValue xcondwait(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue condArg, mutexArg; + xlCondHandle *c; + xlMutexHandle *m; + + condArg = xlGetArgForeignPtr(); + mutexArg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(condArg) != &condTag) + xlFmtError("condition-wait: first argument is not a condition variable"); + if (xlGetFPType(mutexArg) != &mutexTag) + xlFmtError("condition-wait: second argument is not a mutex"); + + c = (xlCondHandle *)xlGetFPtr(condArg); + m = (xlMutexHandle *)xlGetFPtr(mutexArg); + + if (c == NULL || c->destroyed) + xlFmtError("condition-wait: condition has been destroyed"); + if (m == NULL || m->destroyed) + xlFmtError("condition-wait: mutex has been destroyed"); + +#ifdef _WIN32 + SleepConditionVariableCS(&c->cond, &m->cs, INFINITE); +#else + pthread_cond_wait(&c->cond, &m->mutex); +#endif + return xlTrue; +#else + xlGetArgForeignPtr(); + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("condition-wait: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xcondsignal - (condition-signal cond) => #t */ +xlValue xcondsignal(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue arg; + xlCondHandle *c; + + arg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(arg) != &condTag) + xlFmtError("condition-signal: not a condition variable"); + c = (xlCondHandle *)xlGetFPtr(arg); + if (c == NULL || c->destroyed) + xlFmtError("condition-signal: condition has been destroyed"); + +#ifdef _WIN32 + WakeConditionVariable(&c->cond); +#else + pthread_cond_signal(&c->cond); +#endif + return xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("condition-signal: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xcondbroadcast - (condition-broadcast cond) => #t */ +xlValue xcondbroadcast(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue arg; + xlCondHandle *c; + + arg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(arg) != &condTag) + xlFmtError("condition-broadcast: not a condition variable"); + c = (xlCondHandle *)xlGetFPtr(arg); + if (c == NULL || c->destroyed) + xlFmtError("condition-broadcast: condition has been destroyed"); + +#ifdef _WIN32 + WakeAllConditionVariable(&c->cond); +#else + pthread_cond_broadcast(&c->cond); +#endif + return xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("condition-broadcast: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xconddestroy - (condition-destroy cond) => #t */ +xlValue xconddestroy(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue arg; + xlCondHandle *c; + + arg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(arg) != &condTag) + xlFmtError("condition-destroy: not a condition variable"); + c = (xlCondHandle *)xlGetFPtr(arg); + if (c == NULL || c->destroyed) + xlFmtError("condition-destroy: already destroyed"); + + c->destroyed = 1; + + if (registryRelease(c, &condTag) <= 0) + freeCond(c); + + xlSetFPtr(arg, NULL); + return xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("condition-destroy: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xcondlookup - (condition-lookup name) => condition handle or #f */ +xlValue xcondlookup(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue nameArg; + const char *name; + xlCondHandle *c; + + nameArg = xlGetArgString(); + xlLastArg(); + name = xlGetString(nameArg); + + c = (xlCondHandle *)registryLookup(name, &condTag); + if (c == NULL || c->destroyed) + return xlFalse; + + return xlMakeForeignPtr(&condTag, c); +#else + xlGetArgString(); + xlLastArg(); + xlFmtError("condition-lookup: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xcondp - (condition? obj) => #t / #f */ +xlValue xcondp(void) +{ + xlValue arg; + arg = xlGetArg(); + xlLastArg(); + if (xlForeignPtrP(arg) && xlGetFPType(arg) == &condTag && xlGetFPtr(arg) != NULL) + return xlTrue; + return xlFalse; +} diff --git a/tests/test_sync.lsp b/tests/test_sync.lsp new file mode 100644 index 0000000..1ad0112 --- /dev/null +++ b/tests/test_sync.lsp @@ -0,0 +1,174 @@ +;; Comprehensive synchronization tests +;; NOTE: thread-create only evaluates the FIRST expression. +;; Use (begin ...) to wrap multiple expressions. + +(define pass-count 0) +(define fail-count 0) + +(define (check name result) + (if result + (begin (set! pass-count (+ pass-count 1)) + (display " PASS: ") (display name) (newline)) + (begin (set! fail-count (+ fail-count 1)) + (display " FAIL: ") (display name) (newline)))) + +;; ============================================================ +(display "=== 1. Mutex Basic Operations ===") (newline) +;; ============================================================ + +(define m (mutex-create)) +(check "mutex-create returns mutex" (mutex? m)) +(check "mutex? on integer" (not (mutex? 42))) +(check "mutex? on string" (not (mutex? "hello"))) +(check "mutex? on nil" (not (mutex? '()))) +(check "mutex-lock" (mutex-lock m)) +(check "mutex-unlock" (mutex-unlock m)) +(check "mutex-destroy" (mutex-destroy m)) +(check "mutex? after destroy" (not (mutex? m))) + +;; ============================================================ +(display "=== 2. Named Mutex and Lookup ===") (newline) +;; ============================================================ + +(define m1 (mutex-create "alpha")) +(check "named mutex created" (mutex? m1)) +(define m2 (mutex-lookup "alpha")) +(check "mutex-lookup found" (mutex? m2)) +(check "lookup non-existent" (not (mutex-lookup "no-such"))) +(mutex-destroy m1) + +;; ============================================================ +(display "=== 3. Condition Variable Basic Operations ===") (newline) +;; ============================================================ + +(define cv (condition-create)) +(check "condition-create" (condition? cv)) +(check "condition? on integer" (not (condition? 42))) +(check "condition? on mutex" (not (condition? (mutex-create)))) +(check "condition-destroy" (condition-destroy cv)) +(check "condition? after destroy" (not (condition? cv))) + +;; ============================================================ +(display "=== 4. Named Condition Variable and Lookup ===") (newline) +;; ============================================================ + +(define cv1 (condition-create "beta")) +(check "named condition created" (condition? cv1)) +(define cv2 (condition-lookup "beta")) +(check "condition-lookup found" (condition? cv2)) +(check "lookup non-existent" (not (condition-lookup "no-such"))) +(condition-destroy cv1) + +;; ============================================================ +(display "=== 5. Type Discrimination ===") (newline) +;; ============================================================ + +(define tm (mutex-create)) +(define tc (condition-create)) +(check "mutex is not condition" (not (condition? tm))) +(check "condition is not mutex" (not (mutex? tc))) +(mutex-destroy tm) +(condition-destroy tc) + +;; ============================================================ +(display "=== 6. Cross-Thread Mutex ===") (newline) +;; ============================================================ + +(define m3 (mutex-create "cross-mutex")) +(define h1 (thread-create + "(begin (define m (mutex-lookup \"cross-mutex\")) (mutex-lock m) (mutex-unlock m))" #f)) +(thread-join h1) +(check "child thread used mutex" #t) +(mutex-destroy m3) + +;; ============================================================ +(display "=== 7. Cross-Thread Condition Signal ===") (newline) +;; ============================================================ + +(define m4 (mutex-create "sig-mutex")) +(define cv3 (condition-create "sig-cond")) + +;; Lock before spawning so child blocks until main is in condition-wait +(mutex-lock m4) + +(define h2 (thread-create + "(begin (define m (mutex-lookup \"sig-mutex\")) (define c (condition-lookup \"sig-cond\")) (mutex-lock m) (condition-signal c) (mutex-unlock m))" #f)) + +(condition-wait cv3 m4) +(mutex-unlock m4) +(thread-join h2) +(check "condition signal/wait across threads" #t) +(mutex-destroy m4) +(condition-destroy cv3) + +;; ============================================================ +(display "=== 8. Cross-Thread Condition Broadcast ===") (newline) +;; ============================================================ + +;; Each child signals a "ready" condvar before entering broadcast wait, +;; so main knows all children are waiting before it broadcasts. + +(define bm (mutex-create "bm")) +(define bc (condition-create "bc")) +(define r1 (condition-create "r1")) +(define r2 (condition-create "r2")) +(define r3 (condition-create "r3")) + +(mutex-lock bm) + +(define h3 (thread-create + "(begin (define m (mutex-lookup \"bm\")) (define bc (condition-lookup \"bc\")) (define r (condition-lookup \"r1\")) (mutex-lock m) (condition-signal r) (condition-wait bc m) (mutex-unlock m))" #f)) +(condition-wait r1 bm) + +(define h4 (thread-create + "(begin (define m (mutex-lookup \"bm\")) (define bc (condition-lookup \"bc\")) (define r (condition-lookup \"r2\")) (mutex-lock m) (condition-signal r) (condition-wait bc m) (mutex-unlock m))" #f)) +(condition-wait r2 bm) + +(define h5 (thread-create + "(begin (define m (mutex-lookup \"bm\")) (define bc (condition-lookup \"bc\")) (define r (condition-lookup \"r3\")) (mutex-lock m) (condition-signal r) (condition-wait bc m) (mutex-unlock m))" #f)) +(condition-wait r3 bm) + +(condition-broadcast bc) +(mutex-unlock bm) + +(thread-join h3) +(thread-join h4) +(thread-join h5) +(check "broadcast woke 3 threads" #t) +(mutex-destroy bm) +(condition-destroy bc) +(condition-destroy r1) +(condition-destroy r2) +(condition-destroy r3) + +;; ============================================================ +(display "=== 9. Multiple Contending Mutex Threads ===") (newline) +;; ============================================================ + +(define m6 (mutex-create "contend")) + +(define h6 (thread-create + "(begin (define m (mutex-lookup \"contend\")) (define (w n) (if (> n 0) (w (- n 1)) #t)) (mutex-lock m) (w 5000) (mutex-unlock m))" #f)) +(define h7 (thread-create + "(begin (define m (mutex-lookup \"contend\")) (define (w n) (if (> n 0) (w (- n 1)) #t)) (mutex-lock m) (w 5000) (mutex-unlock m))" #f)) +(define h8 (thread-create + "(begin (define m (mutex-lookup \"contend\")) (define (w n) (if (> n 0) (w (- n 1)) #t)) (mutex-lock m) (w 5000) (mutex-unlock m))" #f)) +(define h9 (thread-create + "(begin (define m (mutex-lookup \"contend\")) (define (w n) (if (> n 0) (w (- n 1)) #t)) (mutex-lock m) (w 5000) (mutex-unlock m))" #f)) + +(thread-join h6) +(thread-join h7) +(thread-join h8) +(thread-join h9) +(check "4 contending threads completed" #t) +(mutex-destroy m6) + +;; ============================================================ +;; Summary +;; ============================================================ +(newline) +(display "=== Results: ") +(display pass-count) (display " passed, ") +(display fail-count) (display " failed ===") (newline) + +(exit) From e5e46885624c18d41ceb8a5a6b87ebebde02b223 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Wed, 25 Mar 2026 20:34:48 -0500 Subject: [PATCH 3/9] Added message channels --- README.md | 2 +- doc/CODEBASE_ANALYSIS.md | 12 +- doc/ThreadEnhancementPlan.md | 228 ++----------------- doc/Threads.md | 93 +++++++- doc/xlisp.md | 170 +++++++++++++- include/xlisp.h | 8 + src/xlftab.c | 8 + src/xlsync.c | 422 ++++++++++++++++++++++++++++++++++- tests/test_channel.lsp | 293 ++++++++++++++++++++++++ 9 files changed, 1006 insertions(+), 230 deletions(-) create mode 100644 tests/test_channel.lsp diff --git a/README.md b/README.md index 9efb592..26a9edb 100644 --- a/README.md +++ b/README.md @@ -23,7 +23,7 @@ It has some really nice features as follows: A. When used as an extension language, it is now reentrant and can handle multiple simultaneous threads. B. Native thread creation and joining from Lisp (`thread-create`, `thread-join`, `thread?`). -C. Synchronization primitives: mutexes and condition variables with cross-thread sharing via named registries. +C. Synchronization primitives: mutexes, condition variables, and message channels with cross-thread sharing via named registries. D. Updated version to 10.0.0. ## Building diff --git a/doc/CODEBASE_ANALYSIS.md b/doc/CODEBASE_ANALYSIS.md index 3f70b52..c6e9cdb 100644 --- a/doc/CODEBASE_ANALYSIS.md +++ b/doc/CODEBASE_ANALYSIS.md @@ -38,7 +38,7 @@ xlisp/ | `xldbg.c` | Debugging support | | `xlcontext.c` | Per-thread interpreter context management | | `xlnthread.c` | Native thread creation/join | -| `xlsync.c` | Synchronization primitives (mutexes, condition variables) | +| `xlsync.c` | Synchronization primitives (mutexes, condition variables, channels) | | `msstuff.c` | Windows-specific code | | `unstuff.c` | Unix-specific code | @@ -103,8 +103,8 @@ When built with `THREADS=1`: accesses through the context pointer (e.g., `#define xlVal (xlCtx()->val)`) - Each thread gets independent stacks, heap, GC, symbols, and packages - The bytecode dispatch table (`optab`) is shared and immutable -- Synchronization objects (mutexes, condition variables) are shared at the - C level via a named registry with reference counting +- Synchronization objects (mutexes, condition variables, and message channels) + are shared at the C level via a named registry with reference counting ## Notable Features @@ -113,8 +113,8 @@ When built with `THREADS=1`: - **Class-based OOP** with inheritance and method dispatch - **Scheme influences** - lexical scoping, proper tail recursion - **Common Lisp elements** - packages, keywords, multiple values -- **Native threading** - per-thread interpreter contexts with mutexes and - condition variables for synchronization +- **Native threading** - per-thread interpreter contexts with mutexes, + condition variables, and message channels for synchronization - **Cross-platform** (Windows, Linux, macOS) via ANSI C - **Extensible** via C API and extension modules - **FASL support** - fast loading of pre-compiled bytecode @@ -146,7 +146,7 @@ make THREADS=1 ``` Defines `XLISP_USE_CONTEXT` and links with `-lpthread` (on Unix). -Enables `thread-create`, `thread-join`, mutexes, and condition variables. +Enables `thread-create`, `thread-join`, mutexes, condition variables, and channels. ### Legacy Support diff --git a/doc/ThreadEnhancementPlan.md b/doc/ThreadEnhancementPlan.md index d3eb17f..314e1d9 100644 --- a/doc/ThreadEnhancementPlan.md +++ b/doc/ThreadEnhancementPlan.md @@ -1,219 +1,27 @@ -# Thread Enhancement Plan: Message Channels +# Thread Enhancement Plan -## Status +## Status: Complete -Threads, mutexes, and condition variables are implemented and tested. -This document covers the remaining planned enhancement: message channels -for inter-thread communication. +All planned threading features have been implemented and tested: -## Motivation +- **Threads** (`thread-create`, `thread-join`, `thread?`) -- `src/xlnthread.c` +- **Mutexes** (`mutex-create`, `mutex-lock`, `mutex-unlock`, `mutex-destroy`, `mutex-lookup`, `mutex?`) -- `src/xlsync.c` +- **Condition variables** (`condition-create`, `condition-wait`, `condition-signal`, `condition-broadcast`, `condition-destroy`, `condition-lookup`, `condition?`) -- `src/xlsync.c` +- **Channels** (`channel-create`, `channel-send`, `channel-receive`, `channel-close`, `channel-destroy`, `channel-lookup`, `channel-open?`, `channel?`) -- `src/xlsync.c` -Since threads have independent Lisp heaps, they cannot share Lisp objects -directly. Mutexes and condition variables provide synchronization but not -data exchange. Channels provide a thread-safe queue for passing -string-serialized data between threads. +Total: 24 threading/synchronization functions. -## Channel API +All primitives share a common named-registry pattern for cross-thread +access, use `xlCClass` type tags for foreign pointer discrimination, and +support both POSIX and Windows platforms. -| Function | Signature | Returns | -|---|---|---| -| `CHANNEL-CREATE` | `(channel-create [name] [capacity])` | channel handle | -| `CHANNEL-SEND` | `(channel-send channel string)` | `#t` | -| `CHANNEL-RECEIVE` | `(channel-receive channel)` | string, or `#f` on closed empty channel | -| `CHANNEL-CLOSE` | `(channel-close channel)` | `#t` | -| `CHANNEL-DESTROY` | `(channel-destroy channel)` | `#t` | -| `CHANNEL-LOOKUP` | `(channel-lookup name)` | channel handle or `#f` | -| `CHANNEL-OPEN?` | `(channel-open? channel)` | `#t` / `#f` | -| `CHANNEL?` | `(channel? obj)` | `#t` / `#f` | +## Test Results -Total: 8 new built-in functions. +- `tests/test_sync.lsp` -- 25 tests (mutexes, condvars, cross-thread) +- `tests/test_channel.lsp` -- 38 tests (channels, bounded, multi-producer, blocking) +- Stress tested: 0 errors in 100 iterations (50 sync + 50 channel) -### Semantics +## Documentation -- **`channel-create`**: Creates a channel. An optional *name* registers - it globally for cross-thread lookup. An optional *capacity* (integer) - limits the queue size; 0 or omitted means unbounded. - -- **`channel-send`**: Enqueues a string. Blocks if the channel is - bounded and full. Signals an error if the channel is closed. - -- **`channel-receive`**: Dequeues a string. Blocks if the channel is - empty and still open. Returns `#f` if the channel is closed and empty - (no more data will arrive). - -- **`channel-close`**: Marks the channel as closed. Pending messages can - still be received. Wakes all blocked receivers so they can see the - closed state. - -- **`channel-destroy`**: Frees the underlying resources. Decrements the - reference count; actual cleanup occurs when all references are released. - -- **`channel-lookup`**: Finds a named channel in the global registry. - Returns `#f` if not found. - -## C Data Structure - -```c -typedef struct xlChannelNode { - char *data; /* C string (malloc'd copy) */ - struct xlChannelNode *next; -} xlChannelNode; - -typedef struct xlChannelHandle { -#ifdef _WIN32 - CRITICAL_SECTION lock; - CONDITION_VARIABLE notEmpty; - CONDITION_VARIABLE notFull; -#else - pthread_mutex_t lock; - pthread_cond_t notEmpty; - pthread_cond_t notFull; -#endif - xlChannelNode *head; /* dequeue from head */ - xlChannelNode *tail; /* enqueue at tail */ - int count; /* current messages in queue */ - int capacity; /* max messages (0 = unbounded) */ - int closed; /* non-zero after channel-close */ - int destroyed; -} xlChannelHandle; -``` - -Tagged with a static `xlCClass channelTag` sentinel for type -discrimination via `channel?`, consistent with the existing mutex and -condition variable tagging. - -## Cross-Thread Sharing - -Channels use the same named-registry pattern already implemented for -mutexes and condition variables: - -1. Creating thread calls `(channel-create "name")` — allocates the OS - objects, registers globally by name. -2. Child thread calls `(channel-lookup "name")` — finds the C struct in - the registry, wraps it in a new foreign pointer in the child's heap. -3. Both threads' foreign pointers point to the **same** underlying - `xlChannelHandle`. -4. Reference counting prevents use-after-free. - -## Usage Examples - -### Simple Producer/Consumer - -```lisp -(define ch (channel-create "work-queue")) - -;; Producer thread -(define h (thread-create - "(begin - (define ch (channel-lookup \"work-queue\")) - (channel-send ch \"hello from thread\") - (channel-send ch \"another message\") - (channel-close ch))" - #f)) - -;; Consumer (main thread) -(display (channel-receive ch)) ; => "hello from thread" -(display (channel-receive ch)) ; => "another message" -(display (channel-receive ch)) ; => #f (closed, empty) - -(thread-join h) -(channel-destroy ch) -``` - -### Bounded Channel (Backpressure) - -```lisp -(define ch (channel-create "bounded" 10)) ; max 10 pending messages - -;; Fast producer blocks when queue is full -(define h (thread-create - "(begin - (define ch (channel-lookup \"bounded\")) - (define (produce n) - (if (<= n 100) - (begin - (channel-send ch (number->string n)) - (produce (+ n 1))))) - (produce 1) - (channel-close ch))" - #f)) - -;; Slow consumer -(define (consume) - (let ((msg (channel-receive ch))) - (if msg - (begin (display msg) (newline) (consume))))) -(consume) - -(thread-join h) -(channel-destroy ch) -``` - -### Multiple Producers - -```lisp -(define ch (channel-create "results")) - -(define h1 (thread-create - "(begin - (define ch (channel-lookup \"results\")) - (channel-send ch \"result-from-1\"))" #f)) - -(define h2 (thread-create - "(begin - (define ch (channel-lookup \"results\")) - (channel-send ch \"result-from-2\"))" #f)) - -(display (channel-receive ch)) (newline) -(display (channel-receive ch)) (newline) - -(thread-join h1) -(thread-join h2) -(channel-destroy ch) -``` - -## File Changes - -All changes are in existing files — no new source files needed. - -| File | Change | -|------|--------| -| `src/xlsync.c` | Add channel implementation (8 functions) | -| `include/xlisp.h` | Add 8 function declarations | -| `src/xlftab.c` | Add 8 entries to `subrtab` | -| `doc/xlisp.md` | Add channel documentation section | -| `doc/Threads.md` | Update with channel information | - -## Implementation Notes - -- Channels are implemented entirely in `src/xlsync.c`, extending the - existing synchronization module. -- The named registry, reference counting, and type-tagging infrastructure - already exists and will be reused. -- The `notEmpty` / `notFull` condition variables are internal to the - channel (not exposed to Lisp). They implement blocking send/receive - without requiring the user to manage separate mutexes and condvars. -- All send/receive operations copy data as C strings (`malloc`/`free`), - since the sender's and receiver's Lisp heaps are independent. - -## Error Handling - -Follows existing XLISP conventions: - -- Wrong argument type: `xlBadType(arg)` -- Wrong argument count: `xlLastArg()` / `xlGetArg*()` macros -- Operational errors: `xlFmtError("channel-xxx: description")` -- Non-reentrant build: `xlFmtError("channel-xxx: requires reentrant build (THREADS=1)")` -- Use after destroy: `xlFmtError("channel-xxx: channel has been destroyed")` -- Send to closed channel: `xlFmtError("channel-send: channel is closed")` - -## Testing Plan - -- Single-producer, single-consumer -- Multiple producers, single consumer -- Single producer, multiple consumers -- Bounded channel with backpressure -- Close while receivers are blocked (should unblock and return `#f`) -- Close while senders are blocked on full bounded channel (should error) -- Destroy while other threads hold references (refcount prevents crash) -- 50+ iteration stress runs +- `doc/Threads.md` -- Complete threading reference +- `doc/xlisp.md` sections 49-51 -- Lisp-level API reference diff --git a/doc/Threads.md b/doc/Threads.md index 0cdd86d..3985e1f 100644 --- a/doc/Threads.md +++ b/doc/Threads.md @@ -7,9 +7,9 @@ contexts. Each thread gets a completely independent interpreter instance with its own stacks, heap, symbol tables, garbage collector, and VM registers. Lisp data cannot be shared between threads directly. -Threads coordinate through synchronization primitives (mutexes and -condition variables) that are shared at the C level via a named registry. -Data is exchanged between threads as strings. +Threads coordinate through synchronization primitives (mutexes, +condition variables, and message channels) that are shared at the C level +via a named registry. Data is exchanged between threads as strings. Threading requires a reentrant build (`make THREADS=1`). @@ -241,19 +241,93 @@ Broadcast with ready-signaling: (thread-join h2) ``` +### Channels + +Channels are thread-safe message queues for exchanging string data +between threads. They have internal locking and condition variables, +so no separate mutex management is needed. + +```lisp +(CHANNEL-CREATE [name] [capacity]) ; create a channel +(CHANNEL-SEND channel string) ; enqueue (blocks if bounded and full) +(CHANNEL-RECEIVE channel) ; dequeue (blocks if empty); #f when closed+empty +(CHANNEL-CLOSE channel) ; mark closed; pending messages still receivable +(CHANNEL-DESTROY channel) ; free resources (ref-counted) +(CHANNEL-LOOKUP name) ; look up a named channel => handle or #f +(CHANNEL-OPEN? channel) ; #t if not yet closed +(CHANNEL? obj) ; type predicate +``` + +The optional *capacity* argument limits the queue size. When full, a +bounded channel blocks the sender until the receiver drains a message. +If omitted or 0, the channel is unbounded. + +Producer/consumer example: + +```lisp +(define ch (channel-create "work")) + +;; Producer thread +(define h (thread-create + "(begin + (define ch (channel-lookup \"work\")) + (channel-send ch \"hello\") + (channel-send ch \"world\") + (channel-close ch))" + #f)) + +;; Consumer (main thread) +(define (consume) + (let ((msg (channel-receive ch))) + (if msg + (begin (display msg) (newline) (consume))))) +(consume) ; prints "hello" then "world" + +(thread-join h) +(channel-destroy ch) +``` + +Bounded channel with backpressure: + +```lisp +(define ch (channel-create "bounded" 2)) + +(define h (thread-create + "(begin + (define ch (channel-lookup \"bounded\")) + (channel-send ch \"a\") + (channel-send ch \"b\") + (channel-send ch \"c\") + (channel-send ch \"d\") + (channel-close ch))" + #f)) + +;; Consumer drains messages; producer blocks when queue is full +(define (consume) + (let ((msg (channel-receive ch))) + (if msg (begin (display msg) (newline) (consume))))) +(consume) + +(thread-join h) +(channel-destroy ch) +``` + ### Type Discrimination -Mutexes, condition variables, and thread handles are all foreign pointers -but are tagged with distinct `xlCClass` type markers. The predicates -`mutex?`, `condition?`, and `thread?` correctly distinguish between them: +Mutexes, condition variables, channels, and thread handles are all +foreign pointers but are tagged with distinct `xlCClass` type markers. +The predicates `mutex?`, `condition?`, `channel?`, and `thread?` +correctly distinguish between them: ```lisp (define m (mutex-create)) (define cv (condition-create)) +(define ch (channel-create)) (mutex? m) ; => #t (mutex? cv) ; => #f (condition? cv) ; => #t -(condition? m) ; => #f +(channel? ch) ; => #t +(channel? m) ; => #f ``` ## C-Level API @@ -351,7 +425,7 @@ xlDestroyContext(ctx2); | `include/xlthread.h` | Thread-safe API declarations | | `src/xlcontext.c` | Context creation, destruction, initialization | | `src/xlnthread.c` | `thread-create`, `thread-join`, `thread?` | -| `src/xlsync.c` | Mutexes, condition variables, named registry | +| `src/xlsync.c` | Mutexes, condition variables, channels, named registry | ## Limitations @@ -359,7 +433,7 @@ xlDestroyContext(ctx2); Each context has its own heap; pointers are not valid across contexts. 2. **String-only communication.** Data crosses thread boundaries as C - strings (used by `thread-create` and the named registry). + strings (used by `thread-create`, the named registry, and channels). 3. **Memory overhead.** Each context has a full interpreter instance. Memory scales linearly with context count. @@ -386,3 +460,4 @@ xlDestroyContext(ctx2); | Thread creation | `pthread_create` | `_beginthreadex` | | Mutex | `pthread_mutex_t` | `CRITICAL_SECTION` | | Condition variable | `pthread_cond_t` | `CONDITION_VARIABLE` (Vista+) | +| Channel (internal) | `pthread_mutex_t` + `pthread_cond_t` | `CRITICAL_SECTION` + `CONDITION_VARIABLE` | diff --git a/doc/xlisp.md b/doc/xlisp.md index d6e4088..5fd8e5d 100644 --- a/doc/xlisp.md +++ b/doc/xlisp.md @@ -2455,7 +2455,7 @@ otherwise. # 50. Synchronization Primitives These functions provide mutexes and condition variables for coordinating -between threads. They require a reentrant build (`make THREADS=1`). +between threads. They require a threaded build (`make THREADS=1`). Since each thread has an independent Lisp heap, synchronization objects are shared across threads through a **named registry**. The creating @@ -2669,3 +2669,171 @@ variable before entering the broadcast wait: (thread-join h1) (thread-join h2) ``` + +# 51. Message Channels + +Channels are thread-safe message queues for exchanging string data +between threads. They require a threaded build (`make THREADS=1`). + +Channels have their own internal locking, so no separate mutex is needed +to send or receive. They use the same **named registry** as mutexes +and condition variables for cross-thread sharing. + +## CHANNEL-CREATE + +```lisp +(CHANNEL-CREATE [name] [capacity]) +``` + +Creates a new channel. If *name* (a string) is provided, the channel +is registered globally for cross-thread lookup. If *capacity* (an +integer) is provided, the channel is bounded: `CHANNEL-SEND` will block +when the queue is full. If omitted or 0, the channel is unbounded. + +The arguments can be given in either order: +- `(channel-create)` -- anonymous, unbounded +- `(channel-create "name")` -- named, unbounded +- `(channel-create 10)` -- anonymous, capacity 10 +- `(channel-create "name" 10)` -- named, capacity 10 + +## CHANNEL-SEND + +```lisp +(CHANNEL-SEND channel string) +``` + +Enqueues *string* onto the channel. If the channel is bounded and full, +blocks until space is available. Signals an error if the channel has +been closed. Returns `#t`. + +## CHANNEL-RECEIVE + +```lisp +(CHANNEL-RECEIVE channel) +``` + +Dequeues and returns the next string from the channel. If the channel +is empty and still open, blocks until a message arrives. Returns `#f` +if the channel is closed and empty (no more data will arrive). + +## CHANNEL-CLOSE + +```lisp +(CHANNEL-CLOSE channel) +``` + +Marks the channel as closed. No further sends are allowed, but pending +messages can still be received. Wakes all blocked senders and receivers. +Returns `#t`. + +## CHANNEL-DESTROY + +```lisp +(CHANNEL-DESTROY channel) +``` + +Destroys the channel and frees its resources. Reference-counted: the +actual OS resources are freed when the last reference is released. +Returns `#t`. + +## CHANNEL-LOOKUP + +```lisp +(CHANNEL-LOOKUP name) +``` + +Looks up a named channel in the global registry. Returns a channel +handle, or `#f` if not found. + +## CHANNEL-OPEN? + +```lisp +(CHANNEL-OPEN? channel) +``` + +Returns `#t` if the channel has not been closed, `#f` otherwise. + +## CHANNEL? + +```lisp +(CHANNEL? obj) +``` + +Returns `#t` if *obj* is a live (not yet destroyed) channel handle. + +## Channel Examples + +### Producer/Consumer + +```lisp +(define ch (channel-create "work")) + +;; Producer thread +(define h (thread-create + "(begin + (define ch (channel-lookup \"work\")) + (channel-send ch \"hello\") + (channel-send ch \"world\") + (channel-close ch))" + #f)) + +;; Consumer (main thread) +(define (consume) + (let ((msg (channel-receive ch))) + (if msg + (begin (display msg) (newline) (consume))))) +(consume) ; prints "hello" then "world" + +(thread-join h) +(channel-destroy ch) +``` + +### Bounded Channel (Backpressure) + +```lisp +(define ch (channel-create "bounded" 2)) + +;; Fast producer sends 5 messages; blocks when queue is full +(define h (thread-create + "(begin + (define ch (channel-lookup \"bounded\")) + (channel-send ch \"a\") + (channel-send ch \"b\") + (channel-send ch \"c\") + (channel-send ch \"d\") + (channel-send ch \"e\") + (channel-close ch))" + #f)) + +;; Consumer drains +(define (consume) + (let ((msg (channel-receive ch))) + (if msg (begin (display msg) (newline) (consume))))) +(consume) + +(thread-join h) +(channel-destroy ch) +``` + +### Multiple Producers + +```lisp +(define ch (channel-create "results")) + +(define h1 (thread-create + "(begin + (define ch (channel-lookup \"results\")) + (channel-send ch \"from-A\"))" #f)) + +(define h2 (thread-create + "(begin + (define ch (channel-lookup \"results\")) + (channel-send ch \"from-B\"))" #f)) + +(display (channel-receive ch)) (newline) +(display (channel-receive ch)) (newline) + +(thread-join h1) +(thread-join h2) +(channel-destroy ch) +``` diff --git a/include/xlisp.h b/include/xlisp.h index 0025148..5a798f1 100755 --- a/include/xlisp.h +++ b/include/xlisp.h @@ -1242,6 +1242,14 @@ xlValue xcondbroadcast(void); xlValue xconddestroy(void); xlValue xcondlookup(void); xlValue xcondp(void); +xlValue xchannelcreate(void); +xlValue xchannelsend(void); +xlValue xchannelreceive(void); +xlValue xchannelclose(void); +xlValue xchanneldestroy(void); +xlValue xchannellookup(void); +xlValue xchannelopenp(void); +xlValue xchannelp(void); /* xlcobj.c */ xlEXPORT xlCClass *xlMakeCClass(xlCClassDef *def,xlValue super); diff --git a/src/xlftab.c b/src/xlftab.c index 7f8f5ef..3c1b8f7 100755 --- a/src/xlftab.c +++ b/src/xlftab.c @@ -417,6 +417,14 @@ static xlSubrDef subrtab[] = { { "CONDITION-DESTROY", xconddestroy }, { "CONDITION-LOOKUP", xcondlookup }, { "CONDITION?", xcondp }, +{ "CHANNEL-CREATE", xchannelcreate }, +{ "CHANNEL-SEND", xchannelsend }, +{ "CHANNEL-RECEIVE", xchannelreceive }, +{ "CHANNEL-CLOSE", xchannelclose }, +{ "CHANNEL-DESTROY", xchanneldestroy }, +{ "CHANNEL-LOOKUP", xchannellookup }, +{ "CHANNEL-OPEN?", xchannelopenp }, +{ "CHANNEL?", xchannelp }, {0,0} /* end of table marker */ }; diff --git a/src/xlsync.c b/src/xlsync.c index 31ccbb4..34f5aa6 100644 --- a/src/xlsync.c +++ b/src/xlsync.c @@ -24,8 +24,9 @@ * matter -- no fields are used. This lets mutex?, condition?, channel? * distinguish their handles from other foreign pointers. */ -static xlCClass mutexTag = { NULL, NULL, NULL }; -static xlCClass condTag = { NULL, NULL, NULL }; +static xlCClass mutexTag = { NULL, NULL, NULL }; +static xlCClass condTag = { NULL, NULL, NULL }; +static xlCClass channelTag = { NULL, NULL, NULL }; /* ==================================================================== * Named-object registry @@ -40,7 +41,7 @@ static xlCClass condTag = { NULL, NULL, NULL }; typedef struct xlSyncEntry { char *name; /* registry name (malloc'd) */ void *obj; /* pointer to the handle struct */ - xlCClass *tag; /* &mutexTag or &condTag */ + xlCClass *tag; /* &mutexTag, &condTag, or &channelTag */ int refCount; /* number of live references */ struct xlSyncEntry *next; } xlSyncEntry; @@ -595,3 +596,418 @@ xlValue xcondp(void) return xlTrue; return xlFalse; } + + +/* ==================================================================== + * Channel implementation + * + * A channel is a thread-safe message queue that carries C strings. + * It has its own internal lock and condition variables for blocking + * send (when bounded and full) and blocking receive (when empty). + * ==================================================================== */ + +#ifdef XLISP_USE_CONTEXT + +typedef struct xlChannelNode { + char *data; /* C string (malloc'd copy) */ + struct xlChannelNode *next; +} xlChannelNode; + +typedef struct xlChannelHandle { +#ifdef _WIN32 + CRITICAL_SECTION lock; + CONDITION_VARIABLE notEmpty; + CONDITION_VARIABLE notFull; +#else + pthread_mutex_t lock; + pthread_cond_t notEmpty; + pthread_cond_t notFull; +#endif + xlChannelNode *head; /* dequeue from head */ + xlChannelNode *tail; /* enqueue at tail */ + int count; /* current messages in queue */ + int capacity; /* max messages (0 = unbounded) */ + int closed; /* non-zero after channel-close */ + int destroyed; +} xlChannelHandle; + +static xlChannelHandle *allocChannel(int capacity) +{ + xlChannelHandle *ch = (xlChannelHandle *)malloc(sizeof(xlChannelHandle)); + if (ch == NULL) return NULL; + memset(ch, 0, sizeof(xlChannelHandle)); +#ifdef _WIN32 + InitializeCriticalSection(&ch->lock); + InitializeConditionVariable(&ch->notEmpty); + InitializeConditionVariable(&ch->notFull); +#else + pthread_mutex_init(&ch->lock, NULL); + pthread_cond_init(&ch->notEmpty, NULL); + pthread_cond_init(&ch->notFull, NULL); +#endif + ch->head = NULL; + ch->tail = NULL; + ch->count = 0; + ch->capacity = capacity; + ch->closed = 0; + ch->destroyed = 0; + return ch; +} + +static void freeChannel(xlChannelHandle *ch) +{ + xlChannelNode *n, *next; + if (ch == NULL) return; + /* free any remaining messages */ + for (n = ch->head; n != NULL; n = next) { + next = n->next; + free(n->data); + free(n); + } +#ifdef _WIN32 + DeleteCriticalSection(&ch->lock); +#else + pthread_cond_destroy(&ch->notFull); + pthread_cond_destroy(&ch->notEmpty); + pthread_mutex_destroy(&ch->lock); +#endif + free(ch); +} + +#endif /* XLISP_USE_CONTEXT */ + + +/* xchannelcreate - (channel-create [name] [capacity]) => channel handle */ +xlValue xchannelcreate(void) +{ +#ifdef XLISP_USE_CONTEXT + const char *name = NULL; + int capacity = 0; + xlChannelHandle *ch; + xlValue handle; + + /* optional name argument */ + if (xlMoreArgsP()) { + xlValue arg = xlGetArg(); + if (xlStringP(arg)) { + name = xlGetString(arg); + /* optional capacity after name */ + if (xlMoreArgsP()) { + xlValue capArg = xlGetArgFixnum(); + capacity = (int)xlGetFixnum(capArg); + if (capacity < 0) capacity = 0; + } + } else if (xlFixnumP(arg)) { + /* (channel-create capacity) with no name */ + capacity = (int)xlGetFixnum(arg); + if (capacity < 0) capacity = 0; + } else { + xlBadType(arg); + } + } + xlLastArg(); + + ch = allocChannel(capacity); + if (ch == NULL) + xlFmtError("channel-create: out of memory"); + + handle = xlMakeForeignPtr(&channelTag, ch); + + if (name != NULL) { + if (!registryAdd(name, ch, &channelTag)) { + freeChannel(ch); + xlSetFPtr(handle, NULL); + xlFmtError("channel-create: name already in use"); + } + } + + return handle; +#else + if (xlMoreArgsP()) xlGetArg(); + if (xlMoreArgsP()) xlGetArg(); + xlLastArg(); + xlFmtError("channel-create: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xchannelsend - (channel-send channel string) => #t */ +xlValue xchannelsend(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue chArg, strArg; + xlChannelHandle *ch; + const char *str; + xlChannelNode *node; + + chArg = xlGetArgForeignPtr(); + strArg = xlGetArgString(); + xlLastArg(); + + if (xlGetFPType(chArg) != &channelTag) + xlFmtError("channel-send: not a channel"); + ch = (xlChannelHandle *)xlGetFPtr(chArg); + if (ch == NULL || ch->destroyed) + xlFmtError("channel-send: channel has been destroyed"); + + str = xlGetString(strArg); + + /* allocate the message node */ + node = (xlChannelNode *)malloc(sizeof(xlChannelNode)); + if (node == NULL) + xlFmtError("channel-send: out of memory"); + node->data = (char *)malloc(strlen(str) + 1); + if (node->data == NULL) { + free(node); + xlFmtError("channel-send: out of memory"); + } + strcpy(node->data, str); + node->next = NULL; + + /* enqueue with blocking if bounded and full */ +#ifdef _WIN32 + EnterCriticalSection(&ch->lock); + while (ch->capacity > 0 && ch->count >= ch->capacity && !ch->closed) + SleepConditionVariableCS(&ch->notFull, &ch->lock, INFINITE); + if (ch->closed) { + LeaveCriticalSection(&ch->lock); + free(node->data); + free(node); + xlFmtError("channel-send: channel is closed"); + } + if (ch->tail == NULL) { + ch->head = ch->tail = node; + } else { + ch->tail->next = node; + ch->tail = node; + } + ch->count++; + WakeConditionVariable(&ch->notEmpty); + LeaveCriticalSection(&ch->lock); +#else + pthread_mutex_lock(&ch->lock); + while (ch->capacity > 0 && ch->count >= ch->capacity && !ch->closed) + pthread_cond_wait(&ch->notFull, &ch->lock); + if (ch->closed) { + pthread_mutex_unlock(&ch->lock); + free(node->data); + free(node); + xlFmtError("channel-send: channel is closed"); + } + if (ch->tail == NULL) { + ch->head = ch->tail = node; + } else { + ch->tail->next = node; + ch->tail = node; + } + ch->count++; + pthread_cond_signal(&ch->notEmpty); + pthread_mutex_unlock(&ch->lock); +#endif + + return xlTrue; +#else + xlGetArgForeignPtr(); + xlGetArgString(); + xlLastArg(); + xlFmtError("channel-send: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xchannelreceive - (channel-receive channel) => string or #f */ +xlValue xchannelreceive(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue chArg; + xlChannelHandle *ch; + xlChannelNode *node; + char *data; + xlValue result; + + chArg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(chArg) != &channelTag) + xlFmtError("channel-receive: not a channel"); + ch = (xlChannelHandle *)xlGetFPtr(chArg); + if (ch == NULL || ch->destroyed) + xlFmtError("channel-receive: channel has been destroyed"); + + /* dequeue with blocking if empty */ +#ifdef _WIN32 + EnterCriticalSection(&ch->lock); + while (ch->head == NULL && !ch->closed) + SleepConditionVariableCS(&ch->notEmpty, &ch->lock, INFINITE); + if (ch->head == NULL) { + /* closed and empty */ + LeaveCriticalSection(&ch->lock); + return xlFalse; + } + node = ch->head; + ch->head = node->next; + if (ch->head == NULL) ch->tail = NULL; + ch->count--; + WakeConditionVariable(&ch->notFull); + LeaveCriticalSection(&ch->lock); +#else + pthread_mutex_lock(&ch->lock); + while (ch->head == NULL && !ch->closed) + pthread_cond_wait(&ch->notEmpty, &ch->lock); + if (ch->head == NULL) { + /* closed and empty */ + pthread_mutex_unlock(&ch->lock); + return xlFalse; + } + node = ch->head; + ch->head = node->next; + if (ch->head == NULL) ch->tail = NULL; + ch->count--; + pthread_cond_signal(&ch->notFull); + pthread_mutex_unlock(&ch->lock); +#endif + + /* convert C string to Lisp string */ + data = node->data; + result = xlMakeCString(data); + free(data); + free(node); + return result; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("channel-receive: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xchannelclose - (channel-close channel) => #t */ +xlValue xchannelclose(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue chArg; + xlChannelHandle *ch; + + chArg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(chArg) != &channelTag) + xlFmtError("channel-close: not a channel"); + ch = (xlChannelHandle *)xlGetFPtr(chArg); + if (ch == NULL || ch->destroyed) + xlFmtError("channel-close: channel has been destroyed"); + +#ifdef _WIN32 + EnterCriticalSection(&ch->lock); + ch->closed = 1; + WakeAllConditionVariable(&ch->notEmpty); + WakeAllConditionVariable(&ch->notFull); + LeaveCriticalSection(&ch->lock); +#else + pthread_mutex_lock(&ch->lock); + ch->closed = 1; + pthread_cond_broadcast(&ch->notEmpty); + pthread_cond_broadcast(&ch->notFull); + pthread_mutex_unlock(&ch->lock); +#endif + + return xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("channel-close: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xchanneldestroy - (channel-destroy channel) => #t */ +xlValue xchanneldestroy(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue chArg; + xlChannelHandle *ch; + + chArg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(chArg) != &channelTag) + xlFmtError("channel-destroy: not a channel"); + ch = (xlChannelHandle *)xlGetFPtr(chArg); + if (ch == NULL || ch->destroyed) + xlFmtError("channel-destroy: already destroyed"); + + ch->destroyed = 1; + + if (registryRelease(ch, &channelTag) <= 0) + freeChannel(ch); + + xlSetFPtr(chArg, NULL); + return xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("channel-destroy: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xchannellookup - (channel-lookup name) => channel handle or #f */ +xlValue xchannellookup(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue nameArg; + const char *name; + xlChannelHandle *ch; + + nameArg = xlGetArgString(); + xlLastArg(); + name = xlGetString(nameArg); + + ch = (xlChannelHandle *)registryLookup(name, &channelTag); + if (ch == NULL || ch->destroyed) + return xlFalse; + + return xlMakeForeignPtr(&channelTag, ch); +#else + xlGetArgString(); + xlLastArg(); + xlFmtError("channel-lookup: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xchannelopenp - (channel-open? channel) => #t / #f */ +xlValue xchannelopenp(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue chArg; + xlChannelHandle *ch; + + chArg = xlGetArgForeignPtr(); + xlLastArg(); + + if (xlGetFPType(chArg) != &channelTag) + xlFmtError("channel-open?: not a channel"); + ch = (xlChannelHandle *)xlGetFPtr(chArg); + if (ch == NULL || ch->destroyed) + return xlFalse; + + return ch->closed ? xlFalse : xlTrue; +#else + xlGetArgForeignPtr(); + xlLastArg(); + xlFmtError("channel-open?: requires threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xchannelp - (channel? obj) => #t / #f */ +xlValue xchannelp(void) +{ + xlValue arg; + arg = xlGetArg(); + xlLastArg(); + if (xlForeignPtrP(arg) && xlGetFPType(arg) == &channelTag && xlGetFPtr(arg) != NULL) + return xlTrue; + return xlFalse; +} diff --git a/tests/test_channel.lsp b/tests/test_channel.lsp new file mode 100644 index 0000000..96d3743 --- /dev/null +++ b/tests/test_channel.lsp @@ -0,0 +1,293 @@ +;; Comprehensive channel tests +;; Requires: make THREADS=1 + +(define pass-count 0) +(define fail-count 0) + +(define (check name result) + (if result + (begin (set! pass-count (+ pass-count 1)) + (display " PASS: ") (display name) (newline)) + (begin (set! fail-count (+ fail-count 1)) + (display " FAIL: ") (display name) (newline)))) + +;; ============================================================ +(display "=== 1. Channel Basic Operations ===") (newline) +;; ============================================================ + +(define ch (channel-create)) +(check "channel-create returns channel" (channel? ch)) +(check "channel? on integer" (not (channel? 42))) +(check "channel? on string" (not (channel? "hello"))) +(check "channel? on mutex" (not (channel? (mutex-create)))) +(check "channel-open? on new channel" (channel-open? ch)) + +;; Send and receive in same thread (unbounded channel) +(channel-send ch "hello") +(channel-send ch "world") +(check "receive first" (equal? "hello" (channel-receive ch))) +(check "receive second" (equal? "world" (channel-receive ch))) + +;; Close and receive #f +(channel-close ch) +(check "channel-open? after close" (not (channel-open? ch))) +(check "receive on closed empty channel" (not (channel-receive ch))) + +;; Destroy +(channel-destroy ch) +(check "channel? after destroy" (not (channel? ch))) + +;; ============================================================ +(display "=== 2. Named Channel and Lookup ===") (newline) +;; ============================================================ + +(define ch1 (channel-create "alpha")) +(check "named channel created" (channel? ch1)) +(define ch2 (channel-lookup "alpha")) +(check "channel-lookup found" (channel? ch2)) +(check "lookup non-existent" (not (channel-lookup "no-such"))) + +;; Both handles refer to the same channel +(channel-send ch1 "test") +(check "receive from looked-up handle" (equal? "test" (channel-receive ch2))) + +(channel-destroy ch1) + +;; ============================================================ +(display "=== 3. Channel with Capacity ===") (newline) +;; ============================================================ + +(define ch3 (channel-create 3)) +(check "bounded channel created" (channel? ch3)) +(channel-send ch3 "a") +(channel-send ch3 "b") +(channel-send ch3 "c") +;; channel is now full (capacity 3) +;; can still receive +(check "receive from full" (equal? "a" (channel-receive ch3))) +(check "receive second" (equal? "b" (channel-receive ch3))) +(check "receive third" (equal? "c" (channel-receive ch3))) +(channel-destroy ch3) + +;; Named + capacity +(define ch4 (channel-create "bounded" 5)) +(check "named bounded channel" (channel? ch4)) +(channel-destroy ch4) + +;; ============================================================ +(display "=== 4. Type Discrimination ===") (newline) +;; ============================================================ + +(define tm (mutex-create)) +(define tc (condition-create)) +(define tch (channel-create)) + +(check "channel is not mutex" (not (mutex? tch))) +(check "channel is not condition" (not (condition? tch))) +(check "mutex is not channel" (not (channel? tm))) +(check "condition is not channel" (not (channel? tc))) + +(mutex-destroy tm) +(condition-destroy tc) +(channel-destroy tch) + +;; ============================================================ +(display "=== 5. Cross-Thread: Single Producer, Single Consumer ===") (newline) +;; ============================================================ + +(define ch5 (channel-create "spsc")) + +;; Producer thread sends 5 messages then closes +(define h1 (thread-create + "(begin + (define ch (channel-lookup \"spsc\")) + (channel-send ch \"msg-1\") + (channel-send ch \"msg-2\") + (channel-send ch \"msg-3\") + (channel-send ch \"msg-4\") + (channel-send ch \"msg-5\") + (channel-close ch))" + #f)) + +;; Consumer (main thread) receives all messages +(define msgs '()) +(define (consume) + (let ((msg (channel-receive ch5))) + (if msg + (begin (set! msgs (append msgs (list msg))) + (consume))))) +(consume) + +(check "received 5 messages" (= 5 (length msgs))) +(check "first message" (equal? "msg-1" (car msgs))) +(check "last message" (equal? "msg-5" (list-ref msgs 4))) + +(thread-join h1) +(channel-destroy ch5) + +;; ============================================================ +(display "=== 6. Cross-Thread: Multiple Producers ===") (newline) +;; ============================================================ + +(define ch6 (channel-create "mpsc")) + +(define h2 (thread-create + "(begin + (define ch (channel-lookup \"mpsc\")) + (channel-send ch \"from-A\"))" #f)) + +(define h3 (thread-create + "(begin + (define ch (channel-lookup \"mpsc\")) + (channel-send ch \"from-B\"))" #f)) + +(define h4 (thread-create + "(begin + (define ch (channel-lookup \"mpsc\")) + (channel-send ch \"from-C\"))" #f)) + +;; Receive all 3 +(define m1 (channel-receive ch6)) +(define m2 (channel-receive ch6)) +(define m3 (channel-receive ch6)) + +(check "got 3 messages" (and (string? m1) (string? m2) (string? m3))) + +;; Verify all three sources are present (order may vary) +(define all-msgs (list m1 m2 m3)) +(check "from-A present" (member "from-A" all-msgs)) +(check "from-B present" (member "from-B" all-msgs)) +(check "from-C present" (member "from-C" all-msgs)) + +(thread-join h2) +(thread-join h3) +(thread-join h4) +(channel-destroy ch6) + +;; ============================================================ +(display "=== 7. Cross-Thread: Consumer Blocks Until Data ===") (newline) +;; ============================================================ + +;; Main thread will block on receive; child sends after a delay. +(define ch7 (channel-create "blocking")) +(define mtx (mutex-create "blk-m")) +(define ready-cv (condition-create "blk-r")) + +;; Lock before spawning so child blocks until main is ready +(mutex-lock mtx) + +(define h5 (thread-create + "(begin + (define ch (channel-lookup \"blocking\")) + (define m (mutex-lookup \"blk-m\")) + (define r (condition-lookup \"blk-r\")) + (mutex-lock m) + (condition-signal r) + (mutex-unlock m) + (channel-send ch \"delayed-msg\"))" + #f)) + +;; Wait for child to be running +(condition-wait ready-cv mtx) +(mutex-unlock mtx) + +;; Now receive (child may still be about to send) +(define result (channel-receive ch7)) +(check "blocking receive got message" (equal? "delayed-msg" result)) + +(thread-join h5) +(channel-destroy ch7) +(mutex-destroy mtx) +(condition-destroy ready-cv) + +;; ============================================================ +(display "=== 8. Close Unblocks Waiting Receivers ===") (newline) +;; ============================================================ + +(define ch8 (channel-create "close-test")) +(define mtx2 (mutex-create "cl-m")) +(define ready2 (condition-create "cl-r")) + +(mutex-lock mtx2) + +;; Child will close the channel after signaling ready +(define h6 (thread-create + "(begin + (define ch (channel-lookup \"close-test\")) + (define m (mutex-lookup \"cl-m\")) + (define r (condition-lookup \"cl-r\")) + (mutex-lock m) + (condition-signal r) + (mutex-unlock m) + (channel-close ch))" + #f)) + +(condition-wait ready2 mtx2) +(mutex-unlock mtx2) + +;; Receive should return #f because channel is/will-be closed and empty +(define close-result (channel-receive ch8)) +(check "receive returns #f on close" (not close-result)) + +(thread-join h6) +(channel-destroy ch8) +(mutex-destroy mtx2) +(condition-destroy ready2) + +;; ============================================================ +(display "=== 9. Bounded Channel: Producer Blocks When Full ===") (newline) +;; ============================================================ + +;; Bounded channel of capacity 2. +;; Producer sends 5 messages (must block after 2 until consumer drains). +(define ch9 (channel-create "bounded-test" 2)) + +(define h7 (thread-create + "(begin + (define ch (channel-lookup \"bounded-test\")) + (channel-send ch \"b1\") + (channel-send ch \"b2\") + (channel-send ch \"b3\") + (channel-send ch \"b4\") + (channel-send ch \"b5\") + (channel-close ch))" + #f)) + +(define bounded-msgs '()) +(define (consume-bounded) + (let ((msg (channel-receive ch9))) + (if msg + (begin (set! bounded-msgs (append bounded-msgs (list msg))) + (consume-bounded))))) +(consume-bounded) + +(check "bounded: received 5 messages" (= 5 (length bounded-msgs))) +(check "bounded: correct order" (equal? "b1" (car bounded-msgs))) +(check "bounded: last message" (equal? "b5" (list-ref bounded-msgs 4))) + +(thread-join h7) +(channel-destroy ch9) + +;; ============================================================ +(display "=== 10. Receive Pending Messages After Close ===") (newline) +;; ============================================================ + +(define ch10 (channel-create)) +(channel-send ch10 "pre-close-1") +(channel-send ch10 "pre-close-2") +(channel-close ch10) + +(check "receive after close 1" (equal? "pre-close-1" (channel-receive ch10))) +(check "receive after close 2" (equal? "pre-close-2" (channel-receive ch10))) +(check "receive after close empty" (not (channel-receive ch10))) +(channel-destroy ch10) + +;; ============================================================ +;; Summary +;; ============================================================ +(newline) +(display "=== Results: ") +(display pass-count) (display " passed, ") +(display fail-count) (display " failed ===") (newline) + +(exit) From 111f009c45f95a5f5eafd59ccb89530ac4b7a112 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Wed, 25 Mar 2026 21:11:08 -0500 Subject: [PATCH 4/9] Thread utilities --- README.md | 3 +- doc/CODEBASE_ANALYSIS.md | 3 +- doc/ThreadEnhancementPlan.md | 18 ++- doc/Threads.md | 62 +++++++++ doc/xlisp.md | 149 +++++++++++++++++++++ tests/test_threads.lsp | 239 ++++++++++++++++++++++++++++++++++ threads.lsp | 242 +++++++++++++++++++++++++++++++++++ 7 files changed, 712 insertions(+), 4 deletions(-) create mode 100644 tests/test_threads.lsp create mode 100644 threads.lsp diff --git a/README.md b/README.md index 26a9edb..a10d660 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,8 @@ It has some really nice features as follows: A. When used as an extension language, it is now reentrant and can handle multiple simultaneous threads. B. Native thread creation and joining from Lisp (`thread-create`, `thread-join`, `thread?`). C. Synchronization primitives: mutexes, condition variables, and message channels with cross-thread sharing via named registries. -D. Updated version to 10.0.0. +D. High-level threading utilities: `with-mutex`, `future`/`await`, `pcall`, thread pools, and `pmap` (`threads.lsp`). +E. Updated version to 10.0.0. ## Building diff --git a/doc/CODEBASE_ANALYSIS.md b/doc/CODEBASE_ANALYSIS.md index c6e9cdb..23a521e 100644 --- a/doc/CODEBASE_ANALYSIS.md +++ b/doc/CODEBASE_ANALYSIS.md @@ -114,7 +114,8 @@ When built with `THREADS=1`: - **Scheme influences** - lexical scoping, proper tail recursion - **Common Lisp elements** - packages, keywords, multiple values - **Native threading** - per-thread interpreter contexts with mutexes, - condition variables, and message channels for synchronization + condition variables, message channels, and high-level utilities + (futures, thread pools, parallel map) - **Cross-platform** (Windows, Linux, macOS) via ANSI C - **Extensible** via C API and extension modules - **FASL support** - fast loading of pre-compiled bytecode diff --git a/doc/ThreadEnhancementPlan.md b/doc/ThreadEnhancementPlan.md index 314e1d9..798d697 100644 --- a/doc/ThreadEnhancementPlan.md +++ b/doc/ThreadEnhancementPlan.md @@ -4,6 +4,8 @@ All planned threading features have been implemented and tested: +### Low-Level Primitives (C) + - **Threads** (`thread-create`, `thread-join`, `thread?`) -- `src/xlnthread.c` - **Mutexes** (`mutex-create`, `mutex-lock`, `mutex-unlock`, `mutex-destroy`, `mutex-lookup`, `mutex?`) -- `src/xlsync.c` - **Condition variables** (`condition-create`, `condition-wait`, `condition-signal`, `condition-broadcast`, `condition-destroy`, `condition-lookup`, `condition?`) -- `src/xlsync.c` @@ -15,13 +17,25 @@ All primitives share a common named-registry pattern for cross-thread access, use `xlCClass` type tags for foreign pointer discrimination, and support both POSIX and Windows platforms. +### High-Level Utilities (Lisp) + +- **with-mutex** -- Safe lock/unlock macro with unwind-protect cleanup +- **future / await / future?** -- Spawn computation, retrieve result later +- **pcall** -- Run N expressions concurrently, collect results in order +- **thread-pool** (`thread-pool-create`, `thread-pool-submit`, `thread-pool-destroy`, `thread-pool?`) -- Persistent worker pool +- **pmap** -- Parallel map with template substitution + +All defined in `threads.lsp`. + ## Test Results - `tests/test_sync.lsp` -- 25 tests (mutexes, condvars, cross-thread) - `tests/test_channel.lsp` -- 38 tests (channels, bounded, multi-producer, blocking) -- Stress tested: 0 errors in 100 iterations (50 sync + 50 channel) +- `tests/test_threads.lsp` -- 47 tests (with-mutex, future/await, pcall, thread-pool, pmap, stress, error handling) +- Stress tested: 0 errors in 100+ iterations per suite ## Documentation - `doc/Threads.md` -- Complete threading reference -- `doc/xlisp.md` sections 49-51 -- Lisp-level API reference +- `doc/ThreadEnhancements.md` -- High-level utilities implementation plan +- `doc/xlisp.md` sections 49-52 -- Lisp-level API reference diff --git a/doc/Threads.md b/doc/Threads.md index 3985e1f..cf71ac6 100644 --- a/doc/Threads.md +++ b/doc/Threads.md @@ -416,6 +416,67 @@ xlDestroyContext(ctx1); xlDestroyContext(ctx2); ``` +## High-Level Utilities + +The file `threads.lsp` provides convenient abstractions built on the +low-level primitives. Load it with `(load "threads.lsp")`. + +### with-mutex + +Macro that locks a mutex, evaluates body forms, and guarantees unlock +even on error: + +```lisp +(define m (mutex-create)) +(with-mutex m + ;; critical section + (+ 1 2)) ; => 3 +``` + +### future / await + +Spawn a computation and retrieve the result later: + +```lisp +(define f (future "(number->string (* 6 7))" #f)) +;; ... do other work ... +(await f) ; => "42" +``` + +### pcall + +Run multiple expressions concurrently, collect results in order: + +```lisp +(pcall "(number->string (* 2 3))" + "(number->string (* 4 5))") +;; => ("6" "20") +``` + +### Thread Pool + +Reuse a fixed set of worker threads instead of spawning one per task: + +```lisp +(define pool (thread-pool-create 4 #f)) +(define f1 (thread-pool-submit pool "(number->string (fib 30))")) +(define f2 (thread-pool-submit pool "(number->string (fib 31))")) +(display (await f1)) (newline) +(display (await f2)) (newline) +(thread-pool-destroy pool) +``` + +### pmap + +Parallel map — apply a template expression to a list of values: + +```lisp +(pmap "(number->string (* 2 ~a))" '("5" "10" "15")) +;; => ("10" "20" "30") +``` + +See `doc/xlisp.md` section 52 for the complete API reference. + ## Implementation Files | File | Role | @@ -426,6 +487,7 @@ xlDestroyContext(ctx2); | `src/xlcontext.c` | Context creation, destruction, initialization | | `src/xlnthread.c` | `thread-create`, `thread-join`, `thread?` | | `src/xlsync.c` | Mutexes, condition variables, channels, named registry | +| `threads.lsp` | High-level utilities (with-mutex, future/await, pcall, thread-pool, pmap) | ## Limitations diff --git a/doc/xlisp.md b/doc/xlisp.md index 5fd8e5d..03d90c3 100644 --- a/doc/xlisp.md +++ b/doc/xlisp.md @@ -69,6 +69,10 @@ full license. - [46. Debugging Functions](#46-debugging-functions) - [47. System Functions](#47-system-functions) - [48. Object Representations](#48-object-representations) +- [49. Threading Functions](#49-threading-functions) +- [50. Synchronization Primitives](#50-synchronization-primitives) +- [51. Message Channels](#51-message-channels) +- [52. High-Level Threading Utilities](#52-high-level-threading-utilities) @@ -2837,3 +2841,148 @@ Returns `#t` if *obj* is a live (not yet destroyed) channel handle. (thread-join h2) (channel-destroy ch) ``` + +# 52. High-Level Threading Utilities + +These utilities are defined in `threads.lsp` and provide convenient +abstractions over the low-level threading primitives. Load with +`(load "threads.lsp")`. Requires a thread-safe build (`make THREADS=1`). + +## WITH-MUTEX + +```lisp +(WITH-MUTEX mutex body...) +``` + +Macro. Locks *mutex*, evaluates the *body* forms, unlocks *mutex*, and +returns the value of the last body form. The mutex is guaranteed to be +unlocked even if the body signals an error (via `unwind-protect`). + +```lisp +(define m (mutex-create)) +(with-mutex m + (display "critical section") + (+ 1 2)) ; => 3, mutex is released +``` + +## FUTURE + +```lisp +(FUTURE expr-string [init-file]) +``` + +Spawns a new thread that evaluates *expr-string* and captures the result. +Returns a future object. The optional *init-file* is passed to +`thread-create` (default `#f`). The expression should return a string; +non-string values are converted via `format`. + +```lisp +(define f (future "(number->string (* 6 7))" #f)) +``` + +## AWAIT + +```lisp +(AWAIT future) +``` + +Blocks until the future's thread completes and returns the result string. +Each future can be awaited exactly once; after `await` the future is +invalidated. Signals an error if the future's expression raised an error. + +```lisp +(define f (future "(number->string 42)" #f)) +(await f) ; => "42" +``` + +## FUTURE? + +```lisp +(FUTURE? obj) +``` + +Returns `#t` if *obj* is a live (not yet awaited) future. + +## PCALL + +```lisp +(PCALL expr-string ...) +``` + +Evaluates all *expr-string* arguments concurrently in separate threads and +returns a list of result strings in the same order. + +```lisp +(pcall "(number->string (* 2 3))" + "(number->string (* 4 5))" + "(number->string (* 6 7))") +;; => ("6" "20" "42") +``` + +## THREAD-POOL-CREATE + +```lisp +(THREAD-POOL-CREATE n [init-file]) +``` + +Creates a pool of *n* persistent worker threads. Returns a pool object. +The optional *init-file* is passed to each worker's `thread-create`. + +```lisp +(define pool (thread-pool-create 4 #f)) +``` + +## THREAD-POOL-SUBMIT + +```lisp +(THREAD-POOL-SUBMIT pool expr-string) +``` + +Submits *expr-string* for evaluation by an available worker in *pool*. +Returns a future that can be passed to `await`. + +```lisp +(define f (thread-pool-submit pool "(number->string (+ 1 2))")) +(await f) ; => "3" +``` + +## THREAD-POOL-DESTROY + +```lisp +(THREAD-POOL-DESTROY pool) +``` + +Shuts down the pool: closes the task channel, waits for all workers to +finish, and cleans up resources. Returns `#t`. + +## THREAD-POOL? + +```lisp +(THREAD-POOL? obj) +``` + +Returns `#t` if *obj* is a thread pool. + +## PMAP + +```lisp +(PMAP template values [pool]) +``` + +Applies *template* (a string with a `~a` placeholder) to each element of +*values* (a list of strings), evaluates the resulting expressions in +parallel, and returns a list of result strings in order. + +If *pool* is provided, tasks are submitted to it; otherwise a new thread +is spawned per element. + +```lisp +(pmap "(number->string (* 2 ~a))" '("5" "10" "15")) +;; => ("10" "20" "30") + +;; With a pool: +(define pool (thread-pool-create 4 #f)) +(pmap "(number->string (* 3 ~a))" '("4" "5" "6") pool) +;; => ("12" "15" "18") +(thread-pool-destroy pool) +``` diff --git a/tests/test_threads.lsp b/tests/test_threads.lsp new file mode 100644 index 0000000..d16e10e --- /dev/null +++ b/tests/test_threads.lsp @@ -0,0 +1,239 @@ +;; Comprehensive tests for threads.lsp high-level threading utilities +;; Requires: make THREADS=1 +;; Run with: bin/xlisp threads.lsp tests/test_threads.lsp + +(load "threads.lsp") + +(define pass-count 0) +(define fail-count 0) + +(define (check name result) + (if result + (begin (set! pass-count (+ pass-count 1)) + (display " PASS: ") (display name) (newline)) + (begin (set! fail-count (+ fail-count 1)) + (display " FAIL: ") (display name) (newline)))) + +;; ============================================================ +(display "=== 1. with-mutex ===") (newline) +;; ============================================================ + +(define m1 (mutex-create)) + +;; Basic usage: returns value of body +(check "with-mutex returns body value" + (= 42 (with-mutex m1 (* 6 7)))) + +;; Multiple body forms +(check "with-mutex multiple body forms" + (equal? "hello" + (with-mutex m1 + (+ 1 2) + "hello"))) + +;; Mutex is released after with-mutex +;; (if it weren't, the second lock would deadlock) +(mutex-lock m1) +(mutex-unlock m1) +(check "mutex released after with-mutex" #t) + +;; Nested with-mutex (different mutexes) +(define m2 (mutex-create)) +(check "nested with-mutex" + (= 100 (with-mutex m1 (with-mutex m2 (* 10 10))))) + +;; Error in body: mutex is still released (unwind-protect) +(define m3 (mutex-create)) +(define error-caught #f) +(catch 'error + (with-mutex m3 + (throw-error "test error"))) +(set! error-caught #t) +;; If mutex were still locked, this lock/unlock would deadlock +(mutex-lock m3) +(mutex-unlock m3) +(check "mutex released after error in body" error-caught) +(mutex-destroy m3) + +(mutex-destroy m1) +(mutex-destroy m2) + +;; ============================================================ +(display "=== 2. future / await ===") (newline) +;; ============================================================ + +;; Basic future +(define f1 (future "(number->string (* 6 7))" #f)) +(check "future? on future" (future? f1)) +(check "future? on non-future" (not (future? 42))) +(check "future? on list" (not (future? '(1 2 3)))) + +(define r1 (await f1)) +(check "await returns correct result" (equal? "42" r1)) + +;; Future returning a string directly +(define f2 (future "\"hello world\"" #f)) +(check "await string result" (equal? "hello world" (await f2))) + +;; Multiple concurrent futures +(define fa (future "(number->string (+ 100 1))" #f)) +(define fb (future "(number->string (+ 200 2))" #f)) +(define fc (future "(number->string (+ 300 3))" #f)) +(define ra (await fa)) +(define rb (await fb)) +(define rc (await fc)) +(check "concurrent future A" (equal? "101" ra)) +(check "concurrent future B" (equal? "202" rb)) +(check "concurrent future C" (equal? "303" rc)) + +;; Future with computation +(define f3 (future + "(begin (define (fact n) (if (< n 2) 1 (* n (fact (- n 1))))) (number->string (fact 10)))" + #f)) +(check "future with computation" (equal? "3628800" (await f3))) + +;; future? returns #f after await (invalidated) +(define f4 (future "(number->string 1)" #f)) +(await f4) +(check "future? after await" (not (future? f4))) + +;; Error in future is propagated to await +(define f5 (future "(+ 1 undefined-variable-xyz)" #f)) +(define future-error-caught #f) +(catch 'error + (await f5)) +(set! future-error-caught #t) +(check "error in future propagates to await" future-error-caught) + +;; ============================================================ +(display "=== 3. pcall ===") (newline) +;; ============================================================ + +;; Basic pcall +(define pc-results + (pcall "(number->string (* 2 3))" + "(number->string (* 4 5))" + "(number->string (* 6 7))")) +(check "pcall returns 3 results" (= 3 (length pc-results))) +(check "pcall first" (equal? "6" (car pc-results))) +(check "pcall second" (equal? "20" (cadr pc-results))) +(check "pcall third" (equal? "42" (caddr pc-results))) + +;; pcall with single expression +(define pc-single (pcall "(number->string 99)")) +(check "pcall single" (equal? "99" (car pc-single))) + +;; pcall preserves order even if later tasks finish first +;; (a slow task first, fast task second) +(define pc-order + (pcall "(begin (define (spin n) (if (= n 0) 0 (spin (- n 1)))) (spin 10000) (number->string 1))" + "(number->string 2)")) +(check "pcall preserves order" (equal? "1" (car pc-order))) +(check "pcall preserves order 2" (equal? "2" (cadr pc-order))) + +;; ============================================================ +(display "=== 4. thread-pool ===") (newline) +;; ============================================================ + +(define pool (thread-pool-create 2 #f)) +(check "thread-pool? on pool" (thread-pool? pool)) +(check "thread-pool? on non-pool" (not (thread-pool? 42))) +(check "thread-pool? on future" (not (thread-pool? (list '%future #f #f #f)))) + +;; Submit single task +(define pf1 (thread-pool-submit pool "(number->string (+ 10 20))")) +(check "pool submit returns future" (future? pf1)) +(check "pool task result" (equal? "30" (await pf1))) + +;; Submit multiple tasks (more than pool size) +(define pf2 (thread-pool-submit pool "(number->string 1)")) +(define pf3 (thread-pool-submit pool "(number->string 2)")) +(define pf4 (thread-pool-submit pool "(number->string 3)")) +(define pf5 (thread-pool-submit pool "(number->string 4)")) +(define pr2 (await pf2)) +(define pr3 (await pf3)) +(define pr4 (await pf4)) +(define pr5 (await pf5)) +(check "pool queued task 1" (equal? "1" pr2)) +(check "pool queued task 2" (equal? "2" pr3)) +(check "pool queued task 3" (equal? "3" pr4)) +(check "pool queued task 4" (equal? "4" pr5)) + +;; Pool with computation +(define pf6 (thread-pool-submit pool + "(begin (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (number->string (fib 15)))")) +(check "pool computation" (equal? "610" (await pf6))) + +(thread-pool-destroy pool) +(check "pool destroyed" #t) + +;; ============================================================ +(display "=== 5. pmap ===") (newline) +;; ============================================================ + +;; pmap with futures (no pool) +(define pm1 (pmap "(number->string (* 2 ~a))" '("5" "10" "15"))) +(check "pmap length" (= 3 (length pm1))) +(check "pmap first" (equal? "10" (car pm1))) +(check "pmap second" (equal? "20" (cadr pm1))) +(check "pmap third" (equal? "30" (caddr pm1))) + +;; pmap with pool +(define pool2 (thread-pool-create 2 #f)) +(define pm2 (pmap "(number->string (* 3 ~a))" '("4" "5" "6") pool2)) +(check "pmap pool first" (equal? "12" (car pm2))) +(check "pmap pool second" (equal? "15" (cadr pm2))) +(check "pmap pool third" (equal? "18" (caddr pm2))) +(thread-pool-destroy pool2) + +;; pmap with single element +(define pm3 (pmap "(number->string (+ 1 ~a))" '("99"))) +(check "pmap single element" (equal? "100" (car pm3))) + +;; pmap with empty list +(define pm4 (pmap "(number->string ~a)" '())) +(check "pmap empty list" (null? pm4)) + +;; ============================================================ +(display "=== 6. Stress: pool with many tasks ===") (newline) +;; ============================================================ + +(define pool3 (thread-pool-create 4 #f)) +(define stress-futures '()) + +;; Submit 20 tasks to a 4-worker pool +(let loop ((i 0)) + (if (< i 20) + (let* ((expr (string-append "(number->string (* 2 " (number->string i) "))")) + (f (thread-pool-submit pool3 expr))) + (set! stress-futures (cons f stress-futures)) + (loop (+ i 1))))) +(set! stress-futures (reverse stress-futures)) + +;; Collect all results +(define stress-results (map await stress-futures)) +(check "stress: got 20 results" (= 20 (length stress-results))) +(check "stress: first result" (equal? "0" (car stress-results))) +(check "stress: last result" (equal? "38" (list-ref stress-results 19))) + +;; Verify all results are correct +(define stress-ok + (let loop ((i 0) (results stress-results)) + (if (null? results) + #t + (if (equal? (number->string (* 2 i)) (car results)) + (loop (+ i 1) (cdr results)) + #f)))) +(check "stress: all results correct" stress-ok) + +(thread-pool-destroy pool3) + +;; ============================================================ +;; Summary +;; ============================================================ +(newline) +(display "=== Results: ") +(display pass-count) (display " passed, ") +(display fail-count) (display " failed ===") (newline) + +(exit) diff --git a/threads.lsp b/threads.lsp new file mode 100644 index 0000000..dc5f20e --- /dev/null +++ b/threads.lsp @@ -0,0 +1,242 @@ +;; threads.lsp -- High-level threading utilities for XLISP +;; +;; Requires: make THREADS=1 +;; Load with: (load "threads.lsp") +;; +;; Provides: +;; with-mutex -- safe lock/unlock with cleanup +;; future/await -- spawn computation, retrieve result +;; future? -- type predicate +;; pcall -- parallel call, collect results in order +;; pmap -- parallel map over a list +;; thread-pool-create -- create a pool of worker threads +;; thread-pool-submit -- submit work to a pool (returns future) +;; thread-pool-destroy -- shut down a pool +;; thread-pool? -- type predicate + +;; ============================================================ +;; 1. with-mutex +;; ============================================================ + +(define-macro (with-mutex mtx &body body) + (let ((result (gensym)) + (m (gensym))) + `(let ((,m ,mtx)) + (mutex-lock ,m) + (let ((,result (unwind-protect + (begin ,@body) + (mutex-unlock ,m)))) + ,result)))) + +;; ============================================================ +;; 2. future / await / future? +;; ============================================================ + +;; Internal counter for unique channel names +(define %future-counter 0) + +(define (%future-next-name) + (set! %future-counter (+ %future-counter 1)) + (format #f "__future-~A" %future-counter)) + +(define (%make-future thread-handle channel name) + (list '%future thread-handle channel name)) + +(define (future? obj) + (and (pair? obj) + (eq? (car obj) '%future))) + +(define (%future-thread f) (list-ref f 1)) +(define (%future-channel f) (list-ref f 2)) +(define (%future-name f) (list-ref f 3)) + +(define (future expr-string . args) + (let* ((init-file (if (pair? args) (car args) #f)) + (ch-name (%future-next-name)) + (ch (channel-create ch-name)) + ;; Build the child expression that evaluates expr-string, + ;; converts the result to a string, and sends it on the channel. + (wrapper (string-append + "(catch '%future-exit" + " (begin" + " (define %ch (channel-lookup \"" ch-name "\"))" + " (define %error-sent #f)" + " (set! *error-handler*" + " (lambda (fn env cont)" + " (if (not %error-sent)" + " (begin" + " (set! %error-sent #t)" + " (channel-send %ch \"__FUTURE-ERROR__\")" + " (channel-close %ch)))" + " (throw '%future-exit #f)))" + " (define %result" + " (let ((v " expr-string "))" + " (if (string? v) v" + " (format #f \"~A\" v))))" + " (channel-send %ch %result)" + " (channel-close %ch)))")) + (h (thread-create wrapper init-file))) + (%make-future h ch ch-name))) + +(define (await f) + (let* ((ch (%future-channel f)) + (h (%future-thread f)) + (msg (channel-receive ch))) + (thread-join h) + (channel-destroy ch) + ;; Invalidate the future + (set-car! f #f) + (if (equal? msg "__FUTURE-ERROR__") + (error "future terminated with an error") + msg))) + +;; ============================================================ +;; 3. pcall +;; ============================================================ + +(define (pcall . expr-strings) + (let* ((futures (map (lambda (e) (future e)) expr-strings)) + (results (map await futures))) + results)) + +;; ============================================================ +;; 4. thread-pool +;; ============================================================ + +(define %pool-counter 0) + +(define (%pool-next-name) + (set! %pool-counter (+ %pool-counter 1)) + (format #f "__pool-~A" %pool-counter)) + +(define (%make-pool task-channel handles name) + (list '%thread-pool task-channel handles name)) + +(define (thread-pool? obj) + (and (pair? obj) + (eq? (car obj) '%thread-pool))) + +(define (%pool-task-channel p) (list-ref p 1)) +(define (%pool-handles p) (list-ref p 2)) +(define (%pool-name p) (list-ref p 3)) + +(define (thread-pool-create n . args) + (let* ((init-file (if (pair? args) (car args) #f)) + (pool-name (%pool-next-name)) + (task-ch-name (string-append pool-name "-tasks")) + (task-ch (channel-create task-ch-name)) + ;; Worker loop: receive "result-ch-name\texpr", evaluate, send result + (worker-expr (string-append + "(begin" + " (define %tch (channel-lookup \"" task-ch-name "\"))" + " (define %current-rch #f)" + " (set! *error-handler*" + " (lambda (fn env cont)" + " (if %current-rch" + " (begin" + " (channel-send %current-rch \"__FUTURE-ERROR__\")" + " (channel-close %current-rch)" + " (set! %current-rch #f)))" + " (throw '%worker-error #f)))" + " (let %loop ()" + " (let ((%msg (channel-receive %tch)))" + " (if %msg" + " (begin" + " (catch '%worker-error" + " (let* ((%tab (string-search \"\\t\" %msg))" + " (%rname (substring %msg 0 %tab))" + " (%expr (substring %msg (+ %tab 1) (string-length %msg)))" + " (%rch (channel-lookup %rname)))" + " (set! %current-rch %rch)" + " (let ((%v (eval (read (make-string-input-stream %expr)))))" + " (if %rch" + " (begin" + " (channel-send %rch" + " (if (string? %v) %v (format #f \"~A\" %v)))" + " (channel-close %rch))))" + " (set! %current-rch #f)))" + " (%loop))))))" + )) + (handles (let loop ((i 0) (acc '())) + (if (>= i n) + (reverse acc) + (loop (+ i 1) + (cons (thread-create worker-expr init-file) acc)))))) + (%make-pool task-ch handles pool-name))) + +(define (thread-pool-submit pool expr-string) + (let* ((ch-name (%future-next-name)) + (ch (channel-create ch-name)) + (task-ch (%pool-task-channel pool)) + (msg (string-append ch-name "\t" expr-string))) + (channel-send task-ch msg) + ;; Return a future-like object (no thread handle — pool owns the threads) + (%make-future #f ch ch-name))) + +(define (thread-pool-destroy pool) + (let ((task-ch (%pool-task-channel pool)) + (handles (%pool-handles pool))) + ;; Close the task channel — workers will exit their loops + (channel-close task-ch) + ;; Join all workers + (for-each thread-join handles) + ;; Cleanup + (channel-destroy task-ch) + ;; Invalidate + (set-car! (cdr pool) #f) + (set-car! (cddr pool) #f) + #t)) + +;; Override await for pool futures (no thread handle to join) +(let ((%original-await await)) + (set! await + (lambda (f) + (let* ((ch (%future-channel f)) + (h (%future-thread f)) + (msg (channel-receive ch))) + ;; Join the thread (catch errors from failed threads) + (if h (catch 'error (thread-join h))) + (channel-destroy ch) + ;; Invalidate the future + (set-car! f #f) + (if (equal? msg "__FUTURE-ERROR__") + (error "future terminated with an error") + msg))))) + +;; ============================================================ +;; 5. pmap +;; ============================================================ + +(define (pmap template values . args) + (let ((pool (if (pair? args) (car args) #f))) + (if pool + ;; Use thread pool + (let* ((futures (map (lambda (v) + (thread-pool-submit pool + (string-append + (let loop ((s template) (done "")) + (let ((pos (string-search "~a" s))) + (if pos + (string-append done + (substring s 0 pos) + v + (substring s (+ pos 2) (string-length s))) + (string-append done s)))) + ""))) + values)) + (results (map await futures))) + results) + ;; Use individual futures + (let* ((futures (map (lambda (v) + (future + (let loop ((s template) (done "")) + (let ((pos (string-search "~a" s))) + (if pos + (string-append done + (substring s 0 pos) + v + (substring s (+ pos 2) (string-length s))) + (string-append done s)))))) + values)) + (results (map await futures))) + results)))) From 08c42f62a4f248fd3e5bcdcf2b29f325897223a7 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Wed, 25 Mar 2026 21:33:59 -0500 Subject: [PATCH 5/9] Remove old md file --- doc/ThreadEnhancementPlan.md | 41 ------------------------------------ 1 file changed, 41 deletions(-) delete mode 100644 doc/ThreadEnhancementPlan.md diff --git a/doc/ThreadEnhancementPlan.md b/doc/ThreadEnhancementPlan.md deleted file mode 100644 index 798d697..0000000 --- a/doc/ThreadEnhancementPlan.md +++ /dev/null @@ -1,41 +0,0 @@ -# Thread Enhancement Plan - -## Status: Complete - -All planned threading features have been implemented and tested: - -### Low-Level Primitives (C) - -- **Threads** (`thread-create`, `thread-join`, `thread?`) -- `src/xlnthread.c` -- **Mutexes** (`mutex-create`, `mutex-lock`, `mutex-unlock`, `mutex-destroy`, `mutex-lookup`, `mutex?`) -- `src/xlsync.c` -- **Condition variables** (`condition-create`, `condition-wait`, `condition-signal`, `condition-broadcast`, `condition-destroy`, `condition-lookup`, `condition?`) -- `src/xlsync.c` -- **Channels** (`channel-create`, `channel-send`, `channel-receive`, `channel-close`, `channel-destroy`, `channel-lookup`, `channel-open?`, `channel?`) -- `src/xlsync.c` - -Total: 24 threading/synchronization functions. - -All primitives share a common named-registry pattern for cross-thread -access, use `xlCClass` type tags for foreign pointer discrimination, and -support both POSIX and Windows platforms. - -### High-Level Utilities (Lisp) - -- **with-mutex** -- Safe lock/unlock macro with unwind-protect cleanup -- **future / await / future?** -- Spawn computation, retrieve result later -- **pcall** -- Run N expressions concurrently, collect results in order -- **thread-pool** (`thread-pool-create`, `thread-pool-submit`, `thread-pool-destroy`, `thread-pool?`) -- Persistent worker pool -- **pmap** -- Parallel map with template substitution - -All defined in `threads.lsp`. - -## Test Results - -- `tests/test_sync.lsp` -- 25 tests (mutexes, condvars, cross-thread) -- `tests/test_channel.lsp` -- 38 tests (channels, bounded, multi-producer, blocking) -- `tests/test_threads.lsp` -- 47 tests (with-mutex, future/await, pcall, thread-pool, pmap, stress, error handling) -- Stress tested: 0 errors in 100+ iterations per suite - -## Documentation - -- `doc/Threads.md` -- Complete threading reference -- `doc/ThreadEnhancements.md` -- High-level utilities implementation plan -- `doc/xlisp.md` sections 49-52 -- Lisp-level API reference From 8a8dfb5b2aade5499a0820b27e3071c0370de917 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Wed, 25 Mar 2026 21:46:46 -0500 Subject: [PATCH 6/9] Doc update --- doc/Threads.md | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/doc/Threads.md b/doc/Threads.md index cf71ac6..34e6923 100644 --- a/doc/Threads.md +++ b/doc/Threads.md @@ -78,6 +78,66 @@ The bytecode `optab[256]` dispatch table is shared and immutable. It is initialized once (protected by an `optabInitialized` flag) and read-only thereafter, making it safe for concurrent access. +### Per-Thread Garbage Collection and Memory + +Each thread has its own heap (node segments and vector segments), its own +free lists, and its own garbage collector. The GC runs synchronously +within the thread — it is triggered inline when an allocation cannot be +satisfied, and there is no separate GC thread. Because heaps are not +shared, one thread's GC never touches another thread's memory, and there +are no stop-the-world pauses across threads. + +#### GC Algorithm + +The collector in `src/xldmem.c` uses a three-phase **mark-sweep-compact** +algorithm: + +1. **Mark** — Starting from roots (VM registers `xlFun`, `xlEnv`, `xlVal`; + the value and control stacks; the package list; and protected + pointers), the collector walks all reachable objects. It uses a + **pointer-reversal traversal** (Deutsch-Schorr-Waite algorithm) that + flips car/cdr pointers as it descends, avoiding recursion and needing + no auxiliary stack. Vector-like nodes (symbols, vectors, code objects, + etc.) are marked by iterating their elements. Continuations receive + special handling — their embedded value/control stacks are marked + separately. + +2. **Compact** — Live vectors are slid down within each vector segment to + eliminate gaps left by dead vectors, and each vector node's data + pointer is updated to its new location. Only vector space is + compacted; node space is not. + +3. **Sweep** — Every node in every segment is visited. Unmarked nodes are + returned to the free list. Marked nodes have their mark bit cleared. + Certain types receive special cleanup: file streams are closed, foreign + pointers call their registered `free` callback, and subr name strings + are freed. + +#### Default Memory Sizes + +All threads (including the main thread) use the same hardcoded defaults, +defined in `include/xlisp.h`: + +| Constant | Default | Purpose | +|----------|---------|---------| +| `xlSTACKSIZE` | 65,536 | Value/control stack (in `xlValue` slots) | +| `xlNSSIZE` | 20,000 | Nodes per node segment | +| `xlVSSIZE` | 200,000 | `xlValue` slots per vector segment | + +These are not hard caps — they are the size of **one segment**. Memory +grows on demand: when the GC runs and there still is not enough free +space, `findmemory()` allocates additional segments via `xlNExpand()` and +`xlVExpand()`. There is no upper bound other than what `malloc` can +provide. + +#### No Per-Thread Size Configuration + +There is currently no way to configure memory sizes on a per-thread +basis. The `thread-create` function does not accept sizing parameters, +and `xlCreateContext()` always sets `nsSize` and `vsSize` to the compiled +defaults. To customize sizes you would need to modify the constants in +`include/xlisp.h` and rebuild, which affects all threads equally. + ## Lisp-Level Threading API ### Thread Creation From a9ab52d80f541e7e78d34668b405235bee68e602 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Wed, 25 Mar 2026 21:50:48 -0500 Subject: [PATCH 7/9] README update --- README.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index a10d660..c451564 100644 --- a/README.md +++ b/README.md @@ -21,11 +21,11 @@ It has some really nice features as follows: ## To all of this, I have added: -A. When used as an extension language, it is now reentrant and can handle multiple simultaneous threads. -B. Native thread creation and joining from Lisp (`thread-create`, `thread-join`, `thread?`). -C. Synchronization primitives: mutexes, condition variables, and message channels with cross-thread sharing via named registries. -D. High-level threading utilities: `with-mutex`, `future`/`await`, `pcall`, thread pools, and `pmap` (`threads.lsp`). -E. Updated version to 10.0.0. +- A. When used as an extension language, it is now reentrant and can handle multiple simultaneous threads. +- B. Native thread creation and joining from Lisp (`thread-create`, `thread-join`, `thread?`). +- C. Synchronization primitives: mutexes, condition variables, and message channels with cross-thread sharing via named registries. +- D. High-level threading utilities: `with-mutex`, `future`/`await`, `pcall`, thread pools, and `pmap` (`threads.lsp`). +- E. Updated version to 10.0.0. ## Building From a26867450d5dff3cf585981dba8b6d6add989dc0 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Wed, 25 Mar 2026 22:26:35 -0500 Subject: [PATCH 8/9] Support lists in thread creation --- doc/Threads.md | 24 +++++++++++++++++++----- doc/xlisp.md | 27 +++++++++++++++++---------- src/xlnthread.c | 30 ++++++++++++++++++++++++------ 3 files changed, 60 insertions(+), 21 deletions(-) diff --git a/doc/Threads.md b/doc/Threads.md index 34e6923..99b930f 100644 --- a/doc/Threads.md +++ b/doc/Threads.md @@ -143,21 +143,35 @@ defaults. To customize sizes you would need to modify the constants in ### Thread Creation ```lisp -(THREAD-CREATE expr-string [init-file]) +(THREAD-CREATE expr [init-file]) ``` -Creates a new native OS thread that evaluates *expr-string* (a string -containing a Lisp expression) in its own interpreter context. +Creates a new native OS thread that evaluates *expr* in its own +interpreter context. *expr* can be: + +- A **string** containing a Lisp expression, or +- A **list** (quoted S-expression), which is automatically serialized + to a string. + +Using a list is more natural and avoids escaped quotes inside strings. - *init-file*: optional string naming an initialization file to load before evaluating the expression. Default is `"xlisp.lsp"`. Pass `#f` to skip loading any init file. - Returns a thread handle (foreign pointer). -**Important:** `THREAD-CREATE` evaluates only the **first** expression -in the string. To execute multiple statements, wrap them in `(begin ...)`: +**Important:** `THREAD-CREATE` evaluates only the **first** expression. +To execute multiple statements, wrap them in `(begin ...)`: ```lisp +;; Using a list (preferred) +(define h (thread-create + '(begin + (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) + (fib 30)) + #f)) + +;; Using a string (still supported) (define h (thread-create "(begin (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) diff --git a/doc/xlisp.md b/doc/xlisp.md index 03d90c3..73c7523 100644 --- a/doc/xlisp.md +++ b/doc/xlisp.md @@ -2392,23 +2392,30 @@ object. The remaining elements are the object's instance variable values. XLISP supports native thread creation when built in reentrant mode (`make THREADS=1`). Each spawned thread gets its own independent interpreter context -- it does not share any Lisp-level state with the -calling thread. The thread evaluates a string expression in a fresh +calling thread. The thread evaluates an expression in a fresh environment. If the system was not built with `THREADS=1`, calling these functions signals an error. -**Important:** `THREAD-CREATE` evaluates only the *first* expression in -the string. To execute multiple statements, wrap them in `(begin ...)`. +**Important:** `THREAD-CREATE` evaluates only the *first* expression. +To execute multiple statements, wrap them in `(begin ...)`. ## THREAD-CREATE ```lisp -(THREAD-CREATE expr-string [init-file]) +(THREAD-CREATE expr [init-file]) ``` -Creates a new native thread that evaluates *expr-string* (a string -containing a Lisp expression) in its own interpreter context. +Creates a new native thread that evaluates *expr* in its own interpreter +context. *expr* can be: + +- A **string** containing a Lisp expression, or +- A **list** (quoted S-expression), which is automatically serialized to + a string. + +Using a list avoids awkward string escaping and allows normal editor +support (syntax highlighting, indentation). *init-file* is an optional string naming an initialization file to load before evaluating the expression. The default is `"xlisp.lsp"`. Pass @@ -2417,19 +2424,19 @@ before evaluating the expression. The default is `"xlisp.lsp"`. Pass Returns a thread handle (a foreign-pointer object) that can be passed to `THREAD-JOIN`. -Example: +Example with a list: ```lisp ;; Spawn a thread that computes fib(30) (define h (thread-create - "(begin + '(begin (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) - (fib 30))")) + (fib 30)))) ;; Wait for it to finish (thread-join h) ; => #t ``` -Example with no init file (faster startup): +Example with a string (original form, still supported): ```lisp (define h (thread-create "(+ 1 2)" #f)) (thread-join h) ; => #t diff --git a/src/xlnthread.c b/src/xlnthread.c index 5320c99..b3db2fd 100644 --- a/src/xlnthread.c +++ b/src/xlnthread.c @@ -121,17 +121,35 @@ static void *threadWorker(void *arg) #endif /* XLISP_USE_CONTEXT */ /* xthreadcreate - built-in function 'thread-create' */ -/* (thread-create expr-string [init-file]) => thread-handle */ +/* (thread-create expr [init-file]) => thread-handle */ +/* expr can be a string or a list (which is serialized to a string) */ xlValue xthreadcreate(void) { #ifdef XLISP_USE_CONTEXT - xlValue strval, initval; + xlValue exprval, initval; const char *str, *initStr; xlThreadInfo *info; xlValue handle; - /* get the expression string argument */ - strval = xlGetArgString(); + /* get the expression argument (string or list) */ + exprval = xlGetArg(); + + /* if it's a list, serialize it to a string via write */ + if (xlConsP(exprval)) { + xlValue stream, strobj; + xlCheck(2); + xlPush(exprval); + stream = xlNewUStream(); + xlPush(stream); + xlWrite(exprval, stream); + strobj = xlGetStrOutput(stream); + xlDrop(2); + exprval = strobj; + } + else if (!xlStringP(exprval)) { + xlBadType(exprval); + return xlNil; /* not reached */ + } /* get optional init file argument (default: "xlisp.lsp") */ if (xlMoreArgsP()) { @@ -151,7 +169,7 @@ xlValue xthreadcreate(void) xlLastArg(); - str = xlGetString(strval); + str = xlGetString(exprval); /* allocate thread info */ info = (xlThreadInfo *)malloc(sizeof(xlThreadInfo)); @@ -210,7 +228,7 @@ xlValue xthreadcreate(void) return handle; #else - xlGetArgString(); + xlGetArg(); /* accept string or list */ if (xlMoreArgsP()) xlGetArg(); xlLastArg(); xlFmtError("thread-create: requires threaded build (THREADS=1)"); From 7a782d74f3468594bf70dbf5f0aa777009b331bb Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Thu, 26 Mar 2026 18:58:26 -0500 Subject: [PATCH 9/9] Added ability to share code between threads --- Makefile | 1 + README.md | 3 +- doc/CODEBASE_ANALYSIS.md | 10 +- doc/Threads.md | 61 +++- doc/xlisp.md | 59 ++++ include/xlisp.h | 2 + include/xlshared.h | 73 +++++ src/CMakeLists.txt | 4 +- src/xldmem.c | 28 ++ src/xlftab.c | 9 + src/xlnthread.c | 7 + src/xlshared.c | 414 ++++++++++++++++++++++++++ tests/test_shared.lsp | 623 +++++++++++++++++++++++++++++++++++++++ 13 files changed, 1288 insertions(+), 6 deletions(-) create mode 100644 include/xlshared.h create mode 100644 src/xlshared.c create mode 100644 tests/test_shared.lsp diff --git a/Makefile b/Makefile index 6f025c4..adc2b1b 100755 --- a/Makefile +++ b/Makefile @@ -124,6 +124,7 @@ $(LIBOBJDIR)/xlmain.o \ $(LIBOBJDIR)/xlitersq.o \ $(LIBOBJDIR)/xlmath.o \ $(LIBOBJDIR)/xlnthread.o \ +$(LIBOBJDIR)/xlshared.o \ $(LIBOBJDIR)/xlsync.o \ $(LIBOBJDIR)/xlobj.o \ $(LIBOBJDIR)/xlosint.o \ diff --git a/README.md b/README.md index c451564..c547fe5 100644 --- a/README.md +++ b/README.md @@ -25,7 +25,8 @@ It has some really nice features as follows: - B. Native thread creation and joining from Lisp (`thread-create`, `thread-join`, `thread?`). - C. Synchronization primitives: mutexes, condition variables, and message channels with cross-thread sharing via named registries. - D. High-level threading utilities: `with-mutex`, `future`/`await`, `pcall`, thread pools, and `pmap` (`threads.lsp`). -- E. Updated version to 10.0.0. +- E. Shared bytecode pool: publish compiled functions once and have them automatically available in all threads, avoiding redundant compilation and reducing per-thread memory usage (`share-function`, `shared-code?`). +- F. Updated version to 10.0.0. ## Building diff --git a/doc/CODEBASE_ANALYSIS.md b/doc/CODEBASE_ANALYSIS.md index 23a521e..76b98d6 100644 --- a/doc/CODEBASE_ANALYSIS.md +++ b/doc/CODEBASE_ANALYSIS.md @@ -9,7 +9,7 @@ ``` xlisp/ ├── src/ # Core C source (29 files, ~19.5K lines) -├── include/ # Header files (xlisp.h, xlcontext.h, xlcompat.h, xlthread.h) +├── include/ # Header files (xlisp.h, xlcontext.h, xlcompat.h, xlthread.h, xlshared.h) ├── xlisp/ # REPL executable source ├── ext/ # Extension module ├── doc/ # Documentation (Markdown) @@ -38,6 +38,7 @@ xlisp/ | `xldbg.c` | Debugging support | | `xlcontext.c` | Per-thread interpreter context management | | `xlnthread.c` | Native thread creation/join | +| `xlshared.c` | Shared bytecode pool for cross-thread code sharing | | `xlsync.c` | Synchronization primitives (mutexes, condition variables, channels) | | `msstuff.c` | Windows-specific code | | `unstuff.c` | Unix-specific code | @@ -103,6 +104,9 @@ When built with `THREADS=1`: accesses through the context pointer (e.g., `#define xlVal (xlCtx()->val)`) - Each thread gets independent stacks, heap, GC, symbols, and packages - The bytecode dispatch table (`optab`) is shared and immutable +- A shared bytecode pool allows the main thread to publish compiled functions + that are automatically instantiated into new thread contexts, avoiding + redundant compilation and reducing per-thread memory usage - Synchronization objects (mutexes, condition variables, and message channels) are shared at the C level via a named registry with reference counting @@ -114,8 +118,8 @@ When built with `THREADS=1`: - **Scheme influences** - lexical scoping, proper tail recursion - **Common Lisp elements** - packages, keywords, multiple values - **Native threading** - per-thread interpreter contexts with mutexes, - condition variables, message channels, and high-level utilities - (futures, thread pools, parallel map) + condition variables, message channels, shared bytecode pool, and + high-level utilities (futures, thread pools, parallel map) - **Cross-platform** (Windows, Linux, macOS) via ANSI C - **Extensible** via C API and extension modules - **FASL support** - fast loading of pre-compiled bytecode diff --git a/doc/Threads.md b/doc/Threads.md index 99b930f..1798614 100644 --- a/doc/Threads.md +++ b/doc/Threads.md @@ -490,6 +490,61 @@ xlDestroyContext(ctx1); xlDestroyContext(ctx2); ``` +## Shared Bytecode Pool + +When threads load the same library code independently, each thread pays +the cost of parsing, compiling, and storing its own copy. The **shared +bytecode pool** eliminates this overhead by letting the main thread +publish compiled functions into process-wide shared memory that all +subsequent threads can use automatically. + +### How It Works + +1. The main thread defines and compiles functions normally. +2. `(share-function 'name)` serializes the closure's code object + (bytecodes, literals, nested code) into a shared template stored in + `malloc`'d memory outside any thread's GC heap. +3. When `thread-create` spawns a new thread, `xlLinkSharedCode()` is + called automatically after context initialization. It instantiates + each shared template into the new thread's local heap -- creating + lightweight code object wrappers that point to the shared bytecode + data and resolve symbols against the thread's own package system. + +The raw bytecode bytes (the bulk of compiled code) are shared read-only. +Each thread gets its own small code object nodes and local symbol +references, so the GC in each thread operates independently and +thread-safety is preserved. + +### API + +```lisp +(SHARE-FUNCTION symbol) ; publish a closure to the shared pool => #t +(SHARED-CODE?) ; #t if any code has been shared, #f otherwise +``` + +### Usage Example + +```lisp +;; Main thread: define and share utility functions +(define (add1 n) (+ n 1)) +(define (double n) (* 2 n)) +(share-function 'add1) +(share-function 'double) + +;; Child threads automatically have add1 and double available: +(define h (thread-create "(number->string (add1 (double 20)))" #f)) +(thread-join h) ; => #t +``` + +**Notes:** +- Call `share-function` *before* creating threads that need the code. +- Only closures (compiled functions) can be shared. +- Shared bytecodes persist for the lifetime of the process. +- The function's code is shared, not its runtime value bindings -- each + thread gets independent global variable bindings. + +See `doc/xlisp.md` section 53 for the complete API reference. + ## High-Level Utilities The file `threads.lsp` provides convenient abstractions built on the @@ -561,6 +616,8 @@ See `doc/xlisp.md` section 52 for the complete API reference. | `src/xlcontext.c` | Context creation, destruction, initialization | | `src/xlnthread.c` | `thread-create`, `thread-join`, `thread?` | | `src/xlsync.c` | Mutexes, condition variables, channels, named registry | +| `include/xlshared.h` | Shared bytecode pool data structures and API declarations | +| `src/xlshared.c` | Shared bytecode pool: publish, instantiate, link | | `threads.lsp` | High-level utilities (with-mutex, future/await, pcall, thread-pool, pmap) | ## Limitations @@ -572,7 +629,9 @@ See `doc/xlisp.md` section 52 for the complete API reference. strings (used by `thread-create`, the named registry, and channels). 3. **Memory overhead.** Each context has a full interpreter instance. - Memory scales linearly with context count. + Memory scales linearly with context count. The shared bytecode pool + mitigates this for compiled code: shared functions store bytecodes + once in process-wide memory rather than duplicating them per thread. 4. **Initialization serialization.** Context initialization uses OS callbacks with static buffers that are not thread-safe. A global mutex diff --git a/doc/xlisp.md b/doc/xlisp.md index 73c7523..bd35fba 100644 --- a/doc/xlisp.md +++ b/doc/xlisp.md @@ -73,6 +73,7 @@ full license. - [50. Synchronization Primitives](#50-synchronization-primitives) - [51. Message Channels](#51-message-channels) - [52. High-Level Threading Utilities](#52-high-level-threading-utilities) +- [53. Shared Code Functions](#53-shared-code-functions) @@ -2993,3 +2994,61 @@ is spawned per element. ;; => ("12" "15" "18") (thread-pool-destroy pool) ``` + +# 53. Shared Code Functions + +When using threads, each thread gets its own independent interpreter +context with its own heap, symbols, and compiled code. Normally this +means every thread must load and compile its own copy of any shared +library code, which is slow and wastes memory. + +The **shared bytecode pool** allows the main thread to publish compiled +functions into a process-wide pool. When a new thread is created with +`THREAD-CREATE`, the shared code is automatically instantiated into +the thread's local context -- each thread gets its own lightweight +wrapper objects but the heavy bytecode data is shared read-only across +all threads. + +These functions require a threaded build (`make THREADS=1`). + +## SHARE-FUNCTION + +```lisp +(SHARE-FUNCTION symbol) +``` + +Publishes the closure bound to *symbol* into the shared bytecode pool. +The closure's compiled code (including nested code objects) is copied +into process-wide shared memory. The symbol name and package are +recorded so that new threads can bind the function to the same name. + +Returns `#t`. + +**Note:** Call `SHARE-FUNCTION` in the main thread *before* creating +child threads. Only closures (compiled functions) can be shared; the +function signals an error if the symbol's value is not a closure. + +```lisp +(define (add1 n) (+ n 1)) +(share-function 'add1) + +;; Child threads will automatically have ADD1 available: +(define h (thread-create "(number->string (add1 41))" #f)) +(thread-join h) ; => #t +``` + +## SHARED-CODE? + +```lisp +(SHARED-CODE?) +``` + +Returns `#t` if the shared bytecode pool contains any published code, +`#f` otherwise. Takes no arguments. + +```lisp +(shared-code?) ; => #f (nothing shared yet) +(define (double x) (* 2 x)) +(share-function 'double) +(shared-code?) ; => #t +``` diff --git a/include/xlisp.h b/include/xlisp.h index 5a798f1..8b73c35 100755 --- a/include/xlisp.h +++ b/include/xlisp.h @@ -210,6 +210,7 @@ typedef unsigned long xlUFIXTYPE; /* node flags */ #define xlMARK 1 #define xlLEFT 2 +#define xlSHARED 4 /* vector data is externally managed (shared pool) */ /* port flags */ #define xlpfINPUT 0x0001 @@ -715,6 +716,7 @@ int xlDecodeInstruction(xlValue fptr,xlValue code,xlFIXTYPE lc,xlValue env); xlEXPORT xlValue xlCons(xlValue x,xlValue y); xlEXPORT xlValue xlNewFrame(int type,xlValue parent,xlFIXTYPE size); xlEXPORT xlValue xlMakeString(const char *str,xlFIXTYPE len); +xlEXPORT xlValue xlMakeExternalString(const unsigned char *data,xlFIXTYPE len); xlEXPORT xlValue xlMakeCString(const char *str); xlEXPORT xlValue xlCopyString(xlValue str); xlEXPORT xlValue xlMakeFileStream(FILE *fp,short flags); diff --git a/include/xlshared.h b/include/xlshared.h new file mode 100644 index 0000000..dbd9d44 --- /dev/null +++ b/include/xlshared.h @@ -0,0 +1,73 @@ +/* xlshared.h - shared bytecode pool for cross-thread code sharing */ +/* Copyright (c) 1984-2002, by David Michael Betz + All Rights Reserved + See the included file 'license.txt' for the full license. +*/ + +#ifndef __XLSHARED_H__ +#define __XLSHARED_H__ + +#include "xlisp.h" + +#ifdef XLISP_USE_CONTEXT + +/* shared literal descriptor types */ +#define xlSL_NIL 0 +#define xlSL_TRUE 1 +#define xlSL_FIXNUM 2 +#define xlSL_FLONUM 3 +#define xlSL_CHAR 4 +#define xlSL_STRING 5 +#define xlSL_SYMBOL 6 +#define xlSL_CODE 7 + +/* a shared literal descriptor */ +typedef struct xlSharedLiteral { + int type; + union { + xlFIXTYPE fixnum; + xlFLOTYPE flonum; + xlCHRTYPE character; + struct { char *data; xlFIXTYPE len; } string; + struct { char *name; char *package; } symbol; + int codeIndex; /* index into templates array for nested code */ + } val; +} xlSharedLiteral; + +/* a shared code template */ +typedef struct xlSharedCodeTemplate { + unsigned char *bytecode; /* shared bytecodes (malloc'd, permanent) */ + xlFIXTYPE bytecodeLen; + char *name; /* function name as C string, or NULL */ + int nlits; /* total code vector size */ + xlSharedLiteral *lits; /* literal descriptors for indices xlFIRSTLIT..nlits-1 */ +} xlSharedCodeTemplate; + +/* a top-level binding: symbol name -> template index */ +typedef struct xlSharedBinding { + char *name; + char *package; + int templateIndex; +} xlSharedBinding; + +/* the global shared code pool */ +typedef struct xlSharedPool { + int nTemplates; + int templateCapacity; + xlSharedCodeTemplate *templates; + int nBindings; + int bindingCapacity; + xlSharedBinding *bindings; +} xlSharedPool; + +/* public API */ +int xlHasSharedCode(void); +void xlLinkSharedCode(void); + +/* Lisp-level built-in functions */ +xlValue xsharefunction(void); +xlValue xsharedcodep(void); + +#endif /* XLISP_USE_CONTEXT */ + +#endif /* __XLSHARED_H__ */ diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 3f195fc..f19a00f 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -20,6 +20,7 @@ set(xlisp_sources xlmain.c xlmath.c xlnthread.c + xlshared.c xlsync.c xlobj.c xlosint.c @@ -29,7 +30,8 @@ set(xlisp_sources "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlisp.h" "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlcontext.h" "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlcompat.h" - "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlthread.h") + "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlthread.h" + "${CMAKE_CURRENT_SOURCE_DIR}/../include/xlshared.h") if(${CMAKE_SYSTEM} STREQUAL Windows) list(APPEND xlisp_sources msstuff.c) diff --git a/src/xldmem.c b/src/xldmem.c index ff1e170..1d1bc8c 100755 --- a/src/xldmem.c +++ b/src/xldmem.c @@ -276,6 +276,34 @@ xlEXPORT xlValue xlNewString(xlFIXTYPE size) return val; } +/* xlMakeExternalString - create a string node backed by external data. + * The data pointer must remain valid for the lifetime of the process. + * The GC will not attempt to move or free the external data. + */ +xlEXPORT xlValue xlMakeExternalString(const unsigned char *data,xlFIXTYPE len) +{ + xlValue val; + + /* get a free node */ + if ((val = xlFNodes) == xlNil) { + findmemory(); + if ((val = xlFNodes) == xlNil) + xlFmtAbort("insufficient node space"); + } + + /* unlink the node from the free list */ + xlFNodes = xlCdr(xlFNodes); + --xlNFree; + + /* initialize as a string node with external data */ + val->type = xlSTRING; + val->flags = xlSHARED; + val->value.vector.size = len; + val->value.vector.data = (xlValue *)data; + + return val; +} + /* xlNewPackage - create a new package */ xlEXPORT xlValue xlNewPackage(const char *name) { diff --git a/src/xlftab.c b/src/xlftab.c index 3c1b8f7..400ee78 100755 --- a/src/xlftab.c +++ b/src/xlftab.c @@ -5,6 +5,9 @@ */ #include "xlisp.h" +#ifdef XLISP_USE_CONTEXT +#include "xlshared.h" +#endif /* normal functions */ static xlSubrDef subrtab[] = { @@ -426,6 +429,12 @@ static xlSubrDef subrtab[] = { { "CHANNEL-OPEN?", xchannelopenp }, { "CHANNEL?", xchannelp }, + /* shared code functions */ +#ifdef XLISP_USE_CONTEXT +{ "SHARE-FUNCTION", xsharefunction }, +{ "SHARED-CODE?", xsharedcodep }, +#endif + {0,0} /* end of table marker */ }; diff --git a/src/xlnthread.c b/src/xlnthread.c index b3db2fd..8e868d8 100644 --- a/src/xlnthread.c +++ b/src/xlnthread.c @@ -5,6 +5,9 @@ */ #include "xlisp.h" +#ifdef XLISP_USE_CONTEXT +#include "xlshared.h" +#endif #ifdef _WIN32 #include @@ -102,6 +105,10 @@ static void *threadWorker(void *arg) INIT_UNLOCK(); + /* link shared code into this thread's context */ + if (xlHasSharedCode()) + xlLinkSharedCode(); + /* evaluate the expression */ if (xlEvaluateCString(&result, 1, info->expr) >= 0) info->status = 1; diff --git a/src/xlshared.c b/src/xlshared.c new file mode 100644 index 0000000..679e6ad --- /dev/null +++ b/src/xlshared.c @@ -0,0 +1,414 @@ +/* xlshared.c - shared bytecode pool for cross-thread code sharing */ +/* Copyright (c) 1984-2002, by David Michael Betz + All Rights Reserved + See the included file 'license.txt' for the full license. +*/ + +#include "xlisp.h" + +#ifdef XLISP_USE_CONTEXT + +#include "xlshared.h" +#include + +#ifdef _WIN32 +#include +#else +#include +#endif + +/* the global shared pool (process-wide, not per-context) */ +static xlSharedPool *sharedPool = NULL; + +/* mutex for pool access */ +#ifdef _WIN32 +static CRITICAL_SECTION poolMutex; +static int poolMutexReady = 0; +static void ensurePoolMutex(void) { + if (!poolMutexReady) { + InitializeCriticalSection(&poolMutex); + poolMutexReady = 1; + } +} +#define POOL_LOCK() do { ensurePoolMutex(); EnterCriticalSection(&poolMutex); } while(0) +#define POOL_UNLOCK() LeaveCriticalSection(&poolMutex) +#else +static pthread_mutex_t poolMutex = PTHREAD_MUTEX_INITIALIZER; +#define POOL_LOCK() pthread_mutex_lock(&poolMutex) +#define POOL_UNLOCK() pthread_mutex_unlock(&poolMutex) +#endif + +/* forward declarations */ +static int publishCodeObject(xlValue code); +static xlValue instantiateTemplate(int templateIndex); +static char *copyString(const char *s); +static void ensurePool(void); +static void ensureTemplateCapacity(void); +static void ensureBindingCapacity(void); + +/* ==================================================================== + * Pool management + * ==================================================================== */ + +static void ensurePool(void) +{ + if (sharedPool == NULL) { + sharedPool = (xlSharedPool *)malloc(sizeof(xlSharedPool)); + if (sharedPool == NULL) + xlFmtAbort("shared pool: out of memory"); + memset(sharedPool, 0, sizeof(xlSharedPool)); + } +} + +static void ensureTemplateCapacity(void) +{ + ensurePool(); + if (sharedPool->nTemplates >= sharedPool->templateCapacity) { + int newCap = sharedPool->templateCapacity == 0 ? 64 : sharedPool->templateCapacity * 2; + xlSharedCodeTemplate *newArr = (xlSharedCodeTemplate *)realloc( + sharedPool->templates, newCap * sizeof(xlSharedCodeTemplate)); + if (newArr == NULL) + xlFmtAbort("shared pool: out of memory"); + sharedPool->templates = newArr; + sharedPool->templateCapacity = newCap; + } +} + +static void ensureBindingCapacity(void) +{ + ensurePool(); + if (sharedPool->nBindings >= sharedPool->bindingCapacity) { + int newCap = sharedPool->bindingCapacity == 0 ? 64 : sharedPool->bindingCapacity * 2; + xlSharedBinding *newArr = (xlSharedBinding *)realloc( + sharedPool->bindings, newCap * sizeof(xlSharedBinding)); + if (newArr == NULL) + xlFmtAbort("shared pool: out of memory"); + sharedPool->bindings = newArr; + sharedPool->bindingCapacity = newCap; + } +} + +static char *copyString(const char *s) +{ + char *copy; + if (s == NULL) + return NULL; + copy = (char *)malloc(strlen(s) + 1); + if (copy == NULL) + xlFmtAbort("shared pool: out of memory"); + strcpy(copy, s); + return copy; +} + +/* ==================================================================== + * Publishing: convert a code object into a shared template + * ==================================================================== */ + +/* get the primary name of a package as a C string */ +static const char *packageName(xlValue pkg) +{ + xlValue names; + if (!xlPackageP(pkg)) + return NULL; + names = xlGetNames(pkg); + if (xlConsP(names) && xlStringP(xlCar(names))) + return xlGetString(xlCar(names)); + return NULL; +} + +/* publish a single code object, returning its template index */ +static int publishCodeObject(xlValue code) +{ + xlSharedCodeTemplate tmpl; + xlValue bcode; + xlFIXTYPE bcLen, nlits, i, numUserLits; + const unsigned char *bcData; + + /* extract bytecodes */ + bcode = xlGetBCode(code); + bcLen = xlGetSLength(bcode); + bcData = xlGetCodeStr(code); + + /* copy bytecodes to shared memory */ + tmpl.bytecode = (unsigned char *)malloc(bcLen); + if (tmpl.bytecode == NULL) + xlFmtAbort("shared pool: out of memory"); + memcpy(tmpl.bytecode, bcData, bcLen); + tmpl.bytecodeLen = bcLen; + + /* extract function name */ + { + xlValue nameVal = xlGetCName(code); + if (xlSymbolP(nameVal)) + tmpl.name = copyString(xlGetString(xlGetPName(nameVal))); + else + tmpl.name = NULL; + } + + /* process literals */ + nlits = xlGetSize(code); + tmpl.nlits = nlits; + numUserLits = nlits - xlFIRSTLIT; + + if (numUserLits > 0) { + tmpl.lits = (xlSharedLiteral *)calloc(numUserLits, sizeof(xlSharedLiteral)); + if (tmpl.lits == NULL) + xlFmtAbort("shared pool: out of memory"); + + for (i = 0; i < numUserLits; i++) { + xlValue lit = xlGetElement(code, xlFIRSTLIT + i); + xlSharedLiteral *sl = &tmpl.lits[i]; + + if (xlNullP(lit)) { + sl->type = xlSL_NIL; + } + else if (lit == xlTrue) { + sl->type = xlSL_TRUE; + } + else if (xlFixnumP(lit)) { + sl->type = xlSL_FIXNUM; + sl->val.fixnum = xlGetFixnum(lit); + } + else if (xlFlonumP(lit)) { + sl->type = xlSL_FLONUM; + sl->val.flonum = xlGetFlonum(lit); + } + else if (xlCharacterP(lit)) { + sl->type = xlSL_CHAR; + sl->val.character = xlGetChCode(lit); + } + else if (xlStringP(lit)) { + xlFIXTYPE slen = xlGetSLength(lit); + sl->type = xlSL_STRING; + sl->val.string.len = slen; + sl->val.string.data = (char *)malloc(slen + 1); + if (sl->val.string.data == NULL) + xlFmtAbort("shared pool: out of memory"); + memcpy(sl->val.string.data, xlGetString(lit), slen); + sl->val.string.data[slen] = '\0'; + } + else if (xlSymbolP(lit)) { + xlValue pkg; + sl->type = xlSL_SYMBOL; + sl->val.symbol.name = copyString(xlGetString(xlGetPName(lit))); + pkg = xlGetPackage(lit); + sl->val.symbol.package = copyString(packageName(pkg)); + } + else if (xlCodeP(lit)) { + /* nested code object - publish recursively */ + sl->type = xlSL_CODE; + sl->val.codeIndex = publishCodeObject(lit); + } + else { + /* unsupported literal type - store as NIL */ + sl->type = xlSL_NIL; + } + } + } + else { + tmpl.lits = NULL; + } + + /* add template to pool */ + ensureTemplateCapacity(); + { + int idx = sharedPool->nTemplates; + sharedPool->templates[idx] = tmpl; + sharedPool->nTemplates++; + return idx; + } +} + +/* ==================================================================== + * Instantiation: create local code objects from a shared template + * ==================================================================== */ + +static xlValue instantiateTemplate(int templateIndex) +{ + xlSharedCodeTemplate *tmpl; + xlValue code; + xlFIXTYPE nlits, i, numUserLits; + + if (sharedPool == NULL || templateIndex < 0 || templateIndex >= sharedPool->nTemplates) + xlFmtError("shared pool: invalid template index"); + + tmpl = &sharedPool->templates[templateIndex]; + nlits = tmpl->nlits; + numUserLits = nlits - xlFIRSTLIT; + + /* create a new code object in the local heap */ + code = xlNewCode(nlits); + xlCPush(code); + + /* create a bytecode string node pointing to shared data */ + { + xlValue bstr = xlMakeExternalString(tmpl->bytecode, tmpl->bytecodeLen); + xlSetBCode(code, bstr); + } + + /* set function name */ + if (tmpl->name != NULL) + xlSetCName(code, xlEnter(tmpl->name)); + + /* set vnames to nil (informational only, used for debugging) */ + xlSetVNames(code, xlNil); + + /* resolve each literal in the local context */ + for (i = 0; i < numUserLits; i++) { + xlSharedLiteral *sl = &tmpl->lits[i]; + xlValue val = xlNil; + + switch (sl->type) { + case xlSL_NIL: + val = xlNil; + break; + case xlSL_TRUE: + val = xlTrue; + break; + case xlSL_FIXNUM: + val = xlMakeFixnum(sl->val.fixnum); + break; + case xlSL_FLONUM: + val = xlMakeFlonum(sl->val.flonum); + break; + case xlSL_CHAR: + val = xlMakeChar(sl->val.character); + break; + case xlSL_STRING: + val = xlMakeString(sl->val.string.data, sl->val.string.len); + break; + case xlSL_SYMBOL: { + xlValue pkg = xlNil; + xlValue key; + if (sl->val.symbol.package != NULL) + pkg = xlFindPackage(sl->val.symbol.package); + if (xlNullP(pkg)) + pkg = xlLispPackage; + val = xlInternCString(sl->val.symbol.name, pkg, &key); + break; + } + case xlSL_CODE: + /* nested code object - instantiate recursively */ + val = instantiateTemplate(sl->val.codeIndex); + break; + } + + xlSetElement(code, xlFIRSTLIT + i, val); + } + + return xlPop(); +} + +/* ==================================================================== + * Linking: install all shared bindings into the current context + * ==================================================================== */ + +/* xlHasSharedCode - check if any shared code is available */ +int xlHasSharedCode(void) +{ + return sharedPool != NULL && sharedPool->nBindings > 0; +} + +/* xlLinkSharedCode - instantiate all shared templates and bind them */ +void xlLinkSharedCode(void) +{ + int i; + + if (!xlHasSharedCode()) + return; + + for (i = 0; i < sharedPool->nBindings; i++) { + xlSharedBinding *binding = &sharedPool->bindings[i]; + xlValue code, closure, sym, pkg, key; + + /* instantiate the code template */ + code = instantiateTemplate(binding->templateIndex); + xlCPush(code); + + /* create a closure with the global environment */ + closure = xlMakeClosure(code, xlNil); + xlCPush(closure); + + /* find or create the symbol and bind it */ + pkg = xlNil; + if (binding->package != NULL) + pkg = xlFindPackage(binding->package); + if (xlNullP(pkg)) + pkg = xlLispPackage; + sym = xlInternCString(binding->name, pkg, &key); + xlSetValue(sym, closure); + + xlDrop(2); + } +} + +/* ==================================================================== + * Lisp-level built-in functions + * ==================================================================== */ + +/* xsharefunction - built-in function 'share-function' */ +/* (share-function sym) => #t */ +xlValue xsharefunction(void) +{ +#ifdef XLISP_USE_CONTEXT + xlValue sym, val, code; + const char *symName; + const char *pkgName; + xlValue pkg; + int templateIndex; + + /* get the symbol argument */ + sym = xlGetArgSymbol(); + xlLastArg(); + + /* get the symbol's value - must be a closure */ + val = xlGetValue(sym); + if (!xlClosureP(val)) + xlError("not a closure", val); + + /* extract the code object from the closure */ + code = xlGetCode(val); + if (!xlCodeP(code)) + xlError("closure does not contain a code object", val); + + /* publish the code object to the shared pool */ + POOL_LOCK(); + + templateIndex = publishCodeObject(code); + + /* record the binding */ + symName = xlGetString(xlGetPName(sym)); + pkg = xlGetPackage(sym); + pkgName = packageName(pkg); + + ensureBindingCapacity(); + { + xlSharedBinding *b = &sharedPool->bindings[sharedPool->nBindings]; + b->name = copyString(symName); + b->package = copyString(pkgName); + b->templateIndex = templateIndex; + sharedPool->nBindings++; + } + + POOL_UNLOCK(); + + return xlTrue; +#else + xlFmtError("share-function requires a threaded build (THREADS=1)"); + return xlNil; +#endif +} + +/* xsharedcodep - built-in function 'shared-code?' */ +/* (shared-code?) => #t or #f */ +xlValue xsharedcodep(void) +{ + xlLastArg(); +#ifdef XLISP_USE_CONTEXT + return xlHasSharedCode() ? xlTrue : xlNil; +#else + return xlNil; +#endif +} + +#endif /* XLISP_USE_CONTEXT */ diff --git a/tests/test_shared.lsp b/tests/test_shared.lsp new file mode 100644 index 0000000..1440fe3 --- /dev/null +++ b/tests/test_shared.lsp @@ -0,0 +1,623 @@ +;; Exhaustive tests for the shared bytecode pool feature +;; Requires: make THREADS=1 +;; Run with: bin/xlisp tests/test_shared.lsp + +(define pass-count 0) +(define fail-count 0) + +(define (check name result) + (if result + (begin (set! pass-count (+ pass-count 1)) + (display " PASS: ") (display name) (newline)) + (begin (set! fail-count (+ fail-count 1)) + (display " FAIL: ") (display name) (newline)))) + +;; ============================================================ +(display "=== 1. shared-code? predicate (empty pool) ===") (newline) +;; ============================================================ + +(check "shared-code? initially #f" (not (shared-code?))) +(check "shared-code? returns boolean" (eq? #f (shared-code?))) + +;; ============================================================ +(display "=== 2. share-function basic operations ===") (newline) +;; ============================================================ + +;; Simple function +(define (add1 n) (+ n 1)) +(check "share-function returns #t" (eq? #t (share-function 'add1))) +(check "shared-code? after share" (shared-code?)) + +;; Original function still works in main thread +(check "original add1 still works" (= 6 (add1 5))) + +;; Share another function +(define (double n) (* 2 n)) +(share-function 'double) +(check "double still works after sharing" (= 20 (double 10))) + +;; ============================================================ +(display "=== 3. share-function error handling ===") (newline) +;; ============================================================ + +;; Sharing a non-closure should signal an error +(define not-a-closure 42) +(define share-error-caught #f) +(catch 'error + (share-function 'not-a-closure)) +(set! share-error-caught #t) +(check "share-function rejects non-closure" share-error-caught) + +;; Sharing an unbound symbol should signal an error +(define share-unbound-error #f) +(catch 'error + (share-function 'this-symbol-is-not-bound-anywhere)) +(set! share-unbound-error #t) +(check "share-function rejects unbound symbol" share-unbound-error) + +;; ============================================================ +(display "=== 4. Basic thread with shared code ===") (newline) +;; ============================================================ + +;; Child thread should have add1 available without defining it +(define h1 (thread-create "(number->string (add1 99))" #f)) +(check "thread with shared add1 joins" (thread-join h1)) + +;; Child thread should have double available +(define h2 (thread-create "(number->string (double 21))" #f)) +(check "thread with shared double joins" (thread-join h2)) + +;; ============================================================ +(display "=== 5. Verify shared code produces correct results ===") (newline) +;; ============================================================ + +;; Use a channel to get the result back from the child thread +(define ch1 (channel-create "result1")) + +(define h3 (thread-create + "(begin (define ch (channel-lookup \"result1\")) (channel-send ch (number->string (add1 41))))" + #f)) +(define r3 (channel-receive ch1)) +(check "shared add1 returns correct value" (equal? "42" r3)) +(thread-join h3) +(channel-destroy ch1) + +(define ch2 (channel-create "result2")) +(define h4 (thread-create + "(begin (define ch (channel-lookup \"result2\")) (channel-send ch (number->string (double 25))))" + #f)) +(define r4 (channel-receive ch2)) +(check "shared double returns correct value" (equal? "50" r4)) +(thread-join h4) +(channel-destroy ch2) + +;; ============================================================ +(display "=== 6. Shared function with multiple arguments ===") (newline) +;; ============================================================ + +(define (add a b) (+ a b)) +(share-function 'add) + +(define ch3 (channel-create "result3")) +(define h5 (thread-create + "(begin (define ch (channel-lookup \"result3\")) (channel-send ch (number->string (add 17 25))))" + #f)) +(check "shared multi-arg: correct result" (equal? "42" (channel-receive ch3))) +(thread-join h5) +(channel-destroy ch3) + +;; ============================================================ +(display "=== 7. Shared function with various literal types ===") (newline) +;; ============================================================ + +;; Function that uses string literals +(define (greet name) (string-append "Hello, " name "!")) +(share-function 'greet) + +(define ch4 (channel-create "result4")) +(define h6 (thread-create + "(begin (define ch (channel-lookup \"result4\")) (channel-send ch (greet \"World\")))" + #f)) +(check "shared fn with string literal" (equal? "Hello, World!" (channel-receive ch4))) +(thread-join h6) +(channel-destroy ch4) + +;; Function that uses fixnum literals +(define (add-hundred n) (+ n 100)) +(share-function 'add-hundred) + +(define ch5 (channel-create "result5")) +(define h7 (thread-create + "(begin (define ch (channel-lookup \"result5\")) (channel-send ch (number->string (add-hundred 23))))" + #f)) +(check "shared fn with fixnum literal" (equal? "123" (channel-receive ch5))) +(thread-join h7) +(channel-destroy ch5) + +;; Function that uses flonum literals +(define (add-pi n) (+ n 3.14159)) +(share-function 'add-pi) + +(define ch6 (channel-create "result6")) +(define h8 (thread-create + "(begin (define ch (channel-lookup \"result6\")) (channel-send ch (number->string (add-pi 0.0))))" + #f)) +(define r6 (channel-receive ch6)) +(check "shared fn with flonum literal" (equal? "3.14159" r6)) +(thread-join h8) +(channel-destroy ch6) + +;; Function that uses character literals +(define (char-test) (string #\A #\B #\C)) +(share-function 'char-test) + +(define ch6b (channel-create "result6b")) +(define h8b (thread-create + "(begin (define ch (channel-lookup \"result6b\")) (channel-send ch (char-test)))" + #f)) +(check "shared fn with character literals" (equal? "ABC" (channel-receive ch6b))) +(thread-join h8b) +(channel-destroy ch6b) + +;; Function that uses boolean literals +(define (bool-test x) (if (> x 0) #t #f)) +(share-function 'bool-test) + +(define ch6c (channel-create "result6c")) +(define h8c (thread-create + "(begin (define ch (channel-lookup \"result6c\")) (channel-send ch (if (bool-test 5) \"yes\" \"no\")))" + #f)) +(check "shared fn with #t literal" (equal? "yes" (channel-receive ch6c))) +(thread-join h8c) +(channel-destroy ch6c) + +(define ch6d (channel-create "result6d")) +(define h8d (thread-create + "(begin (define ch (channel-lookup \"result6d\")) (channel-send ch (if (bool-test -1) \"yes\" \"no\")))" + #f)) +(check "shared fn with #f result" (equal? "no" (channel-receive ch6d))) +(thread-join h8d) +(channel-destroy ch6d) + +;; Function that uses nil +(define (nil-test) (if (null? '()) "nil" "not-nil")) +(share-function 'nil-test) + +(define ch6e (channel-create "result6e")) +(define h8e (thread-create + "(begin (define ch (channel-lookup \"result6e\")) (channel-send ch (nil-test)))" + #f)) +(check "shared fn with nil literal" (equal? "nil" (channel-receive ch6e))) +(thread-join h8e) +(channel-destroy ch6e) + +;; ============================================================ +(display "=== 8. Recursive shared function ===") (newline) +;; ============================================================ + +(define (fact n) (if (< n 2) 1 (* n (fact (- n 1))))) +(share-function 'fact) + +(define ch7 (channel-create "result7")) +(define h9 (thread-create + "(begin (define ch (channel-lookup \"result7\")) (channel-send ch (number->string (fact 10))))" + #f)) +(check "shared recursive fn" (equal? "3628800" (channel-receive ch7))) +(thread-join h9) +(channel-destroy ch7) + +;; Fibonacci +(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) +(share-function 'fib) + +(define ch8 (channel-create "result8")) +(define h10 (thread-create + "(begin (define ch (channel-lookup \"result8\")) (channel-send ch (number->string (fib 20))))" + #f)) +(check "shared fibonacci fn" (equal? "6765" (channel-receive ch8))) +(thread-join h10) +(channel-destroy ch8) + +;; ============================================================ +(display "=== 9. Shared function with nested code (lambda) ===") (newline) +;; ============================================================ + +(define (make-adder n) (lambda (x) (+ n x))) +(share-function 'make-adder) + +(define ch9 (channel-create "result9")) +(define h11 (thread-create + "(begin (define ch (channel-lookup \"result9\")) (define add5 (make-adder 5)) (channel-send ch (number->string (add5 37))))" + #f)) +(check "shared fn returning closure" (equal? "42" (channel-receive ch9))) +(thread-join h11) +(channel-destroy ch9) + +;; ============================================================ +(display "=== 10. Shared function calling another shared function ===") (newline) +;; ============================================================ + +;; add1 and double are already shared +(define (add1-then-double n) (double (add1 n))) +(share-function 'add1-then-double) + +(define ch10 (channel-create "result10")) +(define h12 (thread-create + "(begin (define ch (channel-lookup \"result10\")) (channel-send ch (number->string (add1-then-double 20))))" + #f)) +(check "shared fn calls other shared fn" (equal? "42" (channel-receive ch10))) +(thread-join h12) +(channel-destroy ch10) + +;; ============================================================ +(display "=== 11. Multiple threads using same shared code ===") (newline) +;; ============================================================ + +(define ch11a (channel-create "result11a")) +(define ch11b (channel-create "result11b")) +(define ch11c (channel-create "result11c")) + +(define h13a (thread-create + "(begin (define ch (channel-lookup \"result11a\")) (channel-send ch (number->string (fact 8))))" + #f)) +(define h13b (thread-create + "(begin (define ch (channel-lookup \"result11b\")) (channel-send ch (number->string (fact 9))))" + #f)) +(define h13c (thread-create + "(begin (define ch (channel-lookup \"result11c\")) (channel-send ch (number->string (fact 10))))" + #f)) + +(check "concurrent thread A using shared fn" (equal? "40320" (channel-receive ch11a))) +(check "concurrent thread B using shared fn" (equal? "362880" (channel-receive ch11b))) +(check "concurrent thread C using shared fn" (equal? "3628800" (channel-receive ch11c))) + +(thread-join h13a) +(thread-join h13b) +(thread-join h13c) +(channel-destroy ch11a) +(channel-destroy ch11b) +(channel-destroy ch11c) + +;; ============================================================ +(display "=== 12. Shared code with list argument (thread-create) ===") (newline) +;; ============================================================ + +;; thread-create also accepts a list form +(define ch12 (channel-create "result12")) +(define h14 (thread-create + '(begin (define ch (channel-lookup "result12")) (channel-send ch (number->string (add1 99)))) + #f)) +(check "list-form thread-create with shared fn" (equal? "100" (channel-receive ch12))) +(thread-join h14) +(channel-destroy ch12) + +;; ============================================================ +(display "=== 13. Shared higher-order function ===") (newline) +;; ============================================================ + +(define (apply-twice f x) (f (f x))) +(share-function 'apply-twice) + +(define ch13 (channel-create "result13")) +(define h15 (thread-create + "(begin (define ch (channel-lookup \"result13\")) (channel-send ch (number->string (apply-twice add1 5))))" + #f)) +(check "shared higher-order fn" (equal? "7" (channel-receive ch13))) +(thread-join h15) +(channel-destroy ch13) + +;; ============================================================ +(display "=== 14. Shared function with conditional logic ===") (newline) +;; ============================================================ + +(define (classify n) + (cond ((< n 0) "negative") + ((= n 0) "zero") + ((< n 10) "small") + ((< n 100) "medium") + (else "large"))) +(share-function 'classify) + +(define ch14a (channel-create "result14a")) +(define ch14b (channel-create "result14b")) +(define ch14c (channel-create "result14c")) +(define ch14d (channel-create "result14d")) +(define ch14e (channel-create "result14e")) + +(define h16a (thread-create + "(begin (define ch (channel-lookup \"result14a\")) (channel-send ch (classify -5)))" #f)) +(define h16b (thread-create + "(begin (define ch (channel-lookup \"result14b\")) (channel-send ch (classify 0)))" #f)) +(define h16c (thread-create + "(begin (define ch (channel-lookup \"result14c\")) (channel-send ch (classify 7)))" #f)) +(define h16d (thread-create + "(begin (define ch (channel-lookup \"result14d\")) (channel-send ch (classify 42)))" #f)) +(define h16e (thread-create + "(begin (define ch (channel-lookup \"result14e\")) (channel-send ch (classify 999)))" #f)) + +(check "classify negative" (equal? "negative" (channel-receive ch14a))) +(check "classify zero" (equal? "zero" (channel-receive ch14b))) +(check "classify small" (equal? "small" (channel-receive ch14c))) +(check "classify medium" (equal? "medium" (channel-receive ch14d))) +(check "classify large" (equal? "large" (channel-receive ch14e))) + +(thread-join h16a) (thread-join h16b) (thread-join h16c) +(thread-join h16d) (thread-join h16e) +(channel-destroy ch14a) (channel-destroy ch14b) (channel-destroy ch14c) +(channel-destroy ch14d) (channel-destroy ch14e) + +;; ============================================================ +(display "=== 15. Shared function with let/let* bindings ===") (newline) +;; ============================================================ + +(define (hypotenuse a b) + (let ((a2 (* a a)) + (b2 (* b b))) + (sqrt (+ a2 b2)))) +(share-function 'hypotenuse) + +(define ch15 (channel-create "result15")) +(define h17 (thread-create + "(begin (define ch (channel-lookup \"result15\")) (channel-send ch (number->string (hypotenuse 3.0 4.0))))" + #f)) +(check "shared fn with let bindings" (equal? "5" (channel-receive ch15))) +(thread-join h17) +(channel-destroy ch15) + +;; ============================================================ +(display "=== 16. Shared function with string operations ===") (newline) +;; ============================================================ + +(define (shout s) + (string-append "*** " s " ***")) +(share-function 'shout) + +(define ch16 (channel-create "result16")) +(define h18 (thread-create + "(begin (define ch (channel-lookup \"result16\")) (channel-send ch (shout \"HELLO\")))" + #f)) +(check "shared fn with string ops" (equal? "*** HELLO ***" (channel-receive ch16))) +(thread-join h18) +(channel-destroy ch16) + +;; ============================================================ +(display "=== 17. Many shared functions ===") (newline) +;; ============================================================ + +;; Share a batch of simple functions +(define (sf-add a b) (+ a b)) +(define (sf-sub a b) (- a b)) +(define (sf-mul a b) (* a b)) +(define (sf-neg n) (- 0 n)) +(define (sf-abs n) (if (< n 0) (- 0 n) n)) +(define (sf-max a b) (if (> a b) a b)) +(define (sf-min a b) (if (< a b) a b)) +(define (sf-square n) (* n n)) +(define (sf-cube n) (* n n n)) +(define (sf-zero? n) (= n 0)) + +(share-function 'sf-add) +(share-function 'sf-sub) +(share-function 'sf-mul) +(share-function 'sf-neg) +(share-function 'sf-abs) +(share-function 'sf-max) +(share-function 'sf-min) +(share-function 'sf-square) +(share-function 'sf-cube) +(share-function 'sf-zero?) + +(define ch17 (channel-create "result17")) +(define h19 (thread-create + "(begin + (define ch (channel-lookup \"result17\")) + (channel-send ch (number->string (sf-add 10 20))) + (channel-send ch (number->string (sf-sub 50 8))) + (channel-send ch (number->string (sf-mul 6 7))) + (channel-send ch (number->string (sf-neg 42))) + (channel-send ch (number->string (sf-abs -99))) + (channel-send ch (number->string (sf-max 10 20))) + (channel-send ch (number->string (sf-min 10 20))) + (channel-send ch (number->string (sf-square 9))) + (channel-send ch (number->string (sf-cube 3))) + (channel-send ch (if (sf-zero? 0) \"yes\" \"no\")))" + #f)) + +(check "many shared: add" (equal? "30" (channel-receive ch17))) +(check "many shared: sub" (equal? "42" (channel-receive ch17))) +(check "many shared: mul" (equal? "42" (channel-receive ch17))) +(check "many shared: neg" (equal? "-42" (channel-receive ch17))) +(check "many shared: abs" (equal? "99" (channel-receive ch17))) +(check "many shared: max" (equal? "20" (channel-receive ch17))) +(check "many shared: min" (equal? "10" (channel-receive ch17))) +(check "many shared: square" (equal? "81" (channel-receive ch17))) +(check "many shared: cube" (equal? "27" (channel-receive ch17))) +(check "many shared: zero?" (equal? "yes" (channel-receive ch17))) + +(thread-join h19) +(channel-destroy ch17) + +;; ============================================================ +(display "=== 18. Stress: many threads sharing same code ===") (newline) +;; ============================================================ + +(define stress-ch (channel-create "stress")) +(define stress-handles '()) + +;; Spawn 10 threads that all use shared fact +(let loop ((i 1)) + (if (<= i 10) + (begin + (let ((h (thread-create + (string-append "(begin (define ch (channel-lookup \"stress\")) (channel-send ch (number->string (fact " (number->string i) "))))") + #f))) + (set! stress-handles (cons h stress-handles))) + (loop (+ i 1))))) + +;; Collect results (order not guaranteed, so just count correct ones) +(define stress-expected '()) +(let loop ((i 1)) + (if (<= i 10) + (begin + (set! stress-expected (cons (number->string (fact i)) stress-expected)) + (loop (+ i 1))))) + +(define stress-results '()) +(let loop ((i 0)) + (if (< i 10) + (begin + (set! stress-results (cons (channel-receive stress-ch) stress-results)) + (loop (+ i 1))))) + +;; Check that we got all expected values (sort both and compare) +(define (sort-strings lst) + (if (or (null? lst) (null? (cdr lst))) + lst + (let* ((pivot (car lst)) + (rest (cdr lst)) + (less '()) + (greater '())) + (let loop ((r rest)) + (if (null? r) #f + (begin + (if (stringstring (fib 15))))" + #f)) +(check "new thread still gets shared code" (equal? "610" (channel-receive ch19))) +(thread-join h20) +(channel-destroy ch19) + +;; ============================================================ +(display "=== 20. Shared function with do loop ===") (newline) +;; ============================================================ + +(define (sum-to n) + (do ((i 0 (+ i 1)) + (s 0 (+ s i))) + ((> i n) s))) +(share-function 'sum-to) + +(define ch20 (channel-create "result20")) +(define h21 (thread-create + "(begin (define ch (channel-lookup \"result20\")) (channel-send ch (number->string (sum-to 100))))" + #f)) +(check "shared fn with do loop" (equal? "5050" (channel-receive ch20))) +(thread-join h21) +(channel-destroy ch20) + +;; ============================================================ +(display "=== 21. Shared function with list processing ===") (newline) +;; ============================================================ + +(define (my-length lst) + (if (null? lst) 0 (+ 1 (my-length (cdr lst))))) +(share-function 'my-length) + +(define ch21 (channel-create "result21")) +(define h22 (thread-create + "(begin (define ch (channel-lookup \"result21\")) (channel-send ch (number->string (my-length '(a b c d e)))))" + #f)) +(check "shared fn with list processing" (equal? "5" (channel-receive ch21))) +(thread-join h22) +(channel-destroy ch21) + +;; ============================================================ +(display "=== 22. Shared mutually-dependent functions ===") (newline) +;; ============================================================ + +;; Two functions that call each other (via shared bindings) +(define (my-even? n) + (if (= n 0) #t (my-odd? (- n 1)))) +(define (my-odd? n) + (if (= n 0) #f (my-even? (- n 1)))) +(share-function 'my-even?) +(share-function 'my-odd?) + +(define ch22 (channel-create "result22")) +(define h23 (thread-create + "(begin + (define ch (channel-lookup \"result22\")) + (channel-send ch (if (my-even? 10) \"yes\" \"no\")) + (channel-send ch (if (my-odd? 10) \"yes\" \"no\")) + (channel-send ch (if (my-even? 7) \"yes\" \"no\")) + (channel-send ch (if (my-odd? 7) \"yes\" \"no\")))" + #f)) + +(check "mutual recursion: even? 10" (equal? "yes" (channel-receive ch22))) +(check "mutual recursion: odd? 10" (equal? "no" (channel-receive ch22))) +(check "mutual recursion: even? 7" (equal? "no" (channel-receive ch22))) +(check "mutual recursion: odd? 7" (equal? "yes" (channel-receive ch22))) + +(thread-join h23) +(channel-destroy ch22) + +;; ============================================================ +(display "=== 23. Share function that uses apply ===") (newline) +;; ============================================================ + +(define (sum-list lst) + (apply + lst)) +(share-function 'sum-list) + +(define ch23 (channel-create "result23")) +(define h24 (thread-create + "(begin (define ch (channel-lookup \"result23\")) (channel-send ch (number->string (sum-list '(1 2 3 4 5)))))" + #f)) +(check "shared fn using apply" (equal? "15" (channel-receive ch23))) +(thread-join h24) +(channel-destroy ch23) + +;; ============================================================ +(display "=== 24. Shared function with tail recursion ===") (newline) +;; ============================================================ + +(define (tail-sum n acc) + (if (= n 0) acc (tail-sum (- n 1) (+ acc n)))) +(share-function 'tail-sum) + +(define ch24 (channel-create "result24")) +(define h25 (thread-create + "(begin (define ch (channel-lookup \"result24\")) (channel-send ch (number->string (tail-sum 1000 0))))" + #f)) +(check "shared tail-recursive fn" (equal? "500500" (channel-receive ch24))) +(thread-join h25) +(channel-destroy ch24) + +;; ============================================================ +;; Summary +;; ============================================================ +(newline) +(display "=== Results: ") +(display pass-count) (display " passed, ") +(display fail-count) (display " failed ===") (newline) + +(exit)