From 04d771298810804559e8c81dca6d1f998096e2a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 13 Aug 2008 23:08:34 +0000 Subject: [PATCH] merge Kevin's work so far on places svn: r11226 --- src/configure | 25 +- src/mzscheme/configure.ac | 14 + src/mzscheme/gc/Makefile.in | 2 +- src/mzscheme/gc/darwin_stop_world.c | 16 +- src/mzscheme/gc2/Makefile.in | 11 +- src/mzscheme/include/mzscheme.exp | 2 +- src/mzscheme/include/mzscheme3m.exp | 2 +- src/mzscheme/include/mzwin.def | 1 - src/mzscheme/include/mzwin3m.def | 1 - src/mzscheme/include/scheme.h | 22 +- src/mzscheme/src/Makefile.in | 10 + src/mzscheme/src/bool.c | 2 +- src/mzscheme/src/cstartup.inc | 28 +- src/mzscheme/src/env.c | 672 ++++++++++++---------------- src/mzscheme/src/eval.c | 23 +- src/mzscheme/src/fun.c | 8 +- src/mzscheme/src/module.c | 184 ++------ src/mzscheme/src/mzmark.c | 52 +++ src/mzscheme/src/mzmarksrc.c | 24 + src/mzscheme/src/mzrt.c | 358 +++++++++++++++ src/mzscheme/src/mzrt.h | 48 ++ src/mzscheme/src/numstr.c | 2 +- src/mzscheme/src/places.c | 191 ++++++++ src/mzscheme/src/salloc.c | 26 +- src/mzscheme/src/schemef.h | 2 +- src/mzscheme/src/schemex.h | 2 +- src/mzscheme/src/schemex.inc | 2 +- src/mzscheme/src/schemexm.h | 2 +- src/mzscheme/src/schpriv.h | 86 +++- src/mzscheme/src/setjmpup.c | 4 +- src/mzscheme/src/stypes.h | 3 + src/mzscheme/src/symbol.c | 67 ++- src/mzscheme/src/thread.c | 335 +++++++------- src/mzscheme/src/type.c | 2 + 34 files changed, 1415 insertions(+), 814 deletions(-) create mode 100644 src/mzscheme/src/mzrt.c create mode 100644 src/mzscheme/src/mzrt.h create mode 100644 src/mzscheme/src/places.c diff --git a/src/configure b/src/configure index 0a078eaa4e..2f372a51c8 100755 --- a/src/configure +++ b/src/configure @@ -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= use 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 diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index 46a479ac4f..706c0b4a32 100644 --- a/src/mzscheme/configure.ac +++ b/src/mzscheme/configure.ac @@ -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) diff --git a/src/mzscheme/gc/Makefile.in b/src/mzscheme/gc/Makefile.in index dfdb185214..072fbef4a0 100644 --- a/src/mzscheme/gc/Makefile.in +++ b/src/mzscheme/gc/Makefile.in @@ -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: diff --git a/src/mzscheme/gc/darwin_stop_world.c b/src/mzscheme/gc/darwin_stop_world.c index 665e896549..b2814abb27 100644 --- a/src/mzscheme/gc/darwin_stop_world.c +++ b/src/mzscheme/gc/darwin_stop_world.c @@ -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); diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index d71a9ab827..b463f9a977 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -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 diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index bf0423a069..19a8665cb8 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -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 diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index 58cbaf21ef..971a4f841f 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -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 diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index ab2b02268b..58a3676e3e 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -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 diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index dfa3cb862f..4008fe688f 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -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 diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 086b77c924..278527e34b 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -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); diff --git a/src/mzscheme/src/Makefile.in b/src/mzscheme/src/Makefile.in index 9c4f350aa0..2bf1127832 100644 --- a/src/mzscheme/src/Makefile.in +++ b/src/mzscheme/src/Makefile.in @@ -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 \ diff --git a/src/mzscheme/src/bool.c b/src/mzscheme/src/bool.c index a385de0321..714836f502 100644 --- a/src/mzscheme/src/bool.c +++ b/src/mzscheme/src/bool.c @@ -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; diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 322b2228b4..f422a40277 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -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, diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index ec67a2e92d..ebd6d0d26a 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -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 -# include -# include -#endif - -#ifdef MZ_USE_IRIX_SPROCS -# include "../gc/gc.h" -#endif - #define GLOBAL_TABLE_SIZE 500 +#define TABLE_CACHE_MAX_SIZE 2048 /* #define TIME_STARTUP_PROCESS */ -/* globals */ +/* global flags */ int scheme_allow_set_undefined; - void scheme_set_allow_set_undefined(int v) { scheme_allow_set_undefined = v; } int scheme_get_allow_set_undefined() { return scheme_allow_set_undefined; } - int scheme_starting_up; +/* global counters just need to be atomically incremented */ +static int intdef_counter = 0; +static int builtin_ref_counter = 0; +static int env_uid_counter = 0; + +/* globals READ-ONLY SHARED */ +static Scheme_Object *kernel_symbol; +static Scheme_Env *kernel_env; + #define MAX_CONST_LOCAL_POS 64 #define MAX_CONST_LOCAL_TYPES 2 #define MAX_CONST_LOCAL_FLAG_VAL 2 #define SCHEME_LOCAL_FLAGS_MASK 0x3 static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1]; - #define MAX_CONST_TOPLEVEL_DEPTH 16 #define MAX_CONST_TOPLEVEL_POS 16 #define SCHEME_TOPLEVEL_FLAGS_MASK 0x3 static Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1]; -#define TABLE_CACHE_MAX_SIZE 2048 -Scheme_Hash_Table *toplevels_ht; -Scheme_Hash_Table *locals_ht[2]; +/* globals THREAD_LOCAL + * if locked theses are probably sharable*/ +static Scheme_Hash_Table *toplevels_ht; +static Scheme_Hash_Table *locals_ht[2]; -Scheme_Env *scheme_initial_env; - -/* locals */ -static void make_init_env(void); +/* local functions */ +static void make_kernel_env(void); +static void init_scheme_local(); +static void init_toplevels(); static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size); static Scheme_Env *make_empty_inited_env(int toplevel_size); @@ -126,23 +125,19 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj); static Scheme_Object *read_resolve_prefix(Scheme_Object *obj); static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data); - int scheme_is_module_begin_env(Scheme_Comp_Env *env); +Scheme_Env *scheme_engine_instance_init(); +Scheme_Env *scheme_place_instance_init(); +static void place_instance_init_pre_kernel(); +static Scheme_Env *place_instance_init_post_kernel(); + #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif typedef Scheme_Object *(*Lazy_Macro_Fun)(Scheme_Object *, int); -static Scheme_Object *kernel_symbol; - -static int intdef_counter = 0; - -static int builtin_ref_counter = 0; - -static int env_uid_counter; - #define ARBITRARY_USE 0x1 #define CONSTRAINED_USE 0x2 #define WAS_SET_BANGED 0x4 @@ -201,165 +196,78 @@ static void boot_module_resolver() scheme_apply(boot, 0, NULL); } +void os_platform_init() { +#ifdef UNIX_LIMIT_STACK + struct rlimit rl; + + getrlimit(RLIMIT_STACK, &rl); + if (rl.rlim_cur > UNIX_LIMIT_STACK) { + rl.rlim_cur = UNIX_LIMIT_STACK; + setrlimit(RLIMIT_STACK, &rl); + } +#endif +#ifdef UNIX_LIMIT_FDSET_SIZE + struct rlimit rl; + + getrlimit(RLIMIT_NOFILE, &rl); + if (rl.rlim_cur > FD_SETSIZE) { + rl.rlim_cur = FD_SETSIZE; + setrlimit(RLIMIT_NOFILE, &rl); + } +#endif +} + +Scheme_Env *scheme_restart_instance() { + Scheme_Env *env; + void *stack_base; + stack_base = (void *) scheme_get_current_os_thread_stack_base(); + + /* Reset everything: */ + scheme_do_close_managed(NULL, skip_certain_things); + scheme_main_thread = NULL; + + scheme_reset_finalizations(); + scheme_init_stack_check(); +#ifndef MZ_PRECISE_GC + scheme_init_setjumpup(); +#endif + scheme_reset_overflow(); + + scheme_make_thread(stack_base); + scheme_init_error_escape_proc(NULL); + scheme_init_module_resolver(); + + env = scheme_make_empty_env(); + scheme_install_initial_module_set(env); + scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); + + scheme_init_port_config(); + scheme_init_port_fun_config(); + scheme_init_error_config(); +#ifndef NO_SCHEME_EXNS + scheme_init_exn_config(); +#endif + + boot_module_resolver(); + + return env; +} + Scheme_Env *scheme_basic_env() { Scheme_Env *env; if (scheme_main_thread) { - /* Reset everything: */ - scheme_do_close_managed(NULL, skip_certain_things); - scheme_main_thread = NULL; - - scheme_reset_finalizations(); - scheme_init_stack_check(); -#ifndef MZ_PRECISE_GC - scheme_init_setjumpup(); -#endif - scheme_reset_overflow(); - - scheme_make_thread(); - scheme_init_error_escape_proc(NULL); - scheme_init_module_resolver(); - - env = scheme_make_empty_env(); - scheme_install_initial_module_set(env); - scheme_set_param(scheme_current_config(), MZCONFIG_ENV, - (Scheme_Object *)env); - - scheme_init_port_config(); - scheme_init_port_fun_config(); - scheme_init_error_config(); -#ifndef NO_SCHEME_EXNS - scheme_init_exn_config(); -#endif - - boot_module_resolver(); - - return env; + return scheme_restart_instance(); } + + env = scheme_engine_instance_init(); + + return env; +} -#ifdef UNIX_LIMIT_STACK - { - struct rlimit rl; - - getrlimit(RLIMIT_STACK, &rl); - if (rl.rlim_cur > UNIX_LIMIT_STACK) { - rl.rlim_cur = UNIX_LIMIT_STACK; - setrlimit(RLIMIT_STACK, &rl); - } - } -#endif -#ifdef UNIX_LIMIT_FDSET_SIZE - { - struct rlimit rl; - - getrlimit(RLIMIT_NOFILE, &rl); - if (rl.rlim_cur > FD_SETSIZE) { - rl.rlim_cur = FD_SETSIZE; - setrlimit(RLIMIT_NOFILE, &rl); - } - } -#endif - -#ifdef MZ_USE_IRIX_SPROCS - GC_INIT(); -#endif - - scheme_starting_up = 1; - -#ifndef MZ_PRECISE_GC - scheme_init_setjumpup(); - scheme_init_ephemerons(); -#endif - -#ifdef TIME_STARTUP_PROCESS - printf("#if 0\nbasic @ %ld\n", scheme_get_process_milliseconds()); -#endif - - scheme_init_stack_check(); - scheme_init_overflow(); - scheme_init_portable_case(); - - - { - int i, k, cor; - -#ifndef USE_TAGGED_ALLOCATION - GC_CAN_IGNORE Scheme_Local *all; - - all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS); -# ifdef MEMORY_COUNTING_ON - scheme_misc_count += sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS; -# endif -#endif - - for (i = 0; i < MAX_CONST_LOCAL_POS; i++) { - for (k = 0; k < 2; k++) { - for (cor = 0; cor < 3; cor++) { - Scheme_Object *v; - -#ifndef USE_TAGGED_ALLOCATION - v = (Scheme_Object *)(all++); -#else - v = (Scheme_Object *)scheme_malloc_eternal_tagged(sizeof(Scheme_Local)); -#endif - v->type = k + scheme_local_type; - SCHEME_LOCAL_POS(v) = i; - SCHEME_LOCAL_FLAGS(v) = cor; - - scheme_local[i][k][cor] = v; - } - } - } - } - - { - int i, k, cnst; - -#ifndef USE_TAGGED_ALLOCATION - GC_CAN_IGNORE Scheme_Toplevel *all; - - all = (Scheme_Toplevel *)scheme_malloc_eternal(sizeof(Scheme_Toplevel) - * MAX_CONST_TOPLEVEL_DEPTH - * MAX_CONST_TOPLEVEL_POS - * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); -# ifdef MEMORY_COUNTING_ON - scheme_misc_count += (sizeof(Scheme_Toplevel) - * MAX_CONST_TOPLEVEL_DEPTH - * MAX_CONST_TOPLEVEL_POS - * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); -# endif -#endif - - for (i = 0; i < MAX_CONST_TOPLEVEL_DEPTH; i++) { - for (k = 0; k < MAX_CONST_TOPLEVEL_POS; k++) { - for (cnst = 0; cnst <= SCHEME_TOPLEVEL_FLAGS_MASK; cnst++) { - Scheme_Toplevel *v; - -#ifndef USE_TAGGED_ALLOCATION - v = (all++); -#else - v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel)); -#endif - v->iso.so.type = scheme_toplevel_type; - v->depth = i; - v->position = k; - SCHEME_TOPLEVEL_FLAGS(v) = cnst; - - toplevels[i][k][cnst] = (Scheme_Object *)v; - } - } - } - } - -#ifdef MZ_PRECISE_GC - scheme_register_traversers(); - register_traversers(); - scheme_init_hash_key_procs(); -#endif - - scheme_init_true_false(); - +static void init_toplevel_local_offsets_hashtable_caches() +{ REGISTER_SO(toplevels_ht); REGISTER_SO(locals_ht[0]); REGISTER_SO(locals_ht[1]); @@ -372,30 +280,85 @@ Scheme_Env *scheme_basic_env() ht = scheme_make_hash_table(SCHEME_hash_ptr); locals_ht[1] = ht; } +} + + +/* READ-ONLY GLOBAL structures ONE-TIME initialization */ +Scheme_Env *scheme_engine_instance_init() { + Scheme_Env *env; + void *stack_base; + stack_base = (void *) scheme_get_current_os_thread_stack_base(); + + os_platform_init(); #ifdef TIME_STARTUP_PROCESS - printf("pre-process @ %ld\n", scheme_get_process_milliseconds()); + printf("#if 0\nengine_instance_init @ %ld\n", scheme_get_process_milliseconds()); #endif + scheme_starting_up = 1; + + scheme_init_portable_case(); + init_scheme_local(); + init_toplevels(); + + scheme_init_true_false(); + +#ifdef MZ_PRECISE_GC + scheme_register_traversers(); + register_traversers(); + scheme_init_hash_key_procs(); +#endif + + scheme_init_getenv(); /* checks PLTNOJIT */ + #ifdef WINDOWS_PROCESSES /* Must be called before first scheme_make_thread() */ scheme_init_thread_memory(); #endif - - scheme_init_getenv(); /* checks PLTNOJIT */ - scheme_make_thread(); + + place_instance_init_pre_kernel(stack_base); + make_kernel_env(); + env = place_instance_init_post_kernel(); + + return env; +} + +static void place_instance_init_pre_kernel(void *stack_base) { + +#ifdef TIME_STARTUP_PROCESS + printf("place_init @ %ld\n", scheme_get_process_milliseconds()); +#endif + scheme_set_current_os_thread_stack_base(stack_base); + +#ifndef MZ_PRECISE_GC + scheme_init_setjumpup(); + scheme_init_ephemerons(); +#endif + + scheme_init_stack_check(); + scheme_init_overflow(); + + init_toplevel_local_offsets_hashtable_caches(); + + +#ifdef TIME_STARTUP_PROCESS + printf("pre-process @ %ld\n", scheme_get_process_milliseconds()); +#endif + + scheme_make_thread(stack_base); #ifdef TIME_STARTUP_PROCESS printf("process @ %ld\n", scheme_get_process_milliseconds()); #endif +} - make_init_env(); +static Scheme_Env *place_instance_init_post_kernel() { + Scheme_Env *env; env = scheme_make_empty_env(); - scheme_set_param(scheme_current_config(), MZCONFIG_ENV, - (Scheme_Object *)env); + scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); scheme_init_memtrace(env); #ifndef NO_TCP_SUPPORT scheme_init_network(env); @@ -428,7 +391,12 @@ Scheme_Env *scheme_basic_env() return env; } -static void make_init_env(void) +Scheme_Env *scheme_place_instance_init(void *stack_base) { + place_instance_init_pre_kernel(stack_base); + return place_instance_init_post_kernel(); +} + +static void make_kernel_env(void) { Scheme_Env *env; #ifdef TIME_STARTUP_PROCESS @@ -440,8 +408,8 @@ static void make_init_env(void) scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); - REGISTER_SO(scheme_initial_env); - scheme_initial_env = env; + REGISTER_SO(kernel_env); + kernel_env = env; scheme_defining_primitives = 1; builtin_ref_counter = 0; @@ -495,202 +463,52 @@ static void make_init_env(void) #ifndef NO_REGEXP_UTILS MZTIMEIT(regexp, scheme_regexp_initialize(env)); #endif +#ifdef MZ_USE_PLACES + MZTIMEIT(places, scheme_init_place(env)); +#endif MARK_START_TIME(); - scheme_add_global_constant("namespace-symbol->identifier", - scheme_make_prim_w_arity(namespace_identifier, - "namespace-symbol->identifier", - 1, 2), - env); + GLOBAL_PRIM_W_ARITY("namespace-symbol->identifier", namespace_identifier, 1, 2, env); + GLOBAL_PRIM_W_ARITY("namespace-module-identifier", namespace_module_identifier, 0, 1, env); + GLOBAL_PRIM_W_ARITY("namespace-base-phase", namespace_base_phase, 0, 1, env); + GLOBAL_PRIM_W_ARITY("namespace-variable-value", namespace_variable_value, 1, 4, env); + GLOBAL_PRIM_W_ARITY("namespace-set-variable-value!", namespace_set_variable_value, 2, 4, env); + GLOBAL_PRIM_W_ARITY("namespace-undefine-variable!", namespace_undefine_variable, 1, 2, env); + GLOBAL_PRIM_W_ARITY("namespace-mapped-symbols", namespace_mapped_symbols, 0, 1, env); + GLOBAL_PRIM_W_ARITY("namespace-module-registry", namespace_module_registry, 1, 1, env); - scheme_add_global_constant("namespace-module-identifier", - scheme_make_prim_w_arity(namespace_module_identifier, - "namespace-module-identifier", - 0, 1), - env); - scheme_add_global_constant("namespace-base-phase", - scheme_make_prim_w_arity(namespace_base_phase, - "namespace-base-phase", - 0, 1), - env); + GLOBAL_PRIM_W_ARITY("variable-reference->resolved-module-path", variable_module_path, 1, 1, env); + GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env); + GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env); + GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env); + GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env); + GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-certifier", local_certify, 0, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-module-defined-identifiers", local_module_definitions, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-local-module-required-identifiers", local_module_imports, 2, 2, env); + GLOBAL_PRIM_W_ARITY("syntax-local-transforming-module-provides?", local_module_expanding_provides, 0, 0, env); - scheme_add_global_constant("namespace-variable-value", - scheme_make_prim_w_arity(namespace_variable_value, - "namespace-variable-value", - 1, 4), - env); + GLOBAL_PRIM_W_ARITY("make-set!-transformer", make_set_transformer, 1, 1, env); + GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env); + GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env); - scheme_add_global_constant("namespace-set-variable-value!", - scheme_make_prim_w_arity(namespace_set_variable_value, - "namespace-set-variable-value!", - 2, 4), - env); + GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 1, env); + GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env); + GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env); - scheme_add_global_constant("namespace-undefine-variable!", - scheme_make_prim_w_arity(namespace_undefine_variable, - "namespace-undefine-variable!", - 1, 2), - env); - - scheme_add_global_constant("namespace-mapped-symbols", - scheme_make_prim_w_arity(namespace_mapped_symbols, - "namespace-mapped-symbols", - 0, 1), - env); - - scheme_add_global_constant("namespace-module-registry", - scheme_make_prim_w_arity(namespace_module_registry, - "namespace-module-registry", - 1, 1), - env); - - scheme_add_global_constant("variable-reference->resolved-module-path", - scheme_make_prim_w_arity(variable_module_path, - "variable-reference->resolved-module-path", - 1, 1), - env); - scheme_add_global_constant("variable-reference->empty-namespace", - scheme_make_prim_w_arity(variable_namespace, - "variable-reference->empty-namespace", - 1, 1), - env); - scheme_add_global_constant("variable-reference->namespace", - scheme_make_prim_w_arity(variable_top_level_namespace, - "variable-reference->namespace", - 1, 1), - env); - scheme_add_global_constant("variable-reference->phase", - scheme_make_prim_w_arity(variable_phase, - "variable-reference->phase", - 1, 1), - env); - - scheme_add_global_constant("syntax-transforming?", - scheme_make_prim_w_arity(now_transforming, - "syntax-transforming?", - 0, 0), - env); - scheme_add_global_constant("syntax-local-value", - scheme_make_prim_w_arity(local_exp_time_value, - "syntax-local-value", - 1, 3), - env); - scheme_add_global_constant("syntax-local-name", - scheme_make_prim_w_arity(local_exp_time_name, - "syntax-local-name", - 0, 0), - env); - scheme_add_global_constant("syntax-local-context", - scheme_make_prim_w_arity(local_context, - "syntax-local-context", - 0, 0), - env); - scheme_add_global_constant("syntax-local-phase-level", - scheme_make_prim_w_arity(local_phase_level, - "syntax-local-phase-level", - 0, 0), - env); - scheme_add_global_constant("syntax-local-make-definition-context", - scheme_make_prim_w_arity(local_make_intdef_context, - "syntax-local-make-definition-context", - 0, 0), - env); - scheme_add_global_constant("syntax-local-get-shadower", - scheme_make_prim_w_arity(local_get_shadower, - "syntax-local-get-shadower", - 1, 1), - env); - scheme_add_global_constant("syntax-local-introduce", - scheme_make_prim_w_arity(local_introduce, - "syntax-local-introduce", - 1, 1), - env); - scheme_add_global_constant("make-syntax-introducer", - scheme_make_prim_w_arity(make_introducer, - "make-syntax-introducer", - 0, 1), - env); - scheme_add_global_constant("syntax-local-certifier", - scheme_make_prim_w_arity(local_certify, - "syntax-local-certifier", - 0, 1), - env); - - scheme_add_global_constant("syntax-local-module-exports", - scheme_make_prim_w_arity(local_module_exports, - "syntax-local-module-exports", - 1, 1), - env); - scheme_add_global_constant("syntax-local-module-defined-identifiers", - scheme_make_prim_w_arity(local_module_definitions, - "syntax-local-module-defined-identifiers", - 0, 0), - env); - scheme_add_global_constant("syntax-local-module-required-identifiers", - scheme_make_prim_w_arity(local_module_imports, - "syntax-local-module-required-identifiers", - 2, 2), - env); - scheme_add_global_constant("syntax-local-transforming-module-provides?", - scheme_make_prim_w_arity(local_module_expanding_provides, - "syntax-local-transforming-module-provides?", - 0, 0), - env); - - scheme_add_global_constant("make-set!-transformer", - scheme_make_prim_w_arity(make_set_transformer, - "make-set!-transformer", - 1, 1), - env); - - scheme_add_global_constant("set!-transformer?", - scheme_make_prim_w_arity(set_transformer_p, - "set!-transformer?", - 1, 1), - env); - - scheme_add_global_constant("set!-transformer-procedure", - scheme_make_prim_w_arity(set_transformer_proc, - "set!-transformer-procedure", - 1, 1), - env); - - scheme_add_global_constant("make-rename-transformer", - scheme_make_prim_w_arity(make_rename_transformer, - "make-rename-transformer", - 1, 1), - env); - - scheme_add_global_constant("rename-transformer?", - scheme_make_prim_w_arity(rename_transformer_p, - "rename-transformer?", - 1, 1), - env); - - scheme_add_global_constant("rename-transformer-target", - scheme_make_prim_w_arity(rename_transformer_target, - "rename-transformer-target", - 1, 1), - env); - - scheme_add_global_constant("syntax-local-lift-expression", - scheme_make_prim_w_arity(local_lift_expr, - "syntax-local-lift-expression", - 1, 1), - env); - scheme_add_global_constant("syntax-local-lift-context", - scheme_make_prim_w_arity(local_lift_context, - "syntax-local-lift-context", - 0, 0), - env); - - scheme_add_global_constant("syntax-local-lift-module-end-declaration", - scheme_make_prim_w_arity(local_lift_end_statement, - "syntax-local-lift-module-end-declaration", - 1, 1), - env); + GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env); + GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env); { Scheme_Object *sym; @@ -732,6 +550,88 @@ static void make_init_env(void) scheme_defining_primitives = 0; } +int scheme_is_kernel_env(Scheme_Env *env) { + return (env == kernel_env); +} + +Scheme_Env *scheme_get_kernel_env() { + return kernel_env; +} + +static void init_scheme_local() +{ + int i, k, cor; + +#ifndef USE_TAGGED_ALLOCATION + GC_CAN_IGNORE Scheme_Local *all; + + all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS); +# ifdef MEMORY_COUNTING_ON + scheme_misc_count += sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS; +# endif +#endif + + for (i = 0; i < MAX_CONST_LOCAL_POS; i++) { + for (k = 0; k < 2; k++) { + for (cor = 0; cor < 3; cor++) { + Scheme_Object *v; + +#ifndef USE_TAGGED_ALLOCATION + v = (Scheme_Object *)(all++); +#else + v = (Scheme_Object *)scheme_malloc_eternal_tagged(sizeof(Scheme_Local)); +#endif + v->type = k + scheme_local_type; + SCHEME_LOCAL_POS(v) = i; + SCHEME_LOCAL_FLAGS(v) = cor; + + scheme_local[i][k][cor] = v; + } + } + } +} + +static void init_toplevels() +{ + int i, k, cnst; + +#ifndef USE_TAGGED_ALLOCATION + GC_CAN_IGNORE Scheme_Toplevel *all; + + all = (Scheme_Toplevel *)scheme_malloc_eternal(sizeof(Scheme_Toplevel) + * MAX_CONST_TOPLEVEL_DEPTH + * MAX_CONST_TOPLEVEL_POS + * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); +# ifdef MEMORY_COUNTING_ON + scheme_misc_count += (sizeof(Scheme_Toplevel) + * MAX_CONST_TOPLEVEL_DEPTH + * MAX_CONST_TOPLEVEL_POS + * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); +# endif +#endif + + for (i = 0; i < MAX_CONST_TOPLEVEL_DEPTH; i++) { + for (k = 0; k < MAX_CONST_TOPLEVEL_POS; k++) { + for (cnst = 0; cnst <= SCHEME_TOPLEVEL_FLAGS_MASK; cnst++) { + Scheme_Toplevel *v; + +#ifndef USE_TAGGED_ALLOCATION + v = (all++); +#else + v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel)); +#endif + v->iso.so.type = scheme_toplevel_type; + v->depth = i; + v->position = k; + SCHEME_TOPLEVEL_FLAGS(v) = cnst; + + toplevels[i][k][cnst] = (Scheme_Object *)v; + } + } + } +} + + /* Shutdown procedure for resetting a namespace: */ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data) { @@ -1238,6 +1138,7 @@ Scheme_Object **scheme_make_builtin_references_table(void) Scheme_Bucket_Table *ht; Scheme_Object **t; Scheme_Bucket **bs; + Scheme_Env *kenv; long i; t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1)); @@ -1245,7 +1146,9 @@ Scheme_Object **scheme_make_builtin_references_table(void) scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1); #endif - ht = scheme_initial_env->toplevel; + kenv = scheme_get_kernel_env(); + + ht = kenv->toplevel; bs = ht->buckets; @@ -1263,9 +1166,12 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void) Scheme_Bucket_Table *ht; Scheme_Hash_Table*result; Scheme_Bucket **bs; + Scheme_Env *kenv; long i; + + kenv = scheme_get_kernel_env(); - ht = scheme_initial_env->toplevel; + ht = kenv->toplevel; bs = ht->buckets; result = scheme_make_hash_table(SCHEME_hash_ptr); @@ -4808,7 +4714,7 @@ static Scheme_Object *read_variable(Scheme_Object *obj) varname = SCHEME_CDR(obj); if (SAME_OBJ(modname, kernel_symbol) && !mod_phase) { - return (Scheme_Object *)scheme_global_bucket(varname, scheme_initial_env); + return (Scheme_Object *)scheme_global_bucket(varname, scheme_get_kernel_env()); } else { Module_Variable *mv; Scheme_Object *insp; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 58f8f5ec12..e5dd65bb83 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -247,8 +247,8 @@ static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Schem typedef void (*DW_PrePost_Proc)(void *); #ifdef USE_STACK_BOUNDARY_VAR -unsigned long scheme_stack_boundary; -unsigned long volatile scheme_jit_stack_boundary; +THREAD_LOCAL unsigned long scheme_stack_boundary; +THREAD_LOCAL unsigned long volatile scheme_jit_stack_boundary; #endif #ifdef MZ_PRECISE_GC @@ -526,23 +526,25 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void)) /* "Stack overflow" means running out of C-stack space. The other end of this handler (i.e., the target for the longjmp) is scheme_top_level_do in fun.c */ - Scheme_Thread *p = scheme_current_thread; - Scheme_Overflow *overflow; + Scheme_Thread *p = scheme_current_thread; + Scheme_Overflow *overflow; Scheme_Overflow_Jmp *jmp; scheme_about_to_move_C_stack(); - scheme_overflow_k = k; + p->overflow_k = k; scheme_overflow_count++; - + overflow = MALLOC_ONE_RT(Scheme_Overflow); #ifdef MZTAG_REQUIRED overflow->type = scheme_rt_overflow; #endif + /* push old overflow */ overflow->prev = scheme_current_thread->overflow; - overflow->stack_start = p->stack_start; p->overflow = overflow; + overflow->stack_start = p->stack_start; + jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp); #ifdef MZTAG_REQUIRED jmp->type = scheme_rt_overflow_jmp; @@ -551,6 +553,7 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void)) scheme_init_jmpup_buf(&overflow->jmp->cont); scheme_zero_unneeded_rands(scheme_current_thread); /* for GC */ + if (scheme_setjmpup(&overflow->jmp->cont, overflow->jmp, p->stack_start)) { p = scheme_current_thread; overflow = p->overflow; @@ -620,7 +623,7 @@ void scheme_init_stack_check() #ifdef USE_STACK_BOUNDARY_VAR if (!scheme_stack_boundary) { # ifdef ASSUME_FIXED_STACK_SIZE - scheme_stack_boundary = scheme_get_stack_base(); + scheme_stack_boundary = scheme_get_current_os_thread_stack_base(); if (stack_grows_up) scheme_stack_boundary += (FIXED_STACK_SIZE - STACK_SAFETY_MARGIN); else @@ -628,7 +631,7 @@ void scheme_init_stack_check() # endif # ifdef WINDOWS_FIND_STACK_BOUNDS - scheme_stack_boundary = scheme_get_stack_base(); + scheme_stack_boundary = scheme_get_current_os_thread_stack_base(); scheme_stack_boundary += (STACK_SAFETY_MARGIN - 0x100000); # endif @@ -661,7 +664,7 @@ void scheme_init_stack_check() { unsigned long bnd, lim; - bnd = (unsigned long)scheme_get_stack_base(); + bnd = (unsigned long)scheme_get_current_os_thread_stack_base(); lim = (unsigned long)rl.rlim_cur; # ifdef UNIX_STACK_MAXIMUM diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 25213a17f9..4357ebb57c 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -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; diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 11cfaa6afb..150f4f73f9 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -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); diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index d12df5ef6b..dbd985a514 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -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) { diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index c2999acb61..9bc1bff78c 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -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 { diff --git a/src/mzscheme/src/mzrt.c b/src/mzscheme/src/mzrt.c new file mode 100644 index 0000000000..d5aa3b375b --- /dev/null +++ b/src/mzscheme/src/mzrt.c @@ -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 +#include +#include + +#include <../sconfig.h> + +/* platform headers */ +#ifdef WIN32 +# include +#else +# include +# include +# include +# include +# if defined(UNIX_LIMIT_STACK) || defined(UNIX_LIMIT_FDSET_SIZE) +# include +# include +# include +# 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 diff --git a/src/mzscheme/src/mzrt.h b/src/mzscheme/src/mzrt.h new file mode 100644 index 0000000000..634e87abb5 --- /dev/null +++ b/src/mzscheme/src/mzrt.h @@ -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 +#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 diff --git a/src/mzscheme/src/numstr.c b/src/mzscheme/src/numstr.c index de69b454ac..4a23466a94 100644 --- a/src/mzscheme/src/numstr.c +++ b/src/mzscheme/src/numstr.c @@ -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)); diff --git a/src/mzscheme/src/places.c b/src/mzscheme/src/places.c new file mode 100644 index 0000000000..e800266ea4 --- /dev/null +++ b/src/mzscheme/src/places.c @@ -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 diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index f37c377d17..44e2d9131e 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -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) { diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index bf8ff496cc..620ae730d0 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -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; diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 5f4c1e29ef..3fcde19393 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -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; diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index db71a6242a..d8cb32ccc4 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -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; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index 135d404f8e..98411faf50 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -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) diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index ff3a9ca723..3742dc35ea 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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__ */ diff --git a/src/mzscheme/src/setjmpup.c b/src/mzscheme/src/setjmpup.c index 28a902e1ee..fcd23628ef 100644 --- a/src/mzscheme/src/setjmpup.c +++ b/src/mzscheme/src/setjmpup.c @@ -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; diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index fea6451187..047b103b70 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -243,5 +243,8 @@ enum { scheme_rt_rb_node, /* 221 */ #endif + scheme_place_type, /* 222 */ + scheme_engine_type, /* 223 */ + _scheme_last_type_ }; diff --git a/src/mzscheme/src/symbol.c b/src/mzscheme/src/symbol.c index 65b0d3adb7..2339de75d5 100644 --- a/src/mzscheme/src/symbol.c +++ b/src/mzscheme/src/symbol.c @@ -28,6 +28,7 @@ # define SCHEME_NO_GC_PROTO #endif +#include "mzrt.h" #include "schpriv.h" #include #include @@ -51,6 +52,13 @@ Scheme_Hash_Table *scheme_symbol_table = NULL; Scheme_Hash_Table *scheme_keyword_table = NULL; Scheme_Hash_Table *scheme_parallel_symbol_table = NULL; +#ifdef MZ_USE_PLACES +mzrt_rwlock *symbol_table_lock; +#else +# define mzrt_rwlock_rdlock(l) /* empty */ +# define mzrt_rwlock_unlock(l) /* empty */ +#endif + unsigned long scheme_max_found_symbol_name; /* globals */ @@ -282,6 +290,10 @@ scheme_init_symbol_table () scheme_keyword_table = init_one_symbol_table(); scheme_parallel_symbol_table = init_one_symbol_table(); +#ifdef MZ_USE_PLACES + mzrt_rwlock_create(&symbol_table_lock); +#endif + #ifndef MZ_PRECISE_GC GC_custom_finalize = clean_symbol_table; #endif @@ -300,47 +312,15 @@ scheme_init_symbol (Scheme_Env *env) p = scheme_make_folding_prim(symbol_p_prim, "symbol?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("symbol?", p, env); - - scheme_add_global_constant("string->symbol", - scheme_make_immed_prim(string_to_symbol_prim, - "string->symbol", - 1, 1), env); - scheme_add_global_constant("string->uninterned-symbol", - scheme_make_immed_prim(string_to_uninterned_symbol_prim, - "string->uninterned-symbol", - 1, 1), - env); - scheme_add_global_constant("symbol->string", - scheme_make_immed_prim(symbol_to_string_prim, - "symbol->string", - 1, 1), - env); - - scheme_add_global_constant("keyword?", - scheme_make_folding_prim(keyword_p_prim, - "keyword?", - 1, 1, 1), - env); - scheme_add_global_constant("keywordkeyword", - 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("keywordkeyword", 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; diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index bba0a0332c..1d0d529824 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -142,23 +142,13 @@ extern int scheme_jit_malloced; static int buffer_init_size = INIT_TB_SIZE; -Scheme_Thread *scheme_current_thread = NULL; -Scheme_Thread *scheme_main_thread = NULL; -Scheme_Thread *scheme_first_thread = NULL; +THREAD_LOCAL Scheme_Thread *scheme_current_thread = NULL; +THREAD_LOCAL Scheme_Thread *scheme_main_thread = NULL; +THREAD_LOCAL Scheme_Thread *scheme_first_thread = NULL; Scheme_Thread *scheme_get_current_thread() { return scheme_current_thread; } -typedef struct Scheme_Thread_Set { - Scheme_Object so; - struct Scheme_Thread_Set *parent; - Scheme_Object *first; - Scheme_Object *next; - Scheme_Object *prev; - Scheme_Object *search_start; - Scheme_Object *current; -} Scheme_Thread_Set; - -Scheme_Thread_Set *thread_set_top; +THREAD_LOCAL Scheme_Thread_Set *scheme_thread_set_top; static int num_running_threads = 1; @@ -174,10 +164,10 @@ static int did_gc_count; static int init_load_on_demand = 1; #ifdef RUNSTACK_IS_GLOBAL -Scheme_Object **scheme_current_runstack_start; -Scheme_Object **scheme_current_runstack; -MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack; -MZ_MARK_POS_TYPE scheme_current_cont_mark_pos; +THREAD_LOCAL Scheme_Object **scheme_current_runstack_start; +THREAD_LOCAL Scheme_Object **scheme_current_runstack; +THREAD_LOCAL MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack; +THREAD_LOCAL MZ_MARK_POS_TYPE scheme_current_cont_mark_pos; #endif static Scheme_Custodian *main_custodian; @@ -2076,7 +2066,8 @@ static void unschedule_in_set(Scheme_Object *s, Scheme_Thread_Set *t_set) static Scheme_Thread *make_thread(Scheme_Config *config, Scheme_Thread_Cell_Table *cells, Scheme_Object *init_break_cell, - Scheme_Custodian *mgr) + Scheme_Custodian *mgr, + void *stack_base) { Scheme_Thread *process; int prefix = 0; @@ -2120,22 +2111,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config, scheme_fuel_counter_ptr = &scheme_fuel_counter; #endif - /* Before a thread can be used stack_start must be set - * this code sets stack_start for the main_thread - * which is created with scheme_make_thread. - * - * make_subprocess is the only other caller of make_thread - * and it sets stack_start */ #if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC) - { - void *ss; - ss = (void *)GC_get_stack_base(); - process->stack_start = ss; - } GC_get_thread_stack_base = get_current_stack_start; -#else - process->stack_start = GC_stackbottom; #endif + process->stack_start = stack_base; } else { prefix = 1; @@ -2178,10 +2157,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config, } if (SAME_OBJ(process, scheme_first_thread)) { - REGISTER_SO(thread_set_top); - thread_set_top = process->t_set_parent; - thread_set_top->first = (Scheme_Object *)process; - thread_set_top->current = (Scheme_Object *)process; + REGISTER_SO(scheme_thread_set_top); + scheme_thread_set_top = process->t_set_parent; + scheme_thread_set_top->first = (Scheme_Object *)process; + scheme_thread_set_top->current = (Scheme_Object *)process; } else schedule_in_set((Scheme_Object *)process, process->t_set_parent); @@ -2314,10 +2293,10 @@ static Scheme_Thread *make_thread(Scheme_Config *config, return process; } -Scheme_Thread *scheme_make_thread() +Scheme_Thread *scheme_make_thread(void *stack_base) { /* Makes the initial process. */ - return make_thread(NULL, NULL, NULL, NULL); + return make_thread(NULL, NULL, NULL, NULL, stack_base); } static void scheme_check_tail_buffer_size(Scheme_Thread *p) @@ -2532,7 +2511,7 @@ static void select_thread() /* Try to pick a next thread to avoid DOS attacks through whatever kinds of things call select_thread() */ - o = (Scheme_Object *)thread_set_top; + o = (Scheme_Object *)scheme_thread_set_top; while (!SCHEME_THREADP(o)) { t_set = (Scheme_Thread_Set *)o; o = get_t_set_next(t_set->current); @@ -2851,7 +2830,7 @@ static Scheme_Object *make_subprocess(Scheme_Object *child_thunk, maybe_recycle_cell = NULL; } - child = make_thread(config, cells, break_cell, mgr); + child = make_thread(config, cells, break_cell, mgr, child_start); /* Use child_thunk name, if any, for the thread name: */ { @@ -3801,15 +3780,154 @@ void scheme_break_thread(Scheme_Thread *p) # endif } +static void find_next_thread(Scheme_Thread **return_arg) { + Scheme_Thread *next; + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *next_in_set; + Scheme_Thread_Set *t_set; + + double msecs = 0.0; + + /* Find the next process. Skip processes that are definitely + blocked. */ + + /* Start from the root */ + next_in_set = (Scheme_Object *)scheme_thread_set_top; + t_set = NULL; /* this will get set at the beginning of the loop */ + + /* Each thread may or may not be available. If it's not available, + we search thread by thread to find something that is available. */ + while (1) { + /* next_in_set is the thread or set to try... */ + + /* While it's a set, go down into the set, choosing the next + item after the set's current. For each set, remember where we + started searching for something to run, so we'll know when + we've tried everything in the set. */ + while (!SCHEME_THREADP(next_in_set)) { + t_set = (Scheme_Thread_Set *)next_in_set; + next_in_set = get_t_set_next(t_set->current); + if (!next_in_set) + next_in_set = t_set->first; + t_set->current = next_in_set; + t_set->search_start = next_in_set; + } + + /* Now `t_set' is the set we're trying, and `next' will be the + thread to try: */ + next = (Scheme_Thread *)next_in_set; + + /* If we get back to the current thread, then + no other thread was ready. */ + if (SAME_PTR(next, p)) { + next = NULL; + break; + } + + /* Check whether `next' is ready... */ + + if (next->nestee) { + /* Blocked on nestee */ + } else if (next->running & MZTHREAD_USER_SUSPENDED) { + if (next->next || (next->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) { + /* If a non-main thread is still in the queue, + it needs to be swapped in so it can clean up + and suspend itself. */ + break; + } + } else if (next->running & MZTHREAD_KILLED) { + /* This one has been terminated. */ + if ((next->running & MZTHREAD_NEED_KILL_CLEANUP) + || next->nester + || !next->next) { + /* The thread needs to clean up. Swap it in so it can die. */ + break; + } else + remove_thread(next); + break; + } else if (next->external_break && scheme_can_break(next)) { + break; + } else { + if (next->block_descriptor == GENERIC_BLOCKED) { + if (next->block_check) { + Scheme_Ready_Fun_FPC f = (Scheme_Ready_Fun_FPC)next->block_check; + Scheme_Schedule_Info sinfo; + init_schedule_info(&sinfo, next, next->sleep_end); + if (f(next->blocker, &sinfo)) + break; + next->sleep_end = sinfo.sleep_end; + msecs = 0.0; /* that could have taken a while */ + } + } else if (next->block_descriptor == SLEEP_BLOCKED) { + if (!msecs) + msecs = scheme_get_inexact_milliseconds(); + if (next->sleep_end <= msecs) + break; + } else + break; + } + + /* Look for the next thread/set in this set */ + if (next->t_set_next) + next_in_set = next->t_set_next; + else + next_in_set = t_set->first; + + /* If we run out of things to try in this set, + go up to find the next set. */ + if (SAME_OBJ(next_in_set, t_set->search_start)) { + /* Loop to go up past exhausted sets, clearing search_start + from each exhausted set. */ + while (1) { + t_set->search_start = NULL; + t_set = t_set->parent; + + if (t_set) { + next_in_set = get_t_set_next(t_set->current); + if (!next_in_set) + next_in_set = t_set->first; + + if (SAME_OBJ(next_in_set, t_set->search_start)) { + t_set->search_start = NULL; + /* continue going up */ + } else { + t_set->current = next_in_set; + break; + } + } else + break; + } + + if (!t_set) { + /* We ran out of things to try. If we + start again with the top, we should + land back at p. */ + next = NULL; + break; + } + } else { + /* Set current... */ + t_set->current = next_in_set; + } + /* As we go back to the top of the loop, we'll check whether + next_in_set is a thread or set, etc. */ + } + + p = NULL; + next_in_set = NULL; + t_set = NULL; + *return_arg = next; + next = NULL; +} + void scheme_thread_block(float sleep_time) /* If we're blocked, `sleep_time' is a max sleep time, not a min sleep time. Otherwise, it's a min & max sleep time. This proc auto-resets p's blocking info if an escape occurs. */ { double sleep_end; - Scheme_Thread *next, *p = scheme_current_thread; - Scheme_Object *next_in_set; - Scheme_Thread_Set *t_set; + Scheme_Thread *next; + Scheme_Thread *p = scheme_current_thread; if (p->running & MZTHREAD_KILLED) { /* This thread is dead! Give up now. */ @@ -3864,142 +3982,19 @@ void scheme_thread_block(float sleep_time) check_scheduled_kills(); if (!do_atomic && (sleep_end >= 0.0)) { - double msecs = 0.0; - - /* Find the next process. Skip processes that are definitely - blocked. */ - - /* Start from the root */ - next_in_set = (Scheme_Object *)thread_set_top; - t_set = NULL; /* this will get set at the beginning of the loop */ - - /* Each thread may or may not be available. If it's not available, - we search thread by thread to find something that is available. */ - while (1) { - /* next_in_set is the thread or set to try... */ - - /* While it's a set, go down into the set, choosing the next - item after the set's current. For each set, remember where we - started searching for something to run, so we'll know when - we've tried everything in the set. */ - while (!SCHEME_THREADP(next_in_set)) { - t_set = (Scheme_Thread_Set *)next_in_set; - next_in_set = get_t_set_next(t_set->current); - if (!next_in_set) - next_in_set = t_set->first; - t_set->current = next_in_set; - t_set->search_start = next_in_set; - } - - /* Now `t_set' is the set we're trying, and `next' will be the - thread to try: */ - next = (Scheme_Thread *)next_in_set; - - /* If we get back to the current thread, then - no other thread was ready. */ - if (SAME_PTR(next, p)) { - next = NULL; - break; - } - - /* Check whether `next' is ready... */ - - if (next->nestee) { - /* Blocked on nestee */ - } else if (next->running & MZTHREAD_USER_SUSPENDED) { - if (next->next || (next->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) { - /* If a non-main thread is still in the queue, - it needs to be swapped in so it can clean up - and suspend itself. */ - break; - } - } else if (next->running & MZTHREAD_KILLED) { - /* This one has been terminated. */ - if ((next->running & MZTHREAD_NEED_KILL_CLEANUP) - || next->nester - || !next->next) { - /* The thread needs to clean up. Swap it in so it can die. */ - break; - } else - remove_thread(next); - break; - } else if (next->external_break && scheme_can_break(next)) { - break; - } else { - if (next->block_descriptor == GENERIC_BLOCKED) { - if (next->block_check) { - Scheme_Ready_Fun_FPC f = (Scheme_Ready_Fun_FPC)next->block_check; - Scheme_Schedule_Info sinfo; - init_schedule_info(&sinfo, next, next->sleep_end); - if (f(next->blocker, &sinfo)) - break; - next->sleep_end = sinfo.sleep_end; - msecs = 0.0; /* that could have taken a while */ - } - } else if (next->block_descriptor == SLEEP_BLOCKED) { - if (!msecs) - msecs = scheme_get_inexact_milliseconds(); - if (next->sleep_end <= msecs) - break; - } else - break; - } - - /* Look for the next thread/set in this set */ - if (next->t_set_next) - next_in_set = next->t_set_next; - else - next_in_set = t_set->first; - - /* If we run out of things to try in this set, - go up to find the next set. */ - if (SAME_OBJ(next_in_set, t_set->search_start)) { - /* Loop to go up past exhausted sets, clearing search_start - from each exhausted set. */ - while (1) { - t_set->search_start = NULL; - t_set = t_set->parent; - - if (t_set) { - next_in_set = get_t_set_next(t_set->current); - if (!next_in_set) - next_in_set = t_set->first; - - if (SAME_OBJ(next_in_set, t_set->search_start)) { - t_set->search_start = NULL; - /* continue going up */ - } else { - t_set->current = next_in_set; - break; - } - } else - break; - } - - if (!t_set) { - /* We ran out of things to try. If we - start again with the top, we should - land back at p. */ - next = NULL; - break; - } - } else { - /* Set current... */ - t_set->current = next_in_set; - } - /* As we go back to the top of the loop, we'll check whether - next_in_set is a thread or set, etc. */ - } + find_next_thread(&next); } else next = NULL; if (next) { /* Clear out search_start fields */ + Scheme_Thread_Set *t_set; t_set = next->t_set_parent; while (t_set) { t_set->search_start = NULL; t_set = t_set->parent; } + t_set = NULL; } if ((sleep_end > 0.0) && (p->block_descriptor == NOT_BLOCKED)) { @@ -4032,8 +4027,6 @@ void scheme_thread_block(float sleep_time) if (next) { /* Swap in `next', but first clear references to other threads. */ - next_in_set = NULL; - t_set = NULL; swap_target = next; next = NULL; do_swap_thread(); diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 789a632be5..3f26099c07 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -275,6 +275,8 @@ scheme_init_type (Scheme_Env *env) #ifdef MZ_GC_BACKTRACE set_name(scheme_rt_meta_cont, ""); #endif + set_name(scheme_place_type, ""); + set_name(scheme_engine_type, ""); } Scheme_Type scheme_make_type(const char *name)