Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-05-24 04:25:06 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'gc-dev6'

Browse source 
Conflicts:
	runtime.c
This commit is contained in:
Justin Ethier 2016-01-05 02:57:36 -05:00
commit 16dc1f3f5e
23 changed files with 5793 additions and 1492 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

35
Makefile
View file

@ -21,7 +21,8 @@ SMODULES = \
scheme/cyclone/libraries \
scheme/cyclone/macros \
scheme/cyclone/transforms \
scheme/cyclone/util
scheme/cyclone/util \
srfi/18
SLDFILES = $(addsuffix .sld, $(SMODULES))
COBJECTS=$(SLDFILES:.sld=.o)
@ -42,13 +43,14 @@ dispatch.c: generate-c.scm
./generate-c
libcyclone.so.1: runtime.c include/cyclone/runtime.h
gcc -g -c -fPIC runtime.c -o runtime.o
gcc $(CFLAGS) -c -fPIC runtime.c -o runtime.o
gcc -shared -Wl,-soname,libcyclone.so.1 -o libcyclone.so.1.0.1 runtime.o
libcyclone.a: runtime.c include/cyclone/runtime.h include/cyclone/types.h dispatch.c
$(CC) -g -c -Iinclude dispatch.c -o dispatch.o
$(CC) -g -c -Iinclude -DCYC_INSTALL_DIR=\"$(PREFIX)\" -DCYC_INSTALL_LIB=\"$(LIBDIR)\" -DCYC_INSTALL_INC=\"$(INCDIR)\" -DCYC_INSTALL_SLD=\"$(DATADIR)\" runtime.c -o runtime.o
$(AR) rcs libcyclone.a runtime.o dispatch.o
libcyclone.a: runtime.c include/cyclone/runtime.h include/cyclone/types.h gc.c dispatch.c
$(CC) $(CFLAGS) -c -Iinclude dispatch.c -o dispatch.o
$(CC) $(CFLAGS) -std=gnu99 -c -Iinclude gc.c -o gc.o
$(CC) $(CFLAGS) -c -Iinclude -DCYC_INSTALL_DIR=\"$(PREFIX)\" -DCYC_INSTALL_LIB=\"$(LIBDIR)\" -DCYC_INSTALL_INC=\"$(INCDIR)\" -DCYC_INSTALL_SLD=\"$(DATADIR)\" runtime.c -o runtime.o
$(AR) rcs libcyclone.a runtime.o gc.o dispatch.o
# Instructions from: http://www.adp-gmbh.ch/cpp/gcc/create_lib.html
# Note compiler will have to link to this, eg:
#Linking against static library
@ -59,13 +61,17 @@ libcyclone.a: runtime.c include/cyclone/runtime.h include/cyclone/types.h dispat
bootstrap: icyc
# rm -rf $(BOOTSTRAP_DIR)
mkdir -p $(BOOTSTRAP_DIR)/scheme/cyclone
mkdir -p $(BOOTSTRAP_DIR)/srfi
mkdir -p $(BOOTSTRAP_DIR)/include/cyclone
cp include/cyclone/types.h $(BOOTSTRAP_DIR)/include/cyclone
cp include/cyclone/runtime-main.h $(BOOTSTRAP_DIR)/include/cyclone
cp include/cyclone/runtime.h $(BOOTSTRAP_DIR)/include/cyclone
cp include/cyclone/ck_ht_hash.h $(BOOTSTRAP_DIR)/include/cyclone
cp scheme/*.sld $(BOOTSTRAP_DIR)/scheme
cp scheme/cyclone/*.sld $(BOOTSTRAP_DIR)/scheme/cyclone
cp srfi/*.sld $(BOOTSTRAP_DIR)/srfi
cp runtime.c $(BOOTSTRAP_DIR)
cp gc.c $(BOOTSTRAP_DIR)
cp dispatch.c $(BOOTSTRAP_DIR)
cp scheme/base.c $(BOOTSTRAP_DIR)/scheme
cp scheme/read.c $(BOOTSTRAP_DIR)/scheme
@ -81,6 +87,7 @@ bootstrap: icyc
cp scheme/cyclone/transforms.c $(BOOTSTRAP_DIR)/scheme/cyclone
cp scheme/cyclone/cgen.c $(BOOTSTRAP_DIR)/scheme/cyclone
cp scheme/cyclone/util.c $(BOOTSTRAP_DIR)/scheme/cyclone
cp srfi/18.c $(BOOTSTRAP_DIR)/srfi
cp cyclone.c $(BOOTSTRAP_DIR)/cyclone.c
cp Makefile.config $(BOOTSTRAP_DIR)/Makefile.config
@ -95,7 +102,7 @@ tags:
.PHONY: clean
clean:
rm -rf a.out *.o *.so *.a *.out tags cyclone icyc scheme/*.o scheme/*.c scheme/*.meta scheme/cyclone/*.o scheme/cyclone/*.c scheme/cyclone/*.meta cyclone.c dispatch.c icyc.c generate-c.c generate-c
rm -rf a.out *.o *.so *.a *.out tags cyclone icyc scheme/*.o scheme/*.c scheme/*.meta srfi/*.o scheme/cyclone/*.o scheme/cyclone/*.c scheme/cyclone/*.meta cyclone.c dispatch.c icyc.c generate-c.c generate-c
$(foreach f,$(TESTSCM), rm -rf $(f) $(f).c tests/$(f).c;)
install-includes:
@ -119,12 +126,15 @@ install:
$(MKDIR) $(DESTDIR)$(INCDIR)
$(MKDIR) $(DESTDIR)$(DATADIR)
$(MKDIR) $(DESTDIR)$(DATADIR)/scheme/cyclone
$(MKDIR) $(DESTDIR)$(DATADIR)/srfi
$(INSTALL) -m0644 libcyclone.a $(DESTDIR)$(LIBDIR)/
$(INSTALL) -m0644 include/cyclone/*.h $(DESTDIR)$(INCDIR)/
$(INSTALL) -m0644 scheme/*.sld $(DESTDIR)$(DATADIR)/scheme
$(INSTALL) -m0644 scheme/*.o $(DESTDIR)$(DATADIR)/scheme
$(INSTALL) -m0644 scheme/cyclone/*.sld $(DESTDIR)$(DATADIR)/scheme/cyclone
$(INSTALL) -m0644 scheme/cyclone/*.o $(DESTDIR)$(DATADIR)/scheme/cyclone
$(INSTALL) -m0644 srfi/*.sld $(DESTDIR)$(DATADIR)/srfi
$(INSTALL) -m0644 srfi/*.o $(DESTDIR)$(DATADIR)/srfi
$(INSTALL) -m0755 cyclone $(DESTDIR)$(BINDIR)/
$(INSTALL) -m0755 icyc $(DESTDIR)$(BINDIR)/
@ -136,6 +146,8 @@ uninstall:
$(RMDIR) $(DESTDIR)$(INCDIR)
$(RM) $(DESTDIR)$(DATADIR)/scheme/cyclone/*.*
$(RMDIR) $(DESTDIR)$(DATADIR)/scheme/cyclone
$(RM) $(DESTDIR)$(DATADIR)/srfi/*.*
$(RMDIR) $(DESTDIR)$(DATADIR)/srfi
$(RM) $(DESTDIR)$(DATADIR)/scheme/*.*
$(RMDIR) $(DESTDIR)$(DATADIR)/scheme
$(RMDIR) $(DESTDIR)$(DATADIR)
@ -148,8 +160,9 @@ sld:
.PHONY: debug
debug:
cyclone scheme/cyclone/macros.sld && sudo cp scheme/cyclone/macros.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.o /usr/local/share/cyclone/scheme/cyclone/ && \
cyclone scheme/cyclone/util.sld && sudo cp scheme/cyclone/util.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.o /usr/local/share/cyclone/scheme/cyclone/ && \
cyclone scheme/cyclone/transforms.sld && sudo cp scheme/cyclone/transforms.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.o /usr/local/share/cyclone/scheme/cyclone/ && \
cyclone -t cyclone.scm && cyclone -t icyc.scm && sudo make install-bin
sudo ls; cyclone scheme/cyclone/cgen.sld && sudo cp scheme/cyclone/cgen.* /usr/local/share/cyclone/scheme/cyclone/ && cyclone cyclone.scm && sudo make install-includes && sudo make install-libs && ./cyclone generate-c.scm
### cyclone scheme/cyclone/macros.sld && sudo cp scheme/cyclone/macros.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/macros.o /usr/local/share/cyclone/scheme/cyclone/ && \
### cyclone scheme/cyclone/util.sld && sudo cp scheme/cyclone/util.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/util.o /usr/local/share/cyclone/scheme/cyclone/ && \
### cyclone scheme/cyclone/transforms.sld && sudo cp scheme/cyclone/transforms.c /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.sld /usr/local/share/cyclone/scheme/cyclone/ && sudo cp scheme/cyclone/transforms.o /usr/local/share/cyclone/scheme/cyclone/ && \
### cyclone -t cyclone.scm && cyclone -t icyc.scm && sudo make install-bin

1
Makefile.config
View file

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

22
Makefile.config.raspberry-pi-2 Normal file
View file

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

2
README.md
View file

@ -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

13
TODO
View file

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

2
cyclone.scm
View file

@ -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

22
docs/Developer-How-To.md
View file

@ -1,14 +1,16 @@
## Add a primitive
WIP set of instructions for doing this. working to refine this down:
- Add function/definitions to `runtime.h` and `runtime.c`
- Rebuild and install runtime library.
- Add to `prim?` section in `transforms.sld`. Some functions may need to added to the next section in the file, so they are not constant-folded (IE, evaluated at compile time).
- Add above the `c-compile-primitive` section in `cgen.sld`. Some functions may need to be added in multiple places to indicate they take additional arguments, call their continuation, etc.
- Add function/definitions to runtime.h and runtime.c
- Add to prim? section in transforms.scm. Some functions may need to added to the next section in the file, so they are not constant-folded (IE, evaluated at compile time).
- Add to the c-compile-primitive section in cgen.scm.
- install modified .scm files
- cyclone scheme/cyclone/cgen.sld
- copy modified files to cyclone-bootstrap, including cgen.c
- install cyclone-bootstrap
- run 'make clean ; make && make bootstrap' from cyclone repo
- run 'make clean ; ./install' from bootstrap repo
TODO: need to develop this section better to come up with a workable/optimal approach to building things:
- Compile:
cyclone scheme/cyclone/cgen.sld
cyclone scheme/cyclone/transforms.sld
- Copy modified files to cyclone-bootstrap, including runtime, `.sld`, and compiled `.c` files.
- Run `make clean ; ./install` from bootstrap repo
- Add primitives to the list in eval.sld. Rebuild one more time.

203
gc-notes.txt Normal file
View file

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

1321
gc.c Normal file
View file

File diff suppressed because it is too large Load diff

5
generate-c.scm
View file

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

269
include/cyclone/ck_ht_hash.h Normal file
View file

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

72
include/cyclone/runtime-main.h
View file

@ -14,75 +14,17 @@
long global_stack_size = 0;
long global_heap_size = 0;
static void c_entry_pt(int,closure,closure);
static void Cyc_main(long stack_size,long heap_size,char *stack_base);
static void Cyc_main (stack_size,heap_size,stack_base)
long stack_size,heap_size; char *stack_base;
{char in_my_frame;
mclosure0(clos_halt,&Cyc_halt); /* Halt program if final closure is reached */
gc_ans[0] = &clos_halt;
gc_num_ans = 1;
/* Allocate stack buffer. */
stack_begin = stack_base;
#if STACK_GROWS_DOWNWARD
stack_limit1 = stack_begin - stack_size;
stack_limit2 = stack_limit1 - 2000;
#else
stack_limit1 = stack_begin + stack_size;
stack_limit2 = stack_limit1 + 2000;
#endif
#if DEBUG_SHOW_DIAG
printf("main: sizeof(cons_type)=%ld\n",(long) sizeof(cons_type));
#endif
if (check_overflow(stack_base,&in_my_frame))
{printf("main: Recompile with STACK_GROWS_DOWNWARD set to %ld\n",
(long) (1-STACK_GROWS_DOWNWARD)); exit(0);}
#if DEBUG_SHOW_DIAG
printf("main: stack_size=%ld stack_base=%p stack_limit1=%p\n",
stack_size,(void *)stack_base,(void *)stack_limit1);
#endif
/* Initialize stack trace table */
Cyc_st_init();
{
/* Setup first function to execute */
mclosure0(entry_pt,&c_entry_pt);
gc_cont = &entry_pt;
static void c_entry_pt(void *,int,closure,closure);
static void Cyc_heap_init(long heap_size);
static void Cyc_heap_init(long heap_size)
{
/* Allocate heap area for second generation. */
/* Use calloc instead of malloc to assure pages are in main memory. */
#if DEBUG_SHOW_DIAG
printf("main: Allocating and initializing heap...\n");
#endif
bottom = calloc(1,heap_size);
allocp = (char *) ((((long) bottom)+7) & -8);
alloc_end = allocp + heap_size - 8;
dhallocp = dhbottom = calloc(1, heap_size);
dhalloc_limit = dhallocp + (long)((heap_size - 8) * 0.90);
dhalloc_end = dhallocp + heap_size - 8;
#if DEBUG_SHOW_DIAG
printf("main: heap_size=%ld allocp=%p alloc_end=%p\n",
(long) heap_size,(void *)allocp,(void *)alloc_end);
printf("main: Try a larger heap_size if program bombs.\n");
printf("Starting...\n");
#endif
start = clock(); /* Start the timing clock. */
/* Tank, load the jump program... */
setjmp(jmp_main);
#if DEBUG_GC
printf("Done with GC\n");
#endif
if (type_of(gc_cont) == cons_tag || prim(gc_cont)) {
Cyc_apply_from_buf(gc_num_ans, gc_cont, gc_ans);
} else {
do_dispatch(gc_num_ans, ((closure)gc_cont)->fn, gc_cont, gc_ans);
}
printf("Internal error: should never have reached this line\n"); exit(0);}}
gc_init_heap(heap_size);
gc_start_collector();
}
#endif /* CYCLONE_RUNTIME_MAIN_H */

226
include/cyclone/runtime.h
View file

@ -10,30 +10,30 @@
#define CYCLONE_RUNTIME_H
/* Error checking definitions */
#define Cyc_check_num_args(fnc_name, num_args, args) { \
integer_type l = Cyc_length(args); \
#define Cyc_check_num_args(data, fnc_name, num_args, args) { \
integer_type l = Cyc_length(data, args); \
if (num_args > l.value) { \
char buf[128]; \
snprintf(buf, 127, "Expected %d arguments but received %d.", num_args, l.value); \
Cyc_rt_raise_msg(buf); \
Cyc_rt_raise_msg(data, buf); \
} \
}
#define Cyc_check_type(fnc_test, tag, obj) { \
if (eq(boolean_f, fnc_test(obj))) Cyc_invalid_type_error(tag, obj); }
#define Cyc_check_type(data, fnc_test, tag, obj) { \
if (eq(boolean_f, fnc_test(obj))) Cyc_invalid_type_error(data, tag, obj); }
#define Cyc_check_cons_or_nil(obj) { if (!nullp(obj)) { Cyc_check_cons(obj); }}
#define Cyc_check_cons(obj) Cyc_check_type(Cyc_is_cons, cons_tag, obj);
#define Cyc_check_num(obj) Cyc_check_type(Cyc_is_number, integer_tag, obj);
#define Cyc_check_int(obj) Cyc_check_type(Cyc_is_integer, integer_tag, obj);
#define Cyc_check_str(obj) Cyc_check_type(Cyc_is_string, string_tag, obj);
#define Cyc_check_sym(obj) Cyc_check_type(Cyc_is_symbol, symbol_tag, obj);
#define Cyc_check_vec(obj) Cyc_check_type(Cyc_is_vector, vector_tag, obj);
#define Cyc_check_port(obj) Cyc_check_type(Cyc_is_port, port_tag, obj);
#define Cyc_check_fnc(obj) Cyc_check_type(Cyc_is_procedure, closure2_tag, obj);
void Cyc_invalid_type_error(int tag, object found);
void Cyc_check_obj(int tag, object obj);
void Cyc_check_bounds(const char *label, int len, int index);
#define Cyc_check_cons_or_nil(d,obj) { if (!nullp(obj)) { Cyc_check_cons(d,obj); }}
#define Cyc_check_cons(d,obj) Cyc_check_type(d,Cyc_is_cons, cons_tag, obj);
#define Cyc_check_num(d,obj) Cyc_check_type(d,Cyc_is_number, integer_tag, obj);
#define Cyc_check_int(d,obj) Cyc_check_type(d,Cyc_is_integer, integer_tag, obj);
#define Cyc_check_str(d,obj) Cyc_check_type(d,Cyc_is_string, string_tag, obj);
#define Cyc_check_sym(d,obj) Cyc_check_type(d,Cyc_is_symbol, symbol_tag, obj);
#define Cyc_check_vec(d,obj) Cyc_check_type(d,Cyc_is_vector, vector_tag, obj);
#define Cyc_check_port(d,obj) Cyc_check_type(d,Cyc_is_port, port_tag, obj);
#define Cyc_check_mutex(d,obj) Cyc_check_type(d,Cyc_is_mutex, mutex_tag, obj);
void Cyc_invalid_type_error(void *data, int tag, object found);
void Cyc_check_obj(void *data, int tag, object obj);
void Cyc_check_bounds(void *data, const char *label, int len, int index);
/* END error checking */
extern long global_stack_size;
@ -42,7 +42,8 @@ extern const object Cyc_EOF;
object cell_get(object cell);
#define global_set(glo,value) (glo=value)
#define global_set(glo,value) Cyc_global_set(data, (object *)&glo, value)
object Cyc_global_set(void *thd, object *glo, object value);
/* Variable argument count support
@ -72,6 +73,8 @@ object cell_get(object cell);
} else { \
tmp = arg_var; \
} \
var[i].hdr.mark = gc_color_red; \
var[i].hdr.grayed = 0; \
var[i].tag = cons_tag; \
var[i].cons_car = tmp; \
var[i].cons_cdr = (i == (count-1)) ? nil : &var[i + 1]; \
@ -80,81 +83,80 @@ object cell_get(object cell);
} \
}
/* Prototypes for Lisp built-in functions. */
/* Prototypes for primitive functions. */
extern object Cyc_global_variables;
int _cyc_argc;
char **_cyc_argv;
void gc_init_heap(long heap_size);
object Cyc_get_global_variables();
object Cyc_get_cvar(object var);
object Cyc_set_cvar(object var, object value);
object apply(object cont, object func, object args);
void Cyc_apply(int argc, closure cont, object prim, ...);
integer_type Cyc_string_cmp(object str1, object str2);
void dispatch_string_91append(int argc, object clo, object cont, object str1, ...);
string_type Cyc_string_append(int argc, object str1, ...);
string_type Cyc_string_append_va_list(int, object, va_list);
object apply(void *data, object cont, object func, object args);
void Cyc_apply(void *data, int argc, closure cont, object prim, ...);
integer_type Cyc_string_cmp(void *data, object str1, object str2);
void dispatch_string_91append(void *data, int argc, object clo, object cont, object str1, ...);
list mcons(object,object);
cvar_type *mcvar(object *var);
object Cyc_display(object, FILE *port);
object dispatch_display_va(int argc, object clo, object cont, object x, ...);
object dispatch_display_va(void *data, int argc, object clo, object cont, object x, ...);
object Cyc_display_va(int argc, object x, ...);
object Cyc_display_va_list(int argc, object x, va_list ap);
object Cyc_write_char(object c, object port);
object Cyc_write_char(void *data, object c, object port);
object Cyc_write(object, FILE *port);
object dispatch_write_va(int argc, object clo, object cont, object x, ...);
object dispatch_write_va(void *data, int argc, object clo, object cont, object x, ...);
object Cyc_write_va(int argc, object x, ...);
object Cyc_write_va_list(int argc, object x, va_list ap);
object Cyc_has_cycle(object lst);
list assoc(object x, list l);
object __num_eq(object x, object y);
object __num_gt(object x, object y);
object __num_lt(object x, object y);
object __num_gte(object x, object y);
object __num_lte(object x, object y);
object __num_eq(void *, object x, object y);
object __num_gt(void *, object x, object y);
object __num_lt(void *, object x, object y);
object __num_gte(void *, object x, object y);
object __num_lte(void *, object x, object y);
object Cyc_eq(object x, object y);
object Cyc_set_car(object l, object val) ;
object Cyc_set_cdr(object l, object val) ;
integer_type Cyc_length(object l);
integer_type Cyc_vector_length(object v);
object Cyc_vector_ref(object v, object k);
object Cyc_vector_set(object v, object k, object obj);
object Cyc_make_vector(object cont, object len, object fill);
object Cyc_list2vector(object cont, object l);
string_type Cyc_number2string(object n) ;
string_type Cyc_symbol2string(object sym) ;
object Cyc_string2symbol(object str);
string_type Cyc_list2string(object lst);
common_type Cyc_string2number(object str);
void dispatch_string_91append(int argc, object clo, object cont, object str1, ...);
string_type Cyc_string_append(int argc, object str1, ...);
string_type Cyc_string_append_va_list(int argc, object str1, va_list ap);
integer_type Cyc_string_length(object str);
string_type Cyc_substring(object str, object start, object end);
object Cyc_string_ref(object str, object k);
object Cyc_string_set(object str, object k, object chr);
string_type Cyc_installation_dir();
object Cyc_command_line_arguments(object cont);
object Cyc_set_car(void *, object l, object val) ;
object Cyc_set_cdr(void *, object l, object val) ;
integer_type Cyc_length(void *d, object l);
integer_type Cyc_vector_length(void *data, object v);
object Cyc_vector_ref(void *d, object v, object k);
object Cyc_vector_set(void *d, object v, object k, object obj);
object Cyc_make_vector(void *data, object cont, object len, object fill);
object Cyc_list2vector(void *data, object cont, object l);
object Cyc_make_mutex(void *data);
object Cyc_mutex_lock(void *data, object cont, object obj);
object Cyc_mutex_unlock(void *data, object obj);
object Cyc_number2string(void *d, object cont, object n);
object Cyc_symbol2string(void *d, object cont, object sym) ;
object Cyc_string2symbol(void *d, object str);
object Cyc_list2string(void *d, object cont, object lst);
common_type Cyc_string2number(void *d, object str);
object Cyc_string_append(void *data, object cont, int argc, object str1, ...);
integer_type Cyc_string_length(void *data, object str);
object Cyc_substring(void *data, object cont, object str, object start, object end);
object Cyc_string_ref(void *data, object str, object k);
object Cyc_string_set(void *data, object str, object k, object chr);
object Cyc_installation_dir(void *data, object cont, object type);
object Cyc_command_line_arguments(void *data, object cont);
integer_type Cyc_system(object cmd);
integer_type Cyc_char2integer(object chr);
object Cyc_integer2char(object n);
object Cyc_integer2char(void *data, object n);
void Cyc_halt(closure);
object __halt(object obj);
port_type Cyc_stdout(void);
port_type Cyc_stdin(void);
port_type Cyc_stderr(void);
port_type Cyc_io_open_input_file(object str);
port_type Cyc_io_open_output_file(object str);
object Cyc_io_close_port(object port);
object Cyc_io_close_input_port(object port);
object Cyc_io_close_output_port(object port);
object Cyc_io_flush_output_port(object port);
object Cyc_io_delete_file(object filename);
object Cyc_io_file_exists(object filename);
object Cyc_io_read_char(object port);
object Cyc_io_peek_char(object port);
object Cyc_io_read_line(object cont, object port);
port_type Cyc_io_open_input_file(void *data, object str);
port_type Cyc_io_open_output_file(void *data, object str);
object Cyc_io_close_port(void *data, object port);
object Cyc_io_close_input_port(void *data, object port);
object Cyc_io_close_output_port(void *data, object port);
object Cyc_io_flush_output_port(void *data, object port);
object Cyc_io_delete_file(void *data, object filename);
object Cyc_io_file_exists(void *data, object filename);
object Cyc_io_read_char(void *data, object cont, object port);
object Cyc_io_peek_char(void *data, object cont, object port);
object Cyc_io_read_line(void *data, object cont, object port);
object Cyc_is_boolean(object o);
object Cyc_is_cons(object o);
@ -164,74 +166,58 @@ object Cyc_is_real(object o);
object Cyc_is_integer(object o);
object Cyc_is_vector(object o);
object Cyc_is_port(object o);
object Cyc_is_mutex(object o);
object Cyc_is_symbol(object o);
object Cyc_is_string(object o);
object Cyc_is_char(object o);
object Cyc_is_procedure(object o);
object Cyc_is_procedure(void *data, object o);
object Cyc_is_macro(object o);
object Cyc_is_eof_object(object o);
object Cyc_is_cvar(object o);
common_type Cyc_sum_op(object x, object y);
common_type Cyc_sub_op(object x, object y);
common_type Cyc_mul_op(object x, object y);
common_type Cyc_div_op(object x, object y);
common_type Cyc_sum(int argc, object n, ...);
common_type Cyc_sub(int argc, object n, ...);
common_type Cyc_mul(int argc, object n, ...);
common_type Cyc_div(int argc, object n, ...);
common_type Cyc_num_op_va_list(int argc, common_type (fn_op(object, object)), object n, va_list ns);
common_type Cyc_sum_op(void *data, object x, object y);
common_type Cyc_sub_op(void *data, object x, object y);
common_type Cyc_mul_op(void *data, object x, object y);
common_type Cyc_div_op(void *data, object x, object y);
common_type Cyc_sum(void *data, int argc, object n, ...);
common_type Cyc_sub(void *data, int argc, object n, ...);
common_type Cyc_mul(void *data, int argc, object n, ...);
common_type Cyc_div(void *data, int argc, object n, ...);
common_type Cyc_num_op_va_list(void *data, int argc, common_type (fn_op(void *, object, object)), object n, va_list ns);
int equal(object,object);
list assq(object,list);
list assq(void *,object,list);
list assoc(void *,object x, list l);
object get(object,object);
object equalp(object,object);
object memberp(object,list);
object memqp(object,list);
char *transport(char *,int);
void GC(closure,object*,int);
object memberp(void *,object,list);
object memqp(void *,object,list);
void Cyc_st_init();
void Cyc_st_add(char *frame);
void Cyc_st_print(FILE *out);
object Cyc_spawn_thread(object thunk);
void Cyc_start_trampoline(gc_thread_data *thd);
void Cyc_end_thread(gc_thread_data *thd);
void Cyc_exit_thread(gc_thread_data *thd);
object Cyc_thread_sleep(void *data, object timeout);
void GC(void *,closure,object*,int);
object Cyc_trigger_minor_gc(void *data, object cont);
void Cyc_st_add(void *data, char *frame);
void Cyc_st_print(void *data, FILE *out);
char *_strdup (const char *s);
object add_symbol(symbol_type *psym);
object add_symbol_by_name(const char *name);
object find_symbol_by_name(const char *name);
object find_or_add_symbol(const char *name);
extern list symbol_table;
extern list global_table;
void add_global(object *glo);
void add_mutation(object var, object value);
void clear_mutations();
extern list mutation_table;
void dispatch(int argc, function_type func, object clo, object cont, object args);
void dispatch_va(int argc, function_type_va func, object clo, object cont, object args);
void do_dispatch(int argc, function_type func, object clo, object *buffer);
void dispatch(void *data, int argc, function_type func, object clo, object cont, object args);
void dispatch_va(void *data, int argc, function_type_va func, object clo, object cont, object args);
void do_dispatch(void *data, int argc, function_type func, object clo, object *buffer);
/* Global variables. */
extern clock_t start; /* Starting time. */
extern char *stack_begin; /* Initialized by main. */
extern char *stack_limit1; /* Initialized by main. */
extern char *stack_limit2;
extern char *bottom; /* Bottom of tospace. */
extern char *allocp; /* Cheney allocate pointer. */
extern char *alloc_end;
/* TODO: not sure this is the best strategy for strings, especially if there
are a lot of long, later gen strings because that will cause a lot of
copying to occur during GC */
extern char *dhbottom; /* Bottom of data heap */
extern char *dhallocp; /* Current place in data heap */
extern char *dhalloc_limit; /* GC beyond this limit */
extern char *dhalloc_end;
extern long no_gcs; /* Count the number of GC's. */
extern long no_major_gcs; /* Count the number of GC's. */
extern object gc_cont; /* GC continuation closure. */
extern object gc_ans[NUM_GC_ANS]; /* argument for GC continuation closure. */
extern int gc_num_ans;
extern jmp_buf jmp_main; /* Where to jump to. */
/* Define Lisp constants we need. */
extern const object boolean_t;
@ -244,6 +230,10 @@ extern const object primitive_Cyc_91get_91cvar;
extern const object primitive_Cyc_91set_91cvar_67;
extern const object primitive_Cyc_91cvar_127;
extern const object primitive_Cyc_91has_91cycle_127;
extern const object primitive_Cyc_91spawn_91thread_67;
extern const object primitive_Cyc_91end_91thread_67;
extern const object primitive_thread_91sleep_67;
extern const object primitive_Cyc_91minor_91gc;
extern const object primitive__87;
extern const object primitive__91;
extern const object primitive__85;
@ -323,6 +313,10 @@ extern const object primitive_vector_91ref;
extern const object primitive_vector_91set_67;
extern const object primitive_string_91ref;
extern const object primitive_string_91set_67;
extern const object primitive_make_91mutex;
extern const object primitive_mutex_91lock_67;
extern const object primitive_mutex_91unlock_67;
extern const object primitive_mutex_127;
extern const object primitive_Cyc_91installation_91dir;
extern const object primitive_command_91line_91arguments;
extern const object primitive_system;
@ -373,11 +367,11 @@ extern object Cyc_exception_handler_stack;
// behavior portable? If not, will have to modify cgen to not emit the var.
#define __glo__85exception_91handler_91stack_85 Cyc_exception_handler_stack
object Cyc_default_exception_handler(int argc, closure _, object err);
object Cyc_default_exception_handler(void *data, int argc, closure _, object err);
object Cyc_current_exception_handler();
void Cyc_rt_raise(object err);
void Cyc_rt_raise2(const char *msg, object err);
void Cyc_rt_raise_msg(const char *err);
void Cyc_rt_raise(void *data, object err);
void Cyc_rt_raise2(void *data, const char *msg, object err);
void Cyc_rt_raise_msg(void *data, const char *err);
/* END exception handler */
#endif /* CYCLONE_RUNTIME_H */

309
include/cyclone/types.h
View file

@ -16,26 +16,160 @@
#include <stdarg.h>
#include <string.h>
#include <math.h>
#include <pthread.h>
/* Debug GC flag */
#define DEBUG_GC 0
// Maximum number of args that GC will accept
#define NUM_GC_ANS 128
// Which way does the CPU grow its stack?
#define STACK_GROWS_DOWNWARD 1
// Size of the stack buffer, in bytes.
// This is used as the first generation of the GC.
#define STACK_SIZE 250000
// Size of a "page" on the heap (the second generation), in bytes.
#define HEAP_SIZE 6000000
// Number of functions to save for printing call history
#define MAX_STACK_TRACES 10
// GC debugging flags
#define GC_DEBUG_TRACE 0
#define GC_DEBUG_VERBOSE 0
/* Additional runtime checking of the GC system.
This is here because these checks should not be
necessary if GC is working correctly. */
#define GC_SAFETY_CHECKS 1
// General constants
#define NANOSECONDS_PER_MILLISECOND 1000000
/* Define general object type. */
typedef void *object;
/* Threading */
typedef enum { CYC_THREAD_STATE_NEW
, CYC_THREAD_STATE_RUNNABLE
, CYC_THREAD_STATE_BLOCKED
, CYC_THREAD_STATE_BLOCKED_COOPERATING
, CYC_THREAD_STATE_TERMINATED
} cyc_thread_state_type;
/* Thread data structures */
typedef struct gc_thread_data_t gc_thread_data;
struct gc_thread_data_t {
// TODO:
// pthread_t *thread;
cyc_thread_state_type thread_state;
// Data needed to initiate stack-based minor GC
char *stack_start;
char *stack_limit;
// Minor GC write barrier
void *mutations;
// List of objects moved to heap during minor GC
void **moveBuf;
int moveBufLen;
// Need the following to perform longjmp's
//int mutator_num;
jmp_buf *jmp_start;
// After longjmp, pick up execution using continuation/arguments
object gc_cont;
object *gc_args;
short gc_num_args;
// Data needed for heap GC
int gc_alloc_color;
int gc_status;
int last_write;
int last_read;
int pending_writes;
void **mark_buffer;
int mark_buffer_len;
pthread_mutex_t lock;
// Data needed for call history
char **stack_traces;
int stack_trace_idx;
char *stack_prev_frame;
};
/* GC data structures */
typedef struct gc_free_list_t gc_free_list;
struct gc_free_list_t {
// somehow this size param is being overwritten by a "mark() =".
// how could that happen?
//somehow it appears free list pointers are being used where heap objects are
//expected. could this be as simple as objects being sweeped that should not
//have been? unfortunately it is harder to figure how why the objects were
//sweeped. were they not marked properly? is there a race condition? maybe
//more than one issue? what is going on?
//
// the following line does not solve the problem. in fact, with this in
// place there are still cases where the tag is a multiple of 32, implying
// again that a free list node is being used as a heap object. IE, the
// size value is being read into the tag field by code expecting a heap obj.
//
//unsigned int dummy; // just for testing/evaluation, this line is NOT a fix!!
unsigned int size;
gc_free_list *next;
};
typedef struct gc_heap_t gc_heap;
struct gc_heap_t {
unsigned int size;
unsigned int chunk_size; // 0 for any size, other and heap will only alloc chunks of that size
unsigned int max_size;
//unsigned int free_size;
gc_free_list *free_list; // TBD
gc_heap *next; // TBD, linked list is not very efficient, but easy to work with as a start
char *data;
};
typedef struct gc_header_type_t gc_header_type;
struct gc_header_type_t {
unsigned int mark; // mark bits (only need 2)
unsigned char grayed; // stack object to be grayed when moved to heap
};
#define mark(x) (((list) x)->hdr.mark)
#define grayed(x) (((list) x)->hdr.grayed)
/* HEAP definitions */
// experimenting with a heap based off of the one in Chibi scheme
#define gc_heap_first_block(h) ((object)(h->data + gc_heap_align(gc_free_chunk_size)))
#define gc_heap_last_block(h) ((object)((char*)h->data + h->size - gc_heap_align(gc_free_chunk_size)))
#define gc_heap_end(h) ((object)((char*)h->data + h->size))
#define gc_heap_pad_size(s) (sizeof(struct gc_heap_t) + (s) + gc_heap_align(1))
#define gc_free_chunk_size (sizeof(gc_free_list))
#define gc_align(n, bits) (((n)+(1<<(bits))-1)&(((unsigned int)-1)-((1<<(bits))-1)))
// 64-bit is 3, 32-bit is 2
#define gc_word_align(n) gc_align((n), 2)
#define gc_heap_align(n) gc_align(n, 5)
/* Enums for tri-color marking */
typedef enum { STATUS_ASYNC
, STATUS_SYNC1
, STATUS_SYNC2
} gc_status_type;
typedef enum { STAGE_CLEAR_OR_MARKING
, STAGE_TRACING
//, STAGE_REF_PROCESSING
, STAGE_SWEEPING
, STAGE_RESTING
} gc_stage_type;
// Constant colors are defined here.
// The mark/clear colors are defined in the gc module because
// the collector swaps their values as an optimization.
#define gc_color_red 0 // Memory not to be GC'd, such as on the stack
#define gc_color_blue 2 // Unallocated memory
/* Show diagnostic information for the GC when program terminates */
#define DEBUG_SHOW_DIAG 0
/* Maximum number of args that GC will accept */
#define NUM_GC_ANS 128
/* Which way does the CPU grow its stack? */
#define STACK_GROWS_DOWNWARD 1
/* Size of the stack buffer, in bytes. */
#define STACK_SIZE 100000
/* Size of the 2nd generation, in bytes. */
#define HEAP_SIZE 6000000
/* Define size of object tags. Options are "short" or "long". */
/* Define size of object tags */
typedef long tag_type;
#ifndef CLOCKS_PER_SEC
@ -73,15 +207,12 @@ typedef long tag_type;
#define cvar_tag 16
#define vector_tag 17
#define macro_tag 18
#define mutex_tag 19
#define nil NULL
#define eq(x,y) (x == y)
#define nullp(x) (x == NULL)
/* Define general object type. */
typedef void *object;
#define type_of(x) (((list) x)->tag)
#define forward(x) (((list) x)->cons_car)
@ -90,7 +221,7 @@ typedef void *object;
have extra least significant bits that can be used to mark them as
values instead of objects (IE, pointer to a tagged object).
On many machines, addresses are multiples of four, leaving the two
least significant bits free - according to lisp in small pieces.
least significant bits free - from lisp in small pieces.
*/
#define obj_is_char(x) ((unsigned long)(x) & (unsigned long)1)
#define obj_obj2char(x) (char)((long)(x)>>1)
@ -105,19 +236,23 @@ typedef void (*function_type)();
typedef void (*function_type_va)(int, object, object, object, ...);
/* Define C-variable integration type */
typedef struct {tag_type tag; object *pvar;} cvar_type;
typedef struct {gc_header_type hdr; tag_type tag; object *pvar;} cvar_type;
typedef cvar_type *cvar;
#define make_cvar(n,v) cvar_type n; n.tag = cvar_tag; n.pvar = v;
#define make_cvar(n,v) cvar_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = cvar_tag; n.pvar = v;
/* Define mutex type */
typedef struct {gc_header_type hdr; tag_type tag; pthread_mutex_t lock;} mutex_type;
typedef mutex_type *mutex;
/* Define boolean type. */
typedef struct {const tag_type tag; const char *pname;} boolean_type;
typedef struct {gc_header_type hdr; const tag_type tag; const char *pname;} boolean_type;
typedef boolean_type *boolean;
#define boolean_pname(x) (((boolean_type *) x)->pname)
/* Define symbol type. */
typedef struct {const tag_type tag; const char *pname; object plist;} symbol_type;
typedef struct {gc_header_type hdr; const tag_type tag; const char *pname; object plist;} symbol_type;
typedef symbol_type *symbol;
#define symbol_pname(x) (((symbol_type *) x)->pname)
@ -127,28 +262,34 @@ typedef symbol_type *symbol;
static object quote_##name = nil;
/* Define numeric types */
typedef struct {tag_type tag; int value;} integer_type;
#define make_int(n,v) integer_type n; n.tag = integer_tag; n.value = v;
typedef struct {tag_type tag; double value;} double_type;
#define make_double(n,v) double_type n; n.tag = double_tag; n.value = v;
typedef struct {gc_header_type hdr; tag_type tag; int value;} integer_type;
#define make_int(n,v) integer_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = integer_tag; n.value = v;
typedef struct {gc_header_type hdr; tag_type tag; double value;} double_type;
#define make_double(n,v) double_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = double_tag; n.value = v;
#define integer_value(x) (((integer_type *) x)->value)
#define double_value(x) (((double_type *) x)->value)
/* Define string type */
typedef struct {tag_type tag; char *str;} string_type;
#define make_string(cv,s) string_type cv; cv.tag = string_tag; \
{ int len = strlen(s); cv.str = dhallocp; \
if ((dhallocp + len + 1) >= dhbottom + global_heap_size) { \
printf("Fatal error: data heap overflow\n"); exit(1); } \
memcpy(dhallocp, s, len + 1); dhallocp += len + 1; }
#define make_stringn(cv,s,len) string_type cv; cv.tag = string_tag; \
{ cv.str = dhallocp; \
if ((dhallocp + len + 1) >= dhbottom + global_heap_size) { \
printf("Fatal error: data heap overflow\n"); exit(1); } \
memcpy(dhallocp, s, len); dhallocp += len; \
*dhallocp = '\0'; dhallocp += 1;}
typedef struct {gc_header_type hdr; tag_type tag; int len; char *str;} string_type;
//// TODO: new way to allocate strings, but this requires changes to
//// all functions that allocate strings, the GC, cgen, and maybe more.
//// Because these strings are (at least for now) allocaed on the stack.
#define make_string(cs, s) string_type cs; \
{ int len = strlen(s); cs.tag = string_tag; cs.len = len; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
cs.str = alloca(sizeof(char) * (len + 1)); \
memcpy(cs.str, s, len + 1);}
#define make_string_with_len(cs, s, length) string_type cs; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
{ int len = length; \
cs.tag = string_tag; cs.len = len; \
cs.str = alloca(sizeof(char) * (len + 1)); \
memcpy(cs.str, s, len); \
cs.str[len] = '\0';}
#define make_string_noalloc(cs, s, length) string_type cs; cs.hdr.mark = gc_color_red; cs.hdr.grayed = 0; \
{ cs.tag = string_tag; cs.len = length; \
cs.str = s; }
#define string_len(x) (((string_type *) x)->len)
#define string_str(x) (((string_type *) x)->str)
/* I/O types */
@ -157,19 +298,19 @@ typedef struct {tag_type tag; char *str;} string_type;
// consider http://stackoverflow.com/questions/6206893/how-to-implement-char-ready-in-c
// TODO: a simple wrapper around FILE may not be good enough long-term
// TODO: how exactly mode will be used. need to know r/w, bin/txt
typedef struct {tag_type tag; FILE *fp; int mode;} port_type;
#define make_port(p,f,m) port_type p; p.tag = port_tag; p.fp = f; p.mode = m;
typedef struct {gc_header_type hdr; tag_type tag; FILE *fp; int mode;} port_type;
#define make_port(p,f,m) port_type p; p.hdr.mark = gc_color_red; p.hdr.grayed = 0; p.tag = port_tag; p.fp = f; p.mode = m;
/* Vector type */
typedef struct {tag_type tag; int num_elt; object *elts;} vector_type;
typedef struct {gc_header_type hdr; tag_type tag; int num_elt; object *elts;} vector_type;
typedef vector_type *vector;
#define make_empty_vector(v) vector_type v; v.tag = vector_tag; v.num_elt = 0; v.elts = NULL;
#define make_empty_vector(v) vector_type v; v.hdr.mark = gc_color_red; v.hdr.grayed = 0; v.tag = vector_tag; v.num_elt = 0; v.elts = NULL;
/* Define cons type. */
typedef struct {tag_type tag; object cons_car,cons_cdr;} cons_type;
typedef struct {gc_header_type hdr; tag_type tag; object cons_car,cons_cdr;} cons_type;
typedef cons_type *list;
#define car(x) (((list) x)->cons_car)
@ -204,17 +345,17 @@ typedef cons_type *list;
#define cddddr(x) (cdr(cdr(cdr(cdr(x)))))
#define make_cons(n,a,d) \
cons_type n; n.tag = cons_tag; n.cons_car = a; n.cons_cdr = d;
cons_type n; n.hdr.mark = gc_color_red; n.hdr.grayed = 0; n.tag = cons_tag; n.cons_car = a; n.cons_cdr = d;
/* Closure types */
typedef struct {tag_type tag; function_type fn; int num_args; } macro_type;
typedef struct {tag_type tag; function_type fn; int num_args; } closure0_type;
typedef struct {tag_type tag; function_type fn; int num_args; object elt1;} closure1_type;
typedef struct {tag_type tag; function_type fn; int num_args; object elt1,elt2;} closure2_type;
typedef struct {tag_type tag; function_type fn; int num_args; object elt1,elt2,elt3;} closure3_type;
typedef struct {tag_type tag; function_type fn; int num_args; object elt1,elt2,elt3,elt4;} closure4_type;
typedef struct {tag_type tag; function_type fn; int num_args; int num_elt; object *elts;} closureN_type;
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; } macro_type;
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; } closure0_type;
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1;} closure1_type;
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1,elt2;} closure2_type;
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1,elt2,elt3;} closure3_type;
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; object elt1,elt2,elt3,elt4;} closure4_type;
typedef struct {gc_header_type hdr; tag_type tag; function_type fn; int num_args; int num_elt; object *elts;} closureN_type;
typedef closure0_type *closure0;
typedef closure1_type *closure1;
@ -225,15 +366,15 @@ typedef closureN_type *closureN;
typedef closure0_type *closure;
typedef closure0_type *macro;
#define mmacro(c,f) macro_type c; c.tag = macro_tag; c.fn = f; c.num_args = -1;
#define mclosure0(c,f) closure0_type c; c.tag = closure0_tag; c.fn = f; c.num_args = -1;
#define mclosure1(c,f,a) closure1_type c; c.tag = closure1_tag; \
#define mmacro(c,f) macro_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = macro_tag; c.fn = f; c.num_args = -1;
#define mclosure0(c,f) closure0_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure0_tag; c.fn = f; c.num_args = -1;
#define mclosure1(c,f,a) closure1_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure1_tag; \
c.fn = f; c.num_args = -1; c.elt1 = a;
#define mclosure2(c,f,a1,a2) closure2_type c; c.tag = closure2_tag; \
#define mclosure2(c,f,a1,a2) closure2_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure2_tag; \
c.fn = f; c.num_args = -1; c.elt1 = a1; c.elt2 = a2;
#define mclosure3(c,f,a1,a2,a3) closure3_type c; c.tag = closure3_tag; \
#define mclosure3(c,f,a1,a2,a3) closure3_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure3_tag; \
c.fn = f; c.num_args = -1; c.elt1 = a1; c.elt2 = a2; c.elt3 = a3;
#define mclosure4(c,f,a1,a2,a3,a4) closure4_type c; c.tag = closure4_tag; \
#define mclosure4(c,f,a1,a2,a3,a4) closure4_type c; c.hdr.mark = gc_color_red; c.hdr.grayed = 0; c.tag = closure4_tag; \
c.fn = f; c.num_args = -1; c.elt1 = a1; c.elt2 = a2; c.elt3 = a3; c.elt4 = a4;
#define mlist1(e1) (mcons(e1,nil))
@ -247,7 +388,7 @@ typedef closure0_type *macro;
#define make_cell(n,a) make_cons(n,a,nil);
/* Primitive types */
typedef struct {tag_type tag; const char *pname; function_type fn;} primitive_type;
typedef struct {gc_header_type hdr; tag_type tag; const char *pname; function_type fn;} primitive_type;
typedef primitive_type *primitive;
#define defprimitive(name, pname, fnc) \
@ -265,8 +406,54 @@ typedef union {
primitive_type primitive_t;
integer_type integer_t;
double_type double_t;
string_type string_t;
} common_type;
/* Utility functions */
void **vpbuffer_realloc(void **buf, int *len);
void **vpbuffer_add(void **buf, int *len, int i, void *obj);
void vpbuffer_free(void **buf);
/* GC prototypes */
void gc_initialize();
void gc_add_mutator(gc_thread_data *thd);
void gc_remove_mutator(gc_thread_data *thd);
gc_heap *gc_heap_create(size_t size, size_t max_size, size_t chunk_size);
int gc_grow_heap(gc_heap *h, size_t size, size_t chunk_size);
char *gc_copy_obj(object hp, char *obj, gc_thread_data *thd);
void *gc_try_alloc(gc_heap *h, size_t size, char *obj, gc_thread_data *thd);
void *gc_alloc(gc_heap *h, size_t size, char *obj, gc_thread_data *thd, int *heap_grown);
size_t gc_allocated_bytes(object obj, gc_free_list *q, gc_free_list *r);
gc_heap *gc_heap_last(gc_heap *h);
size_t gc_heap_total_size(gc_heap *h);
//size_t gc_heap_total_free_size(gc_heap *h);
//size_t gc_collect(gc_heap *h, size_t *sum_freed);
//void gc_mark(gc_heap *h, object obj);
void gc_mark_globals(void);
size_t gc_sweep(gc_heap *h, size_t *sum_freed_ptr);
void gc_thr_grow_move_buffer(gc_thread_data *d);
void gc_thr_add_to_move_buffer(gc_thread_data *d, int *alloci, object obj);
void gc_thread_data_init(gc_thread_data *thd, int mut_num, char *stack_base, long stack_size);
void gc_thread_data_free(gc_thread_data *thd);
// Prototypes for mutator/collector:
int gc_is_stack_obj(gc_thread_data *thd, object obj);
void gc_mut_update(gc_thread_data *thd, object old_obj, object value);
void gc_mut_cooperate(gc_thread_data *thd, int buf_len);
void gc_mark_gray(gc_thread_data *thd, object obj);
void gc_mark_gray2(gc_thread_data *thd, object obj);
void gc_collector_trace();
void gc_mark_black(object obj);
void gc_collector_mark_gray(object parent, object obj);
void gc_empty_collector_stack();
void gc_handshake(gc_status_type s);
void gc_post_handshake(gc_status_type s);
void gc_wait_handshake();
void gc_start_collector();
void gc_mutator_thread_blocked(gc_thread_data *thd, object cont);
void gc_mutator_thread_runnable(gc_thread_data *thd, object result);
gc_heap *gc_get_heap();
int gc_minor(void *data, object low_limit, object high_limit, closure cont, object *args, int num_args);
void add_mutation(void *data, object var, object value);
void clear_mutations(void *data);
#endif /* CYCLONE_TYPES_H */

2618
runtime.c
View file

File diff suppressed because it is too large Load diff

218
scheme/cyclone/cgen.sld
View file

@ -74,11 +74,23 @@
(define *c-main-function*
"main(int argc,char **argv)
{long stack_size = global_stack_size = STACK_SIZE;
{gc_thread_data *thd;
long stack_size = global_stack_size = STACK_SIZE;
long heap_size = global_heap_size = HEAP_SIZE;
mclosure0(clos_halt,&Cyc_halt); // Halt if final closure is reached
mclosure0(entry_pt,&c_entry_pt); // First function to execute
_cyc_argc = argc;
_cyc_argv = argv;
Cyc_main(stack_size,heap_size,(char *) &stack_size);
gc_initialize();
thd = malloc(sizeof(gc_thread_data));
gc_thread_data_init(thd, 0, (char *) &stack_size, stack_size);
thd->gc_cont = &entry_pt;
thd->gc_args[0] = &clos_halt;
thd->gc_num_args = 1;
gc_add_mutator(thd);
Cyc_heap_init(heap_size);
thd->thread_state = CYC_THREAD_STATE_RUNNABLE;
Cyc_start_trampoline(thd);
return 0;}")
;;; Auto-generation of C macros
@ -110,12 +122,12 @@
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
"/* Check for GC, then call given continuation closure */\n"
"#define return_closcall" n "(cfn" args ") \\\n"
"#define return_closcall" n "(td,cfn" args ") \\\n"
"{char stack; \\\n"
" if (check_overflow(&stack,stack_limit1)) { \\\n"
" if (check_overflow(&stack,(((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign "\\\n"
" GC(cfn,buf," n "); return; \\\n"
" } else {closcall" n "((closure) (cfn)" args "); return;}}\n")))
" GC(td,cfn,buf," n "); return; \\\n"
" } else {closcall" n "(td,(closure) (cfn)" args "); return;}}\n")))
(define (c-macro-return-direct num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
@ -123,13 +135,13 @@
(arry-assign (c-macro-array-assign num-args "buf" "a")))
(string-append
"/* Check for GC, then call C function directly */\n"
"#define return_direct" n "(_fn" args ") { \\\n"
"#define return_direct" n "(td,_fn" args ") { \\\n"
" char stack; \\\n"
" if (check_overflow(&stack,stack_limit1)) { \\\n"
" if (check_overflow(&stack,(((gc_thread_data *)data)->stack_limit))) { \\\n"
" object buf[" n "]; " arry-assign " \\\n"
" mclosure0(c1, _fn); \\\n"
" GC(&c1, buf, " n "); return; \\\n"
" } else { (_fn)(" n ",(closure)_fn" args "); }}\n")))
" GC(td,&c1, buf, " n "); return; \\\n"
" } else { (_fn)(td," n ",(closure)_fn" args "); }}\n")))
(define (c-macro-closcall num-args)
(let ((args (c-macro-n-prefix num-args ",a"))
@ -137,10 +149,10 @@
(n-1 (number->string (if (> num-args 0) (- num-args 1) 0)))
(wrap (lambda (s) (if (> num-args 0) s ""))))
(string-append
"#define closcall" n "(cfn" args ") "
(wrap (string-append "if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(" n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }"))
"#define closcall" n "(td,cfn" args ") "
(wrap (string-append "if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(td," n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }"))
(wrap " else { ")
"((cfn)->fn)(" n ",cfn" args ")"
"((cfn)->fn)(td," n ",cfn" args ")"
(wrap ";}")
)))
@ -172,7 +184,7 @@
(null? (cdr trace)))
""
(string-append
"Cyc_st_add(\""
"Cyc_st_add(data, \""
(car trace)
":"
;; TODO: escape backslashes
@ -439,6 +451,9 @@
((eq? p 'Cyc-set-cvar!) "Cyc_set_cvar")
((eq? p 'Cyc-cvar?) "Cyc_is_cvar")
((eq? p 'Cyc-has-cycle?) "Cyc_has_cycle")
((eq? p 'Cyc-spawn-thread!) "Cyc_spawn_thread")
((eq? p 'Cyc-end-thread!) "Cyc_end_thread")
((eq? p 'thread-sleep!) "Cyc_thread_sleep")
((eq? p 'Cyc-stdout) "Cyc_stdout")
((eq? p 'Cyc-stdin) "Cyc_stdin")
((eq? p 'Cyc-stderr) "Cyc_stderr")
@ -518,8 +533,13 @@
((eq? p 'string-ref) "Cyc_string_ref")
((eq? p 'string-set!) "Cyc_string_set")
((eq? p 'substring) "Cyc_substring")
((eq? p 'make-mutex) "Cyc_make_mutex")
((eq? p 'mutex-lock!) "Cyc_mutex_lock")
((eq? p 'mutex-unlock!) "Cyc_mutex_unlock")
((eq? p 'mutex?) "Cyc_is_mutex")
((eq? p 'Cyc-installation-dir) "Cyc_installation_dir")
((eq? p 'command-line-arguments) "Cyc_command_line_arguments")
((eq? p 'Cyc-minor-gc) "Cyc_trigger_minor_gc")
((eq? p 'system) "Cyc_system")
((eq? p 'assq) "assq")
((eq? p 'assv) "assq")
@ -555,6 +575,69 @@
(else
(error "unhandled primitive: " p))))
;; Does the primitive require passing thread data as its first argument?
(define (prim/data-arg? p)
(member p '(
+
-
*
/
=
>
<
>=
<=
apply
Cyc-default-exception-handler
Cyc-end-thread!
thread-sleep!
open-input-file
open-output-file
close-port
close-input-port
close-output-port
Cyc-flush-output-port
file-exists?
delete-file
read-char
peek-char
Cyc-read-line
Cyc-write-char
integer->char
string->number
list->string
make-vector
list->vector
vector-length
vector-ref
vector-set!
string-append
string-cmp
string->symbol
symbol->string
number->string
string-length
string-ref
string-set!
substring
make-mutex
mutex-lock!
mutex-unlock!
Cyc-installation-dir
command-line-arguments
Cyc-minor-gc
assq
assv
assoc
memq
memv
member
length
set-car!
set-cdr!
procedure?
set-cell!)))
;; Determine if primitive assigns (allocates) a C variable
;; EG: int v = prim();
(define (prim/c-var-assign p)
@ -567,25 +650,31 @@
((eq? p 'length) "integer_type")
((eq? p 'vector-length) "integer_type")
((eq? p 'char->integer) "integer_type")
((eq? p 'Cyc-installation-dir) "string_type")
((eq? p 'system) "integer_type")
((eq? p '+) "common_type")
((eq? p '-) "common_type")
((eq? p '*) "common_type")
((eq? p '/) "common_type")
((eq? p 'string->number) "common_type")
((eq? p 'list->string) "string_type")
((eq? p 'string-cmp) "integer_type")
((eq? p 'string-append) "string_type")
((eq? p 'symbol->string) "string_type")
((eq? p 'number->string) "string_type")
((eq? p 'string-append) "object")
((eq? p 'string-length) "integer_type")
((eq? p 'substring) "string_type")
((eq? p 'apply) "object")
((eq? p 'Cyc-read-line) "object")
((eq? p 'read-char) "object")
((eq? p 'peek-char) "object")
((eq? p 'command-line-arguments) "object")
((eq? p 'Cyc-minor-gc) "object")
((eq? p 'number->string) "object")
((eq? p 'symbol->string) "object")
((eq? p 'substring) "object")
((eq? p 'make-vector) "object")
((eq? p 'list->string) "object")
((eq? p 'list->vector) "object")
;((eq? p 'make-mutex) "object")
((eq? p 'mutex-lock!) "object")
((eq? p 'mutex-unlock!) "object")
((eq? p 'Cyc-installation-dir) "object")
(else #f)))
;; Determine if primitive creates a C variable
@ -607,18 +696,25 @@
string-length substring
+ - * / apply
command-line-arguments
;make-mutex
mutex-lock! mutex-unlock!
Cyc-minor-gc
Cyc-read-line
read-char peek-char
cons length vector-length cell))))
;; Pass continuation as the function's first parameter?
(define (prim:cont? exp)
(and (prim? exp)
(member exp '(Cyc-read-line apply command-line-arguments make-vector list->vector))))
;; TODO: this is a hack, right answer is to include information about
;; how many args each primitive is supposed to take
(define (prim:cont-has-args? exp)
(member exp '(Cyc-read-line apply command-line-arguments Cyc-minor-gc number->string
read-char peek-char mutex-lock!
symbol->string list->string substring string-append
make-vector list->vector Cyc-installation-dir))))
;; Primitive functions that pass a continuation or thread data but have no other arguments
(define (prim:cont/no-args? exp)
(and (prim? exp)
(member exp '(Cyc-read-line apply make-vector list->vector))))
(member exp '(command-line-arguments make-mutex Cyc-minor-gc))))
;; Pass an integer arg count as the function's first parameter?
(define (prim:arg-count? exp)
@ -632,6 +728,13 @@
(and (prim? exp)
(member exp '())))
;; Does string end with the given substring?
;; EG: ("test(" "(") ==> #t
(define (str-ending? str end)
(let ((len (string-length str)))
(and (> len 0)
(equal? end (substring str (- len 1) len)))))
;; c-compile-prim : prim-exp -> string -> string
(define (c-compile-prim p cont)
(let* ((c-func (prim->c-func p))
@ -652,6 +755,10 @@
"," cont "); "))
(else #f)))
;; END apply defs
(tdata (cond
((prim/data-arg? p) "data")
(else "")))
(tdata-comma (if (> (string-length tdata) 0) "," ""))
(c-var-assign
(lambda (type)
(let ((cv-name (mangle (gensym 'c))))
@ -670,12 +777,14 @@
;; Emit closure as first arg, if necessary (apply only)
(cond
(closure-def
(string-append "&" closure-sym
(if (prim:cont-has-args? p) ", " "")))
(string-append
tdata ","
"&" closure-sym))
((prim:cont? p)
(string-append cont
(if (prim:cont-has-args? p) ", " "")))
(else "")))))))))
(string-append
tdata ","
cont))
(else tdata)))))))))
(cond
((prim/c-var-assign p)
(c-var-assign (prim/c-var-assign p)))
@ -692,9 +801,9 @@
cv-name ;; Already a pointer
(string-append "&" cv-name)) ;; Point to data
(list
(string-append c-func "(" cv-name)))))
(string-append c-func "(" cv-name tdata-comma tdata)))))
(else
(c-code (string-append c-func "("))))))
(c-code (string-append c-func "(" tdata))))))
;; END primitives
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -751,7 +860,7 @@
(string-append
(c:allocs->str (c:allocs cgen))
"return_direct" (number->string num-cargs)
"(" this-cont
"(data," this-cont
(if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
(c:body cgen) ");"))))
@ -776,11 +885,24 @@
(c:allocs c-args*) ;; fun alloc depends upon arg allocs
(list (string-append
(car (c:allocs c-fun))
(if (prim/c-var-assign fun) "" ",") ; Allocating C var
(c:body c-args*) ");"))))
(if (prim/c-var-assign fun)
;; Add a comma if there were any args to the func added by comp-prim
(if (or (str-ending? (car (c:allocs c-fun)) "(")
(prim:cont/no-args? fun))
""
",")
",")
(c:body c-args*) ");"))))
;; Args stay with body
(c:append
(c:append c-fun c-args*)
(c:append
(let ()
;; Add a comma if necessary
(if (or (str-ending? (c:body c-fun) "(")
(prim:cont/no-args? fun))
c-fun
(c:append c-fun (c-code ", "))))
c-args*)
(c-code ")")))))
((equal? '%closure-ref fun)
@ -803,7 +925,7 @@
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string (c:num-args cargs))
"("
"(data,"
this-cont
(if (> (c:num-args cargs) 0) "," "")
(c:body cargs)
@ -822,7 +944,7 @@
(c:allocs->str (c:allocs cfun) "\n")
(c:allocs->str (c:allocs cargs) "\n")
"return_closcall" (number->string num-cargs)
"("
"(data,"
this-cont
(if (> num-cargs 0) "," "")
(c:body cargs)
@ -992,6 +1114,8 @@
(create-nclosure (lambda ()
(string-append
"closureN_type " cv-name ";\n"
cv-name ".hdr.mark = gc_color_red;\n "
cv-name ".hdr.grayed = 0;\n"
cv-name ".tag = closureN_tag;\n "
cv-name ".fn = (function_type)__lambda_" (number->string lid) ";\n"
cv-name ".num_args = " (number->string (compute-num-args lam)) ";\n"
@ -1083,7 +1207,7 @@
(cons
(lambda (name)
(string-append "static void " name
"(int argc, "
"(void *data, int argc, "
formals*
") {\n"
preamble
@ -1169,7 +1293,7 @@
(lambda (l)
(emit*
"static void __lambda_"
(number->string (car l)) "(int argc, "
(number->string (car l)) "(void *data, int argc, "
(cdadr l)
") ;"))
lambdas)
@ -1185,14 +1309,14 @@
; Emit entry point
(cond
(program?
(emit "static void c_entry_pt_first_lambda();")
(emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value);")
(for-each
(lambda (lib-name)
(emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(int argc, closure cont, object value);"))
(emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(void *data, int argc, closure cont, object value);"))
required-libs)
(emit "static void c_entry_pt(argc, env,cont) int argc; closure env,cont; { "))
(emit "static void c_entry_pt(data, argc, env,cont) void *data; int argc; closure env,cont; { "))
(else
(emit* "void c_" (lib:name->string lib-name) "_entry_pt(argc, cont,value) int argc; closure cont; object value;{ ")
(emit* "void c_" (lib:name->string lib-name) "_entry_pt(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ")
; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");"))
))
@ -1295,9 +1419,9 @@
(reverse required-libs)) ;; Init each lib's dependencies 1st
(emit*
;; Start cont chain, but do not assume closcall1 macro was defined
"(" this-clo ".fn)(0, &" this-clo ", &" this-clo ");")
"(" this-clo ".fn)(data, 0, &" this-clo ", &" this-clo ");")
(emit "}")
(emit "static void c_entry_pt_first_lambda(int argc, closure cont, object value) {")
(emit "static void c_entry_pt_first_lambda(void *data, int argc, closure cont, object value) {")
; DEBUG (emit (string-append "printf(\"init first lambda\\n\");"))
(emit compiled-program)))
(else
@ -1307,7 +1431,7 @@
(emit*
"(((closure)"
(mangle-global (lib:name->symbol lib-name))
")->fn)(1, cont, cont);")
")->fn)(data, 1, cont, cont);")
))
(emit "}")

6
scheme/cyclone/common.sld
View file

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

56
scheme/cyclone/libraries.sld
View file

@ -19,6 +19,7 @@
)
(export
library?
lib:list->import-set
lib:name
lib:name->string
lib:name->symbol
@ -43,7 +44,19 @@
(define (library? ast)
(tagged-list? 'define-library ast))
(define (lib:name ast) (cadr ast))
;; Convert a raw list to an import set. For example, a list might be
;; (srfi 18) containing the number 18. An import set contains only symbols.
(define (lib:list->import-set lis)
(map
(lambda (atom)
(cond
((number? atom)
(string->symbol (number->string atom)))
(else atom)))
lis))
(define (lib:name ast)
(lib:list->import-set (cadr ast)))
;; Convert name (as list of symbols) to a mangled string
(define (lib:name->string name)
@ -70,7 +83,7 @@
(define (lib:imports ast)
(lib:result
(let ((code (assoc 'import (cddr ast))))
(if code (cdr code) #f))))
(if code (lib:list->import-set (cdr code)) #f))))
(define (lib:body ast)
(lib:result
(let ((code (assoc 'begin (cddr ast))))
@ -86,6 +99,15 @@
;; TODO: include-ci, cond-expand
(define (lib:atom->string atom)
(cond
((symbol? atom)
(symbol->string atom))
((number? atom)
(number->string atom))
(else
(error "Unexpected type in import set"))))
;; Resolve library filename given an import.
;; Assumes ".sld" file extension if one is not specified.
(define (lib:import->filename import . ext)
@ -99,12 +121,13 @@
string-append
(map
(lambda (i)
(string-append "/" (symbol->string i)))
(string-append "/" (lib:atom->string i)))
import))
file-ext))
(filename
(substring filename* 1 (string-length filename*))))
(if (tagged-list? 'scheme import)
(if (or (tagged-list? 'scheme import)
(tagged-list? 'srfi import))
(string-append (Cyc-installation-dir 'sld) "/" filename) ;; Built-in library
filename)))
@ -116,7 +139,7 @@
string-append
(map
(lambda (i)
(string-append (symbol->string i) "/"))
(string-append (lib:atom->string i) "/"))
import-path))))
(if (tagged-list? 'scheme import)
(string-append (Cyc-installation-dir 'sld) "/" path) ;; Built-in library
@ -164,7 +187,7 @@
(map
(lambda (import)
(lib:import->export-list import))
imports)))
(lib:list->import-set imports))))
(define (lib:import->metalist import)
(let ((file (lib:import->filename import ".meta"))
@ -191,18 +214,19 @@
(define (lib:get-all-import-deps imports)
(letrec ((libraries/deps '())
(find-deps!
(lambda (import-set)
(lambda (import-sets)
(for-each
(lambda (i)
(cond
;; Prevent cycles by only processing new libraries
((not (assoc i libraries/deps))
;; Find all dependencies of i (IE, libraries it imports)
(let ((deps (lib:read-imports i)))
(set! libraries/deps (cons (cons i deps) libraries/deps))
(find-deps! deps)
))))
import-set))))
(let ((import-set (lib:list->import-set i)))
(cond
;; Prevent cycles by only processing new libraries
((not (assoc import-set libraries/deps))
;; Find all dependencies of i (IE, libraries it imports)
(let ((deps (lib:read-imports import-set)))
(set! libraries/deps (cons (cons import-set deps) libraries/deps))
(find-deps! deps)
)))))
import-sets))))
(find-deps! imports)
;`((deps ,libraries/deps) ; DEBUG
; (result ,(lib:get-dep-list libraries/deps)))

16
scheme/cyclone/transforms.sld
View file

@ -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

8
scheme/eval.sld
View file

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

45
srfi/18.sld Normal file
View file

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

219
test-ck.c Normal file
View file

@ -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;
//}

1597
test.scm
View file

File diff suppressed because it is too large Load diff