diff --git a/Makefile b/Makefile
index f0abc72e..212221d8 100644
--- a/Makefile
+++ b/Makefile
@@ -21,7 +21,8 @@ SMODULES = \
scheme/cyclone/libraries \
scheme/cyclone/macros \
scheme/cyclone/transforms \
- scheme/cyclone/util
+ scheme/cyclone/util \
+ srfi/18
SLDFILES = $(addsuffix .sld, $(SMODULES))
COBJECTS=$(SLDFILES:.sld=.o)
@@ -42,13 +43,14 @@ dispatch.c: generate-c.scm
./generate-c
libcyclone.so.1: runtime.c include/cyclone/runtime.h
- gcc -g -c -fPIC runtime.c -o runtime.o
+ gcc $(CFLAGS) -c -fPIC runtime.c -o runtime.o
gcc -shared -Wl,-soname,libcyclone.so.1 -o libcyclone.so.1.0.1 runtime.o
-libcyclone.a: runtime.c include/cyclone/runtime.h include/cyclone/types.h dispatch.c
- $(CC) -g -c -Iinclude dispatch.c -o dispatch.o
- $(CC) -g -c -Iinclude -DCYC_INSTALL_DIR=\"$(PREFIX)\" -DCYC_INSTALL_LIB=\"$(LIBDIR)\" -DCYC_INSTALL_INC=\"$(INCDIR)\" -DCYC_INSTALL_SLD=\"$(DATADIR)\" runtime.c -o runtime.o
- $(AR) rcs libcyclone.a runtime.o dispatch.o
+libcyclone.a: runtime.c include/cyclone/runtime.h include/cyclone/types.h gc.c dispatch.c
+ $(CC) $(CFLAGS) -c -Iinclude dispatch.c -o dispatch.o
+ $(CC) $(CFLAGS) -std=gnu99 -c -Iinclude gc.c -o gc.o
+ $(CC) $(CFLAGS) -c -Iinclude -DCYC_INSTALL_DIR=\"$(PREFIX)\" -DCYC_INSTALL_LIB=\"$(LIBDIR)\" -DCYC_INSTALL_INC=\"$(INCDIR)\" -DCYC_INSTALL_SLD=\"$(DATADIR)\" runtime.c -o runtime.o
+ $(AR) rcs libcyclone.a runtime.o gc.o dispatch.o
# Instructions from: http://www.adp-gmbh.ch/cpp/gcc/create_lib.html
# Note compiler will have to link to this, eg:
#Linking against static library
@@ -59,13 +61,17 @@ libcyclone.a: runtime.c include/cyclone/runtime.h include/cyclone/types.h dispat
bootstrap: icyc
# rm -rf $(BOOTSTRAP_DIR)
mkdir -p $(BOOTSTRAP_DIR)/scheme/cyclone
+ mkdir -p $(BOOTSTRAP_DIR)/srfi
mkdir -p $(BOOTSTRAP_DIR)/include/cyclone
cp include/cyclone/types.h $(BOOTSTRAP_DIR)/include/cyclone
cp include/cyclone/runtime-main.h $(BOOTSTRAP_DIR)/include/cyclone
cp include/cyclone/runtime.h $(BOOTSTRAP_DIR)/include/cyclone
+ cp include/cyclone/ck_ht_hash.h $(BOOTSTRAP_DIR)/include/cyclone
cp scheme/*.sld $(BOOTSTRAP_DIR)/scheme
cp scheme/cyclone/*.sld $(BOOTSTRAP_DIR)/scheme/cyclone
+ cp srfi/*.sld $(BOOTSTRAP_DIR)/srfi
cp runtime.c $(BOOTSTRAP_DIR)
+ cp gc.c $(BOOTSTRAP_DIR)
cp dispatch.c $(BOOTSTRAP_DIR)
cp scheme/base.c $(BOOTSTRAP_DIR)/scheme
cp scheme/read.c $(BOOTSTRAP_DIR)/scheme
@@ -81,6 +87,7 @@ bootstrap: icyc
cp scheme/cyclone/transforms.c $(BOOTSTRAP_DIR)/scheme/cyclone
cp scheme/cyclone/cgen.c $(BOOTSTRAP_DIR)/scheme/cyclone
cp scheme/cyclone/util.c $(BOOTSTRAP_DIR)/scheme/cyclone
+ cp srfi/18.c $(BOOTSTRAP_DIR)/srfi
cp cyclone.c $(BOOTSTRAP_DIR)/cyclone.c
cp Makefile.config $(BOOTSTRAP_DIR)/Makefile.config
@@ -95,7 +102,7 @@ tags:
.PHONY: clean
clean:
- rm -rf a.out *.o *.so *.a *.out tags cyclone icyc scheme/*.o scheme/*.c scheme/*.meta scheme/cyclone/*.o scheme/cyclone/*.c scheme/cyclone/*.meta cyclone.c dispatch.c icyc.c generate-c.c generate-c
+ rm -rf a.out *.o *.so *.a *.out tags cyclone icyc scheme/*.o scheme/*.c scheme/*.meta srfi/*.o scheme/cyclone/*.o scheme/cyclone/*.c scheme/cyclone/*.meta cyclone.c dispatch.c icyc.c generate-c.c generate-c
$(foreach f,$(TESTSCM), rm -rf $(f) $(f).c tests/$(f).c;)
install-includes:
@@ -119,12 +126,15 @@ install:
$(MKDIR) $(DESTDIR)$(INCDIR)
$(MKDIR) $(DESTDIR)$(DATADIR)
$(MKDIR) $(DESTDIR)$(DATADIR)/scheme/cyclone
+ $(MKDIR) $(DESTDIR)$(DATADIR)/srfi
$(INSTALL) -m0644 libcyclone.a $(DESTDIR)$(LIBDIR)/
$(INSTALL) -m0644 include/cyclone/*.h $(DESTDIR)$(INCDIR)/
$(INSTALL) -m0644 scheme/*.sld $(DESTDIR)$(DATADIR)/scheme
$(INSTALL) -m0644 scheme/*.o $(DESTDIR)$(DATADIR)/scheme
$(INSTALL) -m0644 scheme/cyclone/*.sld $(DESTDIR)$(DATADIR)/scheme/cyclone
$(INSTALL) -m0644 scheme/cyclone/*.o $(DESTDIR)$(DATADIR)/scheme/cyclone
+ $(INSTALL) -m0644 srfi/*.sld $(DESTDIR)$(DATADIR)/srfi
+ $(INSTALL) -m0644 srfi/*.o $(DESTDIR)$(DATADIR)/srfi
$(INSTALL) -m0755 cyclone $(DESTDIR)$(BINDIR)/
$(INSTALL) -m0755 icyc $(DESTDIR)$(BINDIR)/
@@ -136,6 +146,8 @@ uninstall:
$(RMDIR) $(DESTDIR)$(INCDIR)
$(RM) $(DESTDIR)$(DATADIR)/scheme/cyclone/*.*
$(RMDIR) $(DESTDIR)$(DATADIR)/scheme/cyclone
+ $(RM) $(DESTDIR)$(DATADIR)/srfi/*.*
+ $(RMDIR) $(DESTDIR)$(DATADIR)/srfi
$(RM) $(DESTDIR)$(DATADIR)/scheme/*.*
$(RMDIR) $(DESTDIR)$(DATADIR)/scheme
$(RMDIR) $(DESTDIR)$(DATADIR)
@@ -148,8 +160,9 @@ sld:
.PHONY: debug
debug:
- cyclone scheme/cyclone/macros.sld && sudo cp scheme/cyclone/macros.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.o /usr/local/share/cyclone/scheme/cyclone/ && \
- cyclone scheme/cyclone/util.sld && sudo cp scheme/cyclone/util.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.o /usr/local/share/cyclone/scheme/cyclone/ && \
- cyclone scheme/cyclone/transforms.sld && sudo cp scheme/cyclone/transforms.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.o /usr/local/share/cyclone/scheme/cyclone/ && \
- cyclone -t cyclone.scm && cyclone -t icyc.scm && sudo make install-bin
+ sudo ls; cyclone scheme/cyclone/cgen.sld && sudo cp scheme/cyclone/cgen.* /usr/local/share/cyclone/scheme/cyclone/ && cyclone cyclone.scm && sudo make install-includes && sudo make install-libs && ./cyclone generate-c.scm
+### cyclone scheme/cyclone/macros.sld && sudo cp scheme/cyclone/macros.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.o /usr/local/share/cyclone/scheme/cyclone/ && \
+### cyclone scheme/cyclone/util.sld && sudo cp scheme/cyclone/util.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.o /usr/local/share/cyclone/scheme/cyclone/ && \
+### cyclone scheme/cyclone/transforms.sld && sudo cp scheme/cyclone/transforms.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.o /usr/local/share/cyclone/scheme/cyclone/ && \
+### cyclone -t cyclone.scm && cyclone -t icyc.scm && sudo make install-bin
diff --git a/Makefile.config b/Makefile.config
index 26339936..1829a5a2 100644
--- a/Makefile.config
+++ b/Makefile.config
@@ -1,6 +1,7 @@
# install configuration
+CFLAGS ?= -g
CC ?= cc
AR ?= ar
#CD ?= cd
diff --git a/Makefile.config.raspberry-pi-2 b/Makefile.config.raspberry-pi-2
new file mode 100644
index 00000000..a9a8d28c
--- /dev/null
+++ b/Makefile.config.raspberry-pi-2
@@ -0,0 +1,22 @@
+
+# install configuration
+
+CFLAGS ?= -g -march=armv6k
+CC ?= cc
+AR ?= ar
+#CD ?= cd
+RM ?= rm -f
+#LS ?= ls
+#CP ?= cp
+#LN ?= ln
+INSTALL ?= install
+MKDIR ?= $(INSTALL) -d
+RMDIR ?= rmdir
+
+PREFIX ?= /usr/local
+BINDIR ?= $(PREFIX)/bin
+LIBDIR ?= $(PREFIX)/lib
+INCDIR ?= $(PREFIX)/include/cyclone
+DATADIR ?= $(PREFIX)/share/cyclone
+
+DESTDIR ?=
diff --git a/README.md b/README.md
index 68dedf28..681b1c2e 100644
--- a/README.md
+++ b/README.md
@@ -58,7 +58,9 @@ References
- [CHICKEN Scheme](http://www.call-cc.org/)
- [Chibi Scheme](https://github.com/ashinn/chibi-scheme)
- [Compiling Scheme to C with closure conversion](http://matt.might.net/articles/compiling-scheme-to-c/), by Matt Might
+- Implementing an on-the-fly garbage collector for Java, by Domani et al
- [Lisp in Small Pieces](http://pagesperso-systeme.lip6.fr/Christian.Queinnec/WWW/LiSP.html), by Christian Queinnec
+- Portable, Unobtrusive Garbage Collection for Multiprocessor Systems, by Damien Doligez and Georges Gonthier
- [R5RS Scheme Specification](http://www.schemers.org/Documents/Standards/R5RS/HTML/)
- [R7RS Scheme Specification](http://trac.sacrideo.us/wg/wiki)
- [Structure and Interpretation of Computer Programs](https://mitpress.mit.edu/sicp/full-text/book/book.html), by Harold Abelson and Gerald Jay Sussman
diff --git a/TODO b/TODO
index 93ced0d0..6136b57c 100644
--- a/TODO
+++ b/TODO
@@ -1,4 +1,17 @@
+Instructions to rebuild cyclone after changing string_type returns to object returns:
+shouldn't it just be a matter of compiling cgen and dumping that and the includes/libs into bootstrap??
+;sudo ls ; cyclone scheme/cyclone/cgen.sld && sudo cp scheme/cyclone/cgen.* /usr/local/share/cyclone/scheme/cyclone/
+;make clean ; make && sudo make install
+;sudo make install-includes
+;cp ../cyclone-bootstrap/dispatch.c .
+;make libcyclone.a
+;sudo make install-libs
+;make clean ; make && sudo make install
+at this point, cyclone crashes when compiling the test suite. I think there may be a problem with there being a disconnect between the old/new versions of compiled code, runtime libs, etc. however, the generated c files have the change. so it should be possible to bootstrap using them...
+
+
Roadmap:
+ - Make it easier to work with multiple copies of cyclone. for example, maybe an env variable could be used to point a local copy of cyclone to the current directory for resources, instead of /usr/local/
- Add macro support, ideally including some level of hygiene
- Code cleanup - need to take care of accumulated cruft before release. also, can we profile to make things any faster?
- Target r7rs support (coordinate with feature list)
diff --git a/cyclone.scm b/cyclone.scm
index ee110c76..b43e72f9 100644
--- a/cyclone.scm
+++ b/cyclone.scm
@@ -286,7 +286,7 @@
(comp-prog-cmd
(string-append "gcc " src-file " -g -c -o " exec-file ".o"))
(comp-objs-cmd
- (string-append "gcc " exec-file ".o " objs-str " -lcyclone -lm -g -o " exec-file)))
+ (string-append "gcc " exec-file ".o " objs-str " -pthread -lcyclone -lck -lm -g -o " exec-file)))
;(write `(DEBUG all imports ,lib-deps objs ,objs-str))
;(write `(DEBUG ,(lib:get-all-import-deps (cdar in-prog))))
(cond
diff --git a/docs/Developer-How-To.md b/docs/Developer-How-To.md
index a0d34ba1..9a7514e9 100644
--- a/docs/Developer-How-To.md
+++ b/docs/Developer-How-To.md
@@ -1,14 +1,16 @@
## Add a primitive
-WIP set of instructions for doing this. working to refine this down:
+- Add function/definitions to `runtime.h` and `runtime.c`
+- Rebuild and install runtime library.
+- Add to `prim?` section in `transforms.sld`. Some functions may need to added to the next section in the file, so they are not constant-folded (IE, evaluated at compile time).
+- Add above the `c-compile-primitive` section in `cgen.sld`. Some functions may need to be added in multiple places to indicate they take additional arguments, call their continuation, etc.
-- Add function/definitions to runtime.h and runtime.c
-- Add to prim? section in transforms.scm. Some functions may need to added to the next section in the file, so they are not constant-folded (IE, evaluated at compile time).
-- Add to the c-compile-primitive section in cgen.scm.
-- install modified .scm files
-- cyclone scheme/cyclone/cgen.sld
-- copy modified files to cyclone-bootstrap, including cgen.c
-- install cyclone-bootstrap
-- run 'make clean ; make && make bootstrap' from cyclone repo
-- run 'make clean ; ./install' from bootstrap repo
+TODO: need to develop this section better to come up with a workable/optimal approach to building things:
+- Compile:
+ cyclone scheme/cyclone/cgen.sld
+ cyclone scheme/cyclone/transforms.sld
+- Copy modified files to cyclone-bootstrap, including runtime, `.sld`, and compiled `.c` files.
+- Run `make clean ; ./install` from bootstrap repo
+
+- Add primitives to the list in eval.sld. Rebuild one more time.
diff --git a/gc-notes.txt b/gc-notes.txt
new file mode 100644
index 00000000..d7cdcc13
--- /dev/null
+++ b/gc-notes.txt
@@ -0,0 +1,203 @@
+Phase 1 (gc-dev) - Add gc.h, make sure it compiles.
+Phase 2 (gc-dev2) - Change how strings are allocated, to clean up the code and be compatible with a new GC algorithm.
+Phase 3 (gc-dev3) - Change from using a Cheney-style copying collector to a naive mark&sweep algorithm.
+Phase 4 (gc-dev4) - Integrating new tracing GC algorithm, added new thread data argument to runtime.
+Phase 5 (gc-dev5) - Require pthreads library, stand cyclone back up using new GC algorithm.
+Phase 6 (gc-dev6) - Multiple mutators (application threads)
+Phase 7 (TBD) - Sharing of variables between threads (ideally without limitation, but that might not be realistic)
+
+TODO:
+- merge everything back to master??? I think it's just about time
+- need a legitimate test program that uses mutexes. am worried that when lock calls into a cont, the program will crash because it returns a boolean object, which the runtime does not handle
+ maybe just a simple producer/consumer type program
+
+- multiple mutators, and threading functions/types. probably want this on a new branch, when ready
+ part of this is implementing the beginnings of srfi-18, to create multiple threads, sync them, etc
+ next steps:
+
+ - start making core stuff thread safe. for example, test.scm sometimes
+ crashes, I think printing out result from (read)
+ - assume I/O and eval both have threading issues
+
+- bring exceptions into local thread data? anything else?
+ also, will probably need to lock shared resources such as I/O...
+- user manual
+ need to document everything, including:
+ - how to use cyclone (meta files, compiling modules, etc)
+ - what to be cognizant of when writing threading code. esp, how to deal with stack objects (initiating minor GC's, etc)
+- revisit features list, issues list, etc
+- FFI
+
+DONE:
+- need to cooperate when a mutator is blocked
+ IMPLEMENTATION NOTES:
+
+ these become gc_cont and gc_args, so we need them for the wrapper:
+ GC(td,cfn,buf,1); return;
+ also need the result of the primitive, although that obviously is not
+ available until after it finishes blocking. will just have to live with that
+ constraint.
+
+ requirements:
+ - collector detects initiates async transition
+ - collector will need to perform a minor GC instead of this mutator
+ will need to pass in top of stack then, since collector won't have that.
+ can use address of continuation, if we can guarantee it will always be
+ allocated on the stack prior to wrapper call. or can just let the wrapper
+ do it, and stash it somewhere collector can get to it
+ - collector must set flag immediately to let mutator know what happened
+ - mutator must know when the transition occurs, and wait for it to finish
+ - can use mutator lock
+
+ will cont always be called via closcall1?
+ maybe we need to require prim accepts cont as an arg. might simplify
+ calling the wrapper.
+
+ then instead of a wrapper, the prim can call functions to set initial state and cleanup. it already does this to set thread state, so this isn't that big of a change (just call 2 other functions):
+
+ before_blocking {
+ set thread state ==> BLOCKING
+ set thd->gc_cont to cont, in case collector needs to use it
+ set stack_top to new field in "thd", again in case collector needs it
+ OR NOT, I think we can use stack_limit for this, to define the
+ range of stack addresses
+ }
+
+ after_blocking {
+ set thread state ==> RUNNABLE
+ check async flag
+ if set:
+ wait for thd->lock
+ unset async flag
+ transport result to heap, if necessary (not a value type)
+ set gc_args[0] to result
+ longjmp. assumes gc_cont already set by collector
+ else:
+ call into cont with result, just like today (see Cyc_io_read_line)
+ }
+
+ OLDER NOTES:
+ might be able to stop a thread and do a minor GC on it, but no longjmp until after major GC.
+ would need to figure out how to repack gc_cont and args
+ optionally, some primitives can accept a cont, how to handle? I guess we would have to
+ call the primitive with a wrapper instead of the real cont.
+ worse, how to handle args to a possibly blocking cont? maybe use some kind of proxy
+ objects? do these primitives need to use a read barrier?? ideally want low overhead...
+
+ at the end of the day, obviously need to use a wrapper function to call the primitive,
+ instead of calling it directly.
+
+ how to stop a thread? suppose mutator would set a member in thread data (need to mutex/atomic
+ that, and be careful about doing that for any shared members), and mutator would need to
+ lock somehow if that is set upon return.
+
+ bottom line, only have to worry about this when calling potentially-blocking primitives.
+ and if one is blocked when collector is active, then need the collector to cooperate
+ instead of the blocked mutator. overally this seems do-able, though there are many details
+ to consider.
+
+- how to share variables between threads?
+ obviously need to use mutexes (on the application side) to handle access.
+ but how to handle the case where an object from one thread is added to
+ a list that belongs to another (IE, queueing an object)? because the
+ other thread's object might be added as a stack object.
+
+ keep in mind referenced obj may be a list or such that contains many other
+ refs to stack objects on another thread
+
+ how can a variable be shared? - cons, vector, set!, define (?), set-car, set-cdr
+ can we detect if there will be a problem?
+ * adding var to something in this thread - can tell that obj is red and not on this stack
+ * modifying list on another thread - if list is on heap, how do we know the 'owning' thread is
+ not this one? we would have no idea
+
+ very concerned about how to make this work
+
+ since we only need a minor GC to put the var in the heap, might be able to add a function to trigger a minor GC. could call this function, then it would be safe to move a var to another thread (I think).
+
+ might also need to expose a function that would determine whether any given object lives on the stack, and which thread it is on (or at least, if it belongs to the current one).
+
+ neither is ideal, but might make the whole thing workable. ideally application code would not need to know about stack vs heap
+
+ this feature might end up being gc-dev7 (possibly the final phase)
+
+ORIGINAL notes migrated here from gc.c:
+/*
+Rough plan for how to implement new GC algorithm. We need to do this in
+phases in order to have any hope of getting everything working. Let's prove
+the algorithm out, then extend support to multiple mutators if everything
+looks good.
+
+PHASE 1 - separation of mutator and collector into separate threads
+
+need to syncronize access (preferably via atomics) for anything shared between the
+collector and mutator threads.
+
+can cooperate be part of a minor gc? in that case, the
+marking could be done as part of allocation
+
+but then what exactly does that mean, to mark gray? because
+objects moved to the heap will be set to mark color at that
+point (until collector thread finishes). but would want
+objects on the heap referenced by them to be traced, so
+I suppose that is the purpose of the gray, to indicate
+those still need to be traced. but need to think this through,
+do we need the markbuffer and last read/write? do those make
+ sense with mta approach (assume so)???
+
+ONLY CONCERN - what happens if an object on the stack
+has a reference to an object on the heap that is collected?
+but how would this happen? collector marks global roots before
+telling mutators to go to async, and once mutators go async
+any allocations will not be collected. also once collectors go
+async they have a chance to markgray, which will include the write
+barrier. so given that, is it still possible for an old heap ref to
+sneak into a stack object during the async phase?
+
+more questions on above point:
+- figure out how/if after cooperation/async, can a stack object pick
+ up a reference to a heap object that will be collected during that GC cycle?
+ need to be able to prevent this somehow...
+
+- need to figure out real world use case(s) where this could happen, to try and
+ figure out how to address this problem
+
+from my understanding of the paper, the write barrier prevents this. consider, at the
+start of async, the mutator's roots, global roots, and anything on the write barrier
+have been marked. any new objects will be allocated as marked. that way, anything the
+mutator could later access is either marked or will be after tracing. the only exception
+is if the mutator changes a reference such that tracing will no longer find an object.
+but the write barrier prevents this - during tracing a heap update causes the old
+object to be marked as well. so it will eventually be traced, and there should be no
+dangling objects after GC completes.
+
+PHASE 2 - multi-threaded mutator (IE, more than one stack thread):
+
+- how does the collector handle stack objects that reference objects from
+ another thread's stack?
+ * minor GC will only relocate that thread's objects, so another thread's would not
+ be moved. however, if another thread references one of the GC'd thread's
+ stack objects, it will now get a forwarding pointer. even worse, what if the
+ other thread is blocked and the reference becomes corrupt due to the stack
+ longjmp? there are major issues with one thread referencing another thread's
+ objects.
+ * had considered adding a stack bit to the object header. if we do this and
+ initialize it during object creation, a thread could in theory detect
+ if an object belongs to another thread. but it might be expensive because
+ a read barrier would have to be used to check the object's stack bit and
+ address (to see if it is on this heap).
+ * alternatively, how would one thread pick up a reference to another one's
+ objects? are there any ways to detect these events and deal with them?
+ it might be possible to detect such a case and allocate the object on the heap,
+ replacing it with a fwd pointer. unfortunately that means we need a read
+ barrier (ick) to handle forwarding pointers in arbitrary places
+ * but does that mean we need a fwd pointer to be live for awhile? do we need
+ a read barrier to get this to work? obviously we want to avoid a read barrier
+ at all costs.
+- what are the real costs of allowing forwarding pointers to exist outside of just
+ minor GC? assume each runtime primitive would need to be updated to handle the
+ case where the obj is a fwd pointer - is it just a matter of each function
+ detecting this and (possibly) calling itself again with the 'real' address?
+ obviously that makes the runtime slower due to more checks, but maybe it is
+ not *so* bad?
+*/
diff --git a/gc.c b/gc.c
new file mode 100644
index 00000000..cf5acd65
--- /dev/null
+++ b/gc.c
@@ -0,0 +1,1321 @@
+/**
+ * Cyclone Scheme
+ * Copyright (c) 2015-2016, Justin Ethier
+ * All rights reserved.
+ *
+ * Heap garbage collector used by the Cyclone runtime for major collections.
+ *
+ * Tracing GC algorithm is based on the one from "Implementing an on-the-fly
+ * garbage collector for Java", by Domani et al.
+ *
+ * The heap implementation (alloc / sweep, etc) is based on code from Chibi Scheme.
+ *
+ * Note there is also a minor GC (in runtime.c) that collects objects allocated
+ * on the stack, based on "Cheney on the MTA" (but without the copying collector).
+ */
+
+#include
+#include
+#include "cyclone/types.h"
+#include
+
+////////////////////
+// Global variables
+
+// Note: will need to use atomics and/or locking to access any
+// variables shared between threads
+static int gc_color_mark = 1; // Black, is swapped during GC
+static int gc_color_clear = 3; // White, is swapped during GC
+// unfortunately this had to be split up; const colors are located in types.h
+
+static int gc_status_col = STATUS_SYNC1;
+static int gc_stage = STAGE_RESTING;
+
+// Does not need sync, only used by collector thread
+static void **mark_stack = NULL;
+static int mark_stack_len = 0;
+static int mark_stack_i = 0;
+
+// Lock to protect the heap from concurrent modifications
+static pthread_mutex_t heap_lock;
+
+// Cached heap statistics
+// Note this assumes a single overall heap "chain". Code would need to
+// be modified to support multiple independent heaps
+static int cached_heap_free_size = 0;
+static int cached_heap_total_size = 0;
+
+// Data for each individual mutator thread
+ck_array_t Cyc_mutators, old_mutators;
+static pthread_mutex_t mutators_lock;
+
+static void my_free(void *p, size_t m, bool d)
+{
+ free(p);
+ return;
+}
+
+static void *my_malloc(size_t b)
+{
+ return malloc(b);
+}
+
+static void *my_realloc(void *r, size_t a, size_t b, bool d)
+{
+ return realloc(r, b);
+}
+
+static struct ck_malloc my_allocator = {
+ .malloc = my_malloc,
+ .free = my_free,
+ .realloc = my_realloc
+};
+
+/////////////
+// Functions
+
+// Perform one-time initialization before mutators can be executed
+void gc_initialize()
+{
+ if (ck_array_init(&Cyc_mutators, CK_ARRAY_MODE_SPMC, &my_allocator, 10) == 0){
+ fprintf(stderr, "Unable to initialize mutator array\n");
+ exit(1);
+ }
+
+ if (ck_array_init(&old_mutators, CK_ARRAY_MODE_SPMC, &my_allocator, 10) == 0){
+ fprintf(stderr, "Unable to initialize mutator array\n");
+ exit(1);
+ }
+
+ // Initialize collector's mark stack
+ mark_stack_len = 128;
+ mark_stack = vpbuffer_realloc(mark_stack, &(mark_stack_len));
+
+ // Here is as good a place as any to do this...
+ if (pthread_mutex_init(&(heap_lock), NULL) != 0) {
+ fprintf(stderr, "Unable to initialize heap_lock mutex\n");
+ exit(1);
+ }
+ if (pthread_mutex_init(&(mutators_lock), NULL) != 0) {
+ fprintf(stderr, "Unable to initialize mutators_lock mutex\n");
+ exit(1);
+ }
+}
+
+// Add data for a new mutator
+void gc_add_mutator(gc_thread_data *thd)
+{
+ pthread_mutex_lock(&mutators_lock);
+ if (ck_array_put_unique(&Cyc_mutators, (void *)thd) < 0) {
+ fprintf(stderr, "Unable to allocate memory for a new thread, exiting\n");
+ exit(1);
+ }
+ ck_array_commit(&Cyc_mutators);
+ pthread_mutex_unlock(&mutators_lock);
+}
+
+// Remove selected mutator from the mutator list.
+// This is done for terminated threads. Note data is queued to be
+// freed, to prevent accidentally freeing it while the collector
+// thread is potentially accessing it.
+void gc_remove_mutator(gc_thread_data *thd)
+{
+ pthread_mutex_lock(&mutators_lock);
+ if (!ck_array_remove(&Cyc_mutators, (void *)thd)) {
+ fprintf(stderr, "Unable to remove thread data, exiting\n");
+ exit(1);
+ }
+ ck_array_commit(&Cyc_mutators);
+ // Place on list of old mutators to cleanup
+ if (ck_array_put_unique(&old_mutators, (void *)thd) < 0) {
+ fprintf(stderr, "Unable to add thread data to GC list, existing\n");
+ exit(1);
+ }
+ ck_array_commit(&old_mutators);
+ pthread_mutex_unlock(&mutators_lock);
+}
+
+void gc_free_old_thread_data()
+{
+ ck_array_iterator_t iterator;
+ gc_thread_data *m;
+ int freed = 0;
+
+ pthread_mutex_lock(&mutators_lock);
+ CK_ARRAY_FOREACH(&old_mutators, &iterator, &m){
+printf("JAE DEBUG - freeing old thread data...");
+ gc_thread_data_free(m);
+ if (!ck_array_remove(&old_mutators, (void *)m)) {
+ fprintf(stderr, "Error removing old mutator data\n");
+ exit(1);
+ }
+ freed = 1;
+printf(" done\n");
+ }
+ if (freed) {
+ ck_array_commit(&old_mutators);
+printf("commited old mutator data deletions\n");
+ }
+ pthread_mutex_unlock(&mutators_lock);
+}
+
+gc_heap *gc_heap_create(size_t size, size_t max_size, size_t chunk_size)
+{
+ gc_free_list *free, *next;
+ gc_heap *h;
+ // TODO: mmap?
+ h = malloc(gc_heap_pad_size(size));
+ if (!h) return NULL;
+ h->size = size;
+ //h->free_size = size;
+ cached_heap_total_size += size;
+ cached_heap_free_size += size;
+ h->chunk_size = chunk_size;
+ h->max_size = max_size;
+ h->data = (char *) gc_heap_align(sizeof(h->data) + (unsigned int)&(h->data));
+ h->next = NULL;
+ free = h->free_list = (gc_free_list *)h->data;
+ next = (gc_free_list *)(((char *) free) + gc_heap_align(gc_free_chunk_size));
+ free->size = 0; // First one is just a dummy record
+ free->next = next;
+ next->size = size - gc_heap_align(gc_free_chunk_size);
+ next->next = NULL;
+#if GC_DEBUG_PRINTFS
+ fprintf(stderr, "DEBUG h->data addr: %p\n", &(h->data));
+ fprintf(stderr, "DEBUG h->data addr: %p\n", h->data);
+ fprintf(stderr, ("heap: %p-%p data: %p-%p size: %d\n"),
+ h, ((char*)h)+gc_heap_pad_size(size), h->data, h->data + size, size);
+ fprintf(stderr, ("first: %p end: %p\n"),
+ (object)gc_heap_first_block(h), (object)gc_heap_end(h));
+ fprintf(stderr, ("free1: %p-%p free2: %p-%p\n"),
+ free, ((char*)free)+free->size, next, ((char*)next)+next->size);
+#endif
+ return h;
+}
+
+// Copy given object into given heap object
+char *gc_copy_obj(object dest, char *obj, gc_thread_data *thd)
+{
+ // NOTE: no additional type checking because this is called from gc_move
+ // which already does that
+
+ switch(type_of(obj)){
+ case cons_tag: {
+ list hp = dest;
+ hp->hdr.mark = thd->gc_alloc_color;
+ type_of(hp) = cons_tag;
+ car(hp) = car(obj);
+ cdr(hp) = cdr(obj);
+ return (char *)hp;
+ }
+ case macro_tag: {
+ macro_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = macro_tag;
+ hp->fn = ((macro) obj)->fn;
+ hp->num_args = ((macro) obj)->num_args;
+ return (char *)hp;
+ }
+ case closure0_tag: {
+ closure0_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = closure0_tag;
+ hp->fn = ((closure0) obj)->fn;
+ hp->num_args = ((closure0) obj)->num_args;
+ return (char *)hp;
+ }
+ case closure1_tag: {
+ closure1_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = closure1_tag;
+ hp->fn = ((closure1) obj)->fn;
+ hp->num_args = ((closure1) obj)->num_args;
+ hp->elt1 = ((closure1) obj)->elt1;
+ return (char *)hp;
+ }
+ case closure2_tag: {
+ closure2_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = closure2_tag;
+ hp->fn = ((closure2) obj)->fn;
+ hp->num_args = ((closure2) obj)->num_args;
+ hp->elt1 = ((closure2) obj)->elt1;
+ hp->elt2 = ((closure2) obj)->elt2;
+ return (char *)hp;
+ }
+ case closure3_tag: {
+ closure3_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = closure3_tag;
+ hp->fn = ((closure3) obj)->fn;
+ hp->num_args = ((closure3) obj)->num_args;
+ hp->elt1 = ((closure3) obj)->elt1;
+ hp->elt2 = ((closure3) obj)->elt2;
+ hp->elt3 = ((closure3) obj)->elt3;
+ return (char *)hp;
+ }
+ case closure4_tag: {
+ closure4_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = closure4_tag;
+ hp->fn = ((closure4) obj)->fn;
+ hp->num_args = ((closure4) obj)->num_args;
+ hp->elt1 = ((closure4) obj)->elt1;
+ hp->elt2 = ((closure4) obj)->elt2;
+ hp->elt3 = ((closure4) obj)->elt3;
+ hp->elt4 = ((closure4) obj)->elt4;
+ return (char *)hp;
+ }
+ case closureN_tag: {
+ int i;
+ closureN_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = closureN_tag;
+ hp->fn = ((closureN) obj)->fn;
+ hp->num_args = ((closureN) obj)->num_args;
+ hp->num_elt = ((closureN) obj)-> num_elt;
+ hp->elts = (object *)(((char *)hp) + sizeof(closureN_type));
+ for (i = 0; i < hp->num_elt; i++) {
+ hp->elts[i] = ((closureN) obj)->elts[i];
+ }
+ return (char *)hp;
+ }
+ case vector_tag: {
+ int i;
+ vector_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = vector_tag;
+ hp->num_elt = ((vector) obj)-> num_elt;
+ hp->elts = (object *)(((char *)hp) + sizeof(vector_type));
+ for (i = 0; i < hp->num_elt; i++) {
+ hp->elts[i] = ((vector) obj)->elts[i];
+ }
+ return (char *)hp;
+ }
+ case string_tag: {
+ char *s;
+ string_type *hp = dest;
+ s = ((char *)hp) + sizeof(string_type);
+ memcpy(s, string_str(obj), string_len(obj) + 1);
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = string_tag;
+ string_len(hp) = string_len(obj);
+ string_str(hp) = s;
+ return (char *)hp;
+ }
+ case integer_tag: {
+ integer_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = integer_tag;
+ hp->value = ((integer_type *) obj)->value;
+ return (char *)hp;
+ }
+ case double_tag: {
+ double_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = double_tag;
+ hp->value = ((double_type *) obj)->value;
+ return (char *)hp;
+ }
+ case port_tag: {
+ port_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = port_tag;
+ hp->fp = ((port_type *) obj)->fp;
+ hp->mode = ((port_type *) obj)->mode;
+ return (char *)hp;
+ }
+ case cvar_tag: {
+ cvar_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = cvar_tag;
+ hp->pvar = ((cvar_type *) obj)->pvar;
+ return (char *)hp;
+ }
+ case mutex_tag: {
+ mutex_type *hp = dest;
+ mark(hp) = thd->gc_alloc_color;
+ type_of(hp) = mutex_tag;
+ // NOTE: don't copy mutex itself, caller will do that (this is a special case)
+ return (char *)hp;
+ }
+ case forward_tag:
+ return (char *)forward(obj);
+ case eof_tag:
+ case primitive_tag:
+ case boolean_tag:
+ case symbol_tag:
+ break;
+ default:
+ fprintf(stderr, "gc_copy_obj: bad tag obj=%p obj.tag=%ld\n",(object) obj, type_of(obj));
+ exit(1);
+ }
+ return (char *)obj;
+}
+
+int gc_grow_heap(gc_heap *h, size_t size, size_t chunk_size)
+{
+ size_t cur_size, new_size;
+ gc_heap *h_last, *h_new;
+ pthread_mutex_lock(&heap_lock);
+ h_last = gc_heap_last(h);
+ cur_size = h_last->size;
+ // JAE - For now, just add a new page
+ new_size = cur_size; //gc_heap_align(((cur_size > size) ? cur_size : size) * 2);
+ h_new = gc_heap_create(new_size, h_last->max_size, chunk_size);
+ h_last->next = h_new;
+ pthread_mutex_unlock(&heap_lock);
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "DEBUG - grew heap\n");
+#endif
+ return (h_new != NULL);
+}
+
+void *gc_try_alloc(gc_heap *h, size_t size, char *obj, gc_thread_data *thd)
+{
+ gc_free_list *f1, *f2, *f3;
+ pthread_mutex_lock(&heap_lock);
+ for (; h; h = h->next) { // All heaps
+ // TODO: chunk size (ignoring for now)
+
+ for (f1 = h->free_list, f2 = f1->next; f2; f1 = f2, f2 = f2->next) { // all free in this heap
+ if (f2->size >= size) { // Big enough for request
+ // TODO: take whole chunk or divide up f2 (using f3)?
+ if (f2->size >= (size + gc_heap_align(1) /* min obj size */)) {
+ f3 = (gc_free_list *) (((char *)f2) + size);
+ f3->size = f2->size - size;
+ f3->next = f2->next;
+ f1->next = f3;
+ } else { /* Take the whole chunk */
+ f1->next = f2->next;
+ }
+ // Copy object into heap now to avoid any uninitialized memory issues
+ gc_copy_obj(f2, obj, thd);
+ //h->free_size -= gc_allocated_bytes(obj, NULL, NULL);
+ cached_heap_free_size -= gc_allocated_bytes(obj, NULL, NULL);
+ pthread_mutex_unlock(&heap_lock);
+ return f2;
+ }
+ }
+ }
+ pthread_mutex_unlock(&heap_lock);
+ return NULL;
+}
+
+void *gc_alloc(gc_heap *h, size_t size, char *obj, gc_thread_data *thd, int *heap_grown)
+{
+ void *result = NULL;
+ size_t max_freed = 0, sum_freed = 0, total_size;
+ // TODO: check return value, if null (could not alloc) then
+ // run a collection and check how much free space there is. if less
+ // the allowed ratio, try growing heap.
+ // then try realloc. if cannot alloc now, then throw out of memory error
+ size = gc_heap_align(size);
+ result = gc_try_alloc(h, size, obj, thd);
+ if (!result) {
+ // A vanilla mark&sweep collector would collect now, but unfortunately
+ // we can't do that because we have to go through multiple stages, some
+ // of which are asynchronous. So... no choice but to grow the heap.
+ gc_grow_heap(h, size, 0);
+ *heap_grown = 1;
+ result = gc_try_alloc(h, size, obj, thd);
+ if (!result) {
+ fprintf(stderr, "out of memory error allocating %d bytes\n", size);
+ exit(1); // could throw error, but OOM is a major issue, so...
+ }
+ }
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "alloc %p size = %d, obj=%p, tag=%ld, mark=%d\n", result, size, obj, type_of(obj), mark(((object)result)));
+ // Debug check, should no longer be necessary
+ //if (is_value_type(result)) {
+ // printf("Invalid allocated address - is a value type %p\n", result);
+ //}
+#endif
+ return result;
+}
+
+size_t gc_allocated_bytes(object obj, gc_free_list *q, gc_free_list *r)
+{
+ tag_type t;
+#if GC_SAFETY_CHECKS
+ if (is_value_type(obj)) {
+ fprintf(stderr,
+ "gc_allocated_bytes - passed value type %p q=[%p, %d] r=[%p, %d]\n",
+ obj, q, q->size, r, r->size);
+ exit(1);
+ }
+#endif
+ t = type_of(obj);
+ if (t == cons_tag) return gc_heap_align(sizeof(cons_type));
+ if (t == macro_tag) return gc_heap_align(sizeof(macro_type));
+ if (t == closure0_tag) return gc_heap_align(sizeof(closure0_type));
+ if (t == closure1_tag) return gc_heap_align(sizeof(closure1_type));
+ if (t == closure2_tag) return gc_heap_align(sizeof(closure2_type));
+ if (t == closure3_tag) return gc_heap_align(sizeof(closure3_type));
+ if (t == closure4_tag) return gc_heap_align(sizeof(closure4_type));
+ if (t == closureN_tag){
+ return gc_heap_align(sizeof(closureN_type) + sizeof(object) * ((closureN_type *)obj)->num_elt);
+ }
+ if (t == vector_tag){
+ return gc_heap_align(sizeof(vector_type) + sizeof(object) * ((vector_type *)obj)->num_elt);
+ }
+ if (t == string_tag){
+ return gc_heap_align(sizeof(string_type) + string_len(obj) + 1);
+ }
+ if (t == integer_tag) return gc_heap_align(sizeof(integer_type));
+ if (t == double_tag) return gc_heap_align(sizeof(double_type));
+ if (t == port_tag) return gc_heap_align(sizeof(port_type));
+ if (t == cvar_tag) return gc_heap_align(sizeof(cvar_type));
+ if (t == mutex_tag) return gc_heap_align(sizeof(mutex_type));
+
+ fprintf(stderr, "gc_allocated_bytes: unexpected object %p of type %ld\n", obj, t);
+ exit(1);
+ return 0;
+}
+
+gc_heap *gc_heap_last(gc_heap *h)
+{
+ while (h->next)
+ h = h->next;
+ return h;
+}
+
+size_t gc_heap_total_size(gc_heap *h)
+{
+ size_t total_size = 0;
+ pthread_mutex_lock(&heap_lock);
+ while(h) {
+ total_size += h->size;
+ h = h->next;
+ }
+ pthread_mutex_unlock(&heap_lock);
+ return total_size;
+}
+
+//size_t gc_heap_total_free_size(gc_heap *h)
+//{
+// size_t total_size = 0;
+// pthread_mutex_lock(&heap_lock);
+// while(h) {
+// total_size += h->free_size;
+// h = h->next;
+// }
+// pthread_mutex_unlock(&heap_lock);
+// return total_size;
+//}
+
+size_t gc_sweep(gc_heap *h, size_t *sum_freed_ptr)
+{
+ size_t freed, max_freed=0, heap_freed = 0, sum_freed=0, size;
+ object p, end;
+ gc_free_list *q, *r, *s;
+
+ //
+ // Lock the heap to prevent issues with allocations during sweep
+ // It sucks to have to use a coarse-grained lock like this, but let's
+ // be safe and prevent threading issues right now. Once the new GC
+ // works we can go back and try to speed things up (if possible)
+ // by using more fine-grained locking. Can also profile to see
+ // how much time is even spent sweeping
+ //
+ pthread_mutex_lock(&heap_lock);
+ for (; h; h = h->next) { // All heaps
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "sweep heap %p, size = %d\n", h, h->size);
+#endif
+ p = gc_heap_first_block(h);
+ q = h->free_list;
+ end = gc_heap_end(h);
+ while (p < end) {
+ // find preceding/succeeding free list pointers for p
+ for (r = q->next; r && ((char *)r < (char *)p); q=r, r=r->next);
+
+ if ((char *)r == (char *)p) { // this is a free block, skip it
+ p = (object) (((char *)p) + r->size);
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "skip free block %p size = %d\n", p, r->size);
+#endif
+ continue;
+ }
+ size = gc_heap_align(gc_allocated_bytes(p, q, r));
+
+#if GC_SAFETY_CHECKS
+ if (!is_object_type(p)) {
+ fprintf(stderr, "sweep: invalid object at %p", p);
+ exit(1);
+ }
+ if ((char *)q + q->size > (char *)p) {
+ fprintf(stderr, "bad size at %p < %p + %u", p, q, q->size);
+ exit(1);
+ }
+ if (r && ((char *)p) + size > (char *)r) {
+ fprintf(stderr, "sweep: bad size at %p + %d > %p", p, size, r);
+ exit(1);
+ }
+#endif
+
+ if (mark(p) == gc_color_clear) {
+#if GC_DEBUG_VERBOSE
+ fprintf(stderr, "sweep is freeing unmarked obj: %p with tag %ld\n", p, type_of(p));
+#endif
+ mark(p) = gc_color_blue; // Needed?
+ if (type_of(p) == mutex_tag) {
+#if GC_DEBUG_VERBOSE
+ fprintf(stderr, "pthread_mutex_destroy from sweep\n");
+#endif
+ if (pthread_mutex_destroy(&(((mutex)p)->lock)) != 0) {
+ fprintf(stderr, "Error destroying mutex\n");
+ exit(1);
+ }
+ }
+ // free p
+ heap_freed += size;
+ if (((((char *)q) + q->size) == (char *)p) && (q != h->free_list)) {
+ /* merge q with p */
+ if (r && r->size && ((((char *)p)+size) == (char *)r)) {
+ // ... and with r
+ q->next = r->next;
+ freed = q->size + size + r->size;
+ p = (object) (((char *)p) + size + r->size);
+ } else {
+ freed = q->size + size;
+ p = (object) (((char *)p) + size);
+ }
+ q->size = freed;
+ } else {
+ s = (gc_free_list *)p;
+ if (r && r->size && ((((char *)p) + size) == (char *)r)) {
+ // merge p with r
+ s->size = size + r->size;
+ s->next = r->next;
+ q->next = s;
+ freed = size + r->size;
+ } else {
+ s->size = size;
+ s->next = r;
+ q->next = s;
+ freed = size;
+ }
+ p = (object) (((char *)p) + freed);
+ }
+ if (freed > max_freed)
+ max_freed = freed;
+ } else {
+//#if GC_DEBUG_VERBOSE
+// fprintf(stderr, "sweep: object is marked %p\n", p);
+//#endif
+ p = (object)(((char *)p) + size);
+ }
+ }
+ //h->free_size += heap_freed;
+ cached_heap_free_size += heap_freed;
+ sum_freed += heap_freed;
+ heap_freed = 0;
+ }
+ pthread_mutex_unlock(&heap_lock);
+ if (sum_freed_ptr) *sum_freed_ptr = sum_freed;
+ return max_freed;
+}
+
+void gc_thr_grow_move_buffer(gc_thread_data *d)
+{
+ if (!d) return;
+
+ if (d->moveBufLen == 0) { // Special case
+ d->moveBufLen = 128;
+ d->moveBuf = NULL;
+ } else {
+ d->moveBufLen *= 2;
+ }
+
+ d->moveBuf = realloc(d->moveBuf, d->moveBufLen * sizeof(void *));
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "grew moveBuffer, len = %d\n", d->moveBufLen);
+#endif
+}
+
+void gc_thr_add_to_move_buffer(gc_thread_data *d, int *alloci, object obj)
+{
+ if (*alloci == d->moveBufLen) {
+ gc_thr_grow_move_buffer(d);
+ }
+
+ d->moveBuf[*alloci] = obj;
+ (*alloci)++;
+}
+
+// Generic buffer functions
+void **vpbuffer_realloc(void **buf, int *len)
+{
+ return realloc(buf, (*len) * sizeof(void *));
+}
+
+void **vpbuffer_add(void **buf, int *len, int i, void *obj)
+{
+ if (i == *len) {
+ *len *= 2;
+ buf = vpbuffer_realloc(buf, len);
+ }
+ buf[i] = obj;
+ return buf;
+}
+
+void vpbuffer_free(void **buf)
+{
+ free(buf);
+}
+// END heap definitions
+
+// Tri-color GC section
+
+/////////////////////////////////////////////
+// GC functions called by the Mutator threads
+
+/**
+ * Determine if object lives on the thread's stack
+ */
+int gc_is_stack_obj(gc_thread_data *thd, object obj)
+{
+ char tmp;
+ object low_limit = &tmp;
+ object high_limit = thd->stack_start;
+ return (check_overflow(low_limit, obj) &&
+ check_overflow(obj, high_limit));
+}
+
+/**
+ * Write barrier for updates to heap-allocated objects
+ * The key for this barrier is to identify stack objects that contain
+ * heap references, so they can be marked to avoid collection.
+*/
+void gc_mut_update(gc_thread_data *thd, object old_obj, object value)
+{
+ int status = ck_pr_load_int(&gc_status_col),
+ stage = ck_pr_load_int(&gc_stage);
+ if (ck_pr_load_int(&(thd->gc_status)) != STATUS_ASYNC) {
+ pthread_mutex_lock(&(thd->lock));
+ gc_mark_gray(thd, old_obj);
+ if (gc_is_stack_obj(thd, value)) {
+ // Set object to be marked after moved to heap by next GC.
+ // This avoids having to recursively examine the stack now,
+ // which we have to do anyway during minor GC.
+ grayed(value) = 1;
+ } else {
+ // Value is on the heap, mark gray right now
+ gc_mark_gray(thd, value);
+ }
+ pthread_mutex_unlock(&(thd->lock));
+ } else if (stage == STAGE_TRACING) {
+//fprintf(stderr, "DEBUG - GC async tracing marking heap obj %p ", old_obj);
+//Cyc_display(old_obj, stderr);
+//fprintf(stderr, "\n");
+ pthread_mutex_lock(&(thd->lock));
+ gc_mark_gray(thd, old_obj);
+ pthread_mutex_unlock(&(thd->lock));
+#if GC_DEBUG_VERBOSE
+ if (is_object_type(old_obj) && mark(old_obj) == gc_color_clear) {
+ fprintf(stderr, "added to mark buffer (trace) from write barrier %p:mark %d:", old_obj, mark(old_obj));
+ Cyc_display(old_obj, stderr);
+ fprintf(stderr, "\n");
+ }
+#endif
+ }
+}
+
+void gc_mut_cooperate(gc_thread_data *thd, int buf_len)
+{
+ int i, status_c, status_m;
+#if GC_DEBUG_VERBOSE
+ int debug_print = 0;
+#endif
+
+ // Handle any pending marks from write barrier
+ pthread_mutex_lock(&(thd->lock));
+ thd->last_write += thd->pending_writes;
+ thd->pending_writes = 0;
+ pthread_mutex_unlock(&(thd->lock));
+
+ // I think below is thread safe, but this code is tricky.
+ // Worst case should be that some work is done twice if there is
+ // a race condition
+ //
+ // TODO: should use an atomic comparison here
+ status_c = ck_pr_load_int(&gc_status_col);
+ status_m = ck_pr_load_int(&(thd->gc_status));
+ if (status_m != status_c) {
+ ck_pr_cas_int(&(thd->gc_status), status_m, status_c);
+ if (status_m == STATUS_ASYNC) {
+ // Async is done, so clean up old mark data from the last collection
+ pthread_mutex_lock(&(thd->lock));
+ thd->last_write = 0;
+ thd->last_read = 0;
+ thd->pending_writes = 0;
+ pthread_mutex_unlock(&(thd->lock));
+ }
+ else if (status_m == STATUS_SYNC2) {
+#if GC_DEBUG_VERBOSE
+ debug_print = 1;
+#endif
+ // Mark thread "roots":
+ // Begin my marking current continuation, which may have already
+ // been on the heap prior to latest minor GC
+ pthread_mutex_lock(&(thd->lock));
+ gc_mark_gray(thd, thd->gc_cont);
+ for (i = 0; i < thd->gc_num_args; i++) {
+ gc_mark_gray(thd, thd->gc_args[i]);
+ }
+ // Also, mark everything the collector moved to the heap
+ for (i = 0; i < buf_len; i++) {
+ gc_mark_gray(thd, thd->moveBuf[i]);
+ }
+ pthread_mutex_unlock(&(thd->lock));
+ thd->gc_alloc_color = ck_pr_load_int(&gc_color_mark);
+ }
+ }
+#if GC_DEBUG_VERBOSE
+ if (debug_print) {
+ fprintf(stderr, "coop mark gc_cont %p\n", thd->gc_cont);
+ for (i = 0; i < thd->gc_num_args; i++) {
+ fprintf(stderr, "coop mark gc_args[%d] %p\n", i, thd->gc_args[i]);
+ }
+ for (i = 0; i < buf_len; i++) {
+ fprintf(stderr, "coop mark from move buf %i %p\n", i, thd->moveBuf[i]);
+ }
+ }
+#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 &&
+ (cached_heap_free_size < (cached_heap_total_size * 0.50))){
+#if GC_DEBUG_TRACE
+ fprintf(stdout, "Less than 50%% of the heap is free, initiating collector\n");
+#endif
+ ck_pr_cas_int(&gc_stage, STAGE_RESTING, STAGE_CLEAR_OR_MARKING);
+
+ }
+}
+
+/////////////////////////////////////////////
+// Collector functions
+
+/**
+ * Mark the given object gray if it is on the heap.
+ * Note marking is done implicitly by placing it in a buffer,
+ * to avoid repeated re-scanning.
+ *
+ * This function must be executed once the thread lock has been acquired.
+ */
+void gc_mark_gray(gc_thread_data *thd, object obj)
+{
+ // From what I can tell, no other thread would be modifying
+ // either object type or mark. Both should be stable once the object is placed
+ // into the heap, with the collector being the only thread that changes marks.
+ if (is_object_type(obj) && mark(obj) == gc_color_clear) { // 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
+// algorithm more efficient. So this code (and the corresponding collector
+// trace code) should be converted at some point.
+ thd->mark_buffer = vpbuffer_add(thd->mark_buffer,
+ &(thd->mark_buffer_len),
+ thd->last_write,
+ obj);
+ (thd->last_write)++; // Already locked, just do it...
+ }
+}
+
+void gc_mark_gray2(gc_thread_data *thd, object obj)
+{
+ if (is_object_type(obj) && mark(obj) == gc_color_clear) {
+ thd->mark_buffer = vpbuffer_add(thd->mark_buffer,
+ &(thd->mark_buffer_len),
+ (thd->last_write + thd->pending_writes),
+ obj);
+ thd->pending_writes++;
+ }
+}
+
+void gc_collector_trace()
+{
+ ck_array_iterator_t iterator;
+ gc_thread_data *m;
+ int clean = 0;
+ while (!clean) {
+ clean = 1;
+
+ CK_ARRAY_FOREACH(&Cyc_mutators, &iterator, &m){
+// TODO: ideally, want to use a lock-free data structure to prevent
+// having to use a mutex here. see corresponding code in gc_mark_gray
+ pthread_mutex_lock(&(m->lock));
+ while (m->last_read < m->last_write) {
+ clean = 0;
+#if GC_DEBUG_VERBOSE
+ fprintf(stderr, "gc_mark_black mark buffer %p, last_read = %d last_write = %d\n",
+ (m->mark_buffer)[m->last_read],
+ m->last_read, m->last_write);
+#endif
+ gc_mark_black((m->mark_buffer)[m->last_read]);
+ gc_empty_collector_stack();
+ (m->last_read)++; // Inc here to prevent off-by-one error
+ }
+ pthread_mutex_unlock(&(m->lock));
+
+ // Try checking the condition once more after giving the
+ // mutator a chance to respond, to prevent exiting early.
+ // This is experimental, not sure if it is necessary
+ if (clean) {
+ pthread_mutex_lock(&(m->lock));
+ if (m->last_read < m->last_write) {
+ fprintf(stderr, "JAE DEBUG - might have exited trace early\n");
+ clean = 0;
+ }
+ else if (m->pending_writes) {
+ clean = 0;
+ }
+ pthread_mutex_unlock(&(m->lock));
+ }
+ }
+ }
+}
+
+// TODO: seriously consider changing the mark() macro to color(),
+// and sync up the header variable. that would make all of this code
+// bit clearer...
+
+void gc_mark_black(object obj)
+{
+ // TODO: is sync required to get colors? probably not on the collector
+ // thread (at least) since colors are only changed once during the clear
+ // phase and before the first handshake.
+ int markColor = ck_pr_load_int(&gc_color_mark);
+ if (is_object_type(obj) && mark(obj) != markColor) {
+ // Gray any child objects
+ // Note we probably should use some form of atomics/synchronization
+ // for cons and vector types, as these pointers could change.
+ switch(type_of(obj)) {
+ case cons_tag: {
+ 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)->elt1);
+ break;
+ case closure2_tag:
+ gc_collector_mark_gray(obj, ((closure2) obj)->elt1);
+ gc_collector_mark_gray(obj, ((closure2) obj)->elt2);
+ case closure3_tag:
+ gc_collector_mark_gray(obj, ((closure3) obj)->elt1);
+ gc_collector_mark_gray(obj, ((closure3) obj)->elt2);
+ gc_collector_mark_gray(obj, ((closure3) obj)->elt3);
+ case closure4_tag:
+ gc_collector_mark_gray(obj, ((closure4) obj)->elt1);
+ gc_collector_mark_gray(obj, ((closure4) obj)->elt2);
+ gc_collector_mark_gray(obj, ((closure4) obj)->elt3);
+ gc_collector_mark_gray(obj, ((closure4) obj)->elt4);
+ break;
+ case closureN_tag: {
+ int i, n = ((closureN) obj)->num_elt;
+ for (i = 0; i < n; i++) {
+ gc_collector_mark_gray(obj, ((closureN) obj)->elts[i]);
+ }
+ break;
+ }
+ case vector_tag: {
+ int i, n = ((vector) obj)->num_elt;
+ for (i = 0; i < n; i++) {
+ gc_collector_mark_gray(obj, ((vector) obj)->elts[i]);
+ }
+ break;
+ }
+ case cvar_tag: {
+ cvar_type *c = (cvar_type *)obj;
+ object pvar = *(c->pvar);
+ if (pvar) {
+ gc_collector_mark_gray(obj, pvar);
+ }
+ break;
+ }
+ default:
+ break;
+ }
+ if (mark(obj) != gc_color_red) {
+ // Only blacken objects on the heap
+ mark(obj) = markColor;
+ }
+#if GC_DEBUG_VERBOSE
+ if (mark(obj) != gc_color_red) {
+ fprintf(stderr, "marked %p %d\n", obj, markColor);
+ } else {
+ fprintf(stderr, "not marking stack obj %p %d\n", obj, markColor);
+ }
+#endif
+ }
+}
+
+void gc_collector_mark_gray(object parent, object obj)
+{
+ // "Color" objects gray by adding them to the mark stack for further processing.
+ //
+ // Note that stack objects are always colored red during creation, so
+ // they should never be added to the mark stack. Which would be bad because it
+ // could lead to stack corruption.
+ if (is_object_type(obj) && mark(obj) == gc_color_clear) {
+ mark_stack = vpbuffer_add(mark_stack, &mark_stack_len, mark_stack_i++, obj);
+#if GC_DEBUG_VERBOSE
+ fprintf(stderr, "mark gray parent = %p (%ld) obj = %p\n", parent, type_of(parent), obj);
+#endif
+ }
+}
+
+void gc_empty_collector_stack()
+{
+ // Mark stack is only used by the collector thread, so no sync needed
+ while (mark_stack_i > 0) { // not empty
+ mark_stack_i--;
+//#if GC_DEBUG_VERBOSE
+// fprintf(stderr, "gc_mark_black mark stack %p \n",
+// mark_stack[mark_stack_i]);
+//#endif
+ gc_mark_black(mark_stack[mark_stack_i]);
+ }
+}
+
+void gc_handshake(gc_status_type s)
+{
+ gc_post_handshake(s);
+ gc_wait_handshake();
+}
+
+void gc_post_handshake(gc_status_type s)
+{
+ int status = ck_pr_load_int(&gc_status_col);
+ while (!ck_pr_cas_int(&gc_status_col, status, s)){}
+}
+
+void gc_wait_handshake()
+{
+ ck_array_iterator_t iterator;
+ gc_thread_data *m;
+ int statusm, statusc, thread_status, i, buf_len;
+ struct timespec tim;
+ tim.tv_sec = 0;
+ tim.tv_nsec = 1000000; // 1 millisecond
+
+ CK_ARRAY_FOREACH(&Cyc_mutators, &iterator, &m) {
+ while (1) {
+ // TODO: use an atomic comparison
+ statusc = ck_pr_load_int(&gc_status_col);
+ statusm = ck_pr_load_int(&(m->gc_status));
+ if (statusc == statusm) {
+ // Handshake succeeded, check next mutator
+ break;
+ }
+
+ thread_status = ck_pr_load_int((int *)&(m->thread_state));
+ if (thread_status == CYC_THREAD_STATE_BLOCKED ||
+ thread_status == CYC_THREAD_STATE_BLOCKED_COOPERATING) {
+ if (statusm == STATUS_ASYNC) { // Prev state
+ ck_pr_cas_int(&(m->gc_status), statusm, statusc);
+ // Async is done, so clean up old mark data from the last collection
+ pthread_mutex_lock(&(m->lock));
+ m->last_write = 0;
+ m->last_read = 0;
+ m->pending_writes = 0;
+ pthread_mutex_unlock(&(m->lock));
+ }else if (statusm == STATUS_SYNC1) {
+ ck_pr_cas_int(&(m->gc_status), statusm, statusc);
+ } else if (statusm == STATUS_SYNC2) {
+printf("DEBUG - is mutator still blocked?\n");
+ // Check again, if thread is still blocked we need to cooperate
+ if (ck_pr_cas_int((int *)&(m->thread_state),
+ CYC_THREAD_STATE_BLOCKED,
+ CYC_THREAD_STATE_BLOCKED_COOPERATING)
+ ||
+ ck_pr_cas_int((int *)&(m->thread_state),
+ CYC_THREAD_STATE_BLOCKED_COOPERATING,
+ CYC_THREAD_STATE_BLOCKED_COOPERATING)
+ ) {
+printf("DEBUG - update mutator GC status\n");
+ ck_pr_cas_int(&(m->gc_status), statusm, statusc);
+ pthread_mutex_lock(&(m->lock));
+printf("DEBUG - collector is cooperating for blocked mutator\n");
+ buf_len = gc_minor(m, m->stack_limit, m->stack_start, m->gc_cont, NULL, 0);
+ // Mark thread "roots", based on code from mutator's cooperator
+ gc_mark_gray(m, m->gc_cont);
+ //for (i = 0; i < m->gc_num_args; i++) {
+ // gc_mark_gray(m, m->gc_args[i]);
+ //}
+ // Also, mark everything the collector moved to the heap
+ for (i = 0; i < buf_len; i++) {
+ gc_mark_gray(m, m->moveBuf[i]);
+ }
+ m->gc_alloc_color = ck_pr_load_int(&gc_color_mark);
+ pthread_mutex_unlock(&(m->lock));
+ }
+ }
+ } else if (thread_status == CYC_THREAD_STATE_TERMINATED) {
+ // Thread is no longer running
+ break;
+ }
+
+ // At least for now, just give up quantum and come back to
+ // this quickly to test again. This probably could be more
+ // efficient.
+ nanosleep(&tim, NULL);
+ }
+ }
+}
+
+/////////////////////////////////////////////
+// GC Collection cycle
+
+void debug_dump_globals();
+
+// Main collector function
+void gc_collector()
+{
+ int old_clear, old_mark;
+ size_t freed = 0, max_freed = 0, total_size, total_free;
+#if GC_DEBUG_TRACE
+ time_t sweep_start = time(NULL);
+#endif
+ //clear :
+ ck_pr_cas_int(&gc_stage, STAGE_RESTING, STAGE_CLEAR_OR_MARKING);
+ // exchange values of markColor and clearColor
+ old_clear = ck_pr_load_int(&gc_color_clear);
+ old_mark = ck_pr_load_int(&gc_color_mark);
+ while(!ck_pr_cas_int(&gc_color_clear, old_clear, old_mark)){}
+ while(!ck_pr_cas_int(&gc_color_mark, old_mark, old_clear)){}
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "DEBUG - swap clear %d / mark %d\n", gc_color_clear, gc_color_mark);
+#endif
+ gc_handshake(STATUS_SYNC1);
+#if GC_DEBUG_TRACE
+fprintf(stderr, "DEBUG - after handshake sync 1\n");
+#endif
+ //mark :
+ gc_handshake(STATUS_SYNC2);
+#if GC_DEBUG_TRACE
+fprintf(stderr, "DEBUG - after handshake sync 2\n");
+#endif
+ ck_pr_cas_int(&gc_stage, STAGE_CLEAR_OR_MARKING, STAGE_TRACING);
+ gc_post_handshake(STATUS_ASYNC);
+#if GC_DEBUG_TRACE
+fprintf(stderr, "DEBUG - after post_handshake async\n");
+#endif
+ gc_mark_globals();
+ gc_wait_handshake();
+#if GC_DEBUG_TRACE
+fprintf(stderr, "DEBUG - after wait_handshake async\n");
+#endif
+ //trace :
+ gc_collector_trace();
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "DEBUG - after trace\n");
+ //debug_dump_globals();
+#endif
+ ck_pr_cas_int(&gc_stage, STAGE_TRACING, STAGE_SWEEPING);
+ //
+ //sweep :
+ max_freed = gc_sweep(gc_get_heap(), &freed);
+ total_size = cached_heap_total_size; //gc_heap_total_size(gc_get_heap());
+ total_free = cached_heap_free_size; //gc_heap_total_free_size(gc_get_heap());
+
+ if (total_free < (total_size * 0.10)) {
+#if GC_DEBUG_TRACE
+ fprintf(stdout, "Less than 10%% of the heap is free, growing it\n",
+ total_free, total_size);
+#endif
+ gc_grow_heap(gc_get_heap(), 0, 0);
+ }
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "sweep done, total_size = %d, total_free = %d, freed = %d, max_freed = %d, elapsed = %ld\n",
+ total_size, total_free,
+ freed, max_freed, time(NULL) - sweep_start);
+#endif
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "cleaning up any old thread data\n");
+#endif
+ gc_free_old_thread_data();
+ // Idle the GC thread
+ ck_pr_cas_int(&gc_stage, STAGE_SWEEPING, STAGE_RESTING);
+}
+
+void *collector_main(void *arg)
+{
+ int stage;
+ struct timespec tim;
+ tim.tv_sec = 0;
+//JAE TODO: this is still not good enough, seems memory grows still grows fast with this.
+//alternatively, may want to consider shrinking the heap if possible after a collection, if it is
+//sparse enough (would be difficult to do without relocations, though
+ tim.tv_nsec = 100 * NANOSECONDS_PER_MILLISECOND;
+ while (1) {
+ stage = ck_pr_load_int(&gc_stage);
+ if (stage != STAGE_RESTING) {
+ gc_collector();
+ }
+ nanosleep(&tim, NULL);
+ }
+ return NULL;
+}
+
+static pthread_t collector_thread;
+
+void gc_start_collector()
+{
+ if (pthread_create(&collector_thread, NULL, collector_main, &collector_thread)) {
+ fprintf(stderr, "Error creating collector thread\n");
+ exit(1);
+ }
+}
+
+/////////////////////////////////////////////
+// END tri-color marking section
+/////////////////////////////////////////////
+
+
+// Initialize runtime data structures for a thread.
+// Must be called on the target thread itself during startup,
+// to verify stack limits are setup correctly.
+void gc_thread_data_init(gc_thread_data *thd, int mut_num, char *stack_base, long stack_size)
+{
+ char stack_ref;
+ thd->stack_start = stack_base;
+#if STACK_GROWS_DOWNWARD
+ thd->stack_limit = stack_base - stack_size;
+#else
+ thd->stack_limit = stack_base + stack_size;
+#endif
+ if (check_overflow(stack_base, &stack_ref)){
+ fprintf(stderr,
+ "Error: recompile with STACK_GROWS_DOWNWARD set to %d\n",
+ (1 - STACK_GROWS_DOWNWARD));
+ exit(1);
+ }
+ thd->stack_traces = calloc(MAX_STACK_TRACES, sizeof(char *));
+ thd->stack_trace_idx = 0;
+ thd->stack_prev_frame = NULL;
+ thd->mutations = NULL;
+// thd->thread = NULL;
+ thd->thread_state = CYC_THREAD_STATE_NEW;
+ //thd->mutator_num = mut_num;
+ thd->jmp_start = malloc(sizeof(jmp_buf));
+ thd->gc_args = malloc(sizeof(object) * NUM_GC_ANS);
+ thd->gc_num_args = 0;
+ thd->moveBufLen = 0;
+ gc_thr_grow_move_buffer(thd);
+ thd->gc_alloc_color = ck_pr_load_int(&gc_color_clear);
+ thd->gc_status = ck_pr_load_int(&gc_status_col);
+ thd->last_write = 0;
+ thd->last_read = 0;
+ thd->mark_buffer_len = 128;
+ thd->mark_buffer = vpbuffer_realloc(thd->mark_buffer, &(thd->mark_buffer_len));
+ if (pthread_mutex_init(&(thd->lock), NULL) != 0) {
+ fprintf(stderr, "Unable to initialize thread mutex\n");
+ exit(1);
+ }
+}
+
+void gc_thread_data_free(gc_thread_data *thd)
+{
+ if (thd) {
+ if (pthread_mutex_destroy(&thd->lock) != 0) {
+ // TODO: can only destroy the lock if it is unlocked. need to make sure we
+ // can guarantee that is the case prior to making this call
+ // On the other hand, can we just use sleep and a loop to retry??
+ fprintf(stderr, "Thread mutex is locked, unable to free\n");
+ exit(1);
+ }
+ if (thd->jmp_start) free(thd->jmp_start);
+ if (thd->gc_args) free(thd->gc_args);
+ if (thd->moveBuf) free(thd->moveBuf);
+ if (thd->mark_buffer) free(thd->mark_buffer);
+ if (thd->stack_traces) free(thd->stack_traces);
+ if (thd->mutations) {
+ clear_mutations(thd);
+ }
+ free(thd);
+ }
+}
+
+void gc_mutator_thread_blocked(gc_thread_data *thd, object cont)
+{
+ if(!ck_pr_cas_int((int *)&(thd->thread_state),
+ CYC_THREAD_STATE_RUNNABLE,
+ CYC_THREAD_STATE_BLOCKED)){
+ fprintf(stderr, "Unable to change thread from runnable to blocked. status = %d\n", thd->thread_state);
+ exit(1);
+ }
+ thd->gc_cont = cont;
+ thd->gc_num_args = 0; // Will be set later, after collection
+}
+
+void gc_mutator_thread_runnable(gc_thread_data *thd, object result)
+{
+ // Transition from blocked back to runnable using CAS.
+ // If we are unable to transition back, assume collector
+ // has cooperated on behalf of this mutator thread.
+ if (!ck_pr_cas_int((int *)&(thd->thread_state),
+ CYC_THREAD_STATE_BLOCKED,
+ CYC_THREAD_STATE_RUNNABLE)){
+printf("DEBUG - Collector cooperated, wait for it to finish. status is %d\n", thd->thread_state);
+ // wait for the collector to finish
+ pthread_mutex_lock(&(thd->lock));
+ pthread_mutex_unlock(&(thd->lock));
+ // update thread status
+ while(!ck_pr_cas_int((int *)&(thd->thread_state),
+ CYC_THREAD_STATE_BLOCKED_COOPERATING,
+ CYC_THREAD_STATE_RUNNABLE)){}
+ // transport result to heap, if necessary (IE, is not a value type)
+ if (is_object_type(result)) {
+ // TODO: need to move object to heap
+ // TODO: also, then need to gc_mark_gray heap obj
+ fprintf(stderr, "Unhandled object type result, TODO: implement\n");
+ exit(1);
+ }
+ // Setup value to send to continuation
+ thd->gc_args[0] = result;
+ thd->gc_num_args = 1;
+ // Whoa.
+printf("DEBUG - Call into gc_cont after collector coop\n");
+ longjmp(*(thd->jmp_start), 1);
+ } else {
+ // Collector didn't do anything; make a normal continuation call
+ (((closure)(thd->gc_cont))->fn)(thd, 1, thd->gc_cont, result);
+ }
+}
+
+//// Unit testing:
+//int main(int argc, char **argv) {
+// int a = 1, b = 2, c = 3, i;
+// void **buf = NULL;
+// int size = 1;
+//
+// buf = vpbuffer_realloc(buf, &size);
+// printf("buf = %p, size = %d\n", buf, size);
+// buf = vpbuffer_add(buf, &size, 0, &a);
+// printf("buf = %p, size = %d\n", buf, size);
+// buf = vpbuffer_add(buf, &size, 1, &b);
+// printf("buf = %p, size = %d\n", buf, size);
+// buf = vpbuffer_add(buf, &size, 2, &c);
+// printf("buf = %p, size = %d\n", buf, size);
+// buf = vpbuffer_add(buf, &size, 3, &a);
+// printf("buf = %p, size = %d\n", buf, size);
+// buf = vpbuffer_add(buf, &size, 4, &b);
+// printf("buf = %p, size = %d\n", buf, size);
+// for (i = 5; i < 20; i++) {
+// buf = vpbuffer_add(buf, &size, i, &c);
+// }
+//
+// for (i = 0; i < 20; i++){
+// printf("%d\n", *((int *) buf[i]));
+// }
+// vpbuffer_free(buf);
+// printf("buf = %p, size = %d\n", buf, size);
+// return 0;
+//}
+//
diff --git a/generate-c.scm b/generate-c.scm
index 08078a75..9eeff6b0 100644
--- a/generate-c.scm
+++ b/generate-c.scm
@@ -17,7 +17,7 @@
#include \"cyclone/types.h\"
#include \"cyclone/runtime.h\"
-void do_dispatch(int argc, function_type func, object clo, object *b) {
+void do_dispatch(void *data, int argc, function_type func, object clo, object *b) {
switch(argc) {" )
(define bs "")
@@ -25,6 +25,7 @@ void do_dispatch(int argc, function_type func, object clo, object *b) {
(display "case " )
(display i )
(display ":func(" )
+ (display "data,")
(display i )
(display ",clo" )
(display bs )
@@ -39,7 +40,7 @@ void do_dispatch(int argc, function_type func, object clo, object *b) {
{
char buf[1024];
snprintf(buf, 1023, \"Unhandled number of function arguments: %d\\n\", argc);
- Cyc_rt_raise_msg(buf);
+ Cyc_rt_raise_msg(data, buf);
}
}
}" )))
diff --git a/include/cyclone/ck_ht_hash.h b/include/cyclone/ck_ht_hash.h
new file mode 100644
index 00000000..cd3d7a53
--- /dev/null
+++ b/include/cyclone/ck_ht_hash.h
@@ -0,0 +1,269 @@
+/*
+ * Copyright 2012-2015 Samy Al Bahra
+ * Copyright 2011-2014 AppNexus, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#ifndef CK_HT_HASH_H
+#define CK_HT_HASH_H
+
+/*
+ * This is the Murmur hash written by Austin Appleby.
+ */
+
+#include
+#include
+
+//-----------------------------------------------------------------------------
+// MurmurHash3 was written by Austin Appleby, and is placed in the public
+// domain. The author hereby disclaims copyright to this source code.
+
+// Note - The x86 and x64 versions do _not_ produce the same results, as the
+// algorithms are optimized for their respective platforms. You can still
+// compile and run any of them on any platform, but your performance with the
+// non-native version will be less than optimal.
+
+//-----------------------------------------------------------------------------
+// Platform-specific functions and macros
+
+// Microsoft Visual Studio
+
+#if defined(_MSC_VER)
+
+#define FORCE_INLINE __forceinline
+
+#include
+
+#define ROTL32(x,y) _rotl(x,y)
+#define ROTL64(x,y) _rotl64(x,y)
+
+#define BIG_CONSTANT(x) (x)
+
+// Other compilers
+
+#else // defined(_MSC_VER)
+
+#define FORCE_INLINE inline __attribute__((always_inline))
+
+static inline uint32_t rotl32 ( uint32_t x, int8_t r )
+{
+ return (x << r) | (x >> (32 - r));
+}
+
+static inline uint64_t rotl64 ( uint64_t x, int8_t r )
+{
+ return (x << r) | (x >> (64 - r));
+}
+
+#define ROTL32(x,y) rotl32(x,y)
+#define ROTL64(x,y) rotl64(x,y)
+
+#define BIG_CONSTANT(x) (x##LLU)
+
+#endif // !defined(_MSC_VER)
+
+//-----------------------------------------------------------------------------
+// Block read - if your platform needs to do endian-swapping or can only
+// handle aligned reads, do the conversion here
+
+FORCE_INLINE static uint32_t getblock ( const uint32_t * p, int i )
+{
+ return p[i];
+}
+
+//-----------------------------------------------------------------------------
+// Finalization mix - force all bits of a hash block to avalanche
+
+FORCE_INLINE static uint32_t fmix ( uint32_t h )
+{
+ h ^= h >> 16;
+ h *= 0x85ebca6b;
+ h ^= h >> 13;
+ h *= 0xc2b2ae35;
+ h ^= h >> 16;
+
+ return h;
+}
+
+//-----------------------------------------------------------------------------
+
+static inline void MurmurHash3_x86_32 ( const void * key, int len,
+ uint32_t seed, uint32_t * out )
+{
+ const uint8_t * data = (const uint8_t*)key;
+ const int nblocks = len / 4;
+ int i;
+
+ uint32_t h1 = seed;
+
+ uint32_t c1 = 0xcc9e2d51;
+ uint32_t c2 = 0x1b873593;
+
+ //----------
+ // body
+
+ const uint32_t * blocks = (const uint32_t *)(const void *)(data + nblocks*4);
+
+ for(i = -nblocks; i; i++)
+ {
+ uint32_t k1 = getblock(blocks,i);
+
+ k1 *= c1;
+ k1 = ROTL32(k1,15);
+ k1 *= c2;
+
+ h1 ^= k1;
+ h1 = ROTL32(h1,13);
+ h1 = h1*5+0xe6546b64;
+ }
+
+ //----------
+ // tail
+
+ const uint8_t * tail = (const uint8_t*)(data + nblocks*4);
+
+ uint32_t k1 = 0;
+
+ switch(len & 3)
+ {
+ case 3: k1 ^= tail[2] << 16;
+ case 2: k1 ^= tail[1] << 8;
+ case 1: k1 ^= tail[0];
+ k1 *= c1; k1 = ROTL32(k1,15); k1 *= c2; h1 ^= k1;
+ };
+
+ //----------
+ // finalization
+
+ h1 ^= len;
+
+ h1 = fmix(h1);
+
+ *(uint32_t *)out = h1;
+}
+
+static inline uint64_t MurmurHash64A ( const void * key, int len, uint64_t seed )
+{
+ const uint64_t m = BIG_CONSTANT(0xc6a4a7935bd1e995);
+ const int r = 47;
+
+ uint64_t h = seed ^ (len * m);
+
+ const uint64_t * data = (const uint64_t *)key;
+ const uint64_t * end = data + (len/8);
+
+ while(data != end)
+ {
+ uint64_t k;
+
+ if (!((uintptr_t)data & 0x7))
+ k = *data++;
+ else {
+ memcpy(&k, data, sizeof(k));
+ data++;
+ }
+
+ k *= m;
+ k ^= k >> r;
+ k *= m;
+
+ h ^= k;
+ h *= m;
+ }
+
+ const unsigned char * data2 = (const unsigned char*)data;
+
+ switch(len & 7)
+ {
+ case 7: h ^= (uint64_t)(data2[6]) << 48;
+ case 6: h ^= (uint64_t)(data2[5]) << 40;
+ case 5: h ^= (uint64_t)(data2[4]) << 32;
+ case 4: h ^= (uint64_t)(data2[3]) << 24;
+ case 3: h ^= (uint64_t)(data2[2]) << 16;
+ case 2: h ^= (uint64_t)(data2[1]) << 8;
+ case 1: h ^= (uint64_t)(data2[0]);
+ h *= m;
+ };
+
+ h ^= h >> r;
+ h *= m;
+ h ^= h >> r;
+
+ return h;
+}
+
+
+// 64-bit hash for 32-bit platforms
+
+static inline uint64_t MurmurHash64B ( const void * key, int len, uint64_t seed )
+{
+ const uint32_t m = 0x5bd1e995;
+ const int r = 24;
+
+ uint32_t h1 = (uint32_t)(seed) ^ len;
+ uint32_t h2 = (uint32_t)(seed >> 32);
+
+ const uint32_t * data = (const uint32_t *)key;
+
+ while(len >= 8)
+ {
+ uint32_t k1 = *data++;
+ k1 *= m; k1 ^= k1 >> r; k1 *= m;
+ h1 *= m; h1 ^= k1;
+ len -= 4;
+
+ uint32_t k2 = *data++;
+ k2 *= m; k2 ^= k2 >> r; k2 *= m;
+ h2 *= m; h2 ^= k2;
+ len -= 4;
+ }
+
+ if(len >= 4)
+ {
+ uint32_t k1 = *data++;
+ k1 *= m; k1 ^= k1 >> r; k1 *= m;
+ h1 *= m; h1 ^= k1;
+ len -= 4;
+ }
+
+ switch(len)
+ {
+ case 3: h2 ^= ((const unsigned char*)data)[2] << 16;
+ case 2: h2 ^= ((const unsigned char*)data)[1] << 8;
+ case 1: h2 ^= ((const unsigned char*)data)[0];
+ h2 *= m;
+ };
+
+ h1 ^= h2 >> 18; h1 *= m;
+ h2 ^= h1 >> 22; h2 *= m;
+ h1 ^= h2 >> 17; h1 *= m;
+ h2 ^= h1 >> 19; h2 *= m;
+
+ uint64_t h = h1;
+
+ h = (h << 32) | h2;
+
+ return h;
+}
+
+#endif /* CK_HT_HASH_H */
diff --git a/include/cyclone/runtime-main.h b/include/cyclone/runtime-main.h
index f7914f8b..3d1890e8 100644
--- a/include/cyclone/runtime-main.h
+++ b/include/cyclone/runtime-main.h
@@ -14,75 +14,17 @@
long global_stack_size = 0;
long global_heap_size = 0;
-static void c_entry_pt(int,closure,closure);
-static void Cyc_main(long stack_size,long heap_size,char *stack_base);
-
-static void Cyc_main (stack_size,heap_size,stack_base)
- long stack_size,heap_size; char *stack_base;
-{char in_my_frame;
- mclosure0(clos_halt,&Cyc_halt); /* Halt program if final closure is reached */
- gc_ans[0] = &clos_halt;
- gc_num_ans = 1;
- /* Allocate stack buffer. */
- stack_begin = stack_base;
-#if STACK_GROWS_DOWNWARD
- stack_limit1 = stack_begin - stack_size;
- stack_limit2 = stack_limit1 - 2000;
-#else
- stack_limit1 = stack_begin + stack_size;
- stack_limit2 = stack_limit1 + 2000;
-#endif
-#if DEBUG_SHOW_DIAG
- printf("main: sizeof(cons_type)=%ld\n",(long) sizeof(cons_type));
-#endif
- if (check_overflow(stack_base,&in_my_frame))
- {printf("main: Recompile with STACK_GROWS_DOWNWARD set to %ld\n",
- (long) (1-STACK_GROWS_DOWNWARD)); exit(0);}
-#if DEBUG_SHOW_DIAG
- printf("main: stack_size=%ld stack_base=%p stack_limit1=%p\n",
- stack_size,(void *)stack_base,(void *)stack_limit1);
-#endif
-
- /* Initialize stack trace table */
- Cyc_st_init();
-
- {
- /* Setup first function to execute */
- mclosure0(entry_pt,&c_entry_pt);
- gc_cont = &entry_pt;
+static void c_entry_pt(void *,int,closure,closure);
+static void Cyc_heap_init(long heap_size);
+static void Cyc_heap_init(long heap_size)
+{
/* Allocate heap area for second generation. */
- /* Use calloc instead of malloc to assure pages are in main memory. */
#if DEBUG_SHOW_DIAG
printf("main: Allocating and initializing heap...\n");
#endif
- bottom = calloc(1,heap_size);
- allocp = (char *) ((((long) bottom)+7) & -8);
- alloc_end = allocp + heap_size - 8;
-
- dhallocp = dhbottom = calloc(1, heap_size);
- dhalloc_limit = dhallocp + (long)((heap_size - 8) * 0.90);
- dhalloc_end = dhallocp + heap_size - 8;
-#if DEBUG_SHOW_DIAG
- printf("main: heap_size=%ld allocp=%p alloc_end=%p\n",
- (long) heap_size,(void *)allocp,(void *)alloc_end);
- printf("main: Try a larger heap_size if program bombs.\n");
- printf("Starting...\n");
-#endif
- start = clock(); /* Start the timing clock. */
-
- /* Tank, load the jump program... */
- setjmp(jmp_main);
-#if DEBUG_GC
- printf("Done with GC\n");
-#endif
-
- if (type_of(gc_cont) == cons_tag || prim(gc_cont)) {
- Cyc_apply_from_buf(gc_num_ans, gc_cont, gc_ans);
- } else {
- do_dispatch(gc_num_ans, ((closure)gc_cont)->fn, gc_cont, gc_ans);
- }
-
- printf("Internal error: should never have reached this line\n"); exit(0);}}
+ gc_init_heap(heap_size);
+ gc_start_collector();
+}
#endif /* CYCLONE_RUNTIME_MAIN_H */
diff --git a/include/cyclone/runtime.h b/include/cyclone/runtime.h
index ee83caa3..4d0dbf69 100644
--- a/include/cyclone/runtime.h
+++ b/include/cyclone/runtime.h
@@ -10,30 +10,30 @@
#define CYCLONE_RUNTIME_H
/* Error checking definitions */
-#define Cyc_check_num_args(fnc_name, num_args, args) { \
- integer_type l = Cyc_length(args); \
+#define Cyc_check_num_args(data, fnc_name, num_args, args) { \
+ integer_type l = Cyc_length(data, args); \
if (num_args > l.value) { \
char buf[128]; \
snprintf(buf, 127, "Expected %d arguments but received %d.", num_args, l.value); \
- Cyc_rt_raise_msg(buf); \
+ Cyc_rt_raise_msg(data, buf); \
} \
}
-#define Cyc_check_type(fnc_test, tag, obj) { \
- if (eq(boolean_f, fnc_test(obj))) Cyc_invalid_type_error(tag, obj); }
+#define Cyc_check_type(data, fnc_test, tag, obj) { \
+ if (eq(boolean_f, fnc_test(obj))) Cyc_invalid_type_error(data, tag, obj); }
-#define Cyc_check_cons_or_nil(obj) { if (!nullp(obj)) { Cyc_check_cons(obj); }}
-#define Cyc_check_cons(obj) Cyc_check_type(Cyc_is_cons, cons_tag, obj);
-#define Cyc_check_num(obj) Cyc_check_type(Cyc_is_number, integer_tag, obj);
-#define Cyc_check_int(obj) Cyc_check_type(Cyc_is_integer, integer_tag, obj);
-#define Cyc_check_str(obj) Cyc_check_type(Cyc_is_string, string_tag, obj);
-#define Cyc_check_sym(obj) Cyc_check_type(Cyc_is_symbol, symbol_tag, obj);
-#define Cyc_check_vec(obj) Cyc_check_type(Cyc_is_vector, vector_tag, obj);
-#define Cyc_check_port(obj) Cyc_check_type(Cyc_is_port, port_tag, obj);
-#define Cyc_check_fnc(obj) Cyc_check_type(Cyc_is_procedure, closure2_tag, obj);
-void Cyc_invalid_type_error(int tag, object found);
-void Cyc_check_obj(int tag, object obj);
-void Cyc_check_bounds(const char *label, int len, int index);
+#define Cyc_check_cons_or_nil(d,obj) { if (!nullp(obj)) { Cyc_check_cons(d,obj); }}
+#define Cyc_check_cons(d,obj) Cyc_check_type(d,Cyc_is_cons, cons_tag, obj);
+#define Cyc_check_num(d,obj) Cyc_check_type(d,Cyc_is_number, integer_tag, obj);
+#define Cyc_check_int(d,obj) Cyc_check_type(d,Cyc_is_integer, integer_tag, obj);
+#define Cyc_check_str(d,obj) Cyc_check_type(d,Cyc_is_string, string_tag, obj);
+#define Cyc_check_sym(d,obj) Cyc_check_type(d,Cyc_is_symbol, symbol_tag, obj);
+#define Cyc_check_vec(d,obj) Cyc_check_type(d,Cyc_is_vector, vector_tag, obj);
+#define Cyc_check_port(d,obj) Cyc_check_type(d,Cyc_is_port, port_tag, obj);
+#define Cyc_check_mutex(d,obj) Cyc_check_type(d,Cyc_is_mutex, mutex_tag, obj);
+void Cyc_invalid_type_error(void *data, int tag, object found);
+void Cyc_check_obj(void *data, int tag, object obj);
+void Cyc_check_bounds(void *data, const char *label, int len, int index);
/* END error checking */
extern long global_stack_size;
@@ -42,7 +42,8 @@ extern const object Cyc_EOF;
object cell_get(object cell);
-#define global_set(glo,value) (glo=value)
+#define global_set(glo,value) Cyc_global_set(data, (object *)&glo, value)
+object Cyc_global_set(void *thd, object *glo, object value);
/* Variable argument count support
@@ -72,6 +73,8 @@ object cell_get(object cell);
} else { \
tmp = arg_var; \
} \
+ var[i].hdr.mark = gc_color_red; \
+ var[i].hdr.grayed = 0; \
var[i].tag = cons_tag; \
var[i].cons_car = tmp; \
var[i].cons_cdr = (i == (count-1)) ? nil : &var[i + 1]; \
@@ -80,81 +83,80 @@ object cell_get(object cell);
} \
}
-/* Prototypes for Lisp built-in functions. */
+/* Prototypes for primitive functions. */
extern object Cyc_global_variables;
int _cyc_argc;
char **_cyc_argv;
+void gc_init_heap(long heap_size);
object Cyc_get_global_variables();
object Cyc_get_cvar(object var);
object Cyc_set_cvar(object var, object value);
-object apply(object cont, object func, object args);
-void Cyc_apply(int argc, closure cont, object prim, ...);
-integer_type Cyc_string_cmp(object str1, object str2);
-void dispatch_string_91append(int argc, object clo, object cont, object str1, ...);
-string_type Cyc_string_append(int argc, object str1, ...);
-string_type Cyc_string_append_va_list(int, object, va_list);
+object apply(void *data, object cont, object func, object args);
+void Cyc_apply(void *data, int argc, closure cont, object prim, ...);
+integer_type Cyc_string_cmp(void *data, object str1, object str2);
+void dispatch_string_91append(void *data, int argc, object clo, object cont, object str1, ...);
list mcons(object,object);
cvar_type *mcvar(object *var);
object Cyc_display(object, FILE *port);
-object dispatch_display_va(int argc, object clo, object cont, object x, ...);
+object dispatch_display_va(void *data, int argc, object clo, object cont, object x, ...);
object Cyc_display_va(int argc, object x, ...);
object Cyc_display_va_list(int argc, object x, va_list ap);
-object Cyc_write_char(object c, object port);
+object Cyc_write_char(void *data, object c, object port);
object Cyc_write(object, FILE *port);
-object dispatch_write_va(int argc, object clo, object cont, object x, ...);
+object dispatch_write_va(void *data, int argc, object clo, object cont, object x, ...);
object Cyc_write_va(int argc, object x, ...);
object Cyc_write_va_list(int argc, object x, va_list ap);
object Cyc_has_cycle(object lst);
-list assoc(object x, list l);
-object __num_eq(object x, object y);
-object __num_gt(object x, object y);
-object __num_lt(object x, object y);
-object __num_gte(object x, object y);
-object __num_lte(object x, object y);
+object __num_eq(void *, object x, object y);
+object __num_gt(void *, object x, object y);
+object __num_lt(void *, object x, object y);
+object __num_gte(void *, object x, object y);
+object __num_lte(void *, object x, object y);
object Cyc_eq(object x, object y);
-object Cyc_set_car(object l, object val) ;
-object Cyc_set_cdr(object l, object val) ;
-integer_type Cyc_length(object l);
-integer_type Cyc_vector_length(object v);
-object Cyc_vector_ref(object v, object k);
-object Cyc_vector_set(object v, object k, object obj);
-object Cyc_make_vector(object cont, object len, object fill);
-object Cyc_list2vector(object cont, object l);
-string_type Cyc_number2string(object n) ;
-string_type Cyc_symbol2string(object sym) ;
-object Cyc_string2symbol(object str);
-string_type Cyc_list2string(object lst);
-common_type Cyc_string2number(object str);
-void dispatch_string_91append(int argc, object clo, object cont, object str1, ...);
-string_type Cyc_string_append(int argc, object str1, ...);
-string_type Cyc_string_append_va_list(int argc, object str1, va_list ap);
-integer_type Cyc_string_length(object str);
-string_type Cyc_substring(object str, object start, object end);
-object Cyc_string_ref(object str, object k);
-object Cyc_string_set(object str, object k, object chr);
-string_type Cyc_installation_dir();
-object Cyc_command_line_arguments(object cont);
+object Cyc_set_car(void *, object l, object val) ;
+object Cyc_set_cdr(void *, object l, object val) ;
+integer_type Cyc_length(void *d, object l);
+integer_type Cyc_vector_length(void *data, object v);
+object Cyc_vector_ref(void *d, object v, object k);
+object Cyc_vector_set(void *d, object v, object k, object obj);
+object Cyc_make_vector(void *data, object cont, object len, object fill);
+object Cyc_list2vector(void *data, object cont, object l);
+object Cyc_make_mutex(void *data);
+object Cyc_mutex_lock(void *data, object cont, object obj);
+object Cyc_mutex_unlock(void *data, object obj);
+object Cyc_number2string(void *d, object cont, object n);
+object Cyc_symbol2string(void *d, object cont, object sym) ;
+object Cyc_string2symbol(void *d, object str);
+object Cyc_list2string(void *d, object cont, object lst);
+common_type Cyc_string2number(void *d, object str);
+object Cyc_string_append(void *data, object cont, int argc, object str1, ...);
+integer_type Cyc_string_length(void *data, object str);
+object Cyc_substring(void *data, object cont, object str, object start, object end);
+object Cyc_string_ref(void *data, object str, object k);
+object Cyc_string_set(void *data, object str, object k, object chr);
+object Cyc_installation_dir(void *data, object cont, object type);
+object Cyc_command_line_arguments(void *data, object cont);
integer_type Cyc_system(object cmd);
integer_type Cyc_char2integer(object chr);
-object Cyc_integer2char(object n);
+object Cyc_integer2char(void *data, object n);
void Cyc_halt(closure);
object __halt(object obj);
port_type Cyc_stdout(void);
port_type Cyc_stdin(void);
port_type Cyc_stderr(void);
-port_type Cyc_io_open_input_file(object str);
-port_type Cyc_io_open_output_file(object str);
-object Cyc_io_close_port(object port);
-object Cyc_io_close_input_port(object port);
-object Cyc_io_close_output_port(object port);
-object Cyc_io_flush_output_port(object port);
-object Cyc_io_delete_file(object filename);
-object Cyc_io_file_exists(object filename);
-object Cyc_io_read_char(object port);
-object Cyc_io_peek_char(object port);
-object Cyc_io_read_line(object cont, object port);
+port_type Cyc_io_open_input_file(void *data, object str);
+port_type Cyc_io_open_output_file(void *data, object str);
+object Cyc_io_close_port(void *data, object port);
+object Cyc_io_close_input_port(void *data, object port);
+object Cyc_io_close_output_port(void *data, object port);
+object Cyc_io_flush_output_port(void *data, object port);
+object Cyc_io_delete_file(void *data, object filename);
+object Cyc_io_file_exists(void *data, object filename);
+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_read_line(void *data, object cont, object port);
object Cyc_is_boolean(object o);
object Cyc_is_cons(object o);
@@ -164,74 +166,58 @@ object Cyc_is_real(object o);
object Cyc_is_integer(object o);
object Cyc_is_vector(object o);
object Cyc_is_port(object o);
+object Cyc_is_mutex(object o);
object Cyc_is_symbol(object o);
object Cyc_is_string(object o);
object Cyc_is_char(object o);
-object Cyc_is_procedure(object o);
+object Cyc_is_procedure(void *data, object o);
object Cyc_is_macro(object o);
object Cyc_is_eof_object(object o);
object Cyc_is_cvar(object o);
-common_type Cyc_sum_op(object x, object y);
-common_type Cyc_sub_op(object x, object y);
-common_type Cyc_mul_op(object x, object y);
-common_type Cyc_div_op(object x, object y);
-common_type Cyc_sum(int argc, object n, ...);
-common_type Cyc_sub(int argc, object n, ...);
-common_type Cyc_mul(int argc, object n, ...);
-common_type Cyc_div(int argc, object n, ...);
-common_type Cyc_num_op_va_list(int argc, common_type (fn_op(object, object)), object n, va_list ns);
+common_type Cyc_sum_op(void *data, object x, object y);
+common_type Cyc_sub_op(void *data, object x, object y);
+common_type Cyc_mul_op(void *data, object x, object y);
+common_type Cyc_div_op(void *data, object x, object y);
+common_type Cyc_sum(void *data, int argc, object n, ...);
+common_type Cyc_sub(void *data, int argc, object n, ...);
+common_type Cyc_mul(void *data, int argc, object n, ...);
+common_type Cyc_div(void *data, int argc, object n, ...);
+common_type Cyc_num_op_va_list(void *data, int argc, common_type (fn_op(void *, object, object)), object n, va_list ns);
int equal(object,object);
-list assq(object,list);
+list assq(void *,object,list);
+list assoc(void *,object x, list l);
object get(object,object);
object equalp(object,object);
-object memberp(object,list);
-object memqp(object,list);
-char *transport(char *,int);
-void GC(closure,object*,int);
+object memberp(void *,object,list);
+object memqp(void *,object,list);
-void Cyc_st_init();
-void Cyc_st_add(char *frame);
-void Cyc_st_print(FILE *out);
+object Cyc_spawn_thread(object thunk);
+void Cyc_start_trampoline(gc_thread_data *thd);
+void Cyc_end_thread(gc_thread_data *thd);
+void Cyc_exit_thread(gc_thread_data *thd);
+object Cyc_thread_sleep(void *data, object timeout);
+void GC(void *,closure,object*,int);
+object Cyc_trigger_minor_gc(void *data, object cont);
+
+void Cyc_st_add(void *data, char *frame);
+void Cyc_st_print(void *data, FILE *out);
char *_strdup (const char *s);
object add_symbol(symbol_type *psym);
object add_symbol_by_name(const char *name);
object find_symbol_by_name(const char *name);
object find_or_add_symbol(const char *name);
-extern list symbol_table;
extern list global_table;
void add_global(object *glo);
-void add_mutation(object var, object value);
-void clear_mutations();
-extern list mutation_table;
-
-void dispatch(int argc, function_type func, object clo, object cont, object args);
-void dispatch_va(int argc, function_type_va func, object clo, object cont, object args);
-void do_dispatch(int argc, function_type func, object clo, object *buffer);
+void dispatch(void *data, int argc, function_type func, object clo, object cont, object args);
+void dispatch_va(void *data, int argc, function_type_va func, object clo, object cont, object args);
+void do_dispatch(void *data, int argc, function_type func, object clo, object *buffer);
/* Global variables. */
-extern clock_t start; /* Starting time. */
-extern char *stack_begin; /* Initialized by main. */
-extern char *stack_limit1; /* Initialized by main. */
-extern char *stack_limit2;
-extern char *bottom; /* Bottom of tospace. */
-extern char *allocp; /* Cheney allocate pointer. */
-extern char *alloc_end;
-/* TODO: not sure this is the best strategy for strings, especially if there
- are a lot of long, later gen strings because that will cause a lot of
- copying to occur during GC */
-extern char *dhbottom; /* Bottom of data heap */
-extern char *dhallocp; /* Current place in data heap */
-extern char *dhalloc_limit; /* GC beyond this limit */
-extern char *dhalloc_end;
extern long no_gcs; /* Count the number of GC's. */
extern long no_major_gcs; /* Count the number of GC's. */
-extern object gc_cont; /* GC continuation closure. */
-extern object gc_ans[NUM_GC_ANS]; /* argument for GC continuation closure. */
-extern int gc_num_ans;
-extern jmp_buf jmp_main; /* Where to jump to. */
/* Define Lisp constants we need. */
extern const object boolean_t;
@@ -244,6 +230,10 @@ extern const object primitive_Cyc_91get_91cvar;
extern const object primitive_Cyc_91set_91cvar_67;
extern const object primitive_Cyc_91cvar_127;
extern const object primitive_Cyc_91has_91cycle_127;
+extern const object primitive_Cyc_91spawn_91thread_67;
+extern const object primitive_Cyc_91end_91thread_67;
+extern const object primitive_thread_91sleep_67;
+extern const object primitive_Cyc_91minor_91gc;
extern const object primitive__87;
extern const object primitive__91;
extern const object primitive__85;
@@ -323,6 +313,10 @@ extern const object primitive_vector_91ref;
extern const object primitive_vector_91set_67;
extern const object primitive_string_91ref;
extern const object primitive_string_91set_67;
+extern const object primitive_make_91mutex;
+extern const object primitive_mutex_91lock_67;
+extern const object primitive_mutex_91unlock_67;
+extern const object primitive_mutex_127;
extern const object primitive_Cyc_91installation_91dir;
extern const object primitive_command_91line_91arguments;
extern const object primitive_system;
@@ -373,11 +367,11 @@ extern object Cyc_exception_handler_stack;
// behavior portable? If not, will have to modify cgen to not emit the var.
#define __glo__85exception_91handler_91stack_85 Cyc_exception_handler_stack
-object Cyc_default_exception_handler(int argc, closure _, object err);
+object Cyc_default_exception_handler(void *data, int argc, closure _, object err);
object Cyc_current_exception_handler();
-void Cyc_rt_raise(object err);
-void Cyc_rt_raise2(const char *msg, object err);
-void Cyc_rt_raise_msg(const char *err);
+void Cyc_rt_raise(void *data, object err);
+void Cyc_rt_raise2(void *data, const char *msg, object err);
+void Cyc_rt_raise_msg(void *data, const char *err);
/* END exception handler */
#endif /* CYCLONE_RUNTIME_H */
diff --git a/include/cyclone/types.h b/include/cyclone/types.h
index 333e7cf0..8c482ebe 100644
--- a/include/cyclone/types.h
+++ b/include/cyclone/types.h
@@ -16,26 +16,160 @@
#include
#include
#include
+#include
-/* Debug GC flag */
-#define DEBUG_GC 0
+// Maximum number of args that GC will accept
+#define NUM_GC_ANS 128
+
+// Which way does the CPU grow its stack?
+#define STACK_GROWS_DOWNWARD 1
+
+// Size of the stack buffer, in bytes.
+// This is used as the first generation of the GC.
+#define STACK_SIZE 250000
+
+// Size of a "page" on the heap (the second generation), in bytes.
+#define HEAP_SIZE 6000000
+
+// Number of functions to save for printing call history
+#define MAX_STACK_TRACES 10
+
+// GC debugging flags
+#define GC_DEBUG_TRACE 0
+#define GC_DEBUG_VERBOSE 0
+
+/* Additional runtime checking of the GC system.
+ This is here because these checks should not be
+ necessary if GC is working correctly. */
+#define GC_SAFETY_CHECKS 1
+
+// General constants
+#define NANOSECONDS_PER_MILLISECOND 1000000
+
+/* Define general object type. */
+typedef void *object;
+
+/* Threading */
+typedef enum { CYC_THREAD_STATE_NEW
+ , CYC_THREAD_STATE_RUNNABLE
+ , CYC_THREAD_STATE_BLOCKED
+ , CYC_THREAD_STATE_BLOCKED_COOPERATING
+ , CYC_THREAD_STATE_TERMINATED
+ } cyc_thread_state_type;
+
+/* Thread data structures */
+typedef struct gc_thread_data_t gc_thread_data;
+struct gc_thread_data_t {
+// TODO:
+// pthread_t *thread;
+ cyc_thread_state_type thread_state;
+ // Data needed to initiate stack-based minor GC
+ char *stack_start;
+ char *stack_limit;
+ // Minor GC write barrier
+ void *mutations;
+ // List of objects moved to heap during minor GC
+ void **moveBuf;
+ int moveBufLen;
+ // Need the following to perform longjmp's
+ //int mutator_num;
+ jmp_buf *jmp_start;
+ // After longjmp, pick up execution using continuation/arguments
+ object gc_cont;
+ object *gc_args;
+ short gc_num_args;
+ // Data needed for heap GC
+ int gc_alloc_color;
+ int gc_status;
+ int last_write;
+ int last_read;
+ int pending_writes;
+ void **mark_buffer;
+ int mark_buffer_len;
+ pthread_mutex_t lock;
+ // Data needed for call history
+ char **stack_traces;
+ int stack_trace_idx;
+ char *stack_prev_frame;
+};
+
+/* GC data structures */
+
+typedef struct gc_free_list_t gc_free_list;
+struct gc_free_list_t {
+// somehow this size param is being overwritten by a "mark() =".
+// how could that happen?
+//somehow it appears free list pointers are being used where heap objects are
+//expected. could this be as simple as objects being sweeped that should not
+//have been? unfortunately it is harder to figure how why the objects were
+//sweeped. were they not marked properly? is there a race condition? maybe
+//more than one issue? what is going on?
+//
+// the following line does not solve the problem. in fact, with this in
+// place there are still cases where the tag is a multiple of 32, implying
+// again that a free list node is being used as a heap object. IE, the
+// size value is being read into the tag field by code expecting a heap obj.
+//
+//unsigned int dummy; // just for testing/evaluation, this line is NOT a fix!!
+ unsigned int size;
+ gc_free_list *next;
+};
+
+typedef struct gc_heap_t gc_heap;
+struct gc_heap_t {
+ unsigned int size;
+ unsigned int chunk_size; // 0 for any size, other and heap will only alloc chunks of that size
+ unsigned int max_size;
+ //unsigned int free_size;
+ gc_free_list *free_list; // TBD
+ gc_heap *next; // TBD, linked list is not very efficient, but easy to work with as a start
+ char *data;
+};
+
+typedef struct gc_header_type_t gc_header_type;
+struct gc_header_type_t {
+ unsigned int mark; // mark bits (only need 2)
+ unsigned char grayed; // stack object to be grayed when moved to heap
+};
+#define mark(x) (((list) x)->hdr.mark)
+#define grayed(x) (((list) x)->hdr.grayed)
+
+/* HEAP definitions */
+// experimenting with a heap based off of the one in 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)&(((unsigned int)-1)-((1<<(bits))-1)))
+// 64-bit is 3, 32-bit is 2
+#define gc_word_align(n) gc_align((n), 2)
+#define gc_heap_align(n) gc_align(n, 5)
+
+/* Enums for tri-color marking */
+typedef enum { STATUS_ASYNC
+ , STATUS_SYNC1
+ , STATUS_SYNC2
+ } gc_status_type;
+
+typedef enum { STAGE_CLEAR_OR_MARKING
+ , STAGE_TRACING
+ //, STAGE_REF_PROCESSING
+ , STAGE_SWEEPING
+ , STAGE_RESTING
+ } gc_stage_type;
+
+// Constant colors are defined here.
+// The mark/clear colors are defined in the gc module because
+// the collector swaps their values as an optimization.
+#define gc_color_red 0 // Memory not to be GC'd, such as on the stack
+#define gc_color_blue 2 // Unallocated memory
/* Show diagnostic information for the GC when program terminates */
#define DEBUG_SHOW_DIAG 0
-/* Maximum number of args that GC will accept */
-#define NUM_GC_ANS 128
-
-/* Which way does the CPU grow its stack? */
-#define STACK_GROWS_DOWNWARD 1
-
-/* Size of the stack buffer, in bytes. */
-#define STACK_SIZE 100000
-
-/* Size of the 2nd generation, in bytes. */
-#define HEAP_SIZE 6000000
-
-/* Define size of object tags. Options are "short" or "long". */
+/* Define size of object tags */
typedef long tag_type;
#ifndef CLOCKS_PER_SEC
@@ -73,15 +207,12 @@ typedef long tag_type;
#define cvar_tag 16
#define vector_tag 17
#define macro_tag 18
+#define mutex_tag 19
#define nil NULL
#define eq(x,y) (x == y)
#define nullp(x) (x == NULL)
-/* Define general object type. */
-
-typedef void *object;
-
#define type_of(x) (((list) x)->tag)
#define forward(x) (((list) x)->cons_car)
@@ -90,7 +221,7 @@ typedef void *object;
have extra least significant bits that can be used to mark them as
values instead of objects (IE, pointer to a tagged object).
On many machines, addresses are multiples of four, leaving the two
- least significant bits free - according to lisp in small pieces.
+ least significant bits free - from lisp in small pieces.
*/
#define obj_is_char(x) ((unsigned long)(x) & (unsigned long)1)
#define obj_obj2char(x) (char)((long)(x)>>1)
@@ -105,19 +236,23 @@ typedef void (*function_type)();
typedef void (*function_type_va)(int, object, object, object, ...);
/* Define C-variable integration type */
-typedef struct {tag_type tag; object *pvar;} cvar_type;
+typedef struct {gc_header_type hdr; tag_type tag; object *pvar;} cvar_type;
typedef cvar_type *cvar;
-#define make_cvar(n,v) cvar_type n; n.tag = cvar_tag; n.pvar = v;
+#define make_cvar(n,v) cvar_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = cvar_tag; n.pvar = v;
+
+/* Define mutex type */
+typedef struct {gc_header_type hdr; tag_type tag; pthread_mutex_t lock;} mutex_type;
+typedef mutex_type *mutex;
/* Define boolean type. */
-typedef struct {const tag_type tag; const char *pname;} boolean_type;
+typedef struct {gc_header_type hdr; const tag_type tag; const char *pname;} boolean_type;
typedef boolean_type *boolean;
#define boolean_pname(x) (((boolean_type *) x)->pname)
/* Define symbol type. */
-typedef struct {const tag_type tag; const char *pname; object plist;} symbol_type;
+typedef struct {gc_header_type hdr; const tag_type tag; const char *pname; object plist;} symbol_type;
typedef symbol_type *symbol;
#define symbol_pname(x) (((symbol_type *) x)->pname)
@@ -127,28 +262,34 @@ typedef symbol_type *symbol;
static object quote_##name = nil;
/* Define numeric types */
-typedef struct {tag_type tag; int value;} integer_type;
-#define make_int(n,v) integer_type n; n.tag = integer_tag; n.value = v;
-typedef struct {tag_type tag; double value;} double_type;
-#define make_double(n,v) double_type n; n.tag = double_tag; n.value = v;
+typedef struct {gc_header_type hdr; tag_type tag; int value;} integer_type;
+#define make_int(n,v) integer_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = integer_tag; n.value = v;
+typedef struct {gc_header_type hdr; tag_type tag; double value;} double_type;
+#define make_double(n,v) double_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = double_tag; n.value = v;
#define integer_value(x) (((integer_type *) x)->value)
#define double_value(x) (((double_type *) x)->value)
/* Define string type */
-typedef struct {tag_type tag; char *str;} string_type;
-#define make_string(cv,s) string_type cv; cv.tag = string_tag; \
-{ int len = strlen(s); cv.str = dhallocp; \
- if ((dhallocp + len + 1) >= dhbottom + global_heap_size) { \
- printf("Fatal error: data heap overflow\n"); exit(1); } \
- memcpy(dhallocp, s, len + 1); dhallocp += len + 1; }
-#define make_stringn(cv,s,len) string_type cv; cv.tag = string_tag; \
-{ cv.str = dhallocp; \
- if ((dhallocp + len + 1) >= dhbottom + global_heap_size) { \
- printf("Fatal error: data heap overflow\n"); exit(1); } \
- memcpy(dhallocp, s, len); dhallocp += len; \
- *dhallocp = '\0'; dhallocp += 1;}
+typedef struct {gc_header_type hdr; tag_type tag; int len; char *str;} string_type;
+//// TODO: new way to allocate strings, but this requires changes to
+//// all functions that allocate strings, the GC, cgen, and maybe more.
+//// Because these strings are (at least for now) allocaed on the stack.
+#define make_string(cs, s) string_type cs; \
+{ int len = strlen(s); cs.tag = string_tag; cs.len = len; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
+ cs.str = alloca(sizeof(char) * (len + 1)); \
+ memcpy(cs.str, s, len + 1);}
+#define make_string_with_len(cs, s, length) string_type cs; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
+{ int len = length; \
+ cs.tag = string_tag; cs.len = len; \
+ cs.str = alloca(sizeof(char) * (len + 1)); \
+ memcpy(cs.str, s, len); \
+ cs.str[len] = '\0';}
+#define make_string_noalloc(cs, s, length) string_type cs; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
+{ cs.tag = string_tag; cs.len = length; \
+ cs.str = s; }
+#define string_len(x) (((string_type *) x)->len)
#define string_str(x) (((string_type *) x)->str)
/* I/O types */
@@ -157,19 +298,19 @@ typedef struct {tag_type tag; char *str;} string_type;
// consider http://stackoverflow.com/questions/6206893/how-to-implement-char-ready-in-c
// TODO: a simple wrapper around FILE may not be good enough long-term
// TODO: how exactly mode will be used. need to know r/w, bin/txt
-typedef struct {tag_type tag; FILE *fp; int mode;} port_type;
-#define make_port(p,f,m) port_type p; p.tag = port_tag; p.fp = f; p.mode = m;
+typedef struct {gc_header_type hdr; tag_type tag; FILE *fp; int mode;} port_type;
+#define make_port(p,f,m) port_type p; p.hdr.mark = gc_color_red; p.hdr.grayed = 0; p.tag = port_tag; p.fp = f; p.mode = m;
/* Vector type */
-typedef struct {tag_type tag; int num_elt; object *elts;} vector_type;
+typedef struct {gc_header_type hdr; tag_type tag; int num_elt; object *elts;} vector_type;
typedef vector_type *vector;
-#define make_empty_vector(v) vector_type v; v.tag = vector_tag; v.num_elt = 0; v.elts = NULL;
+#define make_empty_vector(v) vector_type v; v.hdr.mark = gc_color_red; v.hdr.grayed = 0; v.tag = vector_tag; v.num_elt = 0; v.elts = NULL;
/* Define cons type. */
-typedef struct {tag_type tag; object cons_car,cons_cdr;} cons_type;
+typedef struct {gc_header_type hdr; tag_type tag; object cons_car,cons_cdr;} cons_type;
typedef cons_type *list;
#define car(x) (((list) x)->cons_car)
@@ -204,17 +345,17 @@ typedef cons_type *list;
#define cddddr(x) (cdr(cdr(cdr(cdr(x)))))
#define make_cons(n,a,d) \
-cons_type n; n.tag = cons_tag; n.cons_car = a; n.cons_cdr = d;
+cons_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = cons_tag; n.cons_car = a; n.cons_cdr = d;
/* Closure types */
-typedef struct {tag_type tag; function_type fn; int num_args; } macro_type;
-typedef struct {tag_type tag; function_type fn; int num_args; } closure0_type;
-typedef struct {tag_type tag; function_type fn; int num_args; object elt1;} closure1_type;
-typedef struct {tag_type tag; function_type fn; int num_args; object elt1,elt2;} closure2_type;
-typedef struct {tag_type tag; function_type fn; int num_args; object elt1,elt2,elt3;} closure3_type;
-typedef struct {tag_type tag; function_type fn; int num_args; object elt1,elt2,elt3,elt4;} closure4_type;
-typedef struct {tag_type tag; function_type fn; int num_args; int num_elt; object *elts;} closureN_type;
+typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; } macro_type;
+typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; } closure0_type;
+typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1;} closure1_type;
+typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1,elt2;} closure2_type;
+typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1,elt2,elt3;} closure3_type;
+typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1,elt2,elt3,elt4;} closure4_type;
+typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; int num_elt; object *elts;} closureN_type;
typedef closure0_type *closure0;
typedef closure1_type *closure1;
@@ -225,15 +366,15 @@ typedef closureN_type *closureN;
typedef closure0_type *closure;
typedef closure0_type *macro;
-#define mmacro(c,f) macro_type c; c.tag = macro_tag; c.fn = f; c.num_args = -1;
-#define mclosure0(c,f) closure0_type c; c.tag = closure0_tag; c.fn = f; c.num_args = -1;
-#define mclosure1(c,f,a) closure1_type c; c.tag = closure1_tag; \
+#define mmacro(c,f) macro_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = macro_tag; c.fn = f; c.num_args = -1;
+#define mclosure0(c,f) closure0_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure0_tag; c.fn = f; c.num_args = -1;
+#define mclosure1(c,f,a) closure1_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure1_tag; \
c.fn = f; c.num_args = -1; c.elt1 = a;
-#define mclosure2(c,f,a1,a2) closure2_type c; c.tag = closure2_tag; \
+#define mclosure2(c,f,a1,a2) closure2_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure2_tag; \
c.fn = f; c.num_args = -1; c.elt1 = a1; c.elt2 = a2;
-#define mclosure3(c,f,a1,a2,a3) closure3_type c; c.tag = closure3_tag; \
+#define mclosure3(c,f,a1,a2,a3) closure3_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure3_tag; \
c.fn = f; c.num_args = -1; c.elt1 = a1; c.elt2 = a2; c.elt3 = a3;
-#define mclosure4(c,f,a1,a2,a3,a4) closure4_type c; c.tag = closure4_tag; \
+#define mclosure4(c,f,a1,a2,a3,a4) closure4_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure4_tag; \
c.fn = f; c.num_args = -1; c.elt1 = a1; c.elt2 = a2; c.elt3 = a3; c.elt4 = a4;
#define mlist1(e1) (mcons(e1,nil))
@@ -247,7 +388,7 @@ typedef closure0_type *macro;
#define make_cell(n,a) make_cons(n,a,nil);
/* Primitive types */
-typedef struct {tag_type tag; const char *pname; function_type fn;} primitive_type;
+typedef struct {gc_header_type hdr; tag_type tag; const char *pname; function_type fn;} primitive_type;
typedef primitive_type *primitive;
#define defprimitive(name, pname, fnc) \
@@ -265,8 +406,54 @@ typedef union {
primitive_type primitive_t;
integer_type integer_t;
double_type double_t;
- string_type string_t;
} common_type;
+/* Utility functions */
+void **vpbuffer_realloc(void **buf, int *len);
+void **vpbuffer_add(void **buf, int *len, int i, void *obj);
+void vpbuffer_free(void **buf);
+
+/* GC prototypes */
+void gc_initialize();
+void gc_add_mutator(gc_thread_data *thd);
+void gc_remove_mutator(gc_thread_data *thd);
+gc_heap *gc_heap_create(size_t size, size_t max_size, size_t chunk_size);
+int gc_grow_heap(gc_heap *h, size_t size, size_t chunk_size);
+char *gc_copy_obj(object hp, char *obj, gc_thread_data *thd);
+void *gc_try_alloc(gc_heap *h, size_t size, char *obj, gc_thread_data *thd);
+void *gc_alloc(gc_heap *h, size_t size, char *obj, gc_thread_data *thd, int *heap_grown);
+size_t gc_allocated_bytes(object obj, gc_free_list *q, gc_free_list *r);
+gc_heap *gc_heap_last(gc_heap *h);
+size_t gc_heap_total_size(gc_heap *h);
+//size_t gc_heap_total_free_size(gc_heap *h);
+//size_t gc_collect(gc_heap *h, size_t *sum_freed);
+//void gc_mark(gc_heap *h, object obj);
+void gc_mark_globals(void);
+size_t gc_sweep(gc_heap *h, size_t *sum_freed_ptr);
+void gc_thr_grow_move_buffer(gc_thread_data *d);
+void gc_thr_add_to_move_buffer(gc_thread_data *d, int *alloci, object obj);
+void gc_thread_data_init(gc_thread_data *thd, int mut_num, char *stack_base, long stack_size);
+void gc_thread_data_free(gc_thread_data *thd);
+// Prototypes for mutator/collector:
+int gc_is_stack_obj(gc_thread_data *thd, object obj);
+void gc_mut_update(gc_thread_data *thd, object old_obj, object value);
+void gc_mut_cooperate(gc_thread_data *thd, int buf_len);
+void gc_mark_gray(gc_thread_data *thd, object obj);
+void gc_mark_gray2(gc_thread_data *thd, object obj);
+void gc_collector_trace();
+void gc_mark_black(object obj);
+void gc_collector_mark_gray(object parent, object obj);
+void gc_empty_collector_stack();
+void gc_handshake(gc_status_type s);
+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);
+gc_heap *gc_get_heap();
+int gc_minor(void *data, object low_limit, object high_limit, closure cont, object *args, int num_args);
+
+void add_mutation(void *data, object var, object value);
+void clear_mutations(void *data);
#endif /* CYCLONE_TYPES_H */
diff --git a/runtime.c b/runtime.c
index c1d2fcd7..266de942 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1,13 +1,27 @@
/**
* Cyclone Scheme
- * Copyright (c) 2014, Justin Ethier
+ * Copyright (c) 2014-2016, Justin Ethier
* All rights reserved.
*
* This file contains the C runtime used by compiled programs.
*/
+#include
+#include
#include "cyclone/types.h"
#include "cyclone/runtime.h"
+#include "cyclone/ck_ht_hash.h"
+//#include // TODO: only used for debugging!
+
+//int JAE_DEBUG = 0;
+//int gcMoveCountsDEBUG[20] = {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0};
+
+object Cyc_global_set(void *thd, object *glo, object value)
+{
+ gc_mut_update((gc_thread_data *)thd, *glo, value);
+ *(glo) = value;
+ return value;
+}
/* Error checking section - type mismatch, num args, etc */
/* Type names to use for error messages */
@@ -31,109 +45,166 @@ const char *tag_names[21] = { \
, "C primitive" \
, "vector" \
, "macro" \
- , "Reserved for future use" \
+ , "mutex" \
, "Reserved for future use" };
-void Cyc_invalid_type_error(int tag, object found) {
+void Cyc_invalid_type_error(void *data, int tag, object found) {
char buf[256];
- snprintf(buf, 255, "Invalid type: expected %s, found", tag_names[tag]);
- Cyc_rt_raise2(buf, found);
+ snprintf(buf, 255, "Invalid type: expected %s, found ", tag_names[tag]);
+ //snprintf(buf, 255, "Invalid type: expected %s, found (%p) ", tag_names[tag], found);
+ Cyc_rt_raise2(data, buf, found);
}
-void Cyc_check_obj(int tag, object obj) {
+void Cyc_check_obj(void *data, int tag, object obj) {
if (!is_object_type(obj)) {
- Cyc_invalid_type_error(tag, obj);
+ Cyc_invalid_type_error(data, tag, obj);
}
}
-void Cyc_check_bounds(const char *label, int len, int index) {
+void Cyc_check_bounds(void *data, const char *label, int len, int index) {
if (index < 0 || index >= len) {
char buf[128];
snprintf(buf, 127, "%s - invalid index %d", label, index);
- Cyc_rt_raise_msg(buf);
+ Cyc_rt_raise_msg(data, buf);
}
}
/* END error checking */
/* These macros are hardcoded here to support functions in this module. */
-#define closcall1(cfn,a1) if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(0, (closure)a1, cfn); } else { ((cfn)->fn)(1,cfn,a1);}
+#define closcall1(td,cfn,a1) if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(td,0, (closure)a1, cfn); } else { ((cfn)->fn)(td,1,cfn,a1);}
/* Return to continuation after checking for stack overflow. */
-#define return_closcall1(cfn,a1) \
+#define return_closcall1(td,cfn,a1) \
{char stack; \
- if (check_overflow(&stack,stack_limit1)) { \
+ if (check_overflow(&stack,(((gc_thread_data *)data)->stack_limit))) { \
object buf[1]; buf[0] = a1;\
- GC(cfn,buf,1); return; \
- } else {closcall1((closure) (cfn),a1); return;}}
-#define closcall2(cfn,a1,a2) if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(1, (closure)a1, cfn,a2); } else { ((cfn)->fn)(2,cfn,a1,a2);}
+ GC(td,cfn,buf,1); return; \
+ } else {closcall1(td,(closure) (cfn),a1); return;}}
+#define closcall2(td,cfn,a1,a2) if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(td,1, (closure)a1, cfn,a2); } else { ((cfn)->fn)(td,2,cfn,a1,a2);}
/* Return to continuation after checking for stack overflow. */
-#define return_closcall2(cfn,a1,a2) \
+#define return_closcall2(td,cfn,a1,a2) \
{char stack; \
- if (check_overflow(&stack,stack_limit1)) { \
+ if (check_overflow(&stack,(((gc_thread_data *)data)->stack_limit))) { \
object buf[2]; buf[0] = a1;buf[1] = a2;\
- GC(cfn,buf,2); return; \
- } else {closcall2((closure) (cfn),a1,a2); return;}}
+ GC(td,cfn,buf,2); return; \
+ } else {closcall2(td,(closure) (cfn),a1,a2); return;}}
/*END closcall section */
/* Global variables. */
-clock_t start; /* Starting time. */
-char *stack_begin; /* Initialized by main. */
-char *stack_limit1; /* Initialized by main. */
-char *stack_limit2;
-char *bottom; /* Bottom of tospace. */
-char *allocp; /* Cheney allocate pointer. */
-char *alloc_end;
-/* TODO: not sure this is the best strategy for strings, especially if there
- are a lot of long, later gen strings because that will cause a lot of
- copying to occur during GC */
-char *dhbottom; /* Bottom of data heap */
-char *dhallocp; /* Current place in data heap */
-char *dhalloc_limit; /* GC beyond this limit */
-char *dhalloc_end;
+static gc_heap *Cyc_heap;
long no_gcs = 0; /* Count the number of GC's. */
long no_major_gcs = 0; /* Count the number of GC's. */
-object gc_cont; /* GC continuation closure. */
-object gc_ans[NUM_GC_ANS]; /* argument for GC continuation closure. */
-int gc_num_ans;
-jmp_buf jmp_main; /* Where to jump to. */
object Cyc_global_variables = nil;
int _cyc_argc = 0;
char **_cyc_argv = NULL;
-static symbol_type __EOF = {eof_tag, "", nil}; // symbol_type in lieu of custom type
+static symbol_type __EOF = {{0}, eof_tag, "", nil}; // symbol_type in lieu of custom type
const object Cyc_EOF = &__EOF;
+static ck_hs_t symbol_table;
+static int symbol_table_size = 65536;
+static pthread_mutex_t symbol_table_lock;
+
+// Functions to support concurrency kit hashset
+// These are specifically for a table of symbols
+static void *hs_malloc(size_t r)
+{
+ return malloc(r);
+}
+
+static void hs_free(void *p, size_t b, bool r)
+{
+// (void)b;
+// (void)r;
+ free(p);
+// return;
+}
+
+static struct ck_malloc my_allocator = {
+ .malloc = hs_malloc,
+ .free = hs_free
+};
+
+static unsigned long hs_hash(const void *object, unsigned long seed)
+{
+ const symbol_type *c = object;
+ unsigned long h;
+
+ h = (unsigned long)MurmurHash64A(c->pname, strlen(c->pname), seed);
+ return h;
+}
+
+static bool hs_compare(const void *previous, const void *compare)
+{
+ return strcmp(symbol_pname(previous), symbol_pname(compare)) == 0;
+}
+
+static void *set_get(ck_hs_t *hs, const void *value)
+{
+ unsigned long h;
+ void *v;
+
+ h = CK_HS_HASH(hs, hs_hash, value);
+ v = ck_hs_get(hs, h, value);
+ return v;
+}
+
+static bool set_insert(ck_hs_t *hs, const void *value)
+{
+ unsigned long h;
+
+ h = CK_HS_HASH(hs, hs_hash, value);
+ return ck_hs_put(hs, h, value);
+}
+// End supporting functions
+
+void gc_init_heap(long heap_size)
+{
+ Cyc_heap = gc_heap_create(heap_size, 0, 0);
+ if (!ck_hs_init(&symbol_table,
+ CK_HS_MODE_OBJECT | CK_HS_MODE_SPMC,
+ hs_hash, hs_compare,
+ &my_allocator,
+ symbol_table_size,
+ 43423)){
+ fprintf(stderr, "Unable to initialize symbol table\n");
+ exit(1);
+ }
+ if (pthread_mutex_init(&(symbol_table_lock), NULL) != 0) {
+ fprintf(stderr, "Unable to initialize symbol_table_lock mutex\n");
+ exit(1);
+ }
+}
+
+gc_heap *gc_get_heap()
+{
+ return Cyc_heap;
+}
object cell_get(object cell){
return car(cell);
}
-static boolean_type t_boolean = {boolean_tag, "t"};
-static boolean_type f_boolean = {boolean_tag, "f"};
+static boolean_type t_boolean = {{0}, boolean_tag, "t"};
+static boolean_type f_boolean = {{0}, boolean_tag, "f"};
const object boolean_t = &t_boolean;
const object boolean_f = &f_boolean;
-static symbol_type Cyc_void_symbol = {symbol_tag, "", nil};
+static symbol_type Cyc_void_symbol = {{0}, symbol_tag, "", nil};
const object quote_void = &Cyc_void_symbol;
/* Stack Traces */
-static const int MAX_STACK_TRACES = 10;
-static char **Cyc_Stack_Traces;
-static int Cyc_Stack_Trace_Idx = 0;
-
-void Cyc_st_init() {
- Cyc_Stack_Traces = calloc(MAX_STACK_TRACES, sizeof(char *));
-}
-
-void Cyc_st_add(char *frame) {
+void Cyc_st_add(void *data, char *frame) {
+ gc_thread_data *thd = (gc_thread_data *)data;
// Do not allow recursion to remove older frames
- if (frame != Cyc_Stack_Traces[(Cyc_Stack_Trace_Idx - 1) % MAX_STACK_TRACES]) {
- Cyc_Stack_Traces[Cyc_Stack_Trace_Idx] = frame;
- Cyc_Stack_Trace_Idx = (Cyc_Stack_Trace_Idx + 1) % MAX_STACK_TRACES;
+ if (frame != thd->stack_prev_frame) {
+ 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;
}
}
-void Cyc_st_print(FILE *out) {
+void Cyc_st_print(void *data, FILE *out) {
/* print to stream, note it is possible that
some traces could be on the stack after a GC.
not sure what to do about it, may need to
@@ -141,10 +212,11 @@ void Cyc_st_print(FILE *out) {
or, with the tbl being so small, maybe it will
not be an issue in practice? a bit risky to ignore though
*/
- int i = (Cyc_Stack_Trace_Idx + 1) % MAX_STACK_TRACES;
- while (i != Cyc_Stack_Trace_Idx) {
- if (Cyc_Stack_Traces[i]) {
- fprintf(out, "%s\n", Cyc_Stack_Traces[i]);
+ gc_thread_data *thd = (gc_thread_data *)data;
+ int i = (thd->stack_trace_idx + 1) % MAX_STACK_TRACES;
+ while (i != thd->stack_trace_idx) {
+ if (thd->stack_traces[i]) {
+ fprintf(out, "%s\n", thd->stack_traces[i]);
}
i = (i + 1) % MAX_STACK_TRACES;
}
@@ -162,8 +234,6 @@ void Cyc_st_print(FILE *out) {
For now, GC of symbols is missing. long-term it probably would be desirable
*/
-list symbol_table = nil;
-
char *_strdup (const char *s) {
char *d = malloc (strlen (s) + 1);
if (d) { strcpy (d,s); }
@@ -171,21 +241,29 @@ char *_strdup (const char *s) {
}
object find_symbol_by_name(const char *name) {
- list l = symbol_table;
- for (; !nullp(l); l = cdr(l)) {
- const char *str = symbol_pname(car(l));
- if (strcmp(str, name) == 0) return car(l);
- }
- return nil;
+ symbol_type tmp = {{0}, symbol_tag, name, nil};
+ object result = set_get(&symbol_table, &tmp);
+ //if (result) {
+ // printf("found symbol %s\n", symbol_pname(result));
+ //}
+ return result;
}
object add_symbol(symbol_type *psym) {
- symbol_table = mcons(psym, symbol_table);
+ //printf("Adding symbol %s, table size = %ld\n", symbol_pname(psym), ck_hs_count(&symbol_table));
+ pthread_mutex_lock(&symbol_table_lock); // Only 1 "writer" allowed
+ if (ck_hs_count(&symbol_table) == symbol_table_size) {
+ // TODO: grow table if it is not big enough
+ fprintf(stderr, "Ran out of symbol table entries\n");
+ exit(1);
+ }
+ set_insert(&symbol_table, psym);
+ pthread_mutex_unlock(&symbol_table_lock);
return psym;
}
object add_symbol_by_name(const char *name) {
- symbol_type sym = {symbol_tag, _strdup(name), nil};
+ symbol_type sym = {{0}, symbol_tag, _strdup(name), nil};
symbol_type *psym = malloc(sizeof(symbol_type));
memcpy(psym, &sym, sizeof(symbol_type));
return add_symbol(psym);
@@ -199,6 +277,7 @@ object find_or_add_symbol(const char *name){
return add_symbol_by_name(name);
}
}
+
/* END symbol table */
/* Global table */
@@ -210,32 +289,56 @@ void add_global(object *glo) {
// this is more expedient
global_table = mcons(mcvar(glo), global_table);
}
+
+void debug_dump_globals()
+{
+ list l = global_table;
+ for(; !nullp(l); l = cdr(l)){
+ cvar_type *c = (cvar_type *)car(l);
+ //gc_mark(h, *(c->pvar)); // Mark actual object the global points to
+ printf("DEBUG %p ", c->pvar);
+ if (*c->pvar){
+ printf("mark = %d ", mark(*c->pvar));
+ if (mark(*c->pvar) == gc_color_red) {
+ printf("obj = ");
+ Cyc_display(*c->pvar, stdout);
+ }
+ printf("\n");
+ } else {
+ printf(" is NULL\n");
+ }
+ }
+}
+
/* END Global table */
-/* Mutation table
+/* Mutation table functions
*
* Keep track of mutations (EG: set-car!) so that new
* values are transported to the heap during GC.
+ * Note these functions and underlying data structure are only used by
+ * the calling thread, so locking is not required.
*/
-list mutation_table = nil;
-void add_mutation(object var, object value){
+void add_mutation(void *data, object var, object value){
+ gc_thread_data *thd = (gc_thread_data *)data;
if (is_object_type(value)) {
- mutation_table = mcons(var, mutation_table);
+ thd->mutations = mcons(var, thd->mutations);
}
}
/* TODO: consider a more efficient implementation, such as reusing old nodes
instead of reclaiming them each time
*/
-void clear_mutations() {
- list l = mutation_table, next;
+void clear_mutations(void *data) {
+ gc_thread_data *thd = (gc_thread_data *)data;
+ list l = thd->mutations, next;
while (!nullp(l)) {
next = cdr(l);
free(l);
l = next;
}
- mutation_table = nil;
+ thd->mutations = nil;
}
/* END mutation table */
@@ -246,7 +349,7 @@ object Cyc_glo_eval = nil;
/* Exception handler */
object Cyc_exception_handler_stack = nil;
-object Cyc_default_exception_handler(int argc, closure _, object err) {
+object Cyc_default_exception_handler(void *data, int argc, closure _, object err) {
fprintf(stderr, "Error: ");
if (nullp(err) || is_value_type(err) || type_of(err) != cons_tag) {
@@ -261,8 +364,9 @@ object Cyc_default_exception_handler(int argc, closure _, object err) {
}
fprintf(stderr, "\nCall history:\n");
- Cyc_st_print(stderr);
+ Cyc_st_print(data, stderr);
fprintf(stderr, "\n");
+ //raise(SIGINT); // break into debugger, unix only
exit(1);
return nil;
}
@@ -276,29 +380,29 @@ object Cyc_current_exception_handler() {
}
/* Raise an exception from the runtime code */
-void Cyc_rt_raise(object err) {
+void Cyc_rt_raise(void *data, object err) {
make_cons(c2, err, nil);
make_cons(c1, boolean_f, &c2);
make_cons(c0, &c1, nil);
- apply(nil, Cyc_current_exception_handler(), &c0);
+ apply(data, nil, Cyc_current_exception_handler(), &c0);
// Should never get here
fprintf(stderr, "Internal error in Cyc_rt_raise\n");
exit(1);
}
-void Cyc_rt_raise2(const char *msg, object err) {
+void Cyc_rt_raise2(void *data, const char *msg, object err) {
make_string(s, msg);
make_cons(c3, err, nil);
make_cons(c2, &s, &c3);
make_cons(c1, boolean_f, &c2);
make_cons(c0, &c1, nil);
- apply(nil, Cyc_current_exception_handler(), &c0);
+ apply(data, nil, Cyc_current_exception_handler(), &c0);
// Should never get here
fprintf(stderr, "Internal error in Cyc_rt_raise2\n");
exit(1);
}
-void Cyc_rt_raise_msg(const char *err) {
+void Cyc_rt_raise_msg(void *data, const char *err) {
make_string(s, err);
- Cyc_rt_raise(&s);
+ Cyc_rt_raise(data, &s);
}
/* END exception handler */
@@ -384,13 +488,13 @@ object Cyc_has_cycle(object lst) {
// to the value returned by (current-output-port). It is an
// error to attempt an output operation on a closed port
//
-object dispatch_display_va(int argc, object clo, object cont, object x, ...) {
+object dispatch_display_va(void *data, int argc, object clo, object cont, object x, ...) {
object result;
va_list ap;
va_start(ap, x);
result = Cyc_display_va_list(argc - 1, x, ap);
va_end(ap);
- return_closcall1(cont, result);
+ return_closcall1(data, cont, result);
}
object Cyc_display_va(int argc, object x, ...) {
@@ -441,6 +545,9 @@ object Cyc_display(object x, FILE *port)
case cvar_tag:
Cyc_display(Cyc_get_cvar(x), port);
break;
+ case mutex_tag:
+ fprintf(port, "", x);
+ break;
case boolean_tag:
fprintf(port, "#%s",((boolean_type *) x)->pname);
break;
@@ -498,16 +605,18 @@ object Cyc_display(object x, FILE *port)
fprintf(port, ")");
break;
default:
- fprintf(port, "Cyc_display: bad tag x=%ld\n", ((closure)x)->tag); getchar(); exit(0);}
+ fprintf(port, "Cyc_display: bad tag x=%ld\n", ((closure)x)->tag);
+ exit(1);
+ }
return quote_void;}
-object dispatch_write_va(int argc, object clo, object cont, object x, ...) {
+object dispatch_write_va(void *data, int argc, object clo, object cont, object x, ...) {
object result;
va_list ap;
va_start(ap, x);
result = Cyc_write_va_list(argc - 1, x, ap);
va_end(ap);
- return_closcall1(cont, result);
+ return_closcall1(data, cont, result);
}
object Cyc_write_va(int argc, object x, ...) {
@@ -580,24 +689,24 @@ object Cyc_write(object x, FILE *port)
fprintf(port, "\n");
return y;}
-object Cyc_write_char(object c, object port)
+object Cyc_write_char(void *data, object c, object port)
{
if (obj_is_char(c)) {
fprintf(((port_type *)port)->fp, "%c", obj_obj2char(c));
} else {
- Cyc_rt_raise2("Argument is not a character", c);
+ Cyc_rt_raise2(data, "Argument is not a character", c);
}
return quote_void;
}
// TODO: should not be a predicate, may end up moving these to Scheme code
-object memberp(x,l) object x; list l;
-{Cyc_check_cons_or_nil(l);
+object memberp(void *data, object x, list l)
+{Cyc_check_cons_or_nil(data, l);
for (; !nullp(l); l = cdr(l)) if (boolean_f != equalp(x,car(l))) return boolean_t;
return boolean_f;}
-object memqp(x,l) object x; list l;
-{Cyc_check_cons_or_nil(l);
+object memqp(void *data, object x, list l)
+{Cyc_check_cons_or_nil(data, l);
for (; !nullp(l); l = cdr(l)) if (eq(x,car(l))) return boolean_t;
return boolean_f;}
@@ -619,55 +728,55 @@ object equalp(x,y) object x,y;
type_of(x)!=cons_tag || type_of(y)!=cons_tag) return boolean_f;
if (boolean_f == equalp(car(x),car(y))) return boolean_f;}}
-list assq(x,l) object x; list l;
+list assq(void *data, object x, list l)
{if (nullp(l) || is_value_type(l) || type_of(l) != cons_tag) return boolean_f;
for (; !nullp(l); l = cdr(l))
{register list la = car(l);
- Cyc_check_cons(la);
+ Cyc_check_cons(data, la);
if (eq(x,car(la))) return la;}
return boolean_f;}
-list assoc(x,l) object x; list l;
+list assoc(void *data, object x, list l)
{if (nullp(l) || is_value_type(l) || type_of(l) != cons_tag) return boolean_f;
for (; !nullp(l); l = cdr(l))
{register list la = car(l);
- Cyc_check_cons(la);
+ Cyc_check_cons(data, la);
if (boolean_f != equalp(x,car(la))) return la;}
return boolean_f;}
// TODO: generate these using macros???
-object __num_eq(x, y) object x, y;
-{Cyc_check_num(x);
- Cyc_check_num(y);
+object __num_eq(void *data, object x, object y)
+{Cyc_check_num(data, x);
+ Cyc_check_num(data, y);
if (((integer_type *)x)->value == ((integer_type *)y)->value)
return boolean_t;
return boolean_f;}
-object __num_gt(x, y) object x, y;
-{Cyc_check_num(x);
- Cyc_check_num(y);
+object __num_gt(void *data, object x, object y)
+{Cyc_check_num(data, x);
+ Cyc_check_num(data, y);
if (((integer_type *)x)->value > ((integer_type *)y)->value)
return boolean_t;
return boolean_f;}
-object __num_lt(x, y) object x, y;
-{Cyc_check_num(x);
- Cyc_check_num(y);
+object __num_lt(void *data, object x, object y)
+{Cyc_check_num(data, x);
+ Cyc_check_num(data, y);
if (((integer_type *)x)->value < ((integer_type *)y)->value)
return boolean_t;
return boolean_f;}
-object __num_gte(x, y) object x, y;
-{Cyc_check_num(x);
- Cyc_check_num(y);
+object __num_gte(void *data, object x, object y)
+{Cyc_check_num(data, x);
+ Cyc_check_num(data, y);
if (((integer_type *)x)->value >= ((integer_type *)y)->value)
return boolean_t;
return boolean_f;}
-object __num_lte(x, y) object x, y;
-{Cyc_check_num(x);
- Cyc_check_num(y);
+object __num_lte(void *data, object x, object y)
+{Cyc_check_num(data, x);
+ Cyc_check_num(data, y);
if (((integer_type *)x)->value <= ((integer_type *)y)->value)
return boolean_t;
return boolean_f;}
@@ -720,6 +829,11 @@ object Cyc_is_port(object o){
return boolean_t;
return boolean_f;}
+object Cyc_is_mutex(object o){
+ if (!nullp(o) && !is_value_type(o) && ((list)o)->tag == mutex_tag)
+ return boolean_t;
+ return boolean_f;}
+
object Cyc_is_string(object o){
if (!nullp(o) && !is_value_type(o) && ((list)o)->tag == string_tag)
return boolean_t;
@@ -730,7 +844,7 @@ object Cyc_is_char(object o){
return boolean_t;
return boolean_f;}
-object Cyc_is_procedure(object o) {
+object Cyc_is_procedure(void *data, object o) {
int tag;
if (!nullp(o) && !is_value_type(o)) {
tag = type_of(o);
@@ -743,7 +857,7 @@ object Cyc_is_procedure(object o) {
tag == primitive_tag) {
return boolean_t;
} else if (tag == cons_tag) {
- integer_type l = Cyc_length(o);
+ integer_type l = Cyc_length(data, o);
if (l.value > 0 && Cyc_is_symbol(car(o)) == boolean_t) {
if (strncmp(((symbol)car(o))->pname, "primitive", 10) == 0 ||
strncmp(((symbol)car(o))->pname, "procedure", 10) == 0 ) {
@@ -782,63 +896,69 @@ object Cyc_eq(object x, object y) {
return boolean_f;
}
-object Cyc_set_car(object l, object val) {
- if (Cyc_is_cons(l) == boolean_f) Cyc_invalid_type_error(cons_tag, l);
+object Cyc_set_car(void *data, object l, object val) {
+ if (Cyc_is_cons(l) == boolean_f) Cyc_invalid_type_error(data, cons_tag, l);
+ gc_mut_update((gc_thread_data *)data, car(l), val);
car(l) = val;
- add_mutation(l, val);
+ add_mutation(data, l, val);
return l;
}
-object Cyc_set_cdr(object l, object val) {
- if (Cyc_is_cons(l) == boolean_f) Cyc_invalid_type_error(cons_tag, l);
+object Cyc_set_cdr(void *data, object l, object val) {
+ if (Cyc_is_cons(l) == boolean_f) Cyc_invalid_type_error(data, cons_tag, l);
+ gc_mut_update((gc_thread_data *)data, cdr(l), val);
cdr(l) = val;
- add_mutation(l, val);
+ add_mutation(data, l, val);
return l;
}
-object Cyc_vector_set(object v, object k, object obj) {
+object Cyc_vector_set(void *data, object v, object k, object obj) {
int idx;
- Cyc_check_vec(v);
- Cyc_check_int(k);
+ Cyc_check_vec(data, v);
+ Cyc_check_int(data, k);
idx = ((integer_type *)k)->value;
if (idx < 0 || idx >= ((vector)v)->num_elt) {
- Cyc_rt_raise2("vector-set! - invalid index", k);
+ Cyc_rt_raise2(data, "vector-set! - invalid index", k);
}
+ gc_mut_update((gc_thread_data *)data,
+ ((vector)v)->elts[idx],
+ obj);
+
((vector)v)->elts[idx] = obj;
// TODO: probably could be more efficient here and also pass
// index, so only that one entry needs GC.
- add_mutation(v, obj);
+ add_mutation(data, v, obj);
return v;
}
-object Cyc_vector_ref(object v, object k) {
+object Cyc_vector_ref(void *data, object v, object k) {
if (nullp(v) || is_value_type(v) || ((list)v)->tag != vector_tag) {
- Cyc_rt_raise_msg("vector-ref - invalid parameter, expected vector\n");
+ Cyc_rt_raise_msg(data, "vector-ref - invalid parameter, expected vector\n");
}
if (nullp(k) || is_value_type(k) || ((list)k)->tag != integer_tag) {
- Cyc_rt_raise_msg("vector-ref - invalid parameter, expected integer\n");
+ Cyc_rt_raise_msg(data, "vector-ref - invalid parameter, expected integer\n");
}
if (integer_value(k) < 0 || integer_value(k) >= ((vector)v)->num_elt) {
- Cyc_rt_raise2("vector-ref - invalid index", k);
+ Cyc_rt_raise2(data, "vector-ref - invalid index", k);
}
return ((vector)v)->elts[((integer_type *)k)->value];
}
-integer_type Cyc_vector_length(object v) {
+integer_type Cyc_vector_length(void *data, object v) {
if (!nullp(v) && !is_value_type(v) && ((list)v)->tag == vector_tag) {
make_int(len, ((vector)v)->num_elt);
return len;
}
- Cyc_rt_raise_msg("vector-length - invalid parameter, expected vector\n"); }
+ Cyc_rt_raise_msg(data, "vector-length - invalid parameter, expected vector\n"); }
-integer_type Cyc_length(object l){
+integer_type Cyc_length(void *data, object l){
make_int(len, 0);
while(!nullp(l)){
if (is_value_type(l) || ((list)l)->tag != cons_tag){
- Cyc_rt_raise_msg("length - invalid parameter, expected list\n");
+ Cyc_rt_raise_msg(data, "length - invalid parameter, expected list\n");
}
l = cdr(l);
len.value++;
@@ -846,28 +966,30 @@ integer_type Cyc_length(object l){
return len;
}
-string_type Cyc_number2string(object n) {
+object Cyc_number2string(void *data, object cont, object n) {
char buffer[1024];
- Cyc_check_num(n);
+ Cyc_check_num(data, n);
if (type_of(n) == integer_tag) {
snprintf(buffer, 1024, "%d", ((integer_type *)n)->value);
} else if (type_of(n) == double_tag) {
snprintf(buffer, 1024, "%lf", ((double_type *)n)->value);
} else {
- Cyc_rt_raise2("number->string - Unexpected object", n);
+ Cyc_rt_raise2(data, "number->string - Unexpected object", n);
}
+ //make_string_noalloc(str, buffer, strlen(buffer));
make_string(str, buffer);
- return str;
+ return_closcall1(data, cont, &str);
}
-string_type Cyc_symbol2string(object sym) {
- Cyc_check_sym(sym);
- { make_string(str, symbol_pname(sym));
- return str; }}
+object Cyc_symbol2string(void *data, object cont, object sym) {
+ Cyc_check_sym(data, sym);
+ { const char *pname = symbol_pname(sym);
+ make_string(str, pname);
+ return_closcall1(data, cont, &str); }}
-object Cyc_string2symbol(object str) {
+object Cyc_string2symbol(void *data, object str) {
object sym;
- Cyc_check_str(str);
+ Cyc_check_str(data, str);
sym = find_symbol_by_name(string_str(str));
if (!sym) {
sym = add_symbol_by_name(string_str(str));
@@ -875,14 +997,14 @@ object Cyc_string2symbol(object str) {
return sym;
}
-string_type Cyc_list2string(object lst){
+object Cyc_list2string(void *data, object cont, object lst){
char *buf;
int i = 0;
integer_type len;
- Cyc_check_cons_or_nil(lst);
+ Cyc_check_cons_or_nil(data, lst);
- len = Cyc_length(lst); // Inefficient, walks whole list
+ len = Cyc_length(data, lst); // Inefficient, walks whole list
buf = alloca(sizeof(char) * (len.value + 1));
while(!nullp(lst)){
buf[i++] = obj_obj2char(car(lst));
@@ -890,24 +1012,29 @@ string_type Cyc_list2string(object lst){
}
buf[i] = '\0';
- make_string(str, buf);
- return str;
+ //{ make_string_noalloc(str, buf, i);
+ { make_string(str, buf);
+ return_closcall1(data, cont, &str);}
}
-common_type Cyc_string2number(object str){
+common_type Cyc_string2number(void *data, object str){
common_type result;
double n;
- Cyc_check_obj(string_tag, str);
- Cyc_check_str(str);
+ Cyc_check_obj(data, string_tag, str);
+ Cyc_check_str(data, str);
if (type_of(str) == string_tag &&
((string_type *) str)->str){
n = atof(((string_type *) str)->str);
if (ceilf(n) == n) {
+ result.integer_t.hdr.mark = gc_color_red;
+ result.integer_t.hdr.grayed = 0;
result.integer_t.tag = integer_tag;
result.integer_t.value = (int)n;
}
else {
+ result.double_t.hdr.mark = gc_color_red;
+ result.double_t.hdr.grayed = 0;
result.double_t.tag = double_tag;
result.double_t.value = n;
}
@@ -919,9 +1046,9 @@ common_type Cyc_string2number(object str){
return result;
}
-integer_type Cyc_string_cmp(object str1, object str2) {
- Cyc_check_str(str1);
- Cyc_check_str(str2);
+integer_type Cyc_string_cmp(void *data, object str1, object str2) {
+ Cyc_check_str(data, str1);
+ Cyc_check_str(data, str2);
{
make_int(cmp, strcmp(((string_type *)str1)->str,
((string_type *)str2)->str));
@@ -929,112 +1056,98 @@ integer_type Cyc_string_cmp(object str1, object str2) {
}
}
-void dispatch_string_91append(int argc, object clo, object cont, object str1, ...) {
- string_type result;
+#define Cyc_string_append_va_list(data, argc) { \
+ int i = 0, total_len = 1; \
+ int *len = alloca(sizeof(int) * argc); \
+ char *buffer, *bufferp, **str = alloca(sizeof(char *) * argc); \
+ object tmp; \
+ if (argc > 0) { \
+ Cyc_check_str(data, str1); \
+ str[i] = ((string_type *)str1)->str; \
+ len[i] = strlen(str[i]); \
+ total_len += len[i]; \
+ } \
+ for (i = 1; i < argc; i++) { \
+ tmp = va_arg(ap, object); \
+ Cyc_check_str(data, tmp); \
+ str[i] = ((string_type *)tmp)->str; \
+ len[i] = strlen(str[i]); \
+ total_len += len[i]; \
+ } \
+ buffer = bufferp = alloca(sizeof(char) * total_len); \
+ for (i = 0; i < argc; i++) { \
+ memcpy(bufferp, str[i], len[i]); \
+ bufferp += len[i]; \
+ } \
+ *bufferp = '\0'; \
+ make_string(result, buffer); \
+ va_end(ap); \
+ return_closcall1(data, cont, &result); \
+}
+
+void dispatch_string_91append(void *data, int _argc, object clo, object cont, object str1, ...) {
va_list ap;
va_start(ap, str1);
- result = Cyc_string_append_va_list(argc - 1, str1, ap);
- va_end(ap);
- return_closcall1(cont, &result);
+ Cyc_string_append_va_list(data, _argc - 1);
}
-string_type Cyc_string_append(int argc, object str1, ...) {
- string_type result;
+object Cyc_string_append(void *data, object cont, int _argc, object str1, ...) {
va_list ap;
va_start(ap, str1);
- result = Cyc_string_append_va_list(argc, str1, ap);
- va_end(ap);
- return result;
+ Cyc_string_append_va_list(data, _argc);
}
-string_type Cyc_string_append_va_list(int argc, object str1, va_list ap) {
- // TODO: one way to do this, perhaps not the most efficient:
- // compute lengths of the strings,
- // store lens and str ptrs
- // allocate buffer, memcpy each str to buffer
- // make_string using buffer
-
- int i = 0, total_len = 1; // for null char
- int *len = alloca(sizeof(int) * argc);
- char *buffer, *bufferp, **str = alloca(sizeof(char *) * argc);
- object tmp;
-
- if (argc > 0) {
- Cyc_check_str(str1);
- str[i] = ((string_type *)str1)->str;
- len[i] = strlen(str[i]);
- total_len += len[i];
- }
-
- for (i = 1; i < argc; i++) {
- tmp = va_arg(ap, object);
- Cyc_check_str(tmp);
- str[i] = ((string_type *)tmp)->str;
- len[i] = strlen(str[i]);
- total_len += len[i];
- }
-
- buffer = bufferp = alloca(sizeof(char) * total_len);
- for (i = 0; i < argc; i++) {
- memcpy(bufferp, str[i], len[i]);
- bufferp += len[i];
- }
- *bufferp = '\0';
- make_string(result, buffer);
- return result;
-}
-
-integer_type Cyc_string_length(object str) {
- Cyc_check_obj(string_tag, str);
- Cyc_check_str(str);
+integer_type Cyc_string_length(void *data, object str) {
+ Cyc_check_obj(data, string_tag, str);
+ Cyc_check_str(data, str);
{ make_int(len, strlen(string_str(str)));
return len; }}
-object Cyc_string_set(object str, object k, object chr) {
+object Cyc_string_set(void *data, object str, object k, object chr) {
char *raw;
int idx, len;
- Cyc_check_str(str);
- Cyc_check_int(k);
+ Cyc_check_str(data, str);
+ Cyc_check_int(data, k);
if (!eq(boolean_t, Cyc_is_char(chr))) {
- Cyc_rt_raise2("Expected char but received", chr);
+ Cyc_rt_raise2(data, "Expected char but received", chr);
}
raw = string_str(str);
idx = integer_value(k),
len = strlen(raw);
- Cyc_check_bounds("string-set!", len, idx);
+ Cyc_check_bounds(data, "string-set!", len, idx);
raw[idx] = obj_obj2char(chr);
return str;
}
-object Cyc_string_ref(object str, object k) {
+object Cyc_string_ref(void *data, object str, object k) {
const char *raw;
int idx, len;
- Cyc_check_str(str);
- Cyc_check_int(k);
+ Cyc_check_str(data, str);
+ Cyc_check_int(data, k);
raw = string_str(str);
idx = integer_value(k),
len = strlen(raw);
if (idx < 0 || idx >= len) {
- Cyc_rt_raise2("string-ref - invalid index", k);
+ Cyc_rt_raise2(data, "string-ref - invalid index", k);
}
return obj_char2obj(raw[idx]);
}
-string_type Cyc_substring(object str, object start, object end) {
+object Cyc_substring(void *data, object cont, object str, object start, object end) {
const char *raw;
int s, e, len;
- Cyc_check_str(str);
- Cyc_check_int(start);
- Cyc_check_int(end);
+ Cyc_check_str(data, str);
+ Cyc_check_int(data, start);
+ Cyc_check_int(data, end);
raw = string_str(str);
s = integer_value(start),
@@ -1042,18 +1155,18 @@ string_type Cyc_substring(object str, object start, object end) {
len = strlen(raw);
if (s > e) {
- Cyc_rt_raise2("substring - start cannot be greater than end", start);
+ Cyc_rt_raise2(data, "substring - start cannot be greater than end", start);
}
if (s > len) {
- Cyc_rt_raise2("substring - start cannot be greater than string length", start);
+ Cyc_rt_raise2(data, "substring - start cannot be greater than string length", start);
}
if (e > len) {
e = len;
}
{
- make_stringn(sub, raw + s, e - s);
- return sub;
+ make_string_with_len(sub, raw + s, e - s);
+ return_closcall1(data, cont, &sub);
}
}
@@ -1061,28 +1174,28 @@ string_type Cyc_substring(object str, object start, object end) {
* Return directory where cyclone is installed.
* This is configured via the makefile during a build.
*/
-string_type Cyc_installation_dir(object type) {
+object Cyc_installation_dir(void *data, object cont, object type) {
if (Cyc_is_symbol(type) == boolean_t &&
strncmp(((symbol)type)->pname, "sld", 5) == 0) {
char buf[1024];
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_SLD);
make_string(str, buf);
- return str;
+ return_closcall1(data, cont, &str);
} else if (Cyc_is_symbol(type) == boolean_t &&
strncmp(((symbol)type)->pname, "lib", 5) == 0) {
char buf[1024];
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_LIB);
make_string(str, buf);
- return str;
+ return_closcall1(data, cont, &str);
} else if (Cyc_is_symbol(type) == boolean_t &&
strncmp(((symbol)type)->pname, "inc", 5) == 0) {
char buf[1024];
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_INC);
make_string(str, buf);
- return str;
+ return_closcall1(data, cont, &str);
} else {
make_string(str, CYC_INSTALL_DIR);
- return str;
+ return_closcall1(data, cont, &str);
}
}
@@ -1095,7 +1208,7 @@ string_type Cyc_installation_dir(object type) {
*
* For now, runtime options are not removed.
*/
-object Cyc_command_line_arguments(object cont) {
+object Cyc_command_line_arguments(void *data, object cont) {
int i;
object lis = nil;
for (i = _cyc_argc; i > 1; i--) { // skip program name
@@ -1103,19 +1216,68 @@ object Cyc_command_line_arguments(object cont) {
object pl = alloca(sizeof(cons_type));
make_string(s, _cyc_argv[i - 1]);
memcpy(ps, &s, sizeof(string_type));
+ ((list)pl)->hdr.mark = gc_color_red;
+ ((list)pl)->hdr.grayed = 0;
((list)pl)->tag = cons_tag;
((list)pl)->cons_car = ps;
((list)pl)->cons_cdr = lis;
lis = pl;
}
- return_closcall1(cont, lis);
+ return_closcall1(data, cont, lis);
}
-object Cyc_make_vector(object cont, object len, object fill) {
+/**
+ * Create a new mutex by allocating it on the heap. This is different than
+ * other types of objects because by definition a mutex will be used by
+ * multiple threads, so no need to risk having the non-creating thread pick
+ * up a stack object ref by mistake.
+ */
+object Cyc_make_mutex(void *data) {
+ int heap_grown;
+ mutex lock;
+ mutex_type tmp;
+ tmp.hdr.mark = gc_color_red;
+ tmp.hdr.grayed = 0;
+ tmp.tag = mutex_tag;
+ lock = gc_alloc(Cyc_heap, sizeof(mutex_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
+ if (pthread_mutex_init(&(lock->lock), NULL) != 0) {
+ fprintf(stderr, "Unable to make mutex\n");
+ exit(1);
+ }
+ return lock;
+}
+
+object Cyc_mutex_lock(void *data, object cont, object obj) {
+ mutex m = (mutex) obj;
+ Cyc_check_mutex(data, obj);
+ gc_mutator_thread_blocked((gc_thread_data *)data, cont);
+ if (pthread_mutex_lock(&(m->lock)) != 0) {
+ fprintf(stderr, "Error locking mutex\n");
+ exit(1);
+ }
+ gc_mutator_thread_runnable(
+ (gc_thread_data *)data,
+ boolean_t);
+ return boolean_t;
+}
+
+object Cyc_mutex_unlock(void *data, object obj) {
+ mutex m = (mutex) obj;
+ Cyc_check_mutex(data, obj);
+ if (pthread_mutex_unlock(&(m->lock)) != 0) {
+ fprintf(stderr, "Error unlocking mutex\n");
+ exit(1);
+ }
+ return boolean_t;
+}
+
+object Cyc_make_vector(void *data, object cont, object len, object fill) {
object v = nil;
int i;
- Cyc_check_int(len);
+ Cyc_check_int(data, len);
v = alloca(sizeof(vector_type));
+ ((vector)v)->hdr.mark = gc_color_red;
+ ((vector)v)->hdr.grayed = 0;
((vector)v)->tag = vector_tag;
((vector)v)->num_elt = ((integer_type *)len)->value;
((vector)v)->elts =
@@ -1125,18 +1287,20 @@ object Cyc_make_vector(object cont, object len, object fill) {
for (i = 0; i < ((vector)v)->num_elt; i++) {
((vector)v)->elts[i] = fill;
}
- return_closcall1(cont, v);
+ return_closcall1(data, cont, v);
}
-object Cyc_list2vector(object cont, object l) {
+object Cyc_list2vector(void *data, object cont, object l) {
object v = nil;
integer_type len;
object lst = l;
int i = 0;
- Cyc_check_cons_or_nil(l);
- len = Cyc_length(l);
+ Cyc_check_cons_or_nil(data, l);
+ len = Cyc_length(data, l);
v = alloca(sizeof(vector_type));
+ ((vector)v)->hdr.mark = gc_color_red;
+ ((vector)v)->hdr.grayed = 0;
((vector)v)->tag = vector_tag;
((vector)v)->num_elt = len.value;
((vector)v)->elts =
@@ -1147,7 +1311,7 @@ object Cyc_list2vector(object cont, object l) {
((vector)v)->elts[i++] = car(lst);
lst = cdr(lst);
}
- return_closcall1(cont, v);
+ return_closcall1(data, cont, v);
}
integer_type Cyc_system(object cmd) {
@@ -1165,10 +1329,10 @@ integer_type Cyc_char2integer(object chr){
return n;
}
-object Cyc_integer2char(object n){
+object Cyc_integer2char(void *data, object n){
int val = 0;
- Cyc_check_int(n);
+ Cyc_check_int(data, n);
if (!nullp(n)) {
val = ((integer_type *) n)->value;
}
@@ -1191,16 +1355,20 @@ object __halt(object obj) {
}
#define declare_num_op(FUNC, FUNC_OP, FUNC_APPLY, OP, DIV) \
-common_type FUNC_OP(object x, object y) { \
+common_type FUNC_OP(void *data, object x, object y) { \
common_type s; \
int tx = type_of(x), ty = type_of(y); \
+ s.double_t.hdr.mark = gc_color_red; \
+ s.double_t.hdr.grayed = 0; \
s.double_t.tag = double_tag; \
if (DIV && \
((ty == integer_tag && integer_value(y) == 0) || \
(ty == double_tag && double_value(y) == 0.0))) { \
- Cyc_rt_raise_msg("Divide by zero"); \
+ Cyc_rt_raise_msg(data, "Divide by zero"); \
} \
if (tx == integer_tag && ty == integer_tag) { \
+ s.integer_t.hdr.mark = gc_color_red; \
+ s.integer_t.hdr.grayed = 0; \
s.integer_t.tag = integer_tag; \
s.integer_t.value = ((integer_type *)x)->value OP ((integer_type *)y)->value; \
} else if (tx == double_tag && ty == integer_tag) { \
@@ -1213,23 +1381,23 @@ common_type FUNC_OP(object x, object y) { \
make_string(s, "Bad argument type"); \
make_cons(c1, y, nil); \
make_cons(c0, &s, &c1); \
- Cyc_rt_raise(&c0); \
+ Cyc_rt_raise(data, &c0); \
} \
return s; \
} \
-common_type FUNC(int argc, object n, ...) { \
+common_type FUNC(void *data, int argc, object n, ...) { \
va_list ap; \
va_start(ap, n); \
- common_type result = Cyc_num_op_va_list(argc, FUNC_OP, n, ap); \
+ common_type result = Cyc_num_op_va_list(data, argc, FUNC_OP, n, ap); \
va_end(ap); \
return result; \
} \
-void FUNC_APPLY(int argc, object clo, object cont, object n, ...) { \
+void FUNC_APPLY(void *data, int argc, object clo, object cont, object n, ...) { \
va_list ap; \
va_start(ap, n); \
- common_type result = Cyc_num_op_va_list(argc - 1, FUNC_OP, n, ap); \
+ common_type result = Cyc_num_op_va_list(data, argc - 1, FUNC_OP, n, ap); \
va_end(ap); \
- return_closcall1(cont, &result); \
+ return_closcall1(data, cont, &result); \
}
declare_num_op(Cyc_sum, Cyc_sum_op, dispatch_sum, +, 0);
@@ -1239,38 +1407,48 @@ declare_num_op(Cyc_mul, Cyc_mul_op, dispatch_mul, *, 0);
// result contains a decimal component?
declare_num_op(Cyc_div, Cyc_div_op, dispatch_div, /, 1);
-common_type Cyc_num_op_va_list(int argc, common_type (fn_op(object, object)), object n, va_list ns) {
+common_type Cyc_num_op_va_list(void *data, int argc, common_type (fn_op(void *, object, object)), object n, va_list ns) {
common_type sum;
int i;
if (argc == 0) {
+ sum.integer_t.hdr.mark = gc_color_red;
+ sum.integer_t.hdr.grayed = 0;
sum.integer_t.tag = integer_tag;
sum.integer_t.value = 0;
return sum;
}
if (type_of(n) == integer_tag) {
+ sum.integer_t.hdr.mark = gc_color_red;
+ sum.integer_t.hdr.grayed = 0;
sum.integer_t.tag = integer_tag;
sum.integer_t.value = ((integer_type *)n)->value;
} else if (type_of(n) == double_tag) {
+ sum.double_t.hdr.mark = gc_color_red;
+ sum.double_t.hdr.grayed = 0;
sum.double_t.tag = double_tag;
sum.double_t.value = ((double_type *)n)->value;
} else {
make_string(s, "Bad argument type");
make_cons(c1, n, nil);
make_cons(c0, &s, &c1);
- Cyc_rt_raise(&c0);
+ Cyc_rt_raise(data, &c0);
}
for (i = 1; i < argc; i++) {
- common_type result = fn_op(&sum, va_arg(ns, object));
+ common_type result = fn_op(data, &sum, va_arg(ns, object));
if (type_of(&result) == integer_tag) {
+ sum.integer_t.hdr.mark = gc_color_red;
+ sum.integer_t.hdr.grayed = 0;
sum.integer_t.tag = integer_tag;
sum.integer_t.value = ((integer_type *) &result)->value;
} else if (type_of(&result) == double_tag) {
+ sum.double_t.hdr.mark = gc_color_red;
+ sum.double_t.hdr.grayed = 0;
sum.double_t.tag = double_tag;
sum.double_t.value = ((double_type *) &result)->value;
} else {
- Cyc_rt_raise_msg("Internal error, invalid tag in Cyc_num_op_va_list");
+ Cyc_rt_raise_msg(data, "Internal error, invalid tag in Cyc_num_op_va_list");
}
}
@@ -1294,34 +1472,34 @@ port_type Cyc_stderr() {
return p;
}
-port_type Cyc_io_open_input_file(object str) {
+port_type Cyc_io_open_input_file(void *data, object str) {
const char *fname;
- Cyc_check_str(str);
+ Cyc_check_str(data, str);
fname = ((string_type *)str)->str;
make_port(p, NULL, 1);
p.fp = fopen(fname, "r");
- if (p.fp == NULL) { Cyc_rt_raise2("Unable to open file", str); }
+ if (p.fp == NULL) { Cyc_rt_raise2(data, "Unable to open file", str); }
return p;
}
-port_type Cyc_io_open_output_file(object str) {
+port_type Cyc_io_open_output_file(void *data, object str) {
const char *fname;
- Cyc_check_str(str);
+ Cyc_check_str(data, str);
fname = ((string_type *)str)->str;
make_port(p, NULL, 0);
p.fp = fopen(fname, "w");
- if (p.fp == NULL) { Cyc_rt_raise2("Unable to open file", str); }
+ if (p.fp == NULL) { Cyc_rt_raise2(data, "Unable to open file", str); }
return p;
}
-object Cyc_io_close_input_port(object port) {
- return Cyc_io_close_port(port); }
+object Cyc_io_close_input_port(void *data, object port) {
+ return Cyc_io_close_port(data, port); }
-object Cyc_io_close_output_port(object port) {
- return Cyc_io_close_port(port); }
+object Cyc_io_close_output_port(void *data, object port) {
+ return Cyc_io_close_port(data, port); }
-object Cyc_io_close_port(object port) {
- Cyc_check_port(port);
+object Cyc_io_close_port(void *data, object port) {
+ Cyc_check_port(data, port);
{
FILE *stream = ((port_type *)port)->fp;
if (stream) fclose(stream);
@@ -1330,8 +1508,8 @@ object Cyc_io_close_port(object port) {
return port;
}
-object Cyc_io_flush_output_port(object port) {
- Cyc_check_port(port);
+object Cyc_io_flush_output_port(void *data, object port) {
+ Cyc_check_port(data, port);
{
FILE *stream = ((port_type *)port)->fp;
if (stream) {
@@ -1342,18 +1520,18 @@ object Cyc_io_flush_output_port(object port) {
return port;
}
-object Cyc_io_delete_file(object filename) {
+object Cyc_io_delete_file(void *data, object filename) {
const char *fname;
- Cyc_check_str(filename);
+ Cyc_check_str(data, filename);
fname = ((string_type *)filename)->str;
if (remove(fname) == 0)
return boolean_t; // Success
return boolean_f;
}
-object Cyc_io_file_exists(object filename) {
+object Cyc_io_file_exists(void *data, object filename) {
const char *fname;
- Cyc_check_str(filename);
+ Cyc_check_str(data, filename);
fname = ((string_type *)filename)->str;
FILE *file;
// Possibly overkill, but portable
@@ -1365,10 +1543,15 @@ object Cyc_io_file_exists(object filename) {
}
// TODO: port arg is optional! (maybe handle that in expansion section??)
-object Cyc_io_read_char(object port) {
- Cyc_check_port(port);
+object Cyc_io_read_char(void *data, object cont, object port) {
+ int c;
+ Cyc_check_port(data, port);
{
- int c = fgetc(((port_type *) port)->fp);
+ gc_mutator_thread_blocked((gc_thread_data *)data, cont);
+ c = fgetc(((port_type *) port)->fp);
+ gc_mutator_thread_runnable(
+ (gc_thread_data *)data,
+ (c != EOF) ? obj_char2obj(c) : Cyc_EOF);
if (c != EOF) {
return obj_char2obj(c);
}
@@ -1377,20 +1560,23 @@ object Cyc_io_read_char(object port) {
}
/* TODO: this function needs some work, but approximates what is needed */
-object Cyc_io_read_line(object cont, object port) {
+object Cyc_io_read_line(void *data, object cont, object port) {
FILE *stream = ((port_type *)port)->fp;
char buf[1024];
int i = 0, c;
+ gc_mutator_thread_blocked((gc_thread_data *)data, cont);
while (1) {
c = fgetc(stream);
if (c == EOF && i == 0) {
- return_closcall1(cont, Cyc_EOF);
+ gc_mutator_thread_runnable((gc_thread_data *)data, Cyc_EOF);
+ return_closcall1(data, cont, Cyc_EOF);
} else if (c == EOF || i == 1023 || c == '\n') {
buf[i] = '\0';
{
make_string(s, buf);
- return_closcall1(cont, &s);
+ gc_mutator_thread_runnable((gc_thread_data *)data, &s);
+ return_closcall1(data, cont, &s);
}
}
@@ -1399,15 +1585,19 @@ object Cyc_io_read_line(object cont, object port) {
return nil;
}
-object Cyc_io_peek_char(object port) {
+object Cyc_io_peek_char(void *data, object cont, object port) {
FILE *stream;
int c;
- Cyc_check_port(port);
+ Cyc_check_port(data, port);
{
stream = ((port_type *) port)->fp;
+ gc_mutator_thread_blocked((gc_thread_data *)data, cont);
c = fgetc(stream);
ungetc(c, stream);
+ gc_mutator_thread_runnable(
+ (gc_thread_data *)data,
+ (c != EOF) ? obj_char2obj(c) : Cyc_EOF);
if (c != EOF) {
return obj_char2obj(c);
}
@@ -1418,424 +1608,451 @@ object Cyc_io_peek_char(object port) {
/* This heap cons is used only for initialization. */
list mcons(a,d) object a,d;
{register cons_type *c = malloc(sizeof(cons_type));
+ c->hdr.mark = gc_color_red;
+ c->hdr.grayed = 0;
c->tag = cons_tag; c->cons_car = a; c->cons_cdr = d;
return c;}
cvar_type *mcvar(object *var) {
cvar_type *c = malloc(sizeof(cvar_type));
+ c->hdr.mark = gc_color_red;
+ c->hdr.grayed = 0;
c->tag = cvar_tag;
c->pvar = var;
return c;}
-void _Cyc_91global_91vars(object cont, object args){
- return_closcall1(cont, Cyc_global_variables); }
-void _car(object cont, object args) {
- Cyc_check_num_args("car", 1, args);
+void _Cyc_91global_91vars(void *data, object cont, object args){
+ return_closcall1(data, cont, Cyc_global_variables); }
+void _car(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "car", 1, args);
{ object var = car(args);
- Cyc_check_cons(var);
- return_closcall1(cont, car(var)); }}
-void _cdr(object cont, object args) {
- Cyc_check_num_args("cdr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdr(car(args))); }
-void _caar(object cont, object args) {
- Cyc_check_num_args("caar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caar(car(args))); }
-void _cadr(object cont, object args) {
- Cyc_check_num_args("cadr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cadr(car(args))); }
-void _cdar(object cont, object args) {
- Cyc_check_num_args("cdar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdar(car(args))); }
-void _cddr(object cont, object args) {
- Cyc_check_num_args("cddr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cddr(car(args))); }
-void _caaar(object cont, object args) {
- Cyc_check_num_args("caaar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caaar(car(args))); }
-void _caadr(object cont, object args) {
- Cyc_check_num_args("caadr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caadr(car(args))); }
-void _cadar(object cont, object args) {
- Cyc_check_num_args("cadar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cadar(car(args))); }
-void _caddr(object cont, object args) {
- Cyc_check_num_args("caddr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caddr(car(args))); }
-void _cdaar(object cont, object args) {
- Cyc_check_num_args("cdaar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdaar(car(args))); }
-void _cdadr(object cont, object args) {
- Cyc_check_num_args("cdadr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdadr(car(args))); }
-void _cddar(object cont, object args) {
- Cyc_check_num_args("cddar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cddar(car(args))); }
-void _cdddr(object cont, object args) {
- Cyc_check_num_args("cdddr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdddr(car(args))); }
-void _caaaar(object cont, object args) {
- Cyc_check_num_args("caaaar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caaaar(car(args))); }
-void _caaadr(object cont, object args) {
- Cyc_check_num_args("caaadr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caaadr(car(args))); }
-void _caadar(object cont, object args) {
- Cyc_check_num_args("caadar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caadar(car(args))); }
-void _caaddr(object cont, object args) {
- Cyc_check_num_args("caaddr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caaddr(car(args))); }
-void _cadaar(object cont, object args) {
- Cyc_check_num_args("cadaar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cadaar(car(args))); }
-void _cadadr(object cont, object args) {
- Cyc_check_num_args("cadadr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cadadr(car(args))); }
-void _caddar(object cont, object args) {
- Cyc_check_num_args("caddar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, caddar(car(args))); }
-void _cadddr(object cont, object args) {
- Cyc_check_num_args("cadddr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cadddr(car(args))); }
-void _cdaaar(object cont, object args) {
- Cyc_check_num_args("cdaaar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdaaar(car(args))); }
-void _cdaadr(object cont, object args) {
- Cyc_check_num_args("cdaadr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdaadr(car(args))); }
-void _cdadar(object cont, object args) {
- Cyc_check_num_args("cdadar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdadar(car(args))); }
-void _cdaddr(object cont, object args) {
- Cyc_check_num_args("cdaddr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdaddr(car(args))); }
-void _cddaar(object cont, object args) {
- Cyc_check_num_args("cddaar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cddaar(car(args))); }
-void _cddadr(object cont, object args) {
- Cyc_check_num_args("cddadr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cddadr(car(args))); }
-void _cdddar(object cont, object args) {
- Cyc_check_num_args("cdddar", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cdddar(car(args))); }
-void _cddddr(object cont, object args) {
- Cyc_check_num_args("cddddr", 1, args);
- Cyc_check_cons(car(args));
- return_closcall1(cont, cddddr(car(args))); }
-void _cons(object cont, object args) {
- Cyc_check_num_args("cons", 2, args);
+ Cyc_check_cons(data, var);
+ return_closcall1(data, cont, car(var)); }}
+void _cdr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdr(car(args))); }
+void _caar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caar(car(args))); }
+void _cadr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cadr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cadr(car(args))); }
+void _cdar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdar(car(args))); }
+void _cddr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cddr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cddr(car(args))); }
+void _caaar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caaar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caaar(car(args))); }
+void _caadr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caadr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caadr(car(args))); }
+void _cadar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cadar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cadar(car(args))); }
+void _caddr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caddr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caddr(car(args))); }
+void _cdaar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdaar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdaar(car(args))); }
+void _cdadr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdadr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdadr(car(args))); }
+void _cddar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cddar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cddar(car(args))); }
+void _cdddr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdddr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdddr(car(args))); }
+void _caaaar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caaaar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caaaar(car(args))); }
+void _caaadr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caaadr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caaadr(car(args))); }
+void _caadar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caadar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caadar(car(args))); }
+void _caaddr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caaddr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caaddr(car(args))); }
+void _cadaar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cadaar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cadaar(car(args))); }
+void _cadadr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cadadr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cadadr(car(args))); }
+void _caddar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "caddar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, caddar(car(args))); }
+void _cadddr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cadddr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cadddr(car(args))); }
+void _cdaaar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdaaar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdaaar(car(args))); }
+void _cdaadr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdaadr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdaadr(car(args))); }
+void _cdadar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdadar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdadar(car(args))); }
+void _cdaddr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdaddr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdaddr(car(args))); }
+void _cddaar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cddaar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cddaar(car(args))); }
+void _cddadr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cddadr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cddadr(car(args))); }
+void _cdddar(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cdddar", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cdddar(car(args))); }
+void _cddddr(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cddddr", 1, args);
+ Cyc_check_cons(data, car(args));
+ return_closcall1(data, cont, cddddr(car(args))); }
+void _cons(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "cons", 2, args);
{ make_cons(c, car(args), cadr(args));
- return_closcall1(cont, &c); }}
-void _eq_127(object cont, object args){
- Cyc_check_num_args("eq?", 2, args);
- return_closcall1(cont, Cyc_eq(car(args), cadr(args))); }
-void _eqv_127(object cont, object args){
- Cyc_check_num_args("eqv?", 2, args);
- _eq_127(cont, args); }
-void _equal_127(object cont, object args){
- Cyc_check_num_args("equal?", 2, args);
- return_closcall1(cont, equalp(car(args), cadr(args))); }
-void _length(object cont, object args){
- Cyc_check_num_args("length", 1, args);
- { integer_type i = Cyc_length(car(args));
- return_closcall1(cont, &i); }}
-void _vector_91length(object cont, object args){
- Cyc_check_num_args("vector_91length", 1, args);
- { integer_type i = Cyc_vector_length(car(args));
- return_closcall1(cont, &i); }}
-void _null_127(object cont, object args) {
- Cyc_check_num_args("null?", 1, args);
- return_closcall1(cont, Cyc_is_null(car(args))); }
-void _set_91car_67(object cont, object args) {
- Cyc_check_num_args("set-car!", 2, args);
- return_closcall1(cont, Cyc_set_car(car(args), cadr(args))); }
-void _set_91cdr_67(object cont, object args) {
- Cyc_check_num_args("set-cdr!", 2, args);
- return_closcall1(cont, Cyc_set_cdr(car(args), cadr(args))); }
-void _Cyc_91has_91cycle_127(object cont, object args) {
- Cyc_check_num_args("Cyc-has-cycle?", 1, args);
- return_closcall1(cont, Cyc_has_cycle(car(args))); }
-void __87(object cont, object args) {
- integer_type argc = Cyc_length(args);
- dispatch(argc.value, (function_type)dispatch_sum, cont, cont, args); }
-void __91(object cont, object args) {
- Cyc_check_num_args("-", 1, args);
- { integer_type argc = Cyc_length(args);
- dispatch(argc.value, (function_type)dispatch_sub, cont, cont, args); }}
-void __85(object cont, object args) {
- integer_type argc = Cyc_length(args);
- dispatch(argc.value, (function_type)dispatch_mul, cont, cont, args); }
-void __95(object cont, object args) {
- Cyc_check_num_args("/", 1, args);
- { integer_type argc = Cyc_length(args);
- dispatch(argc.value, (function_type)dispatch_div, cont, cont, args); }}
-void _Cyc_91cvar_127(object cont, object args) {
- Cyc_check_num_args("Cyc-cvar?", 1, args);
- return_closcall1(cont, Cyc_is_cvar(car(args))); }
-void _boolean_127(object cont, object args) {
- Cyc_check_num_args("boolean?", 1, args);
- return_closcall1(cont, Cyc_is_boolean(car(args))); }
-void _char_127(object cont, object args) {
- Cyc_check_num_args("char?", 1, args);
- return_closcall1(cont, Cyc_is_char(car(args))); }
-void _eof_91object_127(object cont, object args) {
- Cyc_check_num_args("eof_91object?", 1, args);
- return_closcall1(cont, Cyc_is_eof_object(car(args))); }
-void _number_127(object cont, object args) {
- Cyc_check_num_args("number?", 1, args);
- return_closcall1(cont, Cyc_is_number(car(args))); }
-void _real_127(object cont, object args) {
- Cyc_check_num_args("real?", 1, args);
- return_closcall1(cont, Cyc_is_real(car(args))); }
-void _integer_127(object cont, object args) {
- Cyc_check_num_args("integer?", 1, args);
- return_closcall1(cont, Cyc_is_integer(car(args))); }
-void _pair_127(object cont, object args) {
- Cyc_check_num_args("pair?", 1, args);
- return_closcall1(cont, Cyc_is_cons(car(args))); }
-void _procedure_127(object cont, object args) {
- Cyc_check_num_args("procedure?", 1, args);
- return_closcall1(cont, Cyc_is_procedure(car(args))); }
-void _macro_127(object cont, object args) {
- Cyc_check_num_args("macro?", 1, args);
- return_closcall1(cont, Cyc_is_macro(car(args))); }
-void _port_127(object cont, object args) {
- Cyc_check_num_args("port?", 1, args);
- return_closcall1(cont, Cyc_is_port(car(args))); }
-void _vector_127(object cont, object args) {
- Cyc_check_num_args("vector?", 1, args);
- return_closcall1(cont, Cyc_is_vector(car(args))); }
-void _string_127(object cont, object args) {
- Cyc_check_num_args("string?", 1, args);
- return_closcall1(cont, Cyc_is_string(car(args))); }
-void _symbol_127(object cont, object args) {
- Cyc_check_num_args("symbol?", 1, args);
- return_closcall1(cont, Cyc_is_symbol(car(args))); }
+ return_closcall1(data, cont, &c); }}
+void _eq_127(void *data, object cont, object args){
+ Cyc_check_num_args(data, "eq?", 2, args);
+ return_closcall1(data, cont, Cyc_eq(car(args), cadr(args))); }
+void _eqv_127(void *data, object cont, object args){
+ Cyc_check_num_args(data, "eqv?", 2, args);
+ _eq_127(data, cont, args); }
+void _equal_127(void *data, object cont, object args){
+ Cyc_check_num_args(data, "equal?", 2, args);
+ return_closcall1(data, cont, equalp(car(args), cadr(args))); }
+void _length(void *data, object cont, object args){
+ Cyc_check_num_args(data, "length", 1, args);
+ { integer_type i = Cyc_length(data, car(args));
+ return_closcall1(data, cont, &i); }}
+void _vector_91length(void *data, object cont, object args){
+ Cyc_check_num_args(data, "vector_91length", 1, args);
+ { integer_type i = Cyc_vector_length(data, car(args));
+ return_closcall1(data, cont, &i); }}
+void _null_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "null?", 1, args);
+ return_closcall1(data, cont, Cyc_is_null(car(args))); }
+void _set_91car_67(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "set-car!", 2, args);
+ return_closcall1(data, cont, Cyc_set_car(data, car(args), cadr(args))); }
+void _set_91cdr_67(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "set-cdr!", 2, args);
+ return_closcall1(data, cont, Cyc_set_cdr(data, car(args), cadr(args))); }
+void _Cyc_91has_91cycle_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "Cyc-has-cycle?", 1, args);
+ return_closcall1(data, cont, Cyc_has_cycle(car(args))); }
+void _Cyc_91spawn_91thread_67(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "Cyc-spawn-thread!", 1, args);
+ // TODO: validate argument type?
+ return_closcall1(data, cont, Cyc_spawn_thread(car(args))); }
+void _Cyc_91end_91thread_67(void *data, object cont, object args) {
+ Cyc_end_thread((gc_thread_data *)data);
+ return_closcall1(data, cont, boolean_f); }
+void _thread_91sleep_67(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "thread-sleep!", 1, args);
+ return_closcall1(data, cont, Cyc_thread_sleep(data, car(args))); }
+void _Cyc_91minor_91gc_primitive(void *data, object cont, object args){
+ Cyc_trigger_minor_gc(data, cont); }
+void __87(void *data, object cont, object args) {
+ integer_type argc = Cyc_length(data, args);
+ dispatch(data, argc.value, (function_type)dispatch_sum, cont, cont, args); }
+void __91(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "-", 1, args);
+ { integer_type argc = Cyc_length(data, args);
+ dispatch(data, argc.value, (function_type)dispatch_sub, cont, cont, args); }}
+void __85(void *data, object cont, object args) {
+ integer_type argc = Cyc_length(data, args);
+ dispatch(data, argc.value, (function_type)dispatch_mul, cont, cont, args); }
+void __95(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "/", 1, args);
+ { integer_type argc = Cyc_length(data, args);
+ dispatch(data, argc.value, (function_type)dispatch_div, cont, cont, args); }}
+void _Cyc_91cvar_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "Cyc-cvar?", 1, args);
+ return_closcall1(data, cont, Cyc_is_cvar(car(args))); }
+void _boolean_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "boolean?", 1, args);
+ return_closcall1(data, cont, Cyc_is_boolean(car(args))); }
+void _char_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "char?", 1, args);
+ return_closcall1(data, cont, Cyc_is_char(car(args))); }
+void _eof_91object_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "eof_91object?", 1, args);
+ return_closcall1(data, cont, Cyc_is_eof_object(car(args))); }
+void _number_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "number?", 1, args);
+ return_closcall1(data, cont, Cyc_is_number(car(args))); }
+void _real_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "real?", 1, args);
+ return_closcall1(data, cont, Cyc_is_real(car(args))); }
+void _integer_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "integer?", 1, args);
+ return_closcall1(data, cont, Cyc_is_integer(car(args))); }
+void _pair_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "pair?", 1, args);
+ return_closcall1(data, cont, Cyc_is_cons(car(args))); }
+void _procedure_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "procedure?", 1, args);
+ return_closcall1(data, cont, Cyc_is_procedure(data, car(args))); }
+void _macro_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "macro?", 1, args);
+ return_closcall1(data, cont, Cyc_is_macro(car(args))); }
+void _port_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "port?", 1, args);
+ return_closcall1(data, cont, Cyc_is_port(car(args))); }
+void _vector_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "vector?", 1, args);
+ return_closcall1(data, cont, Cyc_is_vector(car(args))); }
+void _string_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "string?", 1, args);
+ return_closcall1(data, cont, Cyc_is_string(car(args))); }
+void _symbol_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "symbol?", 1, args);
+ return_closcall1(data, cont, Cyc_is_symbol(car(args))); }
-void _Cyc_91get_91cvar(object cont, object args) {
+void _Cyc_91get_91cvar(void *data, object cont, object args) {
printf("not implemented\n"); exit(1); }
-void _Cyc_91set_91cvar_67(object cont, object args) {
+void _Cyc_91set_91cvar_67(void *data, object cont, object args) {
printf("not implemented\n"); exit(1); }
/* Note we cannot use _exit (per convention) because it is reserved by C */
-void _cyc_exit(object cont, object args) {
+void _cyc_exit(void *data, object cont, object args) {
if(nullp(args))
__halt(nil);
__halt(car(args));
}
-void __75halt(object cont, object args) {
+void __75halt(void *data, object cont, object args) {
exit(0); }
-void _cell_91get(object cont, object args) {
+void _cell_91get(void *data, object cont, object args) {
printf("not implemented\n"); exit(1); }
-void _set_91global_67(object cont, object args) {
+void _set_91global_67(void *data, object cont, object args) {
printf("not implemented\n"); exit(1); }
-void _set_91cell_67(object cont, object args) {
+void _set_91cell_67(void *data, object cont, object args) {
printf("not implemented\n"); exit(1); }
-void _cell(object cont, object args) {
+void _cell(void *data, object cont, object args) {
printf("not implemented\n"); exit(1); }
-void __123(object cont, object args) {
- Cyc_check_num_args("=", 2, args);
- return_closcall1(cont, __num_eq(car(args), cadr(args)));}
-void __125(object cont, object args) {
- Cyc_check_num_args(">", 2, args);
- return_closcall1(cont, __num_gt(car(args), cadr(args)));}
-void __121(object cont, object args) {
- Cyc_check_num_args("<", 2, args);
- return_closcall1(cont, __num_lt(car(args), cadr(args)));}
-void __125_123(object cont, object args) {
- Cyc_check_num_args(">=", 2, args);
- return_closcall1(cont, __num_gte(car(args), cadr(args)));}
-void __121_123(object cont, object args) {
- Cyc_check_num_args("<=", 2, args);
- return_closcall1(cont, __num_lte(car(args), cadr(args)));}
+void __123(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "=", 2, args);
+ return_closcall1(data, cont, __num_eq(data, car(args), cadr(args)));}
+void __125(void *data, object cont, object args) {
+ Cyc_check_num_args(data, ">", 2, args);
+ return_closcall1(data, cont, __num_gt(data, car(args), cadr(args)));}
+void __121(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "<", 2, args);
+ return_closcall1(data, cont, __num_lt(data, car(args), cadr(args)));}
+void __125_123(void *data, object cont, object args) {
+ Cyc_check_num_args(data, ">=", 2, args);
+ return_closcall1(data, cont, __num_gte(data, car(args), cadr(args)));}
+void __121_123(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "<=", 2, args);
+ return_closcall1(data, cont, __num_lte(data, car(args), cadr(args)));}
-void _apply(object cont, object args) {
- Cyc_check_num_args("apply", 2, args);
- apply(cont, car(args), cadr(args)); }
-void _assoc (object cont, object args) {
- Cyc_check_num_args("assoc ", 2, args);
- return_closcall1(cont, assoc(car(args), cadr(args)));}
-void _assq (object cont, object args) {
- Cyc_check_num_args("assq ", 2, args);
- return_closcall1(cont, assq(car(args), cadr(args)));}
-void _assv (object cont, object args) {
- Cyc_check_num_args("assv ", 2, args);
- return_closcall1(cont, assq(car(args), cadr(args)));}
-void _member(object cont, object args) {
- Cyc_check_num_args("member", 2, args);
- return_closcall1(cont, memberp(car(args), cadr(args)));}
-void _memq(object cont, object args) {
- Cyc_check_num_args("memq", 2, args);
- return_closcall1(cont, memqp(car(args), cadr(args)));}
-void _memv(object cont, object args) {
- Cyc_check_num_args("memv", 2, args);
- return_closcall1(cont, memqp(car(args), cadr(args)));}
-void _char_91_125integer(object cont, object args) {
- Cyc_check_num_args("char->integer", 1, args);
+void _apply(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "apply", 2, args);
+ apply(data, cont, car(args), cadr(args)); }
+void _assoc (void *data, object cont, object args) {
+ Cyc_check_num_args(data, "assoc ", 2, args);
+ return_closcall1(data, cont, assoc(data, car(args), cadr(args)));}
+void _assq (void *data, object cont, object args) {
+ Cyc_check_num_args(data, "assq ", 2, args);
+ return_closcall1(data, cont, assq(data, car(args), cadr(args)));}
+void _assv (void *data, object cont, object args) {
+ Cyc_check_num_args(data, "assv ", 2, args);
+ return_closcall1(data, cont, assq(data, car(args), cadr(args)));}
+void _member(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "member", 2, args);
+ return_closcall1(data, cont, memberp(data, car(args), cadr(args)));}
+void _memq(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "memq", 2, args);
+ return_closcall1(data, cont, memqp(data, car(args), cadr(args)));}
+void _memv(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "memv", 2, args);
+ return_closcall1(data, cont, memqp(data, car(args), cadr(args)));}
+void _char_91_125integer(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "char->integer", 1, args);
{ integer_type i = Cyc_char2integer(car(args));
- return_closcall1(cont, &i);}}
-void _integer_91_125char(object cont, object args) {
- Cyc_check_num_args("integer->char", 1, args);
- return_closcall1(cont, Cyc_integer2char(car(args)));}
-void _string_91_125number(object cont, object args) {
- Cyc_check_num_args("string->number", 1, args);
- { common_type i = Cyc_string2number(car(args));
- return_closcall1(cont, &i);}}
-void _string_91length(object cont, object args) {
- Cyc_check_num_args("string-length", 1, args);
- { integer_type i = Cyc_string_length(car(args));
- return_closcall1(cont, &i);}}
-void _cyc_substring(object cont, object args) {
- Cyc_check_num_args("substring", 3, args);
- { string_type s = Cyc_substring(car(args), cadr(args), caddr(args));
- return_closcall1(cont, &s);}}
-void _cyc_string_91set_67(object cont, object args) {
- Cyc_check_num_args("string-set!", 3, args);
- { object s = Cyc_string_set(car(args), cadr(args), caddr(args));
- return_closcall1(cont, s); }}
-void _cyc_string_91ref(object cont, object args) {
- Cyc_check_num_args("string-ref", 2, args);
- { object c = Cyc_string_ref(car(args), cadr(args));
- return_closcall1(cont, c); }}
-void _Cyc_91installation_91dir(object cont, object args) {
- Cyc_check_num_args("Cyc-installation-dir", 1, args);
- { string_type dir = Cyc_installation_dir(car(args));
- return_closcall1(cont, &dir);}}
-void _command_91line_91arguments(object cont, object args) {
- object cmdline = Cyc_command_line_arguments(cont);
- return_closcall1(cont, cmdline); }
-void _cyc_system(object cont, object args) {
- Cyc_check_num_args("system", 1, args);
+ return_closcall1(data, cont, &i);}}
+void _integer_91_125char(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "integer->char", 1, args);
+ return_closcall1(data, cont, Cyc_integer2char(data, car(args)));}
+void _string_91_125number(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "string->number", 1, args);
+ { common_type i = Cyc_string2number(data, car(args));
+ return_closcall1(data, cont, &i);}}
+void _string_91length(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "string-length", 1, args);
+ { integer_type i = Cyc_string_length(data, car(args));
+ return_closcall1(data, cont, &i);}}
+void _cyc_substring(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "substring", 3, args);
+ Cyc_substring(data, cont, car(args), cadr(args), caddr(args));}
+void _cyc_string_91set_67(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "string-set!", 3, args);
+ { object s = Cyc_string_set(data, car(args), cadr(args), caddr(args));
+ return_closcall1(data, cont, s); }}
+void _cyc_string_91ref(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "string-ref", 2, args);
+ { object c = Cyc_string_ref(data, car(args), cadr(args));
+ return_closcall1(data, cont, c); }}
+void _Cyc_make_mutex(void *data, object cont, object args) {
+ { object c = Cyc_make_mutex(data);
+ return_closcall1(data, cont, c); }}
+void _Cyc_mutex_lock(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "mutex-lock!", 1, args);
+ { object c = Cyc_mutex_lock(data, cont, car(args));
+ return_closcall1(data, cont, c); }}
+void _Cyc_mutex_unlock(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "mutex-unlock!", 1, args);
+ { object c = Cyc_mutex_unlock(data, car(args));
+ return_closcall1(data, cont, c); }}
+void _mutex_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "mutex?", 1, args);
+ return_closcall1(data, cont, Cyc_is_mutex(car(args))); }
+void _Cyc_91installation_91dir(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "Cyc-installation-dir", 1, args);
+ Cyc_installation_dir(data, cont, car(args));}
+void _command_91line_91arguments(void *data, object cont, object args) {
+ object cmdline = Cyc_command_line_arguments(data, cont);
+ return_closcall1(data, cont, cmdline); }
+void _cyc_system(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "system", 1, args);
{ integer_type i = Cyc_system(car(args));
- return_closcall1(cont, &i);}}
-//void _error(object cont, object args) {
+ return_closcall1(data, cont, &i);}}
+//void _error(void *data, object cont, object args) {
// integer_type argc = Cyc_length(args);
-// dispatch_va(argc.value, dispatch_error, cont, cont, args); }
-void _Cyc_91current_91exception_91handler(object cont, object args) {
+// dispatch_va(data, argc.value, dispatch_error, cont, cont, args); }
+void _Cyc_91current_91exception_91handler(void *data, object cont, object args) {
object handler = Cyc_current_exception_handler();
- return_closcall1(cont, handler); }
-void _Cyc_91default_91exception_91handler(object cont, object args) {
+ return_closcall1(data, cont, handler); }
+void _Cyc_91default_91exception_91handler(void *data, object cont, object args) {
// TODO: this is a quick-and-dirty implementation, may be a better way to write this
- Cyc_default_exception_handler(1, args, car(args));
+ Cyc_default_exception_handler(data, 1, args, car(args));
}
-void _string_91cmp(object cont, object args) {
- Cyc_check_num_args("string-cmp", 2, args);
- { integer_type cmp = Cyc_string_cmp(car(args), cadr(args));
- return_closcall1(cont, &cmp);}}
-void _string_91append(object cont, object args) {
- integer_type argc = Cyc_length(args);
- dispatch(argc.value, (function_type)dispatch_string_91append, cont, cont, args); }
-void _make_91vector(object cont, object args) {
- Cyc_check_num_args("make-vector", 1, args);
- { integer_type argc = Cyc_length(args);
+void _string_91cmp(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "string-cmp", 2, args);
+ { integer_type cmp = Cyc_string_cmp(data, car(args), cadr(args));
+ return_closcall1(data, cont, &cmp);}}
+void _string_91append(void *data, object cont, object args) {
+ integer_type argc = Cyc_length(data, args);
+ dispatch(data, argc.value, (function_type)dispatch_string_91append, cont, cont, args); }
+void _make_91vector(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "make-vector", 1, args);
+ { integer_type argc = Cyc_length(data, args);
if (argc.value >= 2) {
- Cyc_make_vector(cont, car(args), cadr(args));}
+ Cyc_make_vector(data, cont, car(args), cadr(args));}
else {
- Cyc_make_vector(cont, car(args), boolean_f);}}}
-void _vector_91ref(object cont, object args) {
- Cyc_check_num_args("vector-ref", 2, args);
- { object ref = Cyc_vector_ref(car(args), cadr(args));
- return_closcall1(cont, ref);}}
-void _vector_91set_67(object cont, object args) {
- Cyc_check_num_args("vector-set!", 3, args);
- { object ref = Cyc_vector_set(car(args), cadr(args), caddr(args));
- return_closcall1(cont, ref);}}
-void _list_91_125vector(object cont, object args) {
- Cyc_check_num_args("list->vector", 1, args);
- Cyc_list2vector(cont, car(args));}
-void _list_91_125string(object cont, object args) {
- Cyc_check_num_args("list->string", 1, args);
- { string_type s = Cyc_list2string(car(args));
- return_closcall1(cont, &s);}}
-void _string_91_125symbol(object cont, object args) {
- Cyc_check_num_args("string->symbol", 1, args);
- return_closcall1(cont, Cyc_string2symbol(car(args)));}
-void _symbol_91_125string(object cont, object args) {
- Cyc_check_num_args("symbol->string", 1, args);
- { string_type s = Cyc_symbol2string(car(args));
- return_closcall1(cont, &s);}}
-void _number_91_125string(object cont, object args) {
- Cyc_check_num_args("number->string", 1, args);
- { string_type s = Cyc_number2string(car(args));
- return_closcall1(cont, &s);}}
-void _open_91input_91file(object cont, object args) {
- Cyc_check_num_args("open-input-file", 1, args);
- { port_type p = Cyc_io_open_input_file(car(args));
- return_closcall1(cont, &p);}}
-void _open_91output_91file(object cont, object args) {
- Cyc_check_num_args("open-output-file", 1, args);
- { port_type p = Cyc_io_open_output_file(car(args));
- return_closcall1(cont, &p);}}
-void _close_91port(object cont, object args) {
- Cyc_check_num_args("close-port", 1, args);
- return_closcall1(cont, Cyc_io_close_port(car(args)));}
-void _close_91input_91port(object cont, object args) {
- Cyc_check_num_args("close-input-port", 1, args);
- return_closcall1(cont, Cyc_io_close_input_port(car(args)));}
-void _close_91output_91port(object cont, object args) {
- Cyc_check_num_args("close-output-port", 1, args);
- return_closcall1(cont, Cyc_io_close_output_port(car(args)));}
-void _Cyc_91flush_91output_91port(object cont, object args) {
- Cyc_check_num_args("Cyc-flush-output-port", 1, args);
- return_closcall1(cont, Cyc_io_flush_output_port(car(args)));}
-void _file_91exists_127(object cont, object args) {
- Cyc_check_num_args("file-exists?", 1, args);
- return_closcall1(cont, Cyc_io_file_exists(car(args)));}
-void _delete_91file(object cont, object args) {
- Cyc_check_num_args("delete-file", 1, args);
- return_closcall1(cont, Cyc_io_delete_file(car(args)));}
-void _read_91char(object cont, object args) {
- Cyc_check_num_args("read-char", 1, args);
- return_closcall1(cont, Cyc_io_read_char(car(args)));}
-void _peek_91char(object cont, object args) {
- Cyc_check_num_args("peek-char", 1, args);
- return_closcall1(cont, Cyc_io_peek_char(car(args)));}
-void _Cyc_91read_91line(object cont, object args) {
- Cyc_check_num_args("Cyc-read-line", 1, args);
- Cyc_io_read_line(cont, car(args));}
-void _Cyc_91write_91char(object cont, object args) {
- Cyc_check_num_args("write-char", 2, args);
- return_closcall1(cont, Cyc_write_char(car(args), cadr(args)));}
-void _Cyc_91write(object cont, object args) {
- Cyc_check_num_args("write", 1, args);
- { integer_type argc = Cyc_length(args);
- dispatch(argc.value, (function_type)dispatch_write_va, cont, cont, args); }}
-void _display(object cont, object args) {
- Cyc_check_num_args("display", 1, args);
- { integer_type argc = Cyc_length(args);
- dispatch(argc.value, (function_type)dispatch_display_va, cont, cont, args); }}
-void _call_95cc(object cont, object args){
- Cyc_check_num_args("call/cc", 1, args);
- Cyc_check_fnc(car(args));
- return_closcall2(__glo_call_95cc, cont, car(args));
+ Cyc_make_vector(data, cont, car(args), boolean_f);}}}
+void _vector_91ref(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "vector-ref", 2, args);
+ { object ref = Cyc_vector_ref(data, car(args), cadr(args));
+ return_closcall1(data, cont, ref);}}
+void _vector_91set_67(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "vector-set!", 3, args);
+ { object ref = Cyc_vector_set(data, car(args), cadr(args), caddr(args));
+ return_closcall1(data, cont, ref);}}
+void _list_91_125vector(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "list->vector", 1, args);
+ Cyc_list2vector(data, cont, car(args));}
+void _list_91_125string(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "list->string", 1, args);
+ Cyc_list2string(data, cont, car(args));}
+void _string_91_125symbol(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "string->symbol", 1, args);
+ return_closcall1(data, cont, Cyc_string2symbol(data, car(args)));}
+void _symbol_91_125string(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "symbol->string", 1, args);
+ Cyc_symbol2string(data, cont, car(args));}
+void _number_91_125string(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "number->string", 1, args);
+ Cyc_number2string(data, cont, car(args));}
+void _open_91input_91file(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "open-input-file", 1, args);
+ { port_type p = Cyc_io_open_input_file(data, car(args));
+ return_closcall1(data, cont, &p);}}
+void _open_91output_91file(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "open-output-file", 1, args);
+ { port_type p = Cyc_io_open_output_file(data, car(args));
+ return_closcall1(data, cont, &p);}}
+void _close_91port(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "close-port", 1, args);
+ return_closcall1(data, cont, Cyc_io_close_port(data, car(args)));}
+void _close_91input_91port(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "close-input-port", 1, args);
+ return_closcall1(data, cont, Cyc_io_close_input_port(data, car(args)));}
+void _close_91output_91port(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "close-output-port", 1, args);
+ return_closcall1(data, cont, Cyc_io_close_output_port(data, car(args)));}
+void _Cyc_91flush_91output_91port(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "Cyc-flush-output-port", 1, args);
+ return_closcall1(data, cont, Cyc_io_flush_output_port(data, car(args)));}
+void _file_91exists_127(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "file-exists?", 1, args);
+ return_closcall1(data, cont, Cyc_io_file_exists(data, car(args)));}
+void _delete_91file(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "delete-file", 1, args);
+ return_closcall1(data, cont, Cyc_io_delete_file(data, car(args)));}
+void _read_91char(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "read-char", 1, args);
+ return_closcall1(data, cont, Cyc_io_read_char(data, cont, car(args)));}
+void _peek_91char(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "peek-char", 1, args);
+ return_closcall1(data, cont, Cyc_io_peek_char(data, cont, car(args)));}
+void _Cyc_91read_91line(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "Cyc-read-line", 1, args);
+ Cyc_io_read_line(data, cont, car(args));}
+void _Cyc_91write_91char(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "write-char", 2, args);
+ return_closcall1(data, cont, Cyc_write_char(data, car(args), cadr(args)));}
+void _Cyc_91write(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "write", 1, args);
+ { integer_type argc = Cyc_length(data, args);
+ dispatch(data, argc.value, (function_type)dispatch_write_va, cont, cont, args); }}
+void _display(void *data, object cont, object args) {
+ Cyc_check_num_args(data, "display", 1, args);
+ { integer_type argc = Cyc_length(data, args);
+ dispatch(data, argc.value, (function_type)dispatch_display_va, cont, cont, args); }}
+void _call_95cc(void *data, object cont, object args){
+ Cyc_check_num_args(data, "call/cc", 1, args);
+ if (eq(boolean_f, Cyc_is_procedure(data, car(args)))) {
+ Cyc_invalid_type_error(data, closure2_tag, car(args));
+ }
+ return_closcall2(data, __glo_call_95cc, cont, car(args));
}
/*
@@ -1843,14 +2060,14 @@ void _call_95cc(object cont, object args){
* @param func - Function to execute
* @param args - A list of arguments to the function
*/
-object apply(object cont, object func, object args){
+object apply(void *data, object cont, object func, object args){
common_type buf;
//printf("DEBUG apply: ");
//Cyc_display(args);
//printf("\n");
if (!is_object_type(func)) {
- Cyc_rt_raise2("Call of non-procedure: ", func);
+ Cyc_rt_raise2(data, "Call of non-procedure: ", func);
}
// Causes problems...
@@ -1859,7 +2076,7 @@ object apply(object cont, object func, object args){
switch(type_of(func)) {
case primitive_tag:
// TODO: should probably check arg counts and error out if needed
- ((primitive_type *)func)->fn(cont, args);
+ ((primitive_type *)func)->fn(data, cont, args);
break;
case macro_tag:
case closure0_tag:
@@ -1868,10 +2085,10 @@ object apply(object cont, object func, object args){
case closure3_tag:
case closure4_tag:
case closureN_tag:
- buf.integer_t = Cyc_length(args);
+ buf.integer_t = Cyc_length(data, args);
// TODO: validate number of args provided:
- Cyc_check_num_args("", ((closure)func)->num_args, args); // TODO: could be more efficient, eg: cyc_length(args) is called twice.
- dispatch(buf.integer_t.value, ((closure)func)->fn, func, cont, args);
+ Cyc_check_num_args(data, "", ((closure)func)->num_args, args); // TODO: could be more efficient, eg: cyc_length(args) is called twice.
+ dispatch(data, buf.integer_t.value, ((closure)func)->fn, func, cont, args);
break;
case cons_tag:
@@ -1880,25 +2097,25 @@ object apply(object cont, object func, object args){
object fobj = car(func);
if (!is_object_type(fobj) || type_of(fobj) != symbol_tag) {
- Cyc_rt_raise2("Call of non-procedure: ", func);
+ Cyc_rt_raise2(data, "Call of non-procedure: ", func);
} else if (strncmp(((symbol)fobj)->pname, "lambda", 7) == 0) {
make_cons(c, func, args);
//printf("JAE DEBUG, sending to eval: ");
//Cyc_display(&c, stderr);
- ((closure)__glo_eval)->fn(2, __glo_eval, cont, &c, nil);
+ ((closure)__glo_eval)->fn(data, 2, __glo_eval, cont, &c, nil);
// TODO: would be better to compare directly against symbols here,
// but need a way of looking them up ahead of time.
// maybe a libinit() or such is required.
} else if (strncmp(((symbol)fobj)->pname, "primitive", 10) == 0) {
make_cons(c, cadr(func), args);
- ((closure)__glo_eval)->fn(3, __glo_eval, cont, &c, nil);
+ ((closure)__glo_eval)->fn(data, 3, __glo_eval, cont, &c, nil);
} else if (strncmp(((symbol)fobj)->pname, "procedure", 10) == 0) {
make_cons(c, func, args);
- ((closure)__glo_eval)->fn(3, __glo_eval, cont, &c, nil);
+ ((closure)__glo_eval)->fn(data, 3, __glo_eval, cont, &c, nil);
} else {
make_cons(c, func, args);
- Cyc_rt_raise2("Unable to evaluate: ", &c);
+ Cyc_rt_raise2(data, "Unable to evaluate: ", &c);
}
}
@@ -1910,7 +2127,7 @@ object apply(object cont, object func, object args){
}
// Version of apply meant to be called from within compiled code
-void Cyc_apply(int argc, closure cont, object prim, ...){
+void Cyc_apply(void *data, int argc, closure cont, object prim, ...){
va_list ap;
object tmp;
int i;
@@ -1920,6 +2137,8 @@ void Cyc_apply(int argc, closure cont, object prim, ...){
for (i = 0; i < argc; i++) {
tmp = va_arg(ap, object);
+ args[i].hdr.mark = gc_color_red;
+ args[i].hdr.grayed = 0;
args[i].tag = cons_tag;
args[i].cons_car = tmp;
args[i].cons_cdr = (i == (argc-1)) ? nil : &args[i + 1];
@@ -1929,12 +2148,12 @@ void Cyc_apply(int argc, closure cont, object prim, ...){
//printf("\n");
va_end(ap);
- apply(cont, prim, (object)&args[0]);
+ apply(data, cont, prim, (object)&args[0]);
}
// END apply
/* Extract args from given array, assuming cont is the first arg in buf */
-void Cyc_apply_from_buf(int argc, object prim, object *buf) {
+void Cyc_apply_from_buf(void *data, int argc, object prim, object *buf) {
list args;
object cont;
int i;
@@ -1948,403 +2167,415 @@ void Cyc_apply_from_buf(int argc, object prim, object *buf) {
cont = buf[0];
for (i = 1; i < argc; i++) {
+ args[i - 1].hdr.mark = gc_color_red;
+ args[i - 1].hdr.grayed = 0;
args[i - 1].tag = cons_tag;
args[i - 1].cons_car = buf[i];
args[i - 1].cons_cdr = (i == (argc-1)) ? nil : &args[i];
}
- apply(cont, prim, (object)&args[0]);
+ apply(data, cont, prim, (object)&args[0]);
}
/**
- * Copy an object to the GC heap
+ * Start a thread's trampoline
*/
-char *transport(x, gcgen) char *x; int gcgen;
+void Cyc_start_trampoline(gc_thread_data *thd)
{
- if (nullp(x)) return x;
- if (obj_is_char(x)) return x;
+ // Tank, load the jump program
+ setjmp(*(thd->jmp_start));
+
#if DEBUG_GC
- printf("entered transport ");
- printf("transport %ld\n", type_of(x));
+ printf("Done with GC\n");
#endif
- switch (type_of(x))
- {case cons_tag:
- {register list nx = (list) allocp;
- type_of(nx) = cons_tag; car(nx) = car(x); cdr(nx) = cdr(x);
- forward(x) = nx; type_of(x) = forward_tag;
- allocp = ((char *) nx)+sizeof(cons_type);
- return (char *) nx;}
- case macro_tag:
- {register macro nx = (macro) allocp;
- type_of(nx) = macro_tag; nx->fn = ((macro) x)->fn;
- nx->num_args = ((macro) x)->num_args;
- forward(x) = nx; type_of(x) = forward_tag;
- allocp = ((char *) nx)+sizeof(macro_type);
- return (char *) nx;}
- case closure0_tag:
- {register closure0 nx = (closure0) allocp;
- type_of(nx) = closure0_tag; nx->fn = ((closure0) x)->fn;
- nx->num_args = ((closure0) x)->num_args;
- forward(x) = nx; type_of(x) = forward_tag;
- allocp = ((char *) nx)+sizeof(closure0_type);
- return (char *) nx;}
- case closure1_tag:
- {register closure1 nx = (closure1) allocp;
- type_of(nx) = closure1_tag; nx->fn = ((closure1) x)->fn;
- nx->num_args = ((closure1) x)->num_args;
- nx->elt1 = ((closure1) x)->elt1;
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(closure1_type);
- return (char *) nx;}
- case closure2_tag:
- {register closure2 nx = (closure2) allocp;
- type_of(nx) = closure2_tag; nx->fn = ((closure2) x)->fn;
- nx->num_args = ((closure2) x)->num_args;
- nx->elt1 = ((closure2) x)->elt1;
- nx->elt2 = ((closure2) x)->elt2;
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(closure2_type);
- return (char *) nx;}
- case closure3_tag:
- {register closure3 nx = (closure3) allocp;
- type_of(nx) = closure3_tag; nx->fn = ((closure3) x)->fn;
- nx->num_args = ((closure3) x)->num_args;
- nx->elt1 = ((closure3) x)->elt1;
- nx->elt2 = ((closure3) x)->elt2;
- nx->elt3 = ((closure3) x)->elt3;
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(closure3_type);
- return (char *) nx;}
- case closure4_tag:
- {register closure4 nx = (closure4) allocp;
- type_of(nx) = closure4_tag; nx->fn = ((closure4) x)->fn;
- nx->num_args = ((closure4) x)->num_args;
- nx->elt1 = ((closure4) x)->elt1;
- nx->elt2 = ((closure4) x)->elt2;
- nx->elt3 = ((closure4) x)->elt3;
- nx->elt4 = ((closure4) x)->elt4;
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(closure4_type);
- return (char *) nx;}
- case closureN_tag:
- {register closureN nx = (closureN) allocp;
- int i;
- type_of(nx) = closureN_tag; nx->fn = ((closureN) x)->fn;
- nx->num_args = ((closureN) x)->num_args;
- nx->num_elt = ((closureN) x)->num_elt;
- nx->elts = (object *)(((char *)nx) + sizeof(closureN_type));
- for (i = 0; i < nx->num_elt; i++) {
- nx->elts[i] = ((closureN) x)->elts[i];
- }
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(closureN_type) + sizeof(object) * nx->num_elt;
- return (char *) nx;}
- case vector_tag:
- {register vector nx = (vector) allocp;
- int i;
- type_of(nx) = vector_tag;
- nx->num_elt = ((vector) x)->num_elt;
- nx->elts = (object *)(((char *)nx) + sizeof(vector_type));
- for (i = 0; i < nx->num_elt; i++) {
- nx->elts[i] = ((vector) x)->elts[i];
- }
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(vector_type) + sizeof(object) * nx->num_elt;
- return (char *) nx;}
- case string_tag:
- {register string_type *nx = (string_type *) allocp;
- type_of(nx) = string_tag;
- if (gcgen == 0) {
- // Minor, data heap is not relocated
- nx->str = ((string_type *)x)->str;
- } else {
- // Major collection, data heap is moving
- nx->str = dhallocp;
- int len = strlen(((string_type *) x)->str);
- memcpy(dhallocp, ((string_type *) x)->str, len + 1);
- dhallocp += len + 1;
- }
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(string_type);
- return (char *) nx;}
- case integer_tag:
- {register integer_type *nx = (integer_type *) allocp;
- type_of(nx) = integer_tag; nx->value = ((integer_type *) x)->value;
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(integer_type);
- return (char *) nx;}
- case double_tag:
- {register double_type *nx = (double_type *) allocp;
- type_of(nx) = double_tag; nx->value = ((double_type *) x)->value;
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(double_type);
- return (char *) nx;}
- case port_tag:
- {register port_type *nx = (port_type *) allocp;
- type_of(nx) = port_tag; nx->fp = ((port_type *) x)->fp;
- nx->mode = ((port_type *) x)->mode;
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(port_type);
- return (char *) nx;}
- case cvar_tag:
- {register cvar_type *nx = (cvar_type *) allocp;
- type_of(nx) = cvar_tag; nx->pvar = ((cvar_type *) x)->pvar;
- forward(x) = nx; type_of(x) = forward_tag;
- x = (char *) nx; allocp = ((char *) nx)+sizeof(cvar_type);
- return (char *) nx;}
+
+ if (type_of(thd->gc_cont) == cons_tag || prim(thd->gc_cont)) {
+ Cyc_apply_from_buf(thd, thd->gc_num_args, thd->gc_cont, thd->gc_args);
+ } else {
+ do_dispatch(thd, thd->gc_num_args, ((closure)(thd->gc_cont))->fn, thd->gc_cont, thd->gc_args);
+ }
+
+ printf("Internal error: should never have reached this line\n");
+ exit(0);
+}
+
+// Mark globals as part of the tracing collector
+// This is called by the collector thread
+void gc_mark_globals()
+{
+#if GC_DEBUG_TRACE
+ //fprintf(stderr, "(gc_mark_globals heap: %p size: %d)\n", h, (unsigned int)gc_heap_total_size(h));
+ fprintf(stderr, "Cyc_global_variables %p\n", Cyc_global_variables);
+#endif
+ // Mark global variables
+ gc_mark_black(Cyc_global_variables); // Internal global used by the runtime
+ // Marking it ensures all glos are marked
+ {
+ list l = global_table;
+ for(; !nullp(l); l = cdr(l)){
+ cvar_type *c = (cvar_type *)car(l);
+ object glo = *(c->pvar);
+ if (!nullp(glo)) {
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "global pvar %p\n", glo);
+#endif
+ gc_mark_black(glo); // Mark actual object the global points to
+ }
+ }
+ }
+}
+
+char *gc_fixup_moved_obj(gc_thread_data *thd, int *alloci, char *obj, object hp)
+{
+ int acquired_lock = 0;
+ if (grayed(obj)) {
+ // Try to acquire the lock, because we are already locked if
+ // the collector is cooperating on behalf of the mutator
+ if (pthread_mutex_trylock(&(thd->lock)) == 0) {
+ acquired_lock = 1;
+ }
+ gc_mark_gray2(thd, hp);
+ if (acquired_lock){
+ pthread_mutex_unlock(&(thd->lock));
+ }
+ }
+
+ // hp ==> new heap object, point to it from old stack object
+ forward(obj) = hp;
+ type_of(obj) = forward_tag;
+ // keep track of each allocation so we can scan/move
+ // the whole live object 'tree'
+ gc_thr_add_to_move_buffer(thd, alloci, hp);
+ return (char *)hp;
+}
+
+char *gc_move(char *obj, gc_thread_data *thd, int *alloci, int *heap_grown) {
+ if (!is_object_type(obj)) return obj;
+ switch(type_of(obj)){
+ case cons_tag: {
+ list hp = gc_alloc(Cyc_heap, sizeof(cons_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case macro_tag: {
+ macro_type *hp = gc_alloc(Cyc_heap, sizeof(macro_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case closure0_tag: {
+ closure0_type *hp = gc_alloc(Cyc_heap, sizeof(closure0_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case closure1_tag: {
+ closure1_type *hp = gc_alloc(Cyc_heap, sizeof(closure1_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case closure2_tag: {
+ closure2_type *hp = gc_alloc(Cyc_heap, sizeof(closure2_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case closure3_tag: {
+ closure3_type *hp = gc_alloc(Cyc_heap, sizeof(closure3_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case closure4_tag: {
+ closure4_type *hp = gc_alloc(Cyc_heap, sizeof(closure4_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case closureN_tag: {
+ closureN_type *hp = gc_alloc(Cyc_heap,
+ sizeof(closureN_type) + sizeof(object) * (((closureN) obj)->num_elt),
+ obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case vector_tag: {
+ vector_type *hp = gc_alloc(Cyc_heap,
+ sizeof(vector_type) + sizeof(object) * (((vector) obj)->num_elt),
+ obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case string_tag: {
+ string_type *hp = gc_alloc(Cyc_heap,
+ sizeof(string_type) + ((string_len(obj) + 1)),
+ obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case integer_tag: {
+ integer_type *hp = gc_alloc(Cyc_heap, sizeof(integer_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case double_tag: {
+ double_type *hp = gc_alloc(Cyc_heap, sizeof(double_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case port_tag: {
+ port_type *hp = gc_alloc(Cyc_heap, sizeof(port_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
+ case cvar_tag: {
+ cvar_type *hp = gc_alloc(Cyc_heap, sizeof(cvar_type), obj, thd, heap_grown);
+ return gc_fixup_moved_obj(thd, alloci, obj, hp);
+ }
case forward_tag:
- return (char *) forward(x);
+ return (char *)forward(obj);
case eof_tag: break;
case primitive_tag: break;
case boolean_tag: break;
case symbol_tag: break; // JAE TODO: raise an error here? Should not be possible in real code, though (IE, without GC DEBUG flag)
default:
- printf("transport: bad tag x=%p x.tag=%ld\n",(void *)x,type_of(x)); exit(0);}
- return x;}
+ fprintf(stderr, "gc_move: bad tag obj=%p obj.tag=%ld\n",(object) obj, type_of(obj));
+ exit(1);
+ }
+ return (char *)obj;
+}
-/* Use overflow macro which already knows which way the stack goes. */
-/* Major collection, transport objects on stack or old heap */
-#define transp(p) \
-temp = (p); \
-if ((check_overflow(low_limit,temp) && \
- check_overflow(temp,high_limit)) || \
- (check_overflow(old_heap_low_limit - 1, temp) && \
- check_overflow(temp,old_heap_high_limit + 1))) \
- (p) = (object) transport(temp,major);
+#define gc_move2heap(obj) { \
+ temp = obj; \
+ if (check_overflow(low_limit, temp) && \
+ check_overflow(temp, high_limit)){ \
+ (obj) = (object) gc_move(temp, (gc_thread_data *)data, &alloci, &heap_grown); \
+ } \
+}
-void GC_loop(int major, closure cont, object *ans, int num_ans)
-{char foo;
- int i;
- register object temp;
- register object low_limit = &foo; /* Move live data above us. */
- register object high_limit = stack_begin;
- register char *scanp = allocp; /* Cheney scan pointer. */
- register object old_heap_low_limit = low_limit; // Minor-GC default
- register object old_heap_high_limit = high_limit; // Minor-GC default
+object Cyc_trigger_minor_gc(void *data, object cont) {
+ gc_thread_data* thd = (gc_thread_data *)data;
+ thd->gc_args = boolean_t;
+ GC(data, cont, thd->gc_args, 1);
+ return nil;
+}
- char *tmp_bottom = bottom; /* Bottom of tospace. */
- char *tmp_allocp = allocp; /* Cheney allocate pointer. */
- char *tmp_alloc_end = alloc_end;
- char *tmp_dhbottom = dhbottom;
- char *tmp_dhallocp = dhallocp;
- char *tmp_dhallocp_end = dhalloc_end;
+// Do a minor GC
+int gc_minor(void *data, object low_limit, object high_limit, closure cont, object *args, int num_args)
+{
+ object temp;
+ int i;
+ int scani = 0, alloci = 0;
+ int heap_grown = 0;
- if (dhallocp > dhalloc_limit) {
- // Upgrade to major GC
- major = 1;
- no_major_gcs++;
- no_gcs--;
- }
+//fprintf(stdout, "DEBUG, started minor GC\n"); // JAE DEBUG
+ // Prevent overrunning buffer
+ if (num_args > NUM_GC_ANS) {
+ printf("Fatal error - too many arguments (%d) to GC\n", num_args);
+ exit(1);
+ }
- if (major) {
- // Initialize new heap (TODO: make a function for this)
- bottom = calloc(1,global_heap_size);
- allocp = (char *) ((((long) bottom)+7) & -8);
- alloc_end = allocp + global_heap_size - 8;
- scanp = allocp;
- old_heap_low_limit = tmp_bottom;
- old_heap_high_limit = tmp_alloc_end;
-
- dhallocp = dhbottom = calloc(1, global_heap_size);
- dhalloc_limit = dhallocp + (long)((global_heap_size - 8) * 0.90);
- dhalloc_end = dhallocp + global_heap_size - 8;
- }
+ gc_move2heap(cont);
+ ((gc_thread_data *)data)->gc_cont = cont;
+ ((gc_thread_data *)data)->gc_num_args = num_args;
-#if DEBUG_GC
- printf("\n=== started GC type = %d === \n", major);
-#endif
- /* Transport GC's continuation and its argument. */
- transp(cont);
- gc_cont = cont;
- gc_num_ans = num_ans;
-#if DEBUG_GC
- printf("DEBUG done transporting cont\n");
-#endif
+ for (i = 0; i < num_args; i++){
+ gc_move2heap(args[i]);
+ ((gc_thread_data *)data)->gc_args[i] = args[i];
+ }
- /* Prevent overrunning buffer */
- if (num_ans > NUM_GC_ANS) {
- printf("Fatal error - too many arguments (%d) to GC\n", num_ans);
- exit(1);
- }
+ // Transport mutations
+ {
+ list l;
+ for (l = ((gc_thread_data *)data)->mutations; !nullp(l); l = cdr(l)) {
+ object o = car(l);
+ if (type_of(o) == cons_tag) {
+ gc_move2heap(car(o));
+ gc_move2heap(cdr(o));
+ } else if (type_of(o) == vector_tag) {
+ int i;
+ // TODO: probably too inefficient, try collecting single index
+ for (i = 0; i < ((vector)o)->num_elt; i++) {
+ gc_move2heap(((vector)o)->elts[i]);
+ }
+ } else if (type_of(o) == forward_tag) {
+ // Already transported, skip
+ } else {
+ printf("Unexpected type %ld transporting mutation\n", type_of(o));
+ exit(1);
+ }
+ }
+ }
+ clear_mutations(data); // Reset for next time
- for (i = 0; i < num_ans; i++){
- transp(ans[i]);
- gc_ans[i] = ans[i];
- }
-#if DEBUG_GC
- printf("DEBUG done transporting gc_ans\n");
-#endif
+ // Transport globals
+ gc_move2heap(Cyc_global_variables); // Internal global used by the runtime
+ {
+ list l = global_table;
+ for(; !nullp(l); l = cdr(l)){
+ cvar_type *c = (cvar_type *)car(l);
+ gc_move2heap(*(c->pvar)); // Transport underlying global, not the pvar
+ }
+ }
- /* Transport mutations. */
- {
- list l;
- for (l = mutation_table; !nullp(l); l = cdr(l)) {
- object o = car(l);
- if (type_of(o) == cons_tag) {
- // Transport, if necessary
- // TODO: need to test this with major GC, and
- // GC's of list/car-cdr from same generation
- transp(car(o));
- transp(cdr(o));
- } else if (type_of(o) == vector_tag) {
- int i;
- // TODO: probably too inefficient, try collecting single index
- for (i = 0; i < ((vector)o)->num_elt; i++) {
- transp(((vector)o)->elts[i]);
- }
- } else if (type_of(o) == forward_tag) {
- // Already transported, skip
- } else {
- printf("Unexpected type %ld transporting mutation\n", type_of(o));
- exit(1);
- }
- }
- }
- clear_mutations(); /* Reset for next time */
-
- /* Transport global variables. */
- transp(Cyc_global_variables); /* Internal global used by the runtime */
- {
- list l = global_table;
- for(; !nullp(l); l = cdr(l)){
- cvar_type *c = (cvar_type *)car(l);
- transp(*(c->pvar)); // GC global, not the pvar
- }
- }
- while (scanpmoveBuf[scani];
+ switch(type_of(obj)) {
+ case cons_tag: {
+ gc_move2heap(car(obj));
+ gc_move2heap(cdr(obj));
+ break;
+ }
case closure1_tag:
-#if DEBUG_GC
- printf("DEBUG transport closure1 \n");
-#endif
- transp(((closure1) scanp)->elt1);
- scanp += sizeof(closure1_type); break;
+ gc_move2heap(((closure1) obj)->elt1);
+ break;
case closure2_tag:
-#if DEBUG_GC
- printf("DEBUG transport closure2 \n");
-#endif
- transp(((closure2) scanp)->elt1); transp(((closure2) scanp)->elt2);
- scanp += sizeof(closure2_type); break;
+ gc_move2heap(((closure2) obj)->elt1);
+ gc_move2heap(((closure2) obj)->elt2);
case closure3_tag:
-#if DEBUG_GC
- printf("DEBUG transport closure3 \n");
-#endif
- transp(((closure3) scanp)->elt1); transp(((closure3) scanp)->elt2);
- transp(((closure3) scanp)->elt3);
- scanp += sizeof(closure3_type); break;
+ gc_move2heap(((closure3) obj)->elt1);
+ gc_move2heap(((closure3) obj)->elt2);
+ gc_move2heap(((closure3) obj)->elt3);
case closure4_tag:
-#if DEBUG_GC
- printf("DEBUG transport closure4 \n");
-#endif
- transp(((closure4) scanp)->elt1); transp(((closure4) scanp)->elt2);
- transp(((closure4) scanp)->elt3); transp(((closure4) scanp)->elt4);
- scanp += sizeof(closure4_type); break;
- case closureN_tag:
-#if DEBUG_GC
- printf("DEBUG transport closureN \n");
-#endif
- {int i; int n = ((closureN) scanp)->num_elt;
+ gc_move2heap(((closure4) obj)->elt1);
+ gc_move2heap(((closure4) obj)->elt2);
+ gc_move2heap(((closure4) obj)->elt3);
+ gc_move2heap(((closure4) obj)->elt4);
+ break;
+ case closureN_tag: {
+ int i, n = ((closureN) obj)->num_elt;
for (i = 0; i < n; i++) {
- transp(((closureN) scanp)->elts[i]);
+ gc_move2heap(((closureN) obj)->elts[i]);
}
- scanp += sizeof(closureN_type) + sizeof(object) * n;
- }
- break;
- case vector_tag:
-#if DEBUG_GC
- printf("DEBUG transport vector \n");
-#endif
- {int i; int n = ((vector) scanp)->num_elt;
+ break;
+ }
+ case vector_tag: {
+ int i, n = ((vector) obj)->num_elt;
for (i = 0; i < n; i++) {
- transp(((vector) scanp)->elts[i]);
+ gc_move2heap(((vector) obj)->elts[i]);
}
- scanp += sizeof(vector_type) + sizeof(object) * n;
- }
- break;
+ break;
+ }
+ // No child objects to move
+ case closure0_tag:
+ case macro_tag:
case string_tag:
-#if DEBUG_GC
- printf("DEBUG transport string \n");
-#endif
- scanp += sizeof(string_type); break;
case integer_tag:
-#if DEBUG_GC
- printf("DEBUG transport integer \n");
-#endif
- scanp += sizeof(integer_type); break;
case double_tag:
-#if DEBUG_GC
- printf("DEBUG transport double \n");
-#endif
- scanp += sizeof(double_type); break;
case port_tag:
-#if DEBUG_GC
- printf("DEBUG transport port \n");
-#endif
- scanp += sizeof(port_type); break;
case cvar_tag:
-#if DEBUG_GC
- printf("DEBUG transport cvar \n");
-#endif
- scanp += sizeof(cvar_type); break;
+ break;
+ // These types are not heap-allocated
case eof_tag:
case primitive_tag:
case symbol_tag:
case boolean_tag:
default:
- printf("GC: bad tag scanp=%p scanp.tag=%ld\n",(void *)scanp,type_of(scanp));
- exit(0);}
-
- if (major) {
- free(tmp_bottom);
- free(tmp_dhbottom);
- }
+ fprintf(stderr,
+ "GC: unexpected object type %ld for object %p\n", type_of(obj), obj);
+ exit(1);
+ }
+ scani++;
+ }
+ return alloci;
}
-void GC(cont,ans,num_ans) closure cont; object *ans; int num_ans;
-{
- /* Only room for one more minor-GC, so do a major one.
- * Not sure this is the best strategy, it may be better to do major
- * ones sooner, perhaps after every x minor GC's.
- *
- * Also may need to consider dynamically increasing heap size, but
- * by how much (1.3x, 1.5x, etc) and when? I suppose when heap usage
- * after a collection is above a certain percentage, then it would be
- * necessary to increase heap size the next time.
- */
- if (allocp >= (bottom + (global_heap_size - global_stack_size))) {
- //printf("Possibly only room for one more minor GC. no_gcs = %ld\n", no_gcs);
- no_major_gcs++;
- GC_loop(1, cont, ans, num_ans);
- } else {
- no_gcs++; /* Count the number of minor GC's. */
- GC_loop(0, cont, ans, num_ans);
- }
-
- /* You have to let it all go, Neo. Fear, doubt, and disbelief. Free your mind... */
- longjmp(jmp_main,1); /* Return globals gc_cont, gc_ans. */
+/**
+ * Run a minor GC from a mutator thread.
+ * This function runs the core GC algorithm, cooperates with
+ * the collector, and then calls its continuation.
+ */
+void GC(void *data, closure cont, object *args, int num_args)
+{
+ char tmp;
+ object low_limit = &tmp; // This is one end of the stack...
+ object high_limit = ((gc_thread_data *)data)->stack_start;
+ int alloci = gc_minor(data, low_limit, high_limit, cont, args, num_args);
+ // Cooperate with the collector thread
+ gc_mut_cooperate((gc_thread_data *)data, alloci);
+#if GC_DEBUG_TRACE
+ fprintf(stderr, "done with minor GC\n");
+#endif
+ // Let it all go, Neo...
+ longjmp(*(((gc_thread_data *)data)->jmp_start), 1);
}
+ /* Overall GC notes:
+ note fwd pointers are only ever placed on the stack, never the heap
+
+ we now have 2 GC's:
+ - Stack GC, a minor collection where we move live stack objs to heap
+ - Heap GC, a major collection where we do mark&sweep
+
+ when replacing an object,
+ - only need to do this for objects on 'this' stack
+ - if object is a fwd pointer, return it's forwarding address
+ - otherwise,
+ * allocate them on the heap
+ * return the new address
+ * leave a forwarding pointer on the stack with the new address
+ - may be able to modify transp macro to do this part
+
+ can still use write buffer to ensure any heap->stack references are handled
+ - also want to use this barrier to handle any globals that are re-assigned to
+ locations on the stack, to ensure they are moved to the heap during GC.
+ - write barrier really should be per-stack, since OK to leave those items until
+ stack is collected
+ - TBD how this works with multiple threads, each with its own stack
+
+ need to transport:
+ - stack closure/args
+ - mutation write barrier
+ - globals
+
+ after transport is complete, we will not be scanning newspace but
+ do need to transport any stack objects referenced by the above
+ a couple of ideas:
+ - create a list of allocated objects, and pass over them in much
+ the same way the cheney algorithm does (2 "fingers"??). I think
+ this could actually just be a list of pointers since we want to
+ copy to the heap not the scan space. the goal is just to ensure
+ all live stack references are moved to the heap. trick here is to
+ ensure scan space is large enough, although if it runs out
+ we can just allocate a new space (of say double the size),
+ memcpy the old one, and update scanp/allocp accordingly.
+ * can use a bump pointer to build the list, so it should be
+ fairly efficient, especially if we don't have to resize too much
+ * will be writing all of this code from scratch, but can use
+ existing scan code as a guide
+ - or, during transport recursively transport objects that could
+ contain references (closures, lists, etc). This may be more
+ convenient to code, although it requires stack space to traverse
+ the structures. I think it might also get stuck processing circular
+ structures (!!!), so this approach is not an option
+ TBD how (or even if) this can scale to multiple threads...
+ is is possible to use write barrier(s) to detect if one thread is
+ working with another's data during GC? This will be an important
+ point to keep in mind as the code is being written
+
+!!!
+IMPORTANT - does the timing of GC matter? for example, if we GC before
+scanning all the stack space, there might be an object referenced by
+a live stack object that would get freed because we haven't gotten to
+it yet!
+
+so I think we have to scan all the stack space before doing a GC.
+alternatively, can we use a write barrier to keep track of when a
+stack object references one on the heap? that would effectively make
+the heap object into a root until stack GC
+
+Originally thought this, but now not so sure because it seems the above
+has to be taken into account:
+
+ Do not have to explicitly GC until heap is full enough for one to
+ be initiated. do need to code gc_collect though, and ensure it is
+ called at the appropriate time.
+
+I think everything else will work as written, but not quite sure how
+to handle this detail yet. and it is very important to get right
+!!!!
+
+ thoughts:
+ - worth having a write barrier for globals? that is, only GC those that
+ were modified. just an idea...
+ - KEEP IN MIND AN OVERALL GOAL, that this should try to be as close as
+ possible to the cheney algorithm in terms of performance. so obviously we
+ want to try and do as little work as necessary during each minor GC.
+ since we will use a write barrier to keep track of the heap's stack refs,
+ it seems reasonable that we could skip globals that live on the heap.
+ - To some extent, it should be possible to test changes that improve performance
+ by coding something inefficient (but guaranteed to work) and then modifying it to
+ be more efficient (but not quite sure if idea will work).
+ */
+
/**
* Receive a list of arguments and apply them to the given function
*/
-void dispatch(int argc, function_type func, object clo, object cont, object args) {
+void dispatch(void *data, int argc, function_type func, object clo, object cont, object args) {
object b[argc + 1]; // OK to do this? Is this portable?
int i;
@@ -2355,13 +2586,13 @@ void dispatch(int argc, function_type func, object clo, object cont, object args
args = cdr(args);
}
- do_dispatch(argc, func, clo, b);
+ do_dispatch(data, argc, func, clo, b);
}
/**
* Same as above but for a varargs C function
*/
-void dispatch_va(int argc, function_type_va func, object clo, object cont, object args) {
+void dispatch_va(void *data, int argc, function_type_va func, object clo, object cont, object args) {
object b[argc + 1]; // OK to do this? Is this portable?
int i;
@@ -2372,131 +2603,143 @@ void dispatch_va(int argc, function_type_va func, object clo, object cont, objec
args = cdr(args);
}
- do_dispatch(argc, (function_type)func, clo, b);
+ do_dispatch(data, argc, (function_type)func, clo, b);
}
-static primitive_type Cyc_91global_91vars_primitive = {primitive_tag, "Cyc-global-vars", &_Cyc_91global_91vars};
-static primitive_type Cyc_91get_91cvar_primitive = {primitive_tag, "Cyc-get-cvar", &_Cyc_91get_91cvar};
-static primitive_type Cyc_91set_91cvar_67_primitive = {primitive_tag, "Cyc-set-cvar!", &_Cyc_91set_91cvar_67};
-static primitive_type Cyc_91cvar_127_primitive = {primitive_tag, "Cyc-cvar?", &_Cyc_91cvar_127};
-static primitive_type Cyc_91has_91cycle_127_primitive = {primitive_tag, "Cyc-has-cycle?", &_Cyc_91has_91cycle_127};
-static primitive_type _87_primitive = {primitive_tag, "+", &__87};
-static primitive_type _91_primitive = {primitive_tag, "-", &__91};
-static primitive_type _85_primitive = {primitive_tag, "*", &__85};
-static primitive_type _95_primitive = {primitive_tag, "/", &__95};
-static primitive_type _123_primitive = {primitive_tag, "=", &__123};
-static primitive_type _125_primitive = {primitive_tag, ">", &__125};
-static primitive_type _121_primitive = {primitive_tag, "<", &__121};
-static primitive_type _125_123_primitive = {primitive_tag, ">=", &__125_123};
-static primitive_type _121_123_primitive = {primitive_tag, "<=", &__121_123};
-static primitive_type apply_primitive = {primitive_tag, "apply", &_apply};
-static primitive_type _75halt_primitive = {primitive_tag, "%halt", &__75halt};
-static primitive_type exit_primitive = {primitive_tag, "exit", &_cyc_exit};
-static primitive_type Cyc_91current_91exception_91handler_primitive = {primitive_tag, "Cyc_current_exception_handler", &_Cyc_91current_91exception_91handler};
-static primitive_type Cyc_91default_91exception_91handler_primitive = {primitive_tag, "Cyc_default_exception_handler", &_Cyc_91default_91exception_91handler};
-static primitive_type cons_primitive = {primitive_tag, "cons", &_cons};
-static primitive_type cell_91get_primitive = {primitive_tag, "cell-get", &_cell_91get};
-static primitive_type set_91global_67_primitive = {primitive_tag, "set-global!", &_set_91global_67};
-static primitive_type set_91cell_67_primitive = {primitive_tag, "set-cell!", &_set_91cell_67};
-static primitive_type cell_primitive = {primitive_tag, "cell", &_cell};
-static primitive_type eq_127_primitive = {primitive_tag, "eq?", &_eq_127};
-static primitive_type eqv_127_primitive = {primitive_tag, "eqv?", &_eqv_127};
-static primitive_type equal_127_primitive = {primitive_tag, "equal?", &_equal_127};
-static primitive_type assoc_primitive = {primitive_tag, "assoc", &_assoc};
-static primitive_type assq_primitive = {primitive_tag, "assq", &_assq};
-static primitive_type assv_primitive = {primitive_tag, "assv", &_assv};
-static primitive_type member_primitive = {primitive_tag, "member", &_member};
-static primitive_type memq_primitive = {primitive_tag, "memq", &_memq};
-static primitive_type memv_primitive = {primitive_tag, "memv", &_memv};
-static primitive_type length_primitive = {primitive_tag, "length", &_length};
-static primitive_type vector_91length_primitive = {primitive_tag, "vector-length", &_vector_91length};
-static primitive_type set_91car_67_primitive = {primitive_tag, "set-car!", &_set_91car_67};
-static primitive_type set_91cdr_67_primitive = {primitive_tag, "set-cdr!", &_set_91cdr_67};
-static primitive_type car_primitive = {primitive_tag, "car", &_car};
-static primitive_type cdr_primitive = {primitive_tag, "cdr", &_cdr};
-static primitive_type caar_primitive = {primitive_tag, "caar", &_caar};
-static primitive_type cadr_primitive = {primitive_tag, "cadr", &_cadr};
-static primitive_type cdar_primitive = {primitive_tag, "cdar", &_cdar};
-static primitive_type cddr_primitive = {primitive_tag, "cddr", &_cddr};
-static primitive_type caaar_primitive = {primitive_tag, "caaar", &_caaar};
-static primitive_type caadr_primitive = {primitive_tag, "caadr", &_caadr};
-static primitive_type cadar_primitive = {primitive_tag, "cadar", &_cadar};
-static primitive_type caddr_primitive = {primitive_tag, "caddr", &_caddr};
-static primitive_type cdaar_primitive = {primitive_tag, "cdaar", &_cdaar};
-static primitive_type cdadr_primitive = {primitive_tag, "cdadr", &_cdadr};
-static primitive_type cddar_primitive = {primitive_tag, "cddar", &_cddar};
-static primitive_type cdddr_primitive = {primitive_tag, "cdddr", &_cdddr};
-static primitive_type caaaar_primitive = {primitive_tag, "caaaar", &_caaaar};
-static primitive_type caaadr_primitive = {primitive_tag, "caaadr", &_caaadr};
-static primitive_type caadar_primitive = {primitive_tag, "caadar", &_caadar};
-static primitive_type caaddr_primitive = {primitive_tag, "caaddr", &_caaddr};
-static primitive_type cadaar_primitive = {primitive_tag, "cadaar", &_cadaar};
-static primitive_type cadadr_primitive = {primitive_tag, "cadadr", &_cadadr};
-static primitive_type caddar_primitive = {primitive_tag, "caddar", &_caddar};
-static primitive_type cadddr_primitive = {primitive_tag, "cadddr", &_cadddr};
-static primitive_type cdaaar_primitive = {primitive_tag, "cdaaar", &_cdaaar};
-static primitive_type cdaadr_primitive = {primitive_tag, "cdaadr", &_cdaadr};
-static primitive_type cdadar_primitive = {primitive_tag, "cdadar", &_cdadar};
-static primitive_type cdaddr_primitive = {primitive_tag, "cdaddr", &_cdaddr};
-static primitive_type cddaar_primitive = {primitive_tag, "cddaar", &_cddaar};
-static primitive_type cddadr_primitive = {primitive_tag, "cddadr", &_cddadr};
-static primitive_type cdddar_primitive = {primitive_tag, "cdddar", &_cdddar};
-static primitive_type cddddr_primitive = {primitive_tag, "cddddr", &_cddddr};
-static primitive_type char_91_125integer_primitive = {primitive_tag, "char->integer", &_char_91_125integer};
-static primitive_type integer_91_125char_primitive = {primitive_tag, "integer->char", &_integer_91_125char};
-static primitive_type string_91_125number_primitive = {primitive_tag, "string->number", &_string_91_125number};
-static primitive_type string_91length_primitive = {primitive_tag, "string-length", &_string_91length};
-static primitive_type substring_primitive = {primitive_tag, "substring", &_cyc_substring};
-static primitive_type string_91ref_primitive = {primitive_tag, "string-ref", &_cyc_string_91ref};
-static primitive_type string_91set_67_primitive = {primitive_tag, "string-set!", &_cyc_string_91set_67};
-static primitive_type Cyc_91installation_91dir_primitive = {primitive_tag, "Cyc-installation-dir", &_Cyc_91installation_91dir};
-static primitive_type command_91line_91arguments_primitive = {primitive_tag, "command-line-arguments", &_command_91line_91arguments};
-static primitive_type system_primitive = {primitive_tag, "system", &_cyc_system};
-static primitive_type string_91cmp_primitive = {primitive_tag, "string-cmp", &_string_91cmp};
-static primitive_type string_91append_primitive = {primitive_tag, "string-append", &_string_91append};
-static primitive_type list_91_125string_primitive = {primitive_tag, "list->string", &_list_91_125string};
-static primitive_type string_91_125symbol_primitive = {primitive_tag, "string->symbol", &_string_91_125symbol};
-static primitive_type symbol_91_125string_primitive = {primitive_tag, "symbol->string", &_symbol_91_125string};
-static primitive_type number_91_125string_primitive = {primitive_tag, "number->string", &_number_91_125string};
-static primitive_type list_91_125vector_primitive = {primitive_tag, "list-vector", &_list_91_125vector};
-static primitive_type make_91vector_primitive = {primitive_tag, "make-vector", &_make_91vector};
-static primitive_type vector_91ref_primitive = {primitive_tag, "vector-ref", &_vector_91ref};
-static primitive_type vector_91set_67_primitive = {primitive_tag, "vector-set!", &_vector_91set_67};
-static primitive_type boolean_127_primitive = {primitive_tag, "boolean?", &_boolean_127};
-static primitive_type char_127_primitive = {primitive_tag, "char?", &_char_127};
-static primitive_type eof_91object_127_primitive = {primitive_tag, "eof-object?", &_eof_91object_127};
-static primitive_type null_127_primitive = {primitive_tag, "null?", &_null_127};
-static primitive_type number_127_primitive = {primitive_tag, "number?", &_number_127};
-static primitive_type real_127_primitive = {primitive_tag, "real?", &_real_127};
-static primitive_type integer_127_primitive = {primitive_tag, "integer?", &_integer_127};
-static primitive_type pair_127_primitive = {primitive_tag, "pair?", &_pair_127};
-static primitive_type procedure_127_primitive = {primitive_tag, "procedure?", &_procedure_127};
-static primitive_type macro_127_primitive = {primitive_tag, "macro?", &_macro_127};
-static primitive_type port_127_primitive = {primitive_tag, "port?", &_port_127};
-static primitive_type vector_127_primitive = {primitive_tag, "vector?", &_vector_127};
-static primitive_type string_127_primitive = {primitive_tag, "string?", &_string_127};
-static primitive_type symbol_127_primitive = {primitive_tag, "symbol?", &_symbol_127};
-static primitive_type open_91input_91file_primitive = {primitive_tag, "open-input-file", &_open_91input_91file};
-static primitive_type open_91output_91file_primitive = {primitive_tag, "open-output-file", &_open_91output_91file};
-static primitive_type close_91port_primitive = {primitive_tag, "close-port", &_close_91port};
-static primitive_type close_91input_91port_primitive = {primitive_tag, "close-input-port", &_close_91input_91port};
-static primitive_type close_91output_91port_primitive = {primitive_tag, "close-output-port", &_close_91output_91port};
-static primitive_type Cyc_91flush_91output_91port_primitive = {primitive_tag, "Cyc-flush-output-port", &_Cyc_91flush_91output_91port};
-static primitive_type file_91exists_127_primitive = {primitive_tag, "file-exists?", &_file_91exists_127};
-static primitive_type delete_91file_primitive = {primitive_tag, "delete-file", &_delete_91file};
-static primitive_type read_91char_primitive = {primitive_tag, "read-char", &_read_91char};
-static primitive_type peek_91char_primitive = {primitive_tag, "peek-char", &_peek_91char};
-static primitive_type Cyc_91read_91line_primitive = {primitive_tag, "Cyc-read-line", &_Cyc_91read_91line};
-static primitive_type Cyc_91write_primitive = {primitive_tag, "Cyc-write", &_Cyc_91write};
-static primitive_type Cyc_91write_91char_primitive = {primitive_tag, "Cyc-write-char", &_Cyc_91write_91char};
-static primitive_type Cyc_91display_primitive = {primitive_tag, "Cyc-display", &_display};
-static primitive_type call_95cc_primitive = {primitive_tag, "call/cc", &_call_95cc};
+static primitive_type Cyc_91global_91vars_primitive = {{0}, primitive_tag, "Cyc-global-vars", &_Cyc_91global_91vars};
+static primitive_type Cyc_91get_91cvar_primitive = {{0}, primitive_tag, "Cyc-get-cvar", &_Cyc_91get_91cvar};
+static primitive_type Cyc_91set_91cvar_67_primitive = {{0}, primitive_tag, "Cyc-set-cvar!", &_Cyc_91set_91cvar_67};
+static primitive_type Cyc_91cvar_127_primitive = {{0}, primitive_tag, "Cyc-cvar?", &_Cyc_91cvar_127};
+static primitive_type Cyc_91has_91cycle_127_primitive = {{0}, primitive_tag, "Cyc-has-cycle?", &_Cyc_91has_91cycle_127};
+static primitive_type Cyc_91spawn_91thread_67_primitive = {{0}, primitive_tag, "Cyc-spawn-thread!", &_Cyc_91spawn_91thread_67};
+static primitive_type Cyc_91end_91thread_67_primitive = {{0}, primitive_tag, "Cyc-end-thread!", &_Cyc_91end_91thread_67};
+static primitive_type thread_91sleep_67_primitive = {{0}, primitive_tag, "thread-sleep!", &_thread_91sleep_67};
+static primitive_type Cyc_91minor_91gc_primitive = {{0}, primitive_tag, "Cyc-minor-gc", &_Cyc_91minor_91gc_primitive};
+static primitive_type _87_primitive = {{0}, primitive_tag, "+", &__87};
+static primitive_type _91_primitive = {{0}, primitive_tag, "-", &__91};
+static primitive_type _85_primitive = {{0}, primitive_tag, "*", &__85};
+static primitive_type _95_primitive = {{0}, primitive_tag, "/", &__95};
+static primitive_type _123_primitive = {{0}, primitive_tag, "=", &__123};
+static primitive_type _125_primitive = {{0}, primitive_tag, ">", &__125};
+static primitive_type _121_primitive = {{0}, primitive_tag, "<", &__121};
+static primitive_type _125_123_primitive = {{0}, primitive_tag, ">=", &__125_123};
+static primitive_type _121_123_primitive = {{0}, primitive_tag, "<=", &__121_123};
+static primitive_type apply_primitive = {{0}, primitive_tag, "apply", &_apply};
+static primitive_type _75halt_primitive = {{0}, primitive_tag, "%halt", &__75halt};
+static primitive_type exit_primitive = {{0}, primitive_tag, "exit", &_cyc_exit};
+static primitive_type Cyc_91current_91exception_91handler_primitive = {{0}, primitive_tag, "Cyc_current_exception_handler", &_Cyc_91current_91exception_91handler};
+static primitive_type Cyc_91default_91exception_91handler_primitive = {{0}, primitive_tag, "Cyc_default_exception_handler", &_Cyc_91default_91exception_91handler};
+static primitive_type cons_primitive = {{0}, primitive_tag, "cons", &_cons};
+static primitive_type cell_91get_primitive = {{0}, primitive_tag, "cell-get", &_cell_91get};
+static primitive_type set_91global_67_primitive = {{0}, primitive_tag, "set-global!", &_set_91global_67};
+static primitive_type set_91cell_67_primitive = {{0}, primitive_tag, "set-cell!", &_set_91cell_67};
+static primitive_type cell_primitive = {{0}, primitive_tag, "cell", &_cell};
+static primitive_type eq_127_primitive = {{0}, primitive_tag, "eq?", &_eq_127};
+static primitive_type eqv_127_primitive = {{0}, primitive_tag, "eqv?", &_eqv_127};
+static primitive_type equal_127_primitive = {{0}, primitive_tag, "equal?", &_equal_127};
+static primitive_type assoc_primitive = {{0}, primitive_tag, "assoc", &_assoc};
+static primitive_type assq_primitive = {{0}, primitive_tag, "assq", &_assq};
+static primitive_type assv_primitive = {{0}, primitive_tag, "assv", &_assv};
+static primitive_type member_primitive = {{0}, primitive_tag, "member", &_member};
+static primitive_type memq_primitive = {{0}, primitive_tag, "memq", &_memq};
+static primitive_type memv_primitive = {{0}, primitive_tag, "memv", &_memv};
+static primitive_type length_primitive = {{0}, primitive_tag, "length", &_length};
+static primitive_type vector_91length_primitive = {{0}, primitive_tag, "vector-length", &_vector_91length};
+static primitive_type set_91car_67_primitive = {{0}, primitive_tag, "set-car!", &_set_91car_67};
+static primitive_type set_91cdr_67_primitive = {{0}, primitive_tag, "set-cdr!", &_set_91cdr_67};
+static primitive_type car_primitive = {{0}, primitive_tag, "car", &_car};
+static primitive_type cdr_primitive = {{0}, primitive_tag, "cdr", &_cdr};
+static primitive_type caar_primitive = {{0}, primitive_tag, "caar", &_caar};
+static primitive_type cadr_primitive = {{0}, primitive_tag, "cadr", &_cadr};
+static primitive_type cdar_primitive = {{0}, primitive_tag, "cdar", &_cdar};
+static primitive_type cddr_primitive = {{0}, primitive_tag, "cddr", &_cddr};
+static primitive_type caaar_primitive = {{0}, primitive_tag, "caaar", &_caaar};
+static primitive_type caadr_primitive = {{0}, primitive_tag, "caadr", &_caadr};
+static primitive_type cadar_primitive = {{0}, primitive_tag, "cadar", &_cadar};
+static primitive_type caddr_primitive = {{0}, primitive_tag, "caddr", &_caddr};
+static primitive_type cdaar_primitive = {{0}, primitive_tag, "cdaar", &_cdaar};
+static primitive_type cdadr_primitive = {{0}, primitive_tag, "cdadr", &_cdadr};
+static primitive_type cddar_primitive = {{0}, primitive_tag, "cddar", &_cddar};
+static primitive_type cdddr_primitive = {{0}, primitive_tag, "cdddr", &_cdddr};
+static primitive_type caaaar_primitive = {{0}, primitive_tag, "caaaar", &_caaaar};
+static primitive_type caaadr_primitive = {{0}, primitive_tag, "caaadr", &_caaadr};
+static primitive_type caadar_primitive = {{0}, primitive_tag, "caadar", &_caadar};
+static primitive_type caaddr_primitive = {{0}, primitive_tag, "caaddr", &_caaddr};
+static primitive_type cadaar_primitive = {{0}, primitive_tag, "cadaar", &_cadaar};
+static primitive_type cadadr_primitive = {{0}, primitive_tag, "cadadr", &_cadadr};
+static primitive_type caddar_primitive = {{0}, primitive_tag, "caddar", &_caddar};
+static primitive_type cadddr_primitive = {{0}, primitive_tag, "cadddr", &_cadddr};
+static primitive_type cdaaar_primitive = {{0}, primitive_tag, "cdaaar", &_cdaaar};
+static primitive_type cdaadr_primitive = {{0}, primitive_tag, "cdaadr", &_cdaadr};
+static primitive_type cdadar_primitive = {{0}, primitive_tag, "cdadar", &_cdadar};
+static primitive_type cdaddr_primitive = {{0}, primitive_tag, "cdaddr", &_cdaddr};
+static primitive_type cddaar_primitive = {{0}, primitive_tag, "cddaar", &_cddaar};
+static primitive_type cddadr_primitive = {{0}, primitive_tag, "cddadr", &_cddadr};
+static primitive_type cdddar_primitive = {{0}, primitive_tag, "cdddar", &_cdddar};
+static primitive_type cddddr_primitive = {{0}, primitive_tag, "cddddr", &_cddddr};
+static primitive_type char_91_125integer_primitive = {{0}, primitive_tag, "char->integer", &_char_91_125integer};
+static primitive_type integer_91_125char_primitive = {{0}, primitive_tag, "integer->char", &_integer_91_125char};
+static primitive_type string_91_125number_primitive = {{0}, primitive_tag, "string->number", &_string_91_125number};
+static primitive_type string_91length_primitive = {{0}, primitive_tag, "string-length", &_string_91length};
+static primitive_type substring_primitive = {{0}, primitive_tag, "substring", &_cyc_substring};
+static primitive_type string_91ref_primitive = {{0}, primitive_tag, "string-ref", &_cyc_string_91ref};
+static primitive_type string_91set_67_primitive = {{0}, primitive_tag, "string-set!", &_cyc_string_91set_67};
+static primitive_type make_91mutex_primitive = {{0}, primitive_tag, "make-mutex", &_Cyc_make_mutex};
+static primitive_type mutex_91lock_67_primitive = {{0}, primitive_tag, "mutex-lock!", &_Cyc_mutex_lock};
+static primitive_type mutex_91unlock_67_primitive = {{0}, primitive_tag, "mutex-unlock!", &_Cyc_mutex_unlock};
+static primitive_type mutex_127_primitive = {{0}, primitive_tag, "mutex?", &_mutex_127};
+static primitive_type Cyc_91installation_91dir_primitive = {{0}, primitive_tag, "Cyc-installation-dir", &_Cyc_91installation_91dir};
+static primitive_type command_91line_91arguments_primitive = {{0}, primitive_tag, "command-line-arguments", &_command_91line_91arguments};
+static primitive_type system_primitive = {{0}, primitive_tag, "system", &_cyc_system};
+static primitive_type string_91cmp_primitive = {{0}, primitive_tag, "string-cmp", &_string_91cmp};
+static primitive_type string_91append_primitive = {{0}, primitive_tag, "string-append", &_string_91append};
+static primitive_type list_91_125string_primitive = {{0}, primitive_tag, "list->string", &_list_91_125string};
+static primitive_type string_91_125symbol_primitive = {{0}, primitive_tag, "string->symbol", &_string_91_125symbol};
+static primitive_type symbol_91_125string_primitive = {{0}, primitive_tag, "symbol->string", &_symbol_91_125string};
+static primitive_type number_91_125string_primitive = {{0}, primitive_tag, "number->string", &_number_91_125string};
+static primitive_type list_91_125vector_primitive = {{0}, primitive_tag, "list-vector", &_list_91_125vector};
+static primitive_type make_91vector_primitive = {{0}, primitive_tag, "make-vector", &_make_91vector};
+static primitive_type vector_91ref_primitive = {{0}, primitive_tag, "vector-ref", &_vector_91ref};
+static primitive_type vector_91set_67_primitive = {{0}, primitive_tag, "vector-set!", &_vector_91set_67};
+static primitive_type boolean_127_primitive = {{0}, primitive_tag, "boolean?", &_boolean_127};
+static primitive_type char_127_primitive = {{0}, primitive_tag, "char?", &_char_127};
+static primitive_type eof_91object_127_primitive = {{0}, primitive_tag, "eof-object?", &_eof_91object_127};
+static primitive_type null_127_primitive = {{0}, primitive_tag, "null?", &_null_127};
+static primitive_type number_127_primitive = {{0}, primitive_tag, "number?", &_number_127};
+static primitive_type real_127_primitive = {{0}, primitive_tag, "real?", &_real_127};
+static primitive_type integer_127_primitive = {{0}, primitive_tag, "integer?", &_integer_127};
+static primitive_type pair_127_primitive = {{0}, primitive_tag, "pair?", &_pair_127};
+static primitive_type procedure_127_primitive = {{0}, primitive_tag, "procedure?", &_procedure_127};
+static primitive_type macro_127_primitive = {{0}, primitive_tag, "macro?", &_macro_127};
+static primitive_type port_127_primitive = {{0}, primitive_tag, "port?", &_port_127};
+static primitive_type vector_127_primitive = {{0}, primitive_tag, "vector?", &_vector_127};
+static primitive_type string_127_primitive = {{0}, primitive_tag, "string?", &_string_127};
+static primitive_type symbol_127_primitive = {{0}, primitive_tag, "symbol?", &_symbol_127};
+static primitive_type open_91input_91file_primitive = {{0}, primitive_tag, "open-input-file", &_open_91input_91file};
+static primitive_type open_91output_91file_primitive = {{0}, primitive_tag, "open-output-file", &_open_91output_91file};
+static primitive_type close_91port_primitive = {{0}, primitive_tag, "close-port", &_close_91port};
+static primitive_type close_91input_91port_primitive = {{0}, primitive_tag, "close-input-port", &_close_91input_91port};
+static primitive_type close_91output_91port_primitive = {{0}, primitive_tag, "close-output-port", &_close_91output_91port};
+static primitive_type Cyc_91flush_91output_91port_primitive = {{0}, primitive_tag, "Cyc-flush-output-port", &_Cyc_91flush_91output_91port};
+static primitive_type file_91exists_127_primitive = {{0}, primitive_tag, "file-exists?", &_file_91exists_127};
+static primitive_type delete_91file_primitive = {{0}, primitive_tag, "delete-file", &_delete_91file};
+static primitive_type read_91char_primitive = {{0}, primitive_tag, "read-char", &_read_91char};
+static primitive_type peek_91char_primitive = {{0}, primitive_tag, "peek-char", &_peek_91char};
+static primitive_type Cyc_91read_91line_primitive = {{0}, primitive_tag, "Cyc-read-line", &_Cyc_91read_91line};
+static primitive_type Cyc_91write_primitive = {{0}, primitive_tag, "Cyc-write", &_Cyc_91write};
+static primitive_type Cyc_91write_91char_primitive = {{0}, primitive_tag, "Cyc-write-char", &_Cyc_91write_91char};
+static primitive_type Cyc_91display_primitive = {{0}, primitive_tag, "Cyc-display", &_display};
+static primitive_type call_95cc_primitive = {{0}, primitive_tag, "call/cc", &_call_95cc};
const object primitive_Cyc_91global_91vars = &Cyc_91global_91vars_primitive;
const object primitive_Cyc_91get_91cvar = &Cyc_91get_91cvar_primitive;
const object primitive_Cyc_91set_91cvar_67 = &Cyc_91set_91cvar_67_primitive;
const object primitive_Cyc_91cvar_127 = &Cyc_91cvar_127_primitive;
const object primitive_Cyc_91has_91cycle_127 = &Cyc_91has_91cycle_127_primitive;
+const object primitive_Cyc_91spawn_91thread_67 = &Cyc_91spawn_91thread_67_primitive;
+const object primitive_Cyc_91end_91thread_67 = &Cyc_91end_91thread_67_primitive;
+const object primitive_thread_91sleep_67 = &thread_91sleep_67_primitive;
+const object primitive_Cyc_91minor_91gc = &Cyc_91minor_91gc_primitive;
const object primitive__87 = &_87_primitive;
const object primitive__91 = &_91_primitive;
const object primitive__85 = &_85_primitive;
@@ -2568,6 +2811,10 @@ const object primitive_string_91length = &string_91length_primitive;
const object primitive_substring = &substring_primitive;
const object primitive_string_91ref = &string_91ref_primitive;
const object primitive_string_91set_67 = &string_91set_67_primitive;
+const object primitive_make_91mutex = &make_91mutex_primitive;
+const object primitive_mutex_91lock_67 = &mutex_91lock_67_primitive;
+const object primitive_mutex_91unlock_67 = &mutex_91unlock_67_primitive;
+const object primitive_mutex_127 = &mutex_127_primitive;
const object primitive_Cyc_91installation_91dir = &Cyc_91installation_91dir_primitive;
const object primitive_command_91line_91arguments = &command_91line_91arguments_primitive;
const object primitive_system = &system_primitive;
@@ -2609,3 +2856,100 @@ const object primitive_Cyc_91write = &Cyc_91write_primitive;
const object primitive_Cyc_91display = &Cyc_91display_primitive;
const object primitive_call_95cc = &call_95cc_primitive;
+/**
+ * Thread initialization function only called from within the runtime
+ */
+void *Cyc_init_thread(object thunk)
+{
+ long stack_start;
+ gc_thread_data *thd;
+ thd = malloc(sizeof(gc_thread_data));
+ gc_thread_data_init(thd, 0, (char *) &stack_start, global_stack_size);
+ thd->gc_cont = thunk;
+ thd->gc_num_args = 1;
+ thd->gc_args[0] = &Cyc_91end_91thread_67_primitive;
+// thd->thread = pthread_self(); // TODO: ptr vs instance
+// returns instance so would need to malloc here
+// would also need to update termination code to free that memory
+ gc_add_mutator(thd);
+ ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_NEW, CYC_THREAD_STATE_RUNNABLE);
+ Cyc_start_trampoline(thd);
+ return NULL;
+}
+
+/**
+ * Spawn a new thread to execute the given thunk
+ */
+object Cyc_spawn_thread(object thunk)
+{
+// TODO: if we want to return mutator number to the caller, we need
+// to reserve a number here. need to figure out how we are going to
+// synchronize access to GC mutator fields, and then reserve one
+// here. will need to pass it, along with thunk, to Cyc_init_thread.
+// Then can use a new function up there to add the mutator, since we
+// already have the number.
+/*
+how to manage gc mutators. need to handle:
+- need to be able to allocate a thread but not run it yet.
+ maybe have a run level, or status
+- need to make mutators thread safe, ideally without major performance impacts
+- thread terminates
+ - should mark mutator as 'done'
+ - at an opportune moment, free mutator and set it back
+ to null
+
+what is the right data structure? is the array OK? or would it be better
+to look at the lock-free structures provided by ck?
+*/
+ pthread_t thread;
+ pthread_attr_t attr;
+ pthread_attr_init(&attr);
+ pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
+ if (pthread_create(&thread, NULL, Cyc_init_thread, thunk)) {
+ fprintf(stderr, "Error creating a new thread\n");
+ exit(1);
+ }
+ return boolean_t;
+}
+
+/**
+ * Terminate a thread
+ */
+void Cyc_end_thread(gc_thread_data *thd)
+{
+ // TODO: should we consider passing the current continuation (and args)
+ // as an argument? if we don't, will objects be collected that are still
+ // being used by active threads??
+ mclosure0(clo, Cyc_exit_thread);
+ GC(thd, &clo, thd->gc_args, 0);
+}
+
+void Cyc_exit_thread(gc_thread_data *thd)
+{
+ // alternatively could call longjmp with a null continuation, but that seems
+ // more complicated than necessary. or does it... see next comment:
+
+ // TODO: what if there are any locals from the thread's stack still being
+ // referenced? might want to do one more minor GC to clear the stack before
+ // terminating the thread
+
+//printf("DEBUG - exiting thread\n");
+ // Remove thread from the list of mutators, and mark its data to be freed
+ gc_remove_mutator(thd);
+ ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_RUNNABLE, CYC_THREAD_STATE_TERMINATED);
+ pthread_exit(NULL); // For now, just a proof of concept
+}
+
+// For now, accept a number of milliseconds to sleep
+object Cyc_thread_sleep(void *data, object timeout)
+{
+ struct timespec tim;
+ long value;
+ Cyc_check_num(data, timeout);
+ value = ((integer_type *)timeout)->value;
+ tim.tv_sec = value / 1000;
+ tim.tv_nsec = (value % 1000) * NANOSECONDS_PER_MILLISECOND;
+ nanosleep(&tim, NULL);
+ return boolean_t;
+}
+
diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld
index b3beba69..d5410753 100644
--- a/scheme/cyclone/cgen.sld
+++ b/scheme/cyclone/cgen.sld
@@ -74,11 +74,23 @@
(define *c-main-function*
"main(int argc,char **argv)
-{long stack_size = global_stack_size = STACK_SIZE;
+{gc_thread_data *thd;
+ long stack_size = global_stack_size = STACK_SIZE;
long heap_size = global_heap_size = HEAP_SIZE;
+ 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;
- Cyc_main(stack_size,heap_size,(char *) &stack_size);
+ 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;
+ gc_add_mutator(thd);
+ Cyc_heap_init(heap_size);
+ thd->thread_state = CYC_THREAD_STATE_RUNNABLE;
+ Cyc_start_trampoline(thd);
return 0;}")
;;; Auto-generation of C macros
@@ -110,12 +122,12 @@
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
"/* Check for GC, then call given continuation closure */\n"
- "#define return_closcall" n "(cfn" args ") \\\n"
+ "#define return_closcall" n "(td,cfn" args ") \\\n"
"{char stack; \\\n"
- " if (check_overflow(&stack,stack_limit1)) { \\\n"
+ " if (check_overflow(&stack,(((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign "\\\n"
- " GC(cfn,buf," n "); return; \\\n"
- " } else {closcall" n "((closure) (cfn)" args "); return;}}\n")))
+ " GC(td,cfn,buf," n "); return; \\\n"
+ " } else {closcall" n "(td,(closure) (cfn)" args "); return;}}\n")))
(define (c-macro-return-direct num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
@@ -123,13 +135,13 @@
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
"/* Check for GC, then call C function directly */\n"
- "#define return_direct" n "(_fn" args ") { \\\n"
+ "#define return_direct" n "(td,_fn" args ") { \\\n"
" char stack; \\\n"
- " if (check_overflow(&stack,stack_limit1)) { \\\n"
+ " if (check_overflow(&stack,(((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign " \\\n"
" mclosure0(c1, _fn); \\\n"
- " GC(&c1, buf, " n "); return; \\\n"
- " } else { (_fn)(" n ",(closure)_fn" args "); }}\n")))
+ " GC(td,&c1, buf, " n "); return; \\\n"
+ " } else { (_fn)(td," n ",(closure)_fn" args "); }}\n")))
(define (c-macro-closcall num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
@@ -137,10 +149,10 @@
(n-1 (number->string (if (> num-args 0) (- num-args 1) 0)))
(wrap (lambda (s) (if (> num-args 0) s ""))))
(string-append
- "#define closcall" n "(cfn" args ") "
- (wrap (string-append "if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(" n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }"))
+ "#define closcall" n "(td,cfn" args ") "
+ (wrap (string-append "if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(td," n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }"))
(wrap " else { ")
- "((cfn)->fn)(" n ",cfn" args ")"
+ "((cfn)->fn)(td," n ",cfn" args ")"
(wrap ";}")
)))
@@ -172,7 +184,7 @@
(null? (cdr trace)))
""
(string-append
- "Cyc_st_add(\""
+ "Cyc_st_add(data, \""
(car trace)
":"
;; TODO: escape backslashes
@@ -439,6 +451,9 @@
((eq? p 'Cyc-set-cvar!) "Cyc_set_cvar")
((eq? p 'Cyc-cvar?) "Cyc_is_cvar")
((eq? p 'Cyc-has-cycle?) "Cyc_has_cycle")
+ ((eq? p 'Cyc-spawn-thread!) "Cyc_spawn_thread")
+ ((eq? p 'Cyc-end-thread!) "Cyc_end_thread")
+ ((eq? p 'thread-sleep!) "Cyc_thread_sleep")
((eq? p 'Cyc-stdout) "Cyc_stdout")
((eq? p 'Cyc-stdin) "Cyc_stdin")
((eq? p 'Cyc-stderr) "Cyc_stderr")
@@ -518,8 +533,13 @@
((eq? p 'string-ref) "Cyc_string_ref")
((eq? p 'string-set!) "Cyc_string_set")
((eq? p 'substring) "Cyc_substring")
+ ((eq? p 'make-mutex) "Cyc_make_mutex")
+ ((eq? p 'mutex-lock!) "Cyc_mutex_lock")
+ ((eq? p 'mutex-unlock!) "Cyc_mutex_unlock")
+ ((eq? p 'mutex?) "Cyc_is_mutex")
((eq? p 'Cyc-installation-dir) "Cyc_installation_dir")
((eq? p 'command-line-arguments) "Cyc_command_line_arguments")
+ ((eq? p 'Cyc-minor-gc) "Cyc_trigger_minor_gc")
((eq? p 'system) "Cyc_system")
((eq? p 'assq) "assq")
((eq? p 'assv) "assq")
@@ -555,6 +575,69 @@
(else
(error "unhandled primitive: " p))))
+;; Does the primitive require passing thread data as its first argument?
+(define (prim/data-arg? p)
+ (member p '(
+ +
+ -
+ *
+ /
+ =
+ >
+ <
+ >=
+ <=
+ apply
+ Cyc-default-exception-handler
+ Cyc-end-thread!
+ thread-sleep!
+ open-input-file
+ open-output-file
+ close-port
+ close-input-port
+ close-output-port
+ Cyc-flush-output-port
+ file-exists?
+ delete-file
+ read-char
+ peek-char
+ Cyc-read-line
+ Cyc-write-char
+ integer->char
+ string->number
+ list->string
+ make-vector
+ list->vector
+ vector-length
+ vector-ref
+ vector-set!
+ string-append
+ string-cmp
+ string->symbol
+ symbol->string
+ number->string
+ string-length
+ string-ref
+ string-set!
+ substring
+ make-mutex
+ mutex-lock!
+ mutex-unlock!
+ Cyc-installation-dir
+ command-line-arguments
+ Cyc-minor-gc
+ assq
+ assv
+ assoc
+ memq
+ memv
+ member
+ length
+ set-car!
+ set-cdr!
+ procedure?
+ set-cell!)))
+
;; Determine if primitive assigns (allocates) a C variable
;; EG: int v = prim();
(define (prim/c-var-assign p)
@@ -567,25 +650,31 @@
((eq? p 'length) "integer_type")
((eq? p 'vector-length) "integer_type")
((eq? p 'char->integer) "integer_type")
- ((eq? p 'Cyc-installation-dir) "string_type")
((eq? p 'system) "integer_type")
((eq? p '+) "common_type")
((eq? p '-) "common_type")
((eq? p '*) "common_type")
((eq? p '/) "common_type")
((eq? p 'string->number) "common_type")
- ((eq? p 'list->string) "string_type")
((eq? p 'string-cmp) "integer_type")
- ((eq? p 'string-append) "string_type")
- ((eq? p 'symbol->string) "string_type")
- ((eq? p 'number->string) "string_type")
+ ((eq? p 'string-append) "object")
((eq? p 'string-length) "integer_type")
- ((eq? p 'substring) "string_type")
((eq? p 'apply) "object")
((eq? p 'Cyc-read-line) "object")
+ ((eq? p 'read-char) "object")
+ ((eq? p 'peek-char) "object")
((eq? p 'command-line-arguments) "object")
+ ((eq? p 'Cyc-minor-gc) "object")
+ ((eq? p 'number->string) "object")
+ ((eq? p 'symbol->string) "object")
+ ((eq? p 'substring) "object")
((eq? p 'make-vector) "object")
+ ((eq? p 'list->string) "object")
((eq? p 'list->vector) "object")
+ ;((eq? p 'make-mutex) "object")
+ ((eq? p 'mutex-lock!) "object")
+ ((eq? p 'mutex-unlock!) "object")
+ ((eq? p 'Cyc-installation-dir) "object")
(else #f)))
;; Determine if primitive creates a C variable
@@ -607,18 +696,25 @@
string-length substring
+ - * / apply
command-line-arguments
+ ;make-mutex
+ mutex-lock! mutex-unlock!
+ Cyc-minor-gc
Cyc-read-line
+ read-char peek-char
cons length vector-length cell))))
;; Pass continuation as the function's first parameter?
(define (prim:cont? exp)
(and (prim? exp)
- (member exp '(Cyc-read-line apply command-line-arguments make-vector list->vector))))
-;; TODO: this is a hack, right answer is to include information about
-;; how many args each primitive is supposed to take
-(define (prim:cont-has-args? exp)
+ (member exp '(Cyc-read-line apply command-line-arguments Cyc-minor-gc number->string
+ read-char peek-char mutex-lock!
+ symbol->string list->string substring string-append
+ make-vector list->vector Cyc-installation-dir))))
+
+;; Primitive functions that pass a continuation or thread data but have no other arguments
+(define (prim:cont/no-args? exp)
(and (prim? exp)
- (member exp '(Cyc-read-line apply make-vector list->vector))))
+ (member exp '(command-line-arguments make-mutex Cyc-minor-gc))))
;; Pass an integer arg count as the function's first parameter?
(define (prim:arg-count? exp)
@@ -632,6 +728,13 @@
(and (prim? exp)
(member exp '())))
+;; Does string end with the given substring?
+;; EG: ("test(" "(") ==> #t
+(define (str-ending? str end)
+ (let ((len (string-length str)))
+ (and (> len 0)
+ (equal? end (substring str (- len 1) len)))))
+
;; c-compile-prim : prim-exp -> string -> string
(define (c-compile-prim p cont)
(let* ((c-func (prim->c-func p))
@@ -652,6 +755,10 @@
"," cont "); "))
(else #f)))
;; END apply defs
+ (tdata (cond
+ ((prim/data-arg? p) "data")
+ (else "")))
+ (tdata-comma (if (> (string-length tdata) 0) "," ""))
(c-var-assign
(lambda (type)
(let ((cv-name (mangle (gensym 'c))))
@@ -670,12 +777,14 @@
;; Emit closure as first arg, if necessary (apply only)
(cond
(closure-def
- (string-append "&" closure-sym
- (if (prim:cont-has-args? p) ", " "")))
+ (string-append
+ tdata ","
+ "&" closure-sym))
((prim:cont? p)
- (string-append cont
- (if (prim:cont-has-args? p) ", " "")))
- (else "")))))))))
+ (string-append
+ tdata ","
+ cont))
+ (else tdata)))))))))
(cond
((prim/c-var-assign p)
(c-var-assign (prim/c-var-assign p)))
@@ -692,9 +801,9 @@
cv-name ;; Already a pointer
(string-append "&" cv-name)) ;; Point to data
(list
- (string-append c-func "(" cv-name)))))
+ (string-append c-func "(" cv-name tdata-comma tdata)))))
(else
- (c-code (string-append c-func "("))))))
+ (c-code (string-append c-func "(" tdata))))))
;; END primitives
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -751,7 +860,7 @@
(string-append
(c:allocs->str (c:allocs cgen))
"return_direct" (number->string num-cargs)
- "(" this-cont
+ "(data," this-cont
(if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
(c:body cgen) ");"))))
@@ -776,11 +885,24 @@
(c:allocs c-args*) ;; fun alloc depends upon arg allocs
(list (string-append
(car (c:allocs c-fun))
- (if (prim/c-var-assign fun) "" ",") ; Allocating C var
- (c:body c-args*) ");"))))
+ (if (prim/c-var-assign fun)
+ ;; Add a comma if there were any args to the func added by comp-prim
+ (if (or (str-ending? (car (c:allocs c-fun)) "(")
+ (prim:cont/no-args? fun))
+ ""
+ ",")
+ ",")
+ (c:body c-args*) ");"))))
;; Args stay with body
(c:append
- (c:append c-fun c-args*)
+ (c:append
+ (let ()
+ ;; Add a comma if necessary
+ (if (or (str-ending? (c:body c-fun) "(")
+ (prim:cont/no-args? fun))
+ c-fun
+ (c:append c-fun (c-code ", "))))
+ c-args*)
(c-code ")")))))
((equal? '%closure-ref fun)
@@ -803,7 +925,7 @@
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string (c:num-args cargs))
- "("
+ "(data,"
this-cont
(if (> (c:num-args cargs) 0) "," "")
(c:body cargs)
@@ -822,7 +944,7 @@
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string num-cargs)
- "("
+ "(data,"
this-cont
(if (> num-cargs 0) "," "")
(c:body cargs)
@@ -992,6 +1114,8 @@
(create-nclosure (lambda ()
(string-append
"closureN_type " cv-name ";\n"
+ cv-name ".hdr.mark = gc_color_red;\n "
+ cv-name ".hdr.grayed = 0;\n"
cv-name ".tag = closureN_tag;\n "
cv-name ".fn = (function_type)__lambda_" (number->string lid) ";\n"
cv-name ".num_args = " (number->string (compute-num-args lam)) ";\n"
@@ -1083,7 +1207,7 @@
(cons
(lambda (name)
(string-append "static void " name
- "(int argc, "
+ "(void *data, int argc, "
formals*
") {\n"
preamble
@@ -1169,7 +1293,7 @@
(lambda (l)
(emit*
"static void __lambda_"
- (number->string (car l)) "(int argc, "
+ (number->string (car l)) "(void *data, int argc, "
(cdadr l)
") ;"))
lambdas)
@@ -1185,14 +1309,14 @@
; Emit entry point
(cond
(program?
- (emit "static void c_entry_pt_first_lambda();")
+ (emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value);")
(for-each
(lambda (lib-name)
- (emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(int argc, closure cont, object value);"))
+ (emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(void *data, int argc, closure cont, object value);"))
required-libs)
- (emit "static void c_entry_pt(argc, env,cont) int argc; closure env,cont; { "))
+ (emit "static void c_entry_pt(data, argc, env,cont) void *data; int argc; closure env,cont; { "))
(else
- (emit* "void c_" (lib:name->string lib-name) "_entry_pt(argc, cont,value) int argc; closure cont; object value;{ ")
+ (emit* "void c_" (lib:name->string lib-name) "_entry_pt(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ")
; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");"))
))
@@ -1295,9 +1419,9 @@
(reverse required-libs)) ;; Init each lib's dependencies 1st
(emit*
;; Start cont chain, but do not assume closcall1 macro was defined
- "(" this-clo ".fn)(0, &" this-clo ", &" this-clo ");")
+ "(" this-clo ".fn)(data, 0, &" this-clo ", &" this-clo ");")
(emit "}")
- (emit "static void c_entry_pt_first_lambda(int argc, closure cont, object value) {")
+ (emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value) {")
; DEBUG (emit (string-append "printf(\"init first lambda\\n\");"))
(emit compiled-program)))
(else
@@ -1307,7 +1431,7 @@
(emit*
"(((closure)"
(mangle-global (lib:name->symbol lib-name))
- ")->fn)(1, cont, cont);")
+ ")->fn)(data, 1, cont, cont);")
))
(emit "}")
diff --git a/scheme/cyclone/common.sld b/scheme/cyclone/common.sld
index 980ab676..57bf60e5 100644
--- a/scheme/cyclone/common.sld
+++ b/scheme/cyclone/common.sld
@@ -5,7 +5,7 @@
*version-banner*
*c-file-header-comment*)
(begin
-(define *version* "0.0.3 (Pre-release)")
+(define *version* "0.0.4 (Pre-release)")
(define *version-banner*
(string-append "
@@ -18,7 +18,7 @@
,@ https://github.com/justinethier/cyclone
'@
.@
- @@ #@ (c) 2014 Justin Ethier
+ @@ #@ (c) 2014-2016 Justin Ethier
`@@@#@@@. Version " *version* "
#@@@@@
+@@@+
@@ -33,7 +33,7 @@
(string-append "/**
** This file was automatically generated by the Cyclone scheme compiler
**
- ** (c) 2014 Justin Ethier
+ ** (c) 2014-2016 Justin Ethier
** Version " *version* "
**
**/
diff --git a/scheme/cyclone/libraries.sld b/scheme/cyclone/libraries.sld
index 5992af23..fe37069b 100644
--- a/scheme/cyclone/libraries.sld
+++ b/scheme/cyclone/libraries.sld
@@ -19,6 +19,7 @@
)
(export
library?
+ lib:list->import-set
lib:name
lib:name->string
lib:name->symbol
@@ -43,7 +44,19 @@
(define (library? ast)
(tagged-list? 'define-library ast))
-(define (lib:name ast) (cadr ast))
+;; 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.
+(define (lib:list->import-set lis)
+ (map
+ (lambda (atom)
+ (cond
+ ((number? atom)
+ (string->symbol (number->string atom)))
+ (else atom)))
+ lis))
+
+(define (lib:name ast)
+ (lib:list->import-set (cadr ast)))
;; Convert name (as list of symbols) to a mangled string
(define (lib:name->string name)
@@ -70,7 +83,7 @@
(define (lib:imports ast)
(lib:result
(let ((code (assoc 'import (cddr ast))))
- (if code (cdr code) #f))))
+ (if code (lib:list->import-set (cdr code)) #f))))
(define (lib:body ast)
(lib:result
(let ((code (assoc 'begin (cddr ast))))
@@ -86,6 +99,15 @@
;; TODO: include-ci, cond-expand
+(define (lib:atom->string atom)
+ (cond
+ ((symbol? atom)
+ (symbol->string atom))
+ ((number? atom)
+ (number->string atom))
+ (else
+ (error "Unexpected type in import set"))))
+
;; Resolve library filename given an import.
;; Assumes ".sld" file extension if one is not specified.
(define (lib:import->filename import . ext)
@@ -99,12 +121,13 @@
string-append
(map
(lambda (i)
- (string-append "/" (symbol->string i)))
+ (string-append "/" (lib:atom->string i)))
import))
file-ext))
(filename
(substring filename* 1 (string-length filename*))))
- (if (tagged-list? 'scheme import)
+ (if (or (tagged-list? 'scheme import)
+ (tagged-list? 'srfi import))
(string-append (Cyc-installation-dir 'sld) "/" filename) ;; Built-in library
filename)))
@@ -116,7 +139,7 @@
string-append
(map
(lambda (i)
- (string-append (symbol->string i) "/"))
+ (string-append (lib:atom->string i) "/"))
import-path))))
(if (tagged-list? 'scheme import)
(string-append (Cyc-installation-dir 'sld) "/" path) ;; Built-in library
@@ -164,7 +187,7 @@
(map
(lambda (import)
(lib:import->export-list import))
- imports)))
+ (lib:list->import-set imports))))
(define (lib:import->metalist import)
(let ((file (lib:import->filename import ".meta"))
@@ -191,18 +214,19 @@
(define (lib:get-all-import-deps imports)
(letrec ((libraries/deps '())
(find-deps!
- (lambda (import-set)
+ (lambda (import-sets)
(for-each
(lambda (i)
- (cond
- ;; Prevent cycles by only processing new libraries
- ((not (assoc i libraries/deps))
- ;; Find all dependencies of i (IE, libraries it imports)
- (let ((deps (lib:read-imports i)))
- (set! libraries/deps (cons (cons i deps) libraries/deps))
- (find-deps! deps)
- ))))
- import-set))))
+ (let ((import-set (lib:list->import-set i)))
+ (cond
+ ;; Prevent cycles by only processing new libraries
+ ((not (assoc import-set libraries/deps))
+ ;; Find all dependencies of i (IE, libraries it imports)
+ (let ((deps (lib:read-imports import-set)))
+ (set! libraries/deps (cons (cons import-set deps) libraries/deps))
+ (find-deps! deps)
+ )))))
+ import-sets))))
(find-deps! imports)
;`((deps ,libraries/deps) ; DEBUG
; (result ,(lib:get-dep-list libraries/deps)))
diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld
index 3a5d23df..5fc724dc 100644
--- a/scheme/cyclone/transforms.sld
+++ b/scheme/cyclone/transforms.sld
@@ -451,6 +451,10 @@
Cyc-set-cvar!
Cyc-cvar? ;; Cyclone-specific
Cyc-has-cycle?
+ Cyc-spawn-thread!
+ Cyc-end-thread!
+ thread-sleep!
+ Cyc-minor-gc
Cyc-stdout
Cyc-stdin
Cyc-stderr
@@ -512,6 +516,10 @@
vector-length
vector-ref
vector-set!
+ make-mutex
+ mutex-lock!
+ mutex-unlock!
+ mutex?
boolean?
char?
eof-object?
@@ -554,6 +562,10 @@
Cyc-get-cvar
Cyc-set-cvar!
Cyc-cvar?
+ Cyc-spawn-thread!
+ Cyc-end-thread!
+ thread-sleep!
+ Cyc-minor-gc
apply
%halt
exit
@@ -571,6 +583,10 @@
string-set!
string->symbol ;; Could be mistaken for an identifier
make-vector
+ make-mutex
+ mutex-lock!
+ mutex-unlock!
+ mutex?
;; I/O must be done at runtime for side effects:
Cyc-stdout
Cyc-stdin
diff --git a/scheme/eval.sld b/scheme/eval.sld
index 45f69be6..bd7deab7 100644
--- a/scheme/eval.sld
+++ b/scheme/eval.sld
@@ -136,6 +136,9 @@
(list 'Cyc-set-cvar! Cyc-set-cvar!)
(list 'Cyc-cvar? Cyc-cvar?)
(list 'Cyc-has-cycle? Cyc-has-cycle?)
+ (list 'Cyc-spawn-thread! Cyc-spawn-thread!)
+ (list 'Cyc-end-thread! Cyc-end-thread!)
+ (list 'thread-sleep! thread-sleep!)
(list 'Cyc-default-exception-handler Cyc-default-exception-handler)
(list 'Cyc-current-exception-handler Cyc-current-exception-handler)
(list '+ +)
@@ -153,6 +156,7 @@
(list 'Cyc-installation-dir Cyc-installation-dir)
(list 'system system)
(list 'command-line-arguments command-line-arguments)
+ (list 'Cyc-minor-gc Cyc-minor-gc)
(list 'error error)
(list 'cons cons)
(list 'cell-get cell-get)
@@ -219,6 +223,10 @@
(list 'vector-length vector-length)
(list 'vector-ref vector-ref)
(list 'vector-set! vector-set!)
+ (list 'make-mutex make-mutex)
+ (list 'mutex-lock! mutex-lock!)
+ (list 'mutex-unlock! mutex-unlock!)
+ (list 'mutex? mutex?)
(list 'boolean? boolean?)
(list 'char? char?)
(list 'eof-object? eof-object?)
diff --git a/srfi/18.sld b/srfi/18.sld
new file mode 100644
index 00000000..32676df0
--- /dev/null
+++ b/srfi/18.sld
@@ -0,0 +1,45 @@
+(define-library (srfi 18)
+ (import (scheme base))
+ (export
+ thread?
+ make-thread
+ thread-name
+ thread-specific
+ thread-specific-set!
+ thread-start!
+ thread-yield!
+; thread-terminate!
+ ; For now, these are built-ins. No need for them here: make-mutex mutex-lock! mutex-unlock!
+ )
+ (begin
+ ;; Threading
+ (define (thread? obj)
+ (and (vector? obj)
+ (> (vector-length obj) 0)
+ (equal? 'cyc-thread-obj (vector-ref obj 0))))
+
+ (define (make-thread thunk . name)
+ (let ((name-str (if (pair? name)
+ (car name)
+ "")))
+ ;; Fields supported so far:
+ ;; - type marker (implementation-specific)
+ ;; - thunk
+ ;; - internal thread id (implementation-specific)
+ ;; - name
+ ;; - specific
+ (vector 'cyc-thread-obj thunk #f name-str #f)))
+
+ (define (thread-name t) (vector-ref t 3))
+ (define (thread-specific t) (vector-ref t 4))
+ (define (thread-specific-set! t obj) (vector-set! t 4 obj))
+; TODO:
+; current-thread - not sure how to look this up yet... may need a global list of running threads
+ (define (thread-start! t)
+ (let* ((thunk (vector-ref t 1))
+ (mutator-id (Cyc-spawn-thread! thunk)))
+ (vector-set! t 2 mutator-id)))
+ (define (thread-yield!) (thread-sleep! 1))
+; (define (thread-terminate!) (Cyc-end-thread!))
+ ;; TODO: thread-join!
+))
diff --git a/test-ck.c b/test-ck.c
new file mode 100644
index 00000000..e497de63
--- /dev/null
+++ b/test-ck.c
@@ -0,0 +1,219 @@
+/*
+compile with ck in above directory, and using:
+gcc test.c -g -lck && ./a.out
+gcc test.c -std=c99 -g -lck && ./a.out
+*/
+
+#include
+#include "include/cyclone/types.h"
+
+static void
+my_free(void *p, size_t m, bool d)
+{
+ free(p);
+ return;
+}
+
+static void *
+my_malloc(size_t b)
+{
+ return malloc(b);
+}
+
+static void *
+my_realloc(void *r, size_t a, size_t b, bool d)
+{
+ return realloc(r, b);
+}
+static struct ck_malloc m = {
+ .malloc = my_malloc,
+ .free = my_free,
+ .realloc = my_realloc
+};
+
+void main()
+{
+ ck_array_t array;
+ ck_array_iterator_t iterator;
+ gc_thread_data a, b, c;
+ void *pointer;
+ a.gc_num_args = 0;
+ b.gc_num_args = 1;
+ c.gc_num_args = 2;
+
+ if (ck_array_init(&array, CK_ARRAY_MODE_SPMC, &m, 10) == 0){
+ printf("Unable to init array\n");
+ exit(1);
+ }
+
+ ck_array_put_unique(&array, (void *)&a);
+ ck_array_put_unique(&array, (void *)&b);
+ ck_array_put_unique(&array, (void *)&b);
+ ck_array_commit(&array);
+ CK_ARRAY_FOREACH(&array, &iterator, &pointer){
+ printf("value = %d\n", ((gc_thread_data *)pointer)->gc_num_args);
+ }
+ printf("length = %d\n", ck_array_length(&array));
+ ck_array_remove(&array, &a);
+ ck_array_commit(&array);
+
+ printf("length = %d\n", ck_array_length(&array));
+ CK_ARRAY_FOREACH(&array, &iterator, &pointer){
+ printf("looping, value = %d\n", ((gc_thread_data *)pointer)->gc_num_args);
+ ck_array_put_unique(&array, (void *)&c);
+ ck_array_commit(&array);
+ }
+ printf("length = %d\n", ck_array_length(&array));
+ ck_array_deinit(&array, false);
+}
+//#include
+//#include "../ck/src/ck_ht_hash.h"
+//#include "include/cyclone/types.h"
+//
+//static ck_hs_t hs_symbol_table;
+//
+//static void *hs_malloc(size_t r)
+//{
+// return malloc(r);
+//}
+//
+//static void hs_free(void *p, size_t b, bool r)
+//{
+// (void)b;
+// (void)r;
+// free(p);
+// return;
+//}
+//
+//static struct ck_malloc my_allocator = {
+// .malloc = hs_malloc,
+// .free = hs_free
+//};
+//
+//static unsigned long hs_hash(const void *object, unsigned long seed)
+//{
+//// const char *c = object;
+//// unsigned long h;
+////
+//// h = (unsigned long)MurmurHash64A(c, strlen(c), seed);
+//// return h;
+// const symbol_type *c = object;
+// unsigned long h;
+//
+// h = (unsigned long)MurmurHash64A(c->pname, strlen(c->pname), seed);
+// return h;
+//}
+//
+//static bool
+//hs_compare(const void *previous, const void *compare)
+//{
+//
+// return strcmp((previous), (compare)) == 0;
+// //return strcmp(symbol_pname(previous), symbol_pname(compare)) == 0;
+//}
+//static void *
+//set_get(ck_hs_t *hs, const void *value)
+//{
+// unsigned long h;
+// void *v;
+//
+// h = CK_HS_HASH(hs, hs_hash, value);
+// v = ck_hs_get(hs, h, value);
+// return v;
+//}
+//
+//static bool
+//set_insert(ck_hs_t *hs, const void *value)
+//{
+// unsigned long h;
+//
+// h = CK_HS_HASH(hs, hs_hash, value);
+// return ck_hs_put(hs, h, value);
+//}
+//
+//char *_strdup (const char *s) {
+// char *d = malloc (strlen (s) + 1);
+// if (d) { strcpy (d,s); }
+// return d;
+//}
+//
+//object find_symbol_by_name(const char *name) {
+// symbol_type tmp = {{0}, symbol_tag, name, nil};
+// object result = set_get(&hs_symbol_table, &tmp);
+// if (result) {
+// printf("found symbol %s\n", symbol_pname(result));
+// }
+// return result;
+//}
+//
+//object add_symbol(symbol_type *psym) {
+// printf("Adding symbol %s\n", symbol_pname(psym));
+// set_insert(&hs_symbol_table, psym);
+// return psym;
+//}
+//
+//object add_symbol_by_name(const char *name) {
+// symbol_type sym = {{0}, symbol_tag, _strdup(name), nil};
+// symbol_type *psym = malloc(sizeof(symbol_type));
+// memcpy(psym, &sym, sizeof(symbol_type));
+// return add_symbol(psym);
+//}
+//
+//object find_or_add_symbol(const char *name){
+// object sym = find_symbol_by_name(name);
+// if (sym){
+// return sym;
+// } else {
+// return add_symbol_by_name(name);
+// }
+//}
+//
+//void main()
+//{
+// char astr[] = "a";
+// char bstr[] = "b";
+// char cstr[] = "c";
+// symbol_type a = {{0}, symbol_tag, astr, nil};
+// symbol_type aa = {{0}, symbol_tag, astr, nil};
+// symbol_type b = {{0}, symbol_tag, bstr, nil};
+// symbol_type c = {{0}, symbol_tag, cstr, nil};
+//
+// if (!ck_hs_init(&hs_symbol_table,
+// CK_HS_MODE_OBJECT | CK_HS_MODE_SPMC,
+// hs_hash, hs_compare,
+// &my_allocator,
+// 1024, 43423)){
+// fprintf(stderr, "Unable to initialize symbol table\n");
+// exit(1);
+// }
+//
+//
+//// set_insert(&hs_symbol_table, &a);
+//// printf("hs length = %ld\n", ck_hs_count(&hs_symbol_table));
+//// printf("has \"a\" = %p\n", set_get(&hs_symbol_table, &aa));
+//// printf("has \"b\" = %p\n", set_get(&hs_symbol_table, &b));
+//// printf("has \"c\" = %p\n", set_get(&hs_symbol_table, &c));
+////
+//// set_insert(&hs_symbol_table, &b);
+//// printf("hs length = %ld\n", ck_hs_count(&hs_symbol_table));
+//// printf("has \"a\" = %p\n", set_get(&hs_symbol_table, &aa));
+//// printf("has \"b\" = %p\n", set_get(&hs_symbol_table, &b));
+//// printf("has \"c\" = %p\n", set_get(&hs_symbol_table, &c));
+//
+// object asym = find_or_add_symbol("producer");
+// printf("%p\n", asym);
+//
+// object bsym = find_or_add_symbol("b");
+// printf("hs length = %ld\n", ck_hs_count(&hs_symbol_table));
+//
+// object csym = find_or_add_symbol("lambda");
+// printf("hs length = %ld\n", ck_hs_count(&hs_symbol_table));
+//
+// object dsym = find_or_add_symbol("d");
+// printf("hs length = %ld\n", ck_hs_count(&hs_symbol_table));
+//
+// object aasym = find_or_add_symbol("producer");
+// printf("%p\n", aasym);
+// printf("hs length = %ld\n", ck_hs_count(&hs_symbol_table));
+// return;
+//}
diff --git a/test.scm b/test.scm
index ac4233e8..f67c442b 100644
--- a/test.scm
+++ b/test.scm
@@ -1,28 +1,1579 @@
(import (scheme base)
+ (scheme read)
(scheme write)
- (scheme read))
+ (srfi 18))
-(write `(read ,(+ 1 2 3)))
-(write `(read ,(list 1 2 3)))
-(write `(read ,@(list 1 2 3)))
-;;`(read ,
-(write (make-vector 4 #t))
-(write (string->list "abc"))
-(write (apply append '((1) (2) (3))))
-(write #(a))
-(write #(1 2 3))
-(write #((1) (2) (3)))
-(write (eq? #(1) #(1)))
-(write (equal? #(1 1 1) (make-vector 3 1)))
-(write '#(1))
-(write '#())
+;; Spawn off a thread
+;(let ((t (thread-start! (make-thread (lambda () (write 'a))))))
+; ;; Busy wait
+; (letrec ((foo (lambda () (bar)))
+; (bar (lambda () (foo))))
+; (foo))
+;)
-(define a (vector 1 2 3 4 5))
-(define b (vector 10 20 30 40 50))
-(vector-copy! b 1 a 0 2)
-(write (equal? b #(10 1 2 40 50)))
-(call-with-values
- (lambda () (values 1 1))
- (lambda (a) (write a)))
+(define tmp2 (make-mutex))
+(mutex-lock! tmp2)
+(mutex-unlock! tmp2)
+(set! tmp2 #f)
-(write (Cyc-stdout))
+;; A program to prove if cooperation is working, or if it
+;; is blocked by another thread. The (read) causes the main
+;; thread to block. The collector should be notified prior
+;; to the blocking call being made, and the collector should
+;; be able to cooperate on the main thread's behalf:
+(define tmp '())
+(thread-start!
+ (make-thread
+ (lambda ()
+ ;(write 'a)
+ (letrec ((loop (lambda ()
+ (set! tmp (cons "cons" tmp))
+ ;(write tmp)
+ (cond
+ ((> (length tmp) 1000)
+ ;(write "resetting tmp")
+ (set! tmp '()))
+ (else #f))
+ (loop))))
+ (loop))
+ )))
+(read)
+(write "main thread is done")
+
+;;;; A temporary file to attempt to repro crashing / data corruption
+;;(import (scheme base) (scheme write))
+;;
+;;(define lambdas (list))
+;;
+;;;; TODO: fill lambdas list
+;;
+;;(letrec
+;; ((init (lambda (n)
+;; (cond
+;; ((equal? n 0) #f)
+;; (else
+;; (set! lambdas (cons '(9 ("test")) lambdas))
+;; (init (- n 1))))))
+;; (main (lambda ()
+;; (for-each
+;; (lambda (l)
+;; (write (list
+;; "static void __lambda_"
+;; (number->string (car l)) "(void *data, int argc, "
+;; (cdadr l)
+;; ") ;")))
+;; lambdas)))
+;; (loop (lambda ()
+;; (main)
+;; (loop)))
+;; )
+;; (init 1000)
+;; (loop)
+;;)
+; TODO: a long list like this seems to cause trouble. but revisit later, after GC is stabilized
+;(define lambdas
+; '(
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; (9 ("test"))
+; ))