Add exception handler fix

* tests/base.scm: add two tests for issue #556

The two tests are adapted from issue #556 (originally from r7rs).
The tests currently fail because errors and raised objects are
treated in the same way.

* Use different tags for raised objects and raised errors

The behaviour for raising an error (error message irritants) and
objects (raise object) are different in r7rs. So tag error objects
differently, and adjust the raised object handling to handle
the raised object instead of a list containing the raised object.

This should resolve issue #556.

* runtime: use the correct string length for comparison

Fix for the pull request adressing issue #556.

* runtime: distinguish exceptions and errors in default handler

* repl: use error-object? to decide whether an error or an exception was raised

This makes error messages a bit more informative.  Also, if error objects become
a distinct type, then the repl implementation will continue to be correct. The
(deleted) second cond clause seemed to be bit redundant - I am not sure what the
original intent was.

* tests/base.scm: revert accidental deletion of else clause

* Display exceptions as errors for consistency

.github/workflows/c-api-docs.yml

@@ -21,7 +21,7 @@ jobs:
             
     - name: upload deb
       if: matrix.arch == '64'
-      uses: actions/upload-artifact@v1
+      uses: actions/upload-artifact@v4
       with:
         name: cyclone-scheme docs
         path: html.tar.bz2

.github/workflows/c-runtime-unit-tests.yml

@@ -0,0 +1,27 @@
+name: C Runtime Unit Tests
+
+#on: [create]
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+    
+    strategy:    
+      matrix:
+        arch: [64]
+    
+    steps:
+    # Install dependencies
+    - name: Install libck
+      run: sudo apt-get install libck-dev    
+    #- name: Install Cyclone
+    #  run: |
+    #    wget https://github.com/cyclone-scheme/binary-releases/raw/master/ubuntu-18.04-lts/cyclone-scheme_0.30.0_amd64.deb 
+    #    sudo apt install ./cyclone-scheme_0.30.0_amd64.deb
+    - uses: actions/checkout@v1
+
+    # Execute runtime library unit tests
+    - name: make test-lib
+      run: make libcyclone.a && make test-lib && ./test-lib

.github/workflows/ci.yml

@@ -0,0 +1,22 @@
+name: Ubuntu Linux Build
+
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+    
+    strategy:    
+      matrix:
+        arch: [32, 64]
+    
+    steps:
+    - uses: actions/checkout@v1
+    - name: Install deps
+      run: sudo apt-get install indent
+    - name: Install ck
+      run: sudo apt-get install libck-dev
+    - name: make runtime
+      run: make libcyclone.a
+            

.github/workflows/formatting.yml

@@ -0,0 +1,21 @@
+name: Code Formatting
+
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+    
+    strategy:    
+      matrix:
+        arch: [64]
+    
+    steps:
+    - uses: actions/checkout@v1
+    - name: Install deps
+      run: sudo apt-get install -y indent
+    - name: formatting
+      run: |
+        make test-format 
+            

Architecture.md

@@ -0,0 +1,71 @@
+** This document is incomplete and a work in progress **
+
+# High level design
+
+Cyclone has a similar architecture to other modern compilers:
+
+<img src="docs/images/compiler.png" alt="flowchart of cyclone compiler">
+
+First, an input file containing Scheme code is received on the command line and loaded into an abstract syntax tree (AST) by Cyclone's parser. From there a series of source-to-source transformations are performed on the AST to expand macros, perform optimizations, and make the code easier to compile to C. These intermediate representations (IR) can be printed out in a readable format to aid debugging. The final AST is then output as a `.c` file and the C compiler is invoked to create the final executable or object file.
+
+Programs are linked with the necessary Scheme libraries and the Cyclone runtime library to create an executable:
+
+<img src="docs/images/runtime.png" alt="Diagram of files linked into a compiled executable">
+
+For more high-level overview of the project a good place to start is [Writing the Cyclone Scheme Compiler](docs/Writing-the-Cyclone-Scheme-Compiler-Revised-2017.md).
+
+# Code Map
+
+This section provides an overview of the code and module layout used by Cyclone. The [API Documentation](docs/API.md) provides more details on individual modules within these directories as well as code-level API documentation.
+
+## `scheme/`
+
+Code for the built-in Scheme standard libraries lives at the top level of this directory. In general all of the code here is written to conform to the Scheme R7RS specification.
+
+## `scheme/cyclone`
+
+Scheme code for the Cyclone compiler itself lives here as a set of libraries.
+
+There are front-end programs at the top-level of the Cyclone repository that use these libraries:
+
+- `cyclone.scm` for the compiler
+- `icyc.scm` for the interpreter
+
+## `srfi/`
+
+Implementations of various Scheme SRFI's that are distributed directly with Cyclone.
+
+In general the recommended way to distribute SRFI's is to use the Winds package manager. At this point there would need to be a very good reason to include a new SRFI here in the main Cyclone repository.
+
+## `runtime.c`
+
+Most of the code for the C runtime lives here including primitives and the minor GC.
+
+Code here is often written in a continuation passing style because Cheney on the MTA is used as the minor garbage collecting mechanism.
+
+TODO: for example
+
+## `gc.c`
+
+Module for the major garbage collector.
+
+For comprehensive design documentation on the major collector see the [Garbage Collector](Garbage-Collector-Revised-2022.md) documentation.
+
+## `mstreams.c`
+
+Code for in-memory streams. Some of this is platform-specific.
+
+# Setting up a Development Environment
+
+See the [Development Guide](docs/Development.md).
+
+This includes instructions on building and debugging the compiler.
+
+# Building
+
+
+# Debugging
+
+TBD: compiler flags, compilation settings, what else?
+TODO: just include in dev guide
+

CHANGELOG.md

@@ -1,5 +1,151 @@
 # Changelog
 
+## 0.37.0 - TBD
+
+Bug Fixes
+
+- Yorick Hardy fixed the runtime to return the appropriate types of objects to exception handlers.
+- Yorick Hardy modified the runtime to allow `thread-terminate!` to take a thread object as an argument, per SRFI 18.
+- @nmeum fixed `open_memstream`/`fmemopen` feature detection with GCC >= 14.
+- Fixed a bug in `apply` where an error may be raised when processing quoted sub-expressions. For example the following would throw an error: `(apply cons '(5 (1 2)))`. Thanks to @srgx for the bug report!
+- Fixed a beta expansion optimization bug where code such as the following would cause the compiler to hang. Thanks to Yorick Hardy for the bug report:
+
+      (define (compile-forever x) x (compile-forever x))
+
+- Added a fix from Yorick Hardy to define `*ai-v4mapped*` to zero on platforms where `AI_V4MAPPED` is undefined.
+- Updated `sqrt` to properly handle complex results given non-complex input. EG: `(sqrt -1) ==> 1i`. And updated the parser to properly handle `+i` and `-i`. Thanks to Christopher Hebert for the bug reports!
+- Updated `cond-expand` to raise an error if no clauses match, instead of returning `#t`.
+
+## 0.36.0 - February 14, 2024
+
+Features
+
+- Enhanced the reader to parse rationals and store them as inexact numbers.
+- Add a stub for `(rationalize x y)` to `(scheme base)`.
+
+Bug Fixes
+
+- Yorick Hardy provided a fix to `round` so that Cyclone will round to even when x is halfway between two integers, as required by R7RS.
+- Updated various numeric functions to properly handle numeric type conversions, including `quotient`, `remainder`, `numerator`, `denominator`, `truncate`, `truncate-quotient`, and `/`.
+- Fix `exact` to properly handle complex numbers, including raising an error when passed `nan` or `inf` double values.
+- Ensure the runtime properly differentiates between `+inf.0` and `-inf.0`. Thanks to jpellegrini for the bug report.
+- jpellegrini reported that Cyclone returns `#f` when comparing complex numbers using operators other than `=`. Instead it is better to raise an error in these situations.
+- lassik and jpellegrini reported that `abs` was incorrectly returning the real part of a complex number argument. Modified `abs` to properly handle complex numbers.
+- jpellegrini fixed `(srfi 143)` so that the following are constants instead of procedures: `fx-width`, `fx-greatest`, and `fx-least`.
+- Raise an error if `odd?` or `even?` is passed a decimal number. Thanks to jpellegrini for the bug report.
+- Fix `read-line` to read entire lines that consist of more than 1022 bytes. Previously the function would only return partial data up to this limit. Thanks to Robby Zambito for the bug report.
+- `(include "body.scm")` inside a file `path/to/lib.sld` will look for `path/to/body.scm`, then fallback to the legacy behavior, and look for `$(pwd)/body.scm`.
+- Pass append and prepend directories when compiling dependent libraries of a program. This prevents issues where the directories are not made available to any `include` directives within such libraries.
+- Updated the reader to throw an error if a number cannot be parsed, rather than returning `#f`.
+
+## 0.35.0 - August 25, 2022
+
+Features
+
+- Arthur Maciel added `make-opaque` to `(cyclone foreign)`.
+- Add `memory-streams` to the list of symbols that `(features)` can return, indicating that the current installation supports in-memory streams.
+
+Bug Fixes
+
+- Prevent an error when evaluating a `begin` expression that contains both a macro definition and an application of that macro. For example:
+
+      begin (define-syntax foo (syntax-rules () ((foo) 123))) (foo))
+
+- Fix a regression where `c-compiler-options` was not recognized as a top level form by programs.
+- Enforce a maximum recursion depth when printing an object via `display` or `write`, and when comparing objects via `equal?`. This prevents segmentation faults when working with circular data structures.
+- Added proper implementations of `assv` and `memv`. Both were previously implemented in terms of `assq` and `memq`, respectively.
+
+## 0.34.0 - January 2, 2022
+
+Features
+
+- Separate include/library search directory options from "normal" compiler/linker options and place options passed via the `-COPT`/`-CLNK` command-line flags in-between. This allows overwriting the default search paths, since contrary to all other options, the search paths must be prepend for an `-I`/`-L` option to take precedence over an existing one.
+
+Bug Fixes
+
+- Prevent segmentation faults in the runtime when setting a global variable to itself.
+- Do not throw an error when exporting a primitive that is not defined in the current module, as built-ins are always available in any context.
+
+## 0.33.0 - September 24, 2021
+
+Features
+
+- Allow easier macro debugging from the REPL by using `expand`. Passing a single expression as an argument will return the expanded expression:
+
+      cyclone> (expand '(when #t (+ 1 2 3)))
+      (if #t ((lambda () (+ 1 2 3))) )
+
+- During compilation the compiler will now call itself as a subprocess to perform Scheme-to-C compilation. This allows Cyclone to free all of those resources before calling the C compiler to generate a binary, resulting in more efficient compilation.
+
+Bug Fixes
+
+- Do not inline calls to `system` as it could result in multiple calls of the same command.
+
+## 0.32.0 - August 16, 2021
+
+Features
+
+- Initiate major garbage collections faster after allocating a huge object (larger than 500K). This allows the system to reclaim the memory faster and keep overall memory usage low for certain workloads.
+- Cyclone will no longer memoize pure functions by default.
+- Added build option `CYC_PTHREAD_SET_STACK_SIZE` to allow Cyclone to specify a thread stack size rather than using the OS default. EG:
+
+      make CYC_PTHREAD_SET_STACK_SIZE=1 libcyclone.a
+
+Bug Fixes
+
+- @nmeum fixed `(scheme repl)` to flush the output port prior to writing the prompt, guaranteeing the prompt is written at the correct time. 
+- Fixed `fxbit-set?` to properly handle negative values of `i`.
+- Avoid unnecessary renaming of identifiers when the interpreter performs macro expansion.
+- When allocating a large vector we now guarantee all vector elements are initialized before the major collector can trace those elements. This avoids the potential for a race condition which could lead to a segmentation fault.
+- Ensure atomic objects are properly traced by the major garbage collector.
+
+## 0.31.0 - July 27, 2021
+
+### Bug Fixes
+
+#### Compiler
+
+- Properly handle vectors literals at the top level of compiled code. Previously this could lead to segmentation faults (!!) at runtime.
+- Fixed an off-by-one error unpacking arguments when calling a primitive as the continuation after a garbage collection.
+
+#### Base Library
+
+- Fixed `read-line` to prevent data loss when used in conjunction with other I/O functions (such as `read-char`) to read data from the same port. This was because the previous version of `read-line` used a different internal buffer than our other I/O functions.
+- Fixed a bug in `make-list` that consumed all available memory when passing a negative list length.
+- Allow a record type to contain fields that are not initialized by the constructor.
+- Built out `numerator` and `denominator` with code conforming to R7RS.
+
+#### SRFI 18 - Multithreading Library
+
+- Updated `thread-start!` to return the given thread object, per SRFI 18.
+- `thread-join!` now returns the result of the thread it was waiting on, per SRFI 18.
+
+#### C Compiler Warnings
+
+- Eliminate clang compiler warnings referencing `EOF` when building the runtime.
+- Updated runtime so the C compiler will no longer generate warnings regarding the string comparisons in `Cyc_st_add`. Previously this could result in these warnings being spammed to the console when compiling code using Cyclone.
+- Properly escape question marks within strings in generated C code to avoid trigraphs.
+- Avoid an "unused variable" warning from the C compiler when compiling certain recursive functions.
+
+## 0.30.0 - July 2, 2021
+
+Features
+
+- Support semantic versioning of winds packages.
+
+## 0.29.0 - June 15, 2021
+
+Features
+
+- Improve performance of runtime by more efficiently unboxing known fixnums. 
+- Improve performance of compiled code slightly by using more efficient closure calls when possible.
+- Add support for R7RS `#d` decimal specifier for numbers.
+- Added `char-ready?` to `(scheme base)`
+
+Bug Fixes
+
+- Avoid generating C code containing unused variables. In addition to generating better code this also prevents the C compiler from raising associated warnings.
+
 ## 0.28.0 - April 8, 2021
 
 Features

Dockerfile

@@ -4,7 +4,7 @@ MAINTAINER justin.ethier@gmail.com
 
 ARG DEBIAN_FRONTEND=noninteractive
 
-ENV CYCLONE_VERSION v0.28.0
+ENV CYCLONE_VERSION v0.36.0
 RUN apt update -y
 RUN apt install -y build-essential git rsync texinfo libtommath-dev libck-dev make gcc
 

Makefile

@@ -5,9 +5,14 @@
 include Makefile.config
 
 # Commands
-CYCLONE = cyclone -A .
+#
+# Set up Cyclone here to build the compiler itself using a system-installed
+# compiler (EG: from bootstrap or an earlier cyclone version). Everything
+# else can then be built using our local binary.
+CYCLONE_SYSTEM = cyclone -I . -CLNK '-L.'
+CYCLONE_LOCAL = ./cyclone -I . -I libs -COPT '-Iinclude' -CLNK '-L.'
 CCOMP = $(CC) $(CFLAGS)
-INDENT_CMD = indent -linux -l80 -i2 -nut
+FORMAT_CMD = indent -linux -l80 -i2 -nut
 
 # Libraries
 CYC_RT_LIB = libcyclone.a
@@ -30,6 +35,10 @@ SLDFILES = $(wildcard $(SCHEME_DIR)/*.sld) \
 COBJECTS = $(SLDFILES:.sld=.o)
 HEADERS = $(HEADER_DIR)/runtime.h $(HEADER_DIR)/types.h
 TEST_SRC = $(TEST_DIR)/unit-tests.scm \
+					 $(TEST_DIR)/base.scm \
+					 $(TEST_DIR)/test.scm \
+					 $(TEST_DIR)/threading.scm \
+					 $(TEST_DIR)/c-compiler-options.scm \
 					 $(TEST_DIR)/test-shared-queue.scm \
 					 $(TEST_DIR)/macro-hygiene.scm \
 					 $(TEST_DIR)/match-tests.scm \
@@ -45,6 +54,7 @@ TESTS = $(basename $(TEST_SRC))
 all : cyclone icyc libs
 
 test : libs $(TESTS)
+	icyc -p "(cond-expand (linux (begin (define-syntax foo (syntax-rules () ((foo) 123))) (foo))))"
 
 example :
 	cd $(EXAMPLE_DIR) ; $(MAKE)
@@ -120,12 +130,31 @@ uninstall :
 tags :
 	ctags -R *
 
-indent : gc.c runtime.c ffi.c mstreams.c $(HEADER_DIR)/*.h
-	$(INDENT_CMD) gc.c
-	$(INDENT_CMD) runtime.c
-	$(INDENT_CMD) ffi.c
-	$(INDENT_CMD) mstreams.c
-	$(INDENT_CMD) $(HEADER_DIR)/*.h
+format : gc.c runtime.c ffi.c hashset.c mstreams.c ck-polyfill.c ck-polyfill.h $(HEADER_DIR)/*.h
+	$(FORMAT_CMD) $(HEADER_DIR)/hashset.h
+	$(FORMAT_CMD) $(HEADER_DIR)/runtime.h
+	$(FORMAT_CMD) $(HEADER_DIR)/runtime-main.h
+	$(FORMAT_CMD) $(HEADER_DIR)/types.h
+	$(FORMAT_CMD) ck-polyfill.c
+	$(FORMAT_CMD) ck-polyfill.h
+	$(FORMAT_CMD) ffi.c
+	$(FORMAT_CMD) gc.c
+	$(FORMAT_CMD) hashset.c
+	$(FORMAT_CMD) mstreams.c
+	$(FORMAT_CMD) runtime.c
+
+test-format :
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/hashset.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/runtime.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/runtime-main.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/types.h
+#	./scripts/check-c-formatting.sh ffi.c
+#	./scripts/check-c-formatting.sh gc.c
+	./scripts/check-c-formatting.sh hashset.c
+#	./scripts/check-c-formatting.sh mstreams.c
+#	./scripts/check-c-formatting.sh runtime.c
+#	./scripts/check-c-formatting.sh ck-polyfill.c
+#	./scripts/check-c-formatting.sh ck-polyfill.h
 
 # This is a test directive used to test changes to a SLD file
 # EG: make sld SLDPATH=scheme/cyclone SLD=macros
@@ -138,17 +167,20 @@ debug :
 doc :
 	doxygen Doxyfile
 
+api-doc :
+	./scripts/generate-doc-index.sh && mv api-index.scm docs/api/
+
 # Helper rules (of interest to people hacking on this makefile)
 
-.PHONY: clean full bench bootstrap tags indent debug test doc
+.PHONY: clean full bench bootstrap tags format test-format debug test doc api-doc
 
-$(TESTS) : %: %.scm
-	$(CYCLONE) -I . $<
+$(TESTS) : %: %.scm cyclone libs
+	$(CYCLONE_LOCAL) -I . $<
 	./$@
 	rm -rf $@
 
-$(EXAMPLES) : %: %.scm
-	$(CYCLONE) $<
+$(EXAMPLES) : %: %.scm cyclone libs
+	$(CYCLONE_LOCAL) $<
 
 game-of-life :
 	cd $(EXAMPLE_DIR)/game-of-life ; $(MAKE)
@@ -158,14 +190,14 @@ hello-library/hello :
 
 libs : $(COBJECTS)
 
-$(COBJECTS) : %.o: %.sld
-	$(CYCLONE) $<
+$(COBJECTS) : %.o: %.sld cyclone
+	$(CYCLONE_LOCAL) $<
 
 cyclone : cyclone.scm $(CYC_RT_LIB) $(CYC_BN_LIB)
-	$(CYCLONE) cyclone.scm
+	$(CYCLONE_SYSTEM) cyclone.scm
 
-icyc : icyc.scm $(CYC_RT_LIB) $(CYC_BN_LIB)
-	$(CYCLONE) $<
+icyc : icyc.scm $(CYC_RT_LIB) $(CYC_BN_LIB) cyclone libs
+	$(CYCLONE_LOCAL) $<
 
 $(CYC_RT_LIB) : $(CFILES) $(HEADERS) $(CYC_BN_LIB)
 
@@ -187,8 +219,15 @@ mstreams.o : mstreams.c $(HEADERS)
 					-DCYC_HAVE_FMEMOPEN=$(CYC_PLATFORM_HAS_FMEMOPEN) \
 					$< -o $@
 
+ifdef CYC_PTHREAD_SET_STACK_SIZE
+  DEF_PTHREAD_SET_STACK_SIZE=-DCYC_PTHREAD_SET_STACK_SIZE=$(CYC_PTHREAD_SET_STACK_SIZE)
+else
+  DEF_PTHREAD_SET_STACK_SIZE=
+endif
+
 runtime.o : runtime.c $(HEADERS)
 	$(CCOMP) -c \
+					$(DEF_PTHREAD_SET_STACK_SIZE) \
 					-DCYC_INSTALL_DIR=\"$(PREFIX)\" \
 					-DCYC_INSTALL_LIB=\"$(LIBDIR)\" \
 					-DCYC_INSTALL_BIN=\"$(BINDIR)\" \
@@ -256,7 +295,9 @@ bootstrap : icyc libs
 	cp scheme/cyclone/common.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp icyc.scm $(BOOTSTRAP_DIR)
 	cp icyc.c $(BOOTSTRAP_DIR)
-	cp tests/unit-tests.scm $(BOOTSTRAP_DIR)
+	cp tests/unit-tests.scm $(BOOTSTRAP_DIR)/tests
+	cp tests/base.scm $(BOOTSTRAP_DIR)/tests
+	cp tests/threading.scm $(BOOTSTRAP_DIR)/tests
 	cp scheme/cyclone/ast.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp scheme/cyclone/cps-optimizations.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp scheme/cyclone/cps-opt-local-var-redux.scm $(BOOTSTRAP_DIR)/scheme/cyclone
@@ -314,3 +355,7 @@ install-bin : cyclone icyc
 	$(MKDIR) $(DESTDIR)$(BINDIR)
 	$(INSTALL) -m0755 cyclone $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 icyc $(DESTDIR)$(BINDIR)/
+
+# TODO: is this linking in local lcyclone or the system one????
+test-lib: test-lib.c
+	$(CCOMP) -g test-lib.c -o test-lib -L . $(LIBS)

Makefile.config

@@ -13,6 +13,11 @@ CYC_PROFILING ?=
 CYC_GCC_OPT_FLAGS ?= -O2
 #CYC_GCC_OPT_FLAGS ?= -g
 
+# Change this to 1 to use a custom stack size for threads.
+# Required on platforms such as Alpine Linux that use a 
+# very small stack by default.
+CYC_PTHREAD_SET_STACK_SIZE ?=
+
 OS = $(shell uname)
 CC ?= cc
 
@@ -23,24 +28,21 @@ LIBS += -ldl
 endif
 
 # Compiler options
-CFLAGS       ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Wno-shift-negative-value -Wno-unused-command-line-argument -Iinclude
-BASE_CFLAGS  ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Wno-shift-negative-value -Wno-unused-command-line-argument -I$(PREFIX)/include
+CFLAGS       += $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Wno-shift-negative-value -Wno-unused-command-line-argument -Iinclude
+BASE_CFLAGS  ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Wno-shift-negative-value -Wno-unused-command-line-argument
 # Used by Cyclone to compile programs, no need for PIC there
-BASE_PROG_CFLAGS  ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -Wall -I$(PREFIX)/include
-ifeq ($(OS),Darwin)
-COMP_CFLAGS  ?= $(BASE_CFLAGS) -L$(PREFIX)/lib
+BASE_PROG_CFLAGS   ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -Wall
+COMP_CFLAGS        ?= $(BASE_CFLAGS)
+COMP_LIBDIRS       ?= -L$(PREFIX)/lib
+COMP_INCDIRS       ?= -I$(PREFIX)/include
 COMP_PROG_CFLAGS   ?= $(BASE_PROG_CFLAGS)
-else
-COMP_CFLAGS  ?= $(BASE_CFLAGS) -L$(PREFIX)/lib
-COMP_PROG_CFLAGS  ?= $(BASE_PROG_CFLAGS)
-endif
 
 # Use these lines instead for debugging or profiling
 #CFLAGS = -g -Wall
 #CFLAGS = -g -pg -Wall
 
 # Linker options
-LDFLAGS ?= -L. $(CYC_PROFILING)
+LDFLAGS += -L. $(CYC_PROFILING)
 LIBRARY_OUTPUT_FILE = libcyclone.a
 ifeq ($(OS),Darwin)
 LDFLAGS     += -Wl,-undefined -Wl,dynamic_lookup
@@ -57,15 +59,15 @@ endif
 # concurrencykit was installed via Ports, it won't be picked up without explicitly looking
 # for it here
 ifeq ($(OS),FreeBSD)
-LDFLAGS += -L/usr/local/lib
-CFLAGS  += -I/usr/local/include
+COMP_LIBDIRS += -L/usr/local/lib
+COMP_INCDIRS += -I/usr/local/include
 endif
 
 
 # Commands "baked into" cyclone for invoking the C compiler
-CC_PROG ?= "$(CC) ~src-file~ $(COMP_PROG_CFLAGS) -c -o ~exec-file~.o"
-CC_EXEC ?= "$(CC) ~exec-file~.o ~obj-files~ $(LIBS) $(COMP_CFLAGS) -o ~exec-file~"
-CC_LIB  ?= "$(CC) ~src-file~ $(COMP_CFLAGS) -c -o ~exec-file~.o"
+CC_PROG ?= "$(CC) ~src-file~ $(COMP_PROG_CFLAGS) ~cc-extra~ $(COMP_INCDIRS) -c -o ~exec-file~.o"
+CC_EXEC ?= "$(CC) ~exec-file~.o ~obj-files~ $(LIBS) $(COMP_CFLAGS) ~ld-extra~ $(COMP_LIBDIRS) -o ~exec-file~"
+CC_LIB  ?= "$(CC) ~src-file~ $(COMP_CFLAGS) ~cc-extra~ $(COMP_INCDIRS) -c -o ~exec-file~.o"
 CC_SO   ?= "$(CC) -shared $(LDFLAGS) -o ~exec-file~.so ~exec-file~.o"
 
 AR        ?= ar
@@ -89,8 +91,9 @@ DESTDIR   ?=
 
 # Automatically detect platform-specific flags, instead of using autoconf
 #CYC_PLATFORM_HAS_MEMSTREAM ?= 1
-CYC_PLATFORM_HAS_MEMSTREAM := $(shell echo "main(){char *buf; int len; open_memstream(&buf, &len);}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
-CYC_PLATFORM_HAS_FMEMOPEN := $(shell echo "main(){char *buf; fmemopen(&buf, 0, \"r\");}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+HASH := \# # Needed for compatibility with GNU Make < 4.3 <https://lists.gnu.org/archive/html/info-gnu/2020-01/msg00004.html>
+CYC_PLATFORM_HAS_MEMSTREAM := $(shell printf "$(HASH)include <stdio.h>\n%s\n" "int main(void){char *buf; size_t len; open_memstream(&buf, &len); return 0;}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+CYC_PLATFORM_HAS_FMEMOPEN := $(shell printf "$(HASH)include <stdio.h>\n%s\n" "int main(void){char *buf; fmemopen(&buf, 0, \"r\"); return 0;}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
 
 # code from chibi's makefile to detect platform
 ifndef PLATFORM

Makefile.config.raspberry-pi-2

@@ -20,14 +20,14 @@ CREATE_LIBRARY_COMMAND = $(AR)
 CREATE_LIBRARY_FLAGS = rcs
 
 # Compiler options
-CFLAGS       ?= -O2 -fPIC -Wall -march=armv6k -Iinclude
+CFLAGS       += -O2 -fPIC -Wall -march=armv6k -Iinclude
 COMP_CFLAGS  ?= -O2 -fPIC -Wall -march=armv6k -I$(PREFIX)/include -L$(PREFIX)/lib
 # Use these lines instead for debugging or profiling
 #CFLAGS = -g -Wall
 #CFLAGS = -g -pg -Wall
 
 # Linker options
-LDFLAGS ?= -L.
+LDFLAGS += -L.
 ifeq ($(OS),Darwin)
 LDFLAGS     += -Wl,-export_dynamic -Wl,-undefined -Wl,dynamic_lookup
 COMP_CFLAGS += -Wl,-export_dynamic

README.md

@@ -1,7 +1,5 @@
 ![Cyclone Scheme](docs/images/cyclone-logo-04-header.png "Cyclone Scheme")
 
-[![Travis CI](https://travis-ci.org/justinethier/cyclone.svg?branch=master)](https://travis-ci.org/justinethier/cyclone)
-
 [![Github CI - Linux](https://github.com/justinethier/cyclone-bootstrap/workflows/Ubuntu%20Linux%20Build/badge.svg)](https://github.com/justinethier/cyclone-bootstrap)
 
 [![Github CI - MacOS](https://github.com/justinethier/cyclone-bootstrap/workflows/MacOS%20Build/badge.svg)](https://github.com/justinethier/cyclone-bootstrap)
@@ -33,9 +31,15 @@ Cyclone Scheme is a brand-new compiler that allows real-world application develo
 - Support for Linux, Windows, FreeBSD, and Mac platforms. 
 - Known to run on x86-64, x86, and Arm (Raspberry Pi) architectures.
 
+# Try in your Browser
+
+You can [run the Cyclone interpreter](https://cyclone-scheme.netlify.app/terminal.html) right in your browser. No installation required.
+
 # Installation
 
-There are several options available for installing Cyclone:
+For the full user experience - compiling files, installing packages, running native code, etc - it is necessary to install a copy of Cyclone.
+
+There are several installation options available:
 
 ## Docker 
 ![Docker](docs/images/docker-thumb.png "Docker")
@@ -63,6 +67,11 @@ Arch Linux users can install using the [AUR](https://aur.archlinux.org/packages/
     cd cyclone-scheme
     makepkg -si
 
+## Gentoo Linux
+![Gentoo Linux](docs/images/gentoo-linux-logo.png "Gentoo Linux")
+
+Cyclone is available from the [official Gentoo package repository](https://packages.gentoo.org/packages/dev-scheme/cyclone).
+
 ## Build from Source
 ![Build from Source](docs/images/build-thumb.png "Build from Source")
 
@@ -141,9 +150,7 @@ Cyclone provides several example programs, including:
 
 - There is a [Development Guide](docs/Development.md) with instructions for common tasks when hacking on the compiler itself.
 
-- Cyclone's [Garbage Collector](docs/Garbage-Collector.md) is documented at a high-level. This document includes details on extending Cheney on the MTA to support multiple stacks and fusing that approach with a tri-color marking collector.
-
-- The garbage collector was subsequently enhanced to support [Lazy Sweeping](https://github.com/justinethier/cyclone/blob/master/docs/Garbage-Collection-Using-Lazy-Sweeping.md) which improves performance for a wide range of applications.
+- Cyclone's [Garbage Collector](docs/Garbage-Collector-Revised-2022.md) is documented at a high-level. This document includes details on extending Cheney on the MTA to support multiple stacks and fusing that approach with a tri-color marking collector.
 
 # License
 

ck-polyfill.c

@@ -28,7 +28,8 @@ void ck_polyfill_init()
 
 // CK Hashset section
 bool ck_hs_init(ck_hs_t * hs, unsigned int mode, ck_hs_hash_cb_t * hash_func,
-    ck_hs_compare_cb_t *cmp, struct ck_malloc *alloc, unsigned long capacity, unsigned long seed)
+                ck_hs_compare_cb_t * cmp, struct ck_malloc *alloc,
+                unsigned long capacity, unsigned long seed)
 {
   (*hs).hs = simple_hashset_create();
   if (pthread_mutex_init(&((*hs).lock), NULL) != 0) {
@@ -58,15 +59,18 @@ void *ck_hs_get(ck_hs_t *_hs, unsigned long hash, const void *key)
 bool ck_hs_put(ck_hs_t * _hs, unsigned long hash, const void *key)
 {
   bool result = false;
-  int rv;
+  int rv, index;
   simple_hashset_t hs = (*_hs).hs;
 
   pthread_mutex_lock(&((*_hs).lock));
 
+  //index = simple_hashset_is_member(hs, (symbol_type *)key);
+  //if (index == 0) {
   rv = simple_hashset_add(hs, (symbol_type *) key);
   if (rv >= 0) {
     result = true;
   }
+  //}
 
   pthread_mutex_unlock(&((*_hs).lock));
   return result;
@@ -98,8 +102,7 @@ ck_array_init(ck_array_t *array, unsigned int mode,
 //      This function returns 1 if the pointer already exists in the array.  It
 //      returns 0 if the put operation succeeded. It returns -1 on error due to
 //      internal memory allocation failures.
-int
-ck_array_put_unique(ck_array_t *array, void *pointer)
+int ck_array_put_unique(ck_array_t * array, void *pointer)
 {
   pthread_mutex_lock(&(array->lock));
   hashset_add(array->hs, pointer);
@@ -118,8 +121,8 @@ ck_array_put_unique(ck_array_t *array, void *pointer)
 //      This function returns true if the remove operation succeeded. It will
 //      return false otherwise due to internal allocation failures or because the
 //      value did not exist.
-bool
-ck_array_remove(ck_array_t *array, void *pointer){
+bool ck_array_remove(ck_array_t * array, void *pointer)
+{
   pthread_mutex_lock(&(array->lock));
   hashset_remove(array->hs, pointer);
   pthread_mutex_unlock(&(array->lock));
@@ -135,12 +138,12 @@ ck_array_remove(ck_array_t *array, void *pointer){
 // RETURN VALUES
 //      This function returns true if the commit operation succeeded. It will
 //      return false otherwise, and pending operations will not be applied.
-bool ck_array_commit(ck_array_t *array) {
+bool ck_array_commit(ck_array_t * array)
+{
   // Nothing to do in this polyfill
   return true;
 }
 
-
 // TODO: global pthread mutex lock for this? obviously not ideal but the
 // whole purpose of this module is a minimal interface for compatibility
 // not speed
@@ -182,8 +185,7 @@ bool ck_pr_cas_8(uint8_t *target, uint8_t old_value, uint8_t new_value)
   return result;
 }
 
-void
-ck_pr_add_ptr(void *target, uintptr_t delta)
+void ck_pr_add_ptr(void *target, uintptr_t delta)
 {
   pthread_mutex_lock(&glock);
   size_t value = (size_t)target;
@@ -194,24 +196,21 @@ ck_pr_add_ptr(void *target, uintptr_t delta)
   pthread_mutex_unlock(&glock);
 }
 
-void
-ck_pr_add_int(int *target, int delta)
+void ck_pr_add_int(int *target, int delta)
 {
   pthread_mutex_lock(&glock);
   (*target) += delta;
   pthread_mutex_unlock(&glock);
 }
 
-void
-ck_pr_add_8(uint8_t *target, uint8_t delta)
+void ck_pr_add_8(uint8_t * target, uint8_t delta)
 {
   pthread_mutex_lock(&glock);
   (*target) += delta;
   pthread_mutex_unlock(&glock);
 }
 
-void *
-ck_pr_load_ptr(const void *target)
+void *ck_pr_load_ptr(const void *target)
 {
   void *result;
   pthread_mutex_lock(&glock);
@@ -220,8 +219,7 @@ ck_pr_load_ptr(const void *target)
   return result;
 }
 
-int
-ck_pr_load_int(const int *target)
+int ck_pr_load_int(const int *target)
 {
   int result;
   pthread_mutex_lock(&glock);
@@ -230,8 +228,7 @@ ck_pr_load_int(const int *target)
   return result;
 }
 
-uint8_t
-ck_pr_load_8(const uint8_t *target)
+uint8_t ck_pr_load_8(const uint8_t * target)
 {
   uint8_t result;
   pthread_mutex_lock(&glock);
@@ -247,23 +244,27 @@ void ck_pr_store_ptr(void *target, void *value)
   pthread_mutex_unlock(&glock);
 }
 
-
 // Simple hashset
 
 static const size_t prime_1 = 73;
 static const size_t prime_2 = 5009;
 
-size_t hash_function(const char* p, size_t len)
+size_t hash_function(const char *str, size_t len)
 {
-    size_t hash = 0;
-    for (; *p; ++p)
-        hash ^= *p + 0x9e3779b9 + (hash << 6) + (hash >> 2);
+  unsigned long hash = 5381;
+  int c;
+
+  while (c = *str++) {
+    hash = ((hash << 5) + hash) + c;    /* hash * 33 + c */
+  }
+
   return hash;
 }
 
 simple_hashset_t simple_hashset_create()
 {
-    simple_hashset_t set = (simple_hashset_t)calloc(1, sizeof(struct simple_hashset_st));
+  simple_hashset_t set =
+      (simple_hashset_t) calloc(1, sizeof(struct simple_hashset_st));
 
   if (set == NULL) {
     return NULL;
@@ -273,7 +274,10 @@ simple_hashset_t simple_hashset_create()
   set->nbits = 3;
   set->capacity = (size_t)(1 << set->nbits);
   set->mask = set->capacity - 1;
-    set->items = (struct simple_hashset_item_st*)calloc(set->capacity, sizeof(struct simple_hashset_item_st));
+  set->items =
+      (struct simple_hashset_item_st *)calloc(set->capacity,
+                                              sizeof(struct
+                                                     simple_hashset_item_st));
   if (set->items == NULL) {
     simple_hashset_destroy(set);
     return NULL;
@@ -296,7 +300,8 @@ void simple_hashset_set_hash_function(simple_hashset_t set, hash_func_t func)
   set->hash_func = func;
 }
 
-static int simple_hashset_add_member(simple_hashset_t set, symbol_type* key, size_t hash)
+static int simple_hashset_add_member(simple_hashset_t set, symbol_type * key,
+                                     size_t hash)
 {
   size_t index;
 
@@ -309,8 +314,7 @@ static int simple_hashset_add_member(simple_hashset_t set, symbol_type* key, siz
   while (set->items[index].hash != 0 && set->items[index].hash != 1) {
     if (set->items[index].hash == hash) {
       return 0;
-        }
-        else {
+    } else {
       /* search free slot */
       index = set->mask & (index + prime_2);
     }
@@ -331,19 +335,22 @@ static void set_maybe_rehash(simple_hashset_t set)
   struct simple_hashset_item_st *old_items;
   size_t old_capacity, index;
 
-
   if (set->nitems + set->n_deleted_items >= (double)set->capacity * 0.85) {
     old_items = set->items;
     old_capacity = set->capacity;
     ++set->nbits;
     set->capacity = (size_t)(1 << set->nbits);
     set->mask = set->capacity - 1;
-        set->items = (struct simple_hashset_item_st*)calloc(set->capacity, sizeof(struct simple_hashset_item_st));
+    set->items =
+        (struct simple_hashset_item_st *)calloc(set->capacity,
+                                                sizeof(struct
+                                                       simple_hashset_item_st));
     set->nitems = 0;
     set->n_deleted_items = 0;
     //assert(set->items);
     for (index = 0; index < old_capacity; ++index) {
-            simple_hashset_add_member(set, old_items[index].item, old_items[index].hash);
+      simple_hashset_add_member(set, old_items[index].item,
+                                old_items[index].hash);
     }
     free(old_items);
   }
@@ -373,5 +380,3 @@ int simple_hashset_is_member(simple_hashset_t set, symbol_type* key)
   }
   return 0;
 }
-
-

ck-polyfill.h

@@ -38,7 +38,6 @@ struct ck_malloc {
 //    struct simple_hashset_st;
 typedef struct simple_hashset_st *simple_hashset_t;
 
-
 struct hashmap_st;
 typedef struct hashmap_st *hashmap_t;
 
@@ -101,7 +100,8 @@ typedef bool ck_hs_compare_cb_t(const void *, const void *);
 #define CK_HS_HASH(hs, hs_hash, value) 0
 
 bool ck_hs_init(ck_hs_t *, unsigned int, ck_hs_hash_cb_t *,
-    ck_hs_compare_cb_t *, struct ck_malloc *, unsigned long, unsigned long);     
+                ck_hs_compare_cb_t *, struct ck_malloc *, unsigned long,
+                unsigned long);
 
 void *ck_hs_get(ck_hs_t *, unsigned long, const void *);
 bool ck_hs_put(ck_hs_t *, unsigned long, const void *);
@@ -166,8 +166,7 @@ ck_array_init(ck_array_t *array, unsigned int mode,
 //      This function returns 1 if the pointer already exists in the array.  It
 //      returns 0 if the put operation succeeded. It returns -1 on error due to
 //      internal memory allocation failures.
-int
-ck_array_put_unique(ck_array_t *array, void *pointer);
+int ck_array_put_unique(ck_array_t * array, void *pointer);
 
 // DESCRIPTION
 //      The ck_array_remove(3) function will attempt to remove the value of
@@ -180,9 +179,7 @@ ck_array_put_unique(ck_array_t *array, void *pointer);
 //      This function returns true if the remove operation succeeded. It will
 //      return false otherwise due to internal allocation failures or because the
 //      value did not exist.
-bool
-ck_array_remove(ck_array_t *array, void *pointer);
-
+bool ck_array_remove(ck_array_t * array, void *pointer);
 
 // DESCRIPTION
 //      The ck_array_commit(3) function will commit any pending put or remove
@@ -193,9 +190,7 @@ ck_array_remove(ck_array_t *array, void *pointer);
 // RETURN VALUES
 //      This function returns true if the commit operation succeeded. It will
 //      return false otherwise, and pending operations will not be applied.
-bool
-ck_array_commit(ck_array_t *array);
-
+bool ck_array_commit(ck_array_t * array);
 
   // TODO:
 
@@ -213,33 +208,23 @@ ck_array_commit(ck_array_t *array);
 
 ///////////////////////////////////////////////////////////////////////////////
 // CK PR section
-bool
-ck_pr_cas_ptr(void *target, void *old_value, void *new_value);
+bool ck_pr_cas_ptr(void *target, void *old_value, void *new_value);
 
-bool
-ck_pr_cas_int(int *target, int old_value, int new_value);
+bool ck_pr_cas_int(int *target, int old_value, int new_value);
 
-bool
-ck_pr_cas_8(uint8_t *target, uint8_t old_value, uint8_t new_value);
+bool ck_pr_cas_8(uint8_t * target, uint8_t old_value, uint8_t new_value);
 
+void ck_pr_add_ptr(void *target, uintptr_t delta);
 
-void
-ck_pr_add_ptr(void *target, uintptr_t delta);
+void ck_pr_add_int(int *target, int delta);
 
-void
-ck_pr_add_int(int *target, int delta);
+void ck_pr_add_8(uint8_t * target, uint8_t delta);
 
-void
-ck_pr_add_8(uint8_t *target, uint8_t delta);
+void *ck_pr_load_ptr(const void *target);
 
-void *
-ck_pr_load_ptr(const void *target);
+int ck_pr_load_int(const int *target);
 
-int
-ck_pr_load_int(const int *target);
-
-uint8_t
-ck_pr_load_8(const uint8_t *target);
+uint8_t ck_pr_load_8(const uint8_t * target);
 
 void ck_pr_store_ptr(void *target, void *value);
 #endif                          /* CYCLONE_CK_POLYFILL_H */

cyclone.scm

@@ -21,11 +21,12 @@
         (scheme cyclone primitives)
         (scheme cyclone transforms)
         (scheme cyclone cps-optimizations)
-        (scheme cyclone libraries))
+        (scheme cyclone libraries)
+        (srfi 18))
 
 (define *fe:batch-compile* #t) ;; Batch compilation. TODO: default to false or true??
 (define *optimization-level* 2) ;; Default level
-(define *optimize:memoize-pure-functions* #t) ;; Memoize pure funcs by default
+(define *optimize:memoize-pure-functions* #f) ;; Memoize pure function
 (define *optimize:beta-expand-threshold* #f) ;; BE threshold or #f to use default
 (define *optimize:inline-unsafe* #f) ;; Inline primitives even if generated code may be unsafe
 (define *cgen:track-call-history* #t)
@@ -79,6 +80,11 @@
     Cyc_check_str(data, filename);
     double_value(&box) = Cyc_file_last_modified_time(string_str(filename));
     return_closcall1(data, k, &box); ")
+
+(define-c calling-program
+  "(void *data, int argc, closure _, object k)"
+  " make_utf8_string(data, s, _cyc_argv[0]);
+    return_closcall1(data, k, &s); ")
 ;; END batch compilation
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -287,7 +293,10 @@
         (for-each 
           (lambda (lib-dep)
             (when (recompile? lib-dep append-dirs prepend-dirs)
-              (let ((result (system (string-append "cyclone " 
+              (let ((result (system (string-append 
+                                      (calling-program) " " 
+                                      (dirs->args "-A" append-dirs) " "
+                                      (dirs->args "-I" prepend-dirs) " "
                                       (lib:import->filename lib-dep ".sld" append-dirs prepend-dirs)))))
                 (when (> result 0)
                   (error "Unable to compile library" lib-dep)))))
@@ -340,7 +349,8 @@
               (cond
                 ((eq? e 'call/cc) #f) ;; Special case
                 ((and (not module-global?)
-                      (not imported-var?))
+                      (not imported-var?)
+                      (not (prim? e)))
                  (error "Identifier is exported but not defined" e))
                 (else
                   ;; Pass throughs are not defined in this module,
@@ -715,9 +725,7 @@
     in-prog))
 
 ;; Compile and emit:
-(define (run-compiler args cc? cc-prog cc-exec cc-lib cc-so 
-                      cc-opts cc-prog-linker-opts cc-prog-linker-objs 
-                      append-dirs prepend-dirs)
+(define (run-compiler args append-dirs prepend-dirs change-cc-opts!)
   (let* ((in-file (car args))
          (expander (base-expander))
          (in-prog-raw (read-file in-file))
@@ -730,7 +738,7 @@
               in-prog-raw)
             (else
               ;; Account for any cond-expand declarations in the library
-              (list (lib:cond-expand (car in-prog-raw) expander)))))
+              (list (lib:cond-expand in-file (car in-prog-raw) expander)))))
           ;; expand in-prog, if a library, using lib:cond-expand.
           ;; TODO: will also need to do below in lib:get-all-import-deps, after reading each library
          (program:imports/code (if program? (import-reduction in-prog expander) '()))
@@ -739,6 +747,20 @@
                     (not (null? (car program:imports/code))))
              (lib:get-all-import-deps (car program:imports/code) append-dirs prepend-dirs expander)
             '()))
+        ;; Read C compiler options
+         (cc-opts
+          (cond
+            (program? 
+              (let ((opts (program-c-compiler-opts! in-prog)))
+                (when (not (null? opts))
+                  (change-cc-opts! opts))
+                (string-join ;; Check current program for options
+                  opts
+                  " ")))
+            (else
+              (string-join 
+                (lib:c-compiler-options (car in-prog)) 
+                " "))))
          ;; Read all linker options from dependent libs
          (c-linker-options
            (let ((lib-options (lib:get-all-c-linker-options lib-deps append-dirs prepend-dirs expander)))
@@ -748,17 +770,6 @@
                    " "
                    lib-options)
                  lib-options)))
-         ;; Only read C compiler options from module being compiled
-         (cc-opts*
-          (cond
-            (program? 
-              (string-join ;; Check current program for options
-                (program-c-compiler-opts! in-prog)
-                " "))
-            (else
-              (string-join 
-                (lib:c-compiler-options (car in-prog)) 
-                " "))))
          (exec-file (basename in-file))
          (src-file (string-append exec-file ".c"))
          (meta-file (string-append exec-file ".meta"))
@@ -797,13 +808,85 @@
                      lib-deps)
                    in-file 
                    append-dirs 
-                   prepend-dirs)))))
-         (result (create-c-file in-prog)))
+                   prepend-dirs))))))
+    (create-c-file in-prog)
+    (cond
+     (program?
+      ;; Use .meta file to store information for C compiler phase
+      (save-program-metadata meta-file lib-deps c-linker-options))
+     (else
+      ;; Emit .meta file
+      (with-output-to-file
+        meta-file
+        (lambda ()
+          (display ";; This file was automatically generated by the Cyclone Scheme compiler")
+          (newline)
+          (write (macro:get-defined-macros))))))))
 
+(define (save-program-metadata filename lib-deps c-linker-options)
+  (with-output-to-file
+    filename
+    (lambda ()
+      (display ";; This file was automatically generated by the Cyclone Scheme compiler")
+      (newline)
+      (write `(lib-deps . ,lib-deps))
+      (newline)
+      (write `(c-linker-options . ,c-linker-options)))))
+
+(define (load-program-metadata filename)
+  (let ((data (call-with-input-file filename  read-all)))
+    (delete-file filename)
+    data))
+
+(define (get-meta meta symbol default)
+  (if (assoc symbol meta)
+      (cdr (assoc symbol meta))
+      default))
+
+(define (run-external-compiler 
+           args append-dirs prepend-dirs
+           cc? cc-prog cc-exec cc-lib cc-so 
+           cc-opts cc-prog-linker-opts cc-prog-linker-objs)
+  (let* ((in-file (car args))
+         (expander (base-expander))
+         (in-prog-raw (read-file in-file))
+         (program? (not (library? (car in-prog-raw))))
+         (in-prog
+          (cond
+            (program? 
+              (Cyc-add-feature! 'program) ;; Load special feature
+              ;; TODO: what about top-level cond-expands in the program?
+              in-prog-raw)
+            (else
+              ;; Account for any cond-expand declarations in the library
+              (list (lib:cond-expand in-file (car in-prog-raw) expander)))))
+         ;; Only read C compiler options from module being compiled
+         (cc-opts*
+          (cond
+            (program? 
+              (string-join ;; Check current program for options
+                (program-c-compiler-opts! in-prog)
+                " "))
+            (else
+              (string-join 
+                (lib:c-compiler-options (car in-prog)) 
+                " "))))
+         (exec-file (basename in-file))
+         (src-file (string-append exec-file ".c"))
+         (meta-file (string-append exec-file ".meta"))
+         (get-comp-env 
+           (lambda (sym str)
+             (if (> (string-length str) 0)
+                 str
+                 (Cyc-compilation-environment sym)))) 
+        )
     ;; Compile the generated C file
     (cond
       (program?
-        (letrec ((objs-str 
+        (letrec ((metadata (load-program-metadata meta-file))
+                 (c-linker-options (get-meta metadata 'c-linker-options '()))
+                 (lib-deps (get-meta metadata 'lib-deps '()))
+                 (objs-str 
                   (string-append
                     cc-prog-linker-objs
                     (apply
@@ -814,29 +897,29 @@
                         lib-deps))))
                  (comp-prog-cmd 
                    (string-append
+                     (string-replace-all 
                        (string-replace-all 
                          (string-replace-all 
                            ;(Cyc-compilation-environment 'cc-prog) 
                            (get-comp-env 'cc-prog cc-prog)
                            "~src-file~" src-file)
+                         "~cc-extra~" cc-opts)
                        "~exec-file~" exec-file)
                      " "
-                     cc-opts
-                     " "
                      cc-opts*))
                  (comp-objs-cmd 
                   (string-append
                    (string-replace-all
+                     (string-replace-all
                        (string-replace-all
                          (string-replace-all
                            ;(Cyc-compilation-environment 'cc-exec)
                            (get-comp-env 'cc-exec cc-exec)
                            "~exec-file~" exec-file)
+                         "~ld-extra~" cc-prog-linker-opts)
                        "~obj-files~" objs-str)
                      "~exec-file~" exec-file)
                    " "
-                   cc-prog-linker-opts
-                   " "
                    c-linker-options
                    )))
           ;(write `(DEBUG all imports ,lib-deps objs ,objs-str))
@@ -851,24 +934,17 @@
               (display comp-objs-cmd)
               (newline)))))
       (else
-        ;; Emit .meta file
-        (with-output-to-file
-          meta-file
-          (lambda ()
-            (display ";; This file was automatically generated by the Cyclone Scheme compiler")
-            (newline)
-            (write (macro:get-defined-macros))))
         ;; Compile library
         (let ((comp-lib-cmd
                (string-append
+                (string-replace-all 
                   (string-replace-all 
                     (string-replace-all 
                       (get-comp-env 'cc-lib cc-lib)
                       "~src-file~" src-file)
+                    "~cc-extra~" cc-opts)
                   "~exec-file~" exec-file)
                 " "
-                cc-opts
-                " "
                 cc-opts*))
               (comp-so-cmd
                (string-append
@@ -912,6 +988,17 @@
       (list #f)
       args)))
 
+;; Convert a list of directories to a string of arguments.
+;; EG: (dirs->args "-I" '("dir-1" "dir-2")) =>
+;;     " -I dir-1 -I dir-2 "
+(define (dirs->args prefix dirs)
+  (apply 
+    string-append
+    (map
+      (lambda (dir)
+        (string-append " " prefix " " dir " "))
+      dirs)))
+
 ;; Handle command line arguments
 (let* ((args (command-line-arguments))
        (non-opts 
@@ -924,6 +1011,8 @@
                 ;               (equal? #\- (string-ref arg 0)))))
                 ;   args))
        (compile? #t)
+       (run-scm-compiler? (member "-run-scm-compiler" args))
+       (no-compiler-subprocess (member "-no-compiler-subprocess" args))
        (cc-prog (apply string-append (collect-opt-values args "-CP")))
        (cc-exec (apply string-append (collect-opt-values args "-CE")))
        (cc-lib  (apply string-append (collect-opt-values args "-CL")))
@@ -1067,7 +1156,34 @@ Debug options:
             (cdr err))
           (newline)
           (exit 1)))
-      (run-compiler non-opts compile? cc-prog cc-exec cc-lib cc-so 
-                    cc-opts cc-linker-opts cc-linker-extra-objects 
-                    append-dirs prepend-dirs)))))
+      (cond
+        (run-scm-compiler? 
+          ;; Compile Scheme code into a C file
+          (run-compiler non-opts append-dirs prepend-dirs
+            (lambda (opts) 
+              (set! cc-opts opts))))
+        (else
+          ;; Generate the C file
+          (cond
+           (no-compiler-subprocess
+            ;; Special case, we can generate .C file within this process
+            (run-compiler non-opts append-dirs prepend-dirs
+              (lambda (opts) (set! cc-opts opts)))
+
+            )
+           (else
+            ;; Normal path is to run another instance of cyclone to generate
+            ;; the .C file. This lets us immediately free those resources once
+            ;; the Scheme compilation is done.
+            (when (not (zero? (system
+                                (string-append 
+                                  (calling-program) " -run-scm-compiler "
+                                  (string-join args " ")))))
+              (exit 1))))
+          ;; Call the C compiler
+          (run-external-compiler
+            non-opts append-dirs prepend-dirs
+            compile? cc-prog cc-exec cc-lib cc-so 
+            cc-opts cc-linker-opts cc-linker-extra-objects)))
+      ))))
 

docs/Garbage-Collector-Revised-2022.md

@@ -0,0 +1,639 @@
+[<img src="images/cyclone-logo-04-header.png" alt="cyclone-scheme">](http://github.com/justinethier/cyclone)
+
+# Garbage Collector
+
+- [Introduction](#introduction)
+- [Minor Collection](#minor-collection)
+  - [Cheney on the MTA](#cheney-on-the-mta)
+  - [Our Implementation](#our-implementation)
+  - [Write Barriers](#write-barriers)
+- [Major Collection](#major-collection)
+  - [Lazy Sweeping](#lazy-sweeping)
+  - [Object Marking](#object-marking)
+  - [Handshakes](#handshakes)
+  - [Collection Cycle](#collection-cycle)
+  - [Mutator Functions](#mutator-functions)
+  - [Collector Functions](#collector-functions)
+  - [Cooperation by the Collector](#cooperation-by-the-collector)
+  - [Running the Collector](#running-the-collector)
+  - [Performance Measurements](#performance-measurements)
+- [Conclusion](#conclusion)
+- [Further Reading](#further-reading)
+- [Appendix](#appendix)
+  - [Terms](#terms)
+  - [Code](#code)
+  - [Data Structures](#data-structures)
+    - [Heap](#heap)
+    - [Thread Data](#thread-data)
+    - [Object Header](#object-header)
+    - [Mark Buffers](#mark-buffers)
+
+# Introduction
+
+This article provides a high-level overview of Cyclone's garbage collector, including recent work on lazy sweeping and automatic relocation of shared objects. This overview would be a good starting point for understanding the corresponding code in Cyclone's runtime and may also be of interest to anyone wanting to implement - or just peek under the hood of - a modern, real-world collector.
+
+The collector has the following requirements:
+
+- Efficiently free allocated memory.
+- Allow the language implementation to support tail calls and continuations.
+- Allow the language to support native multithreading.
+
+Cyclone uses generational garbage collection (GC) to automatically free allocated memory using two types of collection. In practice, most allocations consist of short-lived objects such as temporary variables. Minor GC is done frequently to clean up most of these short-lived objects. A major collection runs less often to free longer-lived objects that are no longer being used by the application.
+
+Cheney on the MTA, a technique introduced by Henry Baker, is used to implement the minor collector. Objects are allocated directly on the stack using `alloca` so allocations are very fast, do not cause fragmentation, and do not require a special pass to free unused objects. 
+
+A concurrent mark-sweep collector is used to manage heap memory and perform major collections without [stopping the world](https://en.wikipedia.org/wiki/Tracing_garbage_collection#Stop-the-world_vs._incremental_vs._concurrent).
+
+For more background there are introductory articles on garbage collection in the [further reading](#further-reading) section that discuss underlying concepts.
+
+# Minor Collection
+
+## Cheney on the MTA
+
+A runtime based on Henry Baker's paper [CONS Should Not CONS Its Arguments, Part II: Cheney on the M.T.A.](research-papers/CheneyMTA.pdf) was used as it allows for fast code that meets all of the fundamental requirements for a Scheme runtime: tail calls, garbage collection, and continuations.
+
+Baker explains how it works:
+
+> We propose to compile Scheme by converting it into continuation-passing style (CPS), and then compile the resulting lambda expressions into individual C functions. Arguments are passed as normal C arguments, and function calls are normal C calls. Continuation closures and closure environments are passed as extra C arguments. Such a Scheme never executes a C return, so the stack will grow and grow ... eventually, the C "stack" will overflow the space assigned to it, and we must perform garbage collection. 
+
+Cheney on the M.T.A. uses a copying garbage collector. By using static roots and the current continuation closure, the GC is able to copy objects from the stack to a pre-allocated heap without having to know the format of C stack frames. To quote Baker:
+
+> the entire C "stack" is effectively the youngest generation in a generational garbage collector!
+
+After GC is finished, the C stack pointer is reset using [`longjmp`](http://man7.org/linux/man-pages/man3/longjmp.3.html) and the GC calls its continuation. 
+
+Here is a snippet demonstrating how C functions may be written using Baker's approach:
+
+    object Cyc_make_vector(object cont, object len, object fill) {
+      object v = NULL;
+      int i;
+      Cyc_check_int(len);
+
+      // Memory for vector can be allocated directly on the stack
+      v = alloca(sizeof(vector_type));
+
+      // Populate vector object
+      ((vector)v)->tag = vector_tag;
+      ... 
+
+      // Check if GC is needed, then call into continuation with the new vector
+      return_closcall1(cont, v);
+    }
+
+[CHICKEN](http://www.call-cc.org/) was the first Scheme compiler to use Baker's approach.
+
+## Our Implementation
+
+Minor GC is always performed for a single mutator thread. Each thread uses local stack storage for its own objects so there is no need for minor GC to synchronize with other mutator threads.
+
+As described in Baker's paper, Cyclone converts the original program to continuation passing style (CPS) and compiles it as a series of C functions that never return. At runtime each mutator periodically checks to see if its stack has exceeded a certain size. When this happens a minor GC is started and all live stack objects are copied to the heap.
+
+The following root objects are used as a starting point to find all live objects:
+
+- The current continuation
+- Arguments to the current continuation
+- Mutations contained in the write barrier
+- Closures from the exception stack
+- Global variables
+
+The collection algorithm itself operates as follows:
+
+- Move any root objects on the stack to the heap. 
+- For each object moved: 
+  - Replace the stack object with a forwarding pointer. The forwarding pointer ensures all references to a stack object refer to the same heap object, and allows minor GC to handle cycles.
+  - Record each moved object in a buffer to serve as the Cheney to-space.
+- Loop over the to-space buffer and check each object moved to the heap. Move any child objects that are still on the stack. This loop continues until all live objects are moved.
+- [Cooperate](#cooperate) with the major GC's collection thread.
+- Perform a `longjmp` to reset the stack and call into the current continuation.
+
+Any objects left on the stack after `longjmp` are considered garbage. There is no need to clean them up because the stack will just re-use the memory as it grows.
+
+## Write Barriers
+
+### Heap Object References
+
+Baker's paper does not mention one important detail. A heap object can be modified to contain a reference to a stack object. For example, by using a `set-car!` to change the head of a list.
+
+This is problematic since stack references are no longer valid after a minor GC and the GC does not check heap objects. We account for these mutations by using a write barrier to maintain a list of each modified object. During GC these modified objects are treated as roots to avoid dangling references.
+
+The write barrier must be called by each primitive in the runtime that modifies object pointers - `set-car!`, `set-cdr!`, `vector-set!`, etc. Fortunately there are only a handful of these functions.
+
+### Relocating Shared Objects
+
+Cyclone must guarantee the objects located on each mutator thread's stack are only used by that thread. 
+
+This requirement is critical as any existing references to a stack object will become invalid when that object is moved to the heap by minor GC. Without the proper safety measures in place this would lead to the potential for memory safety issues - segmentation faults, undefined behavior, etc.
+
+Thus Cyclone ensures memory safety by automatically relocating objects to the heap before they can be accessed by more than one thread. Each write barrier checks to see if a heap variable is being changed to point to a variable on the stack. When such a change is detected Cyclone will move only that object to the heap if possible. However for objects with many children - such as a list or vector - it may be necessary for Cyclone to trigger a minor collection in order to ensure all objects are relocated to the heap before they can be accessed by multiple threads. 
+
+The following function does the heavy lifting:
+
+    object transport_stack_value(gc_thread_data *data, object var, object value, int *run_gc) 
+    {
+      char tmp;
+      int inttmp, *heap_grown = &inttmp;
+      gc_heap_root *heap = data->heap;
+    
+      // Nothing needs to be done unless we are mutating
+      // a heap variable to point to a stack var.
+      if (!gc_is_stack_obj(&tmp, data, var) && gc_is_stack_obj(&tmp, data, value)) {
+        // Must move `value` to the heap to allow use by other threads
+        switch(type_of(value)) {
+          case string_tag:
+          case bytevector_tag:
+            if (immutable(value)) {
+              // Safe to transport now
+              object hp = gc_alloc(heap, gc_allocated_bytes(value, NULL, NULL), value, data, heap_grown);
+              return hp;
+            }
+            // Need to GC if obj is mutable, EG: a string could be mutated so we can't
+            // have multiple copies of the object running around
+            *run_gc = 1;
+            return value;
+          case double_tag:
+          case port_tag:
+          case c_opaque_tag:
+          case complex_num_tag: {
+            // These objects are immutable, transport now
+            object hp = gc_alloc(heap, gc_allocated_bytes(value, NULL, NULL), value, data, heap_grown);
+            return hp;
+          }
+          // Objs w/children force minor GC to guarantee everything is relocated:
+          case cvar_tag:
+          case closure0_tag:
+          case closure1_tag:
+          case closureN_tag:
+          case pair_tag:
+          case vector_tag:
+            *run_gc = 1;
+            return value;
+          default:
+            // Other object types are not stack-allocated so should never get here
+            printf("Invalid shared object type %d\n", type_of(value));
+            exit(1);
+        }
+      }
+    
+      return value;
+    }
+
+Then, `transport_stack_value` is called from each write barrier in a manner similar to the below for `set-car!`:
+
+    int do_gc = 0;
+    val = transport_stack_value(data, l, val, &do_gc);
+    ...
+    if (do_gc) { // GC and then do assignment
+      mclosure0(clo, (function_type)Cyc_set_car_cps_gc_return);
+      object buf[3]; buf[0] = l; buf[1] = val; buf[2] = cont;
+      GC(data, &clo, buf, 3);
+      return NULL;
+    }
+
+It is still necessary for application code to use the appropriate concurrency constructs - such as locks, atomics, etc - to ensure that a shared object is safely accessed by only one thread at a time.
+
+# Major Collection
+
+Baker's technique uses a copying collector for both the minor and major generations of collection. One of the drawbacks of using a copying collector for major GC is that it relocates all the live objects during collection. This is problematic for supporting native threads because an object can be relocated at any time, invalidating any references to the object. To prevent this either all threads must be stopped while major GC is running or a read barrier must be used each time an object is accessed. Both options add a potentially significant overhead so instead Cyclone uses a tracing collector based on the Doligez-Leroy-Gonthier (DLG) algorithm for major collections. 
+
+An advantage of this approach is that major GC executes asynchronously so threads can continue to run concurrently even during collections. A collector thread is used to perform a major GC with cooperation from the mutator threads.
+
+## Lazy Sweeping
+
+A fundamental mark-sweep optimization suggested by the [Garbage Collection Handbook](#further-reading) is lazy sweeping.
+
+In a simple mark-sweep collector the entire heap is swept at once when tracing is finished. Instead with lazy sweeping each mutator thread will sweep its own heap incrementally as part of allocation. When no more free space is available to meet a request the allocator will check to see if there are unswept heap pages, and if so, the mutator will pick a page and sweep it to free up space. This amortizes the cost of sweeping.
+
+Performance is improved in several ways:
+
+- Better Locality - Heap slots tend to be used soon after they are swept and sweep only needs to visit a small part of the heap. This allows programs to make better use of the processor cache.
+- Thread-Local Data - There is no need to lock the heap for allocation or sweeping since both operations are performed by the same thread.
+- Reduced Complexity - The algorithmic complexity of mark-sweep is reduced to be proportional to the size of the live data in the heap instead of the whole heap, similar to a copying collector. Lazy sweeping will perform best when most of the heap is empty.
+
+Lazy sweeping is discussed here in the first major GC section as it impacts most of the other components of the collector.
+
+## Object Marking
+
+An object can be marked using any of the following colors to indicate the status of its memory:
+
+  - :large_blue_circle: - Blue - Unallocated memory.
+  - :red_circle: - Red - An object on the stack.
+  - :white_circle: - White - Heap memory that has not been scanned by the collector. 
+  - :radio_button: - Gray - Objects marked by the collector that may still have child objects that must be marked.
+  - :black_circle: - Black - Objects marked by the collector whose immediate child objects have also been marked.
+  - :purple_circle: - Purple - Garbage objects on the heap that have not yet been reclaimed due to lazy sweeping.
+
+### Tri-Color Invariant
+
+Only objects marked as white, gray, or black participate in major collections. 
+
+White objects are freed during the sweep state. White is sometimes also referred to as the clear color.
+
+Black objects survive the collection cycle. Black is sometimes referred to as the mark color as live objects are ultimately marked black.
+
+Our collector must guarantee that a black object never has any children that are white objects. This satisfies the so-called tri-color invariant and guarantees that all white objects can be collected once the gray objects are marked. This is the reason our collector must use a gray color instead of transitioning white objects directly to black.
+
+Finally, a [mark buffer](#mark-buffers) is used to store the list of gray objects. This improves performance by avoiding repeated passes over the heap to search for gray objects.
+
+## Deferred Collection
+
+A set of three heap colors is insufficient for lazy sweeping because parts of the heap may not be swept during a collection cycle. Thus an object that is really garbage could accidentally be assigned the black color.
+
+For example, suppose a heap page consists entirely of white objects after a GC is finished. All of the objects are garbage and would be freed if the page is swept. However if this page is not swept before the next collection starts, the collector will [swap the values of white/black](#clear) and during the subsequent cycle all of the objects will appear as if they have the black color. Thus a sweep during this most recent GC cycle would not be able to free any of the objects!
+
+The solution is to add a new color (purple) to indicate garbage objects on the heap. Garbage can then be swept while the collector is busy doing other work such as mark/trace. In order to account for multiple generations of objects the object colors are incremented each cycle instead of being swapped. For example, the collector starts in the following state:
+
+    static unsigned char gc_color_mark = 5;   // Black, is swapped during GC
+    static unsigned char gc_color_clear = 3;  // White, is swapped during GC
+    static unsigned char gc_color_purple = 1;  // There are many "shades" of purple, this is the most recent one
+
+We can assign a new purple color after tracing is finished. At this point the clear color and the purple color are (essentially) the same, and any new objects are allocated using the mark color. When GC starts back up, the clear and mark colors are each incremented by 2:
+
+    // We now increment both so that clear becomes the old mark color and a
+    // new value is used for the mark color. The old clear color becomes
+    // purple, indicating any of these objects are garbage
+    ck_pr_add_8(&gc_color_purple, 2);
+    ck_pr_add_8(&gc_color_clear, 2);
+    ck_pr_add_8(&gc_color_mark, 2);
+
+So we now have purple (assigned the previous clear color), clear (assigned the previous mark color), and mark (assigned a new number). All of these numbers must be odd so they will never conflict with the red or blue colors. Effectively any odd numbered colors not part of this set represent other "shades" of purple.
+
+## Handshakes
+
+Instead of stopping the world and pausing all threads, when the collector needs to coordinate with the mutators it performs a handshake.
+
+Each of the mutator threads, and the collector itself, has a status variable:
+
+     typedef enum { STATUS_ASYNC 
+                  , STATUS_SYNC1 
+                  , STATUS_SYNC2 
+                  } gc_status_type;
+
+The collector will update its status variable and then wait for all of the collectors to change their status before continuing. The mutators periodically call a cooperate function to check in and update their status to match the collectors. A handshake is complete once all mutators have updated their status.
+
+## Collection Cycle
+
+During a GC cycle the collector thread transitions through the following states.
+
+### Clear
+The collector swaps the values of the clear color (white) and the mark color (black). This is more efficient than modifying the color on each object in the heap. The collector then transitions to sync 1. At this point no heap objects are marked, as demonstrated below:
+
+<img src="images/gc-graph-clear.png" alt="Initial object graph">
+
+### Mark
+The collector transitions to sync 2 and then async. At this point it marks the global variables and waits for the mutators to also transition to async. When a mutator transitions it will mark its roots and use black as the allocation color to prevent any new objects from being collected during this cycle:
+
+<img src="images/gc-graph-mark.png" alt="Initial object graph">
+
+### Trace
+The collector finds all live objects using a breadth-first search and marks them black:
+
+<img src="images/gc-graph-trace.png" alt="Initial object graph">
+
+The collector thread performs the bulk of its work during this phase. For more details see the [Collector Trace](#collector-trace) section.
+
+### Sweep
+This function is included here for completeness but is actually performed much later due to [lazy sweeping](#lazy-sweeping).
+
+When the time comes to reclaim memory a mutator scans a heap page and frees memory used by any of the white objects:
+
+<img src="images/gc-graph-sweep.png" alt="Initial object graph">
+
+### Resting
+The collector cycle is complete and it rests until it is triggered again.
+
+## Mutator Functions
+
+Each mutator calls the following functions to coordinate with the collector.
+
+### Allocate
+
+This function is called by a mutator to allocate memory on the heap for an object. This is generally only done during a minor GC when each object is relocated to the heap.
+
+There is no need for the mutator to directly coordinate with the collector during allocation as each thread uses its own set of heap pages.
+
+The main allocation function takes a fast or slow path depending upon whether a free slot is found on the current heap page. 
+
+The logic in simplified form is:
+
+    result = try_alloc();
+    if (result)
+      return result;
+
+    result = try_alloc_slow();
+    if (result) 
+      return result;
+
+    grow_heap(); // malloc more heap space
+    result = try_alloc_slow();
+    if (result) 
+      return result;
+
+    out_of_memory_error();
+  
+A heap page uses a "free list" of available slots to quickly find the next available slot. The `try_alloc` function simply finds the first slot on the free list and returns it, or `NULL` if there is no free slot.
+
+On the other hand, `try_alloc_slow` has to do more work to find the next available heap page, sweep it, and then call `try_alloc` to perform an allocation.
+
+If there is not enough free memory to fulfill a `try_alloc_slow` request a new page is allocated and added to the heap. This is the only choice, unfortunately. The collection process is asynchronous so memory cannot be freed immediately to make room.
+
+### Sweep
+
+Sweep walks an entire heap page, freeing all unused slots along the way. 
+
+To identify an unused object the algorithm must check for two colors:
+
+- Objects that are either newly-allocated or recently traced are given the allocation color; we need to keep them.
+- If the collector is currently tracing, objects not traced yet will have the trace/clear color. We need to keep any of those to make sure the collector has a chance to trace the entire heap.
+
+The code is as follows:
+
+      if (mark(p) != thd->gc_alloc_color && 
+          mark(p) != thd->gc_trace_color) {
+        ... // Free slot p
+      }
+
+### Update
+
+A write barrier is used to ensure any modified objects are properly marked for the current collection cycle. There are two cases:
+
+- Gray the object's new and old values if the mutator is in a synchronous status. 
+- Gray the object's old value if the collector is in the tracing stage.
+
+Because updates can occur at any time a modified object may still live on the stack. In this case the object is tagged to be grayed when it is relocated to the heap.
+
+### Cooperate
+
+Each mutator is required to periodically call this function to cooperate with the collector. During cooperation a mutator will update its status to match the collector's status, to handshake with the collector. 
+
+In addition when a mutator transitions to async it will:
+
+- Mark all of its roots gray
+- Use black as the allocation color for any new objects to prevent them from being collected during this cycle.
+
+Cyclone's mutators cooperate after each minor GC, for two reasons. Minor GC's are frequent and immediately afterwards all of the mutator's live objects can be marked because they are on the heap.
+
+Finally, at the end of a collection cycle the main thread must clean up heap data for any terminated threads.
+
+### Mark Gray
+
+Mutators call this function to add an object to their mark buffer.
+
+    mark_gray(m, obj):
+      if obj != clear_color:
+        m->mark_buffer[m->last_write] = obj
+        m->last_write++
+
+## Collector Functions
+
+### Collector Mark Gray
+
+The collector calls this function to add an object to the mark stack.
+
+    collector_mark_gray(obj):
+      if obj != clear_color:
+        mark_stack->push(obj)
+
+### Mark Black
+
+The collector calls this function to mark an object black and mark all of the object's children gray using Collector Mark Gray.
+
+    mark_black(obj):
+      if mark(obj) != mark_color:
+        for each child(c):
+          collector_mark_gray(c)
+        mark(obj) = mark_color
+
+
+### Empty Collector Mark Stack
+
+This function removes and marks each object on the collector's mark stack.
+
+    empty_collector_mark_stack():
+      while not mark_stack->empty():
+        mark_black(mark_stack->pop())
+
+### Collector Trace
+
+This function performs tracing for the collector by looping over all of the mutator mark buffers. All of the remaining objects in each buffer are marked black, as well as all the remaining objects on the collector's mark stack. This function continues looping until there are no more objects to mark:
+
+    collector_trace():
+      clean = 0
+      while not clean:
+        clean = 1
+        for each mutator(m):
+          while m->last_read < m->last_write:
+            clean = 0
+            mark_black(m->mark_buffer[m->last_read])
+            empty_collector_mark_stack()
+            m->last_read++
+
+The primary job of the collector thread is tracing. 
+
+While tracing the collector visits all live objects and marks them as being in use. Since these objects are stored all across the heap the tracing algorithm cannot take advantage of object locality and tends to demonstrate unusual memory access patterns, leading to inefficient use of the processor cache and poor performance. This makes tracing an excellent task to be done in parallel with the mutator threads so it does not slow down application code.
+
+Note that during tracing some synchronization is required between the collector and the mutator threads. When an object is changed (EG via: `set!`, `vector-set!`, etc) the mutator needs to add this object to the mark stack, which requires a mutex lock to safely update shared resources.
+
+## Cooperation by the Collector
+
+In practice a mutator will not always be able to cooperate in a timely manner. For example, a thread can block indefinitely waiting for user input or reading from a network port. In the meantime the collector will never be able to complete a handshake with this mutator and major GC will never be performed.
+
+Cyclone solves this problem by requiring that a mutator keep track of its thread state. With this information the collector can cooperate on behalf of a blocked mutator and do the work itself instead of waiting for the mutator. 
+
+The possible thread states are:
+
+- `CYC_THREAD_STATE_NEW` - A new thread not yet running.
+- `CYC_THREAD_STATE_RUNNABLE` - A thread that can be scheduled to run by the OS.
+- `CYC_THREAD_STATE_BLOCKED` - A thread that could be blocked.
+- `CYC_THREAD_STATE_BLOCKED_COOPERATING` - A blocked thread that the collector is cooperating with on behalf of the mutator.
+- `CYC_THREAD_STATE_TERMINATED` - A thread that has been terminated by the application but its resources have not been freed up yet.
+
+Before entering a C function that could block the mutator must call a function to update its thread state to `CYC_THREAD_STATE_BLOCKED`. This indicates to the collector that the thread may be blocked.
+
+When the collector handshakes it will check each mutator to see if it is blocked. Normally in this case the collector can just update the blocked mutator's status and move on to the next one. But if the mutator is transitioning to async all of its objects need to be relocated from the stack so they can be marked. In this case the collector changes the thread's state to `CYC_THREAD_STATE_BLOCKED_COOPERATING`, locks the mutator's mutex, and performs a minor collection for the thread. The mutator's objects can then be marked gray and its allocation color can be flipped. When it is finished cooperating for the mutator the collector releases its mutex.
+
+When a mutator exits a (potentially) blocking section of code, it must call another function to update its thread state to `CYC_THREAD_STATE_RUNNABLE`. In addition, the function will detect if the collector cooperated for this mutator by checking if its status is `CYC_THREAD_STATE_BLOCKED_COOPERATING`. If so, the mutator waits for its mutex to be released to ensure the collector has finished cooperating. The mutator then performs a minor GC again to ensure any additional objects - such as results from the blocking code - are moved to the heap before calling `longjmp` to jump back to the beginning of its stack. Either way, the mutator now calls into its continuation and resumes normal operations.
+
+## Running the Collector
+
+Cyclone checks the amount of free memory as part of its cooperation code. A major GC cycle is started if the amount of free memory dips below a threshold. Additionally, during a slow allocation the mutator checks how many heap pages are still free. If that number is too low we trigger a new GC cycle.
+
+The goal is to run major collections infrequently while at the same time minimizing the allocation of new heap pages.
+
+# Performance Measurements
+
+A [benchmark suite](#further-reading) was used to compare performance between the previous version of Cyclone (0.8.1) and the new version with lazy sweeping.
+
+The following table lists the differences in elapsed time (seconds) between versions:
+
+Benchmark | Baseline | Lazy Sweeping | Improvement
+--------- | -------- | ------------- | ------------
+browse | 25.34 | 22.21 | 12.35%
+deriv | 17.17 | 10.83 | 36.90%
+destruc | 38.00 | 30.94 | 18.59%
+diviter | 8.57 | 6.05 | 29.35%
+divrec | 17.98 | 14.49 | 19.46%
+puzzle | 46.97 | 44.97 | 4.25%
+triangl | 26.20 | 25.35 | 3.23%
+tak | 18.73 | 18.36 | 1.99%
+takl | 14.42 | 11.30 | 21.64%
+ntakl | 15.32 | 11.22 | 26.74%
+cpstak | 21.09 | 20.92 | 0.80%
+ctak | 2.78 | 2.77 | 0.28%
+fib | 41.26 | 41.05 | 0.51%
+fibc | 3.52 | 3.47 | 1.37%
+fibfp | 9.56 | 9.57 | -0.12%
+sum | 30.28 | 30.29 | -0.02%
+sumfp | 11.55 | 11.53 | 0.23%
+fft | 21.19 | 17.25 | 18.57%
+mbrot | 16.84 | 15.27 | 9.34%
+mbrotZ | 23.35 | 22.88 | 2.01%
+nucleic | 8.29 | 7.91 | 4.56%
+pi | 0.13 | 0.13 | 1.90%
+pnpoly | 43.64 | 41.80 | 4.22%
+ray | 9.13 | 9.12 | 0.05%
+simplex | 53.26 | 42.60 | 20.02%
+ack | 75.78 | 50.64 | 33.18%
+array1 | 30.84 | 30.65 | 0.60%
+string | 0.28 | 0.26 | 6.91%
+sum1 | 1.01 | 1.00 | 1.23%
+cat | 22.05 | 22.42 | -1.69%
+tail | 1.04 | 0.99 | 4.56%
+wc | 14.46 | 14.75 | -2.07%
+read1 | 3.61 | 3.20 | 11.31%
+conform | 40.67 | 34.00 | 16.40%
+dynamic | 33.84 | 27.61 | 18.41%
+earley | 31.49 | 26.84 | 14.78%
+graphs | 64.84 | 55.22 | 14.84%
+lattice | 84.57 | 68.93 | 18.50%
+matrix | 61.07 | 48.46 | 20.64%
+maze | 23.02 | 18.46 | 19.79%
+mazefun | 23.73 | 20.74 | 12.61%
+nqueens | 47.92 | 45.18 | 5.71%
+paraffins | 15.21 | 10.76 | 29.28%
+parsing | 39.50 | 38.55 | 2.41%
+peval | 32.11 | 27.72 | 13.67%
+primes | 18.79 | 12.83 | 31.74%
+quicksort | 56.64 | 48.13 | 15.03%
+scheme | 23.32 | 21.39 | 8.30%
+slatex | 9.74 | 8.14 | 16.37%
+chudnovsky | 0.09 | 0.09 | 1.79%
+nboyer | 13.80 | 11.84 | 14.24%
+sboyer | 11.90 | 12.09 | -1.60%
+gcbench | 37.12 | 32.37 | 12.79%
+mperm | 49.94 | 39.97 | 19.95%
+equal | 0.74 | 0.70 | 4.43%
+bv2string | 7.54 | 7.62 | -1.00%
+
+This data is illustrated in the following chart:
+
+<img src="images/benchmarks/lazy-sweep-benchmark-times.png" alt="Chart of Results">
+
+Here is an overall summary:
+
+Statistic | Benchmark | Result
+--------- | --------- | ------
+Overall Improvement | N/A |  13.36%
+Average Speedup     | N/A |  10.74%
+Maximum Speedup     | deriv |  36.90%
+Minimum Speedup     | wc |  -2.07%
+
+Overall we achieve an average speedup of 10.74% with lazy sweeping. That said there are a wide range of performance impacts across the whole benchmark suite. 
+
+Those benchmarks with the biggest speedups are likely those that are generating the most garbage. For example `ack` frequently invokes GC and most of the heap is freed during each GC cycle - this benchmark benefits greatly from lazy sweeping. Alternatively `wc` - which did not realize a speedup - spends most of its time running in a tight loop, invokes GC infrequently, and after a GC cycle there are many live objects left on the heap. 
+
+By all accounts lazy sweeping is a great win for Cyclone and has exceeded performance expectations. Though there is a slight performance overhead that affects some programs the overall performance improvement across a wide range of programs more than compensates. 
+
+# Conclusion
+
+[<img src="images/campfire.jpg" alt="Campfire">](#conclusion)
+
+The garbage collector is by far the most complex component of Cyclone. The primary motivation in developing it was to extend Baker's approach to support multiple native threads, which had never been done before prior to this project. Cyclone demonstrates the viability of this approach.
+
+Our GC is also positioned to potentially support state of the art GC's built on top of DLG such as Stopless, Chicken, and Clover.
+
+That said, heap memory fragmentation has not been addressed and could be an issue for long-running programs. Traditionally a compaction process is used to defragment a heap. An alternative strategy has also been suggested by Pizlo:
+
+> instead of copying objects to evacuate fragmented regions of the heap, fragmentation is instead embraced. A fragmented heap is allowed to stay fragmented, but the collector ensures that it can still satisfy allocation requests even if no large enough contiguous free region of space exists.
+
+Ultimately, a garbage collector is tricky to implement and the focus must primarily be on correctness first, with an eye towards performance.
+
+# Further Reading
+
+- [Baby's First Garbage Collector](http://journal.stuffwithstuff.com/2013/12/08/babys-first-garbage-collector/), by Bob Nystrom
+- [Chibi-Scheme](https://github.com/ashinn/chibi-scheme)
+- [CHICKEN internals: the garbage collector](http://www.more-magic.net/posts/internals-gc.html), by Peter Bex
+- [CONS Should Not CONS Its Arguments, Part II: Cheney on the M.T.A.](https://github.com/justinethier/cyclone/raw/master/docs/research-papers/CheneyMTA.pdf), by Henry Baker
+- Fragmentation Tolerant Real Time Garbage Collection (PhD Dissertation), by Filip Pizlo
+- [The Garbage Collection Handbook: The Art of Automatic Memory Management](http://gchandbook.org/), by Antony Hosking, Eliot Moss, and Richard Jones
+- Implementing an on-the-fly garbage collector for Java, by Domani et al
+- Incremental Parallel Garbage Collection, by Paul Thomas
+- Portable, Unobtrusive Garbage Collection for Multiprocessor Systems, by Damien Doligez and Georges Gonthier
+- [Introducing Riptide: WebKit's Retreating Wavefront Concurrent Garbage Collector](https://webkit.org/blog/7122/introducing-riptide-webkits-retreating-wavefront-concurrent-garbage-collector/), by Filip Pizlo
+- [Scheme Benchmarks](https://ecraven.github.io/r7rs-benchmarks/), by [ecraven](https://github.com/ecraven)
+- [The Ramsey sweep](http://people.csail.mit.edu/gregs/ll1-discuss-archive-html/msg00761.html), by Olin Shivers
+
+
+# Appendix
+
+## Terms
+- Collector - A thread running the garbage collection code. The collector is responsible for coordinating and performing most of the work for major garbage collections.
+- Continuation - With respect to the collectors, this is a function that is called to resume execution of application code. For more information see [this article on continuation passing style](https://en.wikipedia.org/wiki/Continuation-passing_style).
+- Forwarding Pointer - When a copying collector relocates an object it leaves one of these pointers behind with the object's new address.
+- Garbage Collector (GC) - A form of automatic memory management that frees memory allocated by objects that are no longer used by the program.
+- Heap - A section of memory used to store longer-lived variables. In C, heap memory is allocated using built-in functions such as `malloc`, and memory must be explicitly deallocated using `free`.
+- Mutation - A modification to an object. For example, changing a vector (array) entry.
+- Mutator - A thread running user (or "application") code; there may be more than one mutator running concurrently.
+- Read Barrier - Code that is executed before reading an object. Read barriers have a larger overhead than write barriers because object reads are much more common.
+- Root - During tracing the collector uses these objects as the starting point to find all reachable data.
+- Stack - The C call stack, where local variables are allocated and freed automatically when a function returns. Stack variables only exist until the function that created them returns, at which point the memory may be overwritten. The stack has a very limited size and undefined behavior (usually a crash) will result if that size is exceeded.
+- Sweep - A phase of garbage collection where the heap - either the whole heap or a subset - is scanned and any unused slots are made available for new allocations.
+- Tracing - A phase of garbage collection that visits and marks all live objects on the heap. This is done by starting from a set of "root" objects and iteratively following references to child objects.
+- Write Barrier - Code that is executed before writing to an object.
+
+## Code
+
+The implementation code is available here:
+
+- [`runtime.c`](../runtime.c) contains most of the runtime system, including code to perform minor GC. A good place to start would be the `GC` and `gc_minor` functions.
+- [`gc.c`](../gc.c) contains the major GC code.
+
+## Data Structures
+
+### Heap
+
+The heap is used to store all objects that survive minor GC, and consists of a linked list of pages. Each page contains a contiguous block of memory and a linked list of free chunks. When a new chunk is requested the first free chunk large enough to meet the request is found and either returned directly or carved up into a smaller chunk to return to the caller.
+
+Memory is always allocated in multiples of 32 bytes. On the one hand this helps prevent external fragmentation by allocating many objects of the same size. But on the other it incurs internal fragmentation because an object will not always fill all of its allocated memory.
+
+A separate set of heap pages is maintained by each mutator thread. Thus there is no need to lock during allocation or sweep operations.
+
+### Thread Data
+
+At runtime Cyclone passes the current continuation, number of arguments, and a thread data parameter to each compiled C function. The continuation and arguments are used by the application code to call into its next function with a result. Thread data is a structure that contains all of the necessary information to perform collections, including:
+
+- Thread state
+- Stack boundaries
+- Jump buffer
+- List of mutated objects detected by the minor GC write barrier
+- Major GC parameters - mark buffer, last read/write, etc (see next sections)
+- Call history buffer
+- Exception handler stack
+
+Each thread has its own instance of the thread data structure and its own stack (assigned by the C runtime/compiler).
+
+### Object Header
+
+Each object contains a header with the following information:
+
+- Tag - A number indicating the object type: cons, vector, string, etc.
+- Mark - The status of the object's memory.
+- Grayed - A field indicating the object has been grayed but has not been added to a mark buffer yet (see major GC sections below). This is only applicable for objects on the stack.
+
+### Mark Buffers
+
+Mark buffers are used to hold gray objects instead of explicitly marking objects gray. These mark buffers consist of fixed-size pointer arrays that are increased in size as necessary using `realloc`.  Each mutator has a reference to a mark buffer holding their gray objects. A last write variable is used to keep track of the buffer size.
+
+The collector updates the mutator's last read variable each time it marks an object from the mark buffer. Marking is finished when last read and last write are equal. The collector also maintains a single mark stack of objects that the collector has marked gray.
+
+An object on the stack cannot be added to a mark buffer because the reference may become invalid before it can be processed by the collector.
+

docs/Release-Checklist.md

@@ -7,6 +7,7 @@ Steps for making a release of Cyclone:
   - `Dockerfile`
   - `DEBIAN/control` in cyclone-bootstrap
   - `.github/workflows/Release.yml` job in cyclone-bootstrap
+  - `libs/common.sld` in cyclone winds repo
 - Update documentation, if applicable
 - Tag releases and push to Github
 - Upload release notes to `gh-pages` branch
@@ -14,3 +15,8 @@ Steps for making a release of Cyclone:
 - Update release on Homebrew (automated)
 - Update release on Dockerhub (push to bitbucket)
 - Upload new binary from cyclone-bootstrap release build to the cyclone-scheme "packages" repo
+- Update WASM hosted Cyclone
+  - Trigger CI action on the WASM repo to recompile the WASM binary: https://github.com/cyclone-scheme/wasm-terminal
+  - Download the generated `.zip` artifact
+  - Extract `terminal.js` and `terminal.wasm` and copy to the `_site` directory in the repo to update the build
+  - Optionally update year in the `terminal.html` file

docs/User-Manual.md

@@ -12,7 +12,12 @@
   - [Generated Files](#generated-files)
   - [Interpreter](#interpreter)
 - [Language Details](#language-details)
+- [Macros](#macros)
+  - [Syntax Rules](#syntax-rules)
+  - [Explicit Renaming](#explicit-renaming)
+  - [Debugging](#debugging)
 - [Multithreaded Programming](#multithreaded-programming)
+  - [Thread Safety](#thread-safety)
 - [Foreign Function Interface](#foreign-function-interface)
   - [Writing a Scheme Function in C](#writing-a-scheme-function-in-c)
   - [Foreign Library](#foreign-library)
@@ -159,6 +164,51 @@ A [R<sup>7</sup>RS Compliance Chart](Scheme-Language-Compliance.md) lists differ
 
 [API Documentation](API.md) is available for the libraries provided by Cyclone.
 
+# Macros
+
+## Syntax Rules
+
+High-level hygienic macros may be created using `syntax-rules`. This system is based on a template language specified by R<sup>7</sup>RS. The specification goes into more detail on how to work with these macros:
+
+    (define-syntax when
+      (syntax-rules  ()
+        ((when test result1 result2 ...)
+         (if test
+             (begin result1 result2 ...)))))
+
+## Explicit Renaming
+
+Alternatively a low-level explicit renaming (ER) system is provided that allows defining macros using Scheme code, in a similar manner as `defmacro`. 
+
+This macro system provides the convenience functions `(rename identifier)` to hygienically rename an identifier and `(compare identifier1 identifier2)` to compare two identifiers:
+
+    (define-syntax when
+      (er-macro-transformer
+        (lambda (exp rename compare)
+          (if (null? (cdr exp)) (error/loc "empty when" exp))
+          (if (null? (cddr exp)) (error/loc "no when body" exp))
+          `(if ,(cadr exp)
+               ((lambda () ,@(cddr exp)))))))
+
+## Debugging
+
+- From the interpreter one can use `expand` to perform macro expansion on the given expression:
+
+      cyclone> (expand '(when #t (+ 1 2 3)))
+      (if #t ((lambda () (+ 1 2 3))) )
+
+- Alternatively when developing an ER macro, since its just a Scheme function, the macro can be defined as a `lambda` and passed a quoted expression to debug:
+
+      (pretty-print
+        ((lambda (exp rename compare)
+           (if (null? (cdr exp)) (error/loc "empty when" exp))
+           (if (null? (cddr exp)) (error/loc "no when body" exp))
+           `(if ,(cadr exp)
+                ((lambda () ,@(cddr exp)))))
+        '(when #t  (write 1) (write 2)) #f #f))
+
+- Finally, a Scheme file may be compiled with the `-t` option to write all of the intermediate transformations - including macro expansions - out to the corresponding `.c` file.
+
 # Multithreaded Programming
 
 ## Overview
@@ -167,17 +217,11 @@ The [`srfi 18`](api/srfi/18.md) library may be imported to provide support for m
 
 Many helper functions are provided by [`(cyclone concurrent)`](api/cyclone/concurrent.md) to make it easier to write multithreaded programs.
 
-## Memory Layout
+## Thread Safety
 
-Cyclone's garbage collector moves objects in memory from the first generation (on the stack) to the second generation (on the heap). This causes problems when an object is used by multiple threads, as the address another thread expects to find an object at may suddenly change. To prevent race conditions an object must be guaranteed to be on the heap prior to being used by another thread. 
+Cyclone uses a generational garbage collector that automatically move objects from the first generation (on the stack) to the second generation (on the heap). This move is performed by the application thread that originally created the object. Without the proper safety measures in place this could cause problems as the address that another thread is using for an object may suddenly change. 
 
-The easiest way to meet this guarantee is to use one of the `make-shared` and `share-all!` functions from `(cyclone concurrent)`. Several of the other constructs from that library (such as futures and shared queues) use these functions internally to guarantee objects are safely shared between threads.
-
-Finally, note there are some objects that are not relocated so the above does not apply:
-
-- Characters and integers are stored using value types and do not need to be garbage collected.
-- Symbols are stored in a global table rather than the stack/heap.
-- Mutexes, Atomics, and other concurrency-oriented objects are always allocated on the heap since by definition they are used by more than one thread.
+**To prevent race conditions Cyclone automatically relocates objects to the heap before they can be accessed by more than one thread.** It is still necessary for application code to use the appropriate concurrency constructs - such as locks, atomics, etc - to ensure that an object is safely accessed by only one thread at a time.
 
 # Foreign Function Interface
 

docs/api/cyclone/foreign.md

@@ -2,12 +2,15 @@
 
 The `(cyclone foreign)` provides a convenient interface for integrating with C code. It is based in concept on the `(chicken foreign)` module from CHICKEN Scheme. Similarly to that module, this library manipulates the C code directly before it is compiled to a native binary. It is not possible to call these forms at runtime.
 
-# Overview
+# API
 
 - [`c-code`](#c-code)
 - [`c-value`](#c-value)
 - [`c-define`](#c-define)
 - [`c-define-type`](#c-define-type)
+- [`opaque?`](#opaque)
+- [`opaque-null?`](#opaque-null)
+- [`make-opaque`](#make-opaque)
 
 ## c-code
 
@@ -51,6 +54,23 @@ EG, to define a type that consists of integers in Scheme and strings in C:
 
     (c-define-type string-as-integer string number->string string->number)
 
+## opaque?
+
+    (opaque? obj)
+
+Predicate to determine if `obj` is a C Opaque object.
+
+## opaque-null?
+
+    (opaque-null? obj)
+
+Predicate to determine if `obj` is a C Opaque object that contains `NULL`.
+
+## make-opaque
+
+    (make-opaque)
+
+Create a C Opaque object containing `NULL`.
 
 # Type Specifiers
 

docs/api/scheme/cyclone/libraries.md

@@ -5,10 +5,12 @@ The `(scheme cyclone libraries)` library implements r7rs libraries.
 *This library is used internally by the compiler and its API may change at any time.*
 
 - [`library?`](#library)
+- [`library-exists?`](#library-exists)
 - [`lib:list->import-set`](#liblist-import-set)
 - [`lib:name`](#libname)
 - [`lib:name->string`](#libname-string)
 - [`lib:name->symbol`](#libname-symbol)
+- [`lib:name->unique-string`](#libname-unique-string)
 - [`lib:result`](#libresult)
 - [`lib:exports`](#libexports)
 - [`lib:rename-exports`](#librename-exports)
@@ -21,7 +23,6 @@ The `(scheme cyclone libraries)` library implements r7rs libraries.
 - [`lib:import->path`](#libimport-path)
 - [`lib:read-imports`](#libread-imports)
 - [`lib:import->export-list`](#libimport-export-list)
-- [`lib:resolve-imports`](#libresolve-imports)
 - [`lib:resolve-meta`](#libresolve-meta)
 - [`lib:get-all`](#libget-all)
 - [`lib:get-all-import-deps`](#libget-all-import-deps)
@@ -33,49 +34,183 @@ The `(scheme cyclone libraries)` library implements r7rs libraries.
 
     (library? obj)
 
+Predicate - return `#t` if the given `obj` a `define-library` S-expression or `#f` otherwise.
+
+# library-exists?
+
+    (library-exists? import-set)
+    (library-exists? import-set file-extension)
+
+Determine if a library exists on the file system for the given import set.
+
+Checks for the default file extension of `.sld` unless `file-extension` is provided.
+
 # lib:list->import-set
 
+    (lib:list->import-set lis)
+
+Convert a raw list to an import set. For example, a list might be `(srfi 18)` containing the number `18`. An import set contains only symbols or sub-lists. Any numbers are converted to the corresponding symbol.
+
+This is also a convenient time to do any name conversions from an alias to the actual library, so any such conversion will also be performed.
+
 # lib:name
 
+    (lib:name ast)
+
+Return the library name as an import set. For example `(scheme base)`.
+
 # lib:name->string
 
+    (lib:name->string name)
+
+Convert name (as list of symbols) to a mangled string.
+
 # lib:name->symbol
 
+    (lib:name->symbol name)
+
+Convert library name to a unique symbol.
+
+# lib:name->unique-string
+
+    (lib:name->unique-string name)
+
+Convert name (as list of symbols) to a mangled string guaranteed to be unique.
+
 # lib:result
 
+    (lib:result result)
+    
+Helper function that returns `result` unless `result` is `#f` in which case the empty list is returned as a default value.
+
 # lib:exports
 
+    (lib:exports ast)
+
+Return the library's exports.
+
 # lib:rename-exports
 
+   (lib:rename-exports ast)
+
+Return the library's exports that are renamed.
+
 # lib:imports
 
+    (lib:imports ast)
+
+Return the library's imports.
+
 # lib:body
 
+    (lib:body ast)
+
+Return the given library's body. IE, the contents of `begin`.
+
 # lib:includes
 
+    (lib:includes ast)
+
+Retun the library's include directives.
+
 # lib:include-c-headers
 
+    (lib:include-c-headers ast)
+
+Return the library's `include-c-headers` directives.
+
 # lib:import->filename
 
+    (lib:import->filename import)
+    (lib:import->filename import extension)
+    (lib:import->filename import extension append-path)
+    (lib:import->filename import extension append-path prepend-path)
+
+Resolve library filename given an import `import`. 
+
+Options:
+
+- `extension`, assumes ".sld" file extension if one is not specified.
+- `append-path`, list of strings
+- `prepend-path`, list of strings
+
 # lib:import->metalist
 
+    (lib:import->metalist import append-dirs prepend-dirs)
+
+Given an import set `import` find the associated `.meta` file, if it exists, and return its contents. An empty list is returned if a file cannot be found.
+
 # lib:import->path
 
+    (lib:import->path import append-dirs prepend-dirs include)
+
+Get path to directory that contains the library.
+
 # lib:read-imports
 
+    (lib:read-imports import append-dirs prepend-dirs expander)
+
+Given a single import from an import-set, open the corresponding library file and retrieve the library's import-set.
+
 # lib:import->export-list
 
-# lib:resolve-imports
+    (lib:import->export-list import append-dirs prepend-dirs expander)
+
+Read export list for a given import.
 
 # lib:resolve-meta
 
+    (lib:resolve-meta imports append-dirs prepend-dirs)
+
+Return contents of all `.meta` files for the given import sets `imports`.
+
 # lib:get-all
 
+    (lib:get-all ast tag)
+
+Get all instances of given tagged list from a library definition, and collect the contents of them into a single list.
+
 # lib:get-all-import-deps
 
+    (lib:get-all-import-deps imports append-dirs prepend-dirs expander)
+
+Given an import set, get all dependant import names that are required
+The list of deps is intended to be returned in order, such that the
+libraries can be initialized properly in sequence.
+
 # lib:get-dep-list
 
+    (lib:get-dep-list imports)
+
+Given a list of alists `(library-name . imports)`, resolve all of the dependencies and return an ordered list of library names such that each library is encounted after the libraries it imports (IE, it's dependencies). For example:
+
+    (lib:get-dep-list `(
+      ((srfi 69) (scheme base) (scheme char))
+      ((scheme base) (scheme cyclone common))
+      ((scheme cyclone common))
+      ((scheme char) (scheme base))
+      ((scheme cyclone hashset) (scheme base) (scheme write))
+      ((scheme write) (scheme base))
+      ((scheme cyclone primitives) (scheme base) (scheme cyclone hashset) (srfi 69))
+      ((scheme process-context))
+      ((scheme cyclone libraries) (scheme base) (scheme read) (scheme process-context) (scheme cyclone util))
+      ((scheme read) (scheme base) (scheme cyclone common) (scheme cyclone util) (scheme char))
+      ((scheme cyclone util) (scheme base) (scheme char))
+      ((scheme eval) (scheme cyclone util) (scheme cyclone libraries) (scheme cyclone primitives) (scheme base) (scheme file) (scheme read))
+      ((scheme file) (scheme base))
+      ((scheme lazy) (scheme base))
+    ))
+
 # lib:imports->idb
 
+    (lib:imports->idb imports append-dirs prepend-dirs expander)
+
+Take a list of imports and create a "database" from them
+consisting of maps between each exported identifier and the
+library that imports that identifier. 
+
 # lib:idb:ids
 
+    (lib:idb:ids db)
+
+Take an idb "database" `db` and create a list of identifiers that are imported. EG: `((call/cc . (scheme base)))` ==> `(call/cc)`

docs/api/scheme/cyclone/primitives.md

@@ -15,7 +15,7 @@ The `(scheme cyclone primitives)` library contains information about Cyclone's s
 - [`prim:cont?`](#primcont)
 - [`prim:cont/no-args?`](#primcontno-args)
 - [`prim:arg-count?`](#primarg-count)
-- [`prim:allocates-object?)`](#primallocates-object)
+- [`prim:allocates-object?`](#primallocates-object)
 
 # prim?
 
@@ -85,7 +85,7 @@ Is `sym` a primitive function that passes a continuation or thread data but has
 
 Should the compiler pass an integer arg count as the function's first parameter?
 
-# prim:allocates-object?)
+# prim:allocates-object?
 
     (prim:allocates-object? sym use-alloca?)
 

docs/api/scheme/cyclone/transforms.md

@@ -43,8 +43,6 @@ The `(scheme cyclone transforms)` library performs Scheme-to-Scheme transformati
 - [`env-make->id              `](#env-make-id)
 - [`env-make->values          `](#env-make-values)
 - [`env-make?                 `](#env-make)
-- [`expand                    `](#expand)
-- [`expand-lambda-body        `](#expand-lambda-body)
 - [`filter-unused-variables   `](#filter-unused-variables)
 - [`free-vars                 `](#free-vars)
 - [`get-macros                `](#get-macros)
@@ -163,10 +161,6 @@ The `(scheme cyclone transforms)` library performs Scheme-to-Scheme transformati
 
 # env-make? 
 
-# expand 
-
-# expand-lambda-body
-
 # filter-unused-variables 
 
 # free-vars 

docs/api/scheme/eval.md

@@ -7,6 +7,7 @@ For more information see the [R<sup>7</sup>RS Scheme Specification](../../r7rs.p
 - [`eval`](#eval)
 - [`create-environment`](#create-environment)
 - [`setup-environment`](#setup-environment)
+- [`expand`](#expand)
 
 # eval
 
@@ -30,3 +31,14 @@ A non-standard function to create a new environment on top of the default one.
     (setup-environment)
 
 A non-standard function to initialize a new global environment.
+
+# expand
+
+    (expand expr [[environment] [rename-environment]])
+
+Perform macro expansion on `expr` and return the resulting expression.
+
+`environment` may be optionally passed as the current environment. 
+
+`rename-environment` is an optional argument of an environment containing variables renamed directly by macros. This would generally be an empty environment when using this function for macro debugging.
+

docs/api/srfi/18.md

@@ -92,9 +92,9 @@ The current thread exits the running state as if its quantum had expired.
 
 # thread-terminate!
 
-    (thread-terminate!)
+    (thread-terminate! thread)
 
-Immediately abort the current thread.
+Immediately abort the given thread.
 
 # thread-join!
 

ffi.c

@@ -20,7 +20,8 @@ void *Cyc_init_thread(object thread_and_thunk, int argc, object *args);
  * for the call and perform a minor GC to ensure any returned object
  * is on the heap and safe to use.
  */
-static void Cyc_return_from_scm_call(void *data, object _, int argc, object *args)
+static void Cyc_return_from_scm_call(void *data, object _, int argc,
+                                     object * args)
 {
   gc_thread_data *thd = data;
   object result = args[0];
@@ -46,7 +47,8 @@ static void Cyc_after_scm_call(void *data, object _, int argc, object *args)
   gc_thread_data *thd = data;
   object result = args[0];
   mclosure0(clo, Cyc_return_from_scm_call);
-  object buf[1]; buf[0] = result;
+  object buf[1];
+  buf[0] = result;
   GC(thd, &clo, buf, 1);
 }
 
@@ -58,7 +60,8 @@ static void Cyc_after_scm_call(void *data, object _, int argc, object *args)
  * can do anything "normal" Scheme code does, and any returned
  * objects will be on the heap and available for use by the caller.
  */
-object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *args)
+object Cyc_scm_call(gc_thread_data * parent_thd, object fnc, int argc,
+                    object * args)
 {
   jmp_buf l;
   gc_thread_data local;
@@ -105,7 +108,8 @@ object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *ar
  * We store results and longjmp back to where we started, at the
  * bottom of the trampoline (we only jump once).
  */
-static void no_gc_after_call_scm(gc_thread_data *thd, object _, int argc, object *args)
+static void no_gc_after_call_scm(gc_thread_data * thd, object _, int argc,
+                                 object * args)
 {
   object result = args[0];
   thd->gc_cont = result;

gc.c

@@ -28,18 +28,19 @@
 
 // 64-bit is 3, 32-bit is 2
 #define GC_BLOCK_BITS 5
-#define GC_BLOCK_SIZE (1 << GC_BLOCK_BITS)
 
 /* HEAP definitions, based off heap from Chibi scheme */
 #define gc_heap_first_block(h) ((object)(h->data + gc_heap_align(gc_free_chunk_size)))
-#define gc_heap_last_block(h) ((object)((char*)h->data + h->size - gc_heap_align(gc_free_chunk_size)))
 #define gc_heap_end(h) ((object)((char*)h->data + h->size))
 #define gc_heap_pad_size(s) (sizeof(struct gc_heap_t) + (s) + gc_heap_align(1))
 #define gc_free_chunk_size (sizeof(gc_free_list))
 
 #define gc_align(n, bits) (((n)+(1<<(bits))-1)&(((uintptr_t)-1)-((1<<(bits))-1)))
 
-//#define gc_word_align(n) gc_align((n), 2)
+// Align to 8 byte block size (EG: 8, 16, etc)
+#define gc_word_align(n) gc_align((n), 3)
+
+// Align on GC_BLOCK_BITS, currently block size of 32 bytes
 #define gc_heap_align(n) gc_align(n, GC_BLOCK_BITS)
 
 ////////////////////
@@ -54,6 +55,7 @@ static unsigned char gc_color_purple = 1;  // There are many "shades" of purple,
 
 static int gc_status_col = STATUS_SYNC1;
 static int gc_stage = STAGE_RESTING;
+static int gc_threads_merged = 0;
 
 // Does not need sync, only used by collector thread
 static void **mark_stack = NULL;
@@ -157,13 +159,17 @@ static void mark_buffer_free(mark_buffer *mb)
 const int NUM_ALLOC_SIZES = 10;
 static double allocated_size_counts[10] = {
   0, 0, 0, 0, 0,
-  0,0,0,0,0};
+  0, 0, 0, 0, 0
+};
+
 static double allocated_obj_counts[25] = {
   0, 0, 0, 0, 0,
   0, 0, 0, 0, 0,
   0, 0, 0, 0, 0,
   0, 0, 0, 0, 0,
-  0,0,0,0,0};
+  0, 0, 0, 0, 0
+};
+
 // TODO: allocated object sizes (EG: 32, 64, etc).
 static double allocated_heap_counts[4] = { 0, 0, 0, 0 };
 
@@ -370,7 +376,8 @@ void gc_free_old_thread_data()
  * @param gc_heap Root of the heap
  * @return Free space in bytes
  */
-uint64_t gc_heap_free_size(gc_heap *h) {
+uint64_t gc_heap_free_size(gc_heap * h)
+{
   uint64_t free_size = 0;
   for (; h; h = h->next) {
     if (h->is_unswept == 1) {   // Assume all free prior to sweep
@@ -493,13 +500,15 @@ void gc_print_fixed_size_free_list(gc_heap *h)
  * @brief Essentially this is half of the sweep code, for sweeping bump&pop
  * @param h Heap page to convert
  */
-static size_t gc_convert_heap_page_to_free_list(gc_heap *h, gc_thread_data *thd) 
+static size_t gc_convert_heap_page_to_free_list(gc_heap * h,
+                                                gc_thread_data * thd)
 {
   size_t freed = 0;
   object p;
   gc_free_list *next;
   int remaining = h->size - (h->size % h->block_size);
-  if (h->data_end == NULL) return 0; // Already converted
+  if (h->data_end == NULL)
+    return 0;                   // Already converted
 
   next = h->free_list = NULL;
   while (remaining > h->remaining) {
@@ -508,8 +517,7 @@ static size_t gc_convert_heap_page_to_free_list(gc_heap *h, gc_thread_data *thd)
     int color = mark(p);
 //    printf("found object %d color %d at %p with remaining=%lu\n", tag, color, p, remaining);
     // free space, add it to the free list
-    if (color != thd->gc_alloc_color &&
-        color != thd->gc_trace_color) { //gc_color_clear) 
+    if (color != thd->gc_alloc_color && color != thd->gc_trace_color) { //gc_color_clear) 
       // Run any finalizers
       if (type_of(p) == mutex_tag) {
 #if GC_DEBUG_VERBOSE
@@ -545,8 +553,7 @@ static size_t gc_convert_heap_page_to_free_list(gc_heap *h, gc_thread_data *thd)
       freed += h->block_size;
       if (next == NULL) {
         next = h->free_list = p;
-      }
-      else {
+      } else {
         next->next = p;
         next = next->next;
       }
@@ -561,8 +568,7 @@ static size_t gc_convert_heap_page_to_free_list(gc_heap *h, gc_thread_data *thd)
 //    printf("no object at %p fill with free list\n", p);
     if (next == NULL) {
       next = h->free_list = p;
-    }
-    else {
+    } else {
       next->next = p;           //(gc_free_list *)(((char *) next) + h->block_size);
       next = next->next;
     }
@@ -621,7 +627,8 @@ static gc_heap *gc_sweep_fixed_size(gc_heap * h, gc_thread_data *thd)
     q = h->free_list;
     while (p < end) {
       // find preceding/succeeding free list pointers for p
-      for (r = (q?q->next:NULL); r && ((char *)r < (char *)p); q = r, r = r->next) ;
+      for (r = (q ? q->next : NULL); r && ((char *)r < (char *)p);
+           q = r, r = r->next) ;
       if ((char *)q == (char *)p || (char *)r == (char *)p) {   // this is a free block, skip it
         //printf("Sweep skip free block %p remaining=%lu\n", p, remaining);
         p = (object) (((char *)p) + h->block_size);
@@ -637,8 +644,7 @@ static gc_heap *gc_sweep_fixed_size(gc_heap * h, gc_thread_data *thd)
         exit(1);
       }
 #endif
-      if (mark(p) != thd->gc_alloc_color && 
-          mark(p) != thd->gc_trace_color) { //gc_color_clear) 
+      if (mark(p) != thd->gc_alloc_color && mark(p) != thd->gc_trace_color) {   //gc_color_clear) 
 #if GC_DEBUG_VERBOSE
         fprintf(stderr, "sweep is freeing unmarked obj: %p with tag %d\n", p,
                 type_of(p));
@@ -737,7 +743,8 @@ gc_heap *gc_heap_free(gc_heap *page, gc_heap *prev_page)
     return NULL;
   }
 #if GC_DEBUG_TRACE
-  fprintf(stderr, "DEBUG freeing heap type %d page at addr: %p\n", page->type, page);
+  fprintf(stderr, "DEBUG freeing heap type %d page at addr: %p\n", page->type,
+          page);
 #endif
 
   prev_page->next = page->next;
@@ -753,16 +760,19 @@ gc_heap *gc_heap_free(gc_heap *page, gc_heap *prev_page)
 static int gc_is_heap_empty(gc_heap * h)
 {
   gc_free_list *f;
-  if (!h) return 0;
+  if (!h)
+    return 0;
 
   if (h->data_end) {            // Fixed-size bump&pop
     return (h->remaining == (h->size - (h->size % h->block_size)));
   }
 
-  if (!h->free_list) return 0;
+  if (!h->free_list)
+    return 0;
 
   f = h->free_list;
-  if (f->size != 0 || !f->next) return 0;
+  if (f->size != 0 || !f->next)
+    return 0;
 
   f = f->next;
   return (f->size + gc_heap_align(gc_free_chunk_size)) == h->size;
@@ -797,7 +807,8 @@ void gc_print_stats(gc_heap * h)
     heap_is_empty = gc_is_heap_empty(h);
     fprintf(stderr,
             "Heap type=%d, page size=%u, is empty=%d, used=%u, free=%u, free chunks=%u, min=%u, max=%u\n",
-            h->type, h->size, heap_is_empty, h->size - free, free, free_chunks, free_min, free_max);
+            h->type, h->size, heap_is_empty, h->size - free, free, free_chunks,
+            free_min, free_max);
   }
 }
 
@@ -826,7 +837,8 @@ char *gc_copy_obj(object dest, char *obj, gc_thread_data * thd)
       hp->num_args = ((closureN) obj)->num_args;
       hp->num_elements = ((closureN) obj)->num_elements;
       hp->elements = (object *) (((char *)hp) + sizeof(closureN_type));
-      memcpy(hp->elements, ((closureN)obj)->elements, sizeof(object *) * hp->num_elements);
+      memcpy(hp->elements, ((closureN) obj)->elements,
+             sizeof(object *) * hp->num_elements);
       return (char *)hp;
     }
   case pair_tag:{
@@ -865,7 +877,8 @@ char *gc_copy_obj(object dest, char *obj, gc_thread_data * thd)
       type_of(hp) = vector_tag;
       hp->num_elements = ((vector) obj)->num_elements;
       hp->elements = (object *) (((char *)hp) + sizeof(vector_type));
-      memcpy(hp->elements, ((vector)obj)->elements, sizeof(object *) * hp->num_elements);
+      memcpy(hp->elements, ((vector) obj)->elements,
+             sizeof(object *) * hp->num_elements);
       return (char *)hp;
     }
   case bytevector_tag:{
@@ -1048,8 +1061,7 @@ gc_heap *gc_grow_heap(gc_heap * h, size_t size, gc_thread_data *thd)
       new_size = HEAP_SIZE;
     }
 #if GC_DEBUG_TRACE
-    fprintf(stderr, "Growing heap %d new page size = %zu\n", h->type,
-            new_size);
+    fprintf(stderr, "Growing heap %d new page size = %zu\n", h->type, new_size);
 #endif
   }
   h_last = gc_heap_last(h_last);        // Ensure we don't unlink any heaps
@@ -1073,8 +1085,7 @@ gc_heap *gc_grow_heap(gc_heap * h, size_t size, gc_thread_data *thd)
  * This function will fail if there is no space on the heap for the 
  * requested object.
  */
-void *gc_try_alloc(gc_heap * h, size_t size, char *obj,
-                   gc_thread_data * thd)
+void *gc_try_alloc(gc_heap * h, size_t size, char *obj, gc_thread_data * thd)
 {
   gc_free_list *f1, *f2, *f3;
 
@@ -1127,7 +1138,8 @@ int gc_num_unswept_heaps(gc_heap *h)
   return count;
 }
 
-void gc_start_major_collection(gc_thread_data *thd){
+void gc_start_major_collection(gc_thread_data * thd)
+{
   if (ck_pr_load_int(&gc_stage) == STAGE_RESTING) {
 #if GC_DEBUG_TRACE
     gc_log(stderr, "gc_start_major_collection - initiating collector");
@@ -1136,7 +1148,8 @@ void gc_start_major_collection(gc_thread_data *thd){
   }
 }
 
-void *gc_try_alloc_slow(gc_heap *h_passed, gc_heap *h, size_t size, char *obj, gc_thread_data *thd)
+void *gc_try_alloc_slow(gc_heap * h_passed, gc_heap * h, size_t size, char *obj,
+                        gc_thread_data * thd)
 {
 #ifdef CYC_HIGH_RES_TIMERS
   long long tstamp = hrt_get_current();
@@ -1214,7 +1227,8 @@ hrt_log_delta("gc sweep", tstamp);
  * This function will fail if there is no space on the heap for the 
  * requested object.
  */
-static void *gc_try_alloc_fixed_size(gc_heap * h, size_t size, char *obj, gc_thread_data * thd)
+static void *gc_try_alloc_fixed_size(gc_heap * h, size_t size, char *obj,
+                                     gc_thread_data * thd)
 {
   void *result;
 
@@ -1244,7 +1258,8 @@ static void *gc_try_alloc_fixed_size(gc_heap * h, size_t size, char *obj, gc_thr
   return NULL;
 }
 
-void *gc_try_alloc_slow_fixed_size(gc_heap *h_passed, gc_heap *h, size_t size, char *obj, gc_thread_data *thd)
+void *gc_try_alloc_slow_fixed_size(gc_heap * h_passed, gc_heap * h, size_t size,
+                                   char *obj, gc_thread_data * thd)
 {
 #ifdef CYC_HIGH_RES_TIMERS
   long long tstamp = hrt_get_current();
@@ -1321,11 +1336,11 @@ void *gc_alloc_bignum(gc_thread_data *data)
   //tmp.hdr.mark = gc_color_red;
   //tmp.hdr.grayed = 0;
   tmp.tag = bignum_tag;
-  bn = gc_alloc(((gc_thread_data *)data)->heap, sizeof(bignum_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
+  bn = gc_alloc(((gc_thread_data *) data)->heap, sizeof(bignum_type),
+                (char *)(&tmp), (gc_thread_data *) data, &heap_grown);
 
   if ((result = mp_init(&bignum_value(bn))) != MP_OKAY) {
-     fprintf(stderr, "Error initializing number %s",
-                     mp_error_to_string(result));
+    fprintf(stderr, "Error initializing number %s", mp_error_to_string(result));
     exit(1);
   }
   return bn;
@@ -1340,10 +1355,10 @@ void *gc_alloc_bignum(gc_thread_data *data)
 void *gc_alloc_from_bignum(gc_thread_data * data, bignum_type * src)
 {
   int heap_grown;
-  return gc_alloc(((gc_thread_data *)data)->heap, sizeof(bignum_type), (char *)(src), (gc_thread_data *)data, &heap_grown);
+  return gc_alloc(((gc_thread_data *) data)->heap, sizeof(bignum_type),
+                  (char *)(src), (gc_thread_data *) data, &heap_grown);
 }
 
-
 /**
  * @brief Allocate memory on the heap for an object
  * @param hrt   The root of the heap to allocate from
@@ -1364,33 +1379,13 @@ void *gc_alloc(gc_heap_root * hrt, size_t size, char *obj, gc_thread_data * thd,
   gc_heap *h_passed, *h = NULL;
   int heap_type;
   void *(*try_alloc)(gc_heap * h, size_t size, char *obj, gc_thread_data * thd);
-  void *(*try_alloc_slow)(gc_heap *h_passed, gc_heap *h, size_t size, char *obj, gc_thread_data *thd);
+  void *(*try_alloc_slow)(gc_heap * h_passed, gc_heap * h, size_t size,
+                          char *obj, gc_thread_data * thd);
   size = gc_heap_align(size);
-  if (size <= 32) {
-    heap_type = HEAP_SM;
-    //try_alloc = &gc_try_alloc;
-    //try_alloc_slow = &gc_try_alloc_slow;
-    // TODO:
+  if (size <= (32 * (LAST_FIXED_SIZE_HEAP_TYPE + 1))) {
+    heap_type = (size - 1) / 32;
     try_alloc = &gc_try_alloc_fixed_size;
     try_alloc_slow = &gc_try_alloc_slow_fixed_size;
-  } else if (size <= 64) {
-    heap_type = HEAP_64;
-    //try_alloc = &gc_try_alloc;
-    //try_alloc_slow = &gc_try_alloc_slow;
-    // TODO:
-    try_alloc = &gc_try_alloc_fixed_size;
-    try_alloc_slow = &gc_try_alloc_slow_fixed_size;
-// Only use this heap on 64-bit platforms, where larger objs are used more often
-// Code from http://stackoverflow.com/a/32717129/101258
-#if INTPTR_MAX == INT64_MAX
-  } else if (size <= 96) {
-    heap_type = HEAP_96;
-    //try_alloc = &gc_try_alloc;
-    //try_alloc_slow = &gc_try_alloc_slow;
-    // TODO:
-    try_alloc = &gc_try_alloc_fixed_size;
-    try_alloc_slow = &gc_try_alloc_slow_fixed_size;
-#endif
   } else if (size >= MAX_STACK_OBJ) {
     heap_type = HEAP_HUGE;
     try_alloc = &gc_try_alloc;
@@ -1424,14 +1419,8 @@ fprintf(stderr, "slow alloc of %p\n", result);
     if (result) {
       // Check if we need to start a major collection
       if (heap_type != HEAP_HUGE &&
-        (//(try_alloc == &gc_try_alloc_fixed_size && // Fixed-size object heap
-         // h_passed->num_unswept_children < (GC_COLLECT_UNDER_UNSWEPT_HEAP_COUNT * 128)) ||
-         h_passed->num_unswept_children < GC_COLLECT_UNDER_UNSWEPT_HEAP_COUNT)) {
-//           gc_num_unswept_heaps(h_passed) < GC_COLLECT_UNDER_UNSWEPT_HEAP_COUNT)){
-//        printf("major collection heap_type = %d h->num_unswept = %d, computed = %d\n", heap_type,  h_passed->num_unswept_children, gc_num_unswept_heaps(h_passed));
-        //if (h_passed->num_unswept_children != gc_num_unswept_heaps(h_passed)) {
-        //  printf("ERROR, counts do not match!\n");
-        //}
+          (h_passed->num_unswept_children <
+           GC_COLLECT_UNDER_UNSWEPT_HEAP_COUNT)) {
         gc_start_major_collection(thd);
       }
     } else {
@@ -1447,9 +1436,16 @@ fprintf(stderr, "slowest alloc of %p\n", result);
 #endif
       if (result) {
         // We had to allocate memory, start a major collection ASAP!
-        if (heap_type != HEAP_HUGE) {
+        //
+        // Huge heaps are a special case because we always allocate a new page
+        // for them. However, we still initiate a collection for them, giving
+        // us a convenient way to handle short-lived HUGE objects. In practice
+        // this makes a BIG difference in memory usage for the array1 benchmark.
+        // Longer-term there may be a better way to deal with huge objects.
+        //
+        //if (heap_type != HEAP_HUGE) {
         gc_start_major_collection(thd);
-        }
+        //}
       } else {
         fprintf(stderr, "out of memory error allocating %zu bytes\n", size);
         fprintf(stderr, "Heap type %d diagnostics:\n", heap_type);
@@ -1464,8 +1460,9 @@ fprintf(stderr, "slowest alloc of %p\n", result);
 #endif
 
 #if GC_DEBUG_VERBOSE
-  fprintf(stderr, "alloc %p size = %zu, obj=%p, tag=%d, mark=%d, thd->alloc=%d, thd->trace=%d\n", result,
-          size, obj, type_of(obj), mark(((object) result)),
+  fprintf(stderr,
+          "alloc %p size = %zu, obj=%p, tag=%d, mark=%d, thd->alloc=%d, thd->trace=%d\n",
+          result, size, obj, type_of(obj), mark(((object) result)),
           thd->gc_alloc_color, thd->gc_trace_color);
   // Debug check, should no longer be necessary
   //if (is_value_type(result)) {
@@ -1661,13 +1658,11 @@ gc_heap *gc_sweep(gc_heap * h, gc_thread_data *thd)
     //   have the trace/clear color. We need to keep any of those to make sure
     //   the collector has a chance to trace the entire heap.
     if (                        //mark(p) != markColor &&
-          mark(p) != thd->gc_alloc_color && 
-          mark(p) != thd->gc_trace_color) { //gc_color_clear) 
+         mark(p) != thd->gc_alloc_color && mark(p) != thd->gc_trace_color) {    //gc_color_clear) 
 #if GC_DEBUG_VERBOSE
-        fprintf(stderr, "sweep is freeing unmarked obj: %p with tag %d mark %d - alloc color %d trace color %d\n", p,
-                type_of(p),
-                mark(p),
-                thd->gc_alloc_color, thd->gc_trace_color);
+      fprintf(stderr,
+              "sweep is freeing unmarked obj: %p with tag %d mark %d - alloc color %d trace color %d\n",
+              p, type_of(p), mark(p), thd->gc_alloc_color, thd->gc_trace_color);
 #endif
       //mark(p) = gc_color_blue;        // Needed?
       if (type_of(p) == mutex_tag) {
@@ -1861,9 +1856,13 @@ static void mark_stack_or_heap_obj(gc_thread_data * thd, object obj, int locked)
     grayed(obj) = 1;
   } else {
     // Value is on the heap, mark gray right now
-    if (!locked) { pthread_mutex_lock(&(thd->lock)); }
+    if (!locked) {
+      pthread_mutex_lock(&(thd->lock));
+    }
     gc_mark_gray(thd, obj);
-    if (!locked) { pthread_mutex_unlock(&(thd->lock)); }
+    if (!locked) {
+      pthread_mutex_unlock(&(thd->lock));
+    }
   }
 }
 
@@ -1903,6 +1902,38 @@ void gc_mut_update(gc_thread_data * thd, object old_obj, object value)
   }
 }
 
+static void gc_sweep_primordial_thread_heap()
+{
+  int heap_type, must_free;
+  gc_heap *h, *prev, *next, *sweep;
+  pthread_mutex_lock(&(primordial_thread->lock));
+  for (heap_type = 0; heap_type < NUM_HEAP_TYPES; heap_type++) {
+    prev = primordial_thread->heap->heap[heap_type];
+    h = prev->next;
+    while (h != NULL) {
+      next = h->next;
+      must_free = 0;
+      if (h->is_unswept) {
+        if (h->type <= LAST_FIXED_SIZE_HEAP_TYPE) {
+          sweep = gc_sweep_fixed_size(h, primordial_thread);
+        } else {
+          sweep = gc_sweep(h, primordial_thread);
+        }
+        must_free = (sweep == NULL);
+      } else {
+        must_free = gc_is_heap_empty(h);
+      }
+      if (must_free) {
+        gc_heap_free(h, prev);
+      } else {
+        prev = h;
+      }
+      h = next;
+    }
+  }
+  pthread_mutex_unlock(&(primordial_thread->lock));
+}
+
 /**
  * @brief Called by a mutator to cooperate with the collector thread
  * @param thd Mutator's thread data
@@ -1913,11 +1944,23 @@ void gc_mut_update(gc_thread_data * thd, object old_obj, object value)
  */
 void gc_mut_cooperate(gc_thread_data * thd, int buf_len)
 {
-  int i, status_c, status_m;
+  int i, status_c, status_m, stage, merged;
 #if GC_DEBUG_VERBOSE
   int debug_print = 0;
 #endif
 
+  // Since terminated threads' heap pages are merged into
+  // the primordial thread's heap, it may be that a sweep
+  // for the primordeal thread is never triggered even though
+  // the heep keeps growing. Perform a sweep here if necessary.
+  stage = ck_pr_load_int(&gc_stage);
+  merged = ck_pr_load_int(&gc_threads_merged);
+  if ((thd == primordial_thread) && (merged == 1)
+      && ((stage == STAGE_SWEEPING) || (stage == STAGE_RESTING))) {
+    gc_sweep_primordial_thread_heap();
+    ck_pr_cas_int(&gc_threads_merged, 1, 0);
+  }
+
   // Handle any pending marks from write barrier
   gc_sum_pending_writes(thd, 0);
 
@@ -2012,36 +2055,6 @@ fprintf(stdout, "done tracing, cooperator is clearing full bits\n");
     // Clear allocation counts to delay next GC trigger
     thd->heap_num_huge_allocations = 0;
     thd->num_minor_gcs = 0;
-// TODO: can't do this now because we don't know how much of the heap is free, as none if it has
-// been swept and we are sweeping incrementally
-//
-//    for (heap_type = 0; heap_type < 2; heap_type++) {
-//      uint64_t free_size = gc_heap_free_size(thd->heap->heap[heap_type]),
-//               threshold = (thd->cached_heap_total_sizes[heap_type]) * GC_FREE_THRESHOLD;
-//      if (free_size < threshold) {
-//        int i, new_heaps = (int)((threshold - free_size) / HEAP_SIZE);
-//        if (new_heaps < 1) {
-//          new_heaps = 1;
-//        }
-////#if GC_DEBUG_TRACE
-//        fprintf(stderr, "Less than %f%% of the heap %d is free (%llu / %llu), growing it %d times\n",
-//                100.0 * GC_FREE_THRESHOLD, heap_type, free_size, threshold, new_heaps);
-////#endif
-//if (new_heaps > 100){ exit(1);} // Something is wrong!
-//        for(i = 0; i < new_heaps; i++){
-//          gc_grow_heap(thd->heap->heap[heap_type], heap_type, 0, 0, thd);
-//        }
-//    //  while ( gc_heap_free_size(thd->heap->heap[heap_type]) < //thd->cached_heap_free_sizes[heap_type] <
-//    //    if (heap_type == HEAP_SM) {
-//    //      gc_grow_heap(thd->heap->heap[heap_type], heap_type, 0, 0, thd);
-//    //    } else if (heap_type == HEAP_64) {
-//    //      gc_grow_heap(thd->heap->heap[heap_type], heap_type, 0, 0, thd);
-//    //    } else if (heap_type == HEAP_REST) {
-//    //      gc_grow_heap(thd->heap->heap[heap_type], heap_type, 0, 0, thd);
-//    //    }
-//      }
-//    }
-
 
     // DEBUG diagnostics
 #if GC_DEBUG_SHOW_SWEEP_DIAG
@@ -2057,57 +2070,36 @@ fprintf(stdout, "done tracing, cooperator is clearing full bits\n");
 
   thd->num_minor_gcs++;
   if (thd->num_minor_gcs % 10 == 9) {   // Throttle a bit since usually we do not need major GC
-    thd->cached_heap_free_sizes[HEAP_SM]   = gc_heap_free_size(thd->heap->heap[HEAP_SM]) ;
-    thd->cached_heap_free_sizes[HEAP_64]   = gc_heap_free_size(thd->heap->heap[HEAP_64]) ;
-    thd->cached_heap_free_sizes[HEAP_96]   = gc_heap_free_size(thd->heap->heap[HEAP_96]) ;
-    thd->cached_heap_free_sizes[HEAP_REST] = gc_heap_free_size(thd->heap->heap[HEAP_REST]);
+    int heap_type, over_gc_collection_threshold = 0;
 
+    for (heap_type = 0; heap_type < HEAP_HUGE; heap_type++) {
+      thd->cached_heap_free_sizes[heap_type] =
+          gc_heap_free_size(thd->heap->heap[heap_type]);
+      if (thd->cached_heap_free_sizes[heap_type] <
+          thd->cached_heap_total_sizes[heap_type] * GC_COLLECTION_THRESHOLD) {
+        over_gc_collection_threshold = 1;
+      }
 #if GC_DEBUG_VERBOSE
-    fprintf(stderr, "heap %d free %zu total %zu\n", HEAP_SM, thd->cached_heap_free_sizes[HEAP_SM], thd->cached_heap_total_sizes[HEAP_SM]);
-    if (thd->cached_heap_free_sizes[HEAP_SM] > thd->cached_heap_total_sizes[HEAP_SM]) {
-      fprintf(stderr, "gc_mut_cooperate - Invalid cached heap sizes, free=%zu total=%zu\n", 
-        thd->cached_heap_free_sizes[HEAP_SM], thd->cached_heap_total_sizes[HEAP_SM]);
-      exit(1);
-    }
-    fprintf(stderr, "heap %d free %zu total %zu\n", HEAP_64, thd->cached_heap_free_sizes[HEAP_64], thd->cached_heap_total_sizes[HEAP_64]);
-    if (thd->cached_heap_free_sizes[HEAP_64] > thd->cached_heap_total_sizes[HEAP_64]) {
-      fprintf(stderr, "gc_mut_cooperate - Invalid cached heap sizes, free=%zu total=%zu\n", 
-        thd->cached_heap_free_sizes[HEAP_64], thd->cached_heap_total_sizes[HEAP_64]);
-      exit(1);
-    }
-    fprintf(stderr, "heap %d free %zu total %zu\n", HEAP_96, thd->cached_heap_free_sizes[HEAP_96], thd->cached_heap_total_sizes[HEAP_96]);
-    if (thd->cached_heap_free_sizes[HEAP_96] > thd->cached_heap_total_sizes[HEAP_96]) {
-      fprintf(stderr, "gc_mut_cooperate - Invalid cached heap sizes, free=%zu total=%zu\n", 
-        thd->cached_heap_free_sizes[HEAP_96], thd->cached_heap_total_sizes[HEAP_96]);
-      exit(1);
-    }
-    fprintf(stderr, "heap %d free %zu total %zu\n", HEAP_REST, thd->cached_heap_free_sizes[HEAP_REST], thd->cached_heap_total_sizes[HEAP_REST]);
-    if (thd->cached_heap_free_sizes[HEAP_REST] > thd->cached_heap_total_sizes[HEAP_REST]) {
-      fprintf(stderr, "gc_mut_cooperate - Invalid cached heap sizes, free=%zu total=%zu\n", 
-        thd->cached_heap_free_sizes[HEAP_REST], thd->cached_heap_total_sizes[HEAP_REST]);
+      fprintf(stderr, "heap %d free %zu total %zu\n",
+              heap_type,
+              thd->cached_heap_free_sizes[heap_type],
+              thd->cached_heap_total_sizes[heap_type]);
+      if (thd->cached_heap_free_sizes[heap_type] >
+          thd->cached_heap_total_sizes[heap_type]) {
+        fprintf(stderr,
+                "gc_mut_cooperate - Invalid cached heap sizes, free=%zu total=%zu\n",
+                thd->cached_heap_free_sizes[heap_type],
+                thd->cached_heap_total_sizes[heap_type]);
         exit(1);
       }
 #endif
+    }
 
     // Initiate collection cycle if free space is too low.
     // Threshold is intentially low because we have to go through an
     // entire handshake/trace/sweep cycle, ideally without growing heap.
     if (ck_pr_load_int(&gc_stage) == STAGE_RESTING &&
-        (
-         //(gc_heap_free_size(thd->heap->heap[HEAP_SM]) < //thd->cached_heap_free_sizes[HEAP_SM] <
-         (thd->cached_heap_free_sizes[HEAP_SM] <
-          thd->cached_heap_total_sizes[HEAP_SM] * GC_COLLECTION_THRESHOLD) ||
-         //(gc_heap_free_size(thd->heap->heap[HEAP_64]) < //thd->cached_heap_free_sizes[HEAP_64] <
-         (thd->cached_heap_free_sizes[HEAP_64] <
-          thd->cached_heap_total_sizes[HEAP_64] * GC_COLLECTION_THRESHOLD) ||
-  #if INTPTR_MAX == INT64_MAX
-         //(gc_heap_free_size(thd->heap->heap[HEAP_96]) < //thd->cached_heap_free_sizes[HEAP_96] <
-         (thd->cached_heap_free_sizes[HEAP_96] <
-          thd->cached_heap_total_sizes[HEAP_96] * GC_COLLECTION_THRESHOLD) ||
-  #endif
-         //(gc_heap_free_size(thd->heap->heap[HEAP_REST]) < //thd->cached_heap_free_sizes[HEAP_REST] <
-         (thd->cached_heap_free_sizes[HEAP_REST] <
-          thd->cached_heap_total_sizes[HEAP_REST] * GC_COLLECTION_THRESHOLD) ||
+        (over_gc_collection_threshold ||
          // Separate huge heap threshold since these are typically allocated as whole pages
          (thd->heap_num_huge_allocations > 100)
         )) {
@@ -2144,8 +2136,7 @@ void gc_mark_gray(gc_thread_data * thd, object obj)
   // timing issues when incrementing colors and since if we ever reach a
   // purple object during tracing we would want to mark it.
   // TODO: revisit if checking for gc_color_purple is truly necessary here and elsewhere.
-  if (is_object_type(obj) && (mark(obj) == gc_color_clear ||
-                              mark(obj) == gc_color_purple)) {     // TODO: sync??
+  if (is_object_type(obj) && (mark(obj) == gc_color_clear || mark(obj) == gc_color_purple)) {   // TODO: sync??
     // Place marked object in a buffer to avoid repeated scans of the heap.
 // TODO:
 // Note that ideally this should be a lock-free data structure to make the
@@ -2171,7 +2162,8 @@ void gc_mark_gray2(gc_thread_data * thd, object obj)
 {
   if (is_object_type(obj) && (mark(obj) == gc_color_clear ||
                               mark(obj) == gc_color_purple)) {
-    mark_buffer_set(thd->mark_buffer, thd->last_write + thd->pending_writes, obj);
+    mark_buffer_set(thd->mark_buffer, thd->last_write + thd->pending_writes,
+                    obj);
     thd->pending_writes++;
   }
 }
@@ -2194,8 +2186,9 @@ static void gc_collector_mark_gray(object parent, object obj)
     fprintf(stderr, "mark gray parent = %p (%d) obj = %p\n", parent,
             type_of(parent), obj);
   } else if (is_object_type(obj)) {
-    fprintf(stderr, "not marking gray, parent = %p (%d) obj = %p mark(obj) = %d, gc_color_clear = %d\n", parent,
-            type_of(parent), obj, mark(obj), gc_color_clear);
+    fprintf(stderr,
+            "not marking gray, parent = %p (%d) obj = %p mark(obj) = %d, gc_color_clear = %d\n",
+            parent, type_of(parent), obj, mark(obj), gc_color_clear);
   }
 }
 #else
@@ -2256,6 +2249,7 @@ void gc_mark_black(object obj)
         if (obj) {
           gc_collector_mark_gray(obj, o);
         }
+        break;
       }
     default:
       break;
@@ -2274,46 +2268,54 @@ void gc_mark_black(object obj)
 #else
 // See full version above for debugging purposes.
 // Also sync any changes to this macro with the function version
-#define gc_mark_black(obj) \
+#define gc_mark_black(_obj) \
 { \
   int markColor = ck_pr_load_8(&gc_color_mark); \
-  if (is_object_type(obj) && mark(obj) != markColor) { \
-    switch (type_of(obj)) { \
+  if (is_object_type(_obj) && mark(_obj) != markColor) { \
+    switch (type_of(_obj)) { \
     case pair_tag:{ \
-        gc_collector_mark_gray(obj, car(obj)); \
-        gc_collector_mark_gray(obj, cdr(obj)); \
+        gc_collector_mark_gray(_obj, car(_obj)); \
+        gc_collector_mark_gray(_obj, cdr(_obj)); \
         break; \
       } \
     case closure1_tag: \
-      gc_collector_mark_gray(obj, ((closure1) obj)->element); \
+      gc_collector_mark_gray(_obj, ((closure1) _obj)->element); \
       break; \
     case closureN_tag:{ \
-        int i, n = ((closureN) obj)->num_elements; \
+        int i, n = ((closureN) _obj)->num_elements; \
         for (i = 0; i < n; i++) { \
-          gc_collector_mark_gray(obj, ((closureN) obj)->elements[i]); \
+          gc_collector_mark_gray(_obj, ((closureN) _obj)->elements[i]); \
         } \
         break; \
       } \
     case vector_tag:{ \
-        int i, n = ((vector) obj)->num_elements; \
+        int i, n = ((vector) _obj)->num_elements; \
         for (i = 0; i < n; i++) { \
-          gc_collector_mark_gray(obj, ((vector) obj)->elements[i]); \
+          gc_collector_mark_gray(_obj, ((vector) _obj)->elements[i]); \
         } \
         break; \
       } \
     case cvar_tag:{ \
-        cvar_type *c = (cvar_type *) obj; \
+        cvar_type *c = (cvar_type *) _obj; \
         object pvar = *(c->pvar); \
         if (pvar) { \
-          gc_collector_mark_gray(obj, pvar); \
+          gc_collector_mark_gray(_obj, pvar); \
+        } \
+        break; \
+      } \
+    case atomic_tag: { \
+        atomic_type *a = (atomic_type *)_obj; \
+        object o = ck_pr_load_ptr(&(a->obj)); \
+        if (_obj) { \
+          gc_collector_mark_gray(_obj, o); \
         } \
         break; \
       } \
     default: \
       break; \
     } \
-    if (mark(obj) != gc_color_red) { \
-      mark(obj) = markColor; \
+    if (mark(_obj) != gc_color_red) { \
+      mark(_obj) = markColor; \
     } \
   } \
 }
@@ -2349,7 +2351,8 @@ void gc_collector_trace()
 #if GC_DEBUG_VERBOSE
         fprintf(stderr,
                 "gc_mark_black mark buffer %p, last_read = %d last_write = %d\n",
-                mark_buffer_get(m->mark_buffer, m->last_read), m->last_read, last_write);
+                mark_buffer_get(m->mark_buffer, m->last_read), m->last_read,
+                last_write);
 #endif
         gc_mark_black(mark_buffer_get(m->mark_buffer, m->last_read));
         gc_empty_collector_stack();
@@ -2470,7 +2473,8 @@ void gc_wait_handshake()
 //printf("DEBUG - update mutator GC status\n");            
             ck_pr_cas_int(&(m->gc_status), statusm, statusc);
 #if GC_DEBUG_TRACE
-            fprintf(stderr, "DEBUG - collector is cooperating for blocked mutator\n");            
+            fprintf(stderr,
+                    "DEBUG - collector is cooperating for blocked mutator\n");
 #endif
             buf_len =
                 gc_minor(m, m->stack_limit, m->stack_start, m->gc_cont, NULL,
@@ -2617,8 +2621,7 @@ static pthread_t collector_thread;
  */
 void gc_start_collector()
 {
-  if (pthread_create
-      (&collector_thread, NULL, collector_main, NULL)) {
+  if (pthread_create(&collector_thread, NULL, collector_main, NULL)) {
     fprintf(stderr, "Error creating collector thread\n");
     exit(1);
   }
@@ -2655,7 +2658,6 @@ void gc_mark_globals(object globals, object global_table)
   }
 }
 
-
 /////////////////////////////////////////////
 // END tri-color marking section
 /////////////////////////////////////////////
@@ -2692,8 +2694,7 @@ void gc_thread_data_init(gc_thread_data * thd, int mut_num, char *stack_base,
   thd->mutations = NULL;
   thd->mutation_buflen = 128;
   thd->mutation_count = 0;
-  thd->mutations = 
-      vpbuffer_realloc(thd->mutations, &(thd->mutation_buflen));
+  thd->mutations = vpbuffer_realloc(thd->mutations, &(thd->mutation_buflen));
   thd->globals_changed = 1;
   thd->param_objs = NULL;
   thd->exception_handler_stack = NULL;
@@ -2723,13 +2724,10 @@ void gc_thread_data_init(gc_thread_data * thd, int mut_num, char *stack_base,
   thd->cached_heap_total_sizes = calloc(5, sizeof(uintptr_t));
   thd->heap = calloc(1, sizeof(gc_heap_root));
   thd->heap->heap = calloc(1, sizeof(gc_heap *) * NUM_HEAP_TYPES);
-  thd->heap->heap[HEAP_REST] = gc_heap_create(HEAP_REST, INITIAL_HEAP_SIZE, thd);
-  thd->heap->heap[HEAP_SM] = gc_heap_create(HEAP_SM, INITIAL_HEAP_SIZE, thd);
-  thd->heap->heap[HEAP_64] = gc_heap_create(HEAP_64, INITIAL_HEAP_SIZE, thd);
-  if (sizeof(void *) == 8) { // Only use this heap on 64-bit platforms
-    thd->heap->heap[HEAP_96] = gc_heap_create(HEAP_96, INITIAL_HEAP_SIZE, thd);
-  }
   thd->heap->heap[HEAP_HUGE] = gc_heap_create(HEAP_HUGE, 1024, thd);
+  for (int i = 0; i < HEAP_HUGE; i++) {
+    thd->heap->heap[i] = gc_heap_create(i, INITIAL_HEAP_SIZE, thd);
+  }
 }
 
 /**
@@ -2786,10 +2784,28 @@ void gc_thread_data_free(gc_thread_data * thd)
  *
  * This function assumes appropriate locks are already held.
  */
-void gc_heap_merge(gc_heap *hdest, gc_heap *hsrc)
+int gc_heap_merge(gc_heap * hdest, gc_heap * hsrc)
 {
+  int freed = 0;
   gc_heap *last = gc_heap_last(hdest);
+  gc_heap *cur = hsrc, *prev = last, *next;
   last->next = hsrc;
+  // free any empty heaps and convert remaining heaps
+  // to free list so that they can be swept
+  while (cur != NULL) {
+    cur->is_unswept = 1;
+    next = cur->next;
+    if (gc_is_heap_empty(cur)) {
+      freed += cur->size;
+      gc_heap_free(cur, prev);
+    } else {
+      gc_convert_heap_page_to_free_list(cur, primordial_thread);
+      ck_pr_cas_int(&gc_threads_merged, 0, 1);
+      prev = cur;
+    }
+    cur = next;
+  }
+  return freed;
 }
 
 /**
@@ -2802,15 +2818,47 @@ void gc_heap_merge(gc_heap *hdest, gc_heap *hsrc)
 void gc_merge_all_heaps(gc_thread_data * dest, gc_thread_data * src)
 {
   gc_heap *hdest, *hsrc;
-  int heap_type;
+  int freed, heap_type, i;
+  pair_type *context = NULL;
+  vector_type *v = src->scm_thread_obj;
+
+  // The following objects are part of the thread context and should
+  // be stored on the primordial thread's heap. Make this explicit by
+  // including it in the thread object.
+  if (src->gc_num_args > 0) {
+    for (i = src->gc_num_args - 1; i >= 0; --i) {
+      context = gc_alloc_pair(dest, (src->gc_args)[i], context);
+    }
+  }
+  if (src->gc_cont != NULL && is_object_type(src->gc_cont)) {
+    context = gc_alloc_pair(dest, src->gc_cont, context);
+  }
+  if (src->exception_handler_stack != NULL) {
+    context = gc_alloc_pair(dest, src->exception_handler_stack, context);
+  }
+  if (src->param_objs != NULL) {
+    context = gc_alloc_pair(dest, src->param_objs, context);
+  }
+
+  if (context != NULL) {
+    gc_mark_black(context);
+    v->elements[8] = context;
+  }
 
   for (heap_type = 0; heap_type < NUM_HEAP_TYPES; heap_type++) {
     hdest = dest->heap->heap[heap_type];
     hsrc = src->heap->heap[heap_type];
+    if (!hdest) {
+      fprintf(stderr,
+              "WARNING !!!!! merging heap type %d does not happen: hdest = %p hsrc = %p size = %d\n",
+              heap_type, hdest, hsrc, hsrc->size);
+      fflush(stderr);
+    }
     if (hdest && hsrc) {
-      gc_heap_merge(hdest, hsrc);
+      freed = gc_heap_merge(hdest, hsrc);
       ck_pr_add_ptr(&(dest->cached_heap_total_sizes[heap_type]),
-           ck_pr_load_ptr(&(src->cached_heap_total_sizes[heap_type])));
+                    ck_pr_load_ptr(&(src->cached_heap_total_sizes[heap_type])) -
+                    freed);
       ck_pr_add_ptr(&(dest->cached_heap_free_sizes[heap_type]),
                     ck_pr_load_ptr(&(src->cached_heap_free_sizes[heap_type])));
     }
@@ -2877,7 +2925,8 @@ void gc_recopy_obj(object obj, gc_thread_data *thd)
  * it was blocking, the mutator will move any remaining stack objects to 
  * the heap and longjmp.
  */
-void gc_mutator_thread_runnable(gc_thread_data * thd, object result, object maybe_copied)
+void gc_mutator_thread_runnable(gc_thread_data * thd, object result,
+                                object maybe_copied)
 {
   char stack_limit;
   // Transition from blocked back to runnable using CAS.
@@ -2916,7 +2965,7 @@ void gc_mutator_thread_runnable(gc_thread_data * thd, object result, object mayb
     // Collector didn't do anything; make a normal continuation call
     if (type_of(thd->gc_cont) == pair_tag || prim(thd->gc_cont)) {
       thd->gc_args[0] = result;
-      Cyc_apply_from_buf(thd, 1, thd->gc_cont, thd->gc_args);
+      Cyc_apply_from_buf(thd, 2, thd->gc_cont, thd->gc_args);
     } else {
       object buf[1] = { result };
       (((closure) (thd->gc_cont))->fn) (thd, thd->gc_cont, 1, buf);

guix/cyclone.scm

@@ -0,0 +1,87 @@
+;; cyclone.scm
+(use-modules
+ (gnu packages)
+ (gnu packages multiprecision)
+ ((guix licenses)
+  #:select (gpl2 gpl2+ lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3+ asl2.0
+                 bsd-0 bsd-3 cc-by-sa4.0 non-copyleft expat
+                 public-domain))
+ (guix gexp)
+ (guix packages)
+ (guix download)
+ (guix git-download)
+ (guix utils)
+ (guix build-system gnu)
+ (gnu packages c))
+
+(define-public cyclone
+  (package
+    (name "cyclone")
+    (version "0.36.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/justinethier/cyclone-bootstrap")
+                    (commit (string-append "v" version))))
+              (sha256
+               (base32
+                "0fv0mnrn5shbx77383f4mbkvc4i9yyj1bjm3dfyhipnaqapbhqpi"))
+              (file-name (git-file-name name version))))
+    (build-system gnu-build-system)
+    (arguments
+     (list
+      #:test-target "test"
+      #:make-flags #~(list (string-append
+                            "CC=" #$(this-package-input "gcc-toolchain")
+                            "/bin/gcc")
+                           (string-append "PREFIX=" #$output)
+                           (string-append "COMP_INCDIRS=-I$(PREFIX)/include -I"
+                                          #$(this-package-input "gcc-toolchain")
+                                          "/include")
+                           (string-append
+                            "COMP_LIBDIRS=-L$(PREFIX)/lib "
+                            "-Wl,-rpath=" #$(this-package-input "ck") "/lib "
+                            "-L" #$(this-package-input "ck") "/lib "
+                            "-Wl,-rpath=" #$(this-package-input "libtommath")
+                            "/lib "
+                            "-L" #$(this-package-input "libtommath") "/lib "
+                            "-Wl,-rpath="
+                            #$(this-package-input "gcc-toolchain") "/lib "
+                            "-L" #$(this-package-input "gcc-toolchain")
+                            "/lib"))
+      #:phases #~(modify-phases %standard-phases
+                   (delete 'configure) ; no configure script
+                   (add-before 'build 'replace-cyclonebn
+                     (lambda* (#:key outputs #:allow-other-keys)
+                       (substitute* "Makefile"
+                         (("-lcyclonebn")
+                          "-ltommath")
+                         (("^[$][(]CYC_BN_LIB[)] :")
+                          "dont-build-cyclonebn :")
+                         (("^	[$][(]INSTALL[)] .* [$][(]CYC_BN_LIB[)].*$")
+                          "#dont-install-cyclonebn\n")
+                         (("[$][(]CYC_BN_LIB[)]")
+                          ""))
+                       (substitute* "Makefile.config"
+                         (("-lcyclonebn")
+                          "-ltommath"))))
+                   (add-after 'install 'wrap
+                     (lambda _
+                       (wrap-program (string-append #$output "/bin/cyclone")
+                         `("LIBRARY_PATH" ":" prefix
+                           ,(list (string-append
+                                   #$(this-package-input "gcc-toolchain")
+                                   "/lib")))))))))
+    (inputs (list ck libtommath (module-ref (resolve-interface
+                                             '(gnu packages commencement))
+                                            'gcc-toolchain)))
+    (home-page "https://justinethier.github.io/cyclone/")
+    (synopsis "R7RS Scheme to C compiler")
+    (description
+     "Cyclone Scheme is a R7RS Scheme-to-C compiler that uses a variant of
+Cheney on the MTA to implement full tail recursion, continuations, and
+generational garbage collection.  It also includes the Winds package manager
+for installing Cyclone libraries.")
+    (license expat)))
+
+cyclone

hashset.c

@@ -86,7 +86,6 @@ static void maybe_rehash(hashset_t set)
   size_t *old_items;
   size_t old_capacity, ii;
 
-
   if (set->nitems + set->n_deleted_items >= (double)set->capacity * 0.85) {
     old_items = set->items;
     old_capacity = set->capacity;
@@ -154,4 +153,3 @@ void hashset_to_array(hashset_t set, void **items)
     }
   }
 }
-

include/cyclone/bignum.h

@@ -178,10 +178,7 @@ typedef int mp_endian;
 
 #ifndef MP_FIXED_CUTOFFS
   extern int
-KARATSUBA_MUL_CUTOFF,
-KARATSUBA_SQR_CUTOFF,
-TOOM_MUL_CUTOFF,
-TOOM_SQR_CUTOFF;
+   KARATSUBA_MUL_CUTOFF, KARATSUBA_SQR_CUTOFF, TOOM_MUL_CUTOFF, TOOM_SQR_CUTOFF;
 #endif
 
 /* define this to use lower memory usage routines (exptmods mostly) */
@@ -258,7 +255,8 @@ typedef struct  {
 
 /* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
   typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat);
-typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source) ltm_prime_callback;
+  typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source)
+   ltm_prime_callback;
 
 /* error code to char* string */
   const char *mp_error_to_string(mp_err code) MP_WUR;
@@ -352,13 +350,19 @@ void mp_set(mp_int *a, mp_digit b);
   mp_err mp_init_set(mp_int * a, mp_digit b) MP_WUR;
 
 /* get integer, set integer and init with integer (deprecated) */
-MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR;
-MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR;
-MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) unsigned long long mp_get_long_long(const mp_int *a) MP_WUR;
+   MP_DEPRECATED(mp_get_mag_u32 /
+                 mp_get_u32) unsigned long mp_get_int(const mp_int * a) MP_WUR;
+   MP_DEPRECATED(mp_get_mag_ul /
+                 mp_get_ul) unsigned long mp_get_long(const mp_int * a) MP_WUR;
+   MP_DEPRECATED(mp_get_mag_ull /
+                 mp_get_ull) unsigned long long mp_get_long_long(const mp_int *
+                                                                 a) MP_WUR;
    MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int * a, unsigned long b);
    MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int * a, unsigned long b);
-MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, unsigned long long b);
-MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
+   MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int * a,
+                                                     unsigned long long b);
+   MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int * a,
+                                                    unsigned long b) MP_WUR;
 
 /* copy, b = a */
   mp_err mp_copy(const mp_int * a, mp_int * b) MP_WUR;
@@ -369,24 +373,27 @@ mp_err mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
 /* trim unused digits */
   void mp_clamp(mp_int * a);
 
-
 /* export binary data */
-MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order, size_t size,
-                                        int endian, size_t nails, const mp_int *op) MP_WUR;
+   MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order,
+                                           size_t size, int endian,
+                                           size_t nails,
+                                           const mp_int * op) MP_WUR;
 
 /* import binary data */
-MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int *rop, size_t count, int order,
-      size_t size, int endian, size_t nails,
+   MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int * rop, size_t count,
+                                             int order, size_t size, int endian,
+                                             size_t nails,
                                              const void *op) MP_WUR;
 
 /* unpack binary data */
-mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian,
-                 size_t nails, const void *op) MP_WUR;
+  mp_err mp_unpack(mp_int * rop, size_t count, mp_order order, size_t size,
+                   mp_endian endian, size_t nails, const void *op) MP_WUR;
 
 /* pack binary data */
   size_t mp_pack_count(const mp_int * a, size_t nails, size_t size) MP_WUR;
-mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size,
-               mp_endian endian, size_t nails, const mp_int *op) MP_WUR;
+  mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
+                 size_t size, mp_endian endian, size_t nails,
+                 const mp_int * op) MP_WUR;
 
 /* ---> digit manipulation <--- */
 
@@ -435,7 +442,8 @@ void mp_rand_source(mp_err(*source)(void *out, size_t size));
  * implemented ways to gather entropy.
  * It is compatible with `rng_get_bytes()` from libtomcrypt so you could
  * provide that one and then set `ltm_rng = rng_get_bytes;` */
-extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
+  extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen,
+                                  void(*callback)(void));
   extern void (*ltm_rng_callback)(void);
 #endif
 
@@ -448,22 +456,26 @@ extern void (*ltm_rng_callback)(void);
    MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int * a, int b) MP_WUR;
 
 /* c = a XOR b (two complement) */
-MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int * a, const mp_int * b,
+                                          mp_int * c) MP_WUR;
   mp_err mp_xor(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* c = a OR b (two complement) */
-MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int * a, const mp_int * b,
+                                        mp_int * c) MP_WUR;
   mp_err mp_or(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* c = a AND b (two complement) */
-MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int * a, const mp_int * b,
+                                          mp_int * c) MP_WUR;
   mp_err mp_and(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* b = ~a (bitwise not, two complement) */
   mp_err mp_complement(const mp_int * a, mp_int * b) MP_WUR;
 
 /* right shift with sign extension */
-MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int * a, int b,
+                                                    mp_int * c) MP_WUR;
   mp_err mp_signed_rsh(const mp_int * a, int b, mp_int * c) MP_WUR;
 
 /* ---> Basic arithmetic <--- */
@@ -493,7 +505,8 @@ mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
   mp_err mp_sqr(const mp_int * a, mp_int * b) MP_WUR;
 
 /* a/b => cb + d == a */
-mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_div(const mp_int * a, const mp_int * b, mp_int * c,
+                mp_int * d) MP_WUR;
 
 /* c = a mod b, 0 <= c < b  */
   mp_err mp_mod(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
@@ -519,7 +532,8 @@ mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
   mp_err mp_mul_d(const mp_int * a, mp_digit b, mp_int * c) MP_WUR;
 
 /* a/b => cb + d == a */
-mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) MP_WUR;
+  mp_err mp_div_d(const mp_int * a, mp_digit b, mp_int * c,
+                  mp_digit * d) MP_WUR;
 
 /* c = a mod b, 0 <= c < b  */
   mp_err mp_mod_d(const mp_int * a, mp_digit b, mp_digit * c) MP_WUR;
@@ -527,13 +541,16 @@ mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) MP_WUR;
 /* ---> number theory <--- */
 
 /* d = a + b (mod c) */
-mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_addmod(const mp_int * a, const mp_int * b, const mp_int * c,
+                   mp_int * d) MP_WUR;
 
 /* d = a - b (mod c) */
-mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_submod(const mp_int * a, const mp_int * b, const mp_int * c,
+                   mp_int * d) MP_WUR;
 
 /* d = a * b (mod c) */
-mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_mulmod(const mp_int * a, const mp_int * b, const mp_int * c,
+                   mp_int * d) MP_WUR;
 
 /* c = a * a (mod b) */
   mp_err mp_sqrmod(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
@@ -545,7 +562,8 @@ mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
   mp_err mp_gcd(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* produces value such that U1*a + U2*b = U3 */
-mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR;
+  mp_err mp_exteuclid(const mp_int * a, const mp_int * b, mp_int * U1,
+                      mp_int * U2, mp_int * U3) MP_WUR;
 
 /* c = [a, b] or (a*b)/(a, b) */
   mp_err mp_lcm(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
@@ -555,20 +573,25 @@ mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
  * returns error if a < 0 and b is even
  */
   mp_err mp_root_u32(const mp_int * a, uint32_t b, mp_int * c) MP_WUR;
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
+   MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int * a, mp_digit b,
+                                               mp_int * c) MP_WUR;
+   MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int * a, mp_digit b,
+                                                  mp_int * c, int fast) MP_WUR;
 
 /* special sqrt algo */
   mp_err mp_sqrt(const mp_int * arg, mp_int * ret) MP_WUR;
 
 /* special sqrt (mod prime) */
-mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR;
+  mp_err mp_sqrtmod_prime(const mp_int * n, const mp_int * prime,
+                          mp_int * ret) MP_WUR;
 
 /* is number a square? */
   mp_err mp_is_square(const mp_int * arg, mp_bool * ret) MP_WUR;
 
 /* computes the jacobi c = (a | n) (or Legendre if b is prime)  */
-MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) MP_WUR;
+   MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int * a,
+                                                const mp_int * n,
+                                                int *c) MP_WUR;
 
 /* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */
   mp_err mp_kronecker(const mp_int * a, const mp_int * p, int *c) MP_WUR;
@@ -592,7 +615,8 @@ mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) MP_WUR;
   mp_err mp_montgomery_calc_normalization(mp_int * a, const mp_int * b) MP_WUR;
 
 /* computes x/R == x (mod N) via Montgomery Reduction */
-mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR;
+  mp_err mp_montgomery_reduce(mp_int * x, const mp_int * n,
+                              mp_digit rho) MP_WUR;
 
 /* returns 1 if a is a valid DR modulus */
   mp_bool mp_dr_is_modulus(const mp_int * a) MP_WUR;
@@ -622,7 +646,8 @@ mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) MP_WUR;
   mp_err mp_reduce_2k_l(mp_int * a, const mp_int * n, const mp_int * d) MP_WUR;
 
 /* Y = G**X (mod P) */
-mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) MP_WUR;
+  mp_err mp_exptmod(const mp_int * G, const mp_int * X, const mp_int * P,
+                    mp_int * Y) MP_WUR;
 
 /* ---> Primes <--- */
 
@@ -635,20 +660,26 @@ mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y)
 #define PRIME_SIZE (MP_DEPRECATED_PRAGMA("PRIME_SIZE has been made internal") PRIVATE_MP_PRIME_TAB_SIZE)
 
 /* table of first PRIME_SIZE primes */
-MP_DEPRECATED(internal) extern const mp_digit ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE];
+   MP_DEPRECATED(internal) extern const mp_digit
+      ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE];
 
 /* result=1 if a is divisible by one of the first PRIME_SIZE primes */
-MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) MP_WUR;
+   MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *
+                                                                 a,
+                                                                 mp_bool *
+                                                                 result) MP_WUR;
 
 /* performs one Fermat test of "a" using base "b".
  * Sets result to 0 if composite or 1 if probable prime
  */
-mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
+  mp_err mp_prime_fermat(const mp_int * a, const mp_int * b,
+                         mp_bool * result) MP_WUR;
 
 /* performs one Miller-Rabin test of "a" using base "b".
  * Sets result to 0 if composite or 1 if probable prime
  */
-mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
+  mp_err mp_prime_miller_rabin(const mp_int * a, const mp_int * b,
+                               mp_bool * result) MP_WUR;
 
 /* This gives [for a given bit size] the number of trials required
  * such that Miller-Rabin gives a prob of failure lower than 2^-96
@@ -658,12 +689,14 @@ int mp_prime_rabin_miller_trials(int size) MP_WUR;
 /* performs one strong Lucas-Selfridge test of "a".
  * Sets result to 0 if composite or 1 if probable prime
  */
-mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) MP_WUR;
+  mp_err mp_prime_strong_lucas_selfridge(const mp_int * a,
+                                         mp_bool * result) MP_WUR;
 
 /* performs one Frobenius test of "a" as described by Paul Underwood.
  * Sets result to 0 if composite or 1 if probable prime
  */
-mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR;
+  mp_err mp_prime_frobenius_underwood(const mp_int * N,
+                                      mp_bool * result) MP_WUR;
 
 /* performs t random rounds of Miller-Rabin on "a" additional to
  * bases 2 and 3.  Also performs an initial sieve of trial
@@ -712,8 +745,10 @@ mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR;
  * so it can be NULL
  *
  */
-MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags,
-      private_mp_prime_callback cb, void *dat) MP_WUR;
+   MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int * a, int t,
+                                                          int size, int flags,
+                                                          private_mp_prime_callback
+                                                          cb, void *dat) MP_WUR;
   mp_err mp_prime_rand(mp_int * a, int t, int size, int flags) MP_WUR;
 
 /* Integer logarithm to integer base */
@@ -721,35 +756,53 @@ mp_err mp_log_u32(const mp_int *a, uint32_t base, uint32_t *c) MP_WUR;
 
 /* c = a**b */
   mp_err mp_expt_u32(const mp_int * a, uint32_t b, mp_int * c) MP_WUR;
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
+   MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int * a, mp_digit b,
+                                               mp_int * c) MP_WUR;
+   MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int * a, mp_digit b,
+                                                  mp_int * c, int fast) MP_WUR;
 
 /* ---> radix conversion <--- */
   int mp_count_bits(const mp_int * a) MP_WUR;
 
-
-MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR;
-MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR;
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
+   MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *
+                                                        a) MP_WUR;
+   MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int * a, const unsigned char
+                                                           *b, int c) MP_WUR;
+   MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int * a,
+                                                       unsigned char *b) MP_WUR;
+   MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int * a,
+                                                         unsigned char *b,
+                                                         unsigned long *outlen)
+   MP_WUR;
 
    MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int * a) MP_WUR;
-MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int *a,  unsigned char *b) MP_WUR;
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
+   MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int * a,
+                                                         const unsigned char *b,
+                                                         int c) MP_WUR;
+   MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int * a,
+                                                     unsigned char *b) MP_WUR;
+   MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int * a,
+                                                       unsigned char *b,
+                                                       unsigned long *outlen)
+   MP_WUR;
 
   size_t mp_ubin_size(const mp_int * a) MP_WUR;
   mp_err mp_from_ubin(mp_int * a, const unsigned char *buf, size_t size) MP_WUR;
-mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
+  mp_err mp_to_ubin(const mp_int * a, unsigned char *buf, size_t maxlen,
+                    size_t *written) MP_WUR;
 
   size_t mp_sbin_size(const mp_int * a) MP_WUR;
   mp_err mp_from_sbin(mp_int * a, const unsigned char *buf, size_t size) MP_WUR;
-mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
+  mp_err mp_to_sbin(const mp_int * a, unsigned char *buf, size_t maxlen,
+                    size_t *written) MP_WUR;
 
   mp_err mp_read_radix(mp_int * a, const char *str, int radix) MP_WUR;
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int *a, char *str, int radix) MP_WUR;
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) MP_WUR;
-mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR;
+   MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int * a, char *str,
+                                                int radix) MP_WUR;
+   MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int * a, char *str,
+                                                  int radix, int maxlen) MP_WUR;
+  mp_err mp_to_radix(const mp_int * a, char *str, size_t maxlen,
+                     size_t *written, int radix) MP_WUR;
   mp_err mp_radix_size(const mp_int * a, int radix, int *size) MP_WUR;
 
 #ifndef MP_NO_FILE
@@ -777,5 +830,4 @@ mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR;
 #ifdef __cplusplus
 }
 #endif
-
 #endif

include/cyclone/hashset.h

@@ -71,5 +71,4 @@ extern "C" {
 #ifdef __cplusplus
 }
 #endif
-
 #endif

include/cyclone/runtime.h

@@ -9,7 +9,6 @@
 #ifndef CYCLONE_RUNTIME_H
 #define CYCLONE_RUNTIME_H
 
-
 /**
  * The boolean True value.
  * \ingroup objects
@@ -66,12 +65,11 @@ void gc_init_heap(long heap_size);
  *
  */
 /**@{*/
-#define Cyc_check_num_args(data, fnc_name, num_args, args) { \
-  object l = Cyc_length(data, args); \
-  if (num_args > obj_obj2int(l)) { \
+#define Cyc_check_num_args(data, fnc_name, num_expected_args, args, args_len) { \
+  if (num_expected_args > args_len) { \
     char buf[128]; \
-    snprintf(buf, 127, "Expected %d arguments to %s but received %ld", \
-             num_args, fnc_name, obj_obj2int(l));  \
+    snprintf(buf, 127, "Expected %d arguments to %s but received %d", \
+             num_expected_args, fnc_name, args_len);  \
     Cyc_rt_raise_msg(data, buf); \
   } \
 }
@@ -79,7 +77,7 @@ void gc_init_heap(long heap_size);
 #define Cyc_check_argc(data, fnc_name, argc, expected) { \
   if (expected > argc) { \
     char buf[128]; \
-    snprintf(buf, 127, "Expected %d arguments to %s but received %ld", \
+    snprintf(buf, 127, "Expected %d arguments to %s but received %d", \
              expected, fnc_name, argc);  \
     Cyc_rt_raise_msg(data, buf); \
   } \
@@ -232,7 +230,8 @@ object Cyc_global_set(void *thd, object sym, object * glo, object value);
 
 #define global_set_cps(thd,k,glo,value) Cyc_global_set_cps(thd, k, NULL, (object *)&glo, value)
 #define global_set_cps_id(thd,k,id,glo,value) Cyc_global_set_cps(thd, k, id, (object *)&glo, value)
-object Cyc_global_set_cps(void *thd, object cont, object sym, object * glo, object value);
+object Cyc_global_set_cps(void *thd, object cont, object sym, object * glo,
+                          object value);
 
 /**
  * Variable argument count support 
@@ -369,21 +368,63 @@ object Cyc_io_close_output_port(void *data, object port);
 object Cyc_io_flush_output_port(void *data, object port);
 object Cyc_io_read_char(void *data, object cont, object port);
 object Cyc_io_peek_char(void *data, object cont, object port);
+object Cyc_io_char_ready(void *data, object port);
 object Cyc_write_u8(void *data, object c, object port);
 object Cyc_io_read_u8(void *data, object cont, object port);
 object Cyc_io_peek_u8(void *data, object cont, object port);
-object Cyc_write_bytevector(void *data, object bvec, object port, object start, object end);
+object Cyc_write_bytevector(void *data, object bvec, object port, object start,
+                            object end);
 object Cyc_io_read_line(void *data, object cont, object port);
 void Cyc_io_read_token(void *data, object cont, object port);
+int Cyc_have_mstreams();
 /**@}*/
 
-
 /**
  * \defgroup prim_num Numbers
  * @brief Number functions
  */
 /**@{*/
 
+/**
+ * Extract result of OP and pass it in a call to continuation `cont`
+ */
+#define return_double_op(data, cont, OP, z) \
+  int i = 0; \
+  Cyc_check_num(data, z); \
+  if (obj_is_int(z)) { \
+    i = obj_obj2int(z); \
+  } else if (type_of(z) == integer_tag) { \
+    i = (int)OP(((integer_type *)z)->value); \
+  } else if (type_of(z) == bignum_tag) { \
+    return_closcall1(data, cont, z); \
+  } else if (type_of(z) == double_tag) { \
+    make_double(d, OP(((double_type *)z)->value)); \
+    return_closcall1(data, cont, &d); \
+  } else { \
+    Cyc_rt_raise2(data, "Expected number but received", z); \
+  } \
+  return_closcall1(data, cont, obj_int2obj(i));
+
+/**
+ * Directly return result of OP to caller
+ */
+#define return_double_op_no_cps(data, ptr, OP, z) \
+  int i = 0; \
+  Cyc_check_num(data, z); \
+  if (obj_is_int(z)) { \
+    i = obj_obj2int(z); \
+  } else if (type_of(z) == integer_tag) { \
+    i = (int)OP(((integer_type *)z)->value); \
+  } else if (type_of(z) == bignum_tag) { \
+    return z; \
+  } else if (type_of(z) == double_tag) { \
+    assign_double(ptr, OP(((double_type *)z)->value)); \
+    return ptr; \
+  } else { \
+    Cyc_rt_raise2(data, "Expected number but received", z); \
+  } \
+  return obj_int2obj(i);
+
 /**
  * Extract double and return it to caller
  */
@@ -463,39 +504,9 @@ void Cyc_io_read_token(void *data, object cont, object port);
   } \
   return_closcall1(data, cont, &d)
 
-/**
- * Extract exact or double number and pass it in a call to continuation `cont`
- */
-#define return_exact_double_op(data, cont, OP, z) \
-  int i = 0; \
-  Cyc_check_num(data, z); \
-  if (obj_is_int(z)) { \
-    i = obj_obj2int(z); \
-  } else if (type_of(z) == integer_tag) { \
-    i = (int)OP(((integer_type *)z)->value); \
-  } else if (type_of(z) == bignum_tag) { \
-    return_closcall1(data, cont, z); \
-  } else { \
-    i = (int)OP(((double_type *)z)->value); \
-  } \
-  return_closcall1(data, cont, obj_int2obj(i))
-
-/**
- * Directly return exact or double number to caller
- */
-#define return_exact_double_op_no_cps(data, ptr, OP, z) \
-  int i = 0; \
-  Cyc_check_num(data, z); \
-  if (obj_is_int(z)) { \
-    i = obj_obj2int(z); \
-  } else if (type_of(z) == integer_tag) { \
-    i = (int)OP(((integer_type *)z)->value); \
-  } else if (type_of(z) == bignum_tag) { \
-    return z; \
-  } else { \
-    i = (int)OP(((double_type *)z)->value); \
-  } \
-  return obj_int2obj(i);
+double round_to_nearest_even(double);
+void Cyc_exact(void *data, object cont, object z);
+object Cyc_exact_no_cps(void *data, object ptr, object z);
 
 /**
  * Take Scheme object that is a number and return the number as a C type
@@ -526,6 +537,7 @@ object Cyc_num_cmp_va_list(void *data, int argc,
                            va_list ns);
 void Cyc_expt(void *data, object cont, object x, object y);
 void Cyc_remainder(void *data, object cont, object num1, object num2);
+void Cyc_get_ratio(void *data, object cont, object n, int numerator);
 object Cyc_number2string2(void *data, object cont, int argc, object n, ...);
 object Cyc_integer2char(void *data, object n);
 object Cyc_sum_op(void *data, common_type * x, object y);
@@ -547,8 +559,10 @@ object Cyc_fast_list_3(object ptr, object a1, object a2, object a3);
 object Cyc_fast_list_4(object ptr, object a1, object a2, object a3, object a4);
 object Cyc_fast_vector_2(object ptr, object a1, object a2);
 object Cyc_fast_vector_3(object ptr, object a1, object a2, object a3);
-object Cyc_fast_vector_4(object ptr, object a1, object a2, object a3, object a4);
-object Cyc_fast_vector_5(object ptr, object a1, object a2, object a3, object a4, object a5);
+object Cyc_fast_vector_4(object ptr, object a1, object a2, object a3,
+                         object a4);
+object Cyc_fast_vector_5(object ptr, object a1, object a2, object a3, object a4,
+                         object a5);
 object Cyc_bit_unset(void *data, object n1, object n2);
 object Cyc_bit_set(void *data, object n1, object n2);
 object Cyc_num_op_va_list(void *data, int argc,
@@ -558,8 +572,7 @@ object Cyc_num_op_va_list(void *data, int argc,
 object Cyc_num_op_args(void *data, int argc,
                        object(fn_op(void *, common_type *, object)),
                        int default_no_args, int default_one_arg,
-                       object *args,
-                       common_type * buf);
+                       object * args, common_type * buf);
 void Cyc_int2bignum(int n, mp_int * bn);
 object Cyc_bignum_normalize(void *data, object n);
 int Cyc_bignum_cmp(bn_cmp_type type, object x, int tx, object y, int ty);
@@ -573,7 +586,6 @@ double MRG32k3a (double seed);
 //object Cyc_eq(object x, object y);
 object Cyc_eqv(object x, object y);
 #define Cyc_eq(x, y) (make_boolean(x == y))
-int equal(object, object);
 object equalp(object, object);
 object Cyc_has_cycle(object lst);
 object Cyc_is_list(object lst);
@@ -641,7 +653,8 @@ object Cyc_vector_ref(void *d, object v, object k);
 object Cyc_vector_set(void *d, object v, object k, object obj);
 object Cyc_vector_set_unsafe(void *d, object v, object k, object obj);
 object Cyc_vector_set_cps(void *d, object cont, object v, object k, object obj);
-object Cyc_vector_set_unsafe_cps(void *d, object cont, object v, object k, object obj);
+object Cyc_vector_set_unsafe_cps(void *d, object cont, object v, object k,
+                                 object obj);
 object Cyc_make_vector(void *data, object cont, int argc, object len, ...);
 /**@}*/
 
@@ -723,8 +736,10 @@ object copy2heap(void *data, object obj);
 #define Cyc_st_add(data, frame) \
 { \
   gc_thread_data *thd = (gc_thread_data *) data; \
+  intptr_t p1 = (intptr_t)frame; \
+  intptr_t p2 = (intptr_t)thd->stack_prev_frame; \
   /* Do not allow recursion to remove older frames */ \
-  if ((char *)frame != thd->stack_prev_frame) { \
+  if (p1 != p2) { \
     thd->stack_prev_frame = frame; \
     thd->stack_traces[thd->stack_trace_idx] = frame; \
     thd->stack_trace_idx = (thd->stack_trace_idx + 1) % MAX_STACK_TRACES; \
@@ -895,7 +910,8 @@ extern object Cyc_glo_call_cc;
  * @brief Raise and handle Scheme exceptions
  */
 /**@{*/
-object Cyc_default_exception_handler(void *data, object _, int argc, object *args);
+object Cyc_default_exception_handler(void *data, object _, int argc,
+                                     object * args);
 
 object Cyc_current_exception_handler(void *data);
 void Cyc_rt_raise(void *data, object err);
@@ -982,6 +998,7 @@ static inline object Cyc_cdr(void *data, object lis)
   Cyc_check_pair(data, lis);
   return cdr(lis);
 }
+
 // Unsafe car/cdr
 #define Cyc_car_unsafe(d, lis) car(lis)
 #define Cyc_cdr_unsafe(d, lis) cdr(lis)
@@ -997,11 +1014,14 @@ object Cyc_length_unsafe(void *d, object l);
 object Cyc_list2vector(void *data, object cont, object l);
 object Cyc_list2string(void *d, object cont, object lst);
 object memberp(void *data, object x, list l);
+object memvp(void *data, object x, list l);
 object memqp(void *data, object x, list l);
 list assq(void *data, object x, list l);
+list assv(void *data, object x, list l);
 list assoc(void *data, object x, list l);
 list assoc_cdr(void *data, object x, list l);
 /**@}*/
 
+void init_polyfills(void);
 
 #endif                          /* CYCLONE_RUNTIME_H */

include/cyclone/types.h

@@ -46,31 +46,13 @@ typedef void *object;
  *\ingroup objects
  */
 enum object_tag {
-        closure0_tag    = 0
-      , closure1_tag    = 1
-      , closureN_tag    = 2
-      , macro_tag       = 3 // Keep closures here for quick type checking
-      , boolean_tag     = 4
-      , bytevector_tag  = 5
-      , c_opaque_tag    = 6
-      , cond_var_tag    = 7
-      , cvar_tag        = 8
-      , double_tag      = 9
-      , eof_tag         = 10
-      , forward_tag     = 11
-      , integer_tag     = 12
-      , bignum_tag      = 13
-      , mutex_tag       = 14
-      , pair_tag        = 15
-      , port_tag        = 16 
-      , primitive_tag   = 17
-      , string_tag      = 18
-      , symbol_tag      = 19
-      , vector_tag      = 20
-      , complex_num_tag = 21
-      , atomic_tag      = 22
-      , void_tag        = 23
-      , record_tag      = 24
+  closure0_tag = 0, closure1_tag = 1, closureN_tag = 2, macro_tag = 3   // Keep closures here for quick type checking
+  , boolean_tag = 4, bytevector_tag = 5, c_opaque_tag = 6, cond_var_tag =
+      7, cvar_tag = 8, double_tag = 9, eof_tag = 10, forward_tag =
+      11, integer_tag = 12, bignum_tag = 13, mutex_tag = 14, pair_tag =
+      15, port_tag = 16, primitive_tag = 17, string_tag = 18, symbol_tag =
+      19, vector_tag = 20, complex_num_tag = 21, atomic_tag = 22, void_tag =
+      23, record_tag = 24
 };
 
 /**
@@ -176,28 +158,24 @@ typedef unsigned char tag_type;
  heaps (128, 160) are also added.
 
  32 bit x86 is starting to have trouble with just a 96 byte heap added.
-
- In the future, a better solution might be to allocate arrays (closureN's, vectors, bytevectors, and strings)
- as fixed-size chunks to prevent heap fragmentation. The advantage is then we have no fragmentation directly.
- But, an array will no longer be contiguous so they may cause other problems, and the runtime has to change
- to work with non-contiguous arrays. This would also cause a lot of problems for strings since the built-in
- functions would no longer work (EG: strlen, etc).
  */
-typedef enum { 
-    HEAP_SM = 0  // 32 byte objects (min gc_heap_align)
-  , HEAP_64
-  , HEAP_96
-  , HEAP_REST    // Everything else
-  , HEAP_HUGE    // Huge objects, 1 per page
-} gc_heap_type;
+
+// Type starts at 0 and ends at LAST_FIXED_SIZE_HEAP_TYPE
+// Presently each type contains buckets of a multiple of 32 bytes
+// EG: 0 ==> 32
+//     1 ==> 64, etc
+typedef int gc_heap_type;
 
 /** The first heap type that is not fixed-size */
 #if INTPTR_MAX == INT64_MAX
-#define LAST_FIXED_SIZE_HEAP_TYPE HEAP_96
+#define LAST_FIXED_SIZE_HEAP_TYPE 2
 #else
-#define LAST_FIXED_SIZE_HEAP_TYPE HEAP_64
+#define LAST_FIXED_SIZE_HEAP_TYPE 1
 #endif
 
+#define HEAP_REST (LAST_FIXED_SIZE_HEAP_TYPE + 1)
+#define HEAP_HUGE (HEAP_REST + 1)
+
 /** The number of `gc_heap_type`'s */
 #define NUM_HEAP_TYPES (HEAP_HUGE + 1)
 
@@ -225,7 +203,7 @@ struct gc_heap_t {
   /** Size of the heap page in bytes */
   unsigned int size;
   /** Keep empty page alive this many times before freeing */
-  unsigned int ttl; 
+  unsigned char ttl;
   /** Bump: Track remaining space; this is useful for bump&pop style allocation */
   unsigned int remaining;
   /** For fixed-size heaps, only allocate blocks of this size */
@@ -407,14 +385,14 @@ int gc_is_mutator_new(gc_thread_data *thd);
 void gc_sleep_ms(int ms);
 gc_heap *gc_heap_create(int heap_type, size_t size, gc_thread_data * thd);
 gc_heap *gc_heap_free(gc_heap * page, gc_heap * prev_page);
-void gc_heap_merge(gc_heap *hdest, gc_heap *hsrc);
+int gc_heap_merge(gc_heap * hdest, gc_heap * hsrc);
 void gc_merge_all_heaps(gc_thread_data * dest, gc_thread_data * src);
 void gc_print_stats(gc_heap * h);
 gc_heap *gc_grow_heap(gc_heap * h, size_t size, gc_thread_data * thd);
 char *gc_copy_obj(object hp, char *obj, gc_thread_data * thd);
-void *gc_try_alloc(gc_heap * h, size_t size, char *obj,
+void *gc_try_alloc(gc_heap * h, size_t size, char *obj, gc_thread_data * thd);
+void *gc_try_alloc_slow(gc_heap * h_passed, gc_heap * h, size_t size, char *obj,
                         gc_thread_data * thd);
-void *gc_try_alloc_slow(gc_heap *h_passed, gc_heap *h, size_t size, char *obj, gc_thread_data *thd);
 void *gc_alloc(gc_heap_root * h, size_t size, char *obj, gc_thread_data * thd,
                int *heap_grown);
 void *gc_alloc_bignum(gc_thread_data * data);
@@ -422,8 +400,10 @@ size_t gc_allocated_bytes(object obj, gc_free_list * q, gc_free_list * r);
 gc_heap *gc_heap_last(gc_heap * h);
 
 void gc_heap_create_rest(gc_heap * h, gc_thread_data * thd);
-void *gc_try_alloc_rest(gc_heap * h, size_t size, char *obj, gc_thread_data * thd);
-void *gc_alloc_rest(gc_heap_root * hrt, size_t size, char *obj, gc_thread_data * thd, int *heap_grown);
+void *gc_try_alloc_rest(gc_heap * h, size_t size, char *obj,
+                        gc_thread_data * thd);
+void *gc_alloc_rest(gc_heap_root * hrt, size_t size, char *obj,
+                    gc_thread_data * thd, int *heap_grown);
 void gc_init_fixed_size_free_list(gc_heap * h);
 
 //size_t gc_heap_total_size(gc_heap * h);
@@ -460,7 +440,8 @@ void gc_post_handshake(gc_status_type s);
 void gc_wait_handshake();
 void gc_start_collector();
 void gc_mutator_thread_blocked(gc_thread_data * thd, object cont);
-void gc_mutator_thread_runnable(gc_thread_data * thd, object result, object maybe_copied);
+void gc_mutator_thread_runnable(gc_thread_data * thd, object result,
+                                object maybe_copied);
 void Cyc_make_shared_object(void *data, object k, object obj);
 #define set_thread_blocked(d, c) \
   gc_mutator_thread_blocked(((gc_thread_data *)d), (c))
@@ -527,7 +508,6 @@ void Cyc_make_shared_object(void *data, object k, object obj);
  */
 #define forward(obj) (((pair_type *) obj)->pair_car)
 
-
 /**
  * \defgroup gc_minor_mut Mutation table
  * @brief Mutation table to support the minor GC write barrier
@@ -542,7 +522,8 @@ void clear_mutations(void *data);
  * @brief Minor GC write barrier to ensure there are no references to stack objects from the heap.
  */
 /**@{*/
-object transport_stack_value(gc_thread_data *data, object var, object value, int *run_gc);
+object transport_stack_value(gc_thread_data * data, object var, object value,
+                             int *run_gc);
 /**@}*/
 
 /**@}*/
@@ -554,7 +535,8 @@ object transport_stack_value(gc_thread_data *data, object var, object value, int
  * \defgroup ffi Foreign Function Interface
  */
 /**@{*/
-object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *args);
+object Cyc_scm_call(gc_thread_data * parent_thd, object fnc, int argc,
+                    object * args);
 object Cyc_scm_call_no_gc(gc_thread_data * parent_thd, object fnc, object arg);
 /**@}*/
 
@@ -665,9 +647,6 @@ typedef uint32_t char_type;
 /** Function type */
 typedef void (*function_type)(void *data, object clo, int argc, object * args);
 
-/** Primitive function */
-typedef void (*primitive_function_type)(void *data, object cont, object args);
-
 /** Non-CPS function type */
 typedef object(*inline_function_type) ();
 
@@ -920,11 +899,8 @@ typedef struct {
  * and provides constants for each of the comparison operators.
  */
 typedef enum {
-    CYC_BN_LTE = -2
-  , CYC_BN_LT = MP_LT
-  , CYC_BN_EQ = MP_EQ
-  , CYC_BN_GT = MP_GT
-  , CYC_BN_GTE = 2
+  CYC_BN_LTE = -2, CYC_BN_LT = MP_LT, CYC_BN_EQ = MP_EQ, CYC_BN_GT =
+      MP_GT, CYC_BN_GTE = 2
 } bn_cmp_type;
 
 /** 
@@ -1175,10 +1151,22 @@ typedef struct {
 } vector_type;
 typedef vector_type *vector;
 
-typedef struct { vector_type v; object arr[2]; } vector_2_type;
-typedef struct { vector_type v; object arr[3]; } vector_3_type;
-typedef struct { vector_type v; object arr[4]; } vector_4_type;
-typedef struct { vector_type v; object arr[5]; } vector_5_type;
+typedef struct {
+  vector_type v;
+  object arr[2];
+} vector_2_type;
+typedef struct {
+  vector_type v;
+  object arr[3];
+} vector_3_type;
+typedef struct {
+  vector_type v;
+  object arr[4];
+} vector_4_type;
+typedef struct {
+  vector_type v;
+  object arr[5];
+} vector_5_type;
 
 /** Create a new vector in the nursery */
 #define make_empty_vector(v) \
@@ -1273,6 +1261,9 @@ typedef pair_type *pair;
   n->pair_car = a; \
   n->pair_cdr = d;
 
+/** Create a new pair in the thread's heap */
+void *gc_alloc_pair(gc_thread_data * data, object head, object tail);
+
 /**
  * Set members of the given pair 
  * @param n - Pointer to a pair object
@@ -1303,9 +1294,21 @@ typedef pair_type *pair;
   (n))
 
 //typedef list_1_type pair_type;
-typedef struct { pair_type a; pair_type b; } list_2_type;
-typedef struct { pair_type a; pair_type b; pair_type c;} list_3_type;
-typedef struct { pair_type a; pair_type b; pair_type c; pair_type d;} list_4_type;
+typedef struct {
+  pair_type a;
+  pair_type b;
+} list_2_type;
+typedef struct {
+  pair_type a;
+  pair_type b;
+  pair_type c;
+} list_3_type;
+typedef struct {
+  pair_type a;
+  pair_type b;
+  pair_type c;
+  pair_type d;
+} list_4_type;
 
 /**
  * Create a pair with a single value. 
@@ -1473,8 +1476,8 @@ typedef closure0_type *macro;
 typedef struct {
   gc_header_type hdr;
   tag_type tag;
+  function_type fn;
   const char *desc;
-  primitive_function_type fn;
 } primitive_type;
 typedef primitive_type *primitive;
 
@@ -1555,5 +1558,6 @@ void *gc_alloc_from_bignum(gc_thread_data *data, bignum_type *src);
 int gc_minor(void *data, object low_limit, object high_limit, closure cont,
              object * args, int num_args);
 
-void Cyc_import_shared_object(void *data, object cont, object filename, object entry_pt_fnc);
+void Cyc_import_shared_object(void *data, object cont, object filename,
+                              object entry_pt_fnc);
 #endif                          /* CYCLONE_TYPES_H */

libs/cyclone/foreign.sld

@@ -14,6 +14,7 @@
   (export
    opaque?
    opaque-null?
+   make-opaque
    
    c-code
    c-value
@@ -31,6 +32,11 @@
       "Cyc_check_opaque(data, p);
        return_closcall1(data, k, make_boolean(opaque_ptr(p) == NULL));")
 
+    (define-c make-opaque
+      "(void *data, int argc, closure _, object k)"
+      "make_c_opaque(opq, NULL);
+       return_closcall1(data, k, &opq);")
+
     ;; (c-define-type name type (pack (unpack)))
     (define-syntax c-define-type
       (er-macro-transformer
@@ -83,7 +89,6 @@
     ;;  - type - Data type of the Scheme object
     ;; Returns:
     ;;  - C code used to unbox the data
-                                        ;(define (scm->c code type)
     (define-syntax scm->c
       (er-macro-transformer
        (lambda (expr rename compare)

mstreams.c

@@ -32,6 +32,15 @@ if (obj_is_not_closure(clo)) { \
  } \
 }
 
+int Cyc_have_mstreams()
+{
+#if CYC_HAVE_FMEMOPEN && CYC_HAVE_OPEN_MEMSTREAM
+  return 1;
+#else
+  return 0;
+#endif
+}
+
 object Cyc_heap_alloc_port(void *data, port_type * p);
 port_type *Cyc_io_open_input_string(void *data, object str)
 {
@@ -49,7 +58,8 @@ port_type *Cyc_io_open_input_string(void *data, object str)
   p->fp = fmemopen(p->str_bv_in_mem_buf, string_len(str), "r");
 #endif
   if (p->fp == NULL) {
-    Cyc_rt_raise2(data, "Unable to open input memory stream", obj_int2obj(errno));
+    Cyc_rt_raise2(data, "Unable to open input memory stream",
+                  obj_int2obj(errno));
   }
   return p;
 }
@@ -70,7 +80,8 @@ port_type *Cyc_io_open_input_bytevector(void *data, object bv)
   p->fp = fmemopen(p->str_bv_in_mem_buf, ((bytevector) bv)->len, "r");
 #endif
   if (p->fp == NULL) {
-    Cyc_rt_raise2(data, "Unable to open input memory stream", obj_int2obj(errno));
+    Cyc_rt_raise2(data, "Unable to open input memory stream",
+                  obj_int2obj(errno));
   }
   return p;
 }
@@ -86,7 +97,8 @@ port_type *Cyc_io_open_output_string(void *data)
   p->fp = open_memstream(&(p->str_bv_in_mem_buf), &(p->str_bv_in_mem_buf_len));
 #endif
   if (p->fp == NULL) {
-    Cyc_rt_raise2(data, "Unable to open output memory stream", obj_int2obj(errno));
+    Cyc_rt_raise2(data, "Unable to open output memory stream",
+                  obj_int2obj(errno));
   }
   return p;
 }
@@ -121,8 +133,8 @@ void Cyc_io_get_output_bytevector(void *data, object cont, object port)
   {
     object bv;
     alloc_bytevector(data, bv, p->str_bv_in_mem_buf_len);
-    memcpy(((bytevector)bv)->data, p->str_bv_in_mem_buf, p->str_bv_in_mem_buf_len);
+    memcpy(((bytevector) bv)->data, p->str_bv_in_mem_buf,
+           p->str_bv_in_mem_buf_len);
     return_closcall1(data, cont, bv);
   }
 }
-

scheme/base.sld

@@ -145,6 +145,7 @@
     write-string-1
     write-string-2
     flush-output-port
+    char-ready?
     peek-char
     read-char
     read-line
@@ -204,23 +205,16 @@
     write-u8
     binary-port?
     textual-port?
-
+    rationalize
 ;;;;
 ; Possibly missing functions:
-;
 ;    u8-ready?
-;
-;    ; No complex or rational numbers at this time
-;    rationalize
-;
 ;    ;; syntax-rules
 ;;;;
   )
   (inline
     square
     quotient
-    numerator
-    denominator
     truncate
     negative?
     positive?
@@ -236,6 +230,9 @@
   (begin
     ;; Features implemented by this Scheme
     (define (features) 
+      (let ((feats *other-features*))
+        (if (> (string-length (Cyc-compilation-environment 'memory-streams)) 0)
+          (set! feats (cons 'memory-streams feats)))
         (cons 
           'cyclone
           (cons
@@ -243,7 +240,7 @@
               (string-append "version-" *version-number*))
             (cons
               (string->symbol (Cyc-compilation-environment 'platform))
-            *other-features*))))
+              feats)))))
 
     (define *other-features* 
             '(r7rs 
@@ -410,7 +407,7 @@
                   (else (error "cond-expand: bad feature" x)))
                 (memq x (features))))
           (let expand ((ls (cdr expr)))
-            (cond ((null? ls))  ; (error "cond-expand: no expansions" expr)
+            (cond ((null? ls)  (error "cond-expand: no expansions" expr))
                   ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
                   ((eq? 'else (caar ls)) ;(identifier->symbol (caar ls)))
                    (if (pair? (cdr ls))
@@ -676,6 +673,14 @@
       (if (null? port)
         (_write-u8 chr (current-output-port))
         (_write-u8 chr (car port))))
+    (define-c Cyc-char-ready?
+      "(void *data, int argc, closure _, object k, object port)"
+      " object rv = Cyc_io_char_ready(data, port);
+        return_closcall1(data, k, rv); ")
+    (define (char-ready? . port)
+      (if (null? port)
+        (Cyc-char-ready? (current-input-port))
+        (Cyc-char-ready? (car port))))
     (define (peek-char . port)
       (if (null? port)
         (Cyc-peek-char (current-input-port))
@@ -684,10 +689,27 @@
       (if (null? port)
         (Cyc-read-char (current-input-port))
         (Cyc-read-char (car port))))
-    (define (read-line . port)
-      (if (null? port)
-        (Cyc-read-line (current-input-port))
-        (Cyc-read-line (car port))))
+    (define (read-line . o)
+      (let* ((port (if (null? o)
+                       (current-input-port)
+                       (car o)))
+             (str (Cyc-read-line port)))
+        (cond
+          ((eof-object? str) str)
+          ((< (string-length str) 1022) str)
+          (else (_read-line str port)))))
+    ;; Helper function to handle case where a line is too
+    ;; long to be read by a single runtime I/O call
+    (define (_read-line str port)
+      (let loop ((lis (list str))
+                 (str (Cyc-read-line port)))
+        (cond
+          ((eof-object? str)
+           (apply string-append (reverse lis)))
+          ((< (string-length str) 1022)
+           (apply string-append (reverse (cons str lis))))
+          (else
+            (loop (cons str lis) (Cyc-read-line port))))))
     (define (read-string k . opts)
       (let ((port (if (null? opts)
                       (current-input-port)
@@ -831,9 +853,9 @@
                    (car fill)))
                (make
                  (lambda (n obj)
-                   (if (zero? n)
-                   '()
-                   (cons obj (make (- n 1) obj) )))))
+                   (if (> n 0)
+                   (cons obj (make (- n 1) obj) )
+                   '() ))))
       (make k x)))
     (define (list-copy ls)
       (let lp ((ls ls) (res '()))
@@ -1229,13 +1251,16 @@
     (define error-object-message car)
     (define error-object-irritants cdr)
     (define (error msg . args)
-      (raise (cons msg args)))
+      (raise-error (cons msg args)))
     (define (raise obj)
       ((Cyc-current-exception-handler) 
-        (cons 'raised (if (pair? obj) obj (list obj)))))
+        (cons 'raised obj)))
     (define (raise-continuable obj)
       ((Cyc-current-exception-handler) 
-        (cons 'continuable (if (pair? obj) obj (list obj)))))
+        (cons 'continuable obj)))
+    (define (raise-error obj)
+      ((Cyc-current-exception-handler) 
+        (cons 'error obj)))
     ;; A simpler exception handler based on the one from Bigloo:
     ;; https://www-sop.inria.fr/indes/fp/Bigloo/doc/bigloo-17.html#g20889
     ;(define (with-handler handler body)
@@ -1335,25 +1360,29 @@
 
   (define-c floor
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, floor, z); "
+    " return_double_op(data, k, floor, z); "
     "(void *data, object ptr, object z)"
-    " return_exact_double_op_no_cps(data, ptr, floor, z);")
+    " return_double_op_no_cps(data, ptr, floor, z);")
   (define-c ceiling
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, ceil, z); "
+    " return_double_op(data, k, ceil, z); "
     "(void *data, object ptr, object z)"
-    " return_exact_double_op_no_cps(data, ptr, ceil, z);")
+    " return_double_op_no_cps(data, ptr, ceil, z);")
   (define-c truncate
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, (int), z); "
+    " return_double_op(data, k, trunc, z); "
     "(void *data, object ptr, object z)"
-    " return_exact_double_op_no_cps(data, ptr, (int), z);")
+    " return_double_op_no_cps(data, ptr, trunc, z);")
   (define-c round
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, round, z); "
+    " return_double_op(data, k, round_to_nearest_even, z); "
     "(void *data, object ptr, object z)"
-    " return_exact_double_op_no_cps(data, ptr, round, z);")
-  (define exact truncate)
+    " return_double_op_no_cps(data, ptr, round_to_nearest_even, z);")
+  (define-c exact
+    "(void *data, int argc, closure _, object k, object z)"
+    " Cyc_exact(data, k, z); "
+    "(void *data, object ptr, object z)"
+    " return Cyc_exact_no_cps(data, ptr, z);")
   (define-c inexact
     "(void *data, int argc, closure _, object k, object z)"
     " return_inexact_double_or_cplx_op(data, k, (double), (double complex), z); "
@@ -1368,6 +1397,9 @@
         alloc_bignum(data, bn);
         BIGNUM_CALL(mp_abs(&bignum_value(num), &bignum_value(bn)));
         return_closcall1(data, k, bn);
+      } else if (is_object_type(num) && type_of(num) == complex_num_tag){
+        make_double(d, cabs(((complex_num_type *)num)->value));
+        return_closcall1(data, k, &d);
       } else {
         make_double(d, fabs(((double_type *)num)->value));
         return_closcall1(data, k, &d);
@@ -1382,8 +1414,14 @@
       (if (< b 0)
         (if (<= res 0) res (+ res b))
         (if (>= res 0) res (+ res b)))))
-  (define (odd? num)   (= (modulo num 2) 1))
-  (define (even? num)  (= (modulo num 2) 0))
+  (define (odd? num)
+    (if (integer? num)
+        (= (modulo num 2) 1)
+        (error "Not an integer" num)))
+  (define (even? num) 
+    (if (integer? num)
+        (= (modulo num 2) 0)
+        (error "Not an integer" num)))
   (define-c bignum?
     "(void *data, int argc, closure _, object k, object obj)"
     " return_closcall1(data, k, Cyc_is_bignum(obj)); ")
@@ -1402,10 +1440,10 @@
       (error "exact non-negative integer required" k))
     (let* ((s (if (bignum? k)
                   (bignum-sqrt k)
-                  (exact (truncate (sqrt k)))))
+                  (exact (truncate (_sqrt k)))))
            (r (- k (* s s))))
       (values s r)))
-  (define-c sqrt
+  (define-c _sqrt
     "(void *data, int argc, closure _, object k, object z)"
     " return_inexact_double_op(data, k, sqrt, z);"
     "(void *data, object ptr, object z)"
@@ -1443,6 +1481,9 @@
     "(void *data, object ptr, object z)"
     " return Cyc_is_complex(z); ")
   (define rational? number?)
+  ;; Stub, doesn't do much now because rationals are not supported
+  (define (rationalize x y)
+    (/ x y))
   (define (max first . rest) (foldl (lambda (old new) (if (> old new) old new)) first rest))
   (define (min first . rest) (foldl (lambda (old new) (if (< old new) old new)) first rest))
   ; Implementations of gcd and lcm using Euclid's algorithm
@@ -1477,11 +1518,25 @@
   ;; END gcd lcm
 
   ;; Placeholders
-  (define (denominator n) 1)
-  (define (numerator n) n)
+  (define-c numerator
+    "(void *data, int argc, closure _, object k, object n)"
+    " Cyc_get_ratio(data, k, n, 1);")
+
+  (define-c denominator
+    "(void *data, int argc, closure _, object k, object n)"
+    " Cyc_get_ratio(data, k, n, 0);")
+
+  (define-c fixnum?
+    "(void *data, int argc, closure _, object k, object obj)"
+    " return_closcall1(data, k, 
+        obj_is_int(obj) ? boolean_t : boolean_f); "
+    "(void *data, object ptr, object obj)"
+    " return obj_is_int(obj) ? boolean_t : boolean_f; ")
 
   (define (quotient x y)
-    (truncate (/ x y)))
+    (if (and (fixnum? x) (fixnum? y))
+        (exact (truncate (/ x y)))
+        (truncate (/ x y))))
 
   (define truncate-quotient quotient)
   (define truncate-remainder remainder)
@@ -2106,7 +2161,10 @@
                (make-record-marker)
                (quote ,name)
                (,(rename 'vector)
-                ,@make-fields))))
+                ,@make-fields ;; Pass field values sent to constructor
+                ,@(make-list ;; And include empty slots for any other fields
+                    (- (length (cddddr expr))
+                       (length make-fields))) ))))
   )))))
 
 (define-syntax define-values

scheme/cyclone/cgen.sld

@@ -69,6 +69,8 @@
   (letrec ((next (lambda (head tail)
                    (cond
                      ((null? head) (list->string (reverse tail)))
+                     ((equal? (car head) #\?) ;; Escape ? to avoid trigraphs
+                      (next (cdr head) (cons #\? (cons #\\ tail))))
                      ((equal? (car head) #\")
                       (next (cdr head) (cons #\" (cons #\\ tail))))
                      ((equal? (car head) #\\)
@@ -93,6 +95,7 @@
 {gc_thread_data *thd;
  long stack_size = global_stack_size = STACK_SIZE;
  long heap_size = global_heap_size = HEAP_SIZE;
+ init_polyfills();
  mclosure0(clos_halt,&Cyc_halt);  // Halt if final closure is reached
  mclosure0(entry_pt,&c_entry_pt); // First function to execute
  _cyc_argc = argc;
@@ -998,10 +1001,12 @@
            ;;(trace:info `(loop ,args ,(cadr args) ,cgen-lis ,parent-args))
            (c:code
              (string-append
-              cgen-allocs ; (c:allocs->str (c:allocs cgen))
+              cgen-allocs
                "\n"
-               cgen-body ; TODO: (c:body cgen) ; TODO: re-assign function args, longer-term using temp variables
+               cgen-body
                "\n"
+               ;; Avoid unused var warning from C compiler
+               (mangle (cadr args)) " = " (mangle (cadr args)) ";"
                "continue;"))))
          
         ((eq? 'Cyc-foreign-code fun)
@@ -1096,7 +1101,10 @@
                 (this-cont (c:body cfun))
                 (cargs (c-compile-args (cdr args) append-preamble "  " this-cont ast-id trace cps?))
                 (raw-cargs (cdddr cargs)) ; Same as above but with lists instead of appended strings
-                (num-cargs (c:num-args cargs)))
+                (num-cargs (c:num-args cargs))
+                (is-cont (and (equal? (length fun) 4)
+                              (cadddr fun))))
+;(trace:error `(JAE DEBUG ,is-cont ,fun))
            (cond
              ((not cps?)
               (c:code 
@@ -1213,6 +1221,18 @@
                           (if (> num-cargs 0) "," "")
                           (c:body cargs)
                           ");"))))
+                  (is-cont ;; Compiled continuation, can make a more efficient call
+                   (c:code 
+                     (string-append
+                       (c:allocs->str (c:allocs cfun) "\n")
+                       (c:allocs->str (c:allocs cargs) "\n")
+                       "return_direct_with_clo" (number->string (c:num-args cargs))
+                       "(data,"
+                       this-cont
+                       ", (((closure)" this-cont ")->fn)"
+                       (if (> (c:num-args cargs) 0) "," "")
+                       (c:body cargs)
+                       ");")))
                   (else
                     (c:code 
                       (string-append
@@ -1299,10 +1319,15 @@
          (let ((exps (foldr
                        (lambda (expr acc)
                          ;; Join expressions; based on c:append
-                         (let ((cp1 (if (ref? expr)
+                         (let ((cp1 (cond
+                                     ((ref? expr)
                                       ;; Ignore lone ref to avoid C warning
-                                        (c:code/vars "" '())
-                                        (c-compile-exp expr append-preamble cont ast-id trace cps?)))
+                                      (c:code/vars "" '()))
+                                     ((tagged-list? '%closure expr)
+                                      ;; Discard unused func and avoid C warning
+                                      (c:code/vars "" '()))
+                                     (else
+                                        (c-compile-exp expr append-preamble cont ast-id trace cps?))))
                                (cp2 acc))
                            (c:code/vars 
                              (let ((cp1-body (c:body cp1)))

scheme/cyclone/common.sld

@@ -18,7 +18,7 @@
     memloc
   )
   (begin
-(define *version-number* "0.28.0")
+(define *version-number* "0.37.0")
 (define *version-name* "")
 (define *version* (string-append *version-number* " " *version-name* ""))
 
@@ -32,7 +32,7 @@
        @@     @@     Cyclone Scheme->C compiler
       ,@             http://justinethier.github.io/cyclone/
       '@        
-      .@             (c) 2014-2021 Justin Ethier
+      .@             (c) 2014-2025 Justin Ethier
        @@     #@     Version " *version* "
        `@@@#@@@.
         #@@@@@   
@@ -49,7 +49,7 @@
  ** This file was automatically generated by the Cyclone scheme compiler
  ** http://justinethier.github.io/cyclone/
  **
- ** (c) 2014-2021 Justin Ethier
+ ** (c) 2014-2024 Justin Ethier
  ** Version " *version* "
  **
  **/

scheme/cyclone/cps-opt-analyze-call-graph.scm

@@ -20,7 +20,8 @@
             (srfi 2)
             (srfi 69)
             )
-    ))
+    )
+  (else #f))
 
 ;; symbol -> hash-table -> boolean
 ;; Is it OK to inline code replacing ref, based on call graph data from lookup table?
@@ -261,4 +262,5 @@
     ;  (ast:ast->pp-sexp
     ;    (opt:local-var-reduction (ast:sexp->ast sexp)))
     ;)
-))
+)
+(else #f))

scheme/cyclone/cps-opt-local-var-redux.scm

@@ -14,7 +14,9 @@
             (scheme cyclone ast) 
             (scheme cyclone primitives)
             (scheme cyclone util) 
-            (scheme cyclone pretty-print))))
+            (scheme cyclone pretty-print)))
+  (else
+    #f))
 
 ;; Local variable reduction:
 ;; Reduce given sexp by replacing certain lambda calls with a let containing
@@ -434,4 +436,5 @@
       (ast:ast->pp-sexp
         (opt:local-var-reduction (ast:sexp->ast sexp)))
     )
-    ))
+    )
+  (else #f))

scheme/cyclone/cps-opt-memoize-pure-fncs.scm

@@ -18,9 +18,9 @@
             (scheme cyclone util) 
             (scheme cyclone pretty-print)
             (srfi 2)
-            (srfi 69)
-            )
-    ))
+            (srfi 69)))
+  (else
+    #f))
 
 ;; Predicate to determine if a function can be memoized
 ;; var - symbol - global name of the function
@@ -371,4 +371,5 @@
 ;;    ;  (ast:ast->pp-sexp
 ;;    ;    (opt:local-var-reduction (ast:sexp->ast sexp)))
 ;;    ;)
-))
+)
+(else #f))

scheme/cyclone/cps-optimizations.sld

@@ -345,6 +345,12 @@
       (let ((var (adb:get/default sym (adb:make-var))))
         (fnc var)))
 
+    ;; If var found in adb pass to callback and return result, else return #f
+    (define (if-var sym callback)
+      (let* ((var (adb:get/default sym #f))
+             (result (if var (callback var) #f)))
+        result))
+
     (define (with-fnc id callback)
       (let ((fnc (adb:get/default id (adb:make-fnc))))
         (callback fnc)))
@@ -1051,7 +1057,8 @@
                     (lambda (arg)
                       (and (prim-call? arg)
                            ;; Do not inline functions that are looping over lists, seems counter-productive
-                           (not (member (car arg) '( member assoc Cyc-fast-member Cyc-fast-assoc assq assv memq memv)))
+                           ;; Or functions that may be harmful to call more than once such as system
+                           (not (member (car arg) '( member assoc Cyc-fast-member Cyc-fast-assoc assq assv memq memv system)))
                            (not (prim:cont? (car arg)))))
                     (cdr exp))
                   ;; Disallow primitives that allocate a new obj,
@@ -1658,7 +1665,7 @@
 
     ;; Full beta expansion phase, make a pass over all of the program's AST
     (define (opt:beta-expand exp)
-;(write `(DEBUG opt:beta-expand ,exp)) (newline)
+      ;(trace:info `(opt:beta-expand ,exp)) (flush-output-port)
       (cond
        ((ast:lambda? exp)
         (ast:%make-lambda
@@ -1687,6 +1694,7 @@
        (else exp)))
 
     (define (analyze-cps exp)
+      ;(trace:info `(analyze-cps ,exp))
       (analyze:find-named-lets exp)
       (analyze:find-direct-recursive-calls exp)
       (analyze:find-recursive-calls exp)
@@ -1961,7 +1969,14 @@
          ((lambda? fn)   (error `(Unexpected lambda in closure-convert ,exp)))
          (else
            (let ((f (cc fn)))
-            `((%closure-ref ,f 0)
+            `((%closure-ref ,f 0
+                            ;; Indicate if closure refers to a compiled continuation
+                            ,@(if (and (symbol? fn)
+                                       (or
+                                         (if-var fn adbv:cont?)
+                                         (if-var fn adbv:global?)))
+                                 (list #t)
+                                 (list)))
               ,f
               ,@args))))))
     (else                
@@ -2216,11 +2231,17 @@
       (scan (if->then exp) def-sym)
       (scan (if->else exp) def-sym))
      ((app? exp)
-      (when (equal? (car exp) def-sym)
+      ;(trace:info `(analyze:find-recursive-calls scan app ,exp))
+      (cond
+        ((equal? (car exp) def-sym)
          (trace:info `("recursive call" ,exp))
          (with-var! def-sym (lambda (var)
-          (adbv:set-self-rec-call! var #t)))
-        ))
+           (adbv:set-self-rec-call! var #t))))
+        (else
+          (for-each
+            (lambda (e)
+              (scan e def-sym))
+            exp))))
      (else #f)))
 
   ;; TODO: probably not good enough, what about recursive functions that are not top-level??

scheme/cyclone/libraries.sld

@@ -286,10 +286,13 @@
 ;obviously also need to expand cond-expand in cases where the code reads sld files to track down library dependencies
 
 ;; Take given define-library expression and cond-expand all declarations
-(define (lib:cond-expand expr expander)
+(define (lib:cond-expand filepath expr expander)
+  ;; parametrize include, and include-ci during expand, inside
+  ;; expander.
+  (parameterize ((current-expand-filepath filepath))
     (let ((name (cadr expr))
           (decls (lib:cond-expand-decls (cddr expr) expander)))
-    `(define-library ,name ,@decls)))
+      `(define-library ,name ,@decls))))
 
 (define (lib:cond-expand-decls decls expander)
   (reverse
@@ -462,7 +465,7 @@
          (fp (open-input-file dir))
          (lib (read-all fp))
          (lib* (if expander
-                   (list (lib:cond-expand (car lib) expander))
+                   (list (lib:cond-expand dir (car lib) expander))
                    lib))
          (imports (lib:imports (car lib*))))
     (close-input-port fp)
@@ -485,7 +488,7 @@
          (fp (open-input-file dir))
          (lib (read-all fp))
          (lib* (if expander
-                   (list (lib:cond-expand (car lib) expander))
+                   (list (lib:cond-expand dir (car lib) expander))
                    lib))
          (options (lib:c-linker-options (car lib*))))
     (close-input-port fp)
@@ -505,7 +508,7 @@
          (fp (open-input-file dir))
          (lib (read-all fp))
          (lib* (if expander
-                   (list (lib:cond-expand (car lib) expander))
+                   (list (lib:cond-expand dir (car lib) expander))
                    lib))
          (options (lib:c-compiler-options (car lib*))))
     (close-input-port fp)
@@ -526,7 +529,7 @@
          (fp (open-input-file dir))
          (lib (read-all fp))
          (lib* (if expander
-                   (list (lib:cond-expand (car lib) expander))
+                   (list (lib:cond-expand dir (car lib) expander))
                    lib))
          (exports (lib:exports (car lib*))))
     (close-input-port fp)

scheme/cyclone/pass-validate-syntax.scm

@@ -14,7 +14,8 @@
       (scheme base)
       (scheme read)
       (scheme cyclone pretty-print)
-      (scheme cyclone util))))
+      (scheme cyclone util)))
+   (else #f))
 ;;
 ;; TODO: call this from cyclone.scm after it works, probably after "resolve macros"
 
@@ -59,7 +60,9 @@
   (define (search exp vars)
     (cond-expand
       (program
-        (pretty-print `(search ,exp ,vars))(newline))) ;; Debugging
+        (pretty-print `(search ,exp ,vars))(newline)) ;; Debugging
+      (else
+        #f))
     (cond
       ;((ast:lambda? exp) 'TODO)
       ((const? exp) #f)
@@ -111,4 +114,5 @@
     ;(if 1 2 3 4)
     
      (let ((sexp (read-all (open-input-file "validation.scm"))))
-      (validate-keyword-syntax sexp))))
+      (validate-keyword-syntax sexp)))
+  (else #f))

scheme/cyclone/primitives.sld

@@ -665,9 +665,9 @@
          ((eq? p 'Cyc-fast-member)  "memberp")
          ((eq? p 'Cyc-fast-assoc)   "assoc")
          ((eq? p 'assq)          "assq")
-         ((eq? p 'assv)          "assq")
+         ((eq? p 'assv)          "assv")
          ((eq? p 'memq)          "memqp")
-         ((eq? p 'memv)          "memqp")
+         ((eq? p 'memv)          "memvp")
          ((eq? p 'boolean?)      "Cyc_is_boolean")
          ((eq? p 'char?)         "Cyc_is_char")
          ((eq? p 'null?)         "Cyc_is_null")

scheme/cyclone/transforms.sld

@@ -597,6 +597,7 @@ if (acc) {
                ;; global may still be init'd to NULL if the order is incorrect in the "top level"
                ;; initialization code.
                (symbol? (car (define->exp (car top-lvl)))) ;; TODO: put these at the end of top-lvl???
+               (vector? (car (define->exp (car top-lvl))))
                (and (list? (car (define->exp (car top-lvl))))
                     (not (lambda? (car (define->exp (car top-lvl)))))))
              (loop (cdr top-lvl)

scheme/cyclone/util.sld

@@ -93,7 +93,8 @@
     string-replace-all
     take
     drop
-    filter)
+    filter
+    current-expand-filepath)
   (inline
     env:frame-values
     env:frame-variables
@@ -113,6 +114,8 @@
   )
   (begin
 
+(define current-expand-filepath (make-parameter #f))
+
 (define (tagged-list? tag exp)
   (if (pair? exp)
       (equal? (car exp) tag)

scheme/eval.sld

@@ -89,17 +89,26 @@
       ((analyze exp *global-environment* rename-env '()) *global-environment*)
       ((analyze exp (car env) rename-env '()) (car env))))
 
+;; Called from the C runtime to support apply
 (define (eval-from-c exp . _env)
   (let ((env (if (null? _env) *global-environment* (car _env))))
     (eval (wrapc exp) env)))
 
-;; Expressions received from C code are already evaluated, but sometimes too much so.
-;; Try to wrap 
+;; Helper function for eval-from-c
+;; 
+;; Expressions received from C code are already evaluated, 
+;; however any quoted expressions will have the quotes
+;; stripped off. This is a problem for expressions that
+;; aren't self evaluating - like (1 2) - so we re-quote
+;; the expressions here so a subsequent eval will work.
+;;
 (define (wrapc exp)
   (cond 
     ((application? exp)
      (cond
-       ((compound-procedure? (car exp))
+       ((or (primitive-procedure? (car exp)) 
+            (compound-procedure? (car exp))
+            (procedure? (car exp)))
         (cons 
           (car exp)
           (map 
@@ -611,19 +620,19 @@
                   #f))
          (expand 
            (lambda (macro-op)
-             ;(define use-env (env:extend-environment '() '() '()))
              (if (Cyc-macro? macro-op)
                ;; Compiled macro, call directly
-               (let ((expanded
-                        (macro:expand exp (list 'macro macro-op) a-env rename-env local-renamed)))
-                 (analyze expanded 
+               (let* ((expanded (_expand exp a-env rename-env '() local-renamed))
+                      (cleaned (macro:cleanup expanded rename-env)))
+                 (analyze cleaned
                           a-env
                           rename-env
                           local-renamed))
                ;; Interpreted macro, build expression and eval
-               (let* ((expanded (macro:expand exp (list 'macro macro-op) a-env rename-env local-renamed)))
+               (let* ((expanded (_expand exp a-env rename-env '() local-renamed))
+                      (cleaned (macro:cleanup expanded rename-env)))
                  (analyze
-                   expanded
+                   cleaned
                    a-env
                    rename-env
                    local-renamed))))))
@@ -636,14 +645,9 @@
 ;(display "/* ")
 ;(write (list exp))
 ;(display "*/ ")
-       (let ((fncs 
-               ;; Our map starts from the end, we reverse
-               ;; so everything is evaluated in order, then
-               ;; reverse again so results are in order
-               (reverse
-                 (map (lambda (expr) 
+       (let ((fncs (Cyc-map-loop-1 (lambda (expr) 
                                       (analyze expr a-env rename-env local-renamed))
-                      (reverse (cdr exp))))))
+                                   (cdr exp))))
          (lambda (env)
            (foldl (lambda (fnc _) (fnc env)) #f fncs))))
       ;; compiled macro
@@ -917,6 +921,10 @@
 ;(newline)
 ;(display "*/ ")
          (cond 
+           ((and (pair? expr) ;; Improper list
+                 (not (list? expr)))
+            (cons (clean (car expr) bv)
+                  (clean (cdr expr) bv)))
            ((const? expr)      expr)
            ((null? expr)       expr)
            ((quote? expr)      
@@ -978,8 +986,14 @@
 ;TODO: modify this whole section to use macros:get-env instead of *defined-macros*. macro:get-env becomes the mac-env. any new scopes need to extend that env, and an env parameter needs to be added to (expand). any macros defined with define-syntax use that env as their mac-env (how to store that)?
 ; expand : exp -> exp
 
-(define (expand exp env rename-env)
-  (_expand exp env rename-env '() '()))
+(define (expand exp . opts)
+  (let ((env (if (> (length opts) 0) 
+                 (car opts)
+                 *global-environment*))
+        (rename-env (if (> (length opts) 1) 
+                        (cadr opts) 
+                        (env:extend-environment '() '() '()))))
+    (_expand exp env rename-env '() '())))
 
 ;; Internal implementation of expand
 ;; exp - Expression to expand

scheme/inexact.sld

@@ -69,7 +69,6 @@
             (/ (c-log z1) (c-log z2*)))))
     (define-inexact-op c-log "log"   "clog")
     (define-inexact-op exp   "exp"   "cexp")
-    (define-inexact-op sqrt  "sqrt"  "csqrt")
     (define-inexact-op sin   "sin"   "csin")
     (define-inexact-op cos   "cos"   "ccos")
     (define-inexact-op tan   "tan"   "ctan")
@@ -93,4 +92,58 @@
                         (* (if (eqv? y -0.0) -1 1)
                            (if (eqv? x -0.0) 3.141592653589793 x))
                         (atan1 (/ y x))))))))
+
+ (define-c
+   sqrt
+   "(void *data, int argc, closure _, object k, object z)"
+   " double complex result;
+     Cyc_check_num(data, z);
+     if (obj_is_int(z)) {
+       result = csqrt(obj_obj2int(z));
+     } else if (type_of(z) == integer_tag) {
+       result = csqrt(((integer_type *)z)->value);
+     } else if (type_of(z) == bignum_tag) {
+       result = csqrt(mp_get_double(&bignum_value(z)));
+     } else if (type_of(z) == complex_num_tag) {
+       result = csqrt(complex_num_value(z));
+     } else {
+       result = csqrt(((double_type *)z)->value);
+     }
+   
+     if (cimag(result) == 0.0) {
+       if (obj_is_int(z) && creal(result) == round(creal(result))) {
+         return_closcall1(data, k, obj_int2obj(creal(result)));
+       }
+       make_double(d, creal(result));
+       return_closcall1(data, k, &d);
+     } else {
+       complex_num_type cn;
+       assign_complex_num((&cn), result);
+       return_closcall1(data, k, &cn);
+     } "
+   "(void *data, object ptr, object z)"
+   " double complex result;
+     Cyc_check_num(data, z);
+     if (obj_is_int(z)) {
+       result = csqrt(obj_obj2int(z));
+     } else if (type_of(z) == integer_tag) {
+       result = csqrt(((integer_type *)z)->value);
+     } else if (type_of(z) == bignum_tag) {
+       result = csqrt(mp_get_double(&bignum_value(z)));
+     } else if (type_of(z) == complex_num_tag) {
+       result = csqrt(complex_num_value(z));
+     } else {
+       result = csqrt(((double_type *)z)->value);
+     }
+  
+     if (cimag(result) == 0.0) {
+       if (obj_is_int(z) && creal(result) == round(creal(result))) {
+         return obj_int2obj(creal(result));
+       }
+       assign_double(ptr, creal(result));
+     } else {
+       assign_complex_num(ptr, result);
+     }
+     return ptr;
+     ")
 ))

scheme/read.sld

@@ -9,6 +9,7 @@
 (define-library (scheme read)
   (import (scheme base)
           (scheme cyclone common)
+          (scheme cyclone util)
           ;(scheme write)
           (scheme char))
   (export
@@ -31,17 +32,37 @@
 (define-syntax include
   (er-macro-transformer
    (lambda (expr rename compare)
-     (apply
-      append
-      (cons
-        '(begin)
-         (map
-          (lambda (filename)
+
+     (define (dirname filename)
+       (let loop ((index (string-length filename)))
+         (if (zero? index)
+             ""
+             (let ((index (- index 1)))
+               (if (char=? (string-ref filename index) #\/)
+                   (substring filename 0 index)
+                   (loop index))))))
+
+     (define (massage filename)
+       (cond
+        ;; may happen in the REPL
+        ((not (current-expand-filepath)) filename)
+        ;; absolute filename
+        ((char=? (string-ref filename 0) #\/) filename)
+        ;; otherwise, open the file relative to the library that is
+        ;; expanded
+        (else (let ((target (string-append (dirname (current-expand-filepath)) "/" filename)))
+                ;; if the target exists use, otherwise fallback to the
+                ;; backward compatible behavior.
+                (if (file-exists? target)
+                    target
+                    filename)))))
+
+     `(begin
+        ,@(let ((filename (massage (cadr expr))))
             (call-with-port
               (open-input-file filename)
               (lambda (port)
-                (read-all/source port filename))))
-          (cdr expr)))))))
+                (read-all/source port filename))))))))
 
 (define-syntax include-ci
   (er-macro-transformer
@@ -158,6 +179,12 @@
   "(void *data, object ptr, object opq)"
   " return(Cyc_is_string(opaque_ptr(opq)));")
 
+(define-c Cyc-opaque->string
+  "(void *data, int argc, closure _, object k, object opq)"
+  " return_closcall1(data, k, opaque_ptr(opq));"
+  "(void *data, object ptr, object opq)"
+  " return(opaque_ptr(opq));")
+
 (define-c Cyc-opaque-unsafe-string->number
   "(void *data, int argc, closure _, object k, object opq)"
   " Cyc_string2number_(data, k, opaque_ptr(opq));")
@@ -205,7 +232,10 @@
       ((Cyc-opaque? token)
        (cond
          ((Cyc-opaque-unsafe-string? token)
-          (Cyc-opaque-unsafe-string->number token))
+          (let ((rv (Cyc-opaque-unsafe-string->number token)))
+            (if rv
+                rv
+                (error "Invalid numeric syntax" (Cyc-opaque->string token)))))
          ;; Open paren, start read loop
          ((Cyc-opaque-unsafe-eq? token #\()
           (let ((line-num (get-line-num fp))
@@ -264,7 +294,10 @@
                                    (substring t 0 end)
                                    (substring t end (- len 1))))
                      (real (string->number real-str))
-                     (imag (string->number imag-str))
+                     (imag (cond
+                             ((equal? "+" imag-str) 1)  ;; Special case, +i w/no number
+                             ((equal? "-" imag-str) -1) ;; Special case, -i
+                             (else (string->number imag-str))))
                     )
                 (Cyc-make-rect real imag)))
              (else

scheme/repl.sld

@@ -20,9 +20,9 @@
     (define (repl)
       (with-handler
         (lambda (obj)
-          (display "Error: ")
           (cond
             ((error-object? obj)
+             (display "Error: ")
              (display (error-object-message obj))
              (if (not (null? (error-object-irritants obj)))
                  (display ": "))
@@ -31,22 +31,13 @@
                  (write o)
                  (display " "))
                (error-object-irritants obj)))
-            ((pair? obj)
-             (when (string? (car obj))
-               (display (car obj))
-               (if (not (null? (cdr obj)))
-                   (display ": "))
-               (set! obj (cdr obj)))
-             (for-each
-               (lambda (o)
-                 (write o)
-                 (display " "))
-               obj))
             (else
+              (display "Error: ")
               (display obj)))
           (newline)
           (repl))
         (display "cyclone> ")
+        (flush-output-port)
         (let ((obj (read)))
           (if (eof-object? obj)
               (newline) ;; Quick way to exit REPL

scripts/check-c-formatting.sh

@@ -0,0 +1,16 @@
+#!/bin/bash
+
+FORMAT_CMD="indent -linux -l80 -i2 -nut"
+FILE=$1
+TMP=$(mktemp)
+
+$FORMAT_CMD $FILE -o $TMP
+
+diff $FILE $TMP > /dev/null
+#ret=$?
+#
+#if [[ $ret -eq 0 ]]; then
+#    echo "passed."
+#else
+#    echo "failed."
+#fi

scripts/convert-doc-index.scm

@@ -48,7 +48,7 @@
   (when (not (eof-object? line))
     (with-handler
       (lambda (obj)
-        (display `(Error processing line ,line details ,obj)))
+        (display `(Error processing line ,line details ,obj) (current-error-port)))
       (display (convert-line line))
       (newline))
         

scripts/generate-doc-index.sh

@@ -2,7 +2,7 @@
 # Cyclone Scheme
 # https://github.com/justinethier/cyclone
 #
-# Copyright (c) 2014-2016, Justin Ethier
+# Copyright (c) 2014-2022, Justin Ethier
 # All rights reserved.
 #
 # Generate a sorted list of functions/variables from the API documentation.
@@ -18,3 +18,30 @@ grep -r "^- \[" docs/api/srfi/* | ./scripts/convert-doc-index >> $TMP
 grep -r "^\[" docs/api/srfi/* | ./scripts/convert-doc-index >> $TMP
 grep -r "^\[" docs/api/cyclone/* | ./scripts/convert-doc-index >> $TMP
 sort $TMP | ./scripts/alphabetize > $API
+
+# --------------------------------------------------------------------------------
+# Index with SEXP format (needed by Winds)
+# The sed command bellow transforms...
+
+#                                        ; newline
+#- - -                                   ; hyphens used as sections divs
+#[`abs`](api/scheme/base.md#abs)         ; Markdown link
+#[`acos`](api/scheme/inexact.md#acos)    ; Markdown link
+
+# ...into...
+
+#((abs (scheme base))                     ; ((definition1 library-that-contains-it)
+# (acos (scheme inexact)))                ;  (definition2 library-that-contains-it))
+
+API_SEXP=api-index.scm
+sed -e '/^-\|^$/d'           \
+    -e 's/\[`/(/'            \
+    -e 's/`\](api\// (/'     \
+    -e 's/.md.*$/))/'        \
+    -e 's/\// /g'            \
+    -e 's/[[:space:]]\+/ /g' $API > $API_SEXP
+
+# Add extra opening and closing parentheses
+sed -e '1s/^/(/'             \
+    -e '$s/$/)/'             \
+    -i $API_SEXP

srfi/106.sld

@@ -388,7 +388,7 @@
 #ifdef AI_V4MAPPED
       return_closcall1(data, k, obj_int2obj(AI_V4MAPPED)); 
 #else
-      Cyc_rt_raise_msg(data, \"AI_V4MAPPED is not available on this platform\");
+      return_closcall1(data, k, obj_int2obj(0)); 
 #endif
       ")
     (define *ai-all* (ai-all))
@@ -398,7 +398,7 @@
 #ifdef AI_ALL
       return_closcall1(data, k, obj_int2obj(AI_ALL)); 
 #else
-      Cyc_rt_raise_msg(data, \"AI_ALL is not available on this platform\");
+      return_closcall1(data, k, obj_int2obj(0)); 
 #endif
       ")
     (make-const ai-addrconfig  "AI_ADDRCONFIG" )

srfi/143.sld

@@ -36,9 +36,6 @@
     fxbit-field-rotate fxbit-field-reverse
   )
   (inline
-    fx-width
-    fx-greatest
-    fx-least
     fixnum?
     fx=?  fx<? fx>? fx<=? fx>=?
     fxzero? fxpositive? fxnegative? fxodd? fxeven?
@@ -50,15 +47,15 @@
     fxarithmetic-shift 
     fxarithmetic-shift-left fxarithmetic-shift-right
     fxbit-count 
-    fxif fxbit-set? fxcopy-bit
+    fxif fxcopy-bit
     fxfirst-set-bit 
     fxbit-field
     mask
   )
   (begin
-    (define (fx-width) 31)
-    (define (fx-greatest) 1073741823)
-    (define (fx-least)   -1073741824)
+    (define fx-width 31)
+    (define fx-greatest 1073741823)
+    (define fx-least   -1073741824)
 
     (define-syntax bin-num-op
       (er-macro-transformer
@@ -161,16 +158,22 @@
          return_closcall1(data, k, obj_int2obj(count));")
 
     (define (fxlength  i)
+      (exact 
         (ceiling (/ (log (if (fxnegative? i)
                              (fxneg i)
                              (fx+ 1 i)))
-                  (log 2))))
+                    (log 2)))))
 
     (define (fxif mask n0 n1)
       (fxior (fxand mask n0)
              (fxand (fxnot mask) n1)))
 
-    (define-c fxbit-set?
+    (define (fxbit-set? index i)
+      (or (%fxbit-set? index i)
+          (and (negative? i)
+               (>= index (fxlength i)))))
+
+    (define-c %fxbit-set?
        "(void* data, int argc, closure _, object k, object index, object i)"
        " Cyc_check_fixnum(data, index);
          Cyc_check_fixnum(data, i);

srfi/18.sld

@@ -73,6 +73,8 @@
         ;; - specific
         ;; - internal
         ;; - end of thread cont (or #f for default)
+        ;; - end-result - Result of thread that terminates successfully
+        ;; - internal thread context at termination, e.g. parameterised objects
         (vector 
           'cyc-thread-obj 
           thunk 
@@ -80,6 +82,8 @@
           name-str 
           #f 
           #f
+          #f
+          #f
           #f)))
 
     (define (thread-name t) (vector-ref t 3))
@@ -96,7 +100,7 @@
       (%get-thread-data))
 
     (define *primordial-thread*
-      (vector 'cyc-thread-obj #f #f "main thread" #f #f))
+      (vector 'cyc-thread-obj #f #f "main thread" #f #f #f #f))
 
     (define-c %current-thread
       "(void *data, int argc, closure _, object k)"
@@ -116,23 +120,55 @@
         make_c_opaque(co, td);
         return_closcall1(data, k, &co); ")
 
+    (define-c %end-thread!
+      "(void *data, int argc, closure _, object k, object ret)"
+      " gc_thread_data *d = data;
+        vector_type *v = d->scm_thread_obj;
+        v->elements[7] = ret;     // Store thread result
+        Cyc_end_thread(d);
+        return_closcall1(data, k, boolean_f);")
+
     (define (thread-start! t)
       ;; Initiate a GC prior to running the thread, in case
       ;; it contains any closures on the "parent" thread's stack
       (let* ((thunk (vector-ref t 1)) 
              (thread-params (cons t (lambda ()
                                       (vector-set! t 5 #f)
-                                      (thunk)))))
+                                      (let ((r (thunk))) (%end-thread! r))))))
         (vector-set! t 5 (%get-thread-data)) ;; Temporarily make parent thread
                                              ;; data available for child init
         (Cyc-minor-gc)
         (Cyc-spawn-thread! thread-params)
-        ))
+        t))
 
     (define (thread-yield!) (thread-sleep! 1))
-    (define-c thread-terminate!
-      "(void *data, object _, int argc, object *args)"
-      " Cyc_end_thread(data); ")
+
+    (define-c %thread-terminate!
+      "(void *data, int argc, closure _, object k, object thread_data_opaque)"
+      " gc_thread_data *td;
+        if (thread_data_opaque == boolean_f) {
+          /* primordial thread */
+          __halt(boolean_f);
+        } else {
+          td = (gc_thread_data *)(opaque_ptr(thread_data_opaque));
+          if (td == data) {
+            Cyc_end_thread(td);
+          } else {
+            pthread_cancel(td->thread_id);
+          }
+        }
+        return_closcall1(data, k, boolean_t);")
+    (define (thread-terminate! t)
+      (cond
+       ((and (thread? t)
+             (or (Cyc-opaque? (vector-ref t 2)) (equal? *primordial-thread* t)))
+        (begin
+         (Cyc-minor-gc)
+         (vector-set! t 5 (%get-thread-data)) ;; remember calling thread
+         (%thread-terminate! (vector-ref t 2))
+         #t))
+       (else
+        #f))) ;; TODO: raise an error instead?
 
     ;; TODO: not good enough, need to return value from thread
     ;; TODO: perhaps not an ideal solution using a loop/polling below, but good
@@ -151,9 +187,13 @@
         }
         return_thread_runnable(data, boolean_t);")
     (define (thread-join! t)
-      (if (and (thread? t) (Cyc-opaque? (vector-ref t 2)))
+      (cond
+       ((and (thread? t) (Cyc-opaque? (vector-ref t 2)))
         (%thread-join! (vector-ref t 2))
-        #f))
+        (Cyc-minor-gc)
+        (vector-ref t 7))
+       (else
+        #f))) ;; TODO: raise an error instead?
 
     (define-c thread-sleep!
       "(void *data, int argc, closure _, object k, object timeout)"

test-lib.c

@@ -0,0 +1,51 @@
+#include <stdio.h>
+#include <assert.h>
+#include "include/cyclone/types.h"
+#include "include/cyclone/runtime.h"
+#include "include/cyclone/runtime-main.h"
+
+/* Future considerations:
+int main(int argc, char **argv, char **envp)
+{gc_thread_data *thd;
+ long stack_size = global_stack_size = STACK_SIZE;
+ long heap_size = global_heap_size = HEAP_SIZE;
+ init_polyfills();
+ mclosure0(clos_halt,&Cyc_halt);  // Halt if final closure is reached
+ mclosure0(entry_pt,&c_entry_pt); // First function to execute
+ _cyc_argc = argc;
+ _cyc_argv = argv;
+ set_env_variables(envp);
+ gc_initialize();
+ thd = malloc(sizeof(gc_thread_data));
+ gc_thread_data_init(thd, 0, (char *) &stack_size, stack_size);
+ thd->gc_cont = &entry_pt;
+ thd->gc_args[0] = &clos_halt;
+ thd->gc_num_args = 1;
+ thd->thread_id = pthread_self();
+ gc_add_mutator(thd);
+ Cyc_heap_init(heap_size);
+ thd->thread_state = CYC_THREAD_STATE_RUNNABLE;
+ Cyc_start_trampoline(thd);
+ return 0;}
+ */
+
+void test_exact() {
+  common_type ptr;
+  make_double(d, 42.5);
+  assert(obj_int2obj(42) == Cyc_exact_no_cps(NULL, &ptr, obj_int2obj(42)));
+  object result = Cyc_exact_no_cps(NULL, &ptr, &d);
+  assert( result == obj_int2obj(43));
+
+  // TODO: unit tests for below as examples:
+  //void Cyc_exact(void *data, object cont, object z)
+}
+
+int main(){
+  assert(boolean_t == boolean_t);
+  assert(boolean_t != boolean_f);
+
+  test_exact();
+
+  printf("All tests passed successfully!\n");
+  return 0;
+}

tests/base.scm

@@ -0,0 +1,217 @@
+;;;; Cyclone Scheme
+;;;; https://github.com/justinethier/cyclone
+;;;;
+;;;; Copyright (c) 2014-2021, Justin Ethier
+;;;; All rights reserved.
+;;;;
+;;;; This module contains unit tests for threading / SRFI 18.
+;;;;
+
+(import 
+  (scheme base)
+  (scheme eval)
+  (scheme inexact)
+  (scheme write)
+  (cyclone test))
+
+
+(define vec #(1 2))
+
+(test-group
+  "vector literals"
+  (test #(1 2) vec)
+  (test vec (vector 1 2))
+)
+
+(test-group
+  "strings"
+  (test "??>" "??>")
+)
+
+(test-group
+  "make-list"
+  (test '() (make-list -2))
+)
+
+(test-group
+  "apply"
+  (test '(5 1 2) (eval '(apply cons '(5 (1 2)))))
+  (test '(5 1 2) (apply cons '(5 (1 2))))
+)
+
+(cond-expand
+  (memory streams
+    (test-group
+      "I/O"
+      (define p (open-input-string "one\ntwo\n"))
+      (test #\o (read-char p))
+      (test "ne" (read-line p))
+      (test "two" (read-line p))
+      (test (eof-object) (read-line p))
+      (define p (open-input-string "one\ntwo\n"))
+      (test "one" (read-line p))
+      (test #\t (read-char p))
+      (test #\w (read-char p))
+      (test "o" (read-line p))
+    )
+  )
+  (else #f)
+)
+
+(test-group
+  "rationals"
+  (test 3.0 (numerator (/ 6 4)))
+  (test 2.0 (denominator (/ 6 4)))
+  (test 3.0 (expt 81 1/4))
+  (test #t
+    (< 1.0e+40 
+       (/ 33333333333333333333333333333333333333333 3.0)
+       1.2e+40))
+)
+
+(test-group
+  "numeric operations - floor, truncate, "
+  (test -1 (truncate -1))
+  (test -1.0 (truncate -1.0))
+  (test -1.0 (truncate -1.1))
+  (test -1.0 (truncate -1.1))
+  (test +inf.0 (truncate +inf.0))
+
+  (test (values 2 1) (floor/ 5 2))
+  (test (values -3 1) (floor/ -5 2))
+  (test (values -3 -1) (floor/ 5 -2))
+  (test (values 2 -1) (floor/ -5 -2))
+  (test (values 2 1) (truncate/ 5 2))
+  (test (values -2 -1) (truncate/ -5 2))
+  (test (values -2 1) (truncate/ 5 -2))
+  (test (values 2 -1) (truncate/ -5 -2))
+  (test (values 2.0 -1.0) (truncate/ -5.0 -2))
+
+  (test 4 (gcd 32 -36))
+  (test 0 (gcd))
+  (test 288 (lcm 32 -36))
+  (test 288.0 (lcm 32.0 -36))
+  (test 1 (lcm))
+
+  (test -5.0 (floor -4.3))
+  (test -4.0 (ceiling -4.3))
+  (test -4.0 (truncate -4.3))
+  (test -4.0 (round -4.3))
+  (test 3.0  (floor 3.5))
+  (test 4.0  (ceiling 3.5))
+  (test 3.0  (truncate 3.5))
+  (test 4.0  (round 3.5))
+  (test 2.0  (round 2.5))
+  (test -4.0 (round -3.5))
+  (test -2.0 (round -2.5))
+  (test 4.0  (round 7/2)) ;; Rationals not supported, so result is inexact
+  (test 7    (round 7))
+
+  (test 3.0 (numerator (/ 6 4))) ;; Inexact because we don't support rationals yet
+  (test 2.0 (denominator (/ 6 4))) ;; Inexact because we don't support rationals yet
+  (test 2.0 (denominator (inexact (/ 6 4))))
+)
+
+(test-group
+  "sqrt"
+  (test 1i (sqrt -1))
+  (test 1i (sqrt -1.0))
+  (test +i (sqrt -1.0))
+  (test 2 (sqrt 4))
+  (test 2.0 (sqrt 4.0))
+  (test 2i (sqrt -4.0))
+  (test #t (complex? (sqrt -1)))
+  (test #t (complex? (sqrt -i)))
+)
+
+(test-group
+  "exact"
+  (test -1 (exact -1))
+  (test -1 (exact -1.0))
+  (test -1 (exact -1.1))
+  (test -1 (exact -1.1))
+  (test 1.0+1.0i (exact 1.1+1.2i))
+  ;(test #t (bignum? (exact 111111111111111111111111111.0)))
+  ;(test #t (bignum? (exact -111111111111111111111111111.0)))
+  ;(test +inf.0 (exact +inf.0))
+)
+
+(test-group
+  "records"
+  (define-record-type employee
+     (make-employee name title)
+     employee?
+     (name get-name)
+     (title get-title)
+     (test get-test set-test!)) ;; Uninitialized by constructor
+  (define e (make-employee "test-name" "job 1"))
+
+  (test #f (get-test e))
+  (set-test! e 'test-field)
+  (test 'test-field (get-test e))
+)
+
+(test-group
+  "assoc"
+  (define a 0.0)
+  (test '(0.0) (assoc a (list (list a))))
+  (test '(0.0) (assoc 0.0 (list (list a))))
+  (test '(0.0) (assv a (list (list a))))
+  (test '(0.0) (assv 0.0 (list (list a))))
+  (test '(0.0) (assq a (list (list a))))
+  (test #f (assq 0.0 (list (list a))))
+)
+
+(test-group
+  "member"
+  (define m 0.0)
+  (test '(0.0) (member m (list m)))
+  (test '(0.0) (member 0.0 (list m)))
+  (test '(0.0) (memv m (list m)))
+  (test '(0.0) (memv 0.0 (list m)))
+  (test '(0.0) (memq m (list m)))
+  (test #f (memq 0.0 (list m)))
+)
+
+(test-group
+  "exception handling"
+  (define (capture-output thunk)
+    (let ((output-string (open-output-string)))
+      (parameterize ((current-output-port output-string))
+        (thunk))
+      (let ((result (get-output-string output-string)))
+       (close-output-port output-string)
+       result)))
+  (test
+    "should be a number65"
+    (capture-output
+      (lambda ()
+        (with-exception-handler
+          (lambda (con)
+            (cond
+              ((string? con)
+               (display con))
+              (else
+               (display "a warning has been issued")))
+            42)
+          (lambda ()
+            (display
+              (+ (raise-continuable "should be a number")
+                 23)))))))
+  (test
+    "condition: an-error"
+    (capture-output
+      (lambda ()
+        (call-with-current-continuation
+          (lambda (k)
+            (with-exception-handler
+              (lambda (x)
+                (display "condition: ")
+                (write x)
+                (k "exception"))
+              (lambda ()
+                (+ 1 (raise 'an-error)))))))))
+)
+
+(test-exit)
+

tests/c-compiler-options.scm

@@ -0,0 +1,9 @@
+;; Simple test to prevent regressions of top-level c-compiler-options 
+(import (scheme base)
+        (scheme write)
+        (cyclone foreign))
+
+(c-compiler-options "-I/tmp")
+
+(display "hello")
+

tests/test.scm

@@ -0,0 +1,26 @@
+;;;; Cyclone Scheme
+;;;; https://github.com/justinethier/cyclone
+;;;;
+;;;; Copyright (c) 2014-2021, Justin Ethier
+;;;; All rights reserved.
+;;;;
+;;;; This module contains unit tests for (cyclone test)
+;;;;
+
+(import 
+  (scheme base)
+  (cyclone test))
+
+(test-group
+  "assert"
+  (test-assert #t)
+)
+
+(test-group
+  "not"
+  (test-not #f)
+)
+
+(test-exit)
+
+

tests/threading.scm

@@ -0,0 +1,22 @@
+;;;; Cyclone Scheme
+;;;; https://github.com/justinethier/cyclone
+;;;;
+;;;; Copyright (c) 2014-2021, Justin Ethier
+;;;; All rights reserved.
+;;;;
+;;;; This module contains unit tests for threading / SRFI 18.
+;;;;
+
+(import 
+  (scheme base)
+  (srfi 18)
+  (cyclone test))
+
+
+(test-group
+  "thread-join!"
+  (let ((t (thread-start! (make-thread (lambda () (expt 2 100))))))
+    (test (expt 2 100) (thread-join! t)))
+)
+
+(test-exit)

tests/unit-tests.scm

@@ -35,6 +35,49 @@
 (set-cdr! l '(c b)) ; Above seems to break if it replaces this line
 (assert:equal "list? on circular list" (list? l) #t)
 
+;; Circular data structures
+(define v1 (vector #f))
+(define v2 (vector v1))
+(vector-set! v1 0 v2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (display v1 fp)
+     (assert:equal "display circular vector" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular vectors" (equal? v1 v2) #t)
+(newline)
+
+(define v1 (vector 1 2 3))
+(define v2 (vector 1 v1 3))
+(vector-set! v1 1 v2)
+(cond-expand
+ (memory-streams
+  (let ((fp (open-output-string)))
+    (write v1 fp)
+    (assert:equal "display circular vector" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular vectors, test 2" (equal? v1 v2) #t)
+(newline)
+
+(define l1 (list #f))
+(define l2 (list l1))
+(set-cdr! l1 l2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (display l1 fp)
+     (assert:equal "display circular list" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular lists" (equal? l1 l2) #f)
+
+(define l1 (list 1 2 3))
+(define l2 (list 1 l1 3))
+(set-cdr! (cdr l1) l2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (write l1 fp)
+     (assert:equal "display circular list" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular lists, test 2" (equal? l1 l2) #f)
+
 ;; Adder example
 (define (make-adder x)
   (lambda (y) (+ x  y)))
@@ -378,6 +421,13 @@
   (x kar set-kar!)
   (y kdr))
 
+(define-record-type <point>
+  (point x y)
+  point?
+  (x get-x set-x!)
+  (y get-y set-y!)
+  (z get-z set-z!))
+
 (assert:equal "Records predicate (t)" (pare? (kons 1 2)) #t)
 (assert:equal "Records predicate (f)" (pare? (cons 1 2)) #f)
 (assert:equal "Records kar" (kar (kons 1 2)) 1)
@@ -389,6 +439,11 @@
   3)
 (assert:equal "Record type predicate (t)" (record? (kons 1 2)) #t)
 (assert:equal "Record type predicate (f)" (record? (cons 1 2)) #f)
+
+(assert:equal "Record type field not in constructor (f)" (get-z (point 1 2)) #f)
+(let ((p (point 1 2)))
+  (set-z! p 99)
+  (assert:equal "Record type get field not in constructor" (get-z p) 99))
 ;; END records
 
 ;; Lazy evaluation