Merge branch 'gc-dev6'

Conflicts:
	runtime.c

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
+libcyclone.a: runtime.c include/cyclone/runtime.h include/cyclone/types.h gc.c dispatch.c
-	$(CC) -g -c -Iinclude dispatch.c -o dispatch.o
+	$(CC) $(CFLAGS) -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
+	$(CC) $(CFLAGS) -std=gnu99 -c -Iinclude gc.c -o gc.o
-	$(AR) rcs libcyclone.a runtime.o dispatch.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/ && \
+	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/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/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/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 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 -t cyclone.scm && cyclone -t icyc.scm && sudo make install-bin
+###	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
 

Makefile.config

@@ -1,6 +1,7 @@
 
 # install configuration
 
+CFLAGS    ?= -g
 CC        ?= cc
 AR        ?= ar
 #CD        ?= cd

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   ?=

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
 - [R<sup>5</sup>RS Scheme Specification](http://www.schemers.org/Documents/Standards/R5RS/HTML/)
 - [R<sup>7</sup>RS 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

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)

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

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
+TODO: need to develop this section better to come up with a workable/optimal approach to building things:
-- 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
 
+- 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.

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?
+*/

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);
   }
   }
 }" )))

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 <ck_stdint.h>
+#include <ck_string.h>
+
+//-----------------------------------------------------------------------------
+// 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 <stdlib.h>
+
+#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 */

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 c_entry_pt(void *,int,closure,closure);
-static void Cyc_main(long stack_size,long heap_size,char *stack_base);
+static void Cyc_heap_init(long heap_size);
-
-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 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);
+  gc_init_heap(heap_size);
-  allocp = (char *) ((((long) bottom)+7) & -8);
+  gc_start_collector();
-  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);}}
 
 #endif /* CYCLONE_RUNTIME_MAIN_H */

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) { \
+#define Cyc_check_num_args(data, fnc_name, num_args, args) { \
-  integer_type l = Cyc_length(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) { \
+#define Cyc_check_type(data, fnc_test, tag, obj) { \
-  if (eq(boolean_f, fnc_test(obj))) Cyc_invalid_type_error(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_or_nil(d,obj) { if (!nullp(obj)) { Cyc_check_cons(d,obj); }}
-#define Cyc_check_cons(obj) Cyc_check_type(Cyc_is_cons, cons_tag, obj);
+#define Cyc_check_cons(d,obj) Cyc_check_type(d,Cyc_is_cons, cons_tag, obj);
-#define Cyc_check_num(obj) Cyc_check_type(Cyc_is_number, integer_tag, obj);
+#define Cyc_check_num(d,obj) Cyc_check_type(d,Cyc_is_number, integer_tag, obj);
-#define Cyc_check_int(obj) Cyc_check_type(Cyc_is_integer, integer_tag, obj);
+#define Cyc_check_int(d,obj) Cyc_check_type(d,Cyc_is_integer, integer_tag, obj);
-#define Cyc_check_str(obj) Cyc_check_type(Cyc_is_string, string_tag, obj);
+#define Cyc_check_str(d,obj) Cyc_check_type(d,Cyc_is_string, string_tag, obj);
-#define Cyc_check_sym(obj) Cyc_check_type(Cyc_is_symbol, symbol_tag, obj);
+#define Cyc_check_sym(d,obj) Cyc_check_type(d,Cyc_is_symbol, symbol_tag, obj);
-#define Cyc_check_vec(obj) Cyc_check_type(Cyc_is_vector, vector_tag, obj);
+#define Cyc_check_vec(d,obj) Cyc_check_type(d,Cyc_is_vector, vector_tag, obj);
-#define Cyc_check_port(obj) Cyc_check_type(Cyc_is_port, port_tag, obj);
+#define Cyc_check_port(d,obj) Cyc_check_type(d,Cyc_is_port, port_tag, obj);
-#define Cyc_check_fnc(obj) Cyc_check_type(Cyc_is_procedure, closure2_tag, obj);
+#define Cyc_check_mutex(d,obj) Cyc_check_type(d,Cyc_is_mutex, mutex_tag, obj);
-void Cyc_invalid_type_error(int tag, object found);
+void Cyc_invalid_type_error(void *data, int tag, object found);
-void Cyc_check_obj(int tag, object obj);
+void Cyc_check_obj(void *data, int tag, object 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);
 /* 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);
+object apply(void *data, object cont, object func, object args);
-void Cyc_apply(int argc, closure cont, object prim, ...);
+void Cyc_apply(void *data, int argc, closure cont, object prim, ...);
-integer_type Cyc_string_cmp(object str1, object str2);
+integer_type Cyc_string_cmp(void *data, object str1, object str2);
-void dispatch_string_91append(int argc, object clo, object cont, object str1, ...);
+void dispatch_string_91append(void *data, 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);
 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(void *, object x, object y);
-object __num_eq(object x, object y);
+object __num_gt(void *, object x, object y);
-object __num_gt(object x, object y);
+object __num_lt(void *, object x, object y);
-object __num_lt(object x, object y);
+object __num_gte(void *, object x, object y);
-object __num_gte(object x, object y);
+object __num_lte(void *, object x, object y);
-object __num_lte(object x, object y);
 object Cyc_eq(object x, object y);
-object Cyc_set_car(object l, object val) ;
+object Cyc_set_car(void *, object l, object val) ;
-object Cyc_set_cdr(object l, object val) ;
+object Cyc_set_cdr(void *, object l, object val) ;
-integer_type Cyc_length(object l);
+integer_type Cyc_length(void *d, object l);
-integer_type Cyc_vector_length(object v);
+integer_type Cyc_vector_length(void *data, object v);
-object Cyc_vector_ref(object v, object k);
+object Cyc_vector_ref(void *d, object v, object k);
-object Cyc_vector_set(object v, object k, object obj);
+object Cyc_vector_set(void *d, object v, object k, object obj);
-object Cyc_make_vector(object cont, object len, object fill);
+object Cyc_make_vector(void *data, object cont, object len, object fill);
-object Cyc_list2vector(object cont, object l);
+object Cyc_list2vector(void *data, object cont, object l);
-string_type Cyc_number2string(object n) ;
+object Cyc_make_mutex(void *data);
-string_type Cyc_symbol2string(object sym) ;
+object Cyc_mutex_lock(void *data, object cont, object obj);
-object Cyc_string2symbol(object str);
+object Cyc_mutex_unlock(void *data, object obj);
-string_type Cyc_list2string(object lst);
+object Cyc_number2string(void *d, object cont, object n);
-common_type Cyc_string2number(object str);
+object Cyc_symbol2string(void *d, object cont, object sym) ;
-void dispatch_string_91append(int argc, object clo, object cont, object str1, ...);
+object Cyc_string2symbol(void *d, object str);
-string_type Cyc_string_append(int argc, object str1, ...);
+object Cyc_list2string(void *d, object cont, object lst);
-string_type Cyc_string_append_va_list(int argc, object str1, va_list ap);
+common_type Cyc_string2number(void *d, object str);
-integer_type Cyc_string_length(object str);
+object Cyc_string_append(void *data, object cont, int argc, object str1, ...);
-string_type Cyc_substring(object str, object start, object end);
+integer_type Cyc_string_length(void *data, object str);
-object Cyc_string_ref(object str, object k);
+object Cyc_substring(void *data, object cont, object str, object start, object end);
-object Cyc_string_set(object str, object k, object chr);
+object Cyc_string_ref(void *data, object str, object k);
-string_type Cyc_installation_dir();
+object Cyc_string_set(void *data, object str, object k, object chr);
-object Cyc_command_line_arguments(object cont);
+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_input_file(void *data, object str);
-port_type Cyc_io_open_output_file(object str);
+port_type Cyc_io_open_output_file(void *data, object str);
-object Cyc_io_close_port(object port);
+object Cyc_io_close_port(void *data, object port);
-object Cyc_io_close_input_port(object port);
+object Cyc_io_close_input_port(void *data, object port);
-object Cyc_io_close_output_port(object port);
+object Cyc_io_close_output_port(void *data, object port);
-object Cyc_io_flush_output_port(object port);
+object Cyc_io_flush_output_port(void *data, object port);
-object Cyc_io_delete_file(object filename);
+object Cyc_io_delete_file(void *data, object filename);
-object Cyc_io_file_exists(object filename);
+object Cyc_io_file_exists(void *data, object filename);
-object Cyc_io_read_char(object port);
+object Cyc_io_read_char(void *data, object cont, object port);
-object Cyc_io_peek_char(object port);
+object Cyc_io_peek_char(void *data, object cont, object port);
-object Cyc_io_read_line(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_sum_op(void *data, object x, object y);
-common_type Cyc_sub_op(object x, object y);
+common_type Cyc_sub_op(void *data, object x, object y);
-common_type Cyc_mul_op(object x, object y);
+common_type Cyc_mul_op(void *data, object x, object y);
-common_type Cyc_div_op(object x, object y);
+common_type Cyc_div_op(void *data, object x, object y);
-common_type Cyc_sum(int argc, object n, ...);
+common_type Cyc_sum(void *data, int argc, object n, ...);
-common_type Cyc_sub(int argc, object n, ...);
+common_type Cyc_sub(void *data, int argc, object n, ...);
-common_type Cyc_mul(int argc, object n, ...);
+common_type Cyc_mul(void *data, int argc, object n, ...);
-common_type Cyc_div(int argc, object n, ...);
+common_type Cyc_div(void *data, 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_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 memberp(void *,object,list);
-object memqp(object,list);
+object memqp(void *,object,list);
-char *transport(char *,int);
-void GC(closure,object*,int);
 
-void Cyc_st_init();
+object Cyc_spawn_thread(object thunk);
-void Cyc_st_add(char *frame);
+void Cyc_start_trampoline(gc_thread_data *thd);
-void Cyc_st_print(FILE *out);
+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 dispatch(void *data, int argc, function_type func, object clo, object cont, object args);
-void clear_mutations();
+void dispatch_va(void *data, int argc, function_type_va func, object clo, object cont, object args);
-extern list mutation_table;
+void do_dispatch(void *data, int argc, function_type func, object clo, object *buffer);
-
-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);
 
 /* 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_raise(void *data, object err);
-void Cyc_rt_raise2(const char *msg, object err);
+void Cyc_rt_raise2(void *data, const char *msg, object err);
-void Cyc_rt_raise_msg(const char *err);
+void Cyc_rt_raise_msg(void *data, const char *err);
 /* END exception handler */
 
 #endif /* CYCLONE_RUNTIME_H */

include/cyclone/types.h

@@ -16,26 +16,160 @@
 #include <stdarg.h>
 #include <string.h>
 #include <math.h>
+#include <pthread.h>
 
-/* Debug GC flag */
+// Maximum number of args that GC will accept
-#define DEBUG_GC 0
+#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 size of object tags */
-#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". */
 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;
+typedef struct {gc_header_type hdr; tag_type tag; int value;} integer_type;
-#define make_int(n,v) integer_type n; n.tag = integer_tag; n.value = v;
+#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 {tag_type tag; double value;} double_type;
+typedef struct {gc_header_type hdr; tag_type tag; double value;} double_type;
-#define make_double(n,v) double_type n; n.tag = double_tag; n.value = v;
+#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;
+typedef struct {gc_header_type hdr; tag_type tag; int len; char *str;} string_type;
-#define make_string(cv,s) string_type cv; cv.tag = string_tag; \
+//// TODO: new way to allocate strings, but this requires changes to 
-{ int len = strlen(s); cv.str = dhallocp; \
+//// all functions that allocate strings, the GC, cgen, and maybe more.
-  if ((dhallocp + len + 1) >= dhbottom + global_heap_size) { \
+//// Because these strings are (at least for now) allocaed on the stack.
-      printf("Fatal error: data heap overflow\n"); exit(1); } \
+#define make_string(cs, s) string_type cs; \
-  memcpy(dhallocp, s, len + 1); dhallocp += len + 1; }
+{ int len = strlen(s); cs.tag = string_tag; cs.len = len; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
-#define make_stringn(cv,s,len) string_type cv; cv.tag = string_tag; \
+  cs.str = alloca(sizeof(char) * (len + 1)); \
-{ cv.str = dhallocp; \
+  memcpy(cs.str, s, len + 1);}
-  if ((dhallocp + len + 1) >= dhbottom + global_heap_size) { \
+#define make_string_with_len(cs, s, length) string_type cs; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
-      printf("Fatal error: data heap overflow\n"); exit(1); } \
+{ int len = length; \
-  memcpy(dhallocp, s, len); dhallocp += len; \
+  cs.tag = string_tag; cs.len = len; \
-  *dhallocp = '\0'; dhallocp += 1;}
+  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;
+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.tag = port_tag; p.fp = f; p.mode = m;
+#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 {gc_header_type hdr; 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 {gc_header_type hdr; 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 {gc_header_type hdr; 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 {gc_header_type hdr; 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 {gc_header_type hdr; 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 {gc_header_type hdr; 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; 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 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.tag = closure0_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.tag = closure1_tag; \
+#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 */

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"
+      "     GC(td,cfn,buf," n "); return; \\\n"
-      " } else {closcall" n "((closure) (cfn)" args "); 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"
+      "     GC(td,&c1, buf, " n "); return; \\\n"
-      " } else { (_fn)(" n ",(closure)_fn" args "); }}\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 ") "
+      "#define closcall" n "(td,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)) "") "); }"))
+        (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 'string-append) "object")
-    ((eq? p 'symbol->string) "string_type")
-    ((eq? p 'number->string) "string_type")
     ((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))))
+       (member exp '(Cyc-read-line apply command-line-arguments Cyc-minor-gc number->string 
-;; TODO: this is a hack, right answer is to include information about
+                     read-char peek-char mutex-lock!
-;;  how many args each primitive is supposed to take
+                     symbol->string list->string substring string-append
-(define (prim:cont-has-args? exp)
+                     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 
+                        (string-append 
-                          (if (prim:cont-has-args? p) ", " "")))
+                          tdata ","
+                          "&" closure-sym))
                        ((prim:cont? p) 
-                        (string-append cont
+                        (string-append 
-                          (if (prim:cont-has-args? p) ", " "")))
+                          tdata ","
-                       (else "")))))))))
+                          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
+                    (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 "}")

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* "
  **
  **/

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)
+                (let ((import-set (lib:list->import-set i)))
                   (cond
                    ;; Prevent cycles by only processing new libraries
-                 ((not (assoc i libraries/deps))
+                   ((not (assoc import-set libraries/deps))
                     ;; Find all dependencies of i (IE, libraries it imports)
-                  (let ((deps (lib:read-imports i))) 
+                    (let ((deps (lib:read-imports import-set))) 
-                   (set! libraries/deps (cons (cons i deps) libraries/deps))
+                     (set! libraries/deps (cons (cons import-set deps) libraries/deps))
                      (find-deps! deps)
-                 ))))
+                   )))))
-              import-set))))
+              import-sets))))
    (find-deps! imports)
    ;`((deps ,libraries/deps) ; DEBUG
    ;  (result ,(lib:get-dep-list libraries/deps)))

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

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

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!
+))

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 <ck_array.h>
+#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 <ck_hs.h>
+//#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;
+//}