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,

620
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,11 +196,32 @@ static void boot_module_resolver()
scheme_apply(boot, 0, NULL);
}
Scheme_Env *scheme_basic_env()
{
Scheme_Env *env;
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();
if (scheme_main_thread) {
/* Reset everything: */
scheme_do_close_managed(NULL, skip_certain_things);
scheme_main_thread = NULL;
@ -217,14 +233,13 @@ Scheme_Env *scheme_basic_env()
#endif
scheme_reset_overflow();
scheme_make_thread();
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_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env);
scheme_init_port_config();
scheme_init_port_fun_config();
@ -236,130 +251,23 @@ Scheme_Env *scheme_basic_env()
boot_module_resolver();
return env;
}
Scheme_Env *scheme_basic_env()
{
Scheme_Env *env;
if (scheme_main_thread) {
return scheme_restart_instance();
}
#ifdef UNIX_LIMIT_STACK
{
struct rlimit rl;
env = scheme_engine_instance_init();
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();
return env;
}
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;
ht = scheme_initial_env->toplevel;
kenv = scheme_get_kernel_env();
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;

17
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
@ -532,17 +532,19 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
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_
};

65
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
@ -301,46 +313,14 @@ scheme_init_symbol (Scheme_Env *env)
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;

199
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,76 +3780,19 @@ void scheme_break_thread(Scheme_Thread *p)
# endif
}
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;
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;
if (p->running & MZTHREAD_KILLED) {
/* This thread is dead! Give up now. */
if (!do_atomic)
exit_or_escape(p);
}
if ((p->running & MZTHREAD_USER_SUSPENDED)
&& !(p->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) {
/* This thread was suspended. */
wait_until_suspend_ok();
if (!p->next) {
/* Suspending the main thread... */
select_thread();
} else
scheme_weak_suspend_thread(p);
}
/* Check scheduled_kills early and often. */
check_scheduled_kills();
shrink_cust_box_array();
if (scheme_active_but_sleeping)
scheme_wake_up();
if (sleep_time > 0) {
sleep_end = scheme_get_inexact_milliseconds();
sleep_end += (sleep_time * 1000.0);
} else
sleep_end = 0;
start_sleep_check:
check_ready_break();
if (!p->external_break && !p->next && scheme_check_for_break && scheme_check_for_break())
p->external_break = 1;
if (p->external_break && !p->suspend_break && scheme_can_break(p)) {
raise_break(p);
goto start_sleep_check;
}
swap_or_sleep:
#ifdef USE_OSKIT_CONSOLE
scheme_check_keyboard_input();
#endif
/* Check scheduled_kills early and often. */
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;
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,
@ -3990,16 +3912,89 @@ void scheme_thread_block(float sleep_time)
/* 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;
Scheme_Thread *p = scheme_current_thread;
if (p->running & MZTHREAD_KILLED) {
/* This thread is dead! Give up now. */
if (!do_atomic)
exit_or_escape(p);
}
if ((p->running & MZTHREAD_USER_SUSPENDED)
&& !(p->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) {
/* This thread was suspended. */
wait_until_suspend_ok();
if (!p->next) {
/* Suspending the main thread... */
select_thread();
} else
scheme_weak_suspend_thread(p);
}
/* Check scheduled_kills early and often. */
check_scheduled_kills();
shrink_cust_box_array();
if (scheme_active_but_sleeping)
scheme_wake_up();
if (sleep_time > 0) {
sleep_end = scheme_get_inexact_milliseconds();
sleep_end += (sleep_time * 1000.0);
} else
sleep_end = 0;
start_sleep_check:
check_ready_break();
if (!p->external_break && !p->next && scheme_check_for_break && scheme_check_for_break())
p->external_break = 1;
if (p->external_break && !p->suspend_break && scheme_can_break(p)) {
raise_break(p);
goto start_sleep_check;
}
swap_or_sleep:
#ifdef USE_OSKIT_CONSOLE
scheme_check_keyboard_input();
#endif
/* Check scheduled_kills early and often. */
check_scheduled_kills();
if (!do_atomic && (sleep_end >= 0.0)) {
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)