suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merge Kevin's work so far on places

Browse Source 
svn: r11226
This commit is contained in:
Matthew Flatt 2008-08-13 23:08:34 +00:00
parent edbbca1fa2
commit 04d7712988
34 changed files with 1415 additions and 814 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/configure vendored
View File

@ -704,6 +704,7 @@ FRAMEWORK_REL_INSTALL
FRAMEWORK_PREFIX
INSTALL_ORIG_TREE
EXE_SUFFIX
PLACE_CGC_FLAGS
MREDLINKER
LIBSFX
WXLIBS
@ -1342,6 +1343,7 @@ Optional Features:
--enable-lt=<prog> use <prog> instead of bundled libtool
--enable-origtree install with original directory structure
--enable-foreign compile foreign support (enabled by default)
--enable-places compile places support
--enable-cgcdefault use CGC (Boehm or Senora) as default build
--enable-sgc use Senora GC instead of the Boehm GC
--enable-sgcdebug use Senora GC for debugging
@ -1881,6 +1883,12 @@ else
fi
# Check whether --enable-foreign was given.
if test "${enable_foreign+set}" = set; then
enableval=$enable_foreign;
fi
# Check whether --enable-cgcdefault was given.
if test "${enable_cgcdefault+set}" = set; then
enableval=$enable_cgcdefault;
@ -2259,6 +2267,7 @@ ZLIB_INC='$(ZLIB_INC)'
PNG_A='$(PNG_A)'
PREFLAGS="$CPPFLAGS"
PLACE_CGC_FLAGS=""
ar_libtool_no_undefined=""
LIBMZSCHEME_DEP=""
@ -5790,6 +5799,7 @@ case $OS in
Linux)
LIBS="$LIBS -rdynamic"
DYN_CFLAGS="-fPIC"
GC_THREADS_FLAG="-DGC_LINUX_THREADS"
# PPC: X11 librares are not found
case `$UNAME -m` in
ppc)
@ -5859,6 +5869,8 @@ case $OS in
ZLIB_A=""
ZLIB_INC=""
GC_THREADS_FLAG="-DGC_DARWIN_THREADS"
gcc_vers_three=`${CC} -v 2>&1 | grep "version [3-9][.]"`
if test "$gcc_vers_three" = "" ; then
# gcc 2.95.2
@ -10470,6 +10482,13 @@ if test "${enable_pthread}" = "yes" ; then
GC2OPTIONS="$GC2OPTIONS -DNO_GC_SIGNALS"
fi
############### places ###################
if test "${enable_places}" = "yes" ; then
PREFLAGS="$PREFLAGS -DMZ_USE_PLACES"
PLACE_CGC_FLAGS="$GC_THREADS_FLAG -DPARALLEL_MARK -DTHREAD_LOCAL_ALLOC"
LDFLAGS="$LDFLAGS -pthread"
fi
################ Xrender ##################
@ -11783,6 +11802,7 @@ LIBS="$LIBS $EXTRALIBS"
mk_needed_dir()
@ -12659,13 +12679,13 @@ FRAMEWORK_REL_INSTALL!$FRAMEWORK_REL_INSTALL$ac_delim
FRAMEWORK_PREFIX!$FRAMEWORK_PREFIX$ac_delim
INSTALL_ORIG_TREE!$INSTALL_ORIG_TREE$ac_delim
EXE_SUFFIX!$EXE_SUFFIX$ac_delim
PLACE_CGC_FLAGS!$PLACE_CGC_FLAGS$ac_delim
MREDLINKER!$MREDLINKER$ac_delim
LIBSFX!$LIBSFX$ac_delim
WXLIBS!$WXLIBS$ac_delim
WXVARIANT!$WXVARIANT$ac_delim
ICP!$ICP$ac_delim
MRLIBINSTALL!$MRLIBINSTALL$ac_delim
LIBFINISH!$LIBFINISH$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 97; then
@ -12707,6 +12727,7 @@ _ACEOF
ac_delim='%!_!# '
for ac_last_try in false false false false false :; do
cat >conf$$subs.sed <<_ACEOF
LIBFINISH!$LIBFINISH$ac_delim
MAKE_MRED!$MAKE_MRED$ac_delim
MAKE_WBUILD!$MAKE_WBUILD$ac_delim
MAKE_COPYTREE!$MAKE_COPYTREE$ac_delim
@ -12746,7 +12767,7 @@ LIBOBJS!$LIBOBJS$ac_delim
LTLIBOBJS!$LTLIBOBJS$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 37; then
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 38; then
break
elif $ac_last_try; then
{ { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5

14
src/mzscheme/configure.ac
View File

@ -41,6 +41,8 @@ AC_ARG_ENABLE(origtree,[ --enable-origtree install with original director
AC_ARG_ENABLE(foreign, [ --enable-foreign compile foreign support (enabled by default)], , enable_foreign=yes)
AC_ARG_ENABLE(foreign, [ --enable-places compile places support])
AC_ARG_ENABLE(cgcdefault, [ --enable-cgcdefault use CGC (Boehm or Senora) as default build])
AC_ARG_ENABLE(sgc, [ --enable-sgc use Senora GC instead of the Boehm GC])
AC_ARG_ENABLE(sgcdebug,[ --enable-sgcdebug use Senora GC for debugging])
@ -329,6 +331,7 @@ ZLIB_INC='$(ZLIB_INC)'
PNG_A='$(PNG_A)'
PREFLAGS="$CPPFLAGS"
PLACE_CGC_FLAGS=""
ar_libtool_no_undefined=""
LIBMZSCHEME_DEP=""
@ -532,6 +535,7 @@ case $OS in
Linux)
LIBS="$LIBS -rdynamic"
DYN_CFLAGS="-fPIC"
GC_THREADS_FLAG="-DGC_LINUX_THREADS"
# PPC: X11 librares are not found
case `$UNAME -m` in
ppc)
@ -601,6 +605,8 @@ case $OS in
ZLIB_A=""
ZLIB_INC=""
GC_THREADS_FLAG="-DGC_DARWIN_THREADS"
[ gcc_vers_three=`${CC} -v 2>&1 | grep "version [3-9][.]"` ]
if test "$gcc_vers_three" = "" ; then
# gcc 2.95.2
@ -1023,6 +1029,13 @@ if test "${enable_pthread}" = "yes" ; then
GC2OPTIONS="$GC2OPTIONS -DNO_GC_SIGNALS"
fi
############### places ###################
if test "${enable_places}" = "yes" ; then
PREFLAGS="$PREFLAGS -DMZ_USE_PLACES"
PLACE_CGC_FLAGS="$GC_THREADS_FLAG -DPARALLEL_MARK -DTHREAD_LOCAL_ALLOC"
LDFLAGS="$LDFLAGS -pthread"
fi
################ Xrender ##################
@ -1300,6 +1313,7 @@ AC_SUBST(FRAMEWORK_REL_INSTALL)
AC_SUBST(FRAMEWORK_PREFIX)
AC_SUBST(INSTALL_ORIG_TREE)
AC_SUBST(EXE_SUFFIX)
AC_SUBST(PLACE_CGC_FLAGS)
AC_SUBST(MREDLINKER)
AC_SUBST(LIBSFX)

2
src/mzscheme/gc/Makefile.in
View File

@ -31,7 +31,7 @@ mainsrcdir = @srcdir@/../..
# compiler options; mainly used to allow importing options
OPTIONS=@OPTIONS@ @CGCOPTIONS@
BASEFLAGS= -I$(srcdir)/include -DNO_SIGNALS @CFLAGS@ @COMPFLAGS@ @PREFLAGS@
BASEFLAGS= -I$(srcdir)/include -DNO_SIGNALS @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @PLACE_CGC_FLAGS@
CFLAGS= $(BASEFLAGS) @PROFFLAGS@ $(OPTIONS) -DNO_EXECUTE_PERMISSION -DSILENT -DNO_GETENV -DLARGE_CONFIG -DATOMIC_UNCOLLECTABLE -DINITIAL_MARK_STACK_SIZE=8192
# To build the parallel collector on Linux, add to the above:

16
src/mzscheme/gc/darwin_stop_world.c
View File

@ -102,15 +102,15 @@ void GC_push_all_stacks() {
if(r != KERN_SUCCESS) ABORT("thread_get_state failed");
#if defined(I386)
lo = state.esp;
lo = state.__esp;
GC_push_one(state.eax);
GC_push_one(state.ebx);
GC_push_one(state.ecx);
GC_push_one(state.edx);
GC_push_one(state.edi);
GC_push_one(state.esi);
GC_push_one(state.ebp);
GC_push_one(state.__eax);
GC_push_one(state.__ebx);
GC_push_one(state.__ecx);
GC_push_one(state.__edx);
GC_push_one(state.__edi);
GC_push_one(state.__esi);
GC_push_one(state.__ebp);
#elif defined(POWERPC)
lo = (void*)(state.r1 - PPC_RED_ZONE_SIZE);

11
src/mzscheme/gc2/Makefile.in
View File

@ -21,7 +21,7 @@ RANLIB = @RANLIB@
CPPFLAGS = @PREFLAGS@ @OPTIONS@ @GC2OPTIONS@ @MZOPTIONS@ -I$(builddir)/.. -I$(srcdir)/../include
CFLAGS = @CFLAGS@ $(CPPFLAGS) @COMPFLAGS@ @PROFFLAGS@
LIBS = @LIBS@
LIBS = @LIBS@ -lpthread
DEF_COLLECTS_DIR = +D INITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../../collects; pwd`"'"'
@ -50,11 +50,13 @@ OBJS = salloc.@LTO@ \
jit.@LTO@ \
list.@LTO@ \
module.@LTO@ \
mzrt.@LTO@ \
network.@LTO@ \
numarith.@LTO@ \
number.@LTO@ \
numcomp.@LTO@ \
numstr.@LTO@ \
places.@LTO@ \
port.@LTO@ \
portfun.@LTO@ \
print.@LTO@ \
@ -98,6 +100,7 @@ XSRCS = $(XSRCDIR)/salloc.c \
$(XSRCDIR)/numcomp.c \
$(XSRCDIR)/number.c \
$(XSRCDIR)/numstr.c \
$(XSRCDIR)/places.c \
$(XSRCDIR)/port.c \
$(XSRCDIR)/portfun.c \
$(XSRCDIR)/print.c \
@ -178,6 +181,8 @@ $(XSRCDIR)/numcomp.c: ../src/numcomp.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/numcomp.c $(SRCDIR)/numcomp.c
$(XSRCDIR)/numstr.c: ../src/numstr.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/numstr.c $(SRCDIR)/numstr.c
$(XSRCDIR)/places.c: ../src/places.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/places.c $(SRCDIR)/places.c
$(XSRCDIR)/port.c: ../src/port.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/port.c $(SRCDIR)/port.c
$(XSRCDIR)/portfun.c: ../src/portfun.@LTO@ $(XFORMDEP)
@ -248,6 +253,8 @@ list.@LTO@: $(XSRCDIR)/list.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@
module.@LTO@: $(XSRCDIR)/module.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/module.c -o module.@LTO@
mzrt.@LTO@: $(SRCDIR)/mzrt.c
$(CC) $(CFLAGS) -c $(SRCDIR)/mzrt.c -o mzrt.@LTO@
network.@LTO@: $(XSRCDIR)/network.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/network.c -o network.@LTO@
numarith.@LTO@: $(XSRCDIR)/numarith.c
@ -258,6 +265,8 @@ numcomp.@LTO@: $(XSRCDIR)/numcomp.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/numcomp.c -o numcomp.@LTO@
numstr.@LTO@: $(XSRCDIR)/numstr.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/numstr.c -o numstr.@LTO@
places.@LTO@: $(XSRCDIR)/places.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/places.c -o places.@LTO@
port.@LTO@: $(XSRCDIR)/port.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/port.c -o port.@LTO@
portfun.@LTO@: $(XSRCDIR)/portfun.c

2
src/mzscheme/include/mzscheme.exp
View File

@ -15,7 +15,7 @@ scheme_set_thread_param
scheme_get_env
scheme_inherit_cells
scheme_current_break_cell
scheme_current_thread
Scheme_Thread
scheme_fuel_counter
scheme_get_current_thread
scheme_start_atomic

2
src/mzscheme/include/mzscheme3m.exp
View File

@ -15,7 +15,7 @@ scheme_set_thread_param
scheme_get_env
scheme_inherit_cells
scheme_current_break_cell
scheme_current_thread
Scheme_Thread
scheme_fuel_counter
scheme_get_current_thread
scheme_start_atomic

1
src/mzscheme/include/mzwin.def
View File

@ -17,7 +17,6 @@ EXPORTS
scheme_get_env
scheme_inherit_cells
scheme_current_break_cell
scheme_current_thread DATA
scheme_fuel_counter DATA
scheme_get_current_thread
scheme_start_atomic

1
src/mzscheme/include/mzwin3m.def
View File

@ -17,7 +17,6 @@ EXPORTS
scheme_get_env
scheme_inherit_cells
scheme_current_break_cell
scheme_current_thread DATA
scheme_fuel_counter DATA
scheme_get_current_thread
scheme_start_atomic

22
src/mzscheme/include/scheme.h
View File

@ -166,6 +166,16 @@ typedef struct FSSpec mzFSSpec;
#define MZ_EXTERN extern MZ_DLLSPEC
#ifdef MZ_USE_PLACES
# if _MSC_VER
# define THREAD_LOCAL __declspec(thread)
# else
# define THREAD_LOCAL __thread
# endif
#else
# define THREAD_LOCAL /* empty */
#endif
#if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_I386) || defined(MZ_USE_JIT_X86_64)
# define MZ_USE_JIT
#endif
@ -1384,7 +1394,6 @@ typedef void (*Scheme_Invoke_Proc)(Scheme_Env *env, long phase_shift,
#define scheme_tail_rator (scheme_current_thread->ku.apply.tail_rator)
#define scheme_tail_num_rands (scheme_current_thread->ku.apply.tail_num_rands)
#define scheme_tail_rands (scheme_current_thread->ku.apply.tail_rands)
#define scheme_overflow_k (scheme_current_thread->overflow_k)
#define scheme_overflow_reply (scheme_current_thread->overflow_reply)
#define scheme_error_buf *(scheme_current_thread->error_buf)
@ -1648,9 +1657,10 @@ MZ_EXTERN void scheme_set_logging(int syslog_level, int stderr_level);
MZ_EXTERN int scheme_get_allow_set_undefined();
MZ_EXTERN Scheme_Thread *scheme_current_thread;
MZ_EXTERN Scheme_Thread *scheme_first_thread;
#ifndef MZ_USE_PLACES
MZ_EXTERN THREAD_LOCAL Scheme_Thread *scheme_current_thread;
MZ_EXTERN THREAD_LOCAL Scheme_Thread *scheme_first_thread;
#endif
/* Set these global hooks (optionally): */
typedef void (*Scheme_Exit_Proc)(int v);
@ -1704,8 +1714,8 @@ MZ_EXTERN void scheme_wake_up(void);
MZ_EXTERN int scheme_get_external_event_fd(void);
/* GC registration: */
MZ_EXTERN void scheme_set_stack_base(void *base, int no_auto_statics);
MZ_EXTERN void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics);
MZ_EXTERN void scheme_set_primordial_stack_base(void *base, int no_auto_statics);
MZ_EXTERN void scheme_set_primordial_stack_bounds(void *base, void *deepest, int no_auto_statics);
/* Stack-preparation start-up: */
typedef int (*Scheme_Nested_Main)(void *data);

10
src/mzscheme/src/Makefile.in
View File

@ -29,11 +29,13 @@ OBJS = salloc.@LTO@ \
jit.@LTO@ \
list.@LTO@ \
module.@LTO@ \
mzrt.@LTO@ \
network.@LTO@ \
numarith.@LTO@ \
number.@LTO@ \
numcomp.@LTO@ \
numstr.@LTO@ \
places.@LTO@ \
port.@LTO@ \
portfun.@LTO@ \
print.@LTO@ \
@ -68,11 +70,13 @@ SRCS = $(srcdir)/salloc.c \
$(srcdir)/jit.c \
$(srcdir)/list.c \
$(srcdir)/module.c \
$(srcdir)/mzrt.c \
$(srcdir)/network.c \
$(srcdir)/numarith.c \
$(srcdir)/number.c \
$(srcdir)/numcomp.c \
$(srcdir)/numstr.c \
$(srcdir)/places.c \
$(srcdir)/port.c \
$(srcdir)/portfun.c \
$(srcdir)/print.c \
@ -174,6 +178,8 @@ list.@LTO@: $(srcdir)/list.c
$(CC) $(CFLAGS) -c $(srcdir)/list.c -o list.@LTO@
module.@LTO@: $(srcdir)/module.c
$(CC) $(CFLAGS) -c $(srcdir)/module.c -o module.@LTO@
mzrt.@LTO@: $(srcdir)/mzrt.c
$(CC) $(CFLAGS) -c $(srcdir)/mzrt.c -o mzrt.@LTO@
network.@LTO@: $(srcdir)/network.c
$(CC) $(CFLAGS) -c $(srcdir)/network.c -o network.@LTO@
numarith.@LTO@: $(srcdir)/numarith.c
@ -184,6 +190,8 @@ numcomp.@LTO@: $(srcdir)/numcomp.c
$(CC) $(CFLAGS) -c $(srcdir)/numcomp.c -o numcomp.@LTO@
numstr.@LTO@: $(srcdir)/numstr.c
$(CC) $(CFLAGS) -c $(srcdir)/numstr.c -o numstr.@LTO@
places.@LTO@: $(srcdir)/places.c
$(CC) $(CFLAGS) -c $(srcdir)/places.c -o places.@LTO@
port.@LTO@: $(srcdir)/port.c
$(CC) $(CFLAGS) -c $(srcdir)/port.c -o port.@LTO@
portfun.@LTO@: $(srcdir)/portfun.c
@ -272,6 +280,8 @@ numcomp.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../in
$(srcdir)/../src/stypes.h $(srcdir)/nummacs.h
numstr.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/random.inc $(srcdir)/newrandom.inc
places.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c
port.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c
portfun.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \

2
src/mzscheme/src/bool.c
View File

@ -272,7 +272,7 @@ static int union_check(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql
}
}
static Scheme_Object *equal_k()
static Scheme_Object *equal_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *v1 = (Scheme_Object *)p->ku.k.p1;

28
src/mzscheme/src/cstartup.inc
View File

@ -1,5 +1,5 @@
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,50,46,54,50,0,0,0,1,0,0,6,0,9,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,48,46,49,50,0,0,0,1,0,0,6,0,9,0,
14,0,18,0,23,0,28,0,32,0,39,0,42,0,55,0,62,0,69,0,78,
0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,68,1,107,1,146,
@ -14,11 +14,11 @@
115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,
98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98,
10,35,11,8,163,218,94,159,2,16,35,35,159,2,15,35,35,16,20,2,9,
10,35,11,8,180,219,94,159,2,16,35,35,159,2,15,35,35,16,20,2,9,
2,2,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,
2,2,8,2,2,2,10,2,2,2,11,2,2,2,12,2,2,97,36,11,8,
163,218,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2,
13,97,10,11,11,8,163,218,16,0,97,10,37,11,8,163,218,16,0,13,16,
180,219,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2,
13,97,10,11,11,8,180,219,16,0,97,10,37,11,8,180,219,16,0,13,16,
4,35,29,11,11,2,2,11,18,98,64,104,101,114,101,8,31,8,30,8,29,
8,28,8,27,27,248,22,190,3,23,196,1,249,22,183,3,80,158,38,35,251,
22,73,2,17,248,22,88,23,200,2,12,249,22,63,2,1,248,22,90,23,202,
@ -28,14 +28,14 @@
36,28,248,22,71,248,22,65,23,195,2,248,22,64,193,249,22,183,3,80,158,
38,35,251,22,73,2,17,248,22,64,23,200,2,249,22,63,2,7,248,22,65,
23,202,1,11,18,100,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
2,18,3,1,7,101,110,118,56,48,56,49,16,4,11,11,2,19,3,1,7,
101,110,118,56,48,56,50,27,248,22,65,248,22,190,3,23,197,1,28,248,22,
2,18,3,1,7,101,110,118,56,49,54,51,16,4,11,11,2,19,3,1,7,
101,110,118,56,49,54,52,27,248,22,65,248,22,190,3,23,197,1,28,248,22,
71,23,194,2,20,15,159,36,35,36,28,248,22,71,248,22,65,23,195,2,248,
22,64,193,249,22,183,3,80,158,38,35,250,22,73,2,20,248,22,73,249,22,
73,248,22,73,2,21,248,22,64,23,202,2,251,22,73,2,17,2,21,2,21,
249,22,63,2,9,248,22,65,23,205,1,18,100,11,8,31,8,30,8,29,8,
28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,56,48,56,52,16,4,
11,11,2,19,3,1,7,101,110,118,56,48,56,53,248,22,190,3,193,27,248,
28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,56,49,54,54,16,4,
11,11,2,19,3,1,7,101,110,118,56,49,54,55,248,22,190,3,193,27,248,
22,190,3,194,249,22,63,248,22,73,248,22,64,196,248,22,65,195,27,248,22,
65,248,22,190,3,23,197,1,249,22,183,3,80,158,38,35,28,248,22,51,248,
22,184,3,248,22,64,23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,
@ -65,8 +65,8 @@
251,22,73,2,17,28,249,22,151,8,248,22,184,3,248,22,64,23,201,2,64,
101,108,115,101,10,248,22,64,23,198,2,250,22,74,2,20,9,248,22,65,23,
201,1,249,22,63,2,6,248,22,65,23,203,1,99,8,31,8,30,8,29,8,
28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,56,49,48,55,16,4,
11,11,2,19,3,1,7,101,110,118,56,49,48,56,18,158,94,10,64,118,111,
28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,56,49,56,57,16,4,
11,11,2,19,3,1,7,101,110,118,56,49,57,48,18,158,94,10,64,118,111,
105,100,8,47,27,248,22,65,248,22,190,3,196,249,22,183,3,80,158,38,35,
28,248,22,51,248,22,184,3,248,22,64,197,250,22,73,2,26,248,22,73,248,
22,64,199,248,22,88,198,27,248,22,184,3,248,22,64,197,250,22,73,2,26,
@ -99,7 +99,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 2031);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,50,46,54,59,0,0,0,1,0,0,3,0,16,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,48,46,49,59,0,0,0,1,0,0,3,0,16,0,
21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200,
0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1,
157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241,
@ -343,12 +343,12 @@
EVAL_ONE_SIZED_STR((char *)expr, 5056);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,50,46,54,8,0,0,0,1,0,0,6,0,19,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,48,46,49,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,111,0,0,0,241,0,0,0,65,113,117,111,116,
101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,
37,107,101,114,110,101,108,11,98,10,35,11,8,165,220,97,159,2,2,35,35,
37,107,101,114,110,101,108,11,98,10,35,11,8,182,221,97,159,2,2,35,35,
159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16,
0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,
100,137,69,35,37,98,117,105,108,116,105,110,29,11,11,10,10,18,96,11,42,
@ -360,7 +360,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 278);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,50,46,54,52,0,0,0,1,0,0,3,0,14,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,48,46,49,52,0,0,0,1,0,0,3,0,14,0,
41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200,
0,223,0,3,1,8,1,13,1,18,1,23,1,54,1,58,1,66,1,74,1,
82,1,185,1,230,1,250,1,29,2,64,2,98,2,108,2,155,2,165,2,172,

672
src/mzscheme/src/env.c
View File

@ -27,52 +27,51 @@
envionments, a.k.a. namespaces), and also implements much of the
initialization sequence (filling the initial namespace). */
#include "mzrt.h"
#include "schpriv.h"
#include "schminc.h"
#include "schmach.h"
#include "schexpobs.h"
#if defined(UNIX_LIMIT_STACK) || defined(UNIX_LIMIT_FDSET_SIZE)
# include <signal.h>
# include <sys/time.h>
# include <sys/resource.h>
#endif
#ifdef MZ_USE_IRIX_SPROCS
# include "../gc/gc.h"
#endif
#define GLOBAL_TABLE_SIZE 500
#define TABLE_CACHE_MAX_SIZE 2048
/* #define TIME_STARTUP_PROCESS */
/* globals */
/* global flags */
int scheme_allow_set_undefined;
void scheme_set_allow_set_undefined(int v) { scheme_allow_set_undefined = v; }
int scheme_get_allow_set_undefined() { return scheme_allow_set_undefined; }
int scheme_starting_up;
/* global counters just need to be atomically incremented */
static int intdef_counter = 0;
static int builtin_ref_counter = 0;
static int env_uid_counter = 0;
/* globals READ-ONLY SHARED */
static Scheme_Object *kernel_symbol;
static Scheme_Env *kernel_env;
#define MAX_CONST_LOCAL_POS 64
#define MAX_CONST_LOCAL_TYPES 2
#define MAX_CONST_LOCAL_FLAG_VAL 2
#define SCHEME_LOCAL_FLAGS_MASK 0x3
static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1];
#define MAX_CONST_TOPLEVEL_DEPTH 16
#define MAX_CONST_TOPLEVEL_POS 16
#define SCHEME_TOPLEVEL_FLAGS_MASK 0x3
static Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1];
#define TABLE_CACHE_MAX_SIZE 2048
Scheme_Hash_Table *toplevels_ht;
Scheme_Hash_Table *locals_ht[2];
/* globals THREAD_LOCAL
* if locked theses are probably sharable*/
static Scheme_Hash_Table *toplevels_ht;
static Scheme_Hash_Table *locals_ht[2];
Scheme_Env *scheme_initial_env;
/* locals */
static void make_init_env(void);
/* local functions */
static void make_kernel_env(void);
static void init_scheme_local();
static void init_toplevels();
static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size);
static Scheme_Env *make_empty_inited_env(int toplevel_size);
@ -126,23 +125,19 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj);
static Scheme_Object *read_resolve_prefix(Scheme_Object *obj);
static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data);
int scheme_is_module_begin_env(Scheme_Comp_Env *env);
Scheme_Env *scheme_engine_instance_init();
Scheme_Env *scheme_place_instance_init();
static void place_instance_init_pre_kernel();
static Scheme_Env *place_instance_init_post_kernel();
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
typedef Scheme_Object *(*Lazy_Macro_Fun)(Scheme_Object *, int);
static Scheme_Object *kernel_symbol;
static int intdef_counter = 0;
static int builtin_ref_counter = 0;
static int env_uid_counter;
#define ARBITRARY_USE 0x1
#define CONSTRAINED_USE 0x2
#define WAS_SET_BANGED 0x4
@ -201,165 +196,78 @@ static void boot_module_resolver()
scheme_apply(boot, 0, NULL);
}
void os_platform_init() {
#ifdef UNIX_LIMIT_STACK
struct rlimit rl;
getrlimit(RLIMIT_STACK, &rl);
if (rl.rlim_cur > UNIX_LIMIT_STACK) {
rl.rlim_cur = UNIX_LIMIT_STACK;
setrlimit(RLIMIT_STACK, &rl);
}
#endif
#ifdef UNIX_LIMIT_FDSET_SIZE
struct rlimit rl;
getrlimit(RLIMIT_NOFILE, &rl);
if (rl.rlim_cur > FD_SETSIZE) {
rl.rlim_cur = FD_SETSIZE;
setrlimit(RLIMIT_NOFILE, &rl);
}
#endif
}
Scheme_Env *scheme_restart_instance() {
Scheme_Env *env;
void *stack_base;
stack_base = (void *) scheme_get_current_os_thread_stack_base();
/* Reset everything: */
scheme_do_close_managed(NULL, skip_certain_things);
scheme_main_thread = NULL;
scheme_reset_finalizations();
scheme_init_stack_check();
#ifndef MZ_PRECISE_GC
scheme_init_setjumpup();
#endif
scheme_reset_overflow();
scheme_make_thread(stack_base);
scheme_init_error_escape_proc(NULL);
scheme_init_module_resolver();
env = scheme_make_empty_env();
scheme_install_initial_module_set(env);
scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env);
scheme_init_port_config();
scheme_init_port_fun_config();
scheme_init_error_config();
#ifndef NO_SCHEME_EXNS
scheme_init_exn_config();
#endif
boot_module_resolver();
return env;
}
Scheme_Env *scheme_basic_env()
{
Scheme_Env *env;
if (scheme_main_thread) {
/* Reset everything: */
scheme_do_close_managed(NULL, skip_certain_things);
scheme_main_thread = NULL;
scheme_reset_finalizations();
scheme_init_stack_check();
#ifndef MZ_PRECISE_GC
scheme_init_setjumpup();
#endif
scheme_reset_overflow();
scheme_make_thread();
scheme_init_error_escape_proc(NULL);
scheme_init_module_resolver();
env = scheme_make_empty_env();
scheme_install_initial_module_set(env);
scheme_set_param(scheme_current_config(), MZCONFIG_ENV,
(Scheme_Object *)env);
scheme_init_port_config();
scheme_init_port_fun_config();
scheme_init_error_config();
#ifndef NO_SCHEME_EXNS
scheme_init_exn_config();
#endif
boot_module_resolver();
return env;
return scheme_restart_instance();
}
env = scheme_engine_instance_init();
return env;
}
#ifdef UNIX_LIMIT_STACK
{
struct rlimit rl;
getrlimit(RLIMIT_STACK, &rl);
if (rl.rlim_cur > UNIX_LIMIT_STACK) {
rl.rlim_cur = UNIX_LIMIT_STACK;
setrlimit(RLIMIT_STACK, &rl);
}
}
#endif
#ifdef UNIX_LIMIT_FDSET_SIZE
{
struct rlimit rl;
getrlimit(RLIMIT_NOFILE, &rl);
if (rl.rlim_cur > FD_SETSIZE) {
rl.rlim_cur = FD_SETSIZE;
setrlimit(RLIMIT_NOFILE, &rl);
}
}
#endif
#ifdef MZ_USE_IRIX_SPROCS
GC_INIT();
#endif
scheme_starting_up = 1;
#ifndef MZ_PRECISE_GC
scheme_init_setjumpup();
scheme_init_ephemerons();
#endif
#ifdef TIME_STARTUP_PROCESS
printf("#if 0\nbasic @ %ld\n", scheme_get_process_milliseconds());
#endif
scheme_init_stack_check();
scheme_init_overflow();
scheme_init_portable_case();
{
int i, k, cor;
#ifndef USE_TAGGED_ALLOCATION
GC_CAN_IGNORE Scheme_Local *all;
all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS);
# ifdef MEMORY_COUNTING_ON
scheme_misc_count += sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS;
# endif
#endif
for (i = 0; i < MAX_CONST_LOCAL_POS; i++) {
for (k = 0; k < 2; k++) {
for (cor = 0; cor < 3; cor++) {
Scheme_Object *v;
#ifndef USE_TAGGED_ALLOCATION
v = (Scheme_Object *)(all++);
#else
v = (Scheme_Object *)scheme_malloc_eternal_tagged(sizeof(Scheme_Local));
#endif
v->type = k + scheme_local_type;
SCHEME_LOCAL_POS(v) = i;
SCHEME_LOCAL_FLAGS(v) = cor;
scheme_local[i][k][cor] = v;
}
}
}
}
{
int i, k, cnst;
#ifndef USE_TAGGED_ALLOCATION
GC_CAN_IGNORE Scheme_Toplevel *all;
all = (Scheme_Toplevel *)scheme_malloc_eternal(sizeof(Scheme_Toplevel)
* MAX_CONST_TOPLEVEL_DEPTH
* MAX_CONST_TOPLEVEL_POS
* (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
# ifdef MEMORY_COUNTING_ON
scheme_misc_count += (sizeof(Scheme_Toplevel)
* MAX_CONST_TOPLEVEL_DEPTH
* MAX_CONST_TOPLEVEL_POS
* (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
# endif
#endif
for (i = 0; i < MAX_CONST_TOPLEVEL_DEPTH; i++) {
for (k = 0; k < MAX_CONST_TOPLEVEL_POS; k++) {
for (cnst = 0; cnst <= SCHEME_TOPLEVEL_FLAGS_MASK; cnst++) {
Scheme_Toplevel *v;
#ifndef USE_TAGGED_ALLOCATION
v = (all++);
#else
v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel));
#endif
v->iso.so.type = scheme_toplevel_type;
v->depth = i;
v->position = k;
SCHEME_TOPLEVEL_FLAGS(v) = cnst;
toplevels[i][k][cnst] = (Scheme_Object *)v;
}
}
}
}
#ifdef MZ_PRECISE_GC
scheme_register_traversers();
register_traversers();
scheme_init_hash_key_procs();
#endif
scheme_init_true_false();
static void init_toplevel_local_offsets_hashtable_caches()
{
REGISTER_SO(toplevels_ht);
REGISTER_SO(locals_ht[0]);
REGISTER_SO(locals_ht[1]);
@ -372,30 +280,85 @@ Scheme_Env *scheme_basic_env()
ht = scheme_make_hash_table(SCHEME_hash_ptr);
locals_ht[1] = ht;
}
}
/* READ-ONLY GLOBAL structures ONE-TIME initialization */
Scheme_Env *scheme_engine_instance_init() {
Scheme_Env *env;
void *stack_base;
stack_base = (void *) scheme_get_current_os_thread_stack_base();
os_platform_init();
#ifdef TIME_STARTUP_PROCESS
printf("pre-process @ %ld\n", scheme_get_process_milliseconds());
printf("#if 0\nengine_instance_init @ %ld\n", scheme_get_process_milliseconds());
#endif
scheme_starting_up = 1;
scheme_init_portable_case();
init_scheme_local();
init_toplevels();
scheme_init_true_false();
#ifdef MZ_PRECISE_GC
scheme_register_traversers();
register_traversers();
scheme_init_hash_key_procs();
#endif
scheme_init_getenv(); /* checks PLTNOJIT */
#ifdef WINDOWS_PROCESSES
/* Must be called before first scheme_make_thread() */
scheme_init_thread_memory();
#endif
scheme_init_getenv(); /* checks PLTNOJIT */
scheme_make_thread();
place_instance_init_pre_kernel(stack_base);
make_kernel_env();
env = place_instance_init_post_kernel();
return env;
}
static void place_instance_init_pre_kernel(void *stack_base) {
#ifdef TIME_STARTUP_PROCESS
printf("place_init @ %ld\n", scheme_get_process_milliseconds());
#endif
scheme_set_current_os_thread_stack_base(stack_base);
#ifndef MZ_PRECISE_GC
scheme_init_setjumpup();
scheme_init_ephemerons();
#endif
scheme_init_stack_check();
scheme_init_overflow();
init_toplevel_local_offsets_hashtable_caches();
#ifdef TIME_STARTUP_PROCESS
printf("pre-process @ %ld\n", scheme_get_process_milliseconds());
#endif
scheme_make_thread(stack_base);
#ifdef TIME_STARTUP_PROCESS
printf("process @ %ld\n", scheme_get_process_milliseconds());
#endif
}
make_init_env();
static Scheme_Env *place_instance_init_post_kernel() {
Scheme_Env *env;
env = scheme_make_empty_env();
scheme_set_param(scheme_current_config(), MZCONFIG_ENV,
(Scheme_Object *)env);
scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env);
scheme_init_memtrace(env);
#ifndef NO_TCP_SUPPORT
scheme_init_network(env);
@ -428,7 +391,12 @@ Scheme_Env *scheme_basic_env()
return env;
}
static void make_init_env(void)
Scheme_Env *scheme_place_instance_init(void *stack_base) {
place_instance_init_pre_kernel(stack_base);
return place_instance_init_post_kernel();
}
static void make_kernel_env(void)
{
Scheme_Env *env;
#ifdef TIME_STARTUP_PROCESS
@ -440,8 +408,8 @@ static void make_init_env(void)
scheme_set_param(scheme_current_config(), MZCONFIG_ENV,
(Scheme_Object *)env);
REGISTER_SO(scheme_initial_env);
scheme_initial_env = env;
REGISTER_SO(kernel_env);
kernel_env = env;
scheme_defining_primitives = 1;
builtin_ref_counter = 0;
@ -495,202 +463,52 @@ static void make_init_env(void)
#ifndef NO_REGEXP_UTILS
MZTIMEIT(regexp, scheme_regexp_initialize(env));
#endif
#ifdef MZ_USE_PLACES
MZTIMEIT(places, scheme_init_place(env));
#endif
MARK_START_TIME();
scheme_add_global_constant("namespace-symbol->identifier",
scheme_make_prim_w_arity(namespace_identifier,
"namespace-symbol->identifier",
1, 2),
env);
GLOBAL_PRIM_W_ARITY("namespace-symbol->identifier", namespace_identifier, 1, 2, env);
GLOBAL_PRIM_W_ARITY("namespace-module-identifier", namespace_module_identifier, 0, 1, env);
GLOBAL_PRIM_W_ARITY("namespace-base-phase", namespace_base_phase, 0, 1, env);
GLOBAL_PRIM_W_ARITY("namespace-variable-value", namespace_variable_value, 1, 4, env);
GLOBAL_PRIM_W_ARITY("namespace-set-variable-value!", namespace_set_variable_value, 2, 4, env);
GLOBAL_PRIM_W_ARITY("namespace-undefine-variable!", namespace_undefine_variable, 1, 2, env);
GLOBAL_PRIM_W_ARITY("namespace-mapped-symbols", namespace_mapped_symbols, 0, 1, env);
GLOBAL_PRIM_W_ARITY("namespace-module-registry", namespace_module_registry, 1, 1, env);
scheme_add_global_constant("namespace-module-identifier",
scheme_make_prim_w_arity(namespace_module_identifier,
"namespace-module-identifier",
0, 1),
env);
scheme_add_global_constant("namespace-base-phase",
scheme_make_prim_w_arity(namespace_base_phase,
"namespace-base-phase",
0, 1),
env);
GLOBAL_PRIM_W_ARITY("variable-reference->resolved-module-path", variable_module_path, 1, 1, env);
GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env);
GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env);
GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env);
GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env);
GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-certifier", local_certify, 0, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-module-defined-identifiers", local_module_definitions, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-module-required-identifiers", local_module_imports, 2, 2, env);
GLOBAL_PRIM_W_ARITY("syntax-local-transforming-module-provides?", local_module_expanding_provides, 0, 0, env);
scheme_add_global_constant("namespace-variable-value",
scheme_make_prim_w_arity(namespace_variable_value,
"namespace-variable-value",
1, 4),
env);
GLOBAL_PRIM_W_ARITY("make-set!-transformer", make_set_transformer, 1, 1, env);
GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env);
scheme_add_global_constant("namespace-set-variable-value!",
scheme_make_prim_w_arity(namespace_set_variable_value,
"namespace-set-variable-value!",
2, 4),
env);
GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 1, env);
GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env);
scheme_add_global_constant("namespace-undefine-variable!",
scheme_make_prim_w_arity(namespace_undefine_variable,
"namespace-undefine-variable!",
1, 2),
env);
scheme_add_global_constant("namespace-mapped-symbols",
scheme_make_prim_w_arity(namespace_mapped_symbols,
"namespace-mapped-symbols",
0, 1),
env);
scheme_add_global_constant("namespace-module-registry",
scheme_make_prim_w_arity(namespace_module_registry,
"namespace-module-registry",
1, 1),
env);
scheme_add_global_constant("variable-reference->resolved-module-path",
scheme_make_prim_w_arity(variable_module_path,
"variable-reference->resolved-module-path",
1, 1),
env);
scheme_add_global_constant("variable-reference->empty-namespace",
scheme_make_prim_w_arity(variable_namespace,
"variable-reference->empty-namespace",
1, 1),
env);
scheme_add_global_constant("variable-reference->namespace",
scheme_make_prim_w_arity(variable_top_level_namespace,
"variable-reference->namespace",
1, 1),
env);
scheme_add_global_constant("variable-reference->phase",
scheme_make_prim_w_arity(variable_phase,
"variable-reference->phase",
1, 1),
env);
scheme_add_global_constant("syntax-transforming?",
scheme_make_prim_w_arity(now_transforming,
"syntax-transforming?",
0, 0),
env);
scheme_add_global_constant("syntax-local-value",
scheme_make_prim_w_arity(local_exp_time_value,
"syntax-local-value",
1, 3),
env);
scheme_add_global_constant("syntax-local-name",
scheme_make_prim_w_arity(local_exp_time_name,
"syntax-local-name",
0, 0),
env);
scheme_add_global_constant("syntax-local-context",
scheme_make_prim_w_arity(local_context,
"syntax-local-context",
0, 0),
env);
scheme_add_global_constant("syntax-local-phase-level",
scheme_make_prim_w_arity(local_phase_level,
"syntax-local-phase-level",
0, 0),
env);
scheme_add_global_constant("syntax-local-make-definition-context",
scheme_make_prim_w_arity(local_make_intdef_context,
"syntax-local-make-definition-context",
0, 0),
env);
scheme_add_global_constant("syntax-local-get-shadower",
scheme_make_prim_w_arity(local_get_shadower,
"syntax-local-get-shadower",
1, 1),
env);
scheme_add_global_constant("syntax-local-introduce",
scheme_make_prim_w_arity(local_introduce,
"syntax-local-introduce",
1, 1),
env);
scheme_add_global_constant("make-syntax-introducer",
scheme_make_prim_w_arity(make_introducer,
"make-syntax-introducer",
0, 1),
env);
scheme_add_global_constant("syntax-local-certifier",
scheme_make_prim_w_arity(local_certify,
"syntax-local-certifier",
0, 1),
env);
scheme_add_global_constant("syntax-local-module-exports",
scheme_make_prim_w_arity(local_module_exports,
"syntax-local-module-exports",
1, 1),
env);
scheme_add_global_constant("syntax-local-module-defined-identifiers",
scheme_make_prim_w_arity(local_module_definitions,
"syntax-local-module-defined-identifiers",
0, 0),
env);
scheme_add_global_constant("syntax-local-module-required-identifiers",
scheme_make_prim_w_arity(local_module_imports,
"syntax-local-module-required-identifiers",
2, 2),
env);
scheme_add_global_constant("syntax-local-transforming-module-provides?",
scheme_make_prim_w_arity(local_module_expanding_provides,
"syntax-local-transforming-module-provides?",
0, 0),
env);
scheme_add_global_constant("make-set!-transformer",
scheme_make_prim_w_arity(make_set_transformer,
"make-set!-transformer",
1, 1),
env);
scheme_add_global_constant("set!-transformer?",
scheme_make_prim_w_arity(set_transformer_p,
"set!-transformer?",
1, 1),
env);
scheme_add_global_constant("set!-transformer-procedure",
scheme_make_prim_w_arity(set_transformer_proc,
"set!-transformer-procedure",
1, 1),
env);
scheme_add_global_constant("make-rename-transformer",
scheme_make_prim_w_arity(make_rename_transformer,
"make-rename-transformer",
1, 1),
env);
scheme_add_global_constant("rename-transformer?",
scheme_make_prim_w_arity(rename_transformer_p,
"rename-transformer?",
1, 1),
env);
scheme_add_global_constant("rename-transformer-target",
scheme_make_prim_w_arity(rename_transformer_target,
"rename-transformer-target",
1, 1),
env);
scheme_add_global_constant("syntax-local-lift-expression",
scheme_make_prim_w_arity(local_lift_expr,
"syntax-local-lift-expression",
1, 1),
env);
scheme_add_global_constant("syntax-local-lift-context",
scheme_make_prim_w_arity(local_lift_context,
"syntax-local-lift-context",
0, 0),
env);
scheme_add_global_constant("syntax-local-lift-module-end-declaration",
scheme_make_prim_w_arity(local_lift_end_statement,
"syntax-local-lift-module-end-declaration",
1, 1),
env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env);
{
Scheme_Object *sym;
@ -732,6 +550,88 @@ static void make_init_env(void)
scheme_defining_primitives = 0;
}
int scheme_is_kernel_env(Scheme_Env *env) {
return (env == kernel_env);
}
Scheme_Env *scheme_get_kernel_env() {
return kernel_env;
}
static void init_scheme_local()
{
int i, k, cor;
#ifndef USE_TAGGED_ALLOCATION
GC_CAN_IGNORE Scheme_Local *all;
all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS);
# ifdef MEMORY_COUNTING_ON
scheme_misc_count += sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS;
# endif
#endif
for (i = 0; i < MAX_CONST_LOCAL_POS; i++) {
for (k = 0; k < 2; k++) {
for (cor = 0; cor < 3; cor++) {
Scheme_Object *v;
#ifndef USE_TAGGED_ALLOCATION
v = (Scheme_Object *)(all++);
#else
v = (Scheme_Object *)scheme_malloc_eternal_tagged(sizeof(Scheme_Local));
#endif
v->type = k + scheme_local_type;
SCHEME_LOCAL_POS(v) = i;
SCHEME_LOCAL_FLAGS(v) = cor;
scheme_local[i][k][cor] = v;
}
}
}
}
static void init_toplevels()
{
int i, k, cnst;
#ifndef USE_TAGGED_ALLOCATION
GC_CAN_IGNORE Scheme_Toplevel *all;
all = (Scheme_Toplevel *)scheme_malloc_eternal(sizeof(Scheme_Toplevel)
* MAX_CONST_TOPLEVEL_DEPTH
* MAX_CONST_TOPLEVEL_POS
* (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
# ifdef MEMORY_COUNTING_ON
scheme_misc_count += (sizeof(Scheme_Toplevel)
* MAX_CONST_TOPLEVEL_DEPTH
* MAX_CONST_TOPLEVEL_POS
* (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
# endif
#endif
for (i = 0; i < MAX_CONST_TOPLEVEL_DEPTH; i++) {
for (k = 0; k < MAX_CONST_TOPLEVEL_POS; k++) {
for (cnst = 0; cnst <= SCHEME_TOPLEVEL_FLAGS_MASK; cnst++) {
Scheme_Toplevel *v;
#ifndef USE_TAGGED_ALLOCATION
v = (all++);
#else
v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel));
#endif
v->iso.so.type = scheme_toplevel_type;
v->depth = i;
v->position = k;
SCHEME_TOPLEVEL_FLAGS(v) = cnst;
toplevels[i][k][cnst] = (Scheme_Object *)v;
}
}
}
}
/* Shutdown procedure for resetting a namespace: */
static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)
{
@ -1238,6 +1138,7 @@ Scheme_Object **scheme_make_builtin_references_table(void)
Scheme_Bucket_Table *ht;
Scheme_Object **t;
Scheme_Bucket **bs;
Scheme_Env *kenv;
long i;
t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1));
@ -1245,7 +1146,9 @@ Scheme_Object **scheme_make_builtin_references_table(void)
scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1);
#endif
ht = scheme_initial_env->toplevel;
kenv = scheme_get_kernel_env();
ht = kenv->toplevel;
bs = ht->buckets;
@ -1263,9 +1166,12 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void)
Scheme_Bucket_Table *ht;
Scheme_Hash_Table*result;
Scheme_Bucket **bs;
Scheme_Env *kenv;
long i;
kenv = scheme_get_kernel_env();
ht = scheme_initial_env->toplevel;
ht = kenv->toplevel;
bs = ht->buckets;
result = scheme_make_hash_table(SCHEME_hash_ptr);
@ -4808,7 +4714,7 @@ static Scheme_Object *read_variable(Scheme_Object *obj)
varname = SCHEME_CDR(obj);
if (SAME_OBJ(modname, kernel_symbol) && !mod_phase) {
return (Scheme_Object *)scheme_global_bucket(varname, scheme_initial_env);
return (Scheme_Object *)scheme_global_bucket(varname, scheme_get_kernel_env());
} else {
Module_Variable *mv;
Scheme_Object *insp;

23
src/mzscheme/src/eval.c
View File

@ -247,8 +247,8 @@ static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Schem
typedef void (*DW_PrePost_Proc)(void *);
#ifdef USE_STACK_BOUNDARY_VAR
unsigned long scheme_stack_boundary;
unsigned long volatile scheme_jit_stack_boundary;
THREAD_LOCAL unsigned long scheme_stack_boundary;
THREAD_LOCAL unsigned long volatile scheme_jit_stack_boundary;
#endif
#ifdef MZ_PRECISE_GC
@ -526,23 +526,25 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
/* "Stack overflow" means running out of C-stack space. The other
end of this handler (i.e., the target for the longjmp) is
scheme_top_level_do in fun.c */
Scheme_Thread *p = scheme_current_thread;
Scheme_Overflow *overflow;
Scheme_Thread *p = scheme_current_thread;
Scheme_Overflow *overflow;
Scheme_Overflow_Jmp *jmp;
scheme_about_to_move_C_stack();
scheme_overflow_k = k;
p->overflow_k = k;
scheme_overflow_count++;
overflow = MALLOC_ONE_RT(Scheme_Overflow);
#ifdef MZTAG_REQUIRED
overflow->type = scheme_rt_overflow;
#endif
/* push old overflow */
overflow->prev = scheme_current_thread->overflow;
overflow->stack_start = p->stack_start;
p->overflow = overflow;
overflow->stack_start = p->stack_start;
jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
#ifdef MZTAG_REQUIRED
jmp->type = scheme_rt_overflow_jmp;
@ -551,6 +553,7 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
scheme_init_jmpup_buf(&overflow->jmp->cont);
scheme_zero_unneeded_rands(scheme_current_thread); /* for GC */
if (scheme_setjmpup(&overflow->jmp->cont, overflow->jmp, p->stack_start)) {
p = scheme_current_thread;
overflow = p->overflow;
@ -620,7 +623,7 @@ void scheme_init_stack_check()
#ifdef USE_STACK_BOUNDARY_VAR
if (!scheme_stack_boundary) {
# ifdef ASSUME_FIXED_STACK_SIZE
scheme_stack_boundary = scheme_get_stack_base();
scheme_stack_boundary = scheme_get_current_os_thread_stack_base();
if (stack_grows_up)
scheme_stack_boundary += (FIXED_STACK_SIZE - STACK_SAFETY_MARGIN);
else
@ -628,7 +631,7 @@ void scheme_init_stack_check()
# endif
# ifdef WINDOWS_FIND_STACK_BOUNDS
scheme_stack_boundary = scheme_get_stack_base();
scheme_stack_boundary = scheme_get_current_os_thread_stack_base();
scheme_stack_boundary += (STACK_SAFETY_MARGIN - 0x100000);
# endif
@ -661,7 +664,7 @@ void scheme_init_stack_check()
{
unsigned long bnd, lim;
bnd = (unsigned long)scheme_get_stack_base();
bnd = (unsigned long)scheme_get_current_os_thread_stack_base();
lim = (unsigned long)rl.rlim_cur;
# ifdef UNIX_STACK_MAXIMUM

8
src/mzscheme/src/fun.c
View File

@ -1809,8 +1809,8 @@ static void initialize_prompt(Scheme_Thread *p, Scheme_Prompt *prompt, void *sta
typedef Scheme_Object *(*Overflow_K_Proc)(void);
Scheme_Overflow_Jmp *scheme_overflow_jmp;
void *scheme_overflow_stack_start;
THREAD_LOCAL Scheme_Overflow_Jmp *scheme_overflow_jmp;
THREAD_LOCAL void *scheme_overflow_stack_start;
/* private, but declared public to avoid inlining: */
void scheme_really_create_overflow(void *stack_base)
@ -1830,7 +1830,7 @@ void scheme_really_create_overflow(void *stack_base)
scheme_init_jmpup_buf(&jmp->cont);
if (scheme_setjmpup(&jmp->cont, jmp, stack_base)) {
/* A jump into here is a request to handle overflow.
The way to continue is in scheme_overflow_k.
The way to continue is in p->overflow_k.
When we get back, put the result into
scheme_overflow_reply. The route to return is
in the thread's `overflow' field. */
@ -1850,7 +1850,7 @@ void scheme_really_create_overflow(void *stack_base)
} else {
void *p1, *p2, *p3, *p4, *p5;
long i1, i2, i3, i4;
Overflow_K_Proc f = scheme_overflow_k;
Overflow_K_Proc f = p->overflow_k;
Scheme_Object *reply;
p1 = p->ku.k.p1;

184
src/mzscheme/src/module.c
View File

@ -321,136 +321,31 @@ void scheme_init_module(Scheme_Env *env)
scheme_init_module_resolver();
scheme_add_global_constant("current-module-name-resolver",
scheme_register_parameter(current_module_name_resolver,
"current-module-name-resolver",
MZCONFIG_CURRENT_MODULE_RESOLVER),
env);
scheme_add_global_constant("current-module-declare-name",
scheme_register_parameter(current_module_name_prefix,
"current-module-declare-name",
MZCONFIG_CURRENT_MODULE_NAME),
env);
GLOBAL_PARAMETER("current-module-name-resolver", current_module_name_resolver, MZCONFIG_CURRENT_MODULE_RESOLVER, env);
GLOBAL_PARAMETER("current-module-declare-name", current_module_name_prefix, MZCONFIG_CURRENT_MODULE_NAME, env);
scheme_add_global_constant("dynamic-require",
scheme_make_prim_w_arity(scheme_dynamic_require,
"dynamic-require",
2, 2),
env);
scheme_add_global_constant("dynamic-require-for-syntax",
scheme_make_prim_w_arity(dynamic_require_for_syntax,
"dynamic-require-for-syntax",
2, 2),
env);
scheme_add_global_constant("namespace-require",
scheme_make_prim_w_arity(namespace_require,
"namespace-require",
1, 1),
env);
scheme_add_global_constant("namespace-attach-module",
scheme_make_prim_w_arity(namespace_attach_module,
"namespace-attach-module",
2, 3),
env);
scheme_add_global_constant("namespace-unprotect-module",
scheme_make_prim_w_arity(namespace_unprotect_module,
"namespace-unprotect-module",
2, 3),
env);
scheme_add_global_constant("namespace-require/copy",
scheme_make_prim_w_arity(namespace_require_copy,
"namespace-require/copy",
1, 1),
env);
scheme_add_global_constant("namespace-require/constant",
scheme_make_prim_w_arity(namespace_require_constant,
"namespace-require/constant",
1, 1),
env);
scheme_add_global_constant("namespace-require/expansion-time",
scheme_make_prim_w_arity(namespace_require_etonly,
"namespace-require/expansion-time",
1, 1),
env);
scheme_add_global_constant("compiled-module-expression?",
scheme_make_prim_w_arity(module_compiled_p,
"compiled-module-expression?",
1, 1),
env);
scheme_add_global_constant("module-compiled-name",
scheme_make_prim_w_arity(module_compiled_name,
"module-compiled-name",
1, 1),
env);
scheme_add_global_constant("module-compiled-imports",
scheme_make_prim_w_arity(module_compiled_imports,
"module-compiled-imports",
1, 1),
env);
scheme_add_global_constant("module-compiled-exports",
scheme_make_prim_w_arity2(module_compiled_exports,
"module-compiled-exports",
1, 1,
2, 2),
env);
scheme_add_global_constant("module-path-index?",
scheme_make_folding_prim(module_path_index_p,
"module-path-index?",
1, 1, 1),
env);
scheme_add_global_constant("module-path-index-resolve",
scheme_make_prim_w_arity(module_path_index_resolve,
"module-path-index-resolve",
1, 1),
env);
scheme_add_global_constant("module-path-index-split",
scheme_make_prim_w_arity2(module_path_index_split,
"module-path-index-split",
1, 1,
2, 2),
env);
scheme_add_global_constant("module-path-index-join",
scheme_make_prim_w_arity(module_path_index_join,
"module-path-index-join",
2, 2),
env);
scheme_add_global_constant("resolved-module-path?",
scheme_make_folding_prim(resolved_module_path_p,
"resolved-module-path?",
1, 1, 1),
env);
scheme_add_global_constant("make-resolved-module-path",
scheme_make_prim_w_arity(make_resolved_module_path,
"make-resolved-module-path",
1, 1),
env);
scheme_add_global_constant("resolved-module-path-name",
scheme_make_prim_w_arity(resolved_module_path_name,
"resolved-module-path-name",
1, 1),
env);
scheme_add_global_constant("module-provide-protected?",
scheme_make_prim_w_arity(module_export_protected_p,
"module-provide-protected?",
2, 2),
env);
scheme_add_global_constant("module->namespace",
scheme_make_prim_w_arity(module_to_namespace,
"module->namespace",
1, 1),
env);
scheme_add_global_constant("module-path?",
scheme_make_prim_w_arity(is_module_path,
"module-path?",
1, 1),
env);
GLOBAL_PRIM_W_ARITY("dynamic-require", scheme_dynamic_require, 2, 2, env);
GLOBAL_PRIM_W_ARITY("dynamic-require-for-syntax", dynamic_require_for_syntax, 2, 2, env);
GLOBAL_PRIM_W_ARITY("namespace-require", namespace_require, 1, 1, env);
GLOBAL_PRIM_W_ARITY("namespace-attach-module", namespace_attach_module, 2, 3, env);
GLOBAL_PRIM_W_ARITY("namespace-unprotect-module", namespace_unprotect_module, 2, 3, env);
GLOBAL_PRIM_W_ARITY("namespace-require/copy", namespace_require_copy, 1, 1, env);
GLOBAL_PRIM_W_ARITY("namespace-require/constant", namespace_require_constant, 1, 1, env);
GLOBAL_PRIM_W_ARITY("namespace-require/expansion-time", namespace_require_etonly, 1, 1, env);
GLOBAL_PRIM_W_ARITY("compiled-module-expression?", module_compiled_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("module-compiled-name", module_compiled_name, 1, 1, env);
GLOBAL_PRIM_W_ARITY("module-compiled-imports", module_compiled_imports, 1, 1, env);
GLOBAL_PRIM_W_ARITY2("module-compiled-exports", module_compiled_exports, 1, 1, 2, 2, env);
GLOBAL_FOLDING_PRIM("module-path-index?", module_path_index_p, 1, 1, 1, env);
GLOBAL_PRIM_W_ARITY("module-path-index-resolve", module_path_index_resolve, 1, 1, env);
GLOBAL_PRIM_W_ARITY2("module-path-index-split", module_path_index_split, 1, 1, 2, 2, env);
GLOBAL_PRIM_W_ARITY("module-path-index-join", module_path_index_join, 2, 2, env);
GLOBAL_FOLDING_PRIM("resolved-module-path?", resolved_module_path_p, 1, 1, 1, env);
GLOBAL_PRIM_W_ARITY("make-resolved-module-path", make_resolved_module_path, 1, 1, env);
GLOBAL_PRIM_W_ARITY("resolved-module-path-name", resolved_module_path_name, 1, 1, env);
GLOBAL_PRIM_W_ARITY("module-provide-protected?", module_export_protected_p, 2, 2, env);
GLOBAL_PRIM_W_ARITY("module->namespace", module_to_namespace, 1, 1, env);
GLOBAL_PRIM_W_ARITY("module-path?", is_module_path, 1, 1, env);
}
void scheme_init_module_resolver(void)
@ -487,8 +382,8 @@ void scheme_finish_kernel(Scheme_Env *env)
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
scheme_initial_env->module = kernel;
scheme_initial_env->insp = insp;
env->module = kernel;
env->insp = insp;
kernel->modname = kernel_modname;
kernel->requires = scheme_null;
@ -503,9 +398,9 @@ void scheme_finish_kernel(Scheme_Env *env)
count = 0;
for (j = 0; j < 2; j++) {
if (!j)
ht = scheme_initial_env->toplevel;
ht = env->toplevel;
else {
ht = scheme_initial_env->syntax;
ht = env->syntax;
syntax_start = count;
}
@ -521,9 +416,9 @@ void scheme_finish_kernel(Scheme_Env *env)
count = 0;
for (j = 0; j < 2; j++) {
if (!j)
ht = scheme_initial_env->toplevel;
ht = env->toplevel;
else
ht = scheme_initial_env->syntax;
ht = env->syntax;
bs = ht->buckets;
for (i = ht->size; i--; ) {
@ -550,9 +445,9 @@ void scheme_finish_kernel(Scheme_Env *env)
kernel->me->rt->num_provides = count;
kernel->me->rt->num_var_provides = syntax_start;
scheme_initial_env->running = 1;
scheme_initial_env->et_running = 1;
scheme_initial_env->attached = 1;
env->running = 1;
env->et_running = 1;
env->attached = 1;
/* Since this is the first module rename, it's registered as
the kernel module rename: */
@ -3160,7 +3055,7 @@ static void setup_accessible_table(Scheme_Module *m)
Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, int rev_mod_phase)
{
if ((name == kernel_modname) && !rev_mod_phase)
return scheme_initial_env;
return scheme_get_kernel_env();
else {
Scheme_Object *chain;
Scheme_Env *menv;
@ -3244,9 +3139,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
{
symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL);
if ((env == scheme_initial_env)
|| ((env->module->primitive
&& !env->module->provide_protects))
if (scheme_is_kernel_env(env)
|| ((env->module->primitive && !env->module->provide_protects))
/* For now[?], we're pretending that all definitions exists for
non-0 local phase. */
|| env->mod_phase) {
@ -3404,8 +3298,10 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem
Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name)
{
if (modname == kernel_modname) {
Scheme_Env *kenv;
kenv = scheme_get_kernel_env();
name = SCHEME_STX_SYM(name);
return scheme_lookup_in_table(scheme_initial_env->syntax, (char *)name);
return scheme_lookup_in_table(kenv->syntax, (char *)name);
} else {
Scheme_Env *menv;
Scheme_Object *val;
@ -4491,7 +4387,7 @@ module_execute(Scheme_Object *data)
env = scheme_environment_from_dummy(m->dummy);
if (SAME_OBJ(m->modname, kernel_modname))
old_menv = scheme_initial_env;
old_menv = scheme_get_kernel_env();
else
old_menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);

52
src/mzscheme/src/mzmark.c
View File

@ -2701,6 +2701,31 @@ static int mark_log_reader_FIXUP(void *p) {
/**********************************************************************/
#ifdef MARKS_FOR_ENGINE_C
static int engine_val_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Engine));
}
static int engine_val_MARK(void *p) {
Scheme_Engine *en = (Scheme_Engine *)p;
return
gcBYTES_TO_WORDS(sizeof(Scheme_Engine));
}
static int engine_val_FIXUP(void *p) {
Scheme_Engine *en = (Scheme_Engine *)p;
return
gcBYTES_TO_WORDS(sizeof(Scheme_Engine));
}
#define engine_val_IS_ATOMIC 0
#define engine_val_IS_CONST_SIZE 1
#endif /* ENGINE */
#ifdef MARKS_FOR_ENV_C
static int mark_comp_env_SIZE(void *p) {
@ -3219,6 +3244,33 @@ static int mark_rb_node_FIXUP(void *p) {
/**********************************************************************/
#ifdef MARKS_FOR_PLACES_C
static int place_val_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Place));
}
static int place_val_MARK(void *p) {
Scheme_Place *pr = (Scheme_Place *)p;
return
gcBYTES_TO_WORDS(sizeof(Scheme_Place));
}
static int place_val_FIXUP(void *p) {
Scheme_Place *pr = (Scheme_Place *)p;
return
gcBYTES_TO_WORDS(sizeof(Scheme_Place));
}
#define place_val_IS_ATOMIC 0
#define place_val_IS_CONST_SIZE 1
#endif /* PLACES */
/**********************************************************************/
#ifdef MARKS_FOR_PORTFUN_C
static int mark_load_handler_data_SIZE(void *p) {

24
src/mzscheme/src/mzmarksrc.c
View File

@ -1074,6 +1074,17 @@ END type;
/**********************************************************************/
START engine;
engine_val {
mark:
Scheme_Engine *en = (Scheme_Engine *)p;
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Engine));
}
END engine;
START env;
mark_comp_env {
@ -1299,6 +1310,19 @@ END hash;
/**********************************************************************/
START places;
place_val {
mark:
Scheme_Place *pr = (Scheme_Place *)p;
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Place));
}
END places;
/**********************************************************************/
START portfun;
mark_load_handler_data {

358
src/mzscheme/src/mzrt.c Normal file
View File

@ -0,0 +1,358 @@
#include "schpriv.h"
#ifdef MZ_USE_PLACES
/************************************************************************/
/************************************************************************/
/************************************************************************/
#include "mzrt.h"
#include "schgc.h"
#ifdef MZ_XFORM
START_XFORM_SUSPEND;
#endif
/* std C headers */
#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
#include <../sconfig.h>
/* platform headers */
#ifdef WIN32
# include <windows.h>
#else
# include <pthread.h>
# include <signal.h>
# include <unistd.h>
# include <time.h>
# if defined(UNIX_LIMIT_STACK) || defined(UNIX_LIMIT_FDSET_SIZE)
# include <signal.h>
# include <sys/time.h>
# include <sys/resource.h>
# endif
#endif
void mzrt_set_user_break_handler(void (*user_break_handler)(int))
{
#ifdef WIN32
#else
signal(SIGINT, user_break_handler);
#endif
}
static void segfault_handler(int signal_num) {
#ifdef WIN32
#else
pid_t pid = getpid();
char buffer[500];
char buf[500];
signal(SIGSEGV, segfault_handler);
fprintf(stderr, "%i %i resume(r)/gdb(d)/exit(e)?\n", signal_num, pid);
fflush(stderr);
while(read(fileno(stdin), buf, 100) <= 0){
if(errno != EINTR){
fprintf(stderr, "\nCould not read response, sleeping for 20 seconds.\n");
}
switch(buf[0]) {
case 'r':
return;
break;
case 'd':
snprintf(buffer, 500, "xterm -e gdb ./mzschemecgc %d &", pid);
fprintf(stderr, "%i %i Launching GDB", signal_num, pid);
system(buffer);
break;
case 'e':
default:
exit(1);
break;
}
}
#endif
}
void mzrt_set_segfault_debug_handler()
{
#ifdef WIN32
#else
signal(SIGSEGV, segfault_handler);
#endif
}
void mzrt_sleep(int seconds)
{
#ifdef WIN32
#else
struct timespec set;
struct timespec rem;
set.tv_sec = seconds;
set.tv_nsec = 0;
rem.tv_sec = 0;
rem.tv_nsec = 0;
while ((-1 == nanosleep(&set, &rem))) {
//fprintf(stderr, "%i %i INITIAL\n", set.tv_sec, set.tv_nsec);
//fprintf(stderr, "%i %i LEFT\n", rem.tv_sec, rem.tv_nsec);
set = rem;
//fprintf(stderr, "%i %i NOW\n", set.tv_sec, set.tv_nsec);
}
#endif
}
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif
/***********************************************************************/
/* Atomic Ops */
/***********************************************************************/
MZ_INLINE2 uint32_t mzrt_atomic_add_32(volatile unsigned int *counter, unsigned int value) {
#ifdef WIN32
# if defined(__MINGW32__)
return InterlockedExchangeAdd((long *)counter, value);
# else
return InterlockedExchangeAdd(counter, value);
# endif
#elif defined (__GNUC__) && (__i386__)
asm volatile ("lock; xaddl %0,%1"
: "=r" (value), "=m" (*counter)
: "0" (value), "m" (*counter)
: "memory", "cc");
return value;
#else
#error !!!Atomic ops not provided!!!
#endif
}
/* returns the pre-incremented value */
MZ_INLINE2 uint32_t mzrt_atomic_incr_32(volatile unsigned int *counter) {
return mzrt_atomic_add_32(counter, 1);
}
/***********************************************************************/
/* Threads */
/***********************************************************************/
typedef struct {
#ifdef WIN32
HANDLE threadid;
#else
pthread_t threadid;
#endif
} mz_proc_thread;
#ifdef WIN32
typedef DWORD (WINAPI *mz_proc_thread_start)(void*);
#else
typedef void *(mz_proc_thread_start)(void*);
#endif
mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* data) {
mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread));
#ifdef WIN32
# ifndef MZ_PRECISE_GC
thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL);
# else
thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL);
# endif
#else
# ifndef MZ_PRECISE_GC
GC_pthread_create(&thread->threadid, NULL, start_proc, data);
# else
pthread_create(&thread->threadid, NULL, start_proc, data);
# endif
#endif
return thread;
}
void * mz_proc_thread_wait(mz_proc_thread *thread) {
#ifdef WIN32
DWORD rc;
WaitForSingleObject(thread->threadid,INFINITE);
GetExitCodeThread(thread->threadid, &rc);
return (void *) rc;
#else
void *rc;
# ifndef MZ_PRECISE_GC
GC_pthread_join(thread->threadid, &rc);
# else
pthread_join(thread->threadid, &rc);
# endif
return rc;
#endif
}
/***********************************************************************/
/* RW Lock */
/***********************************************************************/
/* Unix **************************************************************/
#ifndef WIN32
#ifdef MZ_XFORM
START_XFORM_SUSPEND;
#endif
typedef struct mzrt_rwlock {
pthread_rwlock_t lock;
} mzrt_rwlock;
int mzrt_rwlock_create(mzrt_rwlock **lock) {
*lock = malloc(sizeof(mzrt_rwlock));
return pthread_rwlock_init(&(*lock)->lock, NULL);
}
int mzrt_rwlock_rdlock(mzrt_rwlock *lock) {
return pthread_rwlock_rdlock(&lock->lock);
}
int mzrt_rwlock_wrlock(mzrt_rwlock *lock) {
return pthread_rwlock_rdlock(&lock->lock);
}
int mzrt_rwlock_tryrdlock(mzrt_rwlock *lock) {
return pthread_rwlock_tryrdlock(&lock->lock);
}
int mzrt_rwlock_trywrlock(mzrt_rwlock *lock) {
return pthread_rwlock_trywrlock(&lock->lock);
}
int mzrt_rwlock_unlock(mzrt_rwlock *lock) {
return pthread_rwlock_unlock(&lock->lock);
}
int mzrt_rwlock_destroy(mzrt_rwlock *lock) {
return pthread_rwlock_destroy(&lock->lock);
}
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif
#endif
/* Windows **************************************************************/
#ifdef WIN32
#ifdef MZ_XFORM
START_XFORM_SUSPEND;
#endif
typedef struct mzrt_rwlock {
HANDLE readEvent;
HANDLE writeMutex;
unsigned long readers;
} mzrt_rwlock;
int mzrt_rwlock_create(mzrt_rwlock **lock) {
*lock = malloc(sizeof(mzrt_rwlock));
(*lock)->readers = 0;
/* CreateEvent(LPSECURITY_ATTRIBUTES, manualReset, initiallySignaled, LPCSTR name) */
if (! ((*lock)->readEvent = CreateEvent(NULL, TRUE, FALSE, NULL)))
return 0;
if (! ((*lock)->writeMutex = CreateMutex(NULL, FALSE, NULL)))
return 0;
return 1;
}
static int get_win32_os_error() {
return 0;
}
static int mzrt_rwlock_rdlock_worker(mzrt_rwlock *lock, DWORD millis) {
DWORD rc = WaitForSingleObject(lock->writeMutex, millis);
if (rc == WAIT_FAILED || rc == WAIT_TIMEOUT );
return 0;
InterlockedIncrement(&lock->readers);
if (! ResetEvent(lock->readEvent))
return 0;
if (!ReleaseMutex(lock->writeMutex))
return 0;
return 1;
}
static int mzrt_rwlock_wrlock_worker(mzrt_rwlock *lock, DWORD millis) {
DWORD rc = WaitForSingleObject(lock->writeMutex, millis);
if (rc == WAIT_FAILED || rc == WAIT_TIMEOUT );
return 0;
if (lock->readers) {
if (millis) {
rc = WaitForSingleObject(lock->readEvent, millis);
}
else {
rc = WAIT_TIMEOUT;
}
if (rc == WAIT_FAILED || rc == WAIT_TIMEOUT );
return 0;
}
return 1;
}
int mzrt_rwlock_rdlock(mzrt_rwlock *lock) {
return mzrt_rwlock_rdlock_worker(lock, INFINITE);
}
int mzrt_rwlock_wrlock(mzrt_rwlock *lock) {
return mzrt_rwlock_wrlock_worker(lock, INFINITE);
}
int mzrt_rwlock_tryrdlock(mzrt_rwlock *lock) {
return mzrt_rwlock_rdlock_worker(lock, 0);
}
int mzrt_rwlock_trywrlock(mzrt_rwlock *lock) {
return mzrt_rwlock_wrlock_worker(lock, 0);
}
int mzrt_rwlock_unlock(mzrt_rwlock *lock) {
DWORD rc = 0;
if (!ReleaseMutex(lock->writeMutex)) {
rc = get_win32_os_error();
}
if (rc == ERROR_NOT_OWNER) {
if (lock->readers && !InterlockedDecrement(&lock->readers) && !SetEvent(lock->readEvent)) {
rc = get_win32_os_error();
}
else {
rc = 0;
}
}
return !rc;
}
int mzrt_rwlock_destroy(mzrt_rwlock *lock) {
int rc = 1;
rc &= CloseHandle(lock->readEvent);
rc &= CloseHandle(lock->writeMutex);
return rc;
}
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif
#endif
/************************************************************************/
/************************************************************************/
/************************************************************************/
#endif

48
src/mzscheme/src/mzrt.h Normal file
View File

@ -0,0 +1,48 @@
#ifndef MZRT_H
#define MZRT_H
#ifdef MZ_USE_PLACES
/****************** ATOMIC OPERATIONS ************************************/
/* mzrt_atomic_ops.c */
#ifdef _MSC_VER
typedef unsigned int uint32_t;
#else
# include <stdint.h>
#endif
MZ_INLINE2 uint32_t mzrt_atomic_add_32(volatile unsigned int *counter, unsigned int value);
MZ_INLINE2 uint32_t mzrt_atomic_incr_32(volatile unsigned int *counter);
/****************** SIGNAL HANDLING ***************************************/
/* mzrt.c */
void mzrt_set_segfault_debug_handler();
void mzrt_set_user_break_handler(void (*user_break_handler)(int));
/****************** PROCESS WEIGHT THREADS ********************************/
/* mzrt_threads.c */
typedef struct mz_proc_thread mz_proc_thread; /* OPAQUE DEFINITION */
typedef void *(mz_proc_thread_start)(void*);
mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start*, void* data);
void *mz_proc_thread_wait(mz_proc_thread *thread);
void mzrt_sleep(int seconds);
/****************** THREAD RWLOCK ******************************************/
/* mzrt_rwlock_*.c */
typedef struct mzrt_rwlock mzrt_rwlock; /* OPAQUE DEFINITION */
int mzrt_rwlock_create(mzrt_rwlock **lock);
int mzrt_rwlock_rdlock(mzrt_rwlock *lock);
int mzrt_rwlock_wrlock(mzrt_rwlock *lock);
int mzrt_rwlock_tryrdlock(mzrt_rwlock *lock);
int mzrt_rwlock_trywrlock(mzrt_rwlock *lock);
int mzrt_rwlock_unlock(mzrt_rwlock *lock);
int mzrt_rwlock_destroy(mzrt_rwlock *lock);
#endif
#endif

2
src/mzscheme/src/numstr.c
View File

@ -2059,7 +2059,7 @@ static Scheme_Object *real_to_bytes (int argc, Scheme_Object *argv[])
d = scheme_get_val_as_double(n);
if (size == 4) {
float f = d;
float f = (float) d;
memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &f, sizeof(float));
} else {
memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &d, sizeof(double));

191
src/mzscheme/src/places.c Normal file
View File

@ -0,0 +1,191 @@
#include "schpriv.h"
#ifdef MZ_USE_PLACES
/************************************************************************/
/************************************************************************/
/************************************************************************/
#include "mzrt.h"
Scheme_Object *scheme_place(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_sleep(int argc, Scheme_Object *args[]);
static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[]);
static void load_namespace(char *namespace_name);
static void load_namespace_utf8(Scheme_Object *namespace_name);
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
static void *place_start_proc(void *arg);
/*========================================================================*/
/* initialization */
/*========================================================================*/
void scheme_init_place(Scheme_Env *env)
{
Scheme_Env *plenv;
#ifdef MZ_PRECISE_GC
register_traversers();
#endif
plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env);
scheme_add_global_constant("place", scheme_make_prim_w_arity(scheme_place, "place", 1, 1), plenv);
scheme_add_global_constant("place_sleep", scheme_make_prim_w_arity(scheme_place_sleep, "place_sleep", 1, 1), plenv);
scheme_add_global_constant("place_wait", scheme_make_prim_w_arity(scheme_place_wait, "place_wait", 1, 1), plenv);
scheme_add_global_constant("place?", scheme_make_prim_w_arity(scheme_place_p, "place?", 1, 1), plenv);
scheme_add_global_constant("place6", scheme_make_prim_w_arity(scheme_place, "place6", 1, 1), plenv);
scheme_add_global_constant("place5", scheme_make_prim_w_arity(scheme_place, "place5", 1, 1), plenv);
scheme_add_global_constant("place4", scheme_make_prim_w_arity(scheme_place, "place4", 1, 1), plenv);
scheme_add_global_constant("place3", scheme_make_prim_w_arity(scheme_place, "place3", 1, 1), plenv);
scheme_add_global_constant("place2", scheme_make_prim_w_arity(scheme_place, "place2", 1, 1), plenv);
scheme_add_global_constant("place1", scheme_make_prim_w_arity(scheme_place, "place1", 1, 1), plenv);
scheme_finish_primitive_module(plenv);
}
typedef struct Place_Start_Data {
Scheme_Object *thunk;
} Place_Start_Data;
static void null_out_runtime_globals() {
scheme_current_thread = NULL;
scheme_first_thread = NULL;
scheme_main_thread = NULL;
scheme_current_runstack_start = NULL;
scheme_current_runstack = NULL;
scheme_current_cont_mark_stack = 0;
scheme_current_cont_mark_pos = 0;
}
Scheme_Object *scheme_place_sleep(int argc, Scheme_Object *args[]) {
mzrt_sleep(SCHEME_INT_VAL(args[0]));
return scheme_void;
}
Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
Scheme_Place *place;
Place_Start_Data *place_data;
mz_proc_thread *proc_thread;
/* create place object */
place = MALLOC_ONE_TAGGED(Scheme_Place);
place->so.type = scheme_place_type;
scheme_console_printf("Hello creating new place %p\n", place);
/* pass critical info to new place */
place_data = (Place_Start_Data*)malloc(sizeof(Place_Start_Data));
place_data->thunk = args[0];
/* create new place */
proc_thread = mz_proc_thread_create(place_start_proc, place_data);
place->proc_thread = proc_thread;
return (Scheme_Object*) place;
}
static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) {
void *rc;
Scheme_Place *place;
place = (Scheme_Place *) args[0];
rc = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread);
return args[0];
}
static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[])
{
return SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type) ? scheme_true : scheme_false;
}
static void load_namespace(char *namespace_name) {
load_namespace_utf8( scheme_make_utf8_string(namespace_name));
}
static void load_namespace_utf8(Scheme_Object *namespace_name) {
Scheme_Object *nsreq;
Scheme_Object *a[1];
Scheme_Thread * volatile p;
mz_jmp_buf * volatile saved_error_buf;
mz_jmp_buf volatile new_error_buf;
nsreq = scheme_builtin_value("namespace-require");
a[0] = scheme_make_pair(scheme_intern_symbol("lib"),
scheme_make_pair(namespace_name, scheme_make_null()));
p = scheme_get_current_thread();
saved_error_buf = p->error_buf;
p->error_buf = &new_error_buf;
if (!scheme_setjmp(new_error_buf))
scheme_apply(nsreq, 1, a);
p->error_buf = saved_error_buf;
}
static void *place_start_proc(void *data_arg) {
void *stack_base;
Scheme_Object *thunk;
Place_Start_Data *place_data;
stack_base = PROMPT_STACK(stack_base);
place_data = (Place_Start_Data *) data_arg;
/* create a pristine thread */
null_out_runtime_globals();
REGISTER_SO(scheme_current_thread);
REGISTER_SO(scheme_first_thread);
REGISTER_SO(scheme_main_thread);
REGISTER_SO(scheme_thread_set_top);
/* scheme_make_thread behaves differently if the above global vars are not null */
scheme_place_instance_init();
load_namespace("scheme/init");
thunk = place_data->thunk;
scheme_console_printf("Hello in new place %p\n", thunk);
scheme_apply(thunk, 0, NULL);
stack_base = NULL;
return NULL;
}
/*========================================================================*/
/* precise GC traversers */
/*========================================================================*/
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#define MARKS_FOR_PLACES_C
#include "mzmark.c"
static void register_traversers(void)
{
GC_REG_TRAV(scheme_place_type, place_val);
}
END_XFORM_SKIP;
#endif
/************************************************************************/
/************************************************************************/
/************************************************************************/
#endif

26
src/mzscheme/src/salloc.c
View File

@ -44,6 +44,8 @@ static int *dgc_count;
static int dgc_size;
extern int scheme_num_copied_stacks;
static unsigned long scheme_primordial_os_thread_stack_base;
static THREAD_LOCAL unsigned long scheme_os_thread_stack_base;
#if defined(MZ_XFORM) && !defined(MZ_PRECISE_GC)
void **GC_variable_stack;
@ -60,7 +62,7 @@ extern MZ_DLLIMPORT void GC_init();
extern MZ_DLLIMPORT unsigned long GC_get_stack_base();
#endif
void scheme_set_stack_base(void *base, int no_auto_statics)
void scheme_set_primordial_stack_base(void *base, int no_auto_statics)
{
#ifdef MZ_PRECISE_GC
GC_init_type_tags(_scheme_last_type_,
@ -70,6 +72,10 @@ void scheme_set_stack_base(void *base, int no_auto_statics)
/* We want to be able to allocate symbols early. */
scheme_register_traversers();
#endif
scheme_primordial_os_thread_stack_base = (unsigned long) base;
scheme_os_thread_stack_base = (unsigned long) base;
#if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC)
GC_set_stack_base(base);
/* no_auto_statics must always be true! */
@ -80,7 +86,7 @@ void scheme_set_stack_base(void *base, int no_auto_statics)
GC_init();
GC_clear_roots();
} else {
# if defined(__APPLE__) && defined(__MACH__)
# if (defined(__APPLE__) && defined(__MACH__)) || defined(MZ_USE_IRIX_SPROCS)
GC_init(); /* For Darwin, CGC requires GC_init() always */
# endif
}
@ -88,6 +94,16 @@ void scheme_set_stack_base(void *base, int no_auto_statics)
use_registered_statics = no_auto_statics;
}
void scheme_set_current_os_thread_stack_base(void *base)
{
scheme_os_thread_stack_base = (unsigned long) base;
}
unsigned long scheme_get_current_os_thread_stack_base()
{
return scheme_os_thread_stack_base;
}
typedef struct {
Scheme_Env_Main _main;
int argc;
@ -116,7 +132,7 @@ int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void
void *stack_start;
int volatile return_code;
scheme_set_stack_base(PROMPT_STACK(stack_start), no_auto_statics);
scheme_set_primordial_stack_base(PROMPT_STACK(stack_start), no_auto_statics);
return_code = _main(data);
@ -128,9 +144,9 @@ int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void
return return_code;
}
void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics)
void scheme_set_primordial_stack_bounds(void *base, void *deepest, int no_auto_statics)
{
scheme_set_stack_base(base, no_auto_statics);
scheme_set_primordial_stack_base(base, no_auto_statics);
#ifdef USE_STACK_BOUNDARY_VAR
if (deepest) {

2
src/mzscheme/src/schemef.h
View File

@ -68,7 +68,7 @@ MZ_EXTERN Scheme_Object *scheme_current_break_cell();
/*========================================================================*/
#ifndef LINK_EXTENSIONS_BY_TABLE
MZ_EXTERN Scheme_Thread *scheme_current_thread;
extern THREAD_LOCAL Scheme_Thread *scheme_current_thread;
MZ_EXTERN volatile int scheme_fuel_counter;
#else
MZ_EXTERN Scheme_Thread **scheme_current_thread_ptr;

2
src/mzscheme/src/schemex.h
View File

@ -54,7 +54,7 @@ Scheme_Object *(*scheme_current_break_cell)();
/* threads */
/*========================================================================*/
#ifndef LINK_EXTENSIONS_BY_TABLE
Scheme_Thread *scheme_current_thread;
THREAD_LOCAL Scheme_Thread;
volatile int scheme_fuel_counter;
#else
Scheme_Thread **scheme_current_thread_ptr;

2
src/mzscheme/src/schemex.inc
View File

@ -19,7 +19,7 @@
scheme_extension_table->scheme_inherit_cells = scheme_inherit_cells;
scheme_extension_table->scheme_current_break_cell = scheme_current_break_cell;
#ifndef LINK_EXTENSIONS_BY_TABLE
scheme_extension_table->scheme_current_thread = scheme_current_thread;
scheme_extension_table->Scheme_Thread = Scheme_Thread;
scheme_extension_table->scheme_fuel_counter = scheme_fuel_counter;
#else
scheme_extension_table->scheme_current_thread_ptr = scheme_current_thread_ptr;

2
src/mzscheme/src/schemexm.h
View File

@ -19,7 +19,7 @@
#define scheme_inherit_cells (scheme_extension_table->scheme_inherit_cells)
#define scheme_current_break_cell (scheme_extension_table->scheme_current_break_cell)
#ifndef LINK_EXTENSIONS_BY_TABLE
#define scheme_current_thread (scheme_extension_table->scheme_current_thread)
#define Scheme_Thread (scheme_extension_table->Scheme_Thread)
#define scheme_fuel_counter (scheme_extension_table->scheme_fuel_counter)
#else
#define scheme_current_thread_ptr (scheme_extension_table->scheme_current_thread_ptr)

86
src/mzscheme/src/schpriv.h
View File

@ -106,7 +106,8 @@ int scheme_num_types(void);
void scheme_reset_finalizations(void);
extern unsigned long scheme_get_stack_base(void);
extern unsigned long scheme_get_current_os_thread_stack_base(void);
void scheme_set_current_os_thread_stack_base(void *base);
int scheme_propagate_ephemeron_marks(void);
void scheme_clear_ephemerons(void);
@ -120,11 +121,19 @@ void scheme_clear_ephemerons(void);
#define BITS_PER_MZSHORT (8 * sizeof(mzshort))
#ifndef NO_INLINE_KEYWORD
# define MZ_INLINE MSC_IZE(inline)
# define MZ_INLINE MSC_IZE(MSC_IZE(inline))
#else
# define MZ_INLINE /* empty */
#endif
#if _MSC_VER
# define MZ_NO_INLINE _declspec(noinline)
#elif defined(__GNUC__)
# define MZ_NO_INLINE __attribute ((__noinline__))
#else
# define MZ_NO_INLINE /* empty */
#endif
#ifdef MZ_PRECISE_GC
# define CLEAR_KEY_FIELD(o) ((o)->keyex = 0)
#else
@ -149,7 +158,7 @@ void scheme_init_overflow(void);
void scheme_register_traversers(void);
void scheme_init_hash_key_procs(void);
#endif
Scheme_Thread *scheme_make_thread(void);
Scheme_Thread *scheme_make_thread(void*);
void scheme_init_true_false(void);
void scheme_init_symbol_table(void);
void scheme_init_symbol_type(Scheme_Env *env);
@ -198,6 +207,7 @@ void scheme_init_getenv(void);
#ifndef DONT_USE_FOREIGN
void scheme_init_foreign(Scheme_Env *env);
#endif
void scheme_init_place(Scheme_Env *env);
void scheme_free_dynamic_extensions(void);
@ -303,10 +313,10 @@ extern Scheme_Object *scheme_reduced_procedure_struct;
#define RUNSTACK_IS_GLOBAL
#ifdef RUNSTACK_IS_GLOBAL
extern Scheme_Object **scheme_current_runstack;
extern Scheme_Object **scheme_current_runstack_start;
extern MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack;
extern MZ_MARK_POS_TYPE scheme_current_cont_mark_pos;
extern THREAD_LOCAL Scheme_Object **scheme_current_runstack;
extern THREAD_LOCAL Scheme_Object **scheme_current_runstack_start;
extern THREAD_LOCAL MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack;
extern THREAD_LOCAL MZ_MARK_POS_TYPE scheme_current_cont_mark_pos;
# define MZ_RUNSTACK scheme_current_runstack
# define MZ_RUNSTACK_START scheme_current_runstack_start
# define MZ_CONT_MARK_STACK scheme_current_cont_mark_stack
@ -320,7 +330,24 @@ extern MZ_MARK_POS_TYPE scheme_current_cont_mark_pos;
extern volatile int scheme_fuel_counter;
extern Scheme_Thread *scheme_main_thread;
extern THREAD_LOCAL Scheme_Thread *scheme_main_thread;
#ifdef MZ_USE_PLACES
extern THREAD_LOCAL Scheme_Thread *scheme_current_thread;
extern THREAD_LOCAL Scheme_Thread *scheme_first_thread;
#endif
typedef struct Scheme_Thread_Set {
Scheme_Object so;
struct Scheme_Thread_Set *parent;
Scheme_Object *first;
Scheme_Object *next;
Scheme_Object *prev;
Scheme_Object *search_start;
Scheme_Object *current;
} Scheme_Thread_Set;
extern THREAD_LOCAL Scheme_Thread_Set *scheme_thread_set_top;
#define SCHEME_TAIL_COPY_THRESHOLD 5
@ -970,8 +997,8 @@ void scheme_clean_cust_box_list(void);
Scheme_Object *scheme_handle_stack_overflow(Scheme_Object *(*k)(void));
extern struct Scheme_Overflow_Jmp *scheme_overflow_jmp;
extern void *scheme_overflow_stack_start;
extern THREAD_LOCAL struct Scheme_Overflow_Jmp *scheme_overflow_jmp;
extern THREAD_LOCAL void *scheme_overflow_stack_start;
#ifdef MZ_PRECISE_GC
# define PROMPT_STACK(id) &__gc_var_stack__
@ -1171,10 +1198,10 @@ typedef struct Scheme_Overflow {
|| defined(BEOS_FIND_STACK_BOUNDS) || defined(OSKIT_FIXED_STACK_BOUNDS) \
|| defined(PALM_FIND_STACK_BOUNDS)
# define USE_STACK_BOUNDARY_VAR
extern unsigned long scheme_stack_boundary;
extern THREAD_LOCAL unsigned long scheme_stack_boundary;
/* Same as scheme_stack_boundary, but set to an extreme value when feul auto-expires,
so that JIT-generated code can check just one variable: */
extern unsigned long volatile scheme_jit_stack_boundary;
extern THREAD_LOCAL unsigned long volatile scheme_jit_stack_boundary;
#endif
typedef struct Scheme_Meta_Continuation {
@ -2573,6 +2600,13 @@ void scheme_add_global_keyword_symbol(Scheme_Object *name, Scheme_Object *v, Sch
void scheme_add_global_constant(const char *name, Scheme_Object *v, Scheme_Env *env);
void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env);
#define GLOBAL_FOLDING_PRIM(name, func, a1, a2, a3, env) scheme_add_global_constant(name, scheme_make_folding_prim(func, name, a1, a2, a3), env);
#define GLOBAL_IMMED_PRIM(name, func, a1, a2, env) scheme_add_global_constant(name, scheme_make_immed_prim(func, name, a1, a2), env);
#define GLOBAL_PARAMETER(name, func, constant, env) scheme_add_global_constant(name, scheme_register_parameter(func, name, constant), env);
#define GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) scheme_add_global_constant(name, scheme_make_prim_w_arity(func, name, a1, a2), env);
#define GLOBAL_PRIM_W_ARITY2(name, func, a1, a2, a3, a4, env) scheme_add_global_constant(name, scheme_make_prim_w_arity2(func, name, a1, a2, a3, a4), env);
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, Scheme_Object *phase);
int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym);
@ -2605,7 +2639,10 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
Scheme_Object *stxsym, Scheme_Object *insp,
int pos, int mod_phase);
extern Scheme_Env *scheme_initial_env;
Scheme_Env *scheme_get_kernel_env();
int scheme_is_kernel_env();
void scheme_install_initial_module_set(Scheme_Env *env);
Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home);
@ -3020,4 +3057,27 @@ unsigned short * scheme_ucs4_to_utf16(const mzchar *text, int start, int end,
#define SCHEME_SYM_PARALLELP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x2)
#define SCHEME_SYM_WEIRDP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x3)
/*========================================================================*/
/* places */
/*========================================================================*/
typedef struct Scheme_Place {
Scheme_Object so;
void *proc_thread;
} Scheme_Place;
Scheme_Env *scheme_place_instance_init();
/*========================================================================*/
/* engine */
/*========================================================================*/
typedef struct Scheme_Engine {
Scheme_Object so;
} Scheme_Engine;
Scheme_Env *scheme_engine_instance_init();
#endif /* __mzscheme_private__ */

4
src/mzscheme/src/setjmpup.c
View File

@ -185,6 +185,8 @@ static void *make_stack_copy_rec(long size)
lk = MALLOC_LINK();
cs->prev = lk;
/* double linked list push */
*cs->next = *first_copied_stack;
if (*first_copied_stack)
*(*first_copied_stack)->prev = cs;
@ -246,7 +248,7 @@ END_XFORM_SKIP;
#endif
/* This function must not be inlined! */
void scheme_copy_stack(Scheme_Jumpup_Buf *b, void *base, void *start GC_VAR_STACK_ARG_DECL)
void MZ_NO_INLINE scheme_copy_stack(Scheme_Jumpup_Buf *b, void *base, void *start GC_VAR_STACK_ARG_DECL)
{
long size, msize;
void *here;

3
src/mzscheme/src/stypes.h
View File

@ -243,5 +243,8 @@ enum {
scheme_rt_rb_node, /* 221 */
#endif
scheme_place_type, /* 222 */
scheme_engine_type, /* 223 */
_scheme_last_type_
};

67
src/mzscheme/src/symbol.c
View File

@ -28,6 +28,7 @@
# define SCHEME_NO_GC_PROTO
#endif
#include "mzrt.h"
#include "schpriv.h"
#include <string.h>
#include <ctype.h>
@ -51,6 +52,13 @@ Scheme_Hash_Table *scheme_symbol_table = NULL;
Scheme_Hash_Table *scheme_keyword_table = NULL;
Scheme_Hash_Table *scheme_parallel_symbol_table = NULL;
#ifdef MZ_USE_PLACES
mzrt_rwlock *symbol_table_lock;
#else
# define mzrt_rwlock_rdlock(l) /* empty */
# define mzrt_rwlock_unlock(l) /* empty */
#endif
unsigned long scheme_max_found_symbol_name;
/* globals */
@ -282,6 +290,10 @@ scheme_init_symbol_table ()
scheme_keyword_table = init_one_symbol_table();
scheme_parallel_symbol_table = init_one_symbol_table();
#ifdef MZ_USE_PLACES
mzrt_rwlock_create(&symbol_table_lock);
#endif
#ifndef MZ_PRECISE_GC
GC_custom_finalize = clean_symbol_table;
#endif
@ -300,47 +312,15 @@ scheme_init_symbol (Scheme_Env *env)
p = scheme_make_folding_prim(symbol_p_prim, "symbol?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("symbol?", p, env);
scheme_add_global_constant("string->symbol",
scheme_make_immed_prim(string_to_symbol_prim,
"string->symbol",
1, 1), env);
scheme_add_global_constant("string->uninterned-symbol",
scheme_make_immed_prim(string_to_uninterned_symbol_prim,
"string->uninterned-symbol",
1, 1),
env);
scheme_add_global_constant("symbol->string",
scheme_make_immed_prim(symbol_to_string_prim,
"symbol->string",
1, 1),
env);
scheme_add_global_constant("keyword?",
scheme_make_folding_prim(keyword_p_prim,
"keyword?",
1, 1, 1),
env);
scheme_add_global_constant("keyword<?",
scheme_make_folding_prim(keyword_lt,
"keyword<?",
2, -1, 1),
env);
scheme_add_global_constant("string->keyword",
scheme_make_immed_prim(string_to_keyword_prim,
"string->keyword",
1, 1), env);
scheme_add_global_constant("keyword->string",
scheme_make_immed_prim(keyword_to_string_prim,
"keyword->string",
1, 1),
env);
scheme_add_global_constant("gensym",
scheme_make_immed_prim(gensym,
"gensym",
0, 1),
env);
GLOBAL_IMMED_PRIM("string->symbol", string_to_symbol_prim, 1, 1, env);
GLOBAL_IMMED_PRIM("string->uninterned-symbol", string_to_uninterned_symbol_prim, 1, 1, env);
GLOBAL_IMMED_PRIM("symbol->string", symbol_to_string_prim, 1, 1, env);
GLOBAL_FOLDING_PRIM("keyword?", keyword_p_prim, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("keyword<?", keyword_lt, 2, -1, 1, env);
GLOBAL_IMMED_PRIM("string->keyword", string_to_keyword_prim, 1, 1, env);
GLOBAL_IMMED_PRIM("keyword->string", keyword_to_string_prim, 1, 1, env);
GLOBAL_IMMED_PRIM("gensym", gensym, 0, 1, env);
}
static Scheme_Object *
@ -390,11 +370,16 @@ scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, c
{
Scheme_Object *sym;
mzrt_rwlock_rdlock(symbol_table_lock);
sym = symbol_bucket(symbol_table, name, len, NULL);
mzrt_rwlock_unlock(symbol_table_lock);
if (!sym) {
sym = make_a_symbol(name, len, kind);
mzrt_rwlock_rdlock(symbol_table_lock);
symbol_bucket(symbol_table, name, len, sym);
mzrt_rwlock_unlock(symbol_table_lock);
}
return sym;

335
src/mzscheme/src/thread.c
View File

@ -142,23 +142,13 @@ extern int scheme_jit_malloced;
static int buffer_init_size = INIT_TB_SIZE;
Scheme_Thread *scheme_current_thread = NULL;
Scheme_Thread *scheme_main_thread = NULL;
Scheme_Thread *scheme_first_thread = NULL;
THREAD_LOCAL Scheme_Thread *scheme_current_thread = NULL;
THREAD_LOCAL Scheme_Thread *scheme_main_thread = NULL;
THREAD_LOCAL Scheme_Thread *scheme_first_thread = NULL;
Scheme_Thread *scheme_get_current_thread() { return scheme_current_thread; }
typedef struct Scheme_Thread_Set {
Scheme_Object so;
struct Scheme_Thread_Set *parent;
Scheme_Object *first;
Scheme_Object *next;
Scheme_Object *prev;
Scheme_Object *search_start;
Scheme_Object *current;
} Scheme_Thread_Set;
Scheme_Thread_Set *thread_set_top;
THREAD_LOCAL Scheme_Thread_Set *scheme_thread_set_top;
static int num_running_threads = 1;
@ -174,10 +164,10 @@ static int did_gc_count;
static int init_load_on_demand = 1;
#ifdef RUNSTACK_IS_GLOBAL
Scheme_Object **scheme_current_runstack_start;
Scheme_Object **scheme_current_runstack;
MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack;
MZ_MARK_POS_TYPE scheme_current_cont_mark_pos;
THREAD_LOCAL Scheme_Object **scheme_current_runstack_start;
THREAD_LOCAL Scheme_Object **scheme_current_runstack;
THREAD_LOCAL MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack;
THREAD_LOCAL MZ_MARK_POS_TYPE scheme_current_cont_mark_pos;
#endif
static Scheme_Custodian *main_custodian;
@ -2076,7 +2066,8 @@ static void unschedule_in_set(Scheme_Object *s, Scheme_Thread_Set *t_set)
static Scheme_Thread *make_thread(Scheme_Config *config,
Scheme_Thread_Cell_Table *cells,
Scheme_Object *init_break_cell,
Scheme_Custodian *mgr)
Scheme_Custodian *mgr,
void *stack_base)
{
Scheme_Thread *process;
int prefix = 0;
@ -2120,22 +2111,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
scheme_fuel_counter_ptr = &scheme_fuel_counter;
#endif
/* Before a thread can be used stack_start must be set
* this code sets stack_start for the main_thread
* which is created with scheme_make_thread.
*
* make_subprocess is the only other caller of make_thread
* and it sets stack_start */
#if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC)
{
void *ss;
ss = (void *)GC_get_stack_base();
process->stack_start = ss;
}
GC_get_thread_stack_base = get_current_stack_start;
#else
process->stack_start = GC_stackbottom;
#endif
process->stack_start = stack_base;
} else {
prefix = 1;
@ -2178,10 +2157,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
}
if (SAME_OBJ(process, scheme_first_thread)) {
REGISTER_SO(thread_set_top);
thread_set_top = process->t_set_parent;
thread_set_top->first = (Scheme_Object *)process;
thread_set_top->current = (Scheme_Object *)process;
REGISTER_SO(scheme_thread_set_top);
scheme_thread_set_top = process->t_set_parent;
scheme_thread_set_top->first = (Scheme_Object *)process;
scheme_thread_set_top->current = (Scheme_Object *)process;
} else
schedule_in_set((Scheme_Object *)process, process->t_set_parent);
@ -2314,10 +2293,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config,
return process;
}
Scheme_Thread *scheme_make_thread()
Scheme_Thread *scheme_make_thread(void *stack_base)
{
/* Makes the initial process. */
return make_thread(NULL, NULL, NULL, NULL);
return make_thread(NULL, NULL, NULL, NULL, stack_base);
}
static void scheme_check_tail_buffer_size(Scheme_Thread *p)
@ -2532,7 +2511,7 @@ static void select_thread()
/* Try to pick a next thread to avoid DOS attacks
through whatever kinds of things call select_thread() */
o = (Scheme_Object *)thread_set_top;
o = (Scheme_Object *)scheme_thread_set_top;
while (!SCHEME_THREADP(o)) {
t_set = (Scheme_Thread_Set *)o;
o = get_t_set_next(t_set->current);
@ -2851,7 +2830,7 @@ static Scheme_Object *make_subprocess(Scheme_Object *child_thunk,
maybe_recycle_cell = NULL;
}
child = make_thread(config, cells, break_cell, mgr);
child = make_thread(config, cells, break_cell, mgr, child_start);
/* Use child_thunk name, if any, for the thread name: */
{
@ -3801,15 +3780,154 @@ void scheme_break_thread(Scheme_Thread *p)
# endif
}
static void find_next_thread(Scheme_Thread **return_arg) {
Scheme_Thread *next;
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *next_in_set;
Scheme_Thread_Set *t_set;
double msecs = 0.0;
/* Find the next process. Skip processes that are definitely
blocked. */
/* Start from the root */
next_in_set = (Scheme_Object *)scheme_thread_set_top;
t_set = NULL; /* this will get set at the beginning of the loop */
/* Each thread may or may not be available. If it's not available,
we search thread by thread to find something that is available. */
while (1) {
/* next_in_set is the thread or set to try... */
/* While it's a set, go down into the set, choosing the next
item after the set's current. For each set, remember where we
started searching for something to run, so we'll know when
we've tried everything in the set. */
while (!SCHEME_THREADP(next_in_set)) {
t_set = (Scheme_Thread_Set *)next_in_set;
next_in_set = get_t_set_next(t_set->current);
if (!next_in_set)
next_in_set = t_set->first;
t_set->current = next_in_set;
t_set->search_start = next_in_set;
}
/* Now `t_set' is the set we're trying, and `next' will be the
thread to try: */
next = (Scheme_Thread *)next_in_set;
/* If we get back to the current thread, then
no other thread was ready. */
if (SAME_PTR(next, p)) {
next = NULL;
break;
}
/* Check whether `next' is ready... */
if (next->nestee) {
/* Blocked on nestee */
} else if (next->running & MZTHREAD_USER_SUSPENDED) {
if (next->next || (next->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) {
/* If a non-main thread is still in the queue,
it needs to be swapped in so it can clean up
and suspend itself. */
break;
}
} else if (next->running & MZTHREAD_KILLED) {
/* This one has been terminated. */
if ((next->running & MZTHREAD_NEED_KILL_CLEANUP)
|| next->nester
|| !next->next) {
/* The thread needs to clean up. Swap it in so it can die. */
break;
} else
remove_thread(next);
break;
} else if (next->external_break && scheme_can_break(next)) {
break;
} else {
if (next->block_descriptor == GENERIC_BLOCKED) {
if (next->block_check) {
Scheme_Ready_Fun_FPC f = (Scheme_Ready_Fun_FPC)next->block_check;
Scheme_Schedule_Info sinfo;
init_schedule_info(&sinfo, next, next->sleep_end);
if (f(next->blocker, &sinfo))
break;
next->sleep_end = sinfo.sleep_end;
msecs = 0.0; /* that could have taken a while */
}
} else if (next->block_descriptor == SLEEP_BLOCKED) {
if (!msecs)
msecs = scheme_get_inexact_milliseconds();
if (next->sleep_end <= msecs)
break;
} else
break;
}
/* Look for the next thread/set in this set */
if (next->t_set_next)
next_in_set = next->t_set_next;
else
next_in_set = t_set->first;
/* If we run out of things to try in this set,
go up to find the next set. */
if (SAME_OBJ(next_in_set, t_set->search_start)) {
/* Loop to go up past exhausted sets, clearing search_start
from each exhausted set. */
while (1) {
t_set->search_start = NULL;
t_set = t_set->parent;
if (t_set) {
next_in_set = get_t_set_next(t_set->current);
if (!next_in_set)
next_in_set = t_set->first;
if (SAME_OBJ(next_in_set, t_set->search_start)) {
t_set->search_start = NULL;
/* continue going up */
} else {
t_set->current = next_in_set;
break;
}
} else
break;
}
if (!t_set) {
/* We ran out of things to try. If we
start again with the top, we should
land back at p. */
next = NULL;
break;
}
} else {
/* Set current... */
t_set->current = next_in_set;
}
/* As we go back to the top of the loop, we'll check whether
next_in_set is a thread or set, etc. */
}
p = NULL;
next_in_set = NULL;
t_set = NULL;
*return_arg = next;
next = NULL;
}
void scheme_thread_block(float sleep_time)
/* If we're blocked, `sleep_time' is a max sleep time,
not a min sleep time. Otherwise, it's a min & max sleep time.
This proc auto-resets p's blocking info if an escape occurs. */
{
double sleep_end;
Scheme_Thread *next, *p = scheme_current_thread;
Scheme_Object *next_in_set;
Scheme_Thread_Set *t_set;
Scheme_Thread *next;
Scheme_Thread *p = scheme_current_thread;
if (p->running & MZTHREAD_KILLED) {
/* This thread is dead! Give up now. */
@ -3864,142 +3982,19 @@ void scheme_thread_block(float sleep_time)
check_scheduled_kills();
if (!do_atomic && (sleep_end >= 0.0)) {
double msecs = 0.0;
/* Find the next process. Skip processes that are definitely
blocked. */
/* Start from the root */
next_in_set = (Scheme_Object *)thread_set_top;
t_set = NULL; /* this will get set at the beginning of the loop */
/* Each thread may or may not be available. If it's not available,
we search thread by thread to find something that is available. */
while (1) {
/* next_in_set is the thread or set to try... */
/* While it's a set, go down into the set, choosing the next
item after the set's current. For each set, remember where we
started searching for something to run, so we'll know when
we've tried everything in the set. */
while (!SCHEME_THREADP(next_in_set)) {
t_set = (Scheme_Thread_Set *)next_in_set;
next_in_set = get_t_set_next(t_set->current);
if (!next_in_set)
next_in_set = t_set->first;
t_set->current = next_in_set;
t_set->search_start = next_in_set;
}
/* Now `t_set' is the set we're trying, and `next' will be the
thread to try: */
next = (Scheme_Thread *)next_in_set;
/* If we get back to the current thread, then
no other thread was ready. */
if (SAME_PTR(next, p)) {
next = NULL;
break;
}
/* Check whether `next' is ready... */
if (next->nestee) {
/* Blocked on nestee */
} else if (next->running & MZTHREAD_USER_SUSPENDED) {
if (next->next || (next->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) {
/* If a non-main thread is still in the queue,
it needs to be swapped in so it can clean up
and suspend itself. */
break;
}
} else if (next->running & MZTHREAD_KILLED) {
/* This one has been terminated. */
if ((next->running & MZTHREAD_NEED_KILL_CLEANUP)
|| next->nester
|| !next->next) {
/* The thread needs to clean up. Swap it in so it can die. */
break;
} else
remove_thread(next);
break;
} else if (next->external_break && scheme_can_break(next)) {
break;
} else {
if (next->block_descriptor == GENERIC_BLOCKED) {
if (next->block_check) {
Scheme_Ready_Fun_FPC f = (Scheme_Ready_Fun_FPC)next->block_check;
Scheme_Schedule_Info sinfo;
init_schedule_info(&sinfo, next, next->sleep_end);
if (f(next->blocker, &sinfo))
break;
next->sleep_end = sinfo.sleep_end;
msecs = 0.0; /* that could have taken a while */
}
} else if (next->block_descriptor == SLEEP_BLOCKED) {
if (!msecs)
msecs = scheme_get_inexact_milliseconds();
if (next->sleep_end <= msecs)
break;
} else
break;
}
/* Look for the next thread/set in this set */
if (next->t_set_next)
next_in_set = next->t_set_next;
else
next_in_set = t_set->first;
/* If we run out of things to try in this set,
go up to find the next set. */
if (SAME_OBJ(next_in_set, t_set->search_start)) {
/* Loop to go up past exhausted sets, clearing search_start
from each exhausted set. */
while (1) {
t_set->search_start = NULL;
t_set = t_set->parent;
if (t_set) {
next_in_set = get_t_set_next(t_set->current);
if (!next_in_set)
next_in_set = t_set->first;
if (SAME_OBJ(next_in_set, t_set->search_start)) {
t_set->search_start = NULL;
/* continue going up */
} else {
t_set->current = next_in_set;
break;
}
} else
break;
}
if (!t_set) {
/* We ran out of things to try. If we
start again with the top, we should
land back at p. */
next = NULL;
break;
}
} else {
/* Set current... */
t_set->current = next_in_set;
}
/* As we go back to the top of the loop, we'll check whether
next_in_set is a thread or set, etc. */
}
find_next_thread(&next);
} else
next = NULL;
if (next) {
/* Clear out search_start fields */
Scheme_Thread_Set *t_set;
t_set = next->t_set_parent;
while (t_set) {
t_set->search_start = NULL;
t_set = t_set->parent;
}
t_set = NULL;
}
if ((sleep_end > 0.0) && (p->block_descriptor == NOT_BLOCKED)) {
@ -4032,8 +4027,6 @@ void scheme_thread_block(float sleep_time)
if (next) {
/* Swap in `next', but first clear references to other threads. */
next_in_set = NULL;
t_set = NULL;
swap_target = next;
next = NULL;
do_swap_thread();

2
src/mzscheme/src/type.c
View File

@ -275,6 +275,8 @@ scheme_init_type (Scheme_Env *env)
#ifdef MZ_GC_BACKTRACE
set_name(scheme_rt_meta_cont, "<meta-continuation>");
#endif
set_name(scheme_place_type, "<place>");
set_name(scheme_engine_type, "<engine>");
}
Scheme_Type scheme_make_type(const char *name)