commit a41bd15d66f8068bc7cb2b6c0599c4d5bf166c20
parent 828107c7e6d8cc39eb55fce0337f09787852c201
Author: Andres Navarro <canavarro82@gmail.com>
Date: Mon, 22 Jul 2013 16:06:00 -0300
Merged threads branch
Diffstat:
68 files changed, 2414 insertions(+), 1118 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -2,4 +2,6 @@ v0.4
- Added eq-hashtables (Oto Havle)
- Fixed semantics of eval in the presence of continuation capturing
- and mutation of the argument or result list
-\ No newline at end of file
+ and mutation of the argument or result list
+- Fixed semantics of other combiners in the presence of continuation capturing
+ and mutation (filter)
diff --git a/TODO b/TODO
@@ -1,3 +1,8 @@
+- Check lambda for problems with continuation capturing
+- Check the let family for problems with continuation capturing
+- Check map for problems with continuation capturing
+
+
* Release 0.4+
** refactor:
*** clean stand alone interpreter
diff --git a/src/Makefile b/src/Makefile
@@ -17,7 +17,7 @@ RANLIB= ranlib
# Use "RM= del /q /f" if you want to compile with MinGW without using MSYS
RM= rm -f
-LIBS=-lm $(MYLIBS)
+LIBS=-lm -lpthread $(MYLIBS)
# Set USE_LIBFFI=1 (or other nonempty string) to enable libffi-dependent
# code.
@@ -56,7 +56,8 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kgenvironments.o kgenv_mut.o kgcombiners.o kgcontinuations.o \
kgencapsulations.o kgpromises.o kgkd_vars.o kgks_vars.o kgports.o \
kgchars.o kgnumbers.o kgstrings.o kgbytevectors.o kgvectors.o \
- kgtables.o kgsystem.o kgerrors.o kgkeywords.o \
+ kgtables.o kgsystem.o kgerrors.o kgkeywords.o kgthreads.o kmutex.o \
+ kcondvar.o \
$(if $(USE_LIBFFI),kgffi.o)
# TEMP: in klisp there is no distinction between core & lib
@@ -142,156 +143,171 @@ tags:
kapplicative.o: kapplicative.c kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kapplicative.h koperative.h kgc.h
-kauxlib.o: kauxlib.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
+kauxlib.o: kauxlib.c klisp.h kstate.h klimits.h kobject.h klispconf.h \
ktoken.h kmem.h
kbytevector.o: kbytevector.c kbytevector.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kgc.h kstring.h
kchar.o: kchar.c kobject.h klimits.h klisp.h klispconf.h
+kcondvar.o: kcondvar.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
+ ktoken.h kmem.h kmutex.h kcondvar.h kgc.h kerror.h kpair.h
kcontinuation.o: kcontinuation.c kcontinuation.h kobject.h klimits.h \
- klisp.h klispconf.h kstate.h ktoken.h kmem.h kgc.h
+ klisp.h klispconf.h kstate.h ktoken.h kmem.h kpair.h kgc.h \
+ kapplicative.h koperative.h
kencapsulation.o: kencapsulation.c kobject.h klimits.h klisp.h \
klispconf.h kmem.h kstate.h ktoken.h kencapsulation.h kpair.h kgc.h
kenvironment.o: kenvironment.c kenvironment.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kpair.h kgc.h ksymbol.h kstring.h \
kerror.h ktable.h kapplicative.h koperative.h
-kerror.o: kerror.c klisp.h kobject.h klimits.h klispconf.h kpair.h \
+kerror.o: kerror.c klisp.h kpair.h kobject.h klimits.h klispconf.h \
kstate.h ktoken.h kmem.h kgc.h kstring.h kerror.h
-keval.o: keval.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
+keval.o: keval.c klisp.h kstate.h klimits.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h kerror.h \
- kghelpers.h kapplicative.h koperative.h ksymbol.h kstring.h ktable.h
+ kghelpers.h kvector.h kapplicative.h koperative.h ksymbol.h kstring.h \
+ ktable.h
kgbooleans.o: kgbooleans.c kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kpair.h kgc.h ksymbol.h kstring.h \
- kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h \
- kenvironment.h ktable.h kgbooleans.h
+ kcontinuation.h kerror.h kghelpers.h kvector.h kapplicative.h \
+ koperative.h kenvironment.h ktable.h kgbooleans.h
kgbytevectors.o: kgbytevectors.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h \
- kerror.h kpair.h kgc.h kbytevector.h kghelpers.h kenvironment.h \
- ksymbol.h kstring.h ktable.h kgbytevectors.h
+ kerror.h kpair.h kgc.h kbytevector.h kghelpers.h kvector.h \
+ kenvironment.h ksymbol.h kstring.h ktable.h kgbytevectors.h
kgc.o: kgc.c kgc.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kport.h imath.h imrat.h ktable.h kstring.h kbytevector.h \
- kvector.h kerror.h kpair.h
+ kvector.h kmutex.h kcondvar.h kerror.h kpair.h
kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kpair.h kgc.h kchar.h kghelpers.h kenvironment.h ksymbol.h kstring.h \
- ktable.h kgchars.h
+ kpair.h kgc.h kchar.h kghelpers.h kvector.h kenvironment.h ksymbol.h \
+ kstring.h ktable.h kgchars.h
kgcombiners.o: kgcombiners.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
ksymbol.h kstring.h koperative.h kapplicative.h kerror.h kghelpers.h \
- ktable.h kgcombiners.h
+ kvector.h ktable.h kgcombiners.h
kgcontinuations.o: kgcontinuations.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
kapplicative.h koperative.h ksymbol.h kstring.h kerror.h kghelpers.h \
- ktable.h kgcontinuations.h
+ kvector.h ktable.h kgcontinuations.h
kgcontrol.o: kgcontrol.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h kerror.h kghelpers.h \
- kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h ktable.h \
- kgcontrol.h
+ kvector.h kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h \
+ ktable.h kgcontrol.h
kgencapsulations.o: kgencapsulations.c kstate.h klimits.h klisp.h \
kobject.h klispconf.h ktoken.h kmem.h kencapsulation.h kapplicative.h \
- koperative.h kerror.h kpair.h kgc.h kghelpers.h kcontinuation.h \
- kenvironment.h ksymbol.h kstring.h ktable.h kgencapsulations.h
+ koperative.h kerror.h kpair.h kgc.h kghelpers.h kvector.h \
+ kcontinuation.h kenvironment.h ksymbol.h kstring.h ktable.h \
+ kgencapsulations.h
kgenv_mut.o: kgenv_mut.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h ksymbol.h \
- kstring.h kerror.h kghelpers.h kapplicative.h koperative.h ktable.h \
- kgenv_mut.h
+ kstring.h kerror.h kghelpers.h kvector.h kapplicative.h koperative.h \
+ ktable.h kgenv_mut.h
kgenvironments.o: kgenvironments.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
- ksymbol.h kstring.h kerror.h kghelpers.h kapplicative.h koperative.h \
- ktable.h kport.h kread.h kgenvironments.h
+ ksymbol.h kstring.h kerror.h kport.h kread.h kghelpers.h kvector.h \
+ kapplicative.h koperative.h ktable.h kgenvironments.h
kgeqp.o: kgeqp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h kerror.h kghelpers.h \
- kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h ktable.h \
- kgeqp.h
+ kvector.h kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h \
+ ktable.h kgeqp.h
kgequalp.o: kgequalp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kvector.h kstring.h kbytevector.h \
kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h \
kenvironment.h ksymbol.h ktable.h kgequalp.h
kgerrors.o: kgerrors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kstring.h kpair.h kgc.h kerror.h kghelpers.h \
+ ktoken.h kmem.h kstring.h kpair.h kgc.h kerror.h kghelpers.h kvector.h \
kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
ktable.h kgerrors.h
kgffi.o: kgffi.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kinteger.h kpair.h kgc.h kerror.h kbytevector.h \
- kencapsulation.h ktable.h kghelpers.h kapplicative.h koperative.h \
- kcontinuation.h kenvironment.h ksymbol.h kstring.h kgffi.h
+ kencapsulation.h ktable.h kghelpers.h kvector.h kapplicative.h \
+ koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h kgffi.h
kghelpers.o: kghelpers.c kghelpers.h kstate.h klimits.h klisp.h kobject.h \
- klispconf.h ktoken.h kmem.h kerror.h kpair.h kgc.h kapplicative.h \
- koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h ktable.h \
- kinteger.h imath.h krational.h imrat.h kbytevector.h kvector.h \
+ klispconf.h ktoken.h kmem.h kerror.h kpair.h kgc.h kvector.h \
+ kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
+ kstring.h ktable.h kinteger.h imath.h krational.h imrat.h kbytevector.h \
kencapsulation.h kpromise.h
kgkd_vars.o: kgkd_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h koperative.h \
- kapplicative.h kenvironment.h kerror.h kghelpers.h ksymbol.h kstring.h \
- ktable.h kgkd_vars.h
+ kapplicative.h kenvironment.h kerror.h kghelpers.h kvector.h ksymbol.h \
+ kstring.h ktable.h kgkd_vars.h
+kgkeywords.o: kgkeywords.c kstate.h klimits.h klisp.h kobject.h \
+ klispconf.h ktoken.h kmem.h kstring.h ksymbol.h kkeyword.h kerror.h \
+ kpair.h kgc.h kghelpers.h kvector.h kapplicative.h koperative.h \
+ kcontinuation.h kenvironment.h ktable.h kgkeywords.h
kgks_vars.o: kgks_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h koperative.h \
- kapplicative.h kenvironment.h kerror.h kghelpers.h ksymbol.h kstring.h \
- ktable.h kgks_vars.h
+ kapplicative.h kenvironment.h kerror.h kghelpers.h kvector.h ksymbol.h \
+ kstring.h ktable.h kgks_vars.h
+kglibraries.o: kglibraries.c kstate.h klimits.h klisp.h kobject.h \
+ klispconf.h ktoken.h kmem.h klibrary.h kapplicative.h koperative.h \
+ kcontinuation.h kerror.h kpair.h kgc.h kenvironment.h kkeyword.h \
+ kstring.h kghelpers.h kvector.h ksymbol.h ktable.h kglibraries.h
kgnumbers.o: kgnumbers.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h ksymbol.h kstring.h kinteger.h imath.h krational.h imrat.h \
- kreal.h kghelpers.h kenvironment.h ktable.h kgnumbers.h
+ kreal.h kghelpers.h kvector.h kenvironment.h ktable.h kgnumbers.h
kgpair_mut.o: kgpair_mut.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kcontinuation.h ksymbol.h \
- kstring.h kerror.h kghelpers.h kapplicative.h koperative.h \
+ kstring.h kerror.h kghelpers.h kvector.h kapplicative.h koperative.h \
kenvironment.h ktable.h kgpair_mut.h
kgpairs_lists.o: kgpairs_lists.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kstring.h kcontinuation.h \
- kenvironment.h ksymbol.h kerror.h kghelpers.h kapplicative.h \
+ kenvironment.h ksymbol.h kerror.h kghelpers.h kvector.h kapplicative.h \
koperative.h ktable.h kgpairs_lists.h
kgports.o: kgports.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kport.h kstring.h kbytevector.h kenvironment.h \
+ ktoken.h kmem.h kport.h kstring.h ktable.h kbytevector.h kenvironment.h \
kapplicative.h koperative.h kcontinuation.h kpair.h kgc.h kerror.h \
- ksymbol.h kread.h kwrite.h kghelpers.h ktable.h kgports.h ktable.h
+ ksymbol.h kread.h kwrite.h kghelpers.h kvector.h kgports.h
kgpromises.o: kgpromises.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpromise.h kpair.h kgc.h kapplicative.h \
- koperative.h kcontinuation.h kerror.h kghelpers.h kenvironment.h \
- ksymbol.h kstring.h ktable.h kgpromises.h
-kglibraries.o: kglibraries.c kstate.h klimits.h klisp.h kobject.h \
- klispconf.h ktoken.h kmem.h klibrary.h kpair.h kgc.h kapplicative.h \
- koperative.h kcontinuation.h kerror.h kghelpers.h kenvironment.h \
- ksymbol.h kstring.h ktable.h kglibraries.h kpair.h kkeyword.h
+ koperative.h kcontinuation.h kerror.h kghelpers.h kvector.h \
+ kenvironment.h ksymbol.h kstring.h ktable.h kgpromises.h
kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kground.h kghelpers.h kerror.h kpair.h kgc.h \
+ ktoken.h kmem.h kground.h kghelpers.h kerror.h kpair.h kgc.h kvector.h \
kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
kstring.h ktable.h kgbooleans.h kgeqp.h kgequalp.h kgsymbols.h \
kgcontrol.h kgpairs_lists.h kgpair_mut.h kgenvironments.h kgenv_mut.h \
kgcombiners.h kgcontinuations.h kgencapsulations.h kgpromises.h \
kgkd_vars.h kgks_vars.h kgnumbers.h kgstrings.h kgchars.h kgports.h \
- kgbytevectors.h kgvectors.h kgtables.h kgsystem.h kgerrors.h kglibraries.h \
- kgffi.h keval.h krepl.h
+ kgbytevectors.h kgvectors.h kgtables.h kgsystem.h kgerrors.h \
+ kgkeywords.h kglibraries.h kgthreads.h kgffi.h keval.h krepl.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h ksymbol.h kstring.h kchar.h kvector.h kbytevector.h \
kghelpers.h kenvironment.h ktable.h kgstrings.h
kgsymbols.o: kgsymbols.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kcontinuation.h kpair.h kgc.h kstring.h ksymbol.h \
- kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h ktable.h \
- kgsymbols.h
-kgkeywords.o: kgkeywords.c kgkeywords.h kstate.h klimits.h klisp.h kobject.h \
- klispconf.h ktoken.h kmem.h kcontinuation.h kpair.h kgc.h kstring.h \
- ksymbol.h kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h \
- ktable.h kkeyword.h
+ kerror.h kghelpers.h kvector.h kapplicative.h koperative.h \
+ kenvironment.h ktable.h kgsymbols.h
kgsystem.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kgc.h kerror.h ksystem.h kghelpers.h \
- kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
- kstring.h ktable.h kgsystem.h kinteger.h kmem.h imath.h kgc.h
+ ktoken.h kmem.h kpair.h kgc.h kerror.h ksystem.h kinteger.h imath.h \
+ kghelpers.h kvector.h kapplicative.h koperative.h kcontinuation.h \
+ kenvironment.h ksymbol.h kstring.h ktable.h kgsystem.h
kgtables.o: kgtables.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kpair.h kgc.h kvector.h kbytevector.h kghelpers.h kenvironment.h \
- ksymbol.h kstring.h ktable.h kgtables.h
+ kpair.h kgc.h kghelpers.h kvector.h kenvironment.h ksymbol.h kstring.h \
+ ktable.h kgtables.h
+kgthreads.o: kgthreads.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kmutex.h kcondvar.h kghelpers.h kerror.h kpair.h kgc.h \
+ kvector.h kapplicative.h koperative.h kcontinuation.h kenvironment.h \
+ ksymbol.h kstring.h ktable.h
kgvectors.o: kgvectors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h kvector.h kbytevector.h kghelpers.h kenvironment.h \
ksymbol.h kstring.h ktable.h kgvectors.h
kinteger.o: kinteger.c kinteger.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h imath.h kgc.h
-klisp.o: klisp.c klimits.h klisp.h kobject.h klispconf.h kstate.h \
+kkeyword.o: kkeyword.c kkeyword.h kobject.h klimits.h klisp.h klispconf.h \
+ kstate.h ktoken.h kmem.h kstring.h kgc.h
+klibrary.o: klibrary.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
+ ktoken.h kmem.h klibrary.h kgc.h
+klisp.o: klisp.c klimits.h klisp.h kstate.h kobject.h klispconf.h \
ktoken.h kmem.h kauxlib.h kstring.h kcontinuation.h koperative.h \
kapplicative.h ksymbol.h kenvironment.h kport.h kread.h kwrite.h \
- kerror.h kpair.h kgc.h krepl.h kghelpers.h ktable.h
-kmem.o: kmem.c klisp.h kobject.h klimits.h klispconf.h kstate.h ktoken.h \
+ kerror.h kpair.h kgc.h krepl.h ksystem.h kghelpers.h kvector.h ktable.h
+kmem.o: kmem.c klisp.h kstate.h klimits.h kobject.h klispconf.h ktoken.h \
kmem.h kerror.h kpair.h kgc.h
+kmutex.o: kmutex.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
+ ktoken.h kmem.h kmutex.h kgc.h kerror.h kpair.h
kobject.o: kobject.c kobject.h klimits.h klisp.h klispconf.h
koperative.o: koperative.c koperative.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kgc.h
@@ -301,8 +317,6 @@ kport.o: kport.c kport.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kerror.h kpair.h kgc.h kstring.h kbytevector.h
kpromise.o: kpromise.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kpromise.h kpair.h kgc.h
-klibrary.o: klibrary.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h klibrary.h kgc.h
krational.o: krational.c krational.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kinteger.h imath.h imrat.h kgc.h
kread.o: kread.c kread.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
@@ -310,39 +324,37 @@ kread.o: kread.c kread.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
kreal.o: kreal.c kreal.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kinteger.h imath.h krational.h imrat.h kgc.h kpair.h \
kerror.h
-krepl.o: krepl.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
+krepl.o: krepl.c klisp.h kstate.h klimits.h kobject.h klispconf.h \
ktoken.h kmem.h kcontinuation.h kenvironment.h kerror.h kpair.h kgc.h \
kread.h kwrite.h kstring.h krepl.h ksymbol.h kport.h ktable.h \
- kghelpers.h kapplicative.h koperative.h
-kstate.o: kstate.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
- ktoken.h kmem.h kstring.h kpair.h kgc.h keval.h koperative.h \
- kapplicative.h kcontinuation.h kenvironment.h kground.h krepl.h \
- ksymbol.h kport.h ktable.h kbytevector.h kvector.h kghelpers.h kerror.h \
- kgerrors.h
+ kghelpers.h kvector.h kapplicative.h koperative.h
+kstate.o: kstate.c klisp.h klimits.h kstate.h kobject.h klispconf.h \
+ ktoken.h kmem.h kpair.h kgc.h keval.h koperative.h kapplicative.h \
+ kcontinuation.h kenvironment.h kground.h krepl.h ksymbol.h kstring.h \
+ kport.h ktable.h kbytevector.h kvector.h kghelpers.h kerror.h kgerrors.h
kstring.o: kstring.c kstring.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kgc.h
ksymbol.o: ksymbol.c ksymbol.h kobject.h klimits.h klisp.h klispconf.h \
- kstate.h kmem.h kstring.h kgc.h
-kkeyword.o: kkeyword.c kkeyword.h kobject.h klimits.h klisp.h klispconf.h \
- kstate.h kmem.h kstring.h kgc.h
+ kstate.h ktoken.h kmem.h kstring.h kgc.h
ksystem.o: ksystem.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h kerror.h kpair.h kgc.h ksystem.h
+ ktoken.h kmem.h kerror.h kpair.h kgc.h kinteger.h imath.h ksystem.h
ksystem.posix.o: ksystem.posix.c kobject.h klimits.h klisp.h klispconf.h \
- kstate.h ktoken.h kmem.h kinteger.h imath.h ksystem.h
+ kstate.h ktoken.h kmem.h kinteger.h imath.h kport.h ksystem.h
ksystem.win32.o: ksystem.win32.c kobject.h klimits.h klisp.h klispconf.h \
- kstate.h ktoken.h kmem.h kinteger.h imath.h ksystem.h
-ktable.o: ktable.c klisp.h kobject.h klimits.h klispconf.h kgc.h kstate.h \
+ kstate.h ktoken.h kmem.h kinteger.h imath.h kport.h ksystem.h
+ktable.o: ktable.c klisp.h kgc.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h ktable.h kapplicative.h koperative.h kghelpers.h \
- kerror.h kpair.h kcontinuation.h kenvironment.h ksymbol.h kstring.h
+ kerror.h kpair.h kvector.h kcontinuation.h kenvironment.h ksymbol.h \
+ kstring.h
ktoken.o: ktoken.c ktoken.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h kpair.h \
- kgc.h kstring.h kbytevector.h ksymbol.h kerror.h kport.h kkeyword.h
+ kgc.h kstring.h kbytevector.h ksymbol.h kkeyword.h kerror.h kport.h
kvector.o: kvector.c kvector.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kgc.h
kwrite.o: kwrite.c kwrite.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h \
kpair.h kgc.h kstring.h ksymbol.h kkeyword.h kerror.h ktable.h kport.h \
- kenvironment.h kbytevector.h kvector.h ktoken.h
+ kenvironment.h kbytevector.h kvector.h
imath.o: imath.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kerror.h kpair.h kgc.h
imrat.o: imrat.c imrat.h imath.h kobject.h klimits.h klisp.h klispconf.h \
diff --git a/src/imath.c b/src/imath.c
@@ -2242,7 +2242,6 @@ STATIC mp_digit *s_realloc(klisp_State *K, mp_digit *old, mp_size osize,
#else
mp_digit *new = klispM_realloc_(K, old, osize * sizeof(mp_digit),
nsize * sizeof(mp_digit));
-
assert(new != NULL); /* for debugging */
#endif
return new;
diff --git a/src/kbytevector.c b/src/kbytevector.c
@@ -24,14 +24,9 @@ TValue kbytevector_new_bs_g(klisp_State *K, bool m, const uint8_t *buf,
kbytevector_new_bs_imm(K, buf, size);
}
-/*
-** Constructors for immutable bytevectors
-*/
-
-/* main constructor for immutable bytevectors */
-TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
+/* LOCK: GIL should be acquired */
+static uint32_t get_bytevector_hash(const uint8_t *buf, uint32_t size)
{
- /* first check to see if it's in the stringtable */
uint32_t h = size; /* seed */
size_t step = (size>>5)+1; /* if bytevector is too long, don't hash all
its bytes */
@@ -39,7 +34,16 @@ TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
for (size1 = size; size1 >= step; size1 -= step) /* compute hash */
h = h ^ ((h<<5)+(h>>2)+ buf[size1-1]);
- for (GCObject *o = K->strt.hash[lmod(h, K->strt.size)];
+ return h;
+}
+
+/* Looks for a bytevector in the stringtable and returns a pointer
+ to it if found or NULL otherwise. */
+static Bytevector *search_in_bb_table(klisp_State *K, const uint8_t *buf,
+ uint32_t size, uint32_t h)
+{
+
+ for (GCObject *o = G(K)->strt.hash[lmod(h, G(K)->strt.size)];
o != NULL; o = o->gch.next) {
klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
@@ -49,14 +53,32 @@ TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
Bytevector *tb = (Bytevector *) o;
if (tb->size == size && (memcmp(buf, tb->b, size) == 0)) {
/* bytevector may be dead */
- if (isdead(K, o)) changewhite(o);
- return gc2bytevector(o);
+ if (isdead(G(K), o)) changewhite(o);
+ return tb;
}
- }
+ }
+ return NULL;
+}
+
+
+/*
+** Constructors for immutable bytevectors
+*/
+
+/* main constructor for immutable bytevectors */
+TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
+{
+ uint32_t h = get_bytevector_hash(buf, size);
+
+ /* first check to see if it's in the stringtable */
+ Bytevector *new_bb = search_in_bb_table(K, buf, size, h);
+
+ if (new_bb != NULL) { /* found */
+ return gc2bytevector(new_bb);
+ }
/* If it exits the loop, it means it wasn't found, hash is still in h */
/* REFACTOR: move all of these to a new function */
- Bytevector *new_bb;
if (size > (SIZE_MAX - sizeof(Bytevector)))
klispM_toobig(K);
@@ -66,7 +88,7 @@ TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
/* header + gc_fields */
/* can't use klispC_link, because strings use the next pointer
differently */
- new_bb->gct = klispC_white(K);
+ new_bb->gct = klispC_white(G(K));
new_bb->tt = K_TBYTEVECTOR;
new_bb->kflags = K_FLAG_IMMUTABLE;
new_bb->si = NULL;
@@ -82,7 +104,7 @@ TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
/* add to the string/symbol table (and link it) */
stringtable *tb;
- tb = &K->strt;
+ tb = &G(K)->strt;
h = lmod(h, tb->size);
new_bb->next = tb->hash[h]; /* chain new entry */
tb->hash[h] = (GCObject *)(new_bb);
@@ -93,7 +115,7 @@ TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
klispS_resize(K, tb->size*2); /* too crowded */
krooted_tvs_pop(K);
}
-
+
return ret_tv;
}
@@ -108,8 +130,8 @@ TValue kbytevector_new_s(klisp_State *K, uint32_t size)
Bytevector *new_bb;
if (size == 0) {
- klisp_assert(ttisbytevector(K->empty_bytevector));
- return K->empty_bytevector;
+ klisp_assert(ttisbytevector(G(K)->empty_bytevector));
+ return G(K)->empty_bytevector;
}
new_bb = klispM_malloc(K, sizeof(Bytevector) + size);
@@ -122,7 +144,6 @@ TValue kbytevector_new_s(klisp_State *K, uint32_t size)
new_bb->size = size;
/* the buffer is initialized elsewhere */
-
return gc2bytevector(new_bb);
}
@@ -130,8 +151,8 @@ TValue kbytevector_new_s(klisp_State *K, uint32_t size)
TValue kbytevector_new_bs(klisp_State *K, const uint8_t *buf, uint32_t size)
{
if (size == 0) {
- klisp_assert(ttisbytevector(K->empty_bytevector));
- return K->empty_bytevector;
+ klisp_assert(ttisbytevector(G(K)->empty_bytevector));
+ return G(K)->empty_bytevector;
}
TValue new_bb = kbytevector_new_s(K, size);
@@ -143,8 +164,8 @@ TValue kbytevector_new_bs(klisp_State *K, const uint8_t *buf, uint32_t size)
TValue kbytevector_new_sf(klisp_State *K, uint32_t size, uint8_t fill)
{
if (size == 0) {
- klisp_assert(ttisbytevector(K->empty_bytevector));
- return K->empty_bytevector;
+ klisp_assert(ttisbytevector(G(K)->empty_bytevector));
+ return G(K)->empty_bytevector;
}
TValue new_bb = kbytevector_new_s(K, size);
@@ -153,7 +174,7 @@ TValue kbytevector_new_sf(klisp_State *K, uint32_t size, uint8_t fill)
}
/* both obj1 and obj2 should be bytevectors */
-bool kbytevector_equalp(TValue obj1, TValue obj2)
+bool kbytevector_equalp(klisp_State *K, TValue obj1, TValue obj2)
{
klisp_assert(ttisbytevector(obj1) && ttisbytevector(obj2));
diff --git a/src/kbytevector.h b/src/kbytevector.h
@@ -38,12 +38,13 @@ TValue kbytevector_new_sf(klisp_State *K, uint32_t size, uint8_t fill);
/* both obj1 and obj2 should be bytevectors, this compares byte by byte
and doesn't differentiate immutable from mutable bytevectors */
-bool kbytevector_equalp(TValue obj1, TValue obj2);
+bool kbytevector_equalp(klisp_State *K, TValue obj1, TValue obj2);
bool kbytevectorp(TValue obj);
bool kimmutable_bytevectorp(TValue obj);
bool kmutable_bytevectorp(TValue obj);
/* some macros to access the parts of the bytevectors */
+/* LOCK: these are immutable, so they don't need locking */
#define kbytevector_buf(tv_) (tv2bytevector(tv_)->b)
#define kbytevector_size(tv_) (tv2bytevector(tv_)->size)
diff --git a/src/kcondvar.c b/src/kcondvar.c
@@ -0,0 +1,107 @@
+/*
+** kcondvar.c
+** Kernel Libraries
+** See Copyright Notice in klisp.h
+*/
+
+#include "kobject.h"
+#include "kstate.h"
+#include "kmutex.h"
+#include "kcondvar.h"
+#include "kmem.h"
+#include "kgc.h"
+#include "kerror.h"
+
+/* GC: Assumes mutex is rooted */
+TValue kmake_condvar(klisp_State *K, TValue mutex)
+{
+ Condvar *new_condvar = klispM_new(K, Condvar);
+
+ /* header + gc_fields */
+ klispC_link(K, (GCObject *) new_condvar, K_TCONDVAR, 0);
+
+ /* condvar specific fields */
+ new_condvar->mutex = mutex;
+
+ /* XXX no attrs for now */
+ int32_t res = pthread_cond_init(&new_condvar->cond, NULL);
+
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, "Can't create conndition "
+ "variable", 1, i2tv(res));
+ return KNIL;
+ }
+ return gc2condvar(new_condvar);
+}
+
+/* LOCK: GIL should be acquired exactly once */
+/* LOCK: underlying mutex should be acquired by this thread */
+/* GC: condvar should be rooted */
+void kcondvar_wait(klisp_State *K, TValue condvar)
+{
+ TValue thread = gc2th(K);
+ TValue mutex = kcondvar_mutex(condvar);
+
+ if (!tv_equal(thread, kmutex_owner(mutex))) {
+ klispE_throw_simple(K, "Can't wait without holding the mutex");
+ return;
+ }
+
+ /* save mutex info to recover after awakening */
+ uint32_t count = kmutex_count(mutex);
+ kmutex_owner(mutex) = KMUTEX_NO_OWNER;
+ kmutex_count(mutex) = 0;
+
+ /* we need to release GIL to avoid deadlocks */
+ klisp_unlock(K);
+ int res = pthread_cond_wait(&kcondvar_cond(condvar),
+ &kmutex_mutex(mutex));
+ klisp_lock(K);
+
+ /* recover the saved mutex info */
+ klisp_assert(!kmutex_is_owned(mutex));
+
+ kmutex_owner(mutex) = thread;
+ kmutex_count(mutex) = count;
+
+ /* This shouldn't happen, according to the spec */
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, "Couldn't wait on condvar",
+ 1, i2tv(res));
+ return;
+ }
+}
+
+/* LOCK: GIL should be acquired exactly once */
+/* LOCK: underlying mutex should be acquired by this thread */
+/* GC: condvar should be rooted */
+void kcondvar_signal(klisp_State *K, TValue condvar, bool broadcast)
+{
+ TValue thread = gc2th(K);
+ TValue mutex = kcondvar_mutex(condvar);
+
+ if (!tv_equal(thread, kmutex_owner(mutex))) {
+ klispE_throw_simple(K, broadcast?
+ "Can't broadcast without holding the mutex" :
+ "Can't signal without holding the mutex");
+ return;
+ }
+
+ int res = broadcast? pthread_cond_broadcast(&kcondvar_cond(condvar)) :
+ pthread_cond_signal(&kcondvar_cond(condvar));
+
+ /* This shouldn't happen, according to the spec */
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, broadcast?
+ "Couldn't broadcast on condvar" :
+ "Couldn't signal on condvar",
+ 1, i2tv(res));
+ return;
+ }
+}
+
+void klispV_free(klisp_State *K, Condvar *m)
+{
+ UNUSED(pthread_cond_destroy(&m->cond));
+ klispM_free(K, m);
+}
diff --git a/src/kcondvar.h b/src/kcondvar.h
@@ -0,0 +1,27 @@
+/*
+** kcondvar.h
+** Kernel Libraries
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kcondvar_h
+#define kcondvar_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+TValue kmake_condvar(klisp_State *K, TValue mutex);
+void klispV_free(klisp_State *K, Condvar *condvar);
+
+/* LOCK: these functions require that the calling code has
+ acquired the GIL exactly once previous to the call and
+ they may temporarily release it to avoid deadlocks */
+/* LOCK: underlying mutex should be acquired by this thread */
+/* GC: condvar should be rooted */
+void kcondvar_wait(klisp_State *K, TValue condvar);
+void kcondvar_signal(klisp_State *K, TValue condvar, bool broadcast);
+
+#define kcondvar_mutex(c_) (tv2condvar(c_)->mutex)
+#define kcondvar_cond(m_) (tv2condvar(m_)->cond)
+
+#endif
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -7,6 +7,8 @@
#include <stdarg.h>
#include "kcontinuation.h"
+#include "kpair.h"
+#include "kapplicative.h"
#include "kobject.h"
#include "kstate.h"
#include "kmem.h"
@@ -50,3 +52,198 @@ TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn,
kset_source_info(K, res, kget_csi(K));
return res;
}
+
+/*
+**
+** Interception Handling
+**
+*/
+
+/* Helper for continuation->applicative */
+/* this passes the operand tree to the continuation */
+void cont_app(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(denv);
+ TValue cont = xparams[0];
+ /* guards and dynamic variables are handled in kcall_cont() */
+ kcall_cont(K, cont, ptree);
+}
+
+/*
+** This is used to determine if cont is in the dynamic extent of
+** some other continuation. That's the case iff that continuation
+** was marked by the call to mark_iancestors(cont)
+*/
+
+/* TODO: maybe add some inlines here, profile first and check size difference */
+/* LOCK: GIL should be acquired */
+static void mark_iancestors(TValue cont)
+{
+ while(!ttisnil(cont)) {
+ kmark(cont);
+ cont = tv2cont(cont)->parent;
+ }
+}
+
+/* LOCK: GIL should be acquired */
+static void unmark_iancestors(TValue cont)
+{
+ while(!ttisnil(cont)) {
+ kunmark(cont);
+ cont = tv2cont(cont)->parent;
+ }
+}
+
+/*
+** Returns the first interceptor whose dynamic extent includes cont
+** or nil if there isn't any. The cont is implicitly passed because
+** all of its improper ancestors are marked.
+*/
+/* LOCK: GIL should be acquired */
+static TValue select_interceptor(TValue guard_ls)
+{
+ /* the guard list can't be cyclic, that case is
+ replaced by a simple list while copyng guards */
+ while(!ttisnil(guard_ls)) {
+ /* entry is (selector . interceptor-op) */
+ TValue entry = kcar(guard_ls);
+ TValue selector = kcar(entry);
+ if (kis_marked(selector))
+ return kcdr(entry); /* only interceptor is important */
+ guard_ls = kcdr(guard_ls);
+ }
+ return KNIL;
+}
+
+/*
+** Returns a list of entries like the following:
+** (interceptor-op outer_cont . denv)
+*/
+
+/* GC: assume src_cont & dst_cont are rooted */
+TValue create_interception_list(klisp_State *K, TValue src_cont,
+ TValue dst_cont)
+{
+ mark_iancestors(dst_cont);
+ TValue ilist = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &ilist);
+ TValue tail = ilist;
+ TValue cont = src_cont;
+
+ /* exit guards are from the inside to the outside, and
+ selected by destination */
+
+ /* the loop is until we find the common ancestor, that has to be marked */
+ while(!kis_marked(cont)) {
+ /* only inner conts have exit guards */
+ if (kis_inner_cont(cont)) {
+ klisp_assert(tv2cont(cont)->extra_size > 1);
+ TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
+
+ TValue interceptor = select_interceptor(entries);
+ if (!ttisnil(interceptor)) {
+ /* TODO make macros */
+ TValue denv = tv2cont(cont)->extra[1];
+ TValue outer = tv2cont(cont)->parent;
+ TValue outer_denv = kcons(K, outer, denv);
+ krooted_tvs_push(K, outer_denv);
+ TValue new_entry = kcons(K, interceptor, outer_denv);
+ krooted_tvs_pop(K); /* already in entry */
+ krooted_tvs_push(K, new_entry);
+ TValue new_pair = kcons(K, new_entry, KNIL);
+ krooted_tvs_pop(K);
+ kset_cdr(tail, new_pair);
+ tail = new_pair;
+ }
+ }
+ cont = tv2cont(cont)->parent;
+ }
+ unmark_iancestors(dst_cont);
+
+ /* entry guards are from the outside to the inside, and
+ selected by source, we create the list from the outside
+ by cons and then append it to the exit list to avoid
+ reversing */
+ mark_iancestors(src_cont);
+
+ cont = dst_cont;
+ TValue entry_int = KNIL;
+ krooted_vars_push(K, &entry_int);
+
+ while(!kis_marked(cont)) {
+ /* only outer conts have entry guards */
+ if (kis_outer_cont(cont)) {
+ klisp_assert(tv2cont(cont)->extra_size > 1);
+ TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
+ /* this is rooted because it's a substructure of entries */
+ TValue interceptor = select_interceptor(entries);
+ if (!ttisnil(interceptor)) {
+ /* TODO make macros */
+ TValue denv = tv2cont(cont)->extra[1];
+ TValue outer = cont;
+ TValue outer_denv = kcons(K, outer, denv);
+ krooted_tvs_push(K, outer_denv);
+ TValue new_entry = kcons(K, interceptor, outer_denv);
+ krooted_tvs_pop(K); /* already in entry */
+ krooted_tvs_push(K, new_entry);
+ entry_int = kcons(K, new_entry, entry_int);
+ krooted_tvs_pop(K);
+ }
+ }
+ cont = tv2cont(cont)->parent;
+ }
+
+ unmark_iancestors(src_cont);
+
+ /* all interceptions collected, append the two lists and return */
+ kset_cdr(tail, entry_int);
+
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return kcdr(ilist);
+}
+
+void do_interception(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]:
+ ** xparams[1]: dst cont
+ */
+ TValue ls = xparams[0];
+ TValue dst_cont = xparams[1];
+ if (ttisnil(ls)) {
+ /* all interceptors returned normally */
+ /* this is a normal pass/not subject to interception */
+ kset_cc(K, dst_cont);
+ kapply_cc(K, obj);
+ } else {
+ /* call the operative with the passed obj and applicative
+ for outer cont as ptree in the dynamic environment of
+ the corresponding call to guard-continuation in the
+ dynamic extent of the associated outer continuation.
+ If the operative normally returns a value, others
+ interceptions should be scheduled */
+ TValue first = kcar(ls);
+ TValue op = kcar(first);
+ TValue outer = kcadr(first);
+ TValue denv = kcddr(first);
+ TValue app = kmake_applicative(K, cont_app, 1, outer);
+ krooted_tvs_push(K, app);
+ TValue ptree = klist(K, 2, obj, app);
+ krooted_tvs_pop(K); /* already in ptree */
+ krooted_tvs_push(K, ptree);
+ TValue new_cont = kmake_continuation(K, outer, do_interception,
+ 2, kcdr(ls), dst_cont);
+ kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
+ /* XXX: what to pass as si? */
+ ktail_call(K, op, ptree, denv);
+ }
+}
diff --git a/src/kcontinuation.h b/src/kcontinuation.h
@@ -14,4 +14,10 @@
TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn,
int xcount, ...);
+/* Interceptions */
+void cont_app(klisp_State *K);
+TValue create_interception_list(klisp_State *K, TValue src_cont,
+ TValue dst_cont);
+void do_interception(klisp_State *K);
+
#endif
diff --git a/src/kencapsulation.h b/src/kencapsulation.h
@@ -16,6 +16,7 @@ TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val);
TValue kmake_encapsulation_key(klisp_State *K);
bool kis_encapsulation_type(TValue enc, TValue key);
+/* LOCK: these are immutable, so they don't need locking */
#define kget_enc_val(e_)(tv2enc(e_)->value)
#define kget_enc_key(e_)(tv2enc(e_)->key)
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -45,6 +45,8 @@ TValue kmake_environment(klisp_State *K, TValue parents)
new_env->keyed_parents = KNIL;
new_env->keyed_node = KNIL;
+ /* keep the lock, to avoid problems if the list of parents is mutated */
+
/* Contruct the list of keyed parents */
/* MAYBE: this could be optimized to avoid repetition of parents */
TValue kparents;
@@ -93,6 +95,8 @@ TValue kmake_environment(klisp_State *K, TValue parents)
** Only for list environments, table environments are handled elsewhere
** returns KNIL or a pair with sym as car.
*/
+
+/* LOCK: GIL should be acquired */
TValue kfind_local_binding(klisp_State *K, TValue bindings, TValue sym)
{
UNUSED(K);
@@ -124,7 +128,7 @@ void ktry_set_name(klisp_State *K, TValue obj, TValue sym)
name to other objs, like applicatives to operatives &
some applicatives to objects */
gcvalue(obj)->gch.kflags |= K_FLAG_HAS_NAME;
- TValue *node = klispH_set(K, tv2table(K->name_table), obj);
+ TValue *node = klispH_set(K, tv2table(G(K)->name_table), obj);
*node = sym;
/* TEMP: use this until we have a general mechanism to add
@@ -134,7 +138,7 @@ void ktry_set_name(klisp_State *K, TValue obj, TValue sym)
TValue underlying = kunwrap(obj);
while (kcan_have_name(underlying) && !khas_name(underlying)) {
gcvalue(underlying)->gch.kflags |= K_FLAG_HAS_NAME;
- node = klispH_set(K, tv2table(K->name_table), underlying);
+ node = klispH_set(K, tv2table(G(K)->name_table), underlying);
*node = sym;
if (ttisapplicative(underlying))
underlying = kunwrap(underlying);
@@ -148,7 +152,8 @@ void ktry_set_name(klisp_State *K, TValue obj, TValue sym)
/* Assumes obj has a name */
TValue kget_name(klisp_State *K, TValue obj)
{
- const TValue *node = klispH_get(tv2table(K->name_table),
+ /* LOCK: klispH_get will acquire the GIL */
+ const TValue *node = klispH_get(tv2table(G(K)->name_table),
obj);
klisp_assert(node != &kfree);
return *node;
@@ -165,6 +170,8 @@ void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
ktry_set_name(K, val, sym);
#endif
+ /* lock early because it is possible that even the environment
+ type changes (from list to table) */
TValue bindings = kenv_bindings(K, env);
if (ttistable(bindings)) {
TValue *cell = klispH_setsym(K, tv2table(bindings), tv2sym(sym));
@@ -228,6 +235,7 @@ static inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
}
*value = KINERT;
+
return false;
}
@@ -272,6 +280,7 @@ static inline bool try_get_keyed(klisp_State *K, TValue env, TValue key,
/* MAYBE: this could be optimized to mark environments to avoid
repetition */
/* assume the stack may be in use, keep track of pushed objs */
+
int pushed = 1;
if (!env_is_keyed(env))
env = env_keyed_parents(env);
diff --git a/src/kerror.c b/src/kerror.c
@@ -28,7 +28,6 @@ TValue klispE_new(klisp_State *K, TValue who, TValue cont, TValue msg,
new_error->cont = cont;
new_error->msg = msg;
new_error->irritants = irritants;
-
return gc2error(new_error);
}
@@ -47,6 +46,8 @@ TValue klispE_new_with_errno_irritants(klisp_State *K, const char *service,
return error_obj;
}
+/* This is meant to be called by the GC */
+/* LOCK: GIL should be acquired */
void klispE_free(klisp_State *K, Error *error)
{
klispM_free(K, error);
@@ -87,7 +88,7 @@ void klispE_throw_simple(klisp_State *K, char *msg)
krooted_tvs_push(K, error_obj);
clear_buffers(K); /* this pops both error_msg & error_obj */
/* call_cont protects error from gc */
- kcall_cont(K, K->error_cont, error_obj);
+ kcall_cont(K, G(K)->error_cont, error_obj);
}
/*
@@ -112,7 +113,7 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants)
krooted_tvs_push(K, error_obj);
clear_buffers(K); /* this pops both error_msg & error_obj */
/* call_cont protects error from gc */
- kcall_cont(K, K->error_cont, error_obj);
+ kcall_cont(K, G(K)->error_cont, error_obj);
}
void klispE_throw_system_error_with_irritants(
@@ -122,7 +123,7 @@ void klispE_throw_system_error_with_irritants(
irritants);
krooted_tvs_push(K, error_obj);
clear_buffers(K);
- kcall_cont(K, K->system_error_cont, error_obj);
+ kcall_cont(K, G(K)->system_error_cont, error_obj);
}
/* The array symbolic_error_codes[] assigns locale and target
diff --git a/src/keval.c b/src/keval.c
@@ -51,8 +51,8 @@ void do_eval_ls(klisp_State *K)
needed (the list was reversed during evaluation, so it should
be reversed first) */
TValue res =
- reverse_copy_and_encycle(K, acc, ivalue(tv_apairs) +
- ivalue(tv_cpairs), ivalue(tv_cpairs));
+ reverse_copy_and_encycle(K, acc, ivalue(tv_apairs) +
+ ivalue(tv_cpairs), ivalue(tv_cpairs));
krooted_tvs_pop(K); /* pop acc */
kapply_cc(K, res);
} else {
@@ -91,7 +91,7 @@ void do_combine_operands(klisp_State *K)
comb = tv2app(comb)->underlying;
ktail_call_si(K, comb, operands, env, si);
} else if (ttispair(operands)) {
- int32_t pairs, apairs, cpairs;
+ int32_t pairs, apairs, cpairs;
TValue comb_cont =
kmake_continuation(K, kget_cc(K), do_combine_operator,
3, tv2app(comb)->underlying, env, si);
@@ -103,7 +103,7 @@ void do_combine_operands(klisp_State *K)
argument evaluation with no additional overhead */
TValue arg_ls = check_copy_list(K, operands, false,
&pairs, &cpairs);
- apairs = pairs - cpairs;
+ apairs = pairs - cpairs;
krooted_tvs_push(K, arg_ls);
TValue els_cont =
kmake_continuation(K, comb_cont, do_eval_ls, 6, kcdr(arg_ls),
@@ -173,26 +173,30 @@ void keval_ofn(klisp_State *K)
switch(ttype(obj)) {
case K_TPAIR: {
+ TValue operator = kcar(obj);
+ TValue operands = kcdr(obj);
TValue new_cont =
kmake_continuation(K, kget_cc(K), do_combine_operands, 3,
- kcdr(obj), denv, ktry_get_si(K, obj));
+ operands, denv, ktry_get_si(K, obj));
kset_cc(K, new_cont);
- ktail_eval(K, kcar(obj), denv);
+ ktail_eval(K, operator, denv);
break;
}
- case K_TSYMBOL:
- /* error handling happens in kget_binding */
- kapply_cc(K, kget_binding(K, denv, obj));
+ case K_TSYMBOL: {
+ TValue res = kget_binding(K, denv, obj);
+ kapply_cc(K, res);
break;
+ }
default:
kapply_cc(K, obj);
}
}
/* init continuation names */
+/* LOCK: this is done before allowing multiple threads */
void kinit_eval_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_eval_ls, "eval-argument-list");
add_cont_name(K, t, do_combine_operator, "eval-combine-operator");
add_cont_name(K, t, do_combine_operands, "eval-combine-operands");
diff --git a/src/kgbooleans.c b/src/kgbooleans.c
@@ -194,7 +194,7 @@ void Sandp_Sorp(klisp_State *K)
/* init ground */
void kinit_booleans_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.1.1 boolean? */
@@ -212,9 +212,10 @@ void kinit_booleans_ground_env(klisp_State *K)
add_operative(K, ground_env, "$or?", Sandp_Sorp, 2, symbol, KTRUE);
}
+/* XXX lock? */
/* init continuation names */
void kinit_booleans_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_Sandp_Sorp, "eval-booleans");
}
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -200,7 +200,7 @@ void bytevector_copy(klisp_State *K)
TValue new_bytevector;
/* the if isn't strictly necessary but it's clearer this way */
- if (tv_equal(bytevector, K->empty_bytevector)) {
+ if (tv_equal(bytevector, G(K)->empty_bytevector)) {
new_bytevector = bytevector;
} else {
new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector),
@@ -230,7 +230,7 @@ void bytevector_copyB(klisp_State *K)
}
if (!tv_equal(bytevector1, bytevector2) &&
- !tv_equal(bytevector1, K->empty_bytevector)) {
+ !tv_equal(bytevector1, G(K)->empty_bytevector)) {
memcpy(kbytevector_buf(bytevector2),
kbytevector_buf(bytevector1),
kbytevector_size(bytevector1));
@@ -279,7 +279,7 @@ void bytevector_copy_partial(klisp_State *K)
TValue new_bytevector;
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
- new_bytevector = K->empty_bytevector;
+ new_bytevector = G(K)->empty_bytevector;
} else {
new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector)
+ start, size);
@@ -409,7 +409,7 @@ void bytevector_to_immutable_bytevector(klisp_State *K)
/* init ground */
void kinit_bytevectors_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/*
diff --git a/src/kgc.c b/src/kgc.c
@@ -9,6 +9,11 @@
** Parts that don't apply, or don't apply yet to klisp are in comments.
*/
+/*
+** LOCK: no locks are explicitly acquired here.
+** Whoever calls the GC needs to have already acquired the GIL.
+*/
+
#include <string.h>
#include "kgc.h"
@@ -22,6 +27,8 @@
#include "kstring.h"
#include "kbytevector.h"
#include "kvector.h"
+#include "kmutex.h"
+#include "kcondvar.h"
#include "kerror.h"
#define GCSTEPSIZE 1024u
@@ -45,19 +52,19 @@
/* klisp: NOT USED YET */
#define isfinalized(u) testbit((u)->gct, FINALIZEDBIT)
-#define markfinalized(u) l_setbit((u)->gct, FINALIZEDBIT)
+#define markfinalized(u) k_setbit((u)->gct, FINALIZEDBIT)
/* klisp: NOT USED YET */
#define KEYWEAK bitmask(KEYWEAKBIT)
#define VALUEWEAK bitmask(VALUEWEAKBIT)
/* this one is klisp specific */
-#define markvaluearray(k, a, s) ({ \
+#define markvaluearray(g, a, s) ({ \
TValue *array_ = (a); \
int32_t size_ = (s); \
for(int32_t i_ = 0; i_ < size_; i_++, array_++) { \
TValue mva_obj_ = *array_; \
- markvalue(k, mva_obj_); \
+ markvalue(g, mva_obj_); \
}})
#define markvalue(k,o) { checkconsistency(o); \
@@ -76,9 +83,9 @@ static void removeentry (Node *n) {
gkey(n)->this = gc2deadkey(gcvalue(gkey(n)->this));
}
-static void reallymarkobject (klisp_State *K, GCObject *o)
+static void reallymarkobject (global_State *g, GCObject *o)
{
- klisp_assert(iswhite(o) && !isdead(K, o));
+ klisp_assert(iswhite(o) && !isdead(g, o));
white2gray(o);
/* klisp: most of klisp have the same structure, but conserve the switch
just in case. */
@@ -115,8 +122,11 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
case K_TFPORT:
case K_TMPORT:
case K_TLIBRARY:
- o->gch.gclist = K->gray;
- K->gray = o;
+ case K_TTHREAD:
+ case K_TMUTEX:
+ case K_TCONDVAR:
+ o->gch.gclist = g->gray;
+ g->gray = o;
break;
default:
/* shouldn't happen */
@@ -172,7 +182,7 @@ size_t klispC_separateudata (lua_State *L, int all) {
#endif
-static int32_t traversetable (klisp_State *K, Table *h) {
+static int32_t traversetable (global_State *g, Table *h) {
int32_t i;
TValue tv = gc2table(h);
int32_t weakkey = ktable_has_weak_keys(tv)? 1 : 0;
@@ -182,14 +192,14 @@ static int32_t traversetable (klisp_State *K, Table *h) {
h->gct &= ~(KEYWEAK | VALUEWEAK); /* clear bits */
h->gct |= cast(uint16_t, (weakkey << KEYWEAKBIT) |
(weakvalue << VALUEWEAKBIT));
- h->gclist = K->weak; /* must be cleared after GC, ... */
- K->weak = obj2gco(h); /* ... so put in the appropriate list */
+ h->gclist = g->weak; /* must be cleared after GC, ... */
+ g->weak = obj2gco(h); /* ... so put in the appropriate list */
}
if (weakkey && weakvalue) return 1;
if (!weakvalue) {
i = h->sizearray;
while (i--)
- markvalue(K, h->array[i]);
+ markvalue(g, h->array[i]);
}
i = sizenode(h);
while (i--) {
@@ -200,8 +210,8 @@ static int32_t traversetable (klisp_State *K, Table *h) {
removeentry(n); /* remove empty entries */
else {
klisp_assert(!ttisfree(gkey(n)->this));
- if (!weakkey) markvalue(K, gkey(n)->this);
- if (!weakvalue) markvalue(K, gval(n));
+ if (!weakkey) markvalue(g, gkey(n)->this);
+ if (!weakvalue) markvalue(g, gval(n));
}
}
return weakkey || weakvalue;
@@ -237,14 +247,14 @@ static void traverseproto (global_State *g, Proto *f) {
** traverse one gray object, turning it to black.
** Returns `quantity' traversed.
*/
-static int32_t propagatemark (klisp_State *K) {
- GCObject *o = K->gray;
- K->gray = o->gch.gclist;
+static int32_t propagatemark (global_State *g) {
+ GCObject *o = g->gray;
+ g->gray = o->gch.gclist;
klisp_assert(isgray(o));
gray2black(o);
/* all types have si pointers */
if (o->gch.si != NULL) {
- markobject(K, o->gch.si);
+ markobject(g, o->gch.si);
}
uint8_t type = o->gch.tt;
@@ -253,107 +263,144 @@ static int32_t propagatemark (klisp_State *K) {
case K_TBIGINT: bigints & bigrats are never gray */
case K_TPAIR: {
Pair *p = cast(Pair *, o);
- markvalue(K, p->mark);
- markvalue(K, p->car);
- markvalue(K, p->cdr);
+ markvalue(g, p->mark);
+ markvalue(g, p->car);
+ markvalue(g, p->cdr);
return sizeof(Pair);
}
case K_TSYMBOL: {
Symbol *s = cast(Symbol *, o);
- markvalue(K, s->str);
+ markvalue(g, s->str);
return sizeof(Symbol);
}
case K_TKEYWORD: {
Keyword *k = cast(Keyword *, o);
- markvalue(K, k->str);
+ markvalue(g, k->str);
return sizeof(Keyword);
}
case K_TSTRING: {
String *s = cast(String *, o);
- markvalue(K, s->mark);
+ markvalue(g, s->mark);
return sizeof(String) + (s->size + 1 * sizeof(char));
}
case K_TENVIRONMENT: {
Environment *e = cast(Environment *, o);
- markvalue(K, e->mark);
- markvalue(K, e->parents);
- markvalue(K, e->bindings);
- markvalue(K, e->keyed_node);
- markvalue(K, e->keyed_parents);
+ markvalue(g, e->mark);
+ markvalue(g, e->parents);
+ markvalue(g, e->bindings);
+ markvalue(g, e->keyed_node);
+ markvalue(g, e->keyed_parents);
return sizeof(Environment);
}
case K_TCONTINUATION: {
Continuation *c = cast(Continuation *, o);
- markvalue(K, c->mark);
- markvalue(K, c->parent);
- markvalue(K, c->comb);
- markvaluearray(K, c->extra, c->extra_size);
+ markvalue(g, c->mark);
+ markvalue(g, c->parent);
+ markvalue(g, c->comb);
+ markvaluearray(g, c->extra, c->extra_size);
return sizeof(Continuation) + sizeof(TValue) * c->extra_size;
}
case K_TOPERATIVE: {
Operative *op = cast(Operative *, o);
- markvaluearray(K, op->extra, op->extra_size);
+ markvaluearray(g, op->extra, op->extra_size);
return sizeof(Operative) + sizeof(TValue) * op->extra_size;
}
case K_TAPPLICATIVE: {
Applicative *a = cast(Applicative *, o);
- markvalue(K, a->underlying);
+ markvalue(g, a->underlying);
return sizeof(Applicative);
}
case K_TENCAPSULATION: {
Encapsulation *e = cast(Encapsulation *, o);
- markvalue(K, e->key);
- markvalue(K, e->value);
+ markvalue(g, e->key);
+ markvalue(g, e->value);
return sizeof(Encapsulation);
}
case K_TPROMISE: {
Promise *p = cast(Promise *, o);
- markvalue(K, p->node);
+ markvalue(g, p->node);
return sizeof(Promise);
}
case K_TTABLE: {
Table *h = cast(Table *, o);
- if (traversetable(K, h)) /* table is weak? */
+ if (traversetable(g, h)) /* table is weak? */
black2gray(o); /* keep it gray */
return sizeof(Table) + sizeof(TValue) * h->sizearray +
sizeof(Node) * sizenode(h);
}
case K_TERROR: {
Error *e = cast(Error *, o);
- markvalue(K, e->who);
- markvalue(K, e->cont);
- markvalue(K, e->msg);
- markvalue(K, e->irritants);
+ markvalue(g, e->who);
+ markvalue(g, e->cont);
+ markvalue(g, e->msg);
+ markvalue(g, e->irritants);
return sizeof(Error);
}
case K_TBYTEVECTOR: {
Bytevector *b = cast(Bytevector *, o);
- markvalue(K, b->mark);
+ markvalue(g, b->mark);
return sizeof(Bytevector) + b->size * sizeof(uint8_t);
}
case K_TFPORT: {
FPort *p = cast(FPort *, o);
- markvalue(K, p->filename);
+ markvalue(g, p->filename);
return sizeof(FPort);
}
case K_TMPORT: {
MPort *p = cast(MPort *, o);
- markvalue(K, p->filename);
- markvalue(K, p->buf);
+ markvalue(g, p->filename);
+ markvalue(g, p->buf);
return sizeof(MPort);
}
case K_TVECTOR: {
Vector *v = cast(Vector *, o);
- markvalue(K, v->mark);
- markvaluearray(K, v->array, v->sizearray);
+ markvalue(g, v->mark);
+ markvaluearray(g, v->array, v->sizearray);
return sizeof(Vector) + v->sizearray * sizeof(TValue);
}
case K_TLIBRARY: {
Library *l = cast(Library *, o);
- markvalue(K, l->env);
- markvalue(K, l->exp_list);
+ markvalue(g, l->env);
+ markvalue(g, l->exp_list);
return sizeof(Library);
}
+ case K_TTHREAD: {
+ klisp_State *K = cast(klisp_State *, o);
+
+ markvalue(g, K->curr_cont);
+ markvalue(g, K->next_obj);
+ markvalue(g, K->next_value);
+ markvalue(g, K->next_env);
+ markvalue(g, K->next_si);
+ /* NOTE: next_x_params is protected by next_obj */
+
+ markvalue(g, K->shared_dict);
+ markvalue(g, K->curr_port);
+
+ /* Mark all objects in the auxiliary stack,
+ (all valid indexes are below top) and all the objects in
+ the two protected areas */
+ markvaluearray(g, K->sbuf, K->stop);
+ markvaluearray(g, K->rooted_tvs_buf, K->rooted_tvs_top);
+ /* the area protecting variables is an array of type TValue *[] */
+ TValue **ptr = K->rooted_vars_buf;
+ for (int i = 0, top = K->rooted_vars_top; i < top; i++, ptr++) {
+ markvalue(g, **ptr);
+ }
+ return sizeof(klisp_State) + (sizeof(TValue) * K->stop);
+ }
+ case K_TMUTEX: {
+ Mutex *m = cast(Mutex *, o);
+
+ markvalue(g, m->owner);
+ return sizeof(Mutex);
+ }
+ case K_TCONDVAR: {
+ Condvar *c = cast(Condvar *, o);
+
+ markvalue(g, c->mutex);
+ return sizeof(Condvar);
+ }
default:
fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
type);
@@ -362,9 +409,9 @@ static int32_t propagatemark (klisp_State *K) {
}
-static size_t propagateall (klisp_State *K) {
+static size_t propagateall (global_State *g) {
size_t m = 0;
- while (K->gray) m += propagatemark(K);
+ while (g->gray) m += propagatemark(g);
return m;
}
@@ -442,19 +489,19 @@ static void freeobj (klisp_State *K, GCObject *o) {
/* The string will be freed before/after */
/* symbols with no source info are in the string/symbol table */
if (ttisnil(ktry_get_si(K, gc2sym(o))))
- K->strt.nuse--;
+ G(K)->strt.nuse--;
klispM_free(K, (Symbol *)o);
break;
case K_TKEYWORD:
/* keywords are in the string table */
/* The string will be freed before/after */
- K->strt.nuse--;
+ G(K)->strt.nuse--;
klispM_free(K, (Keyword *)o);
break;
case K_TSTRING:
/* immutable strings are in the string/symbol table */
if (kstring_immutablep(gc2str(o)))
- K->strt.nuse--;
+ G(K)->strt.nuse--;
klispM_freemem(K, o, sizeof(String)+o->str.size+1);
break;
case K_TENVIRONMENT:
@@ -486,7 +533,7 @@ static void freeobj (klisp_State *K, GCObject *o) {
case K_TBYTEVECTOR:
/* immutable bytevectors are in the string/symbol table */
if (kbytevector_immutablep(gc2str(o)))
- K->strt.nuse--;
+ G(K)->strt.nuse--;
klispM_freemem(K, o, sizeof(Bytevector)+o->bytevector.size);
break;
case K_TFPORT:
@@ -509,6 +556,22 @@ static void freeobj (klisp_State *K, GCObject *o) {
case K_TLIBRARY:
klispM_free(K, (Library *)o);
break;
+ case K_TTHREAD: {
+ klisp_State *K2 = (klisp_State *) o;
+
+ klisp_assert(K2 != G(K)->mainthread);
+ klisp_assert(K2 != K);
+ /* threads are always created detached, so there's no
+ need to do a join here */
+ klispT_freethread(K, K2);
+ break;
+ }
+ case K_TMUTEX:
+ klispX_free(K, (Mutex *) o);
+ break;
+ case K_TCONDVAR:
+ klispV_free(K, (Condvar *) o);
+ break;
default:
/* shouldn't happen */
fprintf(stderr, "Unknown GCObject type (in GC free): %d\n",
@@ -525,17 +588,18 @@ static void freeobj (klisp_State *K, GCObject *o) {
static GCObject **sweeplist (klisp_State *K, GCObject **p, uint32_t count)
{
GCObject *curr;
- int deadmask = otherwhite(K);
+ global_State *g = G(K);
+ int deadmask = otherwhite(g);
while ((curr = *p) != NULL && count-- > 0) {
if ((curr->gch.gct ^ WHITEBITS) & deadmask) { /* not dead? */
- klisp_assert(!isdead(K, curr) || testbit(curr->gch.gct, FIXEDBIT));
- makewhite(K, curr); /* make it white (for next cycle) */
+ klisp_assert(!isdead(g, curr) || testbit(curr->gch.gct, FIXEDBIT));
+ makewhite(g, curr); /* make it white (for next cycle) */
p = &curr->gch.next;
} else { /* must erase `curr' */
- klisp_assert(isdead(K, curr) || deadmask == bitmask(SFIXEDBIT));
+ klisp_assert(isdead(g, curr) || deadmask == bitmask(SFIXEDBIT));
*p = curr->gch.next;
- if (curr == K->rootgc) /* is the first element of the list? */
- K->rootgc = curr->gch.next; /* adjust first */
+ if (curr == g->rootgc) /* is the first element of the list? */
+ g->rootgc = curr->gch.next; /* adjust first */
freeobj(K, curr);
}
}
@@ -543,10 +607,11 @@ static GCObject **sweeplist (klisp_State *K, GCObject **p, uint32_t count)
}
static void checkSizes (klisp_State *K) {
+ global_State *g = G(K);
/* check size of string/symbol hash */
- if (K->strt.nuse < cast(uint32_t , K->strt.size/4) &&
- K->strt.size > MINSTRTABSIZE*2)
- klispS_resize(K, K->strt.size/2); /* table is too big */
+ if (g->strt.nuse < cast(uint32_t , g->strt.size/4) &&
+ g->strt.size > MINSTRTABSIZE*2)
+ klispS_resize(K, g->strt.size/2); /* table is too big */
#if 0 /* not used in klisp */
/* check size of buffer */
if (luaZ_sizebuffer(&g->buff) > LUA_MINBUFFER*2) { /* buffer too big? */
@@ -598,90 +663,73 @@ void klispC_callGCTM (lua_State *L) {
/* This still leaves allocated objs in K, namely the
arrays that aren't TValues */
void klispC_freeall (klisp_State *K) {
+ global_State *g = G(K);
/* mask to collect all elements */
- K->currentwhite = WHITEBITS | bitmask(SFIXEDBIT); /* in klisp this may not be
- necessary */
- sweepwholelist(K, &K->rootgc);
+ g->currentwhite = WHITEBITS | bitmask(SFIXEDBIT);
+ sweepwholelist(K, &g->rootgc);
/* free all keyword/symbol/string/bytevectors lists */
- for (int32_t i = 0; i < K->strt.size; i++)
- sweepwholelist(K, &K->strt.hash[i]);
+ for (int32_t i = 0; i < g->strt.size; i++)
+ sweepwholelist(K, &g->strt.hash[i]);
}
-
/* mark root set */
static void markroot (klisp_State *K) {
- K->gray = NULL;
- K->grayagain = NULL;
- K->weak = NULL;
-
- /* TEMP: this is quite awful, think of other way to do this */
- /* MAYBE: some of these could be FIXED */
- markvalue(K, K->name_table);
- markvalue(K, K->cont_name_table);
- markvalue(K, K->curr_cont);
- markvalue(K, K->next_obj);
- markvalue(K, K->next_value);
- markvalue(K, K->next_env);
- markvalue(K, K->next_si);
- /* NOTE: next_x_params is protected by next_obj */
- markvalue(K, K->eval_op);
- markvalue(K, K->list_app);
- markvalue(K, K->memoize_app);
- markvalue(K, K->ground_env);
- markvalue(K, K->module_params_sym);
- markvalue(K, K->root_cont);
- markvalue(K, K->error_cont);
- markvalue(K, K->system_error_cont);
-
- markvalue(K, K->kd_in_port_key);
- markvalue(K, K->kd_out_port_key);
- markvalue(K, K->kd_error_port_key);
- markvalue(K, K->kd_strict_arith_key);
- markvalue(K, K->empty_string);
- markvalue(K, K->empty_bytevector);
- markvalue(K, K->empty_vector);
-
- markvalue(K, K->ktok_lparen);
- markvalue(K, K->ktok_rparen);
- markvalue(K, K->ktok_dot);
- markvalue(K, K->ktok_sexp_comment);
- markvalue(K, K->shared_dict);
-
- markvalue(K, K->curr_port);
-
- markvalue(K, K->require_path);
- markvalue(K, K->require_table);
-
- markvalue(K, K->libraries_registry);
-
- /* Mark all objects in the auxiliary stack,
- (all valid indexes are below top) and all the objects in
- the two protected areas */
- markvaluearray(K, K->sbuf, K->stop);
- markvaluearray(K, K->rooted_tvs_buf, K->rooted_tvs_top);
- /* the area protecting variables is an array of type TValue *[] */
- TValue **ptr = K->rooted_vars_buf;
- for (int i = 0, top = K->rooted_vars_top; i < top; i++, ptr++) {
- markvalue(K, **ptr);
- }
-
- K->gcstate = GCSpropagate;
+ global_State *g = G(K);
+ g->gray = NULL;
+ g->grayagain = NULL;
+ g->weak = NULL;
+
+ markobject(g, g->mainthread); /* this is also in the thread table */
+
+ markvalue(g, g->name_table);
+ markvalue(g, g->cont_name_table);
+ markvalue(g, g->thread_table);
+
+ markvalue(g, g->eval_op);
+ markvalue(g, g->list_app);
+ markvalue(g, g->memoize_app);
+ markvalue(g, g->ground_env);
+ markvalue(g, g->module_params_sym);
+ markvalue(g, g->root_cont);
+ markvalue(g, g->error_cont);
+ markvalue(g, g->system_error_cont);
+
+ markvalue(g, g->kd_in_port_key);
+ markvalue(g, g->kd_out_port_key);
+ markvalue(g, g->kd_error_port_key);
+ markvalue(g, g->kd_strict_arith_key);
+ markvalue(g, g->empty_string);
+ markvalue(g, g->empty_bytevector);
+ markvalue(g, g->empty_vector);
+
+ markvalue(g, g->ktok_lparen);
+ markvalue(g, g->ktok_rparen);
+ markvalue(g, g->ktok_dot);
+ markvalue(g, g->ktok_sexp_comment);
+
+ markvalue(g, g->require_path);
+ markvalue(g, g->require_table);
+
+ markvalue(g, g->libraries_registry);
+
+ g->gcstate = GCSpropagate;
}
static void atomic (klisp_State *K) {
+ global_State *g = G(K);
size_t udsize; /* total size of userdata to be finalized */
/* traverse objects caught by write barrier */
- propagateall(K);
+ propagateall(g);
/* remark weak tables */
- K->gray = K->weak;
- K->weak = NULL;
- propagateall(K);
+ g->gray = g->weak;
+ g->weak = NULL;
+ propagateall(g);
/* remark gray again */
- K->gray = K->grayagain;
- K->grayagain = NULL;
- propagateall(K);
+ g->gray = g->grayagain;
+ g->grayagain = NULL;
+ propagateall(g);
udsize = 0; /* to init var 'till we add user data */
#if 0 /* keep around */
@@ -689,49 +737,50 @@ static void atomic (klisp_State *K) {
marktmu(g); /* mark `preserved' userdata */
udsize += propagateall(g); /* remark, to propagate `preserveness' */
#endif
- cleartable(K->weak); /* remove collected objects from weak tables */
+ cleartable(g->weak); /* remove collected objects from weak tables */
/* flip current white */
- K->currentwhite = cast(uint16_t, otherwhite(K));
- K->sweepstrgc = 0;
- K->sweepgc = &K->rootgc;
- K->gcstate = GCSsweepstring;
- K->estimate = K->totalbytes - udsize; /* first estimate */
+ g->currentwhite = cast(uint16_t, otherwhite(g));
+ g->sweepstrgc = 0;
+ g->sweepgc = &g->rootgc;
+ g->gcstate = GCSsweepstring;
+ g->estimate = g->totalbytes - udsize; /* first estimate */
}
static int32_t singlestep (klisp_State *K) {
- switch (K->gcstate) {
+ global_State *g = G(K);
+ switch (g->gcstate) {
case GCSpause: {
markroot(K); /* start a new collection */
return 0;
}
case GCSpropagate: {
- if (K->gray)
- return propagatemark(K);
+ if (g->gray)
+ return propagatemark(g);
else { /* no more `gray' objects */
atomic(K); /* finish mark phase */
return 0;
}
}
case GCSsweepstring: {
- uint32_t old = K->totalbytes;
- sweepwholelist(K, &K->strt.hash[K->sweepstrgc++]);
- if (K->sweepstrgc >= K->strt.size) /* nothing more to sweep? */
- K->gcstate = GCSsweep; /* end sweep-string phase */
- klisp_assert(old >= K->totalbytes);
- K->estimate -= old - K->totalbytes;
+ uint32_t old = g->totalbytes;
+ sweepwholelist(K, &g->strt.hash[g->sweepstrgc++]);
+ if (g->sweepstrgc >= g->strt.size) /* nothing more to sweep? */
+ g->gcstate = GCSsweep; /* end sweep-string phase */
+ klisp_assert(old >= g->totalbytes);
+ g->estimate -= old - g->totalbytes;
return GCSWEEPCOST;
}
case GCSsweep: {
- uint32_t old = K->totalbytes;
- K->sweepgc = sweeplist(K, K->sweepgc, GCSWEEPMAX);
- if (*K->sweepgc == NULL) { /* nothing more to sweep? */
+ uint32_t old = g->totalbytes;
+ g->sweepgc = sweeplist(K, g->sweepgc, GCSWEEPMAX);
+ if (*g->sweepgc == NULL) { /* nothing more to sweep? */
checkSizes(K);
- K->gcstate = GCSfinalize; /* end sweep phase */
+ g->gcstate = GCSfinalize; /* end sweep phase */
}
- klisp_assert(old >= K->totalbytes);
- K->estimate -= old - K->totalbytes;
+ klisp_assert(old >= g->totalbytes);
+ g->estimate -= old - g->totalbytes;
return GCSWEEPMAX*GCSWEEPCOST;
}
case GCSfinalize: {
@@ -744,8 +793,8 @@ static int32_t singlestep (klisp_State *K) {
}
else {
#endif
- K->gcstate = GCSpause; /* end collection */
- K->gcdept = 0;
+ g->gcstate = GCSpause; /* end collection */
+ g->gcdept = 0;
return 0;
#if 0
}
@@ -757,55 +806,57 @@ static int32_t singlestep (klisp_State *K) {
void klispC_step (klisp_State *K) {
- int32_t lim = (GCSTEPSIZE/100) * K->gcstepmul;
+ global_State *g = G(K);
+ int32_t lim = (GCSTEPSIZE/100) * g->gcstepmul;
if (lim == 0)
lim = (UINT32_MAX-1)/2; /* no limit */
- K->gcdept += K->totalbytes - K->GCthreshold;
+ g->gcdept += g->totalbytes - g->GCthreshold;
do {
lim -= singlestep(K);
- if (K->gcstate == GCSpause)
+ if (g->gcstate == GCSpause)
break;
} while (lim > 0);
- if (K->gcstate != GCSpause) {
- if (K->gcdept < GCSTEPSIZE) {
- K->GCthreshold = K->totalbytes + GCSTEPSIZE;
+ if (g->gcstate != GCSpause) {
+ if (g->gcdept < GCSTEPSIZE) {
+ g->GCthreshold = g->totalbytes + GCSTEPSIZE;
/* - lim/g->gcstepmul;*/
} else {
- K->gcdept -= GCSTEPSIZE;
- K->GCthreshold = K->totalbytes;
+ g->gcdept -= GCSTEPSIZE;
+ g->GCthreshold = g->totalbytes;
}
} else {
- klisp_assert(K->totalbytes >= K->estimate);
- setthreshold(K);
+ klisp_assert(g->totalbytes >= g->estimate);
+ setthreshold(g);
}
}
void klispC_fullgc (klisp_State *K) {
- if (K->gcstate <= GCSpropagate) {
+ global_State *g = G(K);
+ if (g->gcstate <= GCSpropagate) {
/* reset sweep marks to sweep all elements (returning them to white) */
- K->sweepstrgc = 0;
- K->sweepgc = &K->rootgc;
+ g->sweepstrgc = 0;
+ g->sweepgc = &g->rootgc;
/* reset other collector lists */
- K->gray = NULL;
- K->grayagain = NULL;
- K->weak = NULL;
- K->gcstate = GCSsweepstring;
+ g->gray = NULL;
+ g->grayagain = NULL;
+ g->weak = NULL;
+ g->gcstate = GCSsweepstring;
}
- klisp_assert(K->gcstate != GCSpause && K->gcstate != GCSpropagate);
+ klisp_assert(g->gcstate != GCSpause && g->gcstate != GCSpropagate);
/* finish any pending sweep phase */
- while (K->gcstate != GCSfinalize) {
- klisp_assert(K->gcstate == GCSsweepstring || K->gcstate == GCSsweep);
+ while (g->gcstate != GCSfinalize) {
+ klisp_assert(g->gcstate == GCSsweepstring || g->gcstate == GCSsweep);
singlestep(K);
}
markroot(K);
- while (K->gcstate != GCSpause) {
+ while (g->gcstate != GCSpause) {
singlestep(K);
}
- setthreshold(K);
+ setthreshold(g);
}
/* TODO: make all code using mutation to call these,
@@ -815,32 +866,35 @@ void klispC_fullgc (klisp_State *K) {
made before assigning to a GC guarded variable, or pushed in a GC
guarded stack! */
void klispC_barrierf (klisp_State *K, GCObject *o, GCObject *v) {
- klisp_assert(isblack(o) && iswhite(v) && !isdead(K, v) && !isdead(K, o));
- klisp_assert(K->gcstate != GCSfinalize && K->gcstate != GCSpause);
+ global_State *g = G(K);
+ klisp_assert(isblack(o) && iswhite(v) && !isdead(g, v) && !isdead(g, o));
+ klisp_assert(g->gcstate != GCSfinalize && g->gcstate != GCSpause);
klisp_assert(o->gch.tt != K_TTABLE);
/* must keep invariant? */
- if (K->gcstate == GCSpropagate)
- reallymarkobject(K, v); /* restore invariant */
+ if (g->gcstate == GCSpropagate)
+ reallymarkobject(g, v); /* restore invariant */
else /* don't mind */
- makewhite(K, o); /* mark as white just to avoid other barriers */
+ makewhite(g, o); /* mark as white just to avoid other barriers */
}
void klispC_barrierback (klisp_State *K, Table *t) {
+ global_State *g = G(K);
GCObject *o = obj2gco(t);
- klisp_assert(isblack(o) && !isdead(K, o));
- klisp_assert(K->gcstate != GCSfinalize && K->gcstate != GCSpause);
+ klisp_assert(isblack(o) && !isdead(g, o));
+ klisp_assert(g->gcstate != GCSfinalize && g->gcstate != GCSpause);
black2gray(o); /* make table gray (again) */
- t->gclist = K->grayagain;
- K->grayagain = o;
+ t->gclist = g->grayagain;
+ g->grayagain = o;
}
/* NOTE: kflags is added for klisp */
/* NOTE: symbols, keywords, immutable strings and immutable bytevectors do
this "by hand", they don't call this */
void klispC_link (klisp_State *K, GCObject *o, uint8_t tt, uint8_t kflags) {
- o->gch.next = K->rootgc;
- K->rootgc = o;
- o->gch.gct = klispC_white(K);
+ global_State *g = G(K);
+ o->gch.next = g->rootgc;
+ g->rootgc = o;
+ o->gch.gct = klispC_white(g);
o->gch.tt = tt;
o->gch.kflags = kflags;
o->gch.si = NULL;
diff --git a/src/kgc.h b/src/kgc.h
@@ -35,7 +35,7 @@
#define testbits(x,m) ((x) & (m))
#define bitmask(b) (1<<(b))
#define bit2mask(b1,b2) (bitmask(b1) | bitmask(b2))
-#define l_setbit(x,b) setbits(x, bitmask(b))
+#define k_setbit(x,b) setbits(x, bitmask(b))
#define resetbit(x,b) resetbits(x, bitmask(b))
#define testbit(x,b) testbits(x, bitmask(b))
#define set2bits(x,b1,b2) setbits(x, (bit2mask(b1, b2)))
@@ -71,22 +71,21 @@
#define iswhite(x) test2bits((x)->gch.gct, WHITE0BIT, WHITE1BIT)
#define isblack(x) testbit((x)->gch.gct, BLACKBIT)
-
#define isgray(x) (!isblack(x) && !iswhite(x))
-#define otherwhite(K) (K->currentwhite ^ WHITEBITS)
-#define isdead(K,v) ((v)->gch.gct & otherwhite(K) & WHITEBITS)
+#define otherwhite(g) (g->currentwhite ^ WHITEBITS)
+#define isdead(g,v) ((v)->gch.gct & otherwhite(g) & WHITEBITS)
#define changewhite(x) ((x)->gch.gct ^= WHITEBITS)
-#define gray2black(x) l_setbit((x)->gch.gct, BLACKBIT)
+#define gray2black(x) k_setbit((x)->gch.gct, BLACKBIT)
#define valiswhite(x) (iscollectable(x) && iswhite(gcvalue(x)))
-#define klispC_white(K) cast(uint16_t, (K)->currentwhite & WHITEBITS)
+#define klispC_white(g) cast(uint16_t, (g)->currentwhite & WHITEBITS)
#define klispC_checkGC(K) { \
- if (K->totalbytes >= K->GCthreshold) \
+ if (G(K)->totalbytes >= G(K)->GCthreshold) \
klispC_step(K); }
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -186,7 +186,7 @@ void digit_to_char(klisp_State *K)
/* init ground */
void kinit_chars_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/*
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -585,7 +585,7 @@ void array_map(klisp_State *K)
/* init ground */
void kinit_combiners_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.10.1 operative? */
@@ -619,10 +619,11 @@ void kinit_combiners_ground_env(klisp_State *K)
p2tv(kcombinerp));
}
+/* XXX lock? */
/* init continuation names */
void kinit_combiners_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_vau, "$vau-bind!-eval");
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -124,7 +124,6 @@ void guard_continuation(klisp_State *K)
kapply_cc(K, inner_cont);
}
-
/* 7.2.5 continuation->applicative */
void continuation_applicative(klisp_State *K)
{
@@ -138,17 +137,42 @@ void continuation_applicative(klisp_State *K)
bind_1tp(K, ptree, "continuation",
ttiscontinuation, cont);
- /* cont_app is from kstate, it handles dynamic vars &
- interceptions */
TValue app = kmake_applicative(K, cont_app, 1, cont);
kapply_cc(K, app);
}
/* 7.2.6 root-continuation */
-/* done in kground.c/krepl.c */
+static void do_root_exit(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ UNUSED(xparams);
+
+ /* TODO/REFACTOR move this to a end_loop function in kstate.c */
+ /* Just save the value and end the loop */
+ K->next_value = obj;
+ K->next_func = NULL; /* force the loop to terminate */
+ return;
+}
+
+
+static void kinit_root_cont(klisp_State *K)
+{
+ klisp_assert(ttisinert(G(K)->root_cont));
+ G(K)->root_cont = kmake_continuation(K, KNIL, do_root_exit, 0);
+ TValue str, tail, si;
+#if KTRACK_SI
+ /* Add source info to the cont */
+ str = kstring_new_b_imm(K, __FILE__);
+ tail = kcons(K, i2tv(__LINE__), i2tv(0));
+ si = kcons(K, str, tail);
+ kset_source_info(K, G(K)->root_cont, si);
+#endif
+}
/* 7.2.7 error-continuation */
-/* done in kground.c/krepl.c */
+/* done in kgerrors.c */
/*
** 7.3 Library features
@@ -234,15 +258,14 @@ void kgexit(klisp_State *K)
if (!get_opt_tpar(K, obj, "any", anytype))
obj = KINERT;
- /* TODO: look out for guards and dynamic variables */
- /* should be probably handled in kcall_cont() */
- kcall_cont(K, K->root_cont, obj);
+ /* guards and dynamic variables are handled in kcall_cont() */
+ kcall_cont(K, G(K)->root_cont, obj);
}
/* init ground */
void kinit_continuations_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 7.1.1 continuation? */
@@ -260,13 +283,12 @@ void kinit_continuations_ground_env(klisp_State *K)
add_applicative(K, ground_env, "continuation->applicative",
continuation_applicative, 0);
/* 7.2.6 root-continuation */
- klisp_assert(ttiscontinuation(K->root_cont));
- add_value(K, ground_env, "root-continuation",
- K->root_cont);
+ kinit_root_cont(K);
+ add_value(K, ground_env, "root-continuation", G(K)->root_cont);
+
/* 7.2.7 error-continuation */
- klisp_assert(ttiscontinuation(K->error_cont));
- add_value(K, ground_env, "error-continuation",
- K->error_cont);
+ /* done in kgerrors.c */
+
/* 7.3.1 apply-continuation */
add_applicative(K, ground_env, "apply-continuation", apply_continuation,
0);
@@ -281,10 +303,14 @@ void kinit_continuations_ground_env(klisp_State *K)
0);
}
+/* XXX lock? */
/* init continuation names */
void kinit_continuations_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_extended_cont, "extended-cont");
+ add_cont_name(K, t, do_root_exit, "exit");
+ /* this is defined in kcontinuation.c */
+ add_cont_name(K, t, do_interception, "do-interception");
}
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -551,7 +551,7 @@ void Swhen_Sunless(klisp_State *K)
/* init ground */
void kinit_control_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.5.1 inert? */
@@ -579,10 +579,11 @@ void kinit_control_ground_env(klisp_State *K)
b2tv(false));
}
+/* XXX lock? */
/* init continuation names */
void kinit_control_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_select_clause, "select-clause");
add_cont_name(K, t, do_Swhen_Sunless, "conditional-eval-sequence");
diff --git a/src/kgencapsulations.c b/src/kgencapsulations.c
@@ -98,7 +98,7 @@ void make_encapsulation_type(klisp_State *K)
/* init ground */
void kinit_encapsulations_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 8.1.1 make-encapsulation-type */
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -212,7 +212,7 @@ void do_import(klisp_State *K)
kmake_continuation(K, kget_cc(K), do_match, 3,
symbols, denv, sname);
kset_cc(K, new_cont);
- ktail_eval(K, kcons(K, K->list_app, symbols), env);
+ ktail_eval(K, kcons(K, G(K)->list_app, symbols), env);
}
}
@@ -319,7 +319,7 @@ void SimportB(klisp_State *K)
/* init ground */
void kinit_env_mut_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.9.1 $define! */
@@ -332,10 +332,11 @@ void kinit_env_mut_ground_env(klisp_State *K)
add_operative(K, ground_env, "$import!", SimportB, 1, symbol);
}
+/* XXX lock? */
/* init continuation names */
void kinit_env_mut_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_match, "match-ptree");
add_cont_name(K, t, do_set_eval_obj, "set-eval-obj");
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -259,7 +259,7 @@ void Slet(klisp_State *K)
bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
- TValue expr = kcons(K, K->list_app, exprs);
+ TValue expr = kcons(K, G(K)->list_app, exprs);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -349,8 +349,8 @@ void make_kernel_standard_environment(klisp_State *K)
check_0p(K, ptree);
/* std environments have hashtable for bindings */
- TValue new_env = kmake_table_environment(K, K->ground_env);
-// TValue new_env = kmake_environment(K, K->ground_env);
+ TValue new_env = kmake_table_environment(K, G(K)->ground_env);
+// TValue new_env = kmake_environment(K, G(K)->ground_env);
kapply_cc(K, new_env);
}
@@ -385,7 +385,7 @@ void SletS(klisp_State *K)
bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
- TValue expr = kcons(K, K->list_app, exprs);
+ TValue expr = kcons(K, G(K)->list_app, exprs);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -436,7 +436,7 @@ void Sletrec(klisp_State *K)
bptree, KNIL, KNIL, new_env, b2tv(true), body);
kset_cc(K, new_cont);
- TValue expr = kcons(K, K->list_app, exprs);
+ TValue expr = kcons(K, G(K)->list_app, exprs);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -477,7 +477,7 @@ void SletrecS(klisp_State *K)
bptree, KNIL, KNIL, new_env, b2tv(true), body);
kset_cc(K, new_cont);
- TValue expr = kcons(K, K->list_app, exprs);
+ TValue expr = kcons(K, G(K)->list_app, exprs);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -555,7 +555,7 @@ void Slet_redirect(klisp_State *K)
body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
- TValue eexpr = kcons(K, K->list_app, exprs);
+ TValue eexpr = kcons(K, G(K)->list_app, exprs);
krooted_tvs_push(K, eexpr);
TValue new_cont =
@@ -597,14 +597,14 @@ void Slet_safe(klisp_State *K)
/* according to the definition of the report it should be a child
of a child of the ground environment, but since this is a fresh
environment, the semantics are the same */
- TValue new_env = kmake_environment(K, K->ground_env);
+ TValue new_env = kmake_environment(K, G(K)->ground_env);
krooted_tvs_push(K, new_env);
TValue new_cont =
kmake_continuation(K, kget_cc(K), do_let, 7, sname,
bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
- TValue expr = kcons(K, K->list_app, exprs);
+ TValue expr = kcons(K, G(K)->list_app, exprs);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -684,7 +684,7 @@ void Sbindings_to_environment(klisp_State *K)
TValue new_cont = kmake_continuation(K, kget_cc(K),
do_b_to_env, 2, bptree, new_env);
kset_cc(K, new_cont);
- TValue expr = kcons(K, K->list_app, exprs);
+ TValue expr = kcons(K, G(K)->list_app, exprs);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
@@ -746,7 +746,7 @@ void eval_string(klisp_State *K)
/* init ground */
void kinit_environments_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.8.1 environment? */
@@ -788,10 +788,11 @@ void kinit_environments_ground_env(klisp_State *K)
add_applicative(K, ground_env, "eval-string", eval_string, 0);
}
+/* XXX lock? */
/* init continuation names */
void kinit_environments_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_let, "eval-let");
add_cont_name(K, t, do_let_redirect, "eval-let-redirect");
diff --git a/src/kgeqp.c b/src/kgeqp.c
@@ -57,7 +57,7 @@ void eqp(klisp_State *K)
/* init ground */
void kinit_eqp_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.2.1 eq? */
/* 6.5.1 eq? */
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -69,7 +69,7 @@ void equalp(klisp_State *K)
/* init ground */
void kinit_equalp_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.3.1 equal? */
/* 6.6.1 equal? */
diff --git a/src/kgerrors.c b/src/kgerrors.c
@@ -44,7 +44,7 @@ void kgraise(klisp_State *K)
UNUSED(denv);
bind_1p(K, ptree, obj);
- kcall_cont(K, K->error_cont, obj);
+ kcall_cont(K, G(K)->error_cont, obj);
}
void error_object_message(klisp_State *K)
@@ -75,8 +75,19 @@ void error_object_irritants(klisp_State *K)
kapply_cc(K, err_obj->irritants);
}
+void do_error_exit(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ UNUSED(xparams);
+
+ /* TEMP Just pass the error to the root continuation */
+ kapply_cc(K, obj);
+}
+
/* REFACTOR this is the same as do_pass_value */
-void do_exception_cont(klisp_State *K)
+static void do_exception_cont(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue obj = K->next_value;
@@ -88,19 +99,36 @@ void do_exception_cont(klisp_State *K)
/* REFACTOR maybe this should be in kerror.c */
/* Create system-error-continuation. */
-void kinit_error_hierarchy(klisp_State *K)
+static void kinit_error_hierarchy(klisp_State *K)
{
- klisp_assert(ttiscontinuation(K->error_cont));
- klisp_assert(ttisinert(K->system_error_cont));
+ klisp_assert(ttisinert(G(K)->error_cont));
+ G(K)->error_cont = kmake_continuation(K, G(K)->root_cont,
+ do_error_exit, 0);
+
+ TValue str, tail, si;
+
+#if KTRACK_SI
+ str = kstring_new_b_imm(K, __FILE__);
+ tail = kcons(K, i2tv(__LINE__), i2tv(0));
+ si = kcons(K, str, tail);
+ kset_source_info(K, G(K)->error_cont, si);
+#endif
- K->system_error_cont = kmake_continuation(K, K->error_cont,
+ klisp_assert(ttisinert(G(K)->system_error_cont));
+ G(K)->system_error_cont = kmake_continuation(K, G(K)->error_cont,
do_exception_cont, 0);
+#if KTRACK_SI
+ str = kstring_new_b_imm(K, __FILE__);
+ tail = kcons(K, i2tv(__LINE__), i2tv(0));
+ si = kcons(K, str, tail);
+ kset_source_info(K, G(K)->system_error_cont, si);
+#endif
}
/* init ground */
void kinit_error_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
add_applicative(K, ground_env, "error-object?", typep, 2, symbol,
@@ -122,6 +150,16 @@ void kinit_error_ground_env(klisp_State *K)
See Common Lisp and mit scheme for examples
*/
- klisp_assert(ttiscontinuation(K->system_error_cont));
- add_value(K, ground_env, "system-error-continuation", K->system_error_cont);
+ /* 7.2.7 error-continuation */
+ kinit_error_hierarchy(K);
+ add_value(K, ground_env, "error-continuation", G(K)->error_cont);
+ add_value(K, ground_env, "system-error-continuation", G(K)->system_error_cont);
+}
+
+void kinit_error_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(G(K)->cont_name_table);
+
+ add_cont_name(K, t, do_error_exit, "error");
+ add_cont_name(K, t, do_exception_cont, "system-error");
}
diff --git a/src/kgerrors.h b/src/kgerrors.h
@@ -11,10 +11,7 @@
/* init ground */
void kinit_error_ground_env(klisp_State *K);
-
-/* Second stage of itialization of ground environment. Must be
- * called after initializing general error continuation
- * K->error_cont. */
-void kinit_error_hierarchy(klisp_State *K);
+/* init continuation names */
+void kinit_error_cont_names(klisp_State *K);
#endif
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -689,7 +689,7 @@ static TValue ffi_callback_guard(ffi_callback_t *cb, klisp_CFunction fn)
{
TValue app = kmake_applicative(cb->K, fn, 1, p2tv(cb));
krooted_tvs_push(cb->K, app);
- TValue ls1 = kimm_list(cb->K, 2, cb->K->root_cont, app);
+ TValue ls1 = kimm_list(cb->K, 2, G(cb->K)->root_cont, app);
krooted_tvs_push(cb->K, ls1);
TValue ls2 = kimm_list(cb->K, 1, ls1);
krooted_tvs_pop(cb->K);
@@ -872,7 +872,7 @@ static void ffi_callback_entry(ffi_cif *cif, void *ret, void **args, void *user_
/* Enter new "inner" trampoline loop. */
- klispS_run(K);
+ klispT_run(K);
/* restore longjump buffer of the outer trampoline loop */
@@ -895,7 +895,7 @@ static void ffi_callback_entry(ffi_cif *cif, void *ret, void **args, void *user_
** normal return from the exit guard.
*/
(void) ffi_callback_pop(cb);
- klispS_apply_cc(K, kcar(K->next_value));
+ klispT_apply_cc(K, kcar(K->next_value));
longjmp(K->error_jb, 1);
}
}
@@ -1153,7 +1153,7 @@ void ffi_klisp_state(klisp_State *K)
/* init ground */
void kinit_ffi_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* create encapsulation keys */
@@ -1183,10 +1183,11 @@ void kinit_ffi_ground_env(klisp_State *K)
add_applicative(K, ground_env, "ffi-call-interface?", enc_typep, 1, cif_key);
}
+/* XXX lock? */
/* init continuation names */
void kinit_ffi_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_ffi_callback_encode_result,
"ffi-callback-encode-result");
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -27,10 +27,11 @@
#include "kencapsulation.h"
#include "kpromise.h"
+/* XXX lock? */
/* Initialization of continuation names */
void kinit_kghelpers_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_seq, "eval-sequence");
add_cont_name(K, t, do_pass_value, "pass-value");
add_cont_name(K, t, do_return_value, "return-value");
@@ -406,7 +407,7 @@ void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
*cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
unmark_list(K, obj);
-
+
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, allow_infp? "expected list" :
"expected finite list");
@@ -500,7 +501,7 @@ TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
unmark_list(K, obj);
unmark_list(K, kcdr(copy));
-
+
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, "expected list");
return KINERT;
@@ -511,6 +512,8 @@ TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
}
/* GC: assumes ls is rooted */
+/* LOCK: This assumes ls isn't mutated, so no lock is acquired
+ (except the needed for car, cdr & set-cdr) */
TValue reverse_copy_and_encycle(klisp_State *K, TValue ls, int32_t pairs,
int32_t cpairs)
{
@@ -589,7 +592,7 @@ TValue list_to_string_h(klisp_State *K, TValue ls, int32_t length)
TValue new_str;
/* the if isn't strictly necessary but it's clearer this way */
if (length == 0) {
- return K->empty_string;
+ return G(K)->empty_string;
} else {
new_str = kstring_new_s(K, length);
char *buf = kstring_buf(new_str);
@@ -611,7 +614,7 @@ TValue list_to_vector_h(klisp_State *K, TValue ls, int32_t length)
{
if (length == 0) {
- return K->empty_vector;
+ return G(K)->empty_vector;
} else {
TValue new_vec = kvector_new_sf(K, length, KINERT);
TValue *buf = kvector_buf(new_vec);
@@ -628,7 +631,7 @@ TValue list_to_bytevector_h(klisp_State *K, TValue ls, int32_t length)
TValue new_bb;
/* the if isn't strictly necessary but it's clearer this way */
if (length == 0) {
- return K->empty_bytevector;
+ return G(K)->empty_bytevector;
} else {
new_bb = kbytevector_new_s(K, length);
uint8_t *buf = kbytevector_buf(new_bb);
@@ -1065,7 +1068,7 @@ bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
}
break;
case K_TBYTEVECTOR:
- if (!kbytevector_equalp(obj1, obj2)) {
+ if (!kbytevector_equalp(K, obj1, obj2)) {
result = false;
goto end;
}
@@ -1775,7 +1778,7 @@ TValue make_bind_continuation(klisp_State *K, TValue key,
TValue exit_int = kmake_operative(K, do_set_pass,
3, key, old_flag, old_value);
krooted_tvs_push(K, exit_int);
- TValue exit_guard = kcons(K, K->root_cont, exit_int);
+ TValue exit_guard = kcons(K, G(K)->root_cont, exit_int);
krooted_tvs_pop(K); /* already rooted in guard */
krooted_tvs_push(K, exit_guard);
TValue exit_guards = kcons(K, exit_guard, KNIL);
@@ -1785,7 +1788,7 @@ TValue make_bind_continuation(klisp_State *K, TValue key,
TValue entry_int = kmake_operative(K, do_set_pass,
3, key, new_flag, new_value);
krooted_tvs_push(K, entry_int);
- TValue entry_guard = kcons(K, K->root_cont, entry_int);
+ TValue entry_guard = kcons(K, G(K)->root_cont, entry_int);
krooted_tvs_pop(K); /* already rooted in guard */
krooted_tvs_push(K, entry_guard);
TValue entry_guards = kcons(K, entry_guard, KNIL);
@@ -1927,3 +1930,37 @@ void guard_dynamic_extent(klisp_State *K)
ktail_eval(K, expr, denv);
}
+
+
+void do_int_mark_error(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: errorp pointer
+ */
+ UNUSED(denv);
+ bool *errorp = (bool *) pvalue(xparams[0]);
+ *errorp = true;
+ /* ptree is (object divert) */
+ TValue error_obj = kcar(ptree);
+ /* pass the error along after setting the flag */
+ kapply_cc(K, error_obj);
+}
+
+void do_int_mark_root(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: rootp pointer
+ */
+ UNUSED(obj); /* ignore obj */
+ bool *rootp = (bool *) pvalue(xparams[0]);
+ *rootp = false; /* mark that we didn't explicitly call the root cont */
+ /* pass #INERT to the root continuation */
+ kapply_cc(K, KINERT);
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -513,6 +513,13 @@ TValue map_for_each_transpose(klisp_State *K, TValue lss,
int32_t res_apairs, int32_t res_cpairs);
+/* for thread continuation guarding */
+void do_int_mark_root(klisp_State *K);
+void do_int_mark_error(klisp_State *K);
+
+/* TODO add handler for entry guards to avoid
+ continuations to cross threads */
+
/*
** Macros for ground environment initialization
*/
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -59,7 +59,7 @@ void make_keyed_dynamic_variable(klisp_State *K)
/* init ground */
void kinit_kgkd_vars_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 10.1.1 make-keyed-dynamic-variable */
diff --git a/src/kgkeywords.c b/src/kgkeywords.c
@@ -83,7 +83,7 @@ void symbol_to_keyword(klisp_State *K)
/* init ground */
void kinit_keywords_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/*
diff --git a/src/kgks_vars.c b/src/kgks_vars.c
@@ -90,7 +90,7 @@ void make_keyed_static_variable(klisp_State *K)
/* init ground */
void kinit_kgks_vars_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 11.1.1 make-keyed-static-variable */
diff --git a/src/kglibraries.c b/src/kglibraries.c
@@ -127,7 +127,7 @@ static TValue libraries_registry_assoc(klisp_State *K, TValue name, TValue *last
{
TValue last = KNIL;
TValue res = KNIL;
- for (TValue ls = K->libraries_registry; !ttisnil(ls); last = ls,
+ for (TValue ls = G(K)->libraries_registry; !ttisnil(ls); last = ls,
ls = kcdr(ls)) {
if (equal2p(K, kcar(kcar(ls)), name)) {
res = kcar(ls);
@@ -180,8 +180,8 @@ static void do_register_library(klisp_State *K)
}
TValue np = kcons(K, name, obj);
krooted_tvs_push(K, np);
- np = kcons(K, np, K->libraries_registry);
- K->libraries_registry = np;
+ np = kcons(K, np, G(K)->libraries_registry);
+ G(K)->libraries_registry = np;
krooted_tvs_pop(K);
kapply_cc(K, KINERT);
}
@@ -215,7 +215,7 @@ static void Sunregister_libraryB(klisp_State *K)
return;
}
if (ttisnil(last)) { /* it's in the first pair */
- K->libraries_registry = kcdr(K->libraries_registry);
+ G(K)->libraries_registry = kcdr(G(K)->libraries_registry);
} else {
kset_cdr(last, kcdr(kcdr(last)));
}
@@ -331,8 +331,8 @@ static void do_provide_library(klisp_State *K)
TValue np = kcons(K, name, library);
krooted_tvs_pop(K); /* library */
krooted_tvs_push(K, np);
- np = kcons(K, np, K->libraries_registry);
- K->libraries_registry = np;
+ np = kcons(K, np, G(K)->libraries_registry);
+ G(K)->libraries_registry = np;
krooted_tvs_pop(K);
kapply_cc(K, KINERT);
}
@@ -728,7 +728,7 @@ static void Simport_libraryB(klisp_State *K)
/* init ground */
void kinit_libraries_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
add_applicative(K, ground_env, "library?", typep, 2, symbol,
@@ -752,10 +752,11 @@ void kinit_libraries_ground_env(klisp_State *K)
add_operative(K, ground_env, "$import-library!", Simport_libraryB, 0);
}
+/* XXX lock? */
/* init continuation names */
void kinit_libraries_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_register_library, "register-library");
add_cont_name(K, t, do_provide_library, "provide-library");
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -1662,7 +1662,7 @@ void kwith_strict_arithmetic(klisp_State *K)
bind_2tp(K, ptree, "bool", ttisboolean, strictp,
"combiner", ttiscombiner, comb);
- TValue op = kmake_operative(K, do_bind, 1, K->kd_strict_arith_key);
+ TValue op = kmake_operative(K, do_bind, 1, G(K)->kd_strict_arith_key);
krooted_tvs_push(K, op);
TValue args = klist(K, 2, strictp, comb);
@@ -2288,7 +2288,7 @@ void number_to_string(klisp_State *K)
radix = ivalue(maybe_radix);
char small_buf[64]; /* for fixints */
- TValue buf_str = K->empty_string; /* for bigrats, bigints and doubles */
+ TValue buf_str = G(K)->empty_string; /* for bigrats, bigints and doubles */
krooted_vars_push(K, &buf_str);
char *buf;
@@ -2500,7 +2500,7 @@ void string_to_number(klisp_State *K)
/* init ground */
void kinit_numbers_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* No complex or bounded reals for now */
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -488,7 +488,7 @@ void memqp(klisp_State *K)
/* init ground */
void kinit_pair_mut_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.7.1 set-car!, set-cdr! */
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -1215,7 +1215,7 @@ void reduce(klisp_State *K)
/* init ground */
void kinit_pairs_lists_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.6.1 pair? */
@@ -1324,10 +1324,11 @@ void kinit_pairs_lists_ground_env(klisp_State *K)
add_applicative(K, ground_env, "reduce", reduce, 0);
}
+/* XXX lock? */
/* init continuation names */
void kinit_pairs_lists_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_memberp, "member?-search");
add_cont_name(K, t, do_assoc, "assoc-search");
diff --git a/src/kgports.c b/src/kgports.c
@@ -285,7 +285,7 @@ void gread(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(G(K)->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
@@ -318,7 +318,7 @@ void gwrite(klisp_State *K)
port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(G(K)->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
@@ -351,7 +351,7 @@ void gwrite_simple(klisp_State *K)
port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(G(K)->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
@@ -384,7 +384,7 @@ void newline(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(G(K)->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
@@ -416,7 +416,7 @@ void write_char(klisp_State *K)
port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(G(K)->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
@@ -450,7 +450,7 @@ void read_peek_char(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(G(K)->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
@@ -491,7 +491,7 @@ void char_readyp(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(G(K)->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
@@ -522,7 +522,7 @@ void write_u8(klisp_State *K)
bind_al1tp(K, ptree, "u8", ttisu8, u8, port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(G(K)->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
@@ -556,7 +556,7 @@ void read_peek_u8(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(G(K)->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
@@ -597,7 +597,7 @@ void u8_readyp(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(G(K)->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
@@ -681,7 +681,7 @@ TValue make_guarded_read_cont(klisp_State *K, TValue parent, TValue port)
TValue exit_int = kmake_operative(K, do_int_close_file,
1, port);
krooted_tvs_push(K, exit_int);
- TValue exit_guard = kcons(K, K->error_cont, exit_int);
+ TValue exit_guard = kcons(K, G(K)->error_cont, exit_int);
krooted_tvs_pop(K); /* alread in guard */
krooted_tvs_push(K, exit_guard);
TValue exit_guards = kcons(K, exit_guard, KNIL);
@@ -833,7 +833,7 @@ static TValue find_file (klisp_State *K, TValue name, TValue pname) {
/* lua_getfield(L, LUA_ENVIRONINDEX, pname); */
klisp_assert(ttisstring(name) && !kstring_emptyp(name));
const char *path = kstring_buf(pname);
- TValue next = K->empty_string;
+ TValue next = G(K)->empty_string;
krooted_vars_push(K, &next);
TValue wild = kstring_new_b(K, KLISP_PATH_MARK);
krooted_tvs_push(K, wild);
@@ -849,9 +849,10 @@ static TValue find_file (klisp_State *K, TValue name, TValue pname) {
krooted_tvs_pop(K);
krooted_vars_pop(K);
- return K->empty_string; /* return empty_string */
+ return G(K)->empty_string; /* return empty_string */
}
+/* XXX lock? */
/* ?.? require */
/*
** require is like load except that:
@@ -883,7 +884,7 @@ void require(klisp_State *K)
TValue saved_name = kstring_immutablep(name)? name :
kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
- const TValue *node = klispH_getstr(tv2table(K->require_table),
+ const TValue *node = klispH_getstr(tv2table(G(K)->require_table),
tv2str(saved_name));
if (!ttisfree(*node)) {
/* was required already, nothing to be done */
@@ -891,9 +892,9 @@ void require(klisp_State *K)
}
krooted_tvs_push(K, saved_name);
- TValue filename = K->empty_string;
+ TValue filename = G(K)->empty_string;
krooted_vars_push(K, &filename);
- filename = find_file(K, name, K->require_path);
+ filename = find_file(K, name, G(K)->require_path);
if (kstring_emptyp(filename)) {
klispE_throw_simple_with_irritants(K, "Not found", 1, name);
@@ -906,7 +907,7 @@ void require(klisp_State *K)
required recursively. A third option would be to record the
sate of the require in the table, so we could have: error, required,
requiring, etc */
- *(klispH_setstr(K, tv2table(K->require_table), tv2str(saved_name))) =
+ *(klispH_setstr(K, tv2table(G(K)->require_table), tv2str(saved_name))) =
KTRUE;
krooted_tvs_pop(K); /* saved_name no longer necessary */
@@ -941,7 +942,7 @@ void require(klisp_State *K)
} else {
TValue tail = kcdr(ls);
/* std environments have hashtable for bindings */
- TValue env = kmake_table_environment(K, K->ground_env);
+ TValue env = kmake_table_environment(K, G(K)->ground_env);
if (ttispair(tail)) {
krooted_tvs_push(K, ls);
krooted_tvs_push(K, env);
@@ -961,6 +962,7 @@ void require(klisp_State *K)
}
}
+/* XXX lock? */
/* ?.? registered-requirement? */
void registered_requirementP(klisp_State *K)
{
@@ -976,11 +978,12 @@ void registered_requirementP(klisp_State *K)
TValue saved_name = kstring_immutablep(name)? name :
kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
- const TValue *node = klispH_getstr(tv2table(K->require_table),
+ const TValue *node = klispH_getstr(tv2table(G(K)->require_table),
tv2str(saved_name));
kapply_cc(K, ttisfree(*node)? KFALSE : KTRUE);
}
+/* XXX lock? */
void register_requirementB(klisp_State *K)
{
bind_1tp(K, K->next_value, "string", ttisstring, name);
@@ -991,7 +994,7 @@ void register_requirementB(klisp_State *K)
TValue saved_name = kstring_immutablep(name)? name :
kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
- TValue *node = klispH_setstr(K, tv2table(K->require_table),
+ TValue *node = klispH_setstr(K, tv2table(G(K)->require_table),
tv2str(saved_name));
/* throw error if already registered */
@@ -1005,6 +1008,7 @@ void register_requirementB(klisp_State *K)
kapply_cc(K, KINERT);
}
+/* XXX lock? */
void unregister_requirementB(klisp_State *K)
{
bind_1tp(K, K->next_value, "string", ttisstring, name);
@@ -1015,7 +1019,7 @@ void unregister_requirementB(klisp_State *K)
TValue saved_name = kstring_immutablep(name)? name :
kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
- TValue *node = klispH_setstr(K, tv2table(K->require_table),
+ TValue *node = klispH_setstr(K, tv2table(G(K)->require_table),
tv2str(saved_name));
/* throw error if not registered */
@@ -1028,6 +1032,7 @@ void unregister_requirementB(klisp_State *K)
kapply_cc(K, KINERT);
}
+/* XXX lock? */
/* will throw an error if not found */
void find_required_filename(klisp_State *K)
{
@@ -1036,7 +1041,7 @@ void find_required_filename(klisp_State *K)
klispE_throw_simple(K, "Empty name");
return;
}
- TValue filename = find_file(K, name, K->require_path);
+ TValue filename = find_file(K, name, G(K)->require_path);
if (kstring_emptyp(filename)) {
klispE_throw_simple_with_irritants(K, "Not found", 1, name);
@@ -1061,12 +1066,12 @@ void get_module(klisp_State *K)
krooted_tvs_push(K, port);
/* std environments have hashtable for bindings */
- TValue env = kmake_table_environment(K, K->ground_env);
-// TValue env = kmake_environment(K, K->ground_env);
+ TValue env = kmake_table_environment(K, G(K)->ground_env);
+// TValue env = kmake_environment(K, G(K)->ground_env);
krooted_tvs_push(K, env);
if (get_opt_tpar(K, maybe_env, "environment", ttisenvironment)) {
- kadd_binding(K, env, K->module_params_sym, maybe_env);
+ kadd_binding(K, env, G(K)->module_params_sym, maybe_env);
}
TValue ret_env_cont = kmake_continuation(K, kget_cc(K), do_return_value,
@@ -1125,7 +1130,7 @@ void display(klisp_State *K)
port);
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(G(K)->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
@@ -1156,7 +1161,7 @@ void read_line(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_in_port_key); /* access directly */
+ port = kcdr(G(K)->kd_in_port_key); /* access directly */
}
if (!kport_is_input(port)) {
@@ -1187,7 +1192,7 @@ void flush(klisp_State *K)
TValue port = ptree;
if (!get_opt_tpar(K, port, "port", ttisport)) {
- port = kcdr(K->kd_out_port_key); /* access directly */
+ port = kcdr(G(K)->kd_out_port_key); /* access directly */
}
if (!kport_is_output(port)) {
@@ -1211,7 +1216,7 @@ void kinit_ports_ground_env(klisp_State *K)
** Some of these are from r7rs scheme
*/
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 15.1.1 port? */
@@ -1241,19 +1246,19 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* 15.1.? with-error-to-file */
add_applicative(K, ground_env, "with-input-from-file", with_file,
- 3, symbol, b2tv(false), K->kd_in_port_key);
+ 3, symbol, b2tv(false), G(K)->kd_in_port_key);
add_applicative(K, ground_env, "with-output-to-file", with_file,
- 3, symbol, b2tv(true), K->kd_out_port_key);
+ 3, symbol, b2tv(true), G(K)->kd_out_port_key);
add_applicative(K, ground_env, "with-error-to-file", with_file,
- 3, symbol, b2tv(true), K->kd_error_port_key);
+ 3, symbol, b2tv(true), G(K)->kd_error_port_key);
/* 15.1.4 get-current-input-port, get-current-output-port */
/* 15.1.? get-current-error-port */
add_applicative(K, ground_env, "get-current-input-port", get_current_port,
- 2, symbol, K->kd_in_port_key);
+ 2, symbol, G(K)->kd_in_port_key);
add_applicative(K, ground_env, "get-current-output-port", get_current_port,
- 2, symbol, K->kd_out_port_key);
+ 2, symbol, G(K)->kd_out_port_key);
add_applicative(K, ground_env, "get-current-error-port", get_current_port,
- 2, symbol, K->kd_error_port_key);
+ 2, symbol, G(K)->kd_error_port_key);
/* 15.1.5 open-input-file, open-output-file */
add_applicative(K, ground_env, "open-input-file", open_file, 2,
b2tv(false), b2tv(false));
@@ -1378,10 +1383,11 @@ void kinit_ports_ground_env(klisp_State *K)
*/
}
+/* XXX lock? */
/* init continuation names */
void kinit_ports_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_close_file_ret, "close-file-and-ret");
}
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -124,7 +124,7 @@ void Sdelay(klisp_State *K)
bind_1p(K, ptree, exp);
TValue promise_body = kcons(K, exp, KNIL);
krooted_vars_push(K, &promise_body);
- promise_body = kcons(K, K->memoize_app, promise_body);
+ promise_body = kcons(K, G(K)->memoize_app, promise_body);
TValue new_prom = kmake_promise(K, promise_body, denv);
krooted_vars_pop(K);
kapply_cc(K, new_prom);
@@ -133,7 +133,7 @@ void Sdelay(klisp_State *K)
/* init ground */
void kinit_promises_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 9.1.1 promise? */
@@ -149,10 +149,11 @@ void kinit_promises_ground_env(klisp_State *K)
add_applicative(K, ground_env, "$delay", Sdelay, 0);
}
+/* XXX lock? */
/* init continuation names */
void kinit_promises_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_handle_result, "promise-handle-result");
}
diff --git a/src/kground.c b/src/kground.c
@@ -42,6 +42,7 @@
#include "kgerrors.h"
#include "kgkeywords.h"
#include "kglibraries.h"
+#include "kgthreads.h"
#if KUSE_LIBFFI
# include "kgffi.h"
@@ -53,6 +54,7 @@
#include "keval.h"
#include "krepl.h"
+/* XXX lock? */
/*
** This is called once to save the names of the types of continuations
** used in the ground environment & repl
@@ -60,13 +62,6 @@
*/
void kinit_cont_names(klisp_State *K)
{
- /* TEMP root and error continuations are set here (they are in kstate) */
- Table *t = tv2table(K->cont_name_table);
- add_cont_name(K, t, do_root_exit, "exit");
- add_cont_name(K, t, do_error_exit, "error");
- /* TEMP this is also in kstate */
- add_cont_name(K, t, do_interception, "do-interception");
-
/* TEMP repl ones should be done in the interpreter, and not in
the init state */
kinit_repl_cont_names(K);
@@ -86,6 +81,7 @@ void kinit_cont_names(klisp_State *K)
#if KUSE_LIBFFI
kinit_ffi_cont_names(K);
#endif
+ kinit_error_cont_names(K);
kinit_libraries_cont_names(K);
}
@@ -123,6 +119,7 @@ void kinit_ground_env(klisp_State *K)
kinit_error_ground_env(K);
kinit_keywords_ground_env(K);
kinit_libraries_ground_env(K);
+ kinit_threads_ground_env(K);
#if KUSE_LIBFFI
kinit_ffi_ground_env(K);
#endif
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -334,7 +334,7 @@ void substring(klisp_State *K)
TValue new_str;
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
- new_str = K->empty_string;
+ new_str = G(K)->empty_string;
} else {
/* always returns mutable strings */
new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
@@ -374,7 +374,7 @@ void string_append(klisp_State *K)
int32_t size = (int32_t) total_size;
if (size == 0) {
- new_str = K->empty_string;
+ new_str = G(K)->empty_string;
} else {
new_str = kstring_new_s(K, size);
char *buf = kstring_buf(new_str);
@@ -442,7 +442,7 @@ void string_to_vector(klisp_State *K)
TValue res;
if (kstring_emptyp(str)) {
- res = K->empty_vector;
+ res = G(K)->empty_vector;
} else {
uint32_t size = kstring_size(str);
@@ -473,7 +473,7 @@ void vector_to_string(klisp_State *K)
TValue res;
if (kvector_emptyp(vec)) {
- res = K->empty_string;
+ res = G(K)->empty_string;
} else {
uint32_t size = kvector_size(vec);
@@ -507,7 +507,7 @@ void string_to_bytevector(klisp_State *K)
TValue res;
if (kstring_emptyp(str)) {
- res = K->empty_bytevector;
+ res = G(K)->empty_bytevector;
} else {
uint32_t size = kstring_size(str);
@@ -538,7 +538,7 @@ void bytevector_to_string(klisp_State *K)
TValue res;
if (kbytevector_emptyp(bb)) {
- res = K->empty_string;
+ res = G(K)->empty_string;
} else {
uint32_t size = kbytevector_size(bb);
res = kstring_new_s(K, size); /* no need to root this */
@@ -571,7 +571,7 @@ void string_copy(klisp_State *K)
TValue new_str;
/* the if isn't strictly necessary but it's clearer this way */
- if (tv_equal(str, K->empty_string)) {
+ if (tv_equal(str, G(K)->empty_string)) {
new_str = str;
} else {
new_str = kstring_new_bs(K, kstring_buf(str), kstring_size(str));
@@ -623,7 +623,7 @@ void string_fillB(klisp_State *K)
/* init ground */
void kinit_strings_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/*
diff --git a/src/kgsymbols.c b/src/kgsymbols.c
@@ -59,7 +59,7 @@ void string_to_symbol(klisp_State *K)
/* init ground */
void kinit_symbols_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* 4.4.1 symbol? */
diff --git a/src/kgsystem.c b/src/kgsystem.c
@@ -103,15 +103,21 @@ void delete_file(klisp_State *K)
/* TEMP: this should probably be done in a operating system specific
manner, but this will do for now */
+ /* allow other threads to run while the file is being removed */
+ klisp_unlock(K);
if (remove(kstring_buf(filename))) {
/* At least in Windows, this could have failed if there's a dead
(in the gc sense) port still open, should retry once after
doing a complete GC. This isn't ideal but... */
+ klisp_lock(K);
klispC_fullgc(K);
+ klisp_unlock(K);
if (remove(kstring_buf(filename))) {
+ klisp_lock(K);
klispE_throw_errno_with_irritants(K, "remove", 1, filename);
return;
}
+ klisp_lock(K);
}
kapply_cc(K, KINERT);
}
@@ -254,7 +260,7 @@ TValue create_env_var_list(klisp_State *K)
/* init ground */
void kinit_system_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/* ??.?.? get-current-second */
diff --git a/src/kgtables.c b/src/kgtables.c
@@ -311,7 +311,7 @@ static void hash_table_to_list(klisp_State *K)
/* init ground */
void kinit_tables_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
add_applicative(K, ground_env, "hash-table?", typep, 2, symbol,
diff --git a/src/kgthreads.c b/src/kgthreads.c
@@ -0,0 +1,383 @@
+/*
+** kgstrings.c
+** Strings features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "ktable.h"
+#include "kobject.h"
+#include "kmutex.h"
+#include "kcondvar.h"
+#include "kghelpers.h"
+
+/* ?.1? thread? */
+/* uses typep */
+
+/* ?.2? get-current-thread */
+static void get_current_thread(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ check_0p(K, ptree);
+ kapply_cc(K, gc2th(K));
+}
+
+static void *thread_run(void *data)
+{
+ klisp_State *K = (klisp_State *) data;
+
+/* XXX/REFACTOR This is more or less the same that is repeated
+ over and over again in the repl code (klisp.c), move to a helper
+routine somewhere */
+ bool errorp = false; /* may be set to true in error handler */
+ bool rootp = true; /* may be set to false in continuation */
+
+ /* ???/TODO should the fact that the thread thrown an exception
+ be reported to the error output??? */
+
+ /* We have already the appropriate environment,
+ operative and arguments in place, but we still need the
+ continuations/guards */
+ /* LOCK: We need the GIL for allocating the objects */
+ klisp_lock(K);
+
+ K->status = KLISP_THREAD_RUNNING;
+ /* create the guard set error flag after errors */
+ TValue exit_int = kmake_operative(K, do_int_mark_error,
+ 1, p2tv(&errorp));
+ krooted_tvs_push(K, exit_int);
+ TValue exit_guard = kcons(K, G(K)->error_cont, exit_int);
+ krooted_tvs_pop(K); /* already in guard */
+ krooted_tvs_push(K, exit_guard);
+ TValue exit_guards = kcons(K, exit_guard, KNIL);
+ krooted_tvs_pop(K); /* already in guards */
+ krooted_tvs_push(K, exit_guards);
+
+ TValue entry_guards = KNIL;
+
+ /* this is needed for interception code */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ TValue outer_cont = kmake_continuation(K, G(K)->root_cont,
+ do_pass_value, 2, entry_guards, env);
+ kset_outer_cont(outer_cont);
+ krooted_tvs_push(K, outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont,
+ do_pass_value, 2, exit_guards, env);
+ kset_inner_cont(inner_cont);
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+
+ krooted_tvs_push(K, inner_cont);
+
+ /* This continuation will discard the result of the evaluation
+ and return #inert instead, it will also signal via rootp = false
+ that the evaluation didn't explicitly invoke the root continuation
+ */
+ TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
+ 1, p2tv(&rootp));
+
+ krooted_tvs_pop(K); /* pop inner cont */
+ krooted_tvs_push(K, discard_cont);
+
+ kset_cc(K, discard_cont);
+ krooted_tvs_pop(K); /* pop discard cont */
+
+ klisp_unlock(K);
+
+ /* LOCK: run will acquire the lock, and release it when done */
+ klispT_run(K);
+
+ klisp_lock(K);
+
+ /* thread is done, we can remove it from the thread table */
+ /* XXX what happens if this threads terminates abnormally?? */
+ TValue *node = klispH_set(K, tv2table(G(K)->thread_table),
+ gc2th(K));
+ *node = KFREE;
+
+ K->status = errorp? KLISP_THREAD_ERROR : KLISP_THREAD_DONE;
+ /* the thrown object/return value remains in K->next_obj */
+ /* NOTICE that unless root continuation is explicitly invoked
+ the value returned by the function is discarded!!
+ This may change in the future */
+
+ /* signal all threads waiting to join */
+ int32_t ret = pthread_cond_broadcast(&K->joincond);
+ klisp_assert(ret == 0); /* shouldn't happen */
+ klisp_unlock(K);
+ return NULL;
+}
+
+/* ?.3? make-thread */
+static void make_thread(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "combiner", ttiscombiner, comb);
+ TValue top = comb;
+ while(ttisapplicative(top))
+ top = kunwrap(top);
+
+ /* GC: threads are fixed, no need to protect it */
+ klisp_State *new_K = klispT_newthread(K);
+ TValue new_th = gc2th(new_K);
+ /* Prepare the new_K state to call the passed combiner with
+ no arguments and an empty environment */
+ /* TODO set_cc */
+ klispT_set_cc(new_K, G(K)->root_cont);
+ /* This will protect it from GC */
+ new_K->next_env = kmake_empty_environment(K);
+ TValue si = ktry_get_si(new_K, top);
+ klispT_tail_call_si(new_K, top, KNIL, new_K->next_env, si);
+
+ pthread_attr_t attr;
+ int32_t ret = pthread_attr_init(&attr);
+ klisp_assert(ret == 0); /* this shouldn't really happen... */
+ /* make threads detached, the running state and return value
+ will be kept in the corresponding klisp_State struct */
+ pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
+ klisp_assert(ret == 0); /* this shouldn't really happen... */
+
+ K->status = KLISP_THREAD_STARTING;
+ ret = pthread_create(&new_K->thread, &attr, thread_run, new_K);
+
+ if (ret != 0) {
+ /* let the GC collect the failed State */
+ resetbit(new_K->gct, FIXEDBIT);
+ klispE_throw_simple_with_irritants(K, "Error creating thread",
+ 1, i2tv(ret));
+ return;
+ }
+
+ /* this shouldn't fail */
+ UNUSED(pthread_attr_destroy(&attr));
+
+ /* thread created correctly, return it */
+ kapply_cc(K, new_th);
+}
+
+static void thread_join(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "thread", ttisthread, thread);
+
+ if (tv_equal(gc2th(K), thread)) {
+ klispE_throw_simple(K, "Thread can't join with itself");
+ return;
+ } else if (tv_equal(gc2th(G(K)->mainthread), thread)) {
+ klispE_throw_simple(K, "Can't join with main thread");
+ return;
+ }
+
+ klisp_State *K2 = tv2th(thread);
+
+ while(true) {
+ fflush(stdout);
+ if (K2->status == KLISP_THREAD_DONE) {
+ /* NOTICE that unless root continuation was explicitly invoked
+ the value returned by the thread is discarded!!
+ This may change in the future */
+ kapply_cc(K, K2->next_value);
+ } else if (K2->status == KLISP_THREAD_ERROR) {
+ /* throw the same object, but in this thread */
+ kcall_cont(K, G(K)->error_cont, K2->next_value);
+ return;
+ } else {
+ /* must wait for this thread to end */
+ /* LOCK: the GIL should be acquired exactly once */
+ int32_t ret = pthread_cond_wait(&K2->joincond, &G(K)->gil);
+ klisp_assert(ret == 0); /* shouldn't happen */
+ }
+ }
+}
+
+/* make-mutex */
+static void make_mutex(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ check_0p(K, ptree);
+
+ TValue new_mutex = kmake_mutex(K);
+ kapply_cc(K, new_mutex);
+}
+
+/* mutex-lock */
+static void mutex_lock(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "mutex", ttismutex, mutex);
+ kmutex_lock(K, mutex);
+ kapply_cc(K, KINERT);
+}
+
+/* mutex-unlock */
+static void mutex_unlock(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "mutex", ttismutex, mutex);
+ kmutex_unlock(K, mutex);
+ kapply_cc(K, KINERT);
+}
+
+/* mutex-trylock */
+static void mutex_trylock(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "mutex", ttismutex, mutex);
+ bool res = kmutex_trylock(K, mutex);
+ kapply_cc(K, b2tv(res));
+}
+
+/* make-condition-variable */
+static void make_condvar(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "mutex", ttismutex, mutex);
+
+ TValue new_condvar = kmake_condvar(K, mutex);
+ kapply_cc(K, new_condvar);
+}
+
+/* condition-variable-wait */
+static void condvar_wait(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "condition-variable", ttiscondvar, condvar);
+ kcondvar_wait(K, condvar);
+ kapply_cc(K, KINERT);
+}
+
+/* condition-variable-signal / condition-variable-broadcast */
+static void condvar_signal(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(denv);
+ /*
+ ** xparams[0]: broadcast?
+ */
+ bool broadcast = bvalue(xparams[0]);
+
+ bind_1tp(K, ptree, "condition-variable", ttiscondvar, condvar);
+ kcondvar_signal(K, condvar, broadcast);
+ kapply_cc(K, KINERT);
+}
+
+/* init ground */
+void kinit_threads_ground_env(klisp_State *K)
+{
+ TValue ground_env = G(K)->ground_env;
+ TValue symbol, value;
+
+ /*
+ ** This section is still missing from the report. The bindings here are
+ ** taken from a mix of scheme implementations and the pthreads library
+ */
+
+ /* ?.1? thread? */
+ add_applicative(K, ground_env, "thread?", typep, 2, symbol,
+ i2tv(K_TTHREAD));
+
+ /* ?.2? get-current-thread */
+ add_applicative(K, ground_env, "get-current-thread", get_current_thread, 0);
+
+ /* ?.3? make-thread */
+ add_applicative(K, ground_env, "make-thread", make_thread, 0);
+
+ /* ?.4? thread-join */
+ add_applicative(K, ground_env, "thread-join", thread_join, 0);
+
+ /* Mutexes */
+ /* mutex? */
+ add_applicative(K, ground_env, "mutex?", typep, 2, symbol,
+ i2tv(K_TMUTEX));
+
+ /* make-mutex */
+ add_applicative(K, ground_env, "make-mutex", make_mutex, 0);
+ /* REFACTOR: should lock and unlock have an '!'?
+ What about try lock?? '!', '?', '!?', neither? */
+ /* mutex-lock */
+ add_applicative(K, ground_env, "mutex-lock", mutex_lock, 0);
+ /* mutex-unlock */
+ add_applicative(K, ground_env, "mutex-unlock", mutex_unlock, 0);
+ /* mutex-trylock */
+ add_applicative(K, ground_env, "mutex-trylock", mutex_trylock, 0);
+
+ /* Condition variables */
+ /* condition-variable? */
+ add_applicative(K, ground_env, "condition-variable?", typep, 2, symbol,
+ i2tv(K_TCONDVAR));
+
+ /* make-condition-variable */
+ add_applicative(K, ground_env, "make-condition-variable",
+ make_condvar, 0);
+ /* REFACTOR: should signal have an '!'? */
+ /* condition-variable-wait */
+ add_applicative(K, ground_env, "condition-variable-wait",
+ condvar_wait, 0);
+ /* condition-variable-signal */
+ add_applicative(K, ground_env, "condition-variable-signal",
+ condvar_signal, 1, b2tv(false));
+ /* condition-variable-broadcast */
+ add_applicative(K, ground_env, "condition-variable-broadcast",
+ condvar_signal, 1, b2tv(true));
+}
diff --git a/src/kgthreads.h b/src/kgthreads.h
@@ -0,0 +1,16 @@
+/*
+** kgthreads.h
+** Threads features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgthreads_h
+#define kgthreads_h
+
+#include "kstate.h"
+
+/* init ground */
+void kinit_threads_ground_env(klisp_State *K);
+
+#endif
+
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -48,7 +48,7 @@ void make_vector(klisp_State *K)
return;
}
TValue new_vector = (ivalue(tv_s) == 0)?
- K->empty_vector
+ G(K)->empty_vector
: kvector_new_sf(K, ivalue(tv_s), fill);
kapply_cc(K, new_vector);
}
@@ -185,7 +185,7 @@ void bytevector_to_vector(klisp_State *K)
TValue res;
if (kbytevector_emptyp(str)) {
- res = K->empty_vector;
+ res = G(K)->empty_vector;
} else {
uint32_t size = kbytevector_size(str);
@@ -216,7 +216,7 @@ void vector_to_bytevector(klisp_State *K)
TValue res;
if (kvector_emptyp(vec)) {
- res = K->empty_bytevector;
+ res = G(K)->empty_bytevector;
} else {
uint32_t size = kvector_size(vec);
@@ -257,7 +257,7 @@ void vector_copyB(klisp_State *K)
}
if (!tv_equal(vector1, vector2) &&
- !tv_equal(vector1, K->empty_vector)) {
+ !tv_equal(vector1, G(K)->empty_vector)) {
memcpy(kvector_buf(vector2),
kvector_buf(vector1),
kvector_size(vector1) * sizeof(TValue));
@@ -306,7 +306,7 @@ void vector_copy_partial(klisp_State *K)
TValue new_vector;
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
- new_vector = K->empty_vector;
+ new_vector = G(K)->empty_vector;
} else {
new_vector = kvector_new_bs_g(K, true, kvector_buf(vector)
+ start, size);
@@ -428,7 +428,7 @@ void vector_to_immutable_vector(klisp_State *K)
/* init ground */
void kinit_vectors_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = G(K)->ground_env;
TValue symbol, value;
/*
diff --git a/src/kkeyword.c b/src/kkeyword.c
@@ -14,10 +14,8 @@
/* for immutable table */
#include "kstring.h"
-/* No case folding is performed by these constructors */
-TValue kkeyword_new_bs(klisp_State *K, const char *buf, int32_t size)
+static uint32_t get_keyword_hash(const char *buf, uint32_t size)
{
- /* First calculate the hash */
uint32_t h = size; /* seed */
size_t step = (size>>5)+1; /* if string is too long, don't hash all
its chars */
@@ -29,8 +27,15 @@ TValue kkeyword_new_bs(klisp_State *K, const char *buf, int32_t size)
/* keyword hash should be different from string & symbol hash
otherwise keywords and their respective immutable string
would always fall in the same bucket */
- /* look for it in the table */
- for (GCObject *o = K->strt.hash[lmod(h, K->strt.size)]; o != NULL;
+ return h;
+}
+
+/* Looks for a keyword in the stringtable and returns a pointer
+ to it if found or NULL otherwise. */
+static Keyword *search_in_keyword_table(klisp_State *K, const char *buf,
+ uint32_t size, uint32_t h)
+{
+ for (GCObject *o = G(K)->strt.hash[lmod(h, G(K)->strt.size)]; o != NULL;
o = o->gch.next) {
klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
@@ -40,24 +45,39 @@ TValue kkeyword_new_bs(klisp_State *K, const char *buf, int32_t size)
String *ts = tv2str(((Keyword *) o)->str);
if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
/* keyword and/or string may be dead */
- if (isdead(K, o)) changewhite(o);
- if (isdead(K, (GCObject *) ts)) changewhite((GCObject *) ts);
- return gc2keyw(o);
+ if (isdead(G(K), o)) changewhite(o);
+ if (isdead(G(K), (GCObject *) ts)) changewhite((GCObject *) ts);
+ return (Keyword *) o;
}
}
- /* REFACTOR: move this to a new function */
+ /* If it exits the loop, it means it wasn't found */
+ return NULL;
+}
+
+/* No case folding is performed by these constructors */
+TValue kkeyword_new_bs(klisp_State *K, const char *buf, uint32_t size)
+{
+ /* First calculate the hash */
+ uint32_t h = get_keyword_hash(buf, size);
+
+ /* look for it in the table */
+ Keyword *new_keyw = search_in_keyword_table(K, buf, size, h);
+
+ if (new_keyw != NULL) {
+ return gc2keyw(new_keyw);
+ }
/* Didn't find it, alloc new immutable string and save in keyword table,
note that the hash value remained in h */
TValue new_str = kstring_new_bs_imm(K, buf, size);
krooted_tvs_push(K, new_str);
- Keyword *new_keyw = klispM_new(K, Keyword);
+ new_keyw = klispM_new(K, Keyword);
TValue ret_tv = gc2keyw(new_keyw);
krooted_tvs_pop(K);
/* header + gc_fields */
/* can't use klispC_link, because strings use the next pointer
differently */
- new_keyw->gct = klispC_white(K);
+ new_keyw->gct = klispC_white(G(K));
new_keyw->tt = K_TKEYWORD;
new_keyw->kflags = 0;
new_keyw->si = NULL;
@@ -68,7 +88,7 @@ TValue kkeyword_new_bs(klisp_State *K, const char *buf, int32_t size)
/* add to the string/keyword table (and link it) */
stringtable *tb;
- tb = &K->strt;
+ tb = &G(K)->strt;
h = lmod(h, tb->size);
new_keyw->next = tb->hash[h]; /* chain new entry */
tb->hash[h] = (GCObject *)(new_keyw);
diff --git a/src/kkeyword.h b/src/kkeyword.h
@@ -16,7 +16,7 @@
/* No case folding is performed by these constructors */
/* buffer + size, may contain nulls */
-TValue kkeyword_new_bs(klisp_State *K, const char *buf, int32_t size);
+TValue kkeyword_new_bs(klisp_State *K, const char *buf, uint32_t size);
/* null terminated buffer */
TValue kkeyword_new_b(klisp_State *K, const char *buf);
/* copies str if not immutable */
diff --git a/src/klimits.h b/src/klimits.h
@@ -62,6 +62,10 @@
#define MINCONTNAMETABSIZE 32
#endif
+#ifndef MINTHREADTABSIZE
+#define MINTHREADTABSIZE 32
+#endif
+
/* minimum size for the require table (must be power of 2) */
#ifndef MINREQUIRETABSIZE
#define MINREQUIRETABSIZE 32
@@ -86,4 +90,42 @@
#define MINREADLINEBUFFER 80
#endif
+/* XXX for now ignore the return values */
+#ifndef klisp_lock
+#include <pthread.h>
+#define klisp_lock(K) ({ \
+ if (K->gil_count == 0) { \
+ K->gil_count = 1; \
+ UNUSED(pthread_mutex_lock(&G(K)->gil)); \
+ } else { \
+ ++K->gil_count; \
+ }})
+
+#define klisp_unlock(K) ({ \
+ if (K->gil_count <= 1) { \
+ K->gil_count = 0; \
+ UNUSED(pthread_mutex_unlock(&G(K)->gil)); \
+ } else { \
+ --K->gil_count; \
+ }})
+
+/* this will work no matter how many times (even 0) the lock was acquired */
+#define klisp_unlock_all(K) ({ \
+ if (K->gil_count > 0) { \
+ K->gil_count = 1; \
+ klisp_unlock(K); \
+ }})
+
+#endif
+
+/* These were the original defines */
+#ifndef klisp_lock
+#define klisp_lock(K) ((void) 0)
+#define klisp_unlock(K) ((void) 0)
+#endif
+
+#ifndef klispi_threadyield
+#define klispi_threadyield(K) {klisp_unlock(K); klisp_lock(K);}
+#endif
+
#endif
diff --git a/src/klisp.c b/src/klisp.c
@@ -40,7 +40,7 @@
#include "kerror.h"
#include "krepl.h"
#include "ksystem.h"
-#include "kghelpers.h" /* for do_pass_value and do_seq */
+#include "kghelpers.h" /* for do_pass_value and do_seq, mark_root & mark_error */
static const char *progname = KLISP_PROGNAME;
@@ -84,7 +84,7 @@ static void k_message (const char *pname, const char *msg)
(like the repl) */
static void show_error(klisp_State *K, TValue obj) {
/* FOR NOW used only for irritant list */
- TValue port = kcdr(K->kd_error_port_key);
+ TValue port = kcdr(G(K)->kd_error_port_key);
klisp_assert(ttisfport(port) && kfport_file(port) == stderr);
/* TEMP: obj should be an error obj */
@@ -168,41 +168,10 @@ static void print_version(void)
printf("%s\n", KLISP_RELEASE " " KLISP_COPYRIGHT);
}
-void do_int_mark_error(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue ptree = K->next_value;
- TValue denv = K->next_env;
- klisp_assert(ttisenvironment(K->next_env));
- /*
- ** xparams[0]: errorp pointer
- */
- UNUSED(denv);
- bool *errorp = (bool *) pvalue(xparams[0]);
- *errorp = true;
- /* ptree is (object divert) */
- TValue error_obj = kcar(ptree);
- /* pass the error along after setting the flag */
- kapply_cc(K, error_obj);
-}
-
-void do_int_mark_root(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- /*
- ** xparams[0]: rootp pointer
- */
- UNUSED(obj); /* ignore obj */
- bool *rootp = (bool *) pvalue(xparams[0]);
- *rootp = false; /* mark that we didn't explicitly call the root cont */
- /* pass #INERT to the root continuation */
- kapply_cc(K, KINERT);
-}
-
static int dostring (klisp_State *K, const char *s, const char *name)
{
+ klisp_lock(K);
+
bool errorp = false; /* may be set to true in error handler */
bool rootp = true; /* may be set to false in continuation */
@@ -212,7 +181,7 @@ static int dostring (klisp_State *K, const char *s, const char *name)
TValue exit_int = kmake_operative(K, do_int_mark_error,
1, p2tv(&errorp));
krooted_tvs_push(K, exit_int);
- TValue exit_guard = kcons(K, K->error_cont, exit_int);
+ TValue exit_guard = kcons(K, G(K)->error_cont, exit_int);
krooted_tvs_pop(K); /* already in guard */
krooted_tvs_push(K, exit_guard);
TValue exit_guards = kcons(K, exit_guard, KNIL);
@@ -224,7 +193,7 @@ static int dostring (klisp_State *K, const char *s, const char *name)
/* this is needed for interception code */
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
- TValue outer_cont = kmake_continuation(K, K->root_cont,
+ TValue outer_cont = kmake_continuation(K, G(K)->root_cont,
do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
@@ -260,13 +229,16 @@ static int dostring (klisp_State *K, const char *s, const char *name)
/* TODO factor this out into a get_ground_binding(K, char *) */
TValue ev = ksymbol_new_b(K, "eval-string", KNIL);
krooted_vars_push(K, &ev);
- klisp_assert(kbinds(K, K->ground_env, ev));
- ev = kunwrap(kget_binding(K, K->ground_env, ev));
+ klisp_assert(kbinds(K, G(K)->ground_env, ev));
+ ev = kunwrap(kget_binding(K, G(K)->ground_env, ev));
krooted_vars_pop(K);
krooted_tvs_pop(K);
- klispS_tail_call_si(K, ev, ptree, env, KNIL);
- klispS_run(K);
+ klispT_tail_call_si(K, ev, ptree, env, KNIL);
+
+ klisp_unlock(K);
+ /* LOCK: run while acquire the GIL again */
+ klispT_run(K);
int status = errorp? STATUS_ERROR :
(rootp? STATUS_ROOT : STATUS_CONTINUE);
@@ -309,6 +281,7 @@ void do_file_read(klisp_State *K)
/* name = NULL means use stdin */
static int dofile(klisp_State *K, const char *name)
{
+ klisp_lock(K);
bool errorp = false; /* may be set to true in error handler */
bool rootp = true; /* may be set to false in continuation */
@@ -317,7 +290,7 @@ static int dofile(klisp_State *K, const char *name)
/* XXX better do this in a continuation */
if (name == NULL) {
- port = kcdr(K->kd_in_port_key);
+ port = kcdr(G(K)->kd_in_port_key);
} else {
FILE *file = fopen(name, "r");
if (file == NULL) {
@@ -345,7 +318,7 @@ static int dofile(klisp_State *K, const char *name)
TValue exit_int = kmake_operative(K, do_int_mark_error,
1, p2tv(&errorp));
krooted_tvs_push(K, exit_int);
- TValue exit_guard = kcons(K, K->error_cont, exit_int);
+ TValue exit_guard = kcons(K, G(K)->error_cont, exit_int);
krooted_tvs_pop(K); /* already in guard */
krooted_tvs_push(K, exit_guard);
TValue exit_guards = kcons(K, exit_guard, KNIL);
@@ -357,7 +330,7 @@ static int dofile(klisp_State *K, const char *name)
/* this is needed for interception code */
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
- TValue outer_cont = kmake_continuation(K, K->root_cont,
+ TValue outer_cont = kmake_continuation(K, G(K)->root_cont,
do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
@@ -392,9 +365,11 @@ static int dofile(klisp_State *K, const char *name)
krooted_tvs_pop(K); /* pop eval cont */
krooted_tvs_pop(K); /* pop port */
kset_cc(K, read_cont); /* this will protect all conts from gc */
- klispS_apply_cc(K, KINERT);
+ klispT_apply_cc(K, KINERT);
- klispS_run(K);
+ klisp_unlock(K);
+ /* LOCK: run while acquire the GIL again */
+ klispT_run(K);
int status = errorp? STATUS_ERROR :
(rootp? STATUS_ROOT : STATUS_CONTINUE);
@@ -406,9 +381,12 @@ static int dofile(klisp_State *K, const char *name)
static void dotty(klisp_State *K)
{
+ klisp_lock(K);
TValue env = K->next_env;
kinit_repl(K);
- klispS_run(K);
+ klisp_unlock(K);
+ /* LOCK: run while acquire the GIL again */
+ klispT_run(K);
/* get the standard environment again in K->next_env */
K->next_env = env;
}
@@ -416,6 +394,7 @@ static void dotty(klisp_State *K)
/* name != NULL */
static int dorfile(klisp_State *K, const char *name)
{
+ klisp_lock(K);
bool errorp = false; /* may be set to true in error handler */
bool rootp = true; /* may be set to false in continuation */
@@ -428,7 +407,7 @@ static int dorfile(klisp_State *K, const char *name)
TValue exit_int = kmake_operative(K, do_int_mark_error,
1, p2tv(&errorp));
krooted_tvs_push(K, exit_int);
- TValue exit_guard = kcons(K, K->error_cont, exit_int);
+ TValue exit_guard = kcons(K, G(K)->error_cont, exit_int);
krooted_tvs_pop(K); /* already in guard */
krooted_tvs_push(K, exit_guard);
TValue exit_guards = kcons(K, exit_guard, KNIL);
@@ -440,7 +419,7 @@ static int dorfile(klisp_State *K, const char *name)
/* this is needed for interception code */
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
- TValue outer_cont = kmake_continuation(K, K->root_cont,
+ TValue outer_cont = kmake_continuation(K, G(K)->root_cont,
do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
@@ -474,13 +453,15 @@ static int dorfile(klisp_State *K, const char *name)
/* TODO factor this out into a get_ground_binding(K, char *) */
TValue req = ksymbol_new_b(K, "require", KNIL);
krooted_vars_push(K, &req);
- klisp_assert(kbinds(K, K->ground_env, req));
- req = kunwrap(kget_binding(K, K->ground_env, req));
+ klisp_assert(kbinds(K, G(K)->ground_env, req));
+ req = kunwrap(kget_binding(K, G(K)->ground_env, req));
krooted_tvs_pop(K);
krooted_vars_pop(K);
- klispS_tail_call_si(K, req, ptree, env, KNIL);
- klispS_run(K);
+ klispT_tail_call_si(K, req, ptree, env, KNIL);
+ klisp_unlock(K);
+ /* LOCK: run while acquire the GIL again */
+ klispT_run(K);
int status = errorp? STATUS_ERROR :
(rootp? STATUS_ROOT : STATUS_CONTINUE);
@@ -600,6 +581,7 @@ static int runargs (klisp_State *K, char **argv, int n)
return STATUS_CONTINUE;
}
+/* LOCK: assume that the GIL is acquired */
static void populate_argument_lists(klisp_State *K, char **argv, int argc,
int script)
{
@@ -615,8 +597,8 @@ static void populate_argument_lists(klisp_State *K, char **argv, int argc,
}
/* Store the script argument list */
obj = ksymbol_new_b(K, "get-script-arguments", KNIL);
- klisp_assert(kbinds(K, K->ground_env, obj));
- obj = kunwrap(kget_binding(K, K->ground_env, obj));
+ klisp_assert(kbinds(K, G(K)->ground_env, obj));
+ obj = kunwrap(kget_binding(K, G(K)->ground_env, obj));
tv2op(obj)->extra[0] = tail;
while(argc > 0) {
@@ -626,8 +608,8 @@ static void populate_argument_lists(klisp_State *K, char **argv, int argc,
}
/* Store the interpreter argument list */
obj = ksymbol_new_b(K, "get-interpreter-arguments", KNIL);
- klisp_assert(kbinds(K, K->ground_env, obj));
- obj = kunwrap(kget_binding(K, K->ground_env, obj));
+ klisp_assert(kbinds(K, G(K)->ground_env, obj));
+ obj = kunwrap(kget_binding(K, G(K)->ground_env, obj));
tv2op(obj)->extra[0] = tail;
krooted_vars_pop(K);
@@ -697,7 +679,9 @@ static void pmain(klisp_State *K)
/* TEMP this could be either set before or after running the arguments,
we'll do it before for now */
+ klisp_lock(K);
populate_argument_lists(K, argv, s->argc, (script > 0) ? script : s->argc);
+ klisp_unlock(K);
s->status = runargs(K, argv, (script > 0) ? script : s->argc);
@@ -727,6 +711,9 @@ int main(int argc, char *argv[])
{
struct Smain s;
klisp_State *K = klispL_newstate();
+ /* Set the main thread as the current thread */
+ /* XXX/TEMP this could be made in run... */
+ K->thread = pthread_self();
if (K == NULL) {
k_message(argv[0], "cannot create state: not enough memory");
diff --git a/src/klisp.h b/src/klisp.h
@@ -9,9 +9,6 @@
#include <stdlib.h>
-/* NOTE: this inclusion is reversed in lua */
-#include "kobject.h"
-
/*
** SOURCE NOTE: This is mostly from Lua.
*/
@@ -31,17 +28,17 @@ typedef void * (*klisp_Alloc)
(void *ud, void *ptr, size_t osize, size_t nsize);
/*
-** prototype for callable c functions from the interpreter main loop:
-**
-** TEMP: for now it is defined in kobject.h
+** prototype for underlying c functions of continuations &
+** operatives
*/
-/* typedef void (*klisp_Ifunc) (TValue *ud, TValue val); */
+typedef void (*klisp_CFunction) (struct klisp_State *K);
/*
** state manipulation
*/
-klisp_State *klisp_newstate (klisp_Alloc f, void *ud);
-void klisp_close (klisp_State *K);
+klisp_State *klisp_newstate(klisp_Alloc f, void *ud);
+void klisp_close(klisp_State *K);
+klisp_State *klisp_newthread(klisp_State *K);
/******************************************************************************
* Copyright (C) 2011-2012 Andres Navarro, Oto Havle.
diff --git a/src/kmem.c b/src/kmem.c
@@ -9,6 +9,10 @@
** SOURCE NOTE: This is from Lua, but greatly shortened
*/
+/*
+** LOCK: Whoever calls these should have already acquired the GIL.
+*/
+
#include <stddef.h>
#include <stdio.h>
#include <assert.h>
@@ -76,26 +80,27 @@ void *klispM_realloc_ (klisp_State *K, void *block, size_t osize, size_t nsize)
/* TEMP: for now only Stop the world GC */
/* TEMP: prevent recursive call of klispC_fullgc() */
#ifdef KUSE_GC
- if (nsize > 0 && K->totalbytes - osize + nsize >= K->GCthreshold) {
+ if (nsize > 0 && G(K)->totalbytes - osize + nsize >= G(K)->GCthreshold) {
#ifdef KDEBUG_GC
- printf("GC START, total_bytes: %d\n", K->totalbytes);
+ printf("GC START, total_bytes: %d\n", G(K)->totalbytes);
#endif
klispC_fullgc(K);
#ifdef KDEBUG_GC
- printf("GC END, total_bytes: %d\n", K->totalbytes);
+ printf("GC END, total_bytes: %d\n", G(K)->totalbytes);
#endif
}
#endif
- block = (*K->frealloc)(K->ud, block, osize, nsize);
+ block = (*G(K)->frealloc)(G(K)->ud, block, osize, nsize);
if (block == NULL && nsize > 0) {
/* TEMP: try GC if there is no more mem */
/* TODO: make this a catchable error */
+ klisp_unlock_all(K);
fprintf(stderr, MEMERRMSG);
abort();
}
klisp_assert((nsize == 0) == (block == NULL));
- K->totalbytes = (K->totalbytes - osize) + nsize;
+ G(K)->totalbytes = (G(K)->totalbytes - osize) + nsize;
return block;
}
diff --git a/src/kmutex.c b/src/kmutex.c
@@ -0,0 +1,128 @@
+/*
+** kmutex.c
+** Kernel Libraries
+** See Copyright Notice in klisp.h
+*/
+
+#include "kobject.h"
+#include "kstate.h"
+#include "kmutex.h"
+#include "kmem.h"
+#include "kgc.h"
+#include "kerror.h"
+
+TValue kmake_mutex(klisp_State *K)
+{
+ Mutex *new_mutex = klispM_new(K, Mutex);
+
+ /* header + gc_fields */
+ klispC_link(K, (GCObject *) new_mutex, K_TMUTEX, 0);
+
+ /* mutex specific fields */
+ new_mutex->count = 0;
+ new_mutex->owner = KMUTEX_NO_OWNER; /* no owner */
+
+ /* XXX no attrs for now */
+ int32_t res = pthread_mutex_init(&new_mutex->mutex, NULL);
+
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, "Can't create mutex", 1,
+ i2tv(res));
+ return KNIL;
+ }
+ return gc2mutex(new_mutex);
+}
+
+/* LOCK: GIL should be acquired exactly once */
+void kmutex_lock(klisp_State *K, TValue mutex)
+{
+ TValue thread = gc2th(K);
+ if (tv_equal(thread, kmutex_owner(mutex))) {
+ if (kmutex_count(mutex) == KMUTEX_MAX_COUNT) {
+ klispE_throw_simple(K, "Mutex count overflow");
+ return;
+ }
+ ++kmutex_count(mutex);
+ } else {
+ /* we need to release GIL to avoid deadlocks */
+ klisp_unlock(K);
+ int res = pthread_mutex_lock(&kmutex_mutex(mutex));
+ klisp_lock(K);
+
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, "Can't lock mutex",
+ 1, i2tv(res));
+ return;
+ }
+
+ klisp_assert(!kmutex_is_owned(mutex));
+ kmutex_owner(mutex) = thread;
+ kmutex_count(mutex) = 1;
+ }
+}
+
+/* LOCK: GIL should be acquired exactly once */
+void kmutex_unlock(klisp_State *K, TValue mutex)
+{
+ TValue thread = gc2th(K);
+ if (!kmutex_is_owned(mutex)) {
+ klispE_throw_simple(K, "The mutex isn't locked");
+ return;
+ } else if (tv_equal(thread, kmutex_owner(mutex))) {
+ if (kmutex_count(mutex) == 1) {
+ int res = pthread_mutex_unlock(&kmutex_mutex(mutex));
+
+ if (res != 0) {
+ klispE_throw_simple_with_irritants(K, "Can't unlock mutex",
+ 1, i2tv(res));
+ return;
+ }
+
+ kmutex_owner(mutex) = KMUTEX_NO_OWNER;
+ kmutex_count(mutex) = 0;
+ } else {
+ --kmutex_count(mutex);
+ }
+ } else {
+ klispE_throw_simple(K, "The mutex is locked by a different thread");
+ return;
+ }
+}
+
+/* LOCK: GIL should be acquired exactly once */
+bool kmutex_trylock(klisp_State *K, TValue mutex)
+{
+ TValue thread = gc2th(K);
+ if (tv_equal(thread, kmutex_owner(mutex))) {
+ kmutex_lock(K, mutex); /* this will check max_count */
+ return true;
+ } else if (kmutex_is_owned(mutex)) {
+ return false;
+ } else {
+ /* we need to release GIL to avoid deadlocks */
+ klisp_unlock(K);
+ int res = pthread_mutex_trylock(&kmutex_mutex(mutex));
+ klisp_lock(K);
+
+ if (res == 0) {
+ klisp_assert(!kmutex_is_owned(mutex));
+ kmutex_owner(mutex) = thread;
+ kmutex_count(mutex) = 1;
+ return true;
+ } else if (res == EBUSY) {
+ return false;
+ } else {
+ klispE_throw_simple_with_irritants(K, "Error on trylock mutex",
+ 1, i2tv(res));
+ return false;
+ }
+ }
+}
+
+void klispX_free(klisp_State *K, Mutex *m)
+{
+/* XXX/??? Is it okay if the mutex wasn't correctly created?,
+ i.e. the contructor throwed an error*/
+ UNUSED(pthread_mutex_destroy(&m->mutex));
+ klispM_free(K, m);
+}
diff --git a/src/kmutex.h b/src/kmutex.h
@@ -0,0 +1,32 @@
+/*
+** kmutex.h
+** Kernel Libraries
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kmutex_h
+#define kmutex_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+TValue kmake_mutex(klisp_State *K);
+void klispX_free(klisp_State *K, Mutex *mutex);
+
+/* LOCK: these functions require that the calling code has
+ acquired the GIL exactly once previous to the call and
+ they may temporarily release it to avoid deadlocks */
+/* All of these do the required checks of owernship */
+void kmutex_lock(klisp_State *K, TValue mutex);
+void kmutex_unlock(klisp_State *K, TValue mutex);
+bool kmutex_trylock(klisp_State *K, TValue mutex);
+
+#define kmutex_is_owned(m_) (ttisthread(tv2mutex(m_)->owner))
+#define kmutex_owner(m_) (tv2mutex(m_)->owner)
+#define kmutex_mutex(m_) (tv2mutex(m_)->mutex)
+#define kmutex_count(m_) (tv2mutex(m_)->count)
+
+// #define KMUTEX_MAX_COUNT UINT32_MAX
+#define KMUTEX_MAX_COUNT 255
+
+#endif
diff --git a/src/kobject.h b/src/kobject.h
@@ -32,9 +32,11 @@
#include <stdint.h>
#include <stdio.h>
#include <math.h>
+#include <pthread.h>
#include "klimits.h"
#include "klispconf.h"
+#include "klisp.h"
/*
** Union of all collectible objects
@@ -42,13 +44,6 @@
typedef union GCObject GCObject;
/*
-** prototype for underlying c functions of continuations &
-** operatives
-*/
-struct klisp_State; /* later defined in kstate.h */
-typedef void (*klisp_CFunction) (struct klisp_State *K);
-
-/*
** Common Header for all collectible objects (in macro form, to be
** included in other objects)
*/
@@ -177,6 +172,9 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TVECTOR 44
#define K_TKEYWORD 45
#define K_TLIBRARY 46
+#define K_TTHREAD 47
+#define K_TMUTEX 48
+#define K_TCONDVAR 49
/* for tables */
#define K_TDEADKEY 60
@@ -234,6 +232,9 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAG_VECTOR K_MAKE_VTAG(K_TVECTOR)
#define K_TAG_KEYWORD K_MAKE_VTAG(K_TKEYWORD)
#define K_TAG_LIBRARY K_MAKE_VTAG(K_TLIBRARY)
+#define K_TAG_THREAD K_MAKE_VTAG(K_TTHREAD)
+#define K_TAG_MUTEX K_MAKE_VTAG(K_TMUTEX)
+#define K_TAG_CONDVAR K_MAKE_VTAG(K_TCONDVAR)
/*
** Macros to test types
@@ -336,6 +337,9 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisvector(o) (tbasetype_(o) == K_TAG_VECTOR)
#define ttiskeyword(o) (tbasetype_(o) == K_TAG_KEYWORD)
#define ttislibrary(o) (tbasetype_(o) == K_TAG_LIBRARY)
+#define ttisthread(o) (tbasetype_(o) == K_TAG_THREAD)
+#define ttismutex(o) (tbasetype_(o) == K_TAG_MUTEX)
+#define ttiscondvar(o) (tbasetype_(o) == K_TAG_CONDVAR)
/* macros to easily check boolean values */
#define kis_true(o_) (tv_equal((o_), KTRUE))
@@ -567,6 +571,21 @@ typedef struct __attribute__ ((__packed__)) {
TValue exp_list; /* this is an immutable list of symbols */
} Library;
+#define KMUTEX_NO_OWNER (KINERT)
+
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader; /* symbols are marked via their strings */
+ TValue owner; /* KINERT/thread currently holding this mutex */
+ pthread_mutex_t mutex;
+ uint32_t count; /* count for recursive mutex */
+} Mutex;
+
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader; /* symbols are marked via their strings */
+ TValue mutex;
+ pthread_cond_t cond;
+} Condvar;
+
/*
** `module' operation for hashing (size is always a power of 2)
*/
@@ -608,33 +627,6 @@ typedef struct __attribute__ ((__packed__)) {
} MGCheader;
/*
-** Union of all Kernel heap-allocated values
-*/
-/* LUA NOTE: In Lua the corresponding union is in lstate.h */
-union GCObject {
- GCheader gch;
- MGCheader mgch;
- Pair pair;
- Symbol sym;
- String str;
- Environment env;
- Continuation cont;
- Operative op;
- Applicative app;
- Encapsulation enc;
- Promise prom;
- Table table;
- Bytevector bytevector;
- Port port; /* common fields for all types of ports */
- FPort fport;
- MPort mport;
- Vector vector;
- Keyword keyw;
- Library lib;
-};
-
-
-/*
** Some constants
*/
#define KNIL_ {.tv = {.t = K_TAG_NIL, .v = { .i = 0 }}}
@@ -747,6 +739,9 @@ const TValue kfree;
#define gc2vector(o_) (gc2tv(K_TAG_VECTOR, o_))
#define gc2keyw(o_) (gc2tv(K_TAG_KEYWORD, o_))
#define gc2lib(o_) (gc2tv(K_TAG_LIBRARY, o_))
+#define gc2th(o_) (gc2tv(K_TAG_THREAD, o_))
+#define gc2mutex(o_) (gc2tv(K_TAG_MUTEX, o_))
+#define gc2condvar(o_) (gc2tv(K_TAG_CONDVAR, o_))
#define gc2deadkey(o_) (gc2tv(K_TAG_DEADKEY, o_))
/* Macro to convert a TValue into a specific heap allocated object */
@@ -770,6 +765,9 @@ const TValue kfree;
#define tv2port(v_) ((Port *) gcvalue(v_))
#define tv2keyw(v_) ((Keyword *) gcvalue(v_))
#define tv2lib(v_) ((Library *) gcvalue(v_))
+#define tv2th(v_) ((klisp_State *) gcvalue(v_))
+#define tv2mutex(v_) ((Mutex *) gcvalue(v_))
+#define tv2condvar(v_) ((Condvar *) gcvalue(v_))
#define tv2gch(v_) ((GCheader *) gcvalue(v_))
#define tv2mgch(v_) ((MGCheader *) gcvalue(v_))
@@ -927,9 +925,9 @@ int32_t kmark_count;
#define checkconsistency(obj) \
klisp_assert(!iscollectable(obj) || (ttype_(obj) == gcvalue(obj)->gch.tt))
-#define checkliveness(k,obj) \
+#define checkliveness(g,obj) \
klisp_assert(!iscollectable(obj) || \
- ((ttype_(obj) == gcvalue(obj)->gch.tt) && !isdead(k, gcvalue(obj))))
+ ((ttype_(obj) == gcvalue(obj)->gch.tt) && !isdead(g, gcvalue(obj))))
#endif
diff --git a/src/kport.c b/src/kport.c
@@ -146,7 +146,7 @@ TValue kmake_mport(klisp_State *K, TValue buffer, bool writep, bool binaryp)
/* port specific fields */
TValue tv_port = gc2mport(new_port);
- kport_filename(tv_port) = K->empty_string; /* XXX for now no filename */
+ kport_filename(tv_port) = G(K)->empty_string; /* XXX for now no filename */
/* line is 1-based and col is 0-based */
kport_line(tv_port) = 1;
kport_col(tv_port) = 0;
diff --git a/src/krepl.c b/src/krepl.c
@@ -43,7 +43,7 @@ void do_repl_read(klisp_State *K)
/* show prompt */
fprintf(stdout, KLISP_PROMPT);
- TValue port = kcdr(K->kd_in_port_key);
+ TValue port = kcdr(G(K)->kd_in_port_key);
klisp_assert(kfport_file(port) == stdin);
/* Workaround to the problem of the dangling '\n' in repl
(from previous line) */
@@ -70,7 +70,7 @@ void do_repl_eval(klisp_State *K)
/* print a newline to allow the shell a fresh line */
printf("\n");
/* This is ok because there is no interception possible */
- kset_cc(K, K->root_cont);
+ kset_cc(K, G(K)->root_cont);
kapply_cc(K, KINERT);
} else {
/* save the source code info of the object in loop_cont
@@ -93,7 +93,7 @@ void create_loop(klisp_State *K, TValue denv)
TValue error_int = kmake_operative(K, do_repl_int_error, 1, denv);
krooted_tvs_pop(K); /* already in cont */
krooted_tvs_push(K, error_int);
- TValue exit_guard = kcons(K, K->error_cont, error_int);
+ TValue exit_guard = kcons(K, G(K)->error_cont, error_int);
krooted_tvs_pop(K); /* already in guard */
krooted_tvs_push(K, exit_guard);
TValue exit_guards = kcons(K, exit_guard, KNIL);
@@ -105,7 +105,7 @@ void create_loop(klisp_State *K, TValue denv)
/* this is needed for interception code */
TValue env = kmake_empty_environment(K);
krooted_tvs_push(K, env);
- TValue outer_cont = kmake_continuation(K, K->root_cont,
+ TValue outer_cont = kmake_continuation(K, G(K)->root_cont,
do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
krooted_tvs_push(K, outer_cont);
@@ -140,7 +140,7 @@ void do_repl_loop(klisp_State *K)
** xparams[0]: dynamic environment
*/
- TValue port = kcdr(K->kd_out_port_key);
+ TValue port = kcdr(G(K)->kd_out_port_key);
klisp_assert(kfport_file(port) == stdout);
/* false: quote strings, escape chars */
@@ -171,7 +171,7 @@ void do_repl_int_error(klisp_State *K)
TValue divert = kcadr(ptree);
/* FOR NOW used only for irritant list */
- TValue port = kcdr(K->kd_error_port_key);
+ TValue port = kcdr(G(K)->kd_error_port_key);
klisp_assert(ttisfport(port) && kfport_file(port) == stderr);
/* TEMP: obj should be an error obj */
@@ -246,6 +246,7 @@ void do_repl_int_error(klisp_State *K)
/* call this to init the repl in a newly created klisp state */
/* the standard environment should be in K->next_env */
+/* LOCK: the GIL should be acquired */
void kinit_repl(klisp_State *K)
{
TValue std_env = K->next_env;
@@ -254,7 +255,7 @@ void kinit_repl(klisp_State *K)
/* save the root cont in next_si to let the loop continuations have
source info, this is hackish but works */
- K->next_si = ktry_get_si(K, K->root_cont);
+ K->next_si = ktry_get_si(K, G(K)->root_cont);
#endif
/* GC: create_loop will root std_env */
@@ -264,7 +265,8 @@ void kinit_repl(klisp_State *K)
/* init continuation names */
void kinit_repl_cont_names(klisp_State *K)
{
- Table *t = tv2table(K->cont_name_table);
+/* XXX lock? */
+ Table *t = tv2table(G(K)->cont_name_table);
add_cont_name(K, t, do_repl_read, "repl-read");
add_cont_name(K, t, do_repl_eval, "repl-eval");
add_cont_name(K, t, do_repl_loop, "repl-print-loop");
diff --git a/src/kstate.c b/src/kstate.c
@@ -17,6 +17,7 @@
#include <stddef.h>
#include <setjmp.h>
#include <string.h>
+#include <pthread.h>
#include "klisp.h"
#include "klimits.h"
@@ -44,29 +45,64 @@
#include "kgc.h" /* for memory freeing & gc init */
+/* in lua state size can have an extra space here to save
+ some user data, for now we don't have that in klisp */
+#define state_size(x) (sizeof(x) + 0)
+#define fromstate(k) (cast(uint8_t *, (k)) - 0)
+#define tostate(k) (cast(klisp_State *, cast(uint8_t *, k) + 0))
+
/*
-** State creation and destruction
+** Main thread combines a thread state and the global state
*/
-klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
- klisp_State *K;
- void *k = (*f)(ud, NULL, 0, state_size());
- if (k == NULL) return NULL;
- void *s = (*f)(ud, NULL, 0, KS_ISSIZE * sizeof(TValue));
+typedef struct KG {
+ klisp_State k;
+ global_State g;
+} KG;
+
+/*
+** open parts that may cause memory-allocation errors
+*/
+/* TODO move other stuff that cause allocs here */
+static void f_klispopen (klisp_State *K, void *ud) {
+ global_State *g = G(K);
+ UNUSED(ud);
+ klispS_resize(K, MINSTRTABSIZE); /* initial size of string table */
+
+ void *s = (*g->frealloc)(ud, NULL, 0, KS_ISSIZE * sizeof(TValue));
if (s == NULL) {
- (*f)(ud, k, state_size(), 0);
- return NULL;
+ return; /* XXX throw error somehow & free mem */
}
- void *b = (*f)(ud, NULL, 0, KS_ITBSIZE);
+ void *b = (*g->frealloc)(ud, NULL, 0, KS_ITBSIZE);
if (b == NULL) {
- (*f)(ud, k, state_size(), 0);
- (*f)(ud, s, KS_ISSIZE * sizeof(TValue), 0);
- return NULL;
+ return; /* XXX throw error somehow & free mem */
}
- K = (klisp_State *) k;
+ /* initialize temp stacks */
+ ks_ssize(K) = KS_ISSIZE;
+ ks_stop(K) = 0; /* stack is empty */
+ ks_sbuf(K) = (TValue *)s;
- K->curr_cont = KNIL;
+ ks_tbsize(K) = KS_ITBSIZE;
+ ks_tbidx(K) = 0; /* buffer is empty */
+ ks_tbuf(K) = (char *)b;
+
+ /* (at least for now) we'll use a non recursive mutex for the GIL */
+ /* XXX/TODO check return code */
+ pthread_mutex_init(&g->gil, NULL);
+
+/* This is here in lua, but in klisp we still need to alloc
+ a bunch of objects:
+ g->GCthreshold = 4*g->totalbytes;
+*/
+}
+
+static void preinit_state (klisp_State *K, global_State *g) {
+ G(K) = g;
+
+ K->status = KLISP_THREAD_CREATED;
+ K->gil_count = 0;
+ K->curr_cont = KNIL;
K->next_obj = KINERT;
K->next_func = NULL;
K->next_value = KINERT;
@@ -74,123 +110,213 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->next_xparams = NULL;
K->next_si = KNIL;
- /* these will be properly initialized later */
- K->eval_op = KINERT;
- K->list_app = KINERT;
- K->ground_env = KINERT;
- K->module_params_sym = KINERT;
- K->root_cont = KINERT;
- K->error_cont = KINERT;
- K->system_error_cont = KINERT;
-
- K->frealloc = f;
- K->ud = ud;
-
/* current input and output */
K->curr_port = KINERT; /* set on each call to read/write */
+ /* init the stacks used to protect variables & values from gc,
+ this should be done before any new object is created because
+ they are used by them */
+ K->rooted_tvs_top = 0;
+ K->rooted_vars_top = 0;
+
+ /* initialize tokenizer */
+
+ /* WORKAROUND: for stdin line buffering & reading of EOF */
+ K->ktok_seen_eof = false;
+
+ /* TEMP: For now just hardcode it to 8 spaces tab-stop */
+ K->ktok_source_info.tab_width = 8;
+ /* all three are set on each call to read */
+ K->ktok_source_info.filename = KINERT;
+ K->ktok_source_info.line = 1;
+ K->ktok_source_info.col = 0;
+
+ K->ktok_nested_comments = 0;
+
+ /* initialize reader */
+ K->shared_dict = KNIL;
+ K->read_mconsp = false; /* set on each call to read */
+
+ /* initialize writer */
+ K->write_displayp = false; /* set on each call to write */
+
+ /* put zeroes first, in case alloc fails */
+ ks_stop(K) = 0;
+ ks_ssize(K) = 0;
+ ks_sbuf(K) = NULL;
+
+ ks_tbidx(K) = 0;
+ ks_tbsize(K) = 0;
+ ks_tbuf(K) = NULL;
+}
+
+/* LOCK: GIL should be acquired */
+static void close_state(klisp_State *K)
+{
+ global_State *g = G(K);
+
+ /* collect all objects */
+ klispC_freeall(K);
+ klisp_assert(g->rootgc == obj2gco(K));
+ klisp_assert(g->strt.nuse == 0);
+
+ /* free helper buffers */
+ klispM_freemem(K, ks_sbuf(K), ks_ssize(K) * sizeof(TValue));
+ klispM_freemem(K, ks_tbuf(K), ks_tbsize(K));
+ /* free string/symbol table */
+ klispM_freearray(K, g->strt.hash, g->strt.size, GCObject *);
+
+ /* destroy the GIL */
+ pthread_mutex_destroy(&g->gil);
+
+ /* only remaining mem should be of the state struct */
+ klisp_assert(g->totalbytes == sizeof(KG));
+ /* NOTE: this needs to be done "by hand" */
+ (*g->frealloc)(g->ud, fromstate(K), state_size(KG), 0);
+}
+
+/*
+** State creation and destruction
+*/
+klisp_State *klisp_newstate(klisp_Alloc f, void *ud)
+{
+ klisp_State *K;
+ global_State *g;
+
+ void *k = (*f)(ud, NULL, 0, state_size(KG));
+ if (k == NULL) return NULL;
+ K = tostate(k);
+ g = &((KG *)K)->g;
+ /* Init klisp_State object header (for GC) */
+ K->next = NULL;
+ K->tt = K_TTHREAD;
+ K->kflags = 0;
+ K->si = NULL;
+ g->currentwhite = bit2mask(WHITE0BIT, FIXEDBIT);
+ K->gct = klispC_white(g);
+ set2bits(K->gct, FIXEDBIT, SFIXEDBIT);
+
+ preinit_state(K, g);
+
+ ktok_init(K); /* initialize tokenizer tables */
+ g->frealloc = f;
+ g->ud = ud;
+ g->mainthread = K;
+
+ g->GCthreshold = 0; /* mark it as unfinished state */
+
+ /* these will be properly initialized later */
+ g->strt.size = 0;
+ g->strt.nuse = 0;
+ g->strt.hash = NULL;
+ g->name_table = KINERT;
+ g->cont_name_table = KINERT;
+ g->thread_table = KINERT;
+
+ g->empty_string = KINERT;
+ g->empty_bytevector = KINERT;
+ g->empty_vector = KINERT;
+
+ g->ktok_lparen = KINERT;
+ g->ktok_rparen = KINERT;
+ g->ktok_dot = KINERT;
+ g->ktok_sexp_comment = KINERT;
+
+ g->require_path = KINERT;
+ g->require_table = KINERT;
+ g->libraries_registry = KINERT;
+
+ g->eval_op = KINERT;
+ g->list_app = KINERT;
+ g->memoize_app = KINERT;
+ g->ground_env = KINERT;
+ g->module_params_sym = KINERT;
+ g->root_cont = KINERT;
+ g->error_cont = KINERT;
+ g->system_error_cont = KINERT;
+
/* input / output for dynamic keys */
/* these are init later */
- K->kd_in_port_key = KINERT;
- K->kd_out_port_key = KINERT;
- K->kd_error_port_key = KINERT;
+ g->kd_in_port_key = KINERT;
+ g->kd_out_port_key = KINERT;
+ g->kd_error_port_key = KINERT;
/* strict arithmetic dynamic key */
/* this is init later */
- K->kd_strict_arith_key = KINERT;
+ g->kd_strict_arith_key = KINERT;
+
+ g->gcstate = GCSpause;
+ g->rootgc = obj2gco(K); /* was NULL in unithread klisp... CHECK */
+ g->sweepstrgc = 0;
+ g->sweepgc = &g->rootgc;
+ g->gray = NULL;
+ g->grayagain = NULL;
+ g->weak = NULL;
+ g->tmudata = NULL;
+ g->totalbytes = sizeof(KG);
+ g->gcpause = KLISPI_GCPAUSE;
+ g->gcstepmul = KLISPI_GCMUL;
+ g->gcdept = 0;
/* GC */
- K->currentwhite = bit2mask(WHITE0BIT, FIXEDBIT);
- K->gcstate = GCSpause;
- K->sweepstrgc = 0;
- K->rootgc = NULL;
- K->sweepgc = &(K->rootgc);
- K->gray = NULL;
- K->grayagain = NULL;
- K->weak = NULL;
- K->tmudata = NULL;
- K->totalbytes = state_size() + KS_ISSIZE * sizeof(TValue) +
+ g->totalbytes = state_size(KG) + KS_ISSIZE * sizeof(TValue) +
KS_ITBSIZE;
- K->GCthreshold = UINT32_MAX; /* we still have a lot of allocation
+ g->GCthreshold = UINT32_MAX; /* we still have a lot of allocation
+ to do, put a very high value to
+ avoid collection */
+ g->estimate = 0; /* doesn't matter, it is set by gc later */
+ /* XXX Things start being ugly from here on...
+ I have to think about the whole init procedure, for now
+ I am mostly following lua, but the differences between it and
+ klisp show... We still have to allocate a lot of objects and
+ it isn't really clear what happens if we run out of space before
+ all objects are allocated. For now let's suppose that will not
+ happen... */
+ /* TODO handle errors, maybe with longjmp, also see lua
+ luaD_rawrunprotected */
+ f_klispopen(K, NULL); /* this touches GCthreshold */
+
+ g->GCthreshold = UINT32_MAX; /* we still have a lot of allocation
to do, put a very high value to
avoid collection */
- K->estimate = 0; /* doesn't matter, it is set by gc later */
- K->gcdept = 0;
- K->gcpause = KLISPI_GCPAUSE;
- K->gcstepmul = KLISPI_GCMUL;
/* TEMP: err */
+ /* THIS MAY CRASH THE INTERPRETER IF THERE IS AN ERROR IN THE INIT */
/* do nothing for now */
- /* init the stacks used to protect variables & values from gc,
- this should be done before any new object is created because
- they are used by them */
- K->rooted_tvs_top = 0;
- K->rooted_vars_top = 0;
-
/* initialize strings */
- /* initial size of string/symbol table */
- K->strt.size = 0;
- K->strt.nuse = 0;
- K->strt.hash = NULL;
- klispS_resize(K, MINSTRTABSIZE);
-
/* initialize name info table */
/* needs weak keys, otherwise every named object would
be fixed! */
- K->name_table = klispH_new(K, 0, MINNAMETABSIZE,
+ g->name_table = klispH_new(K, 0, MINNAMETABSIZE,
K_FLAG_WEAK_KEYS);
/* here the keys are uncollectable */
- K->cont_name_table = klispH_new(K, 0, MINCONTNAMETABSIZE,
+ g->cont_name_table = klispH_new(K, 0, MINCONTNAMETABSIZE,
K_FLAG_WEAK_NOTHING);
+ /* here the keys are uncollectable */
+ g->thread_table = klispH_new(K, 0, MINTHREADTABSIZE,
+ K_FLAG_WEAK_NOTHING);
/* Empty string */
/* MAYBE: fix it so we can remove empty_string from roots */
- K->empty_string = kstring_new_b_imm(K, "");
+ g->empty_string = kstring_new_b_imm(K, "");
/* Empty bytevector */
/* MAYBE: fix it so we can remove empty_bytevector from roots */
/* XXX: find a better way to do this */
- K->empty_bytevector = KNIL; /* trick constructor to create empty bytevector */
- K->empty_bytevector = kbytevector_new_bs_imm(K, NULL, 0);
+ g->empty_bytevector = KNIL; /* trick constructor to create empty bytevector */
+ g->empty_bytevector = kbytevector_new_bs_imm(K, NULL, 0);
/* Empty vector */
/* MAYBE: see above */
- K->empty_vector = kvector_new_bs_g(K, false, NULL, 0);
-
- /* initialize tokenizer */
-
- /* WORKAROUND: for stdin line buffering & reading of EOF */
- K->ktok_seen_eof = false;
-
- ks_tbsize(K) = KS_ITBSIZE;
- ks_tbidx(K) = 0; /* buffer is empty */
- ks_tbuf(K) = (char *)b;
+ g->empty_vector = kvector_new_bs_g(K, false, NULL, 0);
/* Special Tokens */
- K->ktok_lparen = kcons(K, ch2tv('('), KNIL);
- K->ktok_rparen = kcons(K, ch2tv(')'), KNIL);
- K->ktok_dot = kcons(K, ch2tv('.'), KNIL);
- K->ktok_sexp_comment = kcons(K, ch2tv(';'), KNIL);
-
- /* TEMP: For now just hardcode it to 8 spaces tab-stop */
- K->ktok_source_info.tab_width = 8;
- /* all three are set on each call to read */
- K->ktok_source_info.filename = KINERT;
- K->ktok_source_info.line = 1;
- K->ktok_source_info.col = 0;
-
- K->ktok_nested_comments = 0;
-
- ktok_init(K);
-
- /* initialize reader */
- K->shared_dict = KNIL;
- K->read_mconsp = false; /* set on each call to read */
-
- /* initialize writer */
- K->write_displayp = false; /* set on each call to write */
+ g->ktok_lparen = kcons(K, ch2tv('('), KNIL);
+ g->ktok_rparen = kcons(K, ch2tv(')'), KNIL);
+ g->ktok_dot = kcons(K, ch2tv('.'), KNIL);
+ g->ktok_sexp_comment = kcons(K, ch2tv(';'), KNIL);
/* initialize require facilities */
{
@@ -198,22 +324,17 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
if (str == NULL)
str = KLISP_PATH_DEFAULT;
- K->require_path = kstring_new_b_imm(K, str);
+ g->require_path = kstring_new_b_imm(K, str);
/* replace dirsep with forward slashes,
windows will happily accept forward slashes */
- str = kstring_buf(K->require_path);
+ str = kstring_buf(g->require_path);
while ((str = strchr(str, *KLISP_DIRSEP)) != NULL)
*str++ = '/';
}
- K->require_table = klispH_new(K, 0, MINREQUIRETABSIZE, 0);
+ g->require_table = klispH_new(K, 0, MINREQUIRETABSIZE, 0);
/* initialize library facilities */
- K->libraries_registry = KNIL;
-
- /* initialize temp stack */
- K->ssize = KS_ISSIZE;
- K->stop = 0; /* stack is empty */
- K->sbuf = (TValue *)s;
+ g->libraries_registry = KNIL;
/* the dynamic ports and the keys for the dynamic ports */
TValue in_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDIN*"),
@@ -222,115 +343,153 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
true, false, stdout);
TValue error_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDERR*"),
true, false, stderr);
- K->kd_in_port_key = kcons(K, KTRUE, in_port);
- K->kd_out_port_key = kcons(K, KTRUE, out_port);
- K->kd_error_port_key = kcons(K, KTRUE, error_port);
+ g->kd_in_port_key = kcons(K, KTRUE, in_port);
+ g->kd_out_port_key = kcons(K, KTRUE, out_port);
+ g->kd_error_port_key = kcons(K, KTRUE, error_port);
/* strict arithmetic key, (starts as false) */
- K->kd_strict_arith_key = kcons(K, KTRUE, KFALSE);
+ g->kd_strict_arith_key = kcons(K, KTRUE, KFALSE);
/* create the ground environment and the eval operative */
int32_t line_number;
TValue si;
- K->eval_op = kmake_operative(K, keval_ofn, 0), line_number = __LINE__;
+ g->eval_op = kmake_operative(K, keval_ofn, 0), line_number = __LINE__;
#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
kcons(K, i2tv(line_number), i2tv(0)));
- kset_source_info(K, K->eval_op, si);
+ kset_source_info(K, g->eval_op, si);
#endif
/* TODO: si */
TValue eval_name = ksymbol_new_b(K, "eval", KNIL);
- ktry_set_name(K, K->eval_op, eval_name);
+ ktry_set_name(K, g->eval_op, eval_name);
- K->list_app = kmake_applicative(K, list, 0), line_number = __LINE__;
+ g->list_app = kmake_applicative(K, list, 0), line_number = __LINE__;
#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
kcons(K, i2tv(__LINE__), i2tv(0)));
- kset_source_info(K, K->list_app, si);
- kset_source_info(K, kunwrap(K->list_app), si);
+ kset_source_info(K, g->list_app, si);
+ kset_source_info(K, kunwrap(g->list_app), si);
#endif
- K->memoize_app = kmake_applicative(K, memoize, 0), line_number = __LINE__;
+ g->memoize_app = kmake_applicative(K, memoize, 0), line_number = __LINE__;
#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
kcons(K, i2tv(__LINE__), i2tv(0)));
- kset_source_info(K, K->memoize_app, si);
- kset_source_info(K, kunwrap(K->memoize_app), si);
+ kset_source_info(K, g->memoize_app, si);
+ kset_source_info(K, kunwrap(g->memoize_app), si);
#endif
/* ground environment has a hashtable for bindings */
- K->ground_env = kmake_table_environment(K, KNIL);
-// K->ground_env = kmake_empty_environment(K);
+ g->ground_env = kmake_table_environment(K, KNIL);
+// g->ground_env = kmake_empty_environment(K);
/* MAYBE: fix it so we can remove module_params_sym from roots */
/* TODO si */
- K->module_params_sym = ksymbol_new_b(K, "module-parameters", KNIL);
-
- /* Create the root and error continuation (will be added to the
- environment in kinit_ground_env) */
- K->root_cont = kmake_continuation(K, KNIL, do_root_exit, 0);
-
-#if KTRACK_SI
- /* Add source info to the cont */
- TValue str = kstring_new_b_imm(K, __FILE__);
- TValue tail = kcons(K, i2tv(__LINE__), i2tv(0));
- si = kcons(K, str, tail);
- kset_source_info(K, K->root_cont, si);
-#endif
+ g->module_params_sym = ksymbol_new_b(K, "module-parameters", KNIL);
- K->error_cont = kmake_continuation(K, K->root_cont, do_error_exit, 0);
-
-#if KTRACK_SI
- str = kstring_new_b_imm(K, __FILE__);
- tail = kcons(K, i2tv(__LINE__), i2tv(0));
- si = kcons(K, str, tail);
- kset_source_info(K, K->error_cont, si);
-#endif
-
- /* this must be done before calling kinit_ground_env */
- kinit_error_hierarchy(K);
kinit_ground_env(K);
kinit_cont_names(K);
- /* create a std environment and leave it in K->next_env */
- K->next_env = kmake_table_environment(K, K->ground_env);
+ /* put the main thread in the thread table */
+ TValue *node = klispH_set(K, tv2table(g->thread_table), gc2th(K));
+ *node = KTRUE;
+
+ /* create a std environment and leave it in g->next_env */
+ K->next_env = kmake_table_environment(K, g->ground_env);
/* set the threshold for gc start now that we have allocated all mem */
- K->GCthreshold = 4*K->totalbytes;
+ g->GCthreshold = 4*g->totalbytes;
+ /* luai_userstateopen(L); */
return K;
}
-/*
-** Root and Error continuations
-*/
-void do_root_exit(klisp_State *K)
+/* this is in api.c in lua */
+klisp_State *klisp_newthread(klisp_State *K)
{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- UNUSED(xparams);
-
- /* Just save the value and end the loop */
- K->next_value = obj;
- K->next_func = NULL; /* force the loop to terminate */
- return;
+ /* TODO */
+ return NULL;
}
-void do_error_exit(klisp_State *K)
+klisp_State *klispT_newthread(klisp_State *K)
{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- UNUSED(xparams);
+ klisp_State *K1 = tostate(klispM_malloc(K, state_size(klisp_State)));
+ klispC_link(K, (GCObject *) K1, K_TTHREAD, 0);
- /* TEMP Just pass the error to the root continuation */
- kapply_cc(K, obj);
+ preinit_state(K1, G(K));
+
+ /* protect from gc */
+ krooted_tvs_push(K, gc2th(K1));
+
+ /* initialize temp stacks */
+ ks_sbuf(K1) = (TValue *) klispM_malloc(K, KS_ISSIZE * sizeof(TValue));
+ ks_ssize(K1) = KS_ISSIZE;
+ ks_stop(K1) = 0; /* stack is empty */
+
+ ks_tbuf(K1) = (char *) klispM_malloc(K, KS_ITBSIZE);
+ ks_tbsize(K1) = KS_ITBSIZE;
+ ks_tbidx(K1) = 0; /* buffer is empty */
+
+ /* initialize condition variable for joining */
+ int32_t ret = pthread_cond_init(&K1->joincond, NULL);
+
+ if (ret != 0) {
+ klispE_throw_simple_with_irritants(K, "Error creating joincond for "
+ "new thread", 1, i2tv(ret));
+ return NULL;
+ }
+
+ /* everything went well, put the thread in the thread table */
+ TValue *node = klispH_set(K, tv2table(G(K)->thread_table), gc2th(K1));
+ *node = KTRUE;
+ krooted_tvs_pop(K);
+
+ klisp_assert(iswhite((GCObject *) (K1)));
+ return K1;
+}
+
+
+void klispT_freethread (klisp_State *K, klisp_State *K1)
+{
+ /* main thread can't come here, so it's safe to remove the
+ condvar here */
+ int32_t ret = pthread_cond_destroy(&K1->joincond);
+ klisp_assert(ret == 0); /* shouldn't happen */
+
+ klispM_freemem(K, ks_sbuf(K1), ks_ssize(K1) * sizeof(TValue));
+ klispM_freemem(K, ks_tbuf(K1), ks_tbsize(K1));
+ /* userstatefree() */
+ klispM_freemem(K, fromstate(K1), state_size(klisp_State));
+}
+
+void klisp_close (klisp_State *K)
+{
+ K = G(K)->mainthread; /* only the main thread can be closed */
+
+ klisp_lock(K);
+/* XXX lua does the following */
+#if 0
+ lua_lock(L);
+ luaF_close(L, L->stack); /* close all upvalues for this thread */
+ luaC_separateudata(L, 1); /* separate udata that have GC metamethods */
+ L->errfunc = 0; /* no error function during GC metamethods */ /* free all collectable objects */
+ do { /* repeat until no more errors */
+ L->ci = L->base_ci;
+ L->base = L->top = L->ci->base;
+ L->nCcalls = L->baseCcalls = 0;
+ } while (luaD_rawrunprotected(L, callallgcTM, NULL) != 0);
+ lua_assert(G(L)->tmudata == NULL);
+ luai_userstateclose(L);
+#endif
+
+ /* luai_userstateclose(L); */
+ close_state(K);
}
/*
** Stacks memory management
*/
+/* LOCK: All these functions should be called with the GIL already acquired */
/* TODO test this */
void ks_sgrow(klisp_State *K, int32_t new_top)
{
@@ -372,7 +531,7 @@ void ks_tbgrow(klisp_State *K, int32_t new_top)
size_t new_size = old_size * 2;
while(new_top > new_size)
new_size *= 2;
-
+
ks_tbuf(K) = klispM_realloc_(K, ks_tbuf(K), old_size*sizeof(TValue),
new_size*sizeof(TValue));
ks_tbsize(K) = new_size;
@@ -394,198 +553,6 @@ void ks_tbshrink(klisp_State *K, int32_t new_top)
ks_tbsize(K) = new_size;
}
-
-/*
-**
-** This is for handling interceptions
-** TODO: move to a different file
-**
-*/
-
-/*
-** This is used to determine if cont is in the dynamic extent of
-** some other continuation. That's the case iff that continuation
-** was marked by the call to mark_iancestors(cont)
-*/
-
-/* TODO: maybe add some inlines here, profile first and check size difference */
-void mark_iancestors(TValue cont)
-{
- while(!ttisnil(cont)) {
- kmark(cont);
- cont = tv2cont(cont)->parent;
- }
-}
-
-void unmark_iancestors(TValue cont)
-{
- while(!ttisnil(cont)) {
- kunmark(cont);
- cont = tv2cont(cont)->parent;
- }
-}
-
-/*
-** Returns the first interceptor whose dynamic extent includes cont
-** or nil if there isn't any. The cont is implicitly passed because
-** all of its improper ancestors are marked.
-*/
-TValue select_interceptor(TValue guard_ls)
-{
- /* the guard list can't be cyclic, that case is
- replaced by a simple list while copyng guards */
- while(!ttisnil(guard_ls)) {
- /* entry is (selector . interceptor-op) */
- TValue entry = kcar(guard_ls);
- TValue selector = kcar(entry);
- if (kis_marked(selector))
- return kcdr(entry); /* only interceptor is important */
- guard_ls = kcdr(guard_ls);
- }
- return KNIL;
-}
-
-/*
-** Returns a list of entries like the following:
-** (interceptor-op outer_cont . denv)
-*/
-
-/* GC: assume src_cont & dst_cont are rooted */
-static inline TValue create_interception_list(klisp_State *K, TValue src_cont,
- TValue dst_cont)
-{
- mark_iancestors(dst_cont);
- TValue ilist = kcons(K, KNIL, KNIL);
- krooted_vars_push(K, &ilist);
- TValue tail = ilist;
- TValue cont = src_cont;
-
- /* exit guards are from the inside to the outside, and
- selected by destination */
-
- /* the loop is until we find the common ancestor, that has to be marked */
- while(!kis_marked(cont)) {
- /* only inner conts have exit guards */
- if (kis_inner_cont(cont)) {
- klisp_assert(tv2cont(cont)->extra_size > 1);
- TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
-
- TValue interceptor = select_interceptor(entries);
- if (!ttisnil(interceptor)) {
- /* TODO make macros */
- TValue denv = tv2cont(cont)->extra[1];
- TValue outer = tv2cont(cont)->parent;
- TValue outer_denv = kcons(K, outer, denv);
- krooted_tvs_push(K, outer_denv);
- TValue new_entry = kcons(K, interceptor, outer_denv);
- krooted_tvs_pop(K); /* already in entry */
- krooted_tvs_push(K, new_entry);
- TValue new_pair = kcons(K, new_entry, KNIL);
- krooted_tvs_pop(K);
- kset_cdr(tail, new_pair);
- tail = new_pair;
- }
- }
- cont = tv2cont(cont)->parent;
- }
- unmark_iancestors(dst_cont);
-
- /* entry guards are from the outside to the inside, and
- selected by source, we create the list from the outside
- by cons and then append it to the exit list to avoid
- reversing */
- mark_iancestors(src_cont);
-
- cont = dst_cont;
- TValue entry_int = KNIL;
- krooted_vars_push(K, &entry_int);
-
- while(!kis_marked(cont)) {
- /* only outer conts have entry guards */
- if (kis_outer_cont(cont)) {
- klisp_assert(tv2cont(cont)->extra_size > 1);
- TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
- /* this is rooted because it's a substructure of entries */
- TValue interceptor = select_interceptor(entries);
- if (!ttisnil(interceptor)) {
- /* TODO make macros */
- TValue denv = tv2cont(cont)->extra[1];
- TValue outer = cont;
- TValue outer_denv = kcons(K, outer, denv);
- krooted_tvs_push(K, outer_denv);
- TValue new_entry = kcons(K, interceptor, outer_denv);
- krooted_tvs_pop(K); /* already in entry */
- krooted_tvs_push(K, new_entry);
- entry_int = kcons(K, new_entry, entry_int);
- krooted_tvs_pop(K);
- }
- }
- cont = tv2cont(cont)->parent;
- }
-
- unmark_iancestors(src_cont);
-
- /* all interceptions collected, append the two lists and return */
- kset_cdr(tail, entry_int);
- krooted_vars_pop(K);
- krooted_vars_pop(K);
- return kcdr(ilist);
-}
-
-/* this passes the operand tree to the continuation */
-void cont_app(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue ptree = K->next_value;
- TValue denv = K->next_env;
- klisp_assert(ttisenvironment(K->next_env));
- UNUSED(denv);
- TValue cont = xparams[0];
- /* guards and dynamic variables are handled in kcall_cont() */
- kcall_cont(K, cont, ptree);
-}
-
-void do_interception(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- /*
- ** xparams[0]:
- ** xparams[1]: dst cont
- */
- TValue ls = xparams[0];
- TValue dst_cont = xparams[1];
- if (ttisnil(ls)) {
- /* all interceptors returned normally */
- /* this is a normal pass/not subject to interception */
- kset_cc(K, dst_cont);
- kapply_cc(K, obj);
- } else {
- /* call the operative with the passed obj and applicative
- for outer cont as ptree in the dynamic environment of
- the corresponding call to guard-continuation in the
- dynamic extent of the associated outer continuation.
- If the operative normally returns a value, others
- interceptions should be scheduled */
- TValue first = kcar(ls);
- TValue op = kcar(first);
- TValue outer = kcadr(first);
- TValue denv = kcddr(first);
- TValue app = kmake_applicative(K, cont_app, 1, outer);
- krooted_tvs_push(K, app);
- TValue ptree = klist(K, 2, obj, app);
- krooted_tvs_pop(K); /* already in ptree */
- krooted_tvs_push(K, ptree);
- TValue new_cont = kmake_continuation(K, outer, do_interception,
- 2, kcdr(ls), dst_cont);
- kset_cc(K, new_cont);
- krooted_tvs_pop(K);
- /* XXX: what to pass as si? */
- ktail_call(K, op, ptree, denv);
- }
-}
-
/* GC: Don't assume anything about obj & dst_cont, they may not be rooted.
In the most common case of apply-continuation & continuation->applicative
they are rooted, but in general there's no way to protect them, because
@@ -618,53 +585,42 @@ void kcall_cont(klisp_State *K, TValue dst_cont, TValue obj)
** TODO: do that
*/
kset_cc(K, new_cont);
- klispS_apply_cc(K, obj);
+ klispT_apply_cc(K, obj);
longjmp(K->error_jb, 1);
}
-void klispS_init_repl(klisp_State *K)
+void klispT_init_repl(klisp_State *K)
{
/* this is in krepl.c */
kinit_repl(K);
}
-void klispS_run(klisp_State *K)
+/*
+** TEMP/LOCK: put lock here, until all operatives and continuations do locking directly
+** or a new interface (like lua api) does it for them.
+** This has the problem that nothing can be done in parallel (but still has the advantage
+** that (unlike coroutines) when one thread is blocked (e.g. waiting for IO) the others
+** may continue (provided that the blocked thread unlocks the GIL before blocking...)
+*/
+void klispT_run(klisp_State *K)
{
while(true) {
if (setjmp(K->error_jb)) {
/* continuation called */
/* TEMP: do nothing, the loop will call the continuation */
+ klisp_unlock_all(K);
} else {
+ klisp_lock(K);
/* all ok, continue with next func */
while (K->next_func) {
/* next_func is either operative or continuation
but in any case the call is the same */
(*(K->next_func))(K);
+ klispi_threadyield(K);
}
/* K->next_func is NULL, this means we should exit already */
+ klisp_unlock(K);
break;
}
}
}
-
-void klisp_close (klisp_State *K)
-{
- /* free all collectable objects */
- klispC_freeall(K);
-
- /* free helper buffers */
- klispM_freemem(K, ks_sbuf(K), ks_ssize(K) * sizeof(TValue));
- klispM_freemem(K, ks_tbuf(K), ks_tbsize(K));
-
- /* there should be no pending strings */
- klisp_assert(K->strt.nuse == 0);
-
- /* free string/symbol table */
- klispM_freearray(K, K->strt.hash, K->strt.size, GCObject *);
-
- /* only remaining mem should be of the state struct */
- klisp_assert(K->totalbytes == state_size());
-
- /* NOTE: this needs to be done "by hand" */
- (*(K->frealloc))(K->ud, K, state_size(), 0);
-}
diff --git a/src/kstate.h b/src/kstate.h
@@ -5,8 +5,7 @@
*/
/*
-** SOURCE NOTE: The main structure is from Lua, but because (for now)
-** klisp is single threaded, only global state is provided.
+** SOURCE NOTE: The main structure is from Lua.
*/
#ifndef kstate_h
@@ -14,6 +13,7 @@
#include <stdio.h>
#include <setjmp.h>
+#include <pthread.h>
#include "klimits.h"
#include "kobject.h"
@@ -44,40 +44,21 @@ typedef struct stringtable {
/* NOTE: when adding TValues here, remember to add them to
markroot in kgc.c!! */
+
/* TODO split this struct in substructs (e.g. run_context, tokenizer,
gc, etc) */
-struct klisp_State {
+
+/*
+** `global state', shared by all threads of this state
+*/
+typedef struct global_State {
+ /* Global tables */
stringtable strt; /* hash table for immutable strings & symbols */
TValue name_table; /* hash tables for naming objects */
- TValue cont_name_table; /* hash tables for naming continuation functions*/
-
- TValue curr_cont;
- /*
- ** If next_env is NIL, then the next_func from a continuation
- ** and otherwise next_func is from an operative
- */
- TValue next_obj; /* this is the operative or continuation to call
- must be here to protect it from gc */
- klisp_CFunction next_func; /* the next function to call
- (operative or continuation) */
- TValue next_value; /* the value to be passed to the next function */
- TValue next_env; /* either NIL or an environment for next operative */
- TValue *next_xparams;
- /* TODO replace with GCObject *next_si */
- TValue next_si; /* the source code info for this call */
-
- TValue eval_op; /* the operative for evaluation */
- TValue list_app; /* the applicative for list evaluation */
- TValue memoize_app; /* the applicative for promise memoize */
- TValue ground_env; /* the environment with all the ground definitions */
- /* standard environments are environments with no bindings and ground_env
- as parent */
- TValue module_params_sym; /* this is the symbol "module-parameters" */
- /* it is used in get-module */
- TValue root_cont;
- TValue error_cont;
- TValue system_error_cont; /* initialized by kinit_error_hierarchy() */
+ TValue cont_name_table; /* hash tables for naming continuation functions */
+ TValue thread_table; /* hash table for all live (non done/error) threads */
+ /* Memory allocator */
klisp_Alloc frealloc; /* function to reallocate memory */
void *ud; /* auxiliary data to `frealloc' */
@@ -99,19 +80,10 @@ struct klisp_State {
int32_t gcpause; /* size of pause between successive GCs */
int32_t gcstepmul; /* GC `granularity' */
- /* TEMP: error handling */
- jmp_buf error_jb;
-
- /* input/output port in use (for read & write) */
- TValue curr_port; /* save the port to update source info on errors */
-
- /* for current-input-port, current-output-port, current-error-port */
- TValue kd_in_port_key;
- TValue kd_out_port_key;
- TValue kd_error_port_key;
-
- /* for strict-arithmetic */
- TValue kd_strict_arith_key;
+ /* Basic Continuation objects */
+ TValue root_cont;
+ TValue error_cont;
+ TValue system_error_cont; /* initialized by kinit_error_hierarchy() */
/* Strings */
TValue empty_string;
@@ -129,10 +101,93 @@ struct klisp_State {
TValue ktok_dot;
TValue ktok_sexp_comment;
+ /* require */
+ TValue require_path;
+ TValue require_table;
+
+ /* libraries */
+ TValue libraries_registry; /* this is a list, because library names
+ are list of symbols and numbers so
+ putting them in a table isn't easy */
+
+ /* XXX These should be changed to use thread specific storage */
+ /* for current-input-port, current-output-port, current-error-port */
+ TValue kd_in_port_key;
+ TValue kd_out_port_key;
+ TValue kd_error_port_key;
+
+ /* for strict-arithmetic */
+ TValue kd_strict_arith_key;
+
+ /* Misc objects that are convenient to have here for now */
+ TValue eval_op; /* the operative for evaluation */
+ TValue list_app; /* the applicative for list evaluation */
+ TValue memoize_app; /* the applicative for promise memoize */
+ TValue ground_env; /* the environment with all the ground definitions */
+ /* NOTE standard environments are environments with no bindings and
+ ground_env as parent */
+ TValue module_params_sym; /* this is the symbol "module-parameters" */
+ /* (it is used in get-module) */
+
+ /* The main thread */
+ klisp_State *mainthread;
+ /* The GIL (Global Interpreter Lock) */
+ /* This is a regular mutex, but we use it to emulate a recursive one.
+ The number of times the lock was acquired is maintained in the
+ locking thread in gil_count */
+ pthread_mutex_t gil;
+} global_State;
+
+/*
+** Possible states of a thread/klisp_State,
+** currently threads are started as soon as they are created, but
+** that may change in the future. If the state is done, or error,
+** the returned/thrown object is kept in next_value
+*/
+#define KLISP_THREAD_CREATED (0)
+#define KLISP_THREAD_STARTING (1)
+#define KLISP_THREAD_RUNNING (2)
+#define KLISP_THREAD_DONE (3)
+#define KLISP_THREAD_ERROR (4)
+
+struct klisp_State {
+ CommonHeader; /* This represents a thread object */
+ global_State *k_G;
+ pthread_t thread;
+ int32_t status; /* the execution status of this thread */
+ /* The main thread doesn't have a condition variable here because
+ you can't join it. This may be changed in the future */
+ pthread_cond_t joincond; /* the condition variable for joining */
+ /* Current state of execution */
+ int32_t gil_count; /* the number of times the GIL was acquired */
+ TValue curr_cont; /* the current continuation of this thread */
+ /*
+ ** If next_env is NIL, then the next_func is from a continuation
+ ** and otherwise next_func is from an operative
+ */
+ TValue next_obj; /* this is the operative or continuation to call
+ must be here to protect it from gc */
+ klisp_CFunction next_func; /* the next function to call
+ (operative or continuation) */
+ TValue next_value; /* the value to be passed to the next function */
+ TValue next_env; /* either NIL or an environment for next operative */
+ TValue *next_xparams;
+ /* TODO replace with GCObject *next_si */
+ TValue next_si; /* the source code info for this call */
+
+ /* TEMP: error handling */
+ jmp_buf error_jb;
+
+ /* XXX all reader and writer info should be local to the current
+ continuation to allow user defined port types */
+ /* input/output port in use (for read & write) */
+ TValue curr_port; /* save the port to update source info on errors */
+
/* WORKAROUND for repl */
bool ktok_seen_eof; /* to keep track of eofs that later dissapear */
/* source info tracking */
ksource_info_t ktok_source_info;
+ /* TODO do this with a string or bytevector */
/* tokenizer buffer (XXX this could be done with a string) */
int32_t ktok_buffer_size;
int32_t ktok_buffer_idx;
@@ -148,15 +203,7 @@ struct klisp_State {
/* writer */
bool write_displayp;
- /* require */
- TValue require_path;
- TValue require_table;
-
- /* libraries */
- TValue libraries_registry; /* this is a list, because library names
- are list of symbols and numbers so
- putting them in a table isn't easy */
-
+ /* TODO do this with a vector */
/* auxiliary stack (XXX this could be a vector) */
int32_t ssize; /* total size of array */
int32_t stop; /* top of the stack (all elements are below this index) */
@@ -175,10 +222,40 @@ struct klisp_State {
TValue *rooted_vars_buf[GC_PROTECT_SIZE];
};
+#define G(K) (K->k_G)
+
+/*
+** Union of all Kernel heap-allocated values
+*/
+union GCObject {
+ GCheader gch;
+ MGCheader mgch;
+ Pair pair;
+ Symbol sym;
+ String str;
+ Environment env;
+ Continuation cont;
+ Operative op;
+ Applicative app;
+ Encapsulation enc;
+ Promise prom;
+ Table table;
+ Bytevector bytevector;
+ Port port; /* common fields for all types of ports */
+ FPort fport;
+ MPort mport;
+ Vector vector;
+ Keyword keyw;
+ Library lib;
+ klisp_State th; /* thread */
+};
+
/* some size related macros */
#define KS_ISSIZE (1024)
#define KS_ITBSIZE (1024)
-#define state_size() (sizeof(klisp_State))
+
+klisp_State *klispT_newthread(klisp_State *K);
+void klispT_freethread(klisp_State *K, klisp_State *K1);
/*
** TEMP: for now use inlined functions, later check output in
@@ -209,6 +286,12 @@ static inline bool ks_sisempty(klisp_State *K);
#define ks_sbuf(st_) ((st_)->sbuf)
#define ks_selem(st_, i_) ((ks_sbuf(st_))[i_])
+/* LOCK: All these functions should be called with the GIL already acquired */
+/* XXX/REFACTOR: the problem with these is that if the lock is acquired here
+ there's no way to protect the value just popped, it's no longer in the
+ stack, but the calling function has no way to protect it. One alternative
+ would be to take a ks_vars-protected TValue pointer and put the value there.
+ The other would be using a stack like lua for this... */
static inline void ks_spush(klisp_State *K, TValue obj)
{
ks_selem(K, ks_stop(K)) = obj;
@@ -279,6 +362,7 @@ static inline bool ks_tbisempty(klisp_State *K);
#define ks_tbuf(st_) ((st_)->ktok_buffer)
#define ks_tbelem(st_, i_) ((ks_tbuf(st_))[i_])
+/* LOCK: All these functions should be called with the GIL already acquired */
static inline void ks_tbadd(klisp_State *K, char ch)
{
if (ks_tbidx(K) == ks_tbsize(K))
@@ -355,6 +439,7 @@ static inline void krooted_vars_clear(klisp_State *K) { K->rooted_vars_top = 0;
** Source code tracking
** MAYBE: add source code tracking to symbols
*/
+/* LOCK: All these functions should be called with the GIL already acquired */
#if KTRACK_SI
static inline TValue kget_source_info(klisp_State *K, TValue obj)
{
@@ -395,7 +480,7 @@ static inline TValue kget_csi(klisp_State *K)
** Functions to manipulate the current continuation and calling
** operatives
*/
-static inline void klispS_apply_cc(klisp_State *K, TValue val)
+static inline void klispT_apply_cc(klisp_State *K, TValue val)
{
/* TODO write barriers */
@@ -415,27 +500,26 @@ static inline void klispS_apply_cc(klisp_State *K, TValue val)
K->next_si = ktry_get_si(K, K->next_obj);
}
-#define kapply_cc(K_, val_) klispS_apply_cc((K_), (val_)); return
+#define kapply_cc(K_, val_) klispT_apply_cc((K_), (val_)); return
-static inline TValue klispS_get_cc(klisp_State *K)
+static inline TValue klispT_get_cc(klisp_State *K)
{
return K->curr_cont;
}
-#define kget_cc(K_) (klispS_get_cc(K_))
+#define kget_cc(K_) (klispT_get_cc(K_))
-static inline void klispS_set_cc(klisp_State *K, TValue new_cont)
+static inline void klispT_set_cc(klisp_State *K, TValue new_cont)
{
K->curr_cont = new_cont;
}
-#define kset_cc(K_, c_) (klispS_set_cc(K_, c_))
+#define kset_cc(K_, c_) (klispT_set_cc(K_, c_))
-static inline void klispS_tail_call_si(klisp_State *K, TValue top, TValue ptree,
+static inline void klispT_tail_call_si(klisp_State *K, TValue top, TValue ptree,
TValue env, TValue si)
{
/* TODO write barriers */
-
/* various assert to check the freeing of gc protection methods */
klisp_assert(K->rooted_tvs_top == 0);
klisp_assert(K->rooted_vars_top == 0);
@@ -452,43 +536,38 @@ static inline void klispS_tail_call_si(klisp_State *K, TValue top, TValue ptree,
}
#define ktail_call_si(K_, op_, p_, e_, si_) \
- { klispS_tail_call_si((K_), (op_), (p_), (e_), (si_)); return; }
+ { klispT_tail_call_si((K_), (op_), (p_), (e_), (si_)); return; }
/* if no source info is needed */
#define ktail_call(K_, op_, p_, e_) \
{ klisp_State *K__ = (K_); \
TValue op__ = (op_); \
- (ktail_call_si(K__, op__, p_, e_, ktry_get_si(K__, op__))); } \
+ TValue si__ = ktry_get_si(K__, op__); \
+ (ktail_call_si(K__, op__, p_, e_, si__)); } \
-#define ktail_eval(K_, p_, e_) \
- { klisp_State *K__ = (K_); \
- TValue p__ = (p_); \
- klispS_tail_call_si(K__, K__->eval_op, p__, (e_), \
- ktry_get_si(K__, p__)); \
+#define ktail_eval(K_, p_, e_) \
+ { klisp_State *K__ = (K_); \
+ TValue p__ = (p_); \
+ TValue si__ = ktry_get_si(K__, p__); \
+ klispT_tail_call_si(K__, G(K__)->eval_op, p__, (e_), si__); \
return; }
-/* helper for continuation->applicative & kcall_cont */
-void cont_app(klisp_State *K);
+void do_interception(klisp_State *K);
void kcall_cont(klisp_State *K, TValue dst_cont, TValue obj);
-void klispS_init_repl(klisp_State *K);
-void klispS_run(klisp_State *K);
+void klispT_init_repl(klisp_State *K);
+void klispT_run(klisp_State *K);
void klisp_close (klisp_State *K);
-void do_interception(klisp_State *K);
-
-/* for root and error continuations */
-void do_root_exit(klisp_State *K);
-void do_error_exit(klisp_State *K);
-
/* simple accessors for dynamic keys */
/* XXX: this is ugly but we can't include kpair.h here so... */
/* MAYBE: move car & cdr to kobject.h */
/* TODO: use these where appropriate */
-#define kcurr_input_port(K) (tv2pair((K)->kd_in_port_key)->cdr)
-#define kcurr_output_port(K) (tv2pair((K)->kd_out_port_key)->cdr)
-#define kcurr_error_port(K) (tv2pair((K)->kd_error_port_key)->cdr)
-#define kcurr_strict_arithp(K) bvalue(tv2pair((K)->kd_strict_arith_key)->cdr)
+/* TODO LOCK, thread local */
+#define kcurr_input_port(K) (tv2pair(G(K)->kd_in_port_key)->cdr)
+#define kcurr_output_port(K) (tv2pair(G(K)->kd_out_port_key)->cdr)
+#define kcurr_error_port(K) (tv2pair(G(K)->kd_error_port_key)->cdr)
+#define kcurr_strict_arithp(K) bvalue(tv2pair(G(K)->kd_strict_arith_key)->cdr)
#endif
diff --git a/src/kstring.c b/src/kstring.c
@@ -21,10 +21,10 @@ void klispS_resize (klisp_State *K, int32_t newsize)
GCObject **newhash;
stringtable *tb;
int32_t i;
- if (K->gcstate == GCSsweepstring)
+ if (G(K)->gcstate == GCSsweepstring)
return; /* cannot resize during GC traverse */
newhash = klispM_newvector(K, newsize, GCObject *);
- tb = &K->strt;
+ tb = &G(K)->strt;
for (i = 0; i < newsize; i++) newhash[i] = NULL;
/* rehash */
for (i = 0; i < tb->size; i++) {
@@ -76,10 +76,8 @@ TValue kstring_new_bs_g(klisp_State *K, bool m, const char *buf,
** Constructors for immutable strings
*/
-/* main constructor for immutable strings */
-TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
+static uint32_t get_string_hash(const char *buf, uint32_t size)
{
- /* first check to see if it's in the stringtable */
uint32_t h = size; /* seed */
size_t step = (size>>5)+1; /* if string is too long, don't hash all
its chars */
@@ -87,7 +85,15 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
for (size1 = size; size1 >= step; size1 -= step) /* compute hash */
h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
- for (GCObject *o = K->strt.hash[lmod(h, K->strt.size)];
+ return h;
+}
+
+/* Looks for a string in the stringtable and returns a pointer
+ to it if found or NULL otherwise. */
+static String *search_in_string_table(klisp_State *K, const char *buf,
+ uint32_t size, uint32_t h)
+{
+ for (GCObject *o = G(K)->strt.hash[lmod(h, G(K)->strt.size)];
o != NULL; o = o->gch.next) {
klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
@@ -97,14 +103,27 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
String *ts = (String *) o;
if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
/* string may be dead */
- if (isdead(K, o)) changewhite(o);
- return gc2str(o);
+ if (isdead(G(K), o)) changewhite(o);
+ return ts;
}
}
- /* If it exits the loop, it means it wasn't found, hash is still in h */
- /* REFACTOR: move all of these to a new function */
- String *new_str;
+ /* If it exits the loop, it means it wasn't found */
+ return NULL;
+}
+
+
+/* main constructor for immutable strings */
+TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
+{
+ uint32_t h = get_string_hash(buf, size);
+
+ /* first check to see if it's in the stringtable */
+ String *new_str = search_in_string_table(K, buf, size, h);
+
+ if (new_str != NULL) { /* found */
+ return gc2str(new_str);
+ }
if (size > (SIZE_MAX - sizeof(String) - 1))
klispM_toobig(K);
@@ -114,7 +133,7 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
/* header + gc_fields */
/* can't use klispC_link, because strings use the next pointer
differently */
- new_str->gct = klispC_white(K);
+ new_str->gct = klispC_white(G(K));
new_str->tt = K_TSTRING;
new_str->kflags = K_FLAG_IMMUTABLE;
new_str->si = NULL;
@@ -129,7 +148,7 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
/* add to the string/symbol table (and link it) */
stringtable *tb;
- tb = &K->strt;
+ tb = &G(K)->strt;
h = lmod(h, tb->size);
new_str->next = tb->hash[h]; /* chain new entry */
tb->hash[h] = (GCObject *)(new_str);
@@ -161,8 +180,8 @@ TValue kstring_new_s(klisp_State *K, uint32_t size)
String *new_str;
if (size == 0) {
- klisp_assert(ttisstring(K->empty_string));
- return K->empty_string;
+ klisp_assert(ttisstring(G(K)->empty_string));
+ return G(K)->empty_string;
}
new_str = klispM_malloc(K, sizeof(String) + size + 1);
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -19,13 +19,12 @@
/* No case folding is performed by these constructors */
-/*
+/*
** Interned symbols are only the ones that don't have source info
** (like those created with string->symbol)
*/
-TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size, TValue si)
+static uint32_t get_symbol_hash(const char *buf, uint32_t size)
{
- /* First calculate the hash */
uint32_t h = size; /* seed */
size_t step = (size>>5)+1; /* if string is too long, don't hash all
its chars */
@@ -36,25 +35,47 @@ TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size, TValue si)
h = ~h; /* symbol hash should be different from string hash
otherwise symbols and their respective immutable string
would always fall in the same bucket */
+ return h;
+}
+
+/* Looks for a symbol in the stringtable and returns a pointer
+ to it if found or NULL otherwise. */
+static Symbol *search_in_symbol_table(klisp_State *K, const char *buf,
+ uint32_t size, uint32_t h)
+{
+ for (GCObject *o = G(K)->strt.hash[lmod(h, G(K)->strt.size)];
+ o != NULL; o = o->gch.next) {
+ klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
+ o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
+
+ if (o->gch.tt != K_TSYMBOL) continue;
+
+ String *ts = tv2str(((Symbol *) o)->str);
+ if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
+ /* symbol and/or string may be dead */
+ if (isdead(G(K), o)) changewhite(o);
+ if (isdead(G(K), (GCObject *) ts)) changewhite((GCObject *) ts);
+ return (Symbol *) o;
+ }
+ }
+
+ /* If it exits the loop, it means it wasn't found */
+ return NULL;
+}
+
+TValue ksymbol_new_bs(klisp_State *K, const char *buf, uint32_t size, TValue si)
+{
+ /* First calculate the hash */
+ uint32_t h = get_symbol_hash(buf, size);
+
/* look for it in the table only if it doesn't have source info */
if (ttisnil(si)) {
- for (GCObject *o = K->strt.hash[lmod(h, K->strt.size)];
- o != NULL; o = o->gch.next) {
- klisp_assert(o->gch.tt == K_TKEYWORD || o->gch.tt == K_TSYMBOL ||
- o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR);
-
- if (o->gch.tt != K_TSYMBOL) continue;
-
- String *ts = tv2str(((Symbol *) o)->str);
- if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
- /* symbol and/or string may be dead */
- if (isdead(K, o)) changewhite(o);
- if (isdead(K, (GCObject *) ts)) changewhite((GCObject *) ts);
- return gc2sym(o);
- }
- }
+ Symbol *new_sym = search_in_symbol_table(K, buf, size, h);
+ if (new_sym != NULL) {
+ return gc2sym(new_sym);
+ }
}
- /* REFACTOR: move this to a new function */
+
/* Didn't find it, alloc new immutable string and save in symbol table,
note that the hash value remained in h */
TValue new_str = kstring_new_bs_imm(K, buf, size);
@@ -67,7 +88,7 @@ TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size, TValue si)
/* header + gc_fields */
/* can't use klispC_link, because strings use the next pointer
differently */
- new_sym->gct = klispC_white(K);
+ new_sym->gct = klispC_white(G(K));
new_sym->tt = K_TSYMBOL;
new_sym->kflags = 0;
new_sym->si = NULL;
@@ -78,7 +99,7 @@ TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size, TValue si)
/* add to the string/symbol table (and link it) */
stringtable *tb;
- tb = &K->strt;
+ tb = &G(K)->strt;
h = lmod(h, tb->size);
new_sym->next = tb->hash[h]; /* chain new entry */
tb->hash[h] = (GCObject *)(new_sym);
diff --git a/src/ksymbol.h b/src/ksymbol.h
@@ -20,7 +20,7 @@
/* No case folding is performed by these constructors */
/* buffer + size, may contain nulls */
-TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size,
+TValue ksymbol_new_bs(klisp_State *K, const char *buf, uint32_t size,
TValue si);
/* null terminated buffer */
TValue ksymbol_new_b(klisp_State *K, const char *buf, TValue si);
diff --git a/src/ktable.c b/src/ktable.c
@@ -331,7 +331,7 @@ static void resize (klisp_State *K, Table *t, int32_t nasize, int32_t nhsize)
if (!ttisfree(t->array[i])) {
TValue v = t->array[i];
*klispH_setfixint(K, t, i) = v;
- checkliveness(K, v);
+ checkliveness(G(K), v);
}
}
/* shrink array */
@@ -343,7 +343,7 @@ static void resize (klisp_State *K, Table *t, int32_t nasize, int32_t nhsize)
if (!ttisfree(gval(old))) {
TValue v = gval(old);
*klispH_set(K, t, key2tval(old)) = v;
- checkliveness(K, v);
+ checkliveness(G(K), v);
}
}
if (nold != dummynode)
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -176,7 +176,12 @@ int ktok_ggetc(klisp_State *K)
if (ttisfport(port)) {
/* fport */
FILE *file = kfport_file(port);
+
+ /* LOCK: only a single lock should be acquired */
+ klisp_unlock(K);
int chi = getc(file);
+ klisp_lock(K);
+
if (chi == EOF) {
/* NOTE: eof doesn't change source code location info */
if (ferror(file) != 0) {
@@ -354,10 +359,10 @@ TValue ktok_read_token(klisp_State *K)
continue;
case '(':
ktok_getc(K);
- return K->ktok_lparen;
+ return G(K)->ktok_lparen;
case ')':
ktok_getc(K);
- return K->ktok_rparen;
+ return G(K)->ktok_rparen;
case '"':
return ktok_read_string(K);
case '|':
@@ -382,7 +387,7 @@ TValue ktok_read_token(klisp_State *K)
continue;
case ';': /* sexp comment */
ktok_getc(K); /* discard the ';' */
- return K->ktok_sexp_comment;
+ return G(K)->ktok_sexp_comment;
case ':': /* keyword */
ktok_getc(K); /* discard the ':' */
chi = ktok_peekc(K);
@@ -1122,7 +1127,7 @@ TValue ktok_read_identifier_or_dot(klisp_State *K, bool keywordp)
return KINERT; /* avoid warning */
} else {
ks_tbclear(K);
- return K->ktok_dot;
+ return G(K)->ktok_dot;
}
}
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -54,7 +54,10 @@ void kw_printf(klisp_State *K, const char *format, ...)
if (ttisfport(port)) {
FILE *file = kfport_file(port);
va_start(argp, format);
+ /* LOCK: only a single lock should be acquired */
+ klisp_unlock(K);
int ret = vfprintf(file, format, argp);
+ klisp_lock(K);
va_end(argp);
if (ret < 0) {
@@ -441,7 +444,9 @@ void kw_print_cont_type(klisp_State *K, TValue obj)
K->write_displayp = true; /* avoid "s and escapes */
Continuation *cont = tv2cont(obj);
- const TValue *node = klispH_get(tv2table(K->cont_name_table),
+
+ /* XXX lock? */
+ const TValue *node = klispH_get(tv2table(G(K)->cont_name_table),
p2tv(cont->fn));
char *type;
@@ -720,6 +725,33 @@ void kwrite_scalar(klisp_State *K, TValue obj)
#endif
kw_printf(K, "]");
break;
+ case K_TTHREAD:
+ kw_printf(K, "#[thread");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
+ case K_TMUTEX:
+ kw_printf(K, "#[mutex");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
+ case K_TCONDVAR:
+ kw_printf(K, "#[condvar");
+#if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+#endif
+ kw_printf(K, "]");
+ break;
default:
/* shouldn't happen */
kwrite_error(K, "unknown object type");
@@ -896,7 +928,9 @@ void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch)
if (ttisfport(port)) {
FILE *file = kfport_file(port);
+ klisp_unlock(K);
int res = fputc(chvalue(ch), file);
+ klisp_lock(K);
if (res == EOF) {
clearerr(file); /* clear error for next time */
@@ -934,7 +968,9 @@ void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8)
i/o functions set it */
if (ttisfport(port)) {
FILE *file = kfport_file(port);
+ klisp_unlock(K);
int res = fputc(ivalue(u8), file);
+ klisp_lock(K);
if (res == EOF) {
clearerr(file); /* clear error for next time */
@@ -974,7 +1010,10 @@ void kwrite_flush_port(klisp_State *K, TValue port)
if (ttisfport(port)) { /* only necessary for file ports */
FILE *file = kfport_file(port);
klisp_assert(file);
- if ((fflush(file)) == EOF) {
+ klisp_unlock(K);
+ int res = fflush(file);
+ klisp_lock(K);
+ if (res == EOF) {
clearerr(file); /* clear error for next time */
kwrite_error(K, "error writing");
}
