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

352.7

Browse Source 
svn: r4592
This commit is contained in:
Matthew Flatt 2006-10-13 22:03:29 +00:00
parent 4f27609b33
commit e315bb65dc
46 changed files with 7053 additions and 5251 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/foreign/README
View File

@ -10,3 +10,8 @@ ways:
* Added line to "configure" for i*86-*-darwin*
* Added line to "configure" for i*86-*-openbsd*
* Added line to "configure" for amd64-*-freebsd*
* Added case in "configure" sparc64-*-freebsd* to existing sparc64 line

3
src/foreign/gcc/libffi/configure vendored
View File

@ -5390,12 +5390,13 @@ i*86-*-darwin*) TARGET=X86; TARGETDIR=x86;;
i*86-*-win32*) TARGET=X86_WIN32; TARGETDIR=x86;;
i*86-*-cygwin*) TARGET=X86_WIN32; TARGETDIR=x86;;
i*86-*-mingw*) TARGET=X86_WIN32; TARGETDIR=x86;;
amd64-*-freebsd* ) TARGET=X86_64; TARGETDIR=x86;;
frv-*-*) TARGET=FRV; TARGETDIR=frv;;
sparc-sun-4*) TARGET=SPARC; TARGETDIR=sparc;;
sparc*-sun-*) TARGET=SPARC; TARGETDIR=sparc;;
sparc-*-linux* | sparc-*-netbsdelf* | sparc-*-knetbsd*-gnu) TARGET=SPARC; TARGETDIR=sparc;;
sparc*-*-rtems*) TARGET=SPARC; TARGETDIR=sparc;;
sparc64-*-linux* | sparc64-*-netbsd* | sparc64-*-knetbsd*-gnu) TARGET=SPARC; TARGETDIR=sparc;;
sparc64-*-linux* | sparc64-*-netbsd* | sparc64-*-knetbsd*-gnu | sparc64-*-freebsd*) TARGET=SPARC; TARGETDIR=sparc;;
alpha*-*-linux* | alpha*-*-osf* | alpha*-*-freebsd* | alpha*-*-kfreebsd*-gnu | alpha*-*-netbsd* | alpha*-*-knetbsd*-gnu) TARGET=ALPHA; TARGETDIR=alpha;;
ia64*-*-*) TARGET=IA64; TARGETDIR=ia64;;
m32r*-*-linux* ) TARGET=M32R; TARGETDIR=m32r;;

13
src/mred/mred.cxx
View File

@ -1281,7 +1281,7 @@ static Scheme_Object *MrEdDoNextEvent(MrEdContext *c, wxDispatch_Check_Fun alt,
if (alt_wait) {
Nested_Wait *nw;
Scheme_Object *a[2], *v;
Scheme_Object *a[2], *v = NULL;
nw = (Nested_Wait *)scheme_malloc_tagged(sizeof(Nested_Wait));
nw->so.type = mred_nested_wait_type;
@ -3203,6 +3203,17 @@ wxFrame *MrEdApp::OnInit(void)
initialized = 0;
#ifdef wx_mac
{
TSMDocumentID doc;
OSType itfs[1];
itfs[0] = kUnicodeDocumentInterfaceType;
NewTSMDocument(1, itfs, &doc, 0);
UseInputWindow(NULL, TRUE);
ActivateTSMDocument(doc);
}
#endif
wxREGGLOB(mred_frames);
wxREGGLOB(mred_timers);

272
src/mred/mredmac.cxx
View File

@ -269,118 +269,187 @@ void DequeueMrEdEvents(int type, long message)
}
}
static int WeAreFront(); /* forward decl */
static RgnHandle mouseRgn;
static int waiting_for_next_event;
static int wne_handlersInstalled;
static int pending_self_ae;
/* WNE: a replacement for WaitNextEvent so we can get things like
wheel events. */
static void EnsureWNEReturn()
{
/* Generate an event that WaitNextEvent will return, but
that we can recognize and ignore. An AppleEvent is a
heavyweight but reliable way to do that. */
if (!pending_self_ae) {
ProcessSerialNumber psn;
AEAddressDesc target;
AppleEvent ae;
pending_self_ae = 1;
GetCurrentProcess(&psn);
AECreateDesc(typeProcessSerialNumber, &psn, sizeof(psn), &target);
AECreateAppleEvent('MrEd', 'Smug', &target, kAutoGenerateReturnID, kAnyTransactionID, &ae);
AESend(&ae, NULL, kAENoReply, kAENormalPriority, kNoTimeOut, NULL, NULL);
}
}
void wxSmuggleOutEvent(EventRef ref)
{
EventRecord e;
int ok = 0;
if ((GetEventClass(ref) == kEventClassMouse)
&& (GetEventKind(ref) == 11 /* kEventMouseScroll */)) {
GetEventParameter(ref, kEventParamEventRef, typeEventRef,
NULL, sizeof(ref), NULL, &ref);
}
if ((GetEventClass(ref) == kEventClassMouse)
&& (GetEventKind(ref) == kEventMouseWheelMoved)) {
UInt32 modifiers;
EventMouseWheelAxis axis;
SInt32 delta;
Point pos;
GetEventParameter(ref, kEventParamKeyModifiers, typeUInt32,
NULL, sizeof(modifiers), NULL, &modifiers);
GetEventParameter(ref, kEventParamMouseWheelAxis,
typeMouseWheelAxis, NULL, sizeof(axis), NULL, &axis);
GetEventParameter(ref, kEventParamMouseWheelDelta,
typeLongInteger, NULL, sizeof(delta), NULL, &delta);
GetEventParameter(ref, kEventParamMouseLocation,
typeQDPoint, NULL, sizeof(Point), NULL, &pos);
if (axis == kEventMouseWheelAxisY) {
e.what = wheelEvt;
e.message = (delta > 0);
e.modifiers = modifiers;
e.where.h = pos.h;
e.where.v = pos.v;
ok = TRUE;
}
} else if ((GetEventClass(ref) == kEventClassTextInput)
&& (GetEventKind(ref) == kEventTextInputUnicodeForKeyEvent)) {
UniChar *text;
UInt32 actualSize;
GetEventParameter(ref, kEventParamTextInputSendText,
typeUnicodeText, NULL, 0, &actualSize, NULL);
if (actualSize) {
text = (UniChar*)scheme_malloc_atomic(actualSize);
GetEventParameter(ref, kEventParamTextInputSendText,
typeUnicodeText, NULL, actualSize, NULL, text);
e.what = unicodeEvt;
e.message = text[0];
e.modifiers = 0;
e.where.h = 0;
e.where.v = 0;
ok = TRUE;
}
} else {
ok = ConvertEventRefToEventRecord(ref, &e);
}
if (ok) {
QueueTransferredEvent(&e);
EnsureWNEReturn();
}
}
static OSStatus unhide_cursor_handler(EventHandlerCallRef inHandlerCallRef,
EventRef inEvent,
void *inUserData)
{
wxUnhideCursor();
return eventNotHandledErr;
}
static OSStatus smuggle_handler(EventHandlerCallRef inHandlerCallRef,
EventRef inEvent,
void *inUserData)
{
wxSmuggleOutEvent(inEvent);
return noErr;
}
static pascal OSErr HandleSmug(const AppleEvent *evt, AppleEvent *rae, long k)
{
pending_self_ae = 0;
return 0;
}
/* WNE: a small wrapper for WaitNextEvent, mostly to manage
wake-up activities.
It's tempting to try to use ReceiveNextEvent() to filter
the raw events. Don't do that, because WaitNextEvent() is
magic. In particular, WaitNextEvent() properly handles
Cmd-~, Cmd-Q, dead keys like option-e on a U.S. keyboard,
clicking that brings the application to the foreground,
and the character palette. (We used ReceiveNextEvent()
until version 352.7, and finally gave up when trying
to get the character palette to work.) */
int WNE(EventRecord *e, double sleep_secs)
{
#if 0
int r;
wxResetCanvasBackgrounds();
return WaitNextEvent(everyEvent, e, sleep_secs * 60, NULL);
#else
EventRef ref;
wxResetCanvasBackgrounds();
if (!wne_handlersInstalled) {
EventTypeSpec evts[4];
wne_handlersInstalled = TRUE;
evts[0].eventClass = kEventClassMouse;
evts[0].eventKind = kEventMouseDown;
evts[1].eventClass = kEventClassMouse;
evts[1].eventKind = kEventMouseMoved;
evts[2].eventClass = kEventClassMouse;
evts[2].eventKind = kEventMouseUp;
evts[3].eventClass = kEventClassMouse;
evts[3].eventKind = kEventMouseDragged;
::InstallEventHandler(GetEventDispatcherTarget(),
unhide_cursor_handler,
4,
evts,
NULL,
NULL);
evts[0].eventClass = kEventClassMouse;
evts[0].eventKind = 11 /* kEventMouseScroll */;
evts[1].eventClass = kEventClassMouse;
evts[1].eventKind = kEventMouseWheelMoved;
evts[2].eventClass = kEventClassTextInput;
evts[2].eventKind = kEventTextInputUnicodeForKeyEvent;
::InstallEventHandler(GetEventDispatcherTarget(),
smuggle_handler,
2,
evts,
NULL,
NULL);
AEInstallEventHandler('MrEd', 'Smug', HandleSmug, 0, 0);
mouseRgn = NewRgn();
SetRectRgn(mouseRgn, 0, 0, 1, 1);
}
waiting_for_next_event = 1;
if (noErr == ReceiveNextEvent(0, NULL, sleep_secs, TRUE, &ref)) {
Boolean ok;
waiting_for_next_event = 0;
if (GetEventClass(ref) == kEventClassMouse)
wxUnhideCursor();
ok = ConvertEventRefToEventRecord(ref, e);
if (!ok) {
EventRef compat = NULL;
if ((GetEventClass(ref) == kEventClassMouse)
&& (GetEventKind(ref) == 11 /* kEventMouseScroll */)) {
GetEventParameter(ref, kEventParamEventRef, typeEventRef,
NULL, sizeof(compat), NULL, &compat);
}
if (!compat)
compat = ref;
if ((GetEventClass(compat) == kEventClassMouse)
&& (GetEventKind(compat) == kEventMouseWheelMoved)) {
UInt32 modifiers;
EventMouseWheelAxis axis;
SInt32 delta;
Point pos;
GetEventParameter(compat, kEventParamKeyModifiers, typeUInt32,
NULL, sizeof(modifiers), NULL, &modifiers);
GetEventParameter(compat, kEventParamMouseWheelAxis,
typeMouseWheelAxis, NULL, sizeof(axis), NULL, &axis);
GetEventParameter(compat, kEventParamMouseWheelDelta,
typeLongInteger, NULL, sizeof(delta), NULL, &delta);
GetEventParameter(compat, kEventParamMouseLocation,
typeQDPoint, NULL, sizeof(Point), NULL, &pos);
if (axis == kEventMouseWheelAxisY) {
e->what = wheelEvt;
e->message = (delta > 0);
e->modifiers = modifiers;
e->where.h = pos.h;
e->where.v = pos.v;
ok = TRUE;
}
} else {
SendEventToEventTarget(ref, GetEventDispatcherTarget());
}
}
if (ok && (e->what == mouseDown)) {
/* For bring-to-front: */
if (!WeAreFront()) {
SendEventToEventTarget(ref, GetEventDispatcherTarget());
/* Drop this event, because the target will generate a new one if it's useful */
ok = 0;
}
}
if (ok && (e->what == keyDown)) {
/* Let the normal system handle Cmd-Q, Cmd-~ to rotate windows,
accent handling (so option-e e e doesn't produce an accent on
the 2nd e), etc. */
OSErr oe;
wx_ignore_key = FALSE;
oe = SendEventToEventTarget(ref, GetEventDispatcherTarget());
if ((oe != eventNotHandledErr) && !wx_ignore_key) {
/* The event was handled, so we don't need to handle it again */
ok = 0;
}
}
ReleaseEvent(ref);
return ok;
}
r = WaitNextEvent(everyEvent, e, sleep_secs * 60, mouseRgn);
waiting_for_next_event = 0;
return FALSE;
#endif
return r;
}
void WakeUpMrEd()
{
/* Make sure we wake up a sleep, if this is a callback through
a window painter. */
static EventRef wakeup_evt;
if (waiting_for_next_event) {
if (!wakeup_evt)
CreateEvent(NULL, 'MrEd', 'wkup', 0, 0, &wakeup_evt);
PostEventToQueue(GetMainEventQueue(),
wakeup_evt,
kEventPriorityStandard);
EnsureWNEReturn();
waiting_for_next_event = 0;
}
}
@ -473,23 +542,6 @@ static int WindowStillHere(WindowPtr win)
return IsValidWindowPtr(win);
}
static int WeAreFront()
{
static int inited;
static ProcessSerialNumber us;
ProcessSerialNumber front;
Boolean r;
if (!inited) {
GetCurrentProcess(&us);
inited = 1;
}
GetFrontProcess(&front);
SameProcess(&us, &front, &r);
return r;
}
static int GetMods(void)
{
KeyMap km;

1
src/mzscheme/configure.ac
View File

@ -479,6 +479,7 @@ case $OS in
;;
FreeBSD)
LIBS="$LIBS -rdynamic"
DYN_CFLAGS="-fPIC"
;;
OpenBSD)
LIBS="$LIBS -rdynamic"

19
src/mzscheme/gc/include/private/gcconfig.h
View File

@ -335,10 +335,15 @@
# define X86_64
# define mach_type_known
# endif
/* PLTSCHEME: added FREEBSD + __amd64__ */
# if defined(FREEBSD) && defined(__amd64__)
# define X86_64
# define mach_type_known
# endif
# if defined(FREEBSD) && defined(__sparc__)
# define SPARC
# define mach_type_known
#endif
# endif
# if defined(bsdi) && (defined(i386) || defined(__i386__))
# define I386
# define BSDI
@ -1993,6 +1998,18 @@
# define PREFETCH_FOR_WRITE(x) __builtin_prefetch((x), 1)
# endif
# endif
/* PLTSCHEME: added FREEBSD: */
# ifdef FREEBSD
# define OS_TYPE "FREEBSD"
# define SIG_SUSPEND SIGUSR1
# define SIG_THR_RESTART SIGUSR2
# ifdef __ELF__
# define DYNAMIC_LOADING
# endif
# define HEURISTIC2
extern char etext[];
# define SEARCH_FOR_DATA_START
# endif
# ifdef NETBSD
# define OS_TYPE "NETBSD"
# ifdef __ELF__

5
src/mzscheme/gc2/compact.c
View File

@ -3809,6 +3809,11 @@ void *GC_malloc_one_small_tagged(size_t size_in_bytes)
return GC_malloc_one_tagged(size_in_bytes);
}
void *GC_malloc_one_small_dirty_tagged(size_t size_in_bytes)
{
return GC_malloc_one_tagged(size_in_bytes);
}
void *GC_malloc_pair(void *a, void *b)
{
void *p;

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

@ -138,6 +138,7 @@ scheme_temp_dec_mark_depth
scheme_temp_inc_mark_depth
scheme_current_continuation_marks
scheme_extract_one_cc_mark
scheme_extract_one_cc_mark_to_tag
scheme_do_eval
scheme_eval_compiled_stx_string
scheme_load_compiled_stx_string
@ -396,6 +397,7 @@ scheme_fdisset
scheme_add_fd_handle
scheme_add_fd_eventmask
scheme_security_check_file
scheme_security_check_file_link
scheme_security_check_network
scheme_get_host_address
scheme_free_host_address

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

@ -138,6 +138,7 @@ scheme_temp_dec_mark_depth
scheme_temp_inc_mark_depth
scheme_current_continuation_marks
scheme_extract_one_cc_mark
scheme_extract_one_cc_mark_to_tag
scheme_do_eval
scheme_eval_compiled_stx_string
scheme_load_compiled_stx_string
@ -403,6 +404,7 @@ scheme_fdisset
scheme_add_fd_handle
scheme_add_fd_eventmask
scheme_security_check_file
scheme_security_check_file_link
scheme_security_check_network
scheme_get_host_address
scheme_free_host_address

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

@ -134,6 +134,7 @@ EXPORTS
scheme_temp_inc_mark_depth
scheme_current_continuation_marks
scheme_extract_one_cc_mark
scheme_extract_one_cc_mark_to_tag
scheme_do_eval
scheme_eval_compiled_stx_string
scheme_load_compiled_stx_string
@ -388,6 +389,7 @@ EXPORTS
scheme_add_fd_handle
scheme_add_fd_eventmask
scheme_security_check_file
scheme_security_check_file_link
scheme_security_check_network
scheme_get_host_address
scheme_free_host_address

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

@ -836,13 +836,10 @@ typedef struct Scheme_Jumpup_Buf_Holder {
} Scheme_Jumpup_Buf_Holder;
typedef struct Scheme_Continuation_Jump_State {
struct Scheme_Escaping_Cont *jumping_to_continuation;
union {
Scheme_Object **vals;
Scheme_Object *val;
} u;
struct Scheme_Object *jumping_to_continuation;
Scheme_Object *val; /* or **vals */
mzshort num_vals;
short is_kill;
short is_kill, is_escape;
} Scheme_Continuation_Jump_State;
/* A mark position is in odd number, so that it can be
@ -894,7 +891,6 @@ typedef struct Scheme_Thread {
mz_jmp_buf *error_buf;
Scheme_Continuation_Jump_State cjs;
Scheme_Object *current_escape_cont_key;
Scheme_Thread_Cell_Table *cell_values;
Scheme_Config *init_config;
@ -908,9 +904,8 @@ typedef struct Scheme_Thread {
struct Scheme_Saved_Stack *runstack_saved;
Scheme_Object **runstack_tmp_keep;
/* in case of bouncing, we keep a recently
released runstack; it's dropped on GC, though */
Scheme_Object **spare_runstack;
Scheme_Object **spare_runstack; /* in case of bouncing, we keep a recently
released runstack; it's dropped on GC, though */
long spare_runstack_size;
struct Scheme_Thread **runstack_owner;
@ -920,17 +915,32 @@ typedef struct Scheme_Thread {
MZ_MARK_STACK_TYPE cont_mark_stack; /* current mark stack position */
struct Scheme_Cont_Mark **cont_mark_stack_segments;
int cont_mark_seg_count;
int cont_mark_stack_bottom; /* for restored delimited continuations */
int cont_mark_pos_bottom; /* for splicing cont marks in meta continuations */
struct Scheme_Thread **cont_mark_stack_owner;
struct Scheme_Cont_Mark *cont_mark_stack_swapped;
struct Scheme_Prompt *barrier_prompt; /* a pseudo-prompt */
struct Scheme_Prompt *meta_prompt; /* a pseudo-prompt */
struct Scheme_Meta_Continuation *meta_continuation;
long engine_weight;
void *stack_start, *stack_end;
Scheme_Jumpup_Buf jmpup_buf;
void *stack_start; /* This is the C stack base of the thread, which
corresponds to the starting stack address for
paging out the thread, and in 3m corresponds to
the starting stack address for GC marking. In non-3m,
it can be 0, which means that the deepest (non-main)
thread starting address should be used. This value will
change when a continuation is applied under a prompt,
and it will be changed on stack overflow. */
void *stack_end; /* The end of the C stack, for determine stack overflow.
Currently, this is the same for all threads. */
Scheme_Jumpup_Buf jmpup_buf; /* For jumping back to this thread */
long *cc_ok;
long cc_ok_save;
struct Scheme_Dynamic_Wind *dw;
int running;
@ -949,10 +959,7 @@ typedef struct Scheme_Thread {
char ran_some;
char suspend_to_kill;
short overflow_set;
struct Scheme_Overflow *overflow;
mz_jmp_buf *overflow_buf;
void *o_start;
struct Scheme_Comp_Env *current_local_env;
Scheme_Object *current_local_mark;
@ -1600,6 +1607,7 @@ MZ_EXTERN void scheme_set_original_dir(Scheme_Object *d);
/* Initialization */
MZ_EXTERN Scheme_Env *scheme_basic_env(void);
MZ_EXTERN void scheme_reset_overflow(void);
#ifdef USE_MSVC_MD_LIBRARY
MZ_EXTERN void GC_pre_init(void);

45
src/mzscheme/sconfig.h
View File

@ -260,13 +260,13 @@
/************** x86/OpenBSD with gcc ****************/
/* Thanks to Bengt Kleberg */
# if defined(__OpenBSD__) && (defined(__i386__) || defined(i386) || defined(__x86_64__))
#if defined(__OpenBSD__) && (defined(__i386__) || defined(i386) || defined(__x86_64__))
#if defined(__x86_64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-openbsd"
#else
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-openbsd"
#endif
# if defined(__x86_64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-openbsd"
# else
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-openbsd"
# endif
# include "uconfig.h"
# undef HAS_STANDARD_IOB
@ -302,14 +302,23 @@
/************** x86/FreeBSD with gcc ****************/
# if defined(__FreeBSD__) && (defined(i386) || defined(__x86_64__))
#if defined(i386)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-freebsd"
#endif
#if defined(__x86_64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-freebsd"
#endif
#if defined(__FreeBSD__)
# if defined(__i386__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-freebsd"
# define REGISTER_POOR_MACHINE
# define MZ_USE_JIT_I386
# define FREEBSD_CONTROL_387
# elif defined(__amd64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "amd64-freebsd"
# define REGISTER_POOR_MACHINE
# define MZ_USE_JIT_X86_64
# elif defined(__sparc64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc64-freebsd"
# define FLUSH_SPARC_REGISTER_WINDOWS
# else
# error Unported platform.
# endif
# include "uconfig.h"
# undef HAS_STANDARD_IOB
@ -331,15 +340,7 @@
# define USE_TM_GMTOFF_FIELD
# define REGISTER_POOR_MACHINE
#if defined(__x86_64__)
# define MZ_USE_JIT_X86_64
# define MZ_JIT_USE_MPROTECT
#else
# define MZ_USE_JIT_I386
# define MZ_JIT_USE_MPROTECT
#endif
# define FLAGS_ALREADY_SET

26
src/mzscheme/sgc/Makefile.in
View File

@ -12,31 +12,31 @@ ARFLAGS = @ARFLAGS@
CFLAGS = @CFLAGS@ @PREFLAGS@ @COMPFLAGS@ @PROFFLAGS@ @OPTIONS@
OBJS = sgc.o
OBJS = sgc.@LTO@
SRCS = $(srcdir)/sgc.c
../libmzgc.a: $(OBJS)
../libmzgc.@LIBSFX@: $(OBJS)
$(MAKE) gcobjects
$(AR) $(ARFLAGS) ../libmzgc.a $(OBJS)
$(RANLIB) ../libmzgc.a
$(AR) $(ARFLAGS) ../libmzgc.@LIBSFX@ $(OBJS)
$(RANLIB) ../libmzgc.@LIBSFX@
test: $(OBJS) test.o
$(CC) -o test $(OBJS) test.o
test: $(OBJS) test.@LTO@
$(CC) -o test $(OBJS) test.@LTO@
gcobjects: $(OBJS)
sgc.o: $(srcdir)/sgc.c $(srcdir)/autostat.inc $(srcdir)/collect.inc $(srcdir)/../utils/splay.c
$(CC) $(CFLAGS) -I.. -c $(srcdir)/sgc.c -o sgc.o
sgc.@LTO@: $(srcdir)/sgc.c $(srcdir)/autostat.inc $(srcdir)/collect.inc $(srcdir)/../utils/splay.c
$(CC) $(CFLAGS) -I.. -c $(srcdir)/sgc.c -o sgc.@LTO@
test.o: $(srcdir)/test.c
$(CC) $(CFLAGS) -c $(srcdir)/test.c -o test.o
test.@LTO@: $(srcdir)/test.c
$(CC) $(CFLAGS) -c $(srcdir)/test.c -o test.@LTO@
clean:
/bin/rm -f $(OBJS) gc.a test
/bin/rm -f $(OBJS) gc.@LIBSFX@ test
# Extra dependencies
sgc.o: $(srcdir)/sgc.h
sgc.@LTO@: $(srcdir)/sgc.h
test.o: $(srcdir)/sgc.h
test.@LTO@: $(srcdir)/sgc.h

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

@ -159,7 +159,7 @@ env.@LTO@: $(srcdir)/env.c
$(CC) $(CFLAGS) -c $(srcdir)/env.c -o env.@LTO@
error.@LTO@: $(srcdir)/error.c
$(CC) $(CFLAGS) -c $(srcdir)/error.c -o error.@LTO@
eval.@LTO@: $(srcdir)/eval.c $(srcdir)/schapp.inc
eval.@LTO@: $(srcdir)/eval.c $(srcdir)/schapp.inc $(srcdir)/schnapp.inc
$(CC) $(CFLAGS) -c $(srcdir)/eval.c -o eval.@LTO@
file.@LTO@: $(srcdir)/file.c
$(CC) $(CFLAGS) -c $(srcdir)/file.c -o file.@LTO@

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

File diff suppressed because it is too large Load Diff

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

@ -409,8 +409,6 @@ static Scheme_Object *do_load_extension(const char *filename,
#endif
#ifndef NO_DYNAMIC_LOAD
scheme_no_dumps("a dynamic extension has been loaded");
ed = (ExtensionData *)scheme_hash_get(loaded_extensions, mzPROC_TO_HASH_OBJ(init_f));
if (ed) {

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

@ -166,6 +166,7 @@ Scheme_Env *scheme_basic_env()
#ifndef MZ_PRECISE_GC
scheme_init_setjumpup();
#endif
scheme_reset_overflow();
scheme_make_thread();
scheme_init_error_escape_proc(NULL);
@ -224,6 +225,7 @@ Scheme_Env *scheme_basic_env()
#endif
scheme_init_stack_check();
scheme_init_overflow();
scheme_init_portable_case();
@ -430,7 +432,6 @@ static void make_init_env(void)
MZTIMEIT(print, scheme_init_print(env));
MZTIMEIT(file, scheme_init_file(env));
MZTIMEIT(dynamic-extension, scheme_init_dynamic_extension(env));
MZTIMEIT(image, scheme_init_image(env));
#ifndef NO_REGEXP_UTILS
MZTIMEIT(regexp, scheme_regexp_initialize(env));
#endif

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

@ -2495,7 +2495,7 @@ do_raise(Scheme_Object *arg, int return_ok, int need_debug)
if (need_debug) {
Scheme_Object *marks;
marks = scheme_current_continuation_marks();
marks = scheme_current_continuation_marks(NULL);
((Scheme_Structure *)arg)->slots[1] = marks;
}

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

@ -513,7 +513,9 @@ 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_Overflow_Jmp *jmp;
scheme_overflow_k = k;
scheme_overflow_count++;
@ -523,23 +525,44 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
overflow->type = scheme_rt_overflow;
#endif
overflow->prev = scheme_current_thread->overflow;
scheme_current_thread->overflow = overflow;
overflow->stack_start = p->stack_start;
p->overflow = overflow;
scheme_init_jmpup_buf(&overflow->cont);
jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
#ifdef MZTAG_REQUIRED
jmp->type = scheme_rt_overflow_jmp;
#endif
overflow->jmp = jmp;
scheme_init_jmpup_buf(&overflow->jmp->cont);
scheme_zero_unneeded_rands(scheme_current_thread); /* for GC */
if (scheme_setjmpup(&overflow->cont, overflow, scheme_current_thread->o_start)) {
if (!overflow->captured) /* reset if not captured in a continuation */
scheme_reset_jmpup_buf(&overflow->cont);
if (scheme_setjmpup(&overflow->jmp->cont, overflow->jmp, ADJUST_STACK_START(p->stack_start))) {
p = scheme_current_thread;
overflow = p->overflow;
p->overflow = overflow->prev;
p->error_buf = overflow->jmp->savebuf;
if (!overflow->jmp->captured) /* reset if not captured in a continuation */
scheme_reset_jmpup_buf(&overflow->jmp->cont);
if (!scheme_overflow_reply) {
/* No reply value means we should continue some escape. */
scheme_longjmp(scheme_error_buf, 1);
if (p->cjs.jumping_to_continuation
&& p->cjs.is_escape) {
/* Jump directly to prompt: */
Scheme_Prompt *prompt = (Scheme_Prompt *)p->cjs.jumping_to_continuation;
scheme_longjmp(*prompt->prompt_buf, 1);
} else {
/* Continue normal escape: */
scheme_longjmp(scheme_error_buf, 1);
}
} else {
Scheme_Object *reply = scheme_overflow_reply;
scheme_overflow_reply = NULL;
return reply;
}
} else
scheme_longjmp(*scheme_current_thread->overflow_buf, 1);
} else {
p->stack_start = scheme_overflow_stack_start;
scheme_longjmpup(&scheme_overflow_jmp->cont);
}
return NULL; /* never gets here */
}
@ -652,7 +675,8 @@ void *scheme_enlarge_runstack(long size, void *(*k)())
Scheme_Saved_Stack *saved;
void *v;
int cont_count;
long min_size;
volatile int escape;
mz_jmp_buf newbuf, * volatile savebuf;
saved = MALLOC_ONE_RT(Scheme_Saved_Stack);
@ -660,18 +684,27 @@ void *scheme_enlarge_runstack(long size, void *(*k)())
saved->type = scheme_rt_saved_stack;
#endif
saved->prev = p->runstack_saved;
saved->runstack = MZ_RUNSTACK;
saved->runstack_start = MZ_RUNSTACK_START;
saved->runstack_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START);
saved->runstack_size = p->runstack_size;
size += SCHEME_TAIL_COPY_THRESHOLD;
/* If we keep growing the stack, then probably it
needs to be much larger, so at least double the stack size
each time: */
min_size = 2 * (p->runstack_size);
if (size < min_size)
size = min_size;
if (size) {
/* If we keep growing the stack, then probably it
needs to be much larger, so at least double the
stack size each time: */
long min_size;
min_size = 2 * (p->runstack_size);
if (size < min_size)
size = min_size;
} else {
/* This is for a prompt. Re-use the current size,
up to a point: */
size = p->runstack_size;
if (size > 1000)
size = 1000;
}
p->runstack_saved = saved;
if (p->spare_runstack && (size <= p->spare_runstack_size)) {
@ -686,24 +719,38 @@ void *scheme_enlarge_runstack(long size, void *(*k)())
cont_count = scheme_cont_capture_count;
v = k();
/* If `k' escapes, the escape handler will restore the stack
pointers. */
savebuf = p->error_buf;
p->error_buf = &newbuf;
if (scheme_setjmp(newbuf)) {
v = NULL;
escape = 1;
p = scheme_current_thread; /* might have changed! */
} else {
v = k();
escape = 0;
p = scheme_current_thread; /* might have changed! */
p = scheme_current_thread; /* might have changed! */
if (cont_count == scheme_cont_capture_count) {
if (!p->spare_runstack || (p->runstack_size > p->spare_runstack_size)) {
p->spare_runstack = MZ_RUNSTACK_START;
p->spare_runstack_size = p->runstack_size;
if (cont_count == scheme_cont_capture_count) {
if (!p->spare_runstack || (p->runstack_size > p->spare_runstack_size)) {
p->spare_runstack = MZ_RUNSTACK_START;
p->spare_runstack_size = p->runstack_size;
}
}
}
p->error_buf = savebuf;
saved = p->runstack_saved;
p->runstack_saved = saved->prev;
MZ_RUNSTACK = saved->runstack;
MZ_RUNSTACK_START = saved->runstack_start;
MZ_RUNSTACK = MZ_RUNSTACK_START + saved->runstack_offset;
p->runstack_size = saved->runstack_size;
if (escape) {
scheme_longjmp(*p->error_buf, 1);
}
return v;
}
@ -5282,30 +5329,68 @@ void scheme_pop_continuation_frame(Scheme_Cont_Frame_Data *d)
MZ_CONT_MARK_STACK = d->cont_mark_stack;
}
void *scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
MZ_MARK_STACK_TYPE scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Cont_Mark *cm = NULL;
long findpos;
long findpos, bottom;
findpos = (long)MZ_CONT_MARK_STACK;
while (findpos--) {
Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
long pos = findpos & SCHEME_MARK_SEGMENT_MASK;
Scheme_Cont_Mark *find = seg + pos;
bottom = (long)p->cont_mark_stack_bottom;
while (1) {
if (findpos-- > bottom) {
Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
long pos = findpos & SCHEME_MARK_SEGMENT_MASK;
Scheme_Cont_Mark *find = seg + pos;
if ((long)find->pos < (long)MZ_CONT_MARK_POS) {
break;
} else {
if (find->key == key) {
cm = find;
break;
if ((long)find->pos < (long)MZ_CONT_MARK_POS) {
break;
} else {
/* Assume that we'll mutate rather than allocate a new mark record. */
/* This is a bad assumption for a nasty program that repeatedly
creates a new key for the same frame, but it's good enough. */
find->cache = NULL;
if (find->key == key) {
cm = find;
break;
} else {
/* Assume that we'll mutate rather than allocate a new mark record. */
/* This is a bad assumption for a nasty program that repeatedly
creates a new key for the same frame, but it's good enough. */
find->cache = NULL;
}
}
} else {
if (MZ_CONT_MARK_POS == p->cont_mark_pos_bottom + 2) {
if (p->meta_continuation) {
if (key != scheme_stack_dump_key) {
/* Check the end of the meta-continuation's stack */
Scheme_Meta_Continuation *mc = p->meta_continuation;
for (findpos = (long)mc->cont_mark_shareable; findpos--; ) {
if (mc->cont_mark_stack_copied[findpos].pos != mc->cont_mark_pos)
break;
if (mc->cont_mark_stack_copied[findpos].key == key) {
if (mc->copy_after_captured < scheme_cont_capture_count) {
/* Clone the meta-continuation, in case it was captured by
a continuation in its current state. */
Scheme_Meta_Continuation *naya;
Scheme_Cont_Mark *cp;
naya = MALLOC_ONE_RT(Scheme_Meta_Continuation);
memcpy(naya, mc, sizeof(Scheme_Meta_Continuation));
cp = MALLOC_N(Scheme_Cont_Mark, naya->cont_mark_shareable);
memcpy(cp, mc->cont_mark_stack_copied, naya->cont_mark_shareable * sizeof(Scheme_Cont_Mark));
naya->cont_mark_stack_copied = cp;
naya->copy_after_captured = scheme_cont_capture_count;
mc = naya;
p->meta_continuation = mc;
}
mc->cont_mark_stack_copied[findpos].val = val;
mc->cont_mark_stack_copied[findpos].cache = NULL;
return 0;
} else {
mc->cont_mark_stack_copied[findpos].cache = NULL;
}
}
}
}
}
break;
}
}
@ -5334,6 +5419,7 @@ void *scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
seg = p->cont_mark_stack_segments[segpos];
cm = seg + pos;
findpos = MZ_CONT_MARK_STACK;
MZ_CONT_MARK_STACK++;
}
@ -5342,7 +5428,7 @@ void *scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
cm->pos = MZ_CONT_MARK_POS; /* always odd */
cm->cache = NULL;
return cm;
return findpos;
}
void scheme_temp_dec_mark_depth()
@ -5495,6 +5581,51 @@ static void make_tail_buffer_safe()
p->tail_buffer = tb;
}
static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b,
Scheme_Object *prompt_tag, int *_common_depth)
{
int alen = 0, blen = 0;
int prompt_delta = 0;
if (prompt_tag) {
Scheme_Dynamic_Wind *dw;
for (dw = a; dw && (dw->prompt_tag != prompt_tag); dw = dw->prev) {
}
if (dw)
prompt_delta = dw->depth + 1;
}
alen = (a ? a->depth + 1 : 0) - prompt_delta;
blen = (b ? b->depth + 1 : 0);
while (alen > blen) {
--alen;
a = a->prev;
}
if (!alen) {
*_common_depth = -1;
return a;
}
while (blen > alen) {
--blen;
b = b->prev;
}
/* At this point, we have chains that are the same length. */
while (blen) {
if (SAME_OBJ(a->id ? a->id : (Scheme_Object *)a,
b->id ? b->id : (Scheme_Object *)b))
break;
a = a->prev;
b = b->prev;
blen--;
}
*_common_depth = (b ? b->depth : -1);
return a;
}
#ifdef REGISTER_POOR_MACHINE
# define USE_LOCAL_RUNSTACK 0
# define DELAY_THREAD_RUNSTACK_UPDATE 0
@ -5544,7 +5675,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
#if USE_LOCAL_RUNSTACK
GC_MAYBE_IGNORE_INTERIOR Scheme_Object **runstack;
#endif
GC_MAYBE_IGNORE_INTERIOR Scheme_Cont_Mark *pm = NULL;
MZ_MARK_STACK_TYPE pmstack = -1;
# define p scheme_current_thread
#ifdef DO_STACK_CHECK
@ -5821,24 +5952,33 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
obj = data->code;
if (pm) {
if (pmstack >= 0) {
long segpos = ((long)pmstack) >> SCHEME_LOG_MARK_SEGMENT_SIZE;
long pos = ((long)pmstack) & SCHEME_MARK_SEGMENT_MASK;
GC_CAN_IGNORE Scheme_Cont_Mark *pm = NULL;
pm = p->cont_mark_stack_segments[segpos] + pos;
if (!pm->cache)
pm->val = data->name;
else {
/* Need to clear caches and/or update pm, so do it the slow way */
/* Need to clear caches, so do it the slow way */
UPDATE_THREAD_RSPTR_FOR_PROC_MARK();
pm = (Scheme_Cont_Mark *)scheme_set_cont_mark(scheme_stack_dump_key, data->name);
pmstack = scheme_set_cont_mark(scheme_stack_dump_key, data->name);
}
} else {
/* Allocate a new mark record: */
long segpos = ((long)MZ_CONT_MARK_STACK) >> SCHEME_LOG_MARK_SEGMENT_SIZE;
if (segpos >= p->cont_mark_seg_count) {
UPDATE_THREAD_RSPTR_FOR_PROC_MARK();
pm = (Scheme_Cont_Mark *)scheme_set_cont_mark(scheme_stack_dump_key, data->name);
pmstack = scheme_set_cont_mark(scheme_stack_dump_key, data->name);
} else {
long pos = ((long)MZ_CONT_MARK_STACK) & SCHEME_MARK_SEGMENT_MASK;
GC_CAN_IGNORE Scheme_Cont_Mark *pm;
GC_CAN_IGNORE Scheme_Cont_Mark *seg;
pmstack = MZ_CONT_MARK_STACK;
seg = p->cont_mark_stack_segments[segpos];
pm = seg + pos;
MZ_CONT_MARK_STACK++;
@ -5914,6 +6054,9 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
Scheme_Cont *c;
Scheme_Dynamic_Wind *dw, *common;
Scheme_Object *value;
Scheme_Meta_Continuation *prompt_mc;
Scheme_Prompt *prompt;
int common_depth;
if (num_rands != 1) {
GC_CAN_IGNORE Scheme_Object **vals;
@ -5944,51 +6087,161 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
c = c->buf.cont;
}
if (c->ok && !*c->ok) {
UPDATE_THREAD_RSPTR_FOR_ERROR();
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"continuation application: attempted to cross a continuation barrier");
}
p->suspend_break++; /* restored at call/cc destination */
if (c->composable) {
/* Composable continuation. Jump right in... */
RUNSTACK = old_runstack;
RUNSTACK_CHANGED();
UPDATE_THREAD_RSPTR();
v = scheme_compose_continuation(c, num_rands, value);
} else {
/* Aborting (Scheme-style) continuation. */
/* Find `common', then intersection of dynamic-wind chain for
the current continuation and the given continuation */
common = p->dw;
while (common) {
dw = c->dw;
while (dw && dw != common) {
dw = dw->prev;
}
if (dw)
break;
common = common->prev;
}
c->common = common;
/* For dynamic-winds after `common' in this
continuation, execute the post-thunks */
for (dw = p->dw; dw != common; dw = dw->prev) {
if (dw->post) {
DW_PrePost_Proc post = dw->post;
p->dw = dw->prev;
MZ_CONT_MARK_POS = dw->envss.cont_mark_pos;
MZ_CONT_MARK_STACK = dw->envss.cont_mark_stack;
post(dw->data);
p = scheme_current_thread;
}
}
prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL,
SCHEME_PTR_VAL(c->prompt_tag),
NULL,
&prompt_mc);
if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, c->prompt_tag)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"continuation application: no corresponding prompt in the current continuation");
}
/* A continuation barrier is analogous to a dynamic-wind. A jump is
allowed if no dynamic-wind-like barriers would be executed for
the jump. */
{
Scheme_Prompt *b1, *b2;
b1 = p->barrier_prompt;
if (b1) {
if (!b1->is_barrier)
b1 = NULL;
else if (prompt && (prompt->depth > b1->depth))
b1 = NULL;
}
b2 = c->ss.barrier_prompt;
if (b2) {
if (!b2->is_barrier)
b2 = NULL;
else if (c->prompt_depth > b2->depth)
b2 = NULL;
}
if (b1 != b2) {
UPDATE_THREAD_RSPTR_FOR_ERROR();
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"continuation application: attempt to cross a continuation barrier");
}
}
p->suspend_break++; /* restored at call/cc destination */
/* Find `common', the intersection of dynamic-wind chain for
the current continuation and the given continuation, looking
no further back in the current continuation than a prompt. */
common = intersect_dw(p->dw, c->dw, c->prompt_tag, &common_depth);
/* For dynamic-winds after `common' in this
continuation, execute the post-thunks */
{
int meta_depth = 0;
for (dw = p->dw;
((common && common->id) ? dw->id != common->id : dw != common);
) {
if (dw->post) {
p->dw = dw->prev;
meta_depth += dw->next_meta;
if (meta_depth) {
scheme_apply_dw_in_meta(dw, 1, meta_depth);
} else {
DW_PrePost_Proc post = dw->post;
MZ_CONT_MARK_POS = dw->envss.cont_mark_pos;
MZ_CONT_MARK_STACK = dw->envss.cont_mark_stack;
post(dw->data);
}
p = scheme_current_thread;
/* p->dw might not match dw if the post thunk captures a
continuation that is later restored in a different
meta continuation: */
dw = p->dw;
} else
dw = dw->prev;
}
}
c->common_dw_depth = common_depth;
if (num_rands == 1)
c->value = value;
else {
GC_CAN_IGNORE Scheme_Object *vals;
vals = scheme_values(num_rands, (Scheme_Object **)value);
c->value = vals;
}
scheme_longjmpup(&c->buf);
if (num_rands == 1)
c->value = value;
else {
GC_CAN_IGNORE Scheme_Object *vals;
vals = scheme_values(num_rands, (Scheme_Object **)value);
c->value = vals;
}
p->dw = common;
if (!prompt) {
/* Invoke the continuation directly. If there's no prompt,
then the prompt's job is taken by the pseudo-prompt
created with a new thread or a barrier prompt. */
p->meta_continuation = NULL; /* since prompt wasn't in any meta-continuation */
p->meta_prompt = NULL;
if (c->ss.barrier_prompt == p->barrier_prompt) {
/* Barrier determines continuation end. */
c->resume_to = NULL;
p->stack_start = c->stack_start;
} else {
/* Prompt is pseudo-prompt at thread beginning.
We're effectively composing the continuation,
so use it's prompt stack start. */
Scheme_Overflow *oflow;
oflow = scheme_get_thread_end_overflow();
c->resume_to = oflow;
p->stack_start = c->prompt_stack_start;
}
scheme_longjmpup(&c->buf);
} else {
p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
p->cjs.num_vals = 1;
p->cjs.val = (Scheme_Object *)c;
p->cjs.is_escape = 1;
if (prompt_mc) {
/* The prompt is from a meta-continuation that's different
from the current one. Jump to the meta-continuation
and continue from there. Immediate destination is
in compose_continuation() in fun.c; the ultimate
destination is in scheme_finish_apply_for_prompt()
in fun.c. */
p->meta_continuation = prompt_mc->next;
p->stack_start = prompt_mc->overflow->stack_start;
scheme_longjmpup(&prompt_mc->overflow->jmp->cont);
} else if ((!prompt->boundary_overflow_id && !p->overflow)
|| (prompt->boundary_overflow_id == p->overflow->id)) {
/* Jump directly to the prompt: destination is in
scheme_finish_apply_for_prompt() in fun.c. */
scheme_longjmp(*prompt->prompt_buf, 1);
} else {
/* Need to unwind overflows to get to the prompt. */
Scheme_Overflow *overflow = p->overflow;
while (overflow->prev
&& (!overflow->prev->id
|| (overflow->prev->id != prompt->boundary_overflow_id))) {
overflow = overflow->prev;
}
/* Immediate destination is in scheme_handle_stack_overflow().
Ultimate destination is in scheme_finish_apply_for_prompt()
in fun.c. */
p->overflow = overflow;
p->stack_start = overflow->stack_start;
scheme_longjmpup(&overflow->jmp->cont);
}
}
return NULL;
return NULL;
}
} else if (type == scheme_escaping_cont_type) {
Scheme_Object *value;
@ -6019,8 +6272,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
"continuation application: attempt to jump into an escape continuation");
}
p->cjs.u.val = value;
p->cjs.jumping_to_continuation = (Scheme_Escaping_Cont *)obj;
p->cjs.val = value;
p->cjs.jumping_to_continuation = obj;
scheme_longjmp(MZTHREADELEM(p, error_buf), 1);
return NULL;
} else if (type == scheme_proc_struct_type) {

21
src/mzscheme/src/file.c
View File

@ -3983,7 +3983,8 @@ static Scheme_Object *delete_directory(int argc, Scheme_Object *argv[])
static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
{
char *src, *dest;
char *src;
Scheme_Object *dest;
int copied;
if (!SCHEME_PATH_STRINGP(argv[0]))
@ -3991,15 +3992,23 @@ static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
if (!SCHEME_PATH_STRINGP(argv[1]))
scheme_wrong_type("make-file-or-directory-link", SCHEME_PATH_STRING_STR, 0, argc, argv);
dest = scheme_expand_string_filename(argv[0],
"make-file-or-directory-link",
&copied,
SCHEME_GUARD_FILE_EXISTS);
dest = argv[0];
/* dest does not get expanded, but we need to make sure it's a path */
dest = TO_PATH(dest);
if (has_null(SCHEME_PATH_VAL(dest), SCHEME_PATH_LEN(dest))) {
raise_null_error("make-file-or-directory-link", dest, "");
return NULL;
}
src = scheme_expand_string_filename(argv[1],
"make-file-or-directory-link",
&copied,
SCHEME_GUARD_FILE_WRITE);
scheme_security_check_file_link("make-file-or-directory-link",
src,
SCHEME_PATH_VAL(dest));
#if defined(DOS_FILE_SYSTEM)
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"make-file-or-directory-link: link creation not supported on this platform; "
@ -4007,7 +4016,7 @@ static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
argv[1]);
#else
while (1) {
if (!MSC_W_IZE(symlink)(MSC_WIDE_PATH(dest), src))
if (!symlink(SCHEME_PATH_VAL(dest), src))
return scheme_void;
else if (errno != EINTR)
break;

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

File diff suppressed because it is too large Load Diff

3
src/mzscheme/src/hash.c
View File

@ -291,6 +291,9 @@ static Scheme_Object *do_hash_set(Scheme_Hash_Table *table, Scheme_Object *key,
h = (h + h2) & mask;
}
if (!val)
return NULL;
if (set == 1)
h = useme;
else if (table->mcount * FILL_FACTOR >= table->size) {

741
src/mzscheme/src/image.c
View File

@ -22,31 +22,11 @@
All rights reserved.
*/
/* Images are long since unsupported, so all that's left is this
little trampoline. */
#include "schpriv.h"
#ifdef UNIX_IMAGE_DUMPS
#include "schmach.h"
#ifdef FILES_HAVE_FDS
# include <sys/types.h>
# include <sys/time.h>
# ifdef SELECT_INCLUDE
# include <sys/select.h>
# endif
#endif
#ifndef NO_USER_BREAK_HANDLER
# include <signal.h>
#endif
#ifdef UNISTD_INCLUDE
# include <unistd.h>
#endif
#ifdef UNIX_IMAGE_DUMPS
# include <ctype.h>
# include "schgc.h"
#endif
extern void *GC_get_stack_base();
#endif
MZ_DLLSPEC int (*scheme_actual_main)(int argc, char **argv);
void scheme_set_actual_main(int (*m)(int argc, char **argv))
@ -54,720 +34,11 @@ void scheme_set_actual_main(int (*m)(int argc, char **argv))
scheme_actual_main = m;
}
#ifdef UNIX_IMAGE_DUMPS
static Scheme_Object *(*scheme_dump_heap)(char *filename) = NULL;
static Scheme_Object *(*scheme_load_heap)(char *filename, Scheme_Object *argvec) = NULL;
#endif
static char *no_dumps;
extern int scheme_file_open_count;
#ifdef UNIX_PROCESSES
extern void *scheme_system_children;
#endif
static Scheme_Object *dump_heap(int argc, Scheme_Object **argv);
static Scheme_Object *load_heap(int argc, Scheme_Object **argv);
void scheme_init_image(Scheme_Env *env)
{
scheme_add_global_constant("write-image-to-file",
scheme_make_prim_w_arity(dump_heap,
"write-image-to-file",
1, 2),
env);
scheme_add_global_constant("read-image-from-file",
scheme_make_prim_w_arity(load_heap,
"read-image-from-file",
2, 2),
env);
}
void scheme_no_dumps(char *why)
{
if (why && !no_dumps)
no_dumps = why;
}
static Scheme_Object *dump_heap(int argc, Scheme_Object **argv)
{
char *filename;
if (!SCHEME_PATH_STRINGP(argv[0]))
scheme_wrong_type("write-image-to-file", SCHEME_PATH_STRING_STR, 0, argc, argv);
if (argc > 1)
if (!SCHEME_FALSEP(argv[1]))
scheme_check_proc_arity("write-image-to-file", 0,
1, argc, argv);
filename = scheme_expand_string_filename(argv[0],
"write-image-to-file", NULL,
SCHEME_GUARD_FILE_WRITE);
#ifdef UNIX_IMAGE_DUMPS
if (scheme_dump_heap) {
if (no_dumps) {
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
"write-image-to-file: image cannot be saved; %s",
no_dumps);
return NULL;
} else if (scheme_file_open_count) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"write-image-to-file: a file, process, or TCP port is open (%d)",
scheme_file_open_count);
return NULL;
#ifdef UNIX_PROCESSES
} else if (scheme_system_children) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"write-image-to-file: a subprocess is still active");
return NULL;
#endif
} else {
Scheme_Object *v;
v = scheme_dump_heap(filename);
if (!v) {
if (argc > 1) {
if (SCHEME_FALSEP(argv[1]))
exit(0);
else
return _scheme_tail_apply(argv[1], 0, NULL);
} else
return scheme_void;
} else
return v;
}
}
#endif
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"write-image-to-file: not supported");
return NULL;
}
static Scheme_Object *load_heap(int argc, Scheme_Object **argv)
{
char *filename;
int bad = 0;
if (!SCHEME_PATH_STRINGP(argv[0]))
scheme_wrong_type("read-image-from-file", SCHEME_PATH_STRING_STR, 0, argc, argv);
if (SCHEME_VECTORP(argv[1])) {
Scheme_Object **a;
int i;
a = SCHEME_VEC_ELS(argv[1]);
for (i = SCHEME_VEC_SIZE(argv[1]); i--; ) {
if (!SCHEME_BYTE_STRINGP(a[i])) {
bad = 1;
break;
}
}
} else
bad = 1;
if (bad)
scheme_wrong_type("read-image-from-file", "vector of strings", 0, argc, argv);
filename = scheme_expand_string_filename(argv[0],
"read-image-from-file", NULL,
SCHEME_GUARD_FILE_READ);
#ifdef UNIX_IMAGE_DUMPS
if (scheme_load_heap)
scheme_load_heap(filename, argv[1]);
#endif
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"read-image-from-file: not supported");
return NULL;
}
/******************************************************************************/
#ifdef UNIX_IMAGE_DUMPS
/* XXX_SKIP_PLT makes images sortof work for dynamically-linked programs */
#if defined(sun) && defined(ECHRNG)
# define SOLARIS_SKIP_PLT
#endif
#if 0 && defined(__FreeBSD__)
# define FREEBSD_SKIP_PLT
#endif
static char *restore_brk;
static unsigned long stack_base;
static unsigned long orig_brk;
static int data_count;
static unsigned long *data_starts;
static unsigned long *data_ends;
typedef unsigned long ptr_t;
typedef unsigned long word;
static Scheme_Jumpup_Buf **restore_launch_ubuf;
extern char **environ;
#include <errno.h>
#include <fcntl.h>
#include <unistd.h>
#include <sys/param.h>
#include "../gc/include/private/gcconfig.h"
static void die_now(char *phase, char *file)
{
printf("Restore from \"%s\" failed at %s (%d)\n", file, phase, errno);
exit(-1);
}
#if defined(linux) || defined(__FreeBSD__)
# define FIND_WRITEABLE_SECTION
#endif
#ifdef FIND_WRITEABLE_SECTION
static unsigned long current_value;
static mz_jmp_buf goback;
static void bus_error(int ignore)
{
scheme_longjmp(goback, 1);
}
#endif
static void do_restore_env_argv(long orig_len, long len,
char *start, char *carry, mz_jmp_buf b)
{
char buffer[1024];
if (len < 0) {
long l, i;
Scheme_Object *v;
FLUSH_REGISTER_WINDOWS;
if ((unsigned long)carry < (unsigned long)start)
start = carry;
memcpy(start, restore_brk + sizeof(long), orig_len);
brk(restore_brk);
l = *(long *)start;
start += sizeof(long);
environ = malloc(sizeof(char *) * (l + 1));
environ[l] = NULL;
for (i = 0; i < l; i++) {
int l = strlen(start);
environ[i] = malloc(l + 1);
memcpy(environ[i], start, l + 1);
start += l + 1;
}
/* align for long */
if ((long)start & (sizeof(long) - 1))
start += (sizeof(long) - ((long)start & (sizeof(long) - 1)));
l = *(long *)start;
start += sizeof(long);
v = scheme_make_vector(l, scheme_null);
for (i = 0; i < l; i++) {
SCHEME_VEC_ELS(v)[i] = scheme_make_string(start);
start += strlen(start) + 1;
}
scheme_longjmp(b, (long)v);
} else
do_restore_env_argv(orig_len, len - 1024,
start ? start : buffer, buffer, b);
}
static Scheme_Object *restore_env_argv(long len)
{
mz_jmp_buf buf;
Scheme_Object *v;
/* We're going to trash the stack, so we'll need to escape */
v = (Scheme_Object *)scheme_setjmp(buf);
if (!v)
do_restore_env_argv(len, len, NULL, NULL, buf);
return v;
}
static Scheme_Object *dump_image(char *filename)
{
Scheme_Jumpup_Buf *buf;
Scheme_Object *v;
buf = (Scheme_Jumpup_Buf *)scheme_malloc(sizeof(Scheme_Jumpup_Buf));
scheme_init_jmpup_buf(buf);
if (!scheme_setjmpup(buf, buf, (void *)stack_base)) {
unsigned long current_brk = (unsigned long)sbrk(0);
int fd;
do {
fd = open(filename, O_WRONLY | O_CREAT | O_TRUNC, 0644);
} while ((fd == -1) && (errno == EINTR));
if (fd == -1) {
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
"write-image-to-file: couldn't write file \"%q\"",
filename);
} else {
int i;
const char *machine = scheme_system_library_subpath();
unsigned char len = strlen(machine);
write(fd, (char *)&len, sizeof(char));
write(fd, (char *)machine, len);
len = strlen(MZSCHEME_VERSION);
write(fd, (char *)&len, sizeof(char));
write(fd, (char *)MZSCHEME_VERSION, len);
write(fd, (char *)&data_count, sizeof(int));
for (i = 0; i < data_count; i++) {
write(fd, (char *)&(data_starts[i]), sizeof(unsigned long));
write(fd, (char *)&(data_ends[i]), sizeof(unsigned long));
}
write(fd, (char *)&orig_brk, sizeof(unsigned long));
write(fd, (char *)&stack_base, sizeof(unsigned long));
for (i = 0; i < data_count; i++) {
write(fd, (char *)data_starts[i], data_ends[i] - data_starts[i]);
}
write(fd, (char *)&current_brk, sizeof(unsigned long));
write(fd, (char *)orig_brk, current_brk - orig_brk);
write(fd, (char *)&buf, sizeof(Scheme_Jumpup_Buf *));
close(fd);
}
v = NULL;
} else {
/* We've been restored. environ contains a pointer to environment + argv. */
long len;
len = *(long *)restore_brk;
v = restore_env_argv(len);
}
/* zero it back out for GC */
scheme_init_jmpup_buf(buf);
return v;
}
static void mismatch(int which, unsigned long a, unsigned long b, char *file, void (*die)(char *c1, char *c2))
{
char buffer[256];
errno = which;
sprintf(buffer, "setup mismatch [%lx vs %lx]", a, b);
die(buffer, file);
}
static void do_restore_image(char *file, int argc, char **argv,
Scheme_Jumpup_Buf **ubuf,
void (*die)(char *c1, char *c2),
long env_len, char *env_space1, char *env_space2)
{
# define MACHVERS_MAX_LEN 100
int fd;
int i, count;
long argv_len;
unsigned long current_brk;
unsigned long saved_data_start, saved_data_end, saved_orig_brk, saved_stack_base;
int saved_data_count;
const char *machine = scheme_system_library_subpath();
char machvers[MACHVERS_MAX_LEN];
unsigned char len;
char **save_environ;
do {
fd = open(file, O_RDONLY);
} while ((fd == -1) && (errno == EINTR));
if (fd == -1)
die("open", file);
if (read(fd, (char *)&len, sizeof(char)) != sizeof(char)) {
close(fd);
die("getting machine type", file);
}
if (len >= MACHVERS_MAX_LEN) {
close(fd);
die("getting machine type", file);
}
if (read(fd, (char *)machvers, len) != len) {
close(fd);
die("getting machine type", file);
}
machvers[len] = 0;
if (strcmp(machvers, machine)) {
char buffer[256];
sprintf(buffer, "machine type: image is %s, this is %s", machvers, machine);
die(buffer, file);
}
if (read(fd, (char *)&len, sizeof(char)) != sizeof(char)) {
close(fd);
die("getting version", file);
}
if (len >= MACHVERS_MAX_LEN) {
close(fd);
die("getting version", file);
}
if (read(fd, (char *)machvers, len) != len) {
close(fd);
die("getting version", file);
}
machvers[len] = 0;
if (strcmp(machvers, MZSCHEME_VERSION)) {
char buffer[256];
sprintf(buffer, "version: image is %s, this is %s", machvers, machine);
die(buffer, file);
}
if (read(fd, (char *)&saved_data_count, sizeof(int)) != sizeof(int)) {
close(fd);
die("setup", file);
}
if (saved_data_count != data_count) {
close(fd);
mismatch(-1, saved_data_count, data_count, file, die);
}
for (i = 0; i < data_count; i++) {
if (read(fd, (char *)&saved_data_start, sizeof(unsigned long)) != sizeof(unsigned long)
|| read(fd, (char *)&saved_data_end, sizeof(unsigned long)) != sizeof(unsigned long)) {
close(fd);
die("setup", file);
}
if (saved_data_start != data_starts[i]) {
close(fd);
mismatch(-10 * (i + 1), saved_data_start, data_starts[i], file, die);
}
if (saved_data_end != data_ends[i]) {
close(fd);
mismatch(-1000 + -10 * (i + 1), saved_data_end, data_ends[i], file, die);
}
}
if (read(fd, (char *)&saved_orig_brk, sizeof(unsigned long)) != sizeof(unsigned long)
|| read(fd, (char *)&saved_stack_base, sizeof(unsigned long)) != sizeof(unsigned long)) {
close(fd);
die("setup", file);
}
if (saved_orig_brk != orig_brk) {
close(fd);
mismatch(-3, saved_orig_brk, orig_brk, file, die);
}
if (saved_stack_base != stack_base) {
close(fd);
mismatch(-4, saved_stack_base, stack_base, file, die);
}
if ((unsigned long)env_space1 > (unsigned long)env_space2)
env_space1 = env_space2;
save_environ = (char **)env_space1;
for (i = 0; environ[i]; i++) {}
env_space1 += i * sizeof(char *);
for (i = 0; environ[i]; i++) {
int l;
save_environ[i] = env_space1;
l = strlen(environ[i]);
memcpy(save_environ[i], environ[i], l + 1);
env_space1 += l + 1;
}
count = i;
for (i = 0; i < data_count; i++) {
if (read(fd, (char *)data_starts[i], data_ends[i] - data_starts[i]) != (data_ends[i] - data_starts[i]))
die_now("data", file);
}
if (read(fd, (char *)&current_brk, sizeof(unsigned long)) != sizeof(unsigned long))
die_now("data position", file);
brk((void *)current_brk);
if (read(fd, (char *)orig_brk, current_brk - orig_brk) != (current_brk - orig_brk))
die_now("dynamic data", file);
if (read(fd, (char *)ubuf, sizeof(Scheme_Jumpup_Buf *)) != sizeof(Scheme_Jumpup_Buf *))
die_now("stack", file);
close(fd);
/* Use sbrk to make room for env and argv; this will have to be restored
in a tricky way. */
argv_len = sizeof(long);
for (i = 0; i < argc; i++) {
argv_len += strlen(argv[i]) + 1;
}
env_len += sizeof(long);
restore_brk = sbrk(env_len + argv_len + 2 * sizeof(long));
env_space1 = restore_brk;
*(long *)env_space1 = env_len + argv_len + sizeof(long);
env_space1 += sizeof(long);
*(long *)env_space1 = count;
env_space1 += sizeof(long);
for (i = 0; i < count; i++) {
int l = strlen(save_environ[i]);
memcpy(env_space1, save_environ[i], l + 1);
env_space1 += l + 1;
}
/* align for long */
if ((long)env_space1 & (sizeof(long) - 1))
env_space1 += (sizeof(long) - ((long)env_space1 & (sizeof(long) - 1)));
*(long *)env_space1 = argc;
env_space1 += sizeof(long);
for (i = 0; i < argc; i++) {
int l = strlen(argv[i]);
memcpy(env_space1, argv[i], l + 1);
env_space1 += l + 1;
}
scheme_longjmpup(*ubuf);
}
static void do_restore_image_with_space(char *file, int argc, char **argv,
Scheme_Jumpup_Buf **ubuf,
void (*die)(char *c1, char *c2),
long orig_len, long len, void *start, void *carry)
{
char buffer[1024];
if (len < 1024)
do_restore_image(file, argc, argv, ubuf, die, orig_len, (char *)start, buffer);
else
do_restore_image_with_space(file, argc, argv, ubuf, die, orig_len, len - 1024, start, buffer);
}
static void restore_image(char *file, int argc, char **argv,
Scheme_Jumpup_Buf **ubuf,
void (*die)(char *c1, char *c2))
{
int i;
long len = 0;
for (i = 0; environ[i]; i++) {
len += strlen(environ[i]) + 1;
}
len += sizeof(char **) * (i + 1);
do_restore_image_with_space(file, argc, argv, ubuf, die, len, len, &len, &len);
}
static void read_image_exn(char *phase, char *file)
{
scheme_raise_exn(MZEXN_FAIL,
"read-image-from-file: restore from \"%q\" failed at %s (%d).",
file, phase, errno);
}
static Scheme_Object *load_image(char *filename, Scheme_Object *argvec)
{
# define MAX_ARGV 20
# define MAX_ARGLEN 2048
char *argv[MAX_ARGV], argspace[MAX_ARGLEN + MAX_ARGV], *s;
int i, count;
long l;
Scheme_Object **a;
count = SCHEME_VEC_SIZE(argvec);
if (count > MAX_ARGV)
scheme_raise_exn(MZEXN_FAIL,
"read-image-from-file: too many string arguments; "
"maximum is %d", MAX_ARGV);
l = 0;
a = SCHEME_VEC_ELS(argvec);
for (i = count; i--; ) {
l += SCHEME_STRTAG_VAL(a[i]);
}
a = NULL;
if (l > MAX_ARGLEN)
scheme_raise_exn(MZEXN_FAIL,
"read-image-from-file: string arguments too long; "
"maximum total length is %d", MAX_ARGLEN);
s = argspace;
for (i = 0; i < count; i++) {
l = SCHEME_STRTAG_VAL(a[i]);
memcpy(s, SCHEME_STR_VAL(a[i]), l + 1);
argv[i] = s;
s += l + 1;
}
restore_image(filename, count, argv, restore_launch_ubuf, read_image_exn);
return NULL;
}
#ifdef SOLARIS_SKIP_PLT
#include <sys/link.h>
unsigned long plt_start, plt_end;
void find_plt()
{
extern Elf32_Dyn _DYNAMIC;
Elf32_Dyn *dp;
int tag;
for (dp = ((Elf32_Dyn *)(&_DYNAMIC)); (tag = dp->d_tag) != DT_NULL; dp++) {
if (tag == DT_PLTGOT) {
plt_start = (unsigned long)dp->d_un.d_val;
} else if (tag == DT_PLTRELSZ) {
plt_end = (unsigned long)dp->d_un.d_val;
}
}
plt_end += plt_start;
}
#endif
#ifdef FREEBSD_SKIP_PLT
#include <sys/types.h>
#include <nlist.h>
#include <link.h>
static unsigned long plt_start, plt_end;
extern struct _dynamic _DYNAMIC;
void find_plt()
{
plt_start = _DYNAMIC.d_un.d_sdt->sdt_plt;
plt_end = plt_start + _DYNAMIC.d_un.d_sdt->sdt_plt_sz;
}
#endif
int scheme_image_main(int argc, char **argv)
{
Scheme_Jumpup_Buf *buf;
data_count = 1;
data_starts = malloc(sizeof(unsigned long));
data_ends = malloc(sizeof(unsigned long));
stack_base = (unsigned long)GC_get_stack_base();
data_starts[0] = (unsigned long)DATASTART;
data_ends[0] = (unsigned long)DATAEND;
orig_brk = data_ends[0];
#if defined(SOLARIS_SKIP_PLT) || defined(FREEBSD_SKIP_PLT)
{
unsigned long ds, de;
ds = data_starts[0];
de = data_ends[0];
data_starts = malloc(2 * sizeof(unsigned long));
data_ends = malloc(2 * sizeof(unsigned long));
data_count = 2;
find_plt();
data_starts[0] = ds;
data_ends[0] = plt_start;
data_starts[1] = plt_end;
data_ends[1] = de;
}
#endif
scheme_dump_heap = dump_image;
scheme_load_heap = load_image;
#ifdef FIND_WRITEABLE_SECTION
/* Find writeable section of text segment: */
{
unsigned long ds;
MZ_SIGSET(SIGBUS, bus_error);
MZ_SIGSET(SIGSEGV, bus_error);
ds = data_starts[0];
if (!scheme_setjmp(goback)) {
for (current_value = data_ends[0]; (current_value -= sizeof(long)) > ds; ) {
*(unsigned long *)current_value = *(unsigned long *)current_value;
}
}
data_starts[0] = current_value + sizeof(long);
MZ_SIGSET(SIGBUS, SIG_DFL);
MZ_SIGSET(SIGSEGV, SIG_DFL);
}
#endif
if ((argc > 1) && (!strcmp(argv[1], "--restore")
|| !scheme_strncmp(argv[1], "-R", 2))) {
char *file, *exfile;
int startargs;
if (argv[1][1] == 'R') {
file = argv[1] + 2;
if (!*file) {
printf("%s: Missing file name for -R.\n", argv[0]);
printf("Use the --help or -h flag for help.\n");
return -1;
}
startargs = 2;
} else if (argc < 3) {
printf("%s: Missing file name for --restore.\n", argv[0]);
printf("Use the --help or -h flag for help.\n");
return -1;
} else {
file = argv[2];
startargs = 3;
}
exfile = file; /* scheme_expand_filename(file, strlen(file), NULL, NULL); */
if (!exfile)
die_now("bad filename", file);
restore_image(exfile, argc - startargs, argv + startargs, &buf, die_now);
die_now("stack jump", file);
}
restore_launch_ubuf = &buf;
{
/* Make a copy of argv so that it's definitely in the normal heap: */
char **naya_argv;
int i;
naya_argv = scheme_malloc(argc * sizeof(char *));
for (i = 0; i < argc; i++) {
naya_argv[i] = scheme_strdup(argv[i]);
}
/* doesn't support atexit(): */
_exit(scheme_actual_main(argc, naya_argv));
}
return -1;
}
#endif
/******************************************************************************/
#ifndef UNIX_IMAGE_DUMPS
int scheme_image_main(int argc, char **argv)
{
return scheme_actual_main(argc, argv);
}
#endif
void scheme_no_dumps(char *why)
{
}

30
src/mzscheme/src/jit.c
View File

@ -1448,7 +1448,8 @@ static int generate_direct_prim_non_tail_call(mz_jit_state *jitter, int num_rand
static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok, GC_CAN_IGNORE jit_insn *reftop)
/* If num_rands < 0, original argc is in V1, and we should
pop argc arguments off runstack before pushing more. */
pop argc arguments off runstack before pushing more.
This function is called with short jumps enabled. */
{
GC_CAN_IGNORE jit_insn *ref, *ref2, *refloop;
@ -1493,7 +1494,9 @@ static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok
mz_patch_branch(ref2);
jit_ldxi_l(JIT_V1, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_rator);
jit_ldxi_l(JIT_R0, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_num_rands);
__END_SHORT_JUMPS__(1);
(void)jit_jmpi(reftop);
__START_SHORT_JUMPS__(1);
/* Slow path; restore R0 to SCHEME_TAIL_CALL_WAITING */
mz_patch_branch(ref);
@ -2802,6 +2805,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
if (!i) {
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
reffail = _jit.x.pc;
__END_SHORT_JUMPS__(1);
if (steps == 1) {
if (name[1] == 'a') {
(void)jit_jmpi(bad_car_code);
@ -2823,6 +2827,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
}
}
}
__START_SHORT_JUMPS__(1);
mz_patch_branch(ref);
} else {
(void)jit_bmsi_ul(reffail, JIT_R0, 0x1);
@ -2955,17 +2960,19 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
CHECK_LIMIT();
__START_SHORT_JUMPS__(branch_short);
if (!SCHEME_CHARP(r1)) {
GC_CAN_IGNORE jit_insn *pref;
pref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
reffail = _jit.x.pc;
(void)jit_movi_p(JIT_R2, ((Scheme_Primitive_Proc *)rator)->prim_val);
__END_SHORT_JUMPS__(branch_short);
if (direction > 0) {
(void)jit_jmpi(call_original_binary_rev_arith_code);
} else {
(void)jit_jmpi(call_original_binary_arith_code);
}
__START_SHORT_JUMPS__(branch_short);
mz_patch_branch(pref);
jit_ldxi_s(JIT_R2, JIT_R0, (int)&((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(reffail, JIT_R2, scheme_char_type);
@ -2980,11 +2987,13 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
pref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1);
reffail = _jit.x.pc;
(void)jit_movi_p(JIT_R2, ((Scheme_Primitive_Proc *)rator)->prim_val);
__END_SHORT_JUMPS__(branch_short);
if (direction > 0) {
(void)jit_jmpi(call_original_binary_rev_arith_code);
} else {
(void)jit_jmpi(call_original_binary_arith_code);
}
__START_SHORT_JUMPS__(branch_short);
mz_patch_branch(pref);
} else {
(void)jit_bmsi_ul(reffail, JIT_R1, 0x1);
@ -3939,16 +3948,20 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
/* R0 is space left (in bytes), R2 is argc */
jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE);
if (is_tail) {
__END_SHORT_JUMPS__(1);
(void)jit_bltr_ul(app_values_tail_slow_code, JIT_R0, JIT_R2);
__START_SHORT_JUMPS__(1);
ref5 = 0;
} else {
GC_CAN_IGNORE jit_insn *refok;
refok = jit_bger_ul(jit_forward(), JIT_R0, JIT_R2);
__END_SHORT_JUMPS__(1);
if (multi_ok) {
(void)jit_calli(app_values_multi_slow_code);
} else {
(void)jit_calli(app_values_slow_code);
}
__START_SHORT_JUMPS__(1);
ref5 = jit_jmpi(jit_forward());
mz_patch_branch(refok);
}
@ -4965,13 +4978,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
jit_addr_p(JIT_RUNSTACK_BASE, JIT_RUNSTACK_BASE, JIT_RUNSTACK);
jit_jmpr(JIT_V1);
CHECK_LIMIT();
/* Slower path (non-tail) when argv != runstack. To simulate
a tail call, we must decrement the cont-mark pos. */
/* Slower path (non-tail) when argv != runstack. */
mz_patch_branch(ref);
mz_patch_branch(ref2);
jit_ldi_l(JIT_V1, &scheme_current_cont_mark_pos);
jit_subi_l(JIT_V1, JIT_V1, 2);
jit_sti_l(&scheme_current_cont_mark_pos, JIT_V1);
CHECK_LIMIT();
mz_prepare(3);
jit_pusharg_p(JIT_R2);
@ -4979,9 +4988,6 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
jit_pusharg_p(JIT_R0);
(void)mz_finish(_scheme_apply_multi_from_native);
CHECK_LIMIT();
jit_ldi_l(JIT_NOT_RET, &scheme_current_cont_mark_pos);
jit_addi_l(JIT_NOT_RET, JIT_NOT_RET, 2);
jit_sti_l(&scheme_current_cont_mark_pos, JIT_NOT_RET);
mz_get_local_p(JIT_NOT_RET, JIT_LOCAL1);
mz_pop_locals();
jit_ret();
@ -6251,9 +6257,7 @@ Scheme_Object *scheme_native_stack_trace(void)
stack_end -= (RETURN_ADDRESS_OFFSET << JIT_LOG_WORD_SIZE);
tail = stack_cache_stack[stack_cache_stack_pos].cache;
} else {
stack_end = (unsigned long)(scheme_current_thread->next
? scheme_current_thread->stack_start
: scheme_current_thread->o_start);
stack_end = (unsigned long)ADJUST_STACK_START(scheme_current_thread->stack_start);
tail = scheme_null;
}

16
src/mzscheme/src/lightning/ppc/asm.h
View File

@ -352,19 +352,31 @@ typedef unsigned int jit_insn;
#define CLRRWIrri(RA,RS,N) RLWINMrriii(RA, RS, 0, 0, 31-(N))
#define CLRLSLWIrrii(RA,RS,B,N) RLWINMrriii(RA, RS, N, (B)-(N), 31-(N))
#if 0
static int bad_short_jump()
{
scheme_signal_error("bad short jump");
return 1;
}
# define NOT_SHORT_JUMPS() (_jitl.long_jumps ? 0 : bad_short_jump()) ,
#else
# define NOT_SHORT_JUMPS() /* empty */
#endif
/* 9 below inverts the branch condition and the branch prediction.
* This has an incestuous knowledge of JIT_AUX */
#define BC_EXT(A, C, D) ((_siP(16, _jit_UL(D)-_jit_UL(_jit.x.pc)) && !_jitl.long_jumps) \
? BCiii((A), (C), (D)) \
: (BCiii((A)^9, (C), _jit.x.pc+5), \
: (NOT_SHORT_JUMPS() \
BCiii((A)^9, (C), _jit.x.pc+5), \
LISri(JIT_AUX,_HI(D)), \
ORIrri(JIT_AUX,JIT_AUX,_LO(D)), \
MTLRr(JIT_AUX), BLR() ))
#define B_EXT(D) ((_siP(16, _jit_UL(D)-_jit_UL(_jit.x.pc)) && !_jitl.long_jumps) \
? Bi((D)) \
: (LISri(JIT_AUX,_HI(D)), \
: (NOT_SHORT_JUMPS() \
LISri(JIT_AUX,_HI(D)), \
ORIrri(JIT_AUX,JIT_AUX,_LO(D)), \
MTLRr(JIT_AUX), BLR()) )

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

@ -882,14 +882,13 @@ static int cont_proc_MARK(void *p) {
Scheme_Cont *c = (Scheme_Cont *)p;
gcMARK(c->dw);
gcMARK(c->common);
gcMARK(c->ok);
gcMARK(c->prompt_tag);
gcMARK(c->meta_continuation);
gcMARK(c->save_overflow);
gcMARK(c->runstack_copied);
gcMARK(c->runstack_owner);
gcMARK(c->cont_mark_stack_copied);
gcMARK(c->cont_mark_stack_owner);
gcMARK(c->orig_mark_segments);
gcMARK(c->init_config);
gcMARK(c->init_break_cell);
#ifdef MZ_USE_JIT
@ -899,6 +898,15 @@ static int cont_proc_MARK(void *p) {
MARK_jmpup(&c->buf);
MARK_cjs(&c->cjs);
MARK_stack_state(&c->ss);
gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
/* These shouldn't actually persist across a GC, but
just in case... */
gcMARK(c->value);
gcMARK(c->resume_to);
gcMARK(c->use_next_cont);
gcMARK(c->extra_marks);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
@ -908,14 +916,13 @@ static int cont_proc_FIXUP(void *p) {
Scheme_Cont *c = (Scheme_Cont *)p;
gcFIXUP(c->dw);
gcFIXUP(c->common);
gcFIXUP(c->ok);
gcFIXUP(c->prompt_tag);
gcFIXUP(c->meta_continuation);
gcFIXUP(c->save_overflow);
gcFIXUP(c->runstack_copied);
gcFIXUP(c->runstack_owner);
gcFIXUP(c->cont_mark_stack_copied);
gcFIXUP(c->cont_mark_stack_owner);
gcFIXUP(c->orig_mark_segments);
gcFIXUP(c->init_config);
gcFIXUP(c->init_break_cell);
#ifdef MZ_USE_JIT
@ -925,6 +932,15 @@ static int cont_proc_FIXUP(void *p) {
FIXUP_jmpup(&c->buf);
FIXUP_cjs(&c->cjs);
FIXUP_stack_state(&c->ss);
gcFIXUP(c->runstack_start);
gcFIXUP(c->runstack_saved);
/* These shouldn't actually persist across a GC, but
just in case... */
gcFIXUP(c->value);
gcFIXUP(c->resume_to);
gcFIXUP(c->use_next_cont);
gcFIXUP(c->extra_marks);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
@ -934,6 +950,39 @@ static int cont_proc_FIXUP(void *p) {
#define cont_proc_IS_CONST_SIZE 1
static int meta_cont_proc_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Meta_Continuation));
}
static int meta_cont_proc_MARK(void *p) {
Scheme_Meta_Continuation *c = (Scheme_Meta_Continuation *)p;
gcMARK(c->prompt_tag);
gcMARK(c->overflow);
gcMARK(c->next);
gcMARK(c->cont_mark_stack_copied);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Meta_Continuation));
}
static int meta_cont_proc_FIXUP(void *p) {
Scheme_Meta_Continuation *c = (Scheme_Meta_Continuation *)p;
gcFIXUP(c->prompt_tag);
gcFIXUP(c->overflow);
gcFIXUP(c->next);
gcFIXUP(c->cont_mark_stack_copied);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Meta_Continuation));
}
#define meta_cont_proc_IS_ATOMIC 0
#define meta_cont_proc_IS_CONST_SIZE 1
static int mark_dyn_wind_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Dynamic_Wind));
@ -942,8 +991,9 @@ static int mark_dyn_wind_SIZE(void *p) {
static int mark_dyn_wind_MARK(void *p) {
Scheme_Dynamic_Wind *dw = (Scheme_Dynamic_Wind *)p;
gcMARK(dw->id);
gcMARK(dw->data);
gcMARK(dw->cont);
gcMARK(dw->prompt_tag);
gcMARK(dw->prev);
MARK_stack_state(&dw->envss);
@ -955,8 +1005,9 @@ static int mark_dyn_wind_MARK(void *p) {
static int mark_dyn_wind_FIXUP(void *p) {
Scheme_Dynamic_Wind *dw = (Scheme_Dynamic_Wind *)p;
gcFIXUP(dw->id);
gcFIXUP(dw->data);
gcFIXUP(dw->cont);
gcFIXUP(dw->prompt_tag);
gcFIXUP(dw->prev);
FIXUP_stack_state(&dw->envss);
@ -978,7 +1029,8 @@ static int mark_overflow_MARK(void *p) {
Scheme_Overflow *o = (Scheme_Overflow *)p;
gcMARK(o->prev);
MARK_jmpup(&o->cont);
gcMARK(o->jmp);
gcMARK(o->id);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Overflow));
@ -988,7 +1040,8 @@ static int mark_overflow_FIXUP(void *p) {
Scheme_Overflow *o = (Scheme_Overflow *)p;
gcFIXUP(o->prev);
FIXUP_jmpup(&o->cont);
gcFIXUP(o->jmp);
gcFIXUP(o->id);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Overflow));
@ -998,6 +1051,33 @@ static int mark_overflow_FIXUP(void *p) {
#define mark_overflow_IS_CONST_SIZE 1
static int mark_overflow_jmp_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Overflow_Jmp));
}
static int mark_overflow_jmp_MARK(void *p) {
Scheme_Overflow_Jmp *o = (Scheme_Overflow_Jmp *)p;
MARK_jmpup(&o->cont);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Overflow_Jmp));
}
static int mark_overflow_jmp_FIXUP(void *p) {
Scheme_Overflow_Jmp *o = (Scheme_Overflow_Jmp *)p;
FIXUP_jmpup(&o->cont);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Overflow_Jmp));
}
#define mark_overflow_jmp_IS_ATOMIC 0
#define mark_overflow_jmp_IS_CONST_SIZE 1
static int escaping_cont_proc_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Escaping_Cont));
@ -1006,13 +1086,10 @@ static int escaping_cont_proc_SIZE(void *p) {
static int escaping_cont_proc_MARK(void *p) {
Scheme_Escaping_Cont *c = (Scheme_Escaping_Cont *)p;
gcMARK(c->mark_key);
gcMARK(c->marks_prefix);
#ifdef MZ_USE_JIT
gcMARK(c->native_trace);
#endif
MARK_cjs(&c->cjs);
MARK_stack_state(&c->envss);
return
@ -1022,13 +1099,10 @@ static int escaping_cont_proc_MARK(void *p) {
static int escaping_cont_proc_FIXUP(void *p) {
Scheme_Escaping_Cont *c = (Scheme_Escaping_Cont *)p;
gcFIXUP(c->mark_key);
gcFIXUP(c->marks_prefix);
#ifdef MZ_USE_JIT
gcFIXUP(c->native_trace);
#endif
FIXUP_cjs(&c->cjs);
FIXUP_stack_state(&c->envss);
return
@ -1486,8 +1560,6 @@ static int thread_val_MARK(void *p) {
MARK_cjs(&pr->cjs);
gcMARK(pr->current_escape_cont_key);
gcMARK(pr->cell_values);
gcMARK(pr->init_config);
gcMARK(pr->init_break_cell);
@ -1501,14 +1573,17 @@ static int thread_val_MARK(void *p) {
gcMARK(pr->runstack_owner);
gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcMARK(pr->barrier_prompt);
gcMARK(pr->meta_prompt);
gcMARK(pr->meta_continuation);
gcMARK(pr->cont_mark_stack_segments);
gcMARK(pr->cont_mark_stack_owner);
gcMARK(pr->cont_mark_stack_swapped);
MARK_jmpup(&pr->jmpup_buf);
gcMARK(pr->cc_ok);
gcMARK(pr->dw);
gcMARK(pr->nester);
@ -1575,8 +1650,6 @@ static int thread_val_FIXUP(void *p) {
FIXUP_cjs(&pr->cjs);
gcFIXUP(pr->current_escape_cont_key);
gcFIXUP(pr->cell_values);
gcFIXUP(pr->init_config);
gcFIXUP(pr->init_break_cell);
@ -1590,14 +1663,17 @@ static int thread_val_FIXUP(void *p) {
gcFIXUP(pr->runstack_owner);
gcFIXUP(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcFIXUP(pr->barrier_prompt);
gcFIXUP(pr->meta_prompt);
gcFIXUP(pr->meta_continuation);
gcFIXUP(pr->cont_mark_stack_segments);
gcFIXUP(pr->cont_mark_stack_owner);
gcFIXUP(pr->cont_mark_stack_swapped);
FIXUP_jmpup(&pr->jmpup_buf);
gcFIXUP(pr->cc_ok);
gcFIXUP(pr->dw);
gcFIXUP(pr->nester);
@ -1656,6 +1732,33 @@ static int thread_val_FIXUP(void *p) {
#define thread_val_IS_CONST_SIZE 1
static int prompt_val_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
}
static int prompt_val_MARK(void *p) {
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcMARK(pr->boundary_overflow_id);
gcMARK(pr->boundary_dw_id);
gcMARK(pr->runstack_boundary_start);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
}
static int prompt_val_FIXUP(void *p) {
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcFIXUP(pr->boundary_overflow_id);
gcFIXUP(pr->boundary_dw_id);
gcFIXUP(pr->runstack_boundary_start);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
}
#define prompt_val_IS_ATOMIC 0
#define prompt_val_IS_CONST_SIZE 1
static int cont_mark_set_val_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cont_Mark_Set));
@ -2256,6 +2359,7 @@ static int guard_val_MARK(void *p) {
gcMARK(g->parent);
gcMARK(g->file_proc);
gcMARK(g->network_proc);
gcMARK(g->link_proc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Security_Guard));
}
@ -2266,6 +2370,7 @@ static int guard_val_FIXUP(void *p) {
gcFIXUP(g->parent);
gcFIXUP(g->file_proc);
gcFIXUP(g->network_proc);
gcFIXUP(g->link_proc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Security_Guard));
}
@ -2546,24 +2651,20 @@ static int mark_saved_stack_SIZE(void *p) {
}
static int mark_saved_stack_MARK(void *p) {
Scheme_Saved_Stack *saved = (Scheme_Saved_Stack *) p;
Scheme_Object **old = saved->runstack_start;
Scheme_Saved_Stack *saved = (Scheme_Saved_Stack *)p;
gcMARK(saved->prev);
gcMARK( saved->runstack_start);
saved->runstack = saved->runstack_start + (saved->runstack - old);
gcMARK(saved->runstack_start);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Saved_Stack));
}
static int mark_saved_stack_FIXUP(void *p) {
Scheme_Saved_Stack *saved = (Scheme_Saved_Stack *) p;
Scheme_Object **old = saved->runstack_start;
Scheme_Saved_Stack *saved = (Scheme_Saved_Stack *)p;
gcFIXUP(saved->prev);
gcFIXUP_TYPED_NOW(Scheme_Object **, saved->runstack_start);
saved->runstack = saved->runstack_start + (saved->runstack - old);
gcFIXUP(saved->runstack_start);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Saved_Stack));

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

@ -329,14 +329,13 @@ cont_proc {
Scheme_Cont *c = (Scheme_Cont *)p;
gcMARK(c->dw);
gcMARK(c->common);
gcMARK(c->ok);
gcMARK(c->prompt_tag);
gcMARK(c->meta_continuation);
gcMARK(c->save_overflow);
gcMARK(c->runstack_copied);
gcMARK(c->runstack_owner);
gcMARK(c->cont_mark_stack_copied);
gcMARK(c->cont_mark_stack_owner);
gcMARK(c->orig_mark_segments);
gcMARK(c->init_config);
gcMARK(c->init_break_cell);
#ifdef MZ_USE_JIT
@ -346,17 +345,40 @@ cont_proc {
MARK_jmpup(&c->buf);
MARK_cjs(&c->cjs);
MARK_stack_state(&c->ss);
gcMARK(c->runstack_start);
gcMARK(c->runstack_saved);
/* These shouldn't actually persist across a GC, but
just in case... */
gcMARK(c->value);
gcMARK(c->resume_to);
gcMARK(c->use_next_cont);
gcMARK(c->extra_marks);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
}
meta_cont_proc {
mark:
Scheme_Meta_Continuation *c = (Scheme_Meta_Continuation *)p;
gcMARK(c->prompt_tag);
gcMARK(c->overflow);
gcMARK(c->next);
gcMARK(c->cont_mark_stack_copied);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Meta_Continuation));
}
mark_dyn_wind {
mark:
Scheme_Dynamic_Wind *dw = (Scheme_Dynamic_Wind *)p;
gcMARK(dw->id);
gcMARK(dw->data);
gcMARK(dw->cont);
gcMARK(dw->prompt_tag);
gcMARK(dw->prev);
MARK_stack_state(&dw->envss);
@ -370,23 +392,31 @@ mark_overflow {
Scheme_Overflow *o = (Scheme_Overflow *)p;
gcMARK(o->prev);
MARK_jmpup(&o->cont);
gcMARK(o->jmp);
gcMARK(o->id);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Overflow));
}
mark_overflow_jmp {
mark:
Scheme_Overflow_Jmp *o = (Scheme_Overflow_Jmp *)p;
MARK_jmpup(&o->cont);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Overflow_Jmp));
}
escaping_cont_proc {
mark:
Scheme_Escaping_Cont *c = (Scheme_Escaping_Cont *)p;
gcMARK(c->mark_key);
gcMARK(c->marks_prefix);
#ifdef MZ_USE_JIT
gcMARK(c->native_trace);
#endif
MARK_cjs(&c->cjs);
MARK_stack_state(&c->envss);
size:
@ -566,8 +596,6 @@ thread_val {
MARK_cjs(&pr->cjs);
gcMARK(pr->current_escape_cont_key);
gcMARK(pr->cell_values);
gcMARK(pr->init_config);
gcMARK(pr->init_break_cell);
@ -581,14 +609,17 @@ thread_val {
gcMARK(pr->runstack_owner);
gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcMARK(pr->barrier_prompt);
gcMARK(pr->meta_prompt);
gcMARK(pr->meta_continuation);
gcMARK(pr->cont_mark_stack_segments);
gcMARK(pr->cont_mark_stack_owner);
gcMARK(pr->cont_mark_stack_swapped);
MARK_jmpup(&pr->jmpup_buf);
gcMARK(pr->cc_ok);
gcMARK(pr->dw);
gcMARK(pr->nester);
@ -643,6 +674,16 @@ thread_val {
gcBYTES_TO_WORDS(sizeof(Scheme_Thread));
}
prompt_val {
mark:
Scheme_Prompt *pr = (Scheme_Prompt *)p;
gcMARK(pr->boundary_overflow_id);
gcMARK(pr->boundary_dw_id);
gcMARK(pr->runstack_boundary_start);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
}
cont_mark_set_val {
mark:
Scheme_Cont_Mark_Set *s = (Scheme_Cont_Mark_Set *)p;
@ -885,6 +926,7 @@ guard_val {
gcMARK(g->parent);
gcMARK(g->file_proc);
gcMARK(g->network_proc);
gcMARK(g->link_proc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Security_Guard));
}
@ -1006,12 +1048,10 @@ mark_comp_info {
mark_saved_stack {
mark:
Scheme_Saved_Stack *saved = (Scheme_Saved_Stack *) p;
Scheme_Object **old = saved->runstack_start;
Scheme_Saved_Stack *saved = (Scheme_Saved_Stack *)p;
gcMARK(saved->prev);
gcFIXUP_TYPED_NOW(Scheme_Object **, saved->runstack_start);
saved->runstack = saved->runstack_start + (saved->runstack - old);
gcMARK(saved->runstack_start);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Saved_Stack));

12
src/mzscheme/src/print.c
View File

@ -1849,7 +1849,17 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_utf8_string(pp, ">", 0, 1);
}
}
else if (SCHEME_CPTRP(obj))
else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_prompt_tag_type)
&& SCHEME_CDR(obj) && !(compact || !pp->print_unreadable))
{
print_utf8_string(pp, "#<", 0, 2);
print_string_in_angle(pp, scheme_symbol_val(SCHEME_CDR(obj)),
"continuation-prompt-tag:",
SCHEME_SYM_LEN(SCHEME_CDR(obj)));
PRINTADDRESS(pp, obj);
print_utf8_string(pp, ">", 0, 1);
}
else if (SCHEME_CPTRP(obj))
{
Scheme_Object *tag = SCHEME_CPTR_TYPE(obj);
if (compact || !pp->print_unreadable) {

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

@ -1831,11 +1831,6 @@ long scheme_count_memory(Scheme_Object *root, Scheme_Hash_Table *ht)
for (rs = c->runstack_copied; rs; rs = rs->prev) {
s += sizeof(Scheme_Saved_Stack);
scheme_count_closure(rs->runstack,
rs->runstack_size
- (rs->runstack
- rs->runstack_start),
ht);
}
}
break;
@ -1894,18 +1889,8 @@ long scheme_count_memory(Scheme_Object *root, Scheme_Hash_Table *ht)
#endif
/* Check stack: */
scheme_count_closure(p->runstack, /* p->runstack may be wrong, but count_closure is turned off */
p->runstack_size
- (p->runstack
- p->runstack_start),
ht);
for (saved = p->runstack_saved; saved; saved = saved->prev) {
s += (saved->runstack_size * sizeof(Scheme_Object *));
scheme_count_closure(saved->runstack,
saved->runstack_size
- (saved->runstack
- saved->runstack_start),
ht);
}
}
break;

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

@ -279,15 +279,18 @@ MZ_EXTERN void scheme_set_tail_buffer_size(int s);
MZ_EXTERN Scheme_Object *scheme_force_value(Scheme_Object *);
MZ_EXTERN Scheme_Object *scheme_force_one_value(Scheme_Object *);
MZ_EXTERN void *scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN MZ_MARK_STACK_TYPE scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN void scheme_push_continuation_frame(Scheme_Cont_Frame_Data *);
MZ_EXTERN void scheme_pop_continuation_frame(Scheme_Cont_Frame_Data *);
MZ_EXTERN void scheme_temp_dec_mark_depth();
MZ_EXTERN void scheme_temp_inc_mark_depth();
MZ_EXTERN Scheme_Object *scheme_current_continuation_marks(void);
MZ_EXTERN Scheme_Object *scheme_current_continuation_marks(Scheme_Object *prompt_tag);
MZ_EXTERN Scheme_Object *scheme_extract_one_cc_mark(Scheme_Object *mark_set,
Scheme_Object *key);
MZ_EXTERN Scheme_Object *scheme_extract_one_cc_mark_to_tag(Scheme_Object *mark_set,
Scheme_Object *key,
Scheme_Object *prompt_tag);
/* Internal */
MZ_EXTERN Scheme_Object *scheme_do_eval(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val);
@ -795,6 +798,7 @@ MZ_EXTERN void scheme_add_fd_handle(void *h, void *fds, int repost);
MZ_EXTERN void scheme_add_fd_eventmask(void *fds, int mask);
MZ_EXTERN void scheme_security_check_file(const char *who, const char *filename, int guards);
MZ_EXTERN void scheme_security_check_file_link(const char *who, const char *filename, const char *content);
MZ_EXTERN void scheme_security_check_network(const char *who, const char *host, int port, int client);
MZ_EXTERN struct mz_addrinfo *scheme_get_host_address(const char *address, int id, int *err,

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

@ -223,14 +223,17 @@ Scheme_Object *(*scheme_tail_eval_expr)(Scheme_Object *obj);
void (*scheme_set_tail_buffer_size)(int s);
Scheme_Object *(*scheme_force_value)(Scheme_Object *);
Scheme_Object *(*scheme_force_one_value)(Scheme_Object *);
void *(*scheme_set_cont_mark)(Scheme_Object *key, Scheme_Object *val);
MZ_MARK_STACK_TYPE (*scheme_set_cont_mark)(Scheme_Object *key, Scheme_Object *val);
void (*scheme_push_continuation_frame)(Scheme_Cont_Frame_Data *);
void (*scheme_pop_continuation_frame)(Scheme_Cont_Frame_Data *);
void (*scheme_temp_dec_mark_depth)();
void (*scheme_temp_inc_mark_depth)();
Scheme_Object *(*scheme_current_continuation_marks)(void);
Scheme_Object *(*scheme_current_continuation_marks)(Scheme_Object *prompt_tag);
Scheme_Object *(*scheme_extract_one_cc_mark)(Scheme_Object *mark_set,
Scheme_Object *key);
Scheme_Object *(*scheme_extract_one_cc_mark_to_tag)(Scheme_Object *mark_set,
Scheme_Object *key,
Scheme_Object *prompt_tag);
/* Internal */
Scheme_Object *(*scheme_do_eval)(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val);
Scheme_Object *(*scheme_eval_compiled_stx_string)(Scheme_Object *expr, Scheme_Env *env,
@ -663,6 +666,7 @@ int (*scheme_fdisset)(void *fd, int pos);
void (*scheme_add_fd_handle)(void *h, void *fds, int repost);
void (*scheme_add_fd_eventmask)(void *fds, int mask);
void (*scheme_security_check_file)(const char *who, const char *filename, int guards);
void (*scheme_security_check_file_link)(const char *who, const char *filename, const char *content);
void (*scheme_security_check_network)(const char *who, const char *host, int port, int client);
struct mz_addrinfo *(*scheme_get_host_address)(const char *address, int id, int *err,
int family, int passive, int tcp);

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

@ -146,6 +146,7 @@
scheme_extension_table->scheme_temp_inc_mark_depth = scheme_temp_inc_mark_depth;
scheme_extension_table->scheme_current_continuation_marks = scheme_current_continuation_marks;
scheme_extension_table->scheme_extract_one_cc_mark = scheme_extract_one_cc_mark;
scheme_extension_table->scheme_extract_one_cc_mark_to_tag = scheme_extract_one_cc_mark_to_tag;
scheme_extension_table->scheme_do_eval = scheme_do_eval;
scheme_extension_table->scheme_eval_compiled_stx_string = scheme_eval_compiled_stx_string;
scheme_extension_table->scheme_load_compiled_stx_string = scheme_load_compiled_stx_string;
@ -445,6 +446,7 @@
scheme_extension_table->scheme_add_fd_handle = scheme_add_fd_handle;
scheme_extension_table->scheme_add_fd_eventmask = scheme_add_fd_eventmask;
scheme_extension_table->scheme_security_check_file = scheme_security_check_file;
scheme_extension_table->scheme_security_check_file_link = scheme_security_check_file_link;
scheme_extension_table->scheme_security_check_network = scheme_security_check_network;
scheme_extension_table->scheme_get_host_address = scheme_get_host_address;
scheme_extension_table->scheme_free_host_address = scheme_free_host_address;

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

@ -146,6 +146,7 @@
#define scheme_temp_inc_mark_depth (scheme_extension_table->scheme_temp_inc_mark_depth)
#define scheme_current_continuation_marks (scheme_extension_table->scheme_current_continuation_marks)
#define scheme_extract_one_cc_mark (scheme_extension_table->scheme_extract_one_cc_mark)
#define scheme_extract_one_cc_mark_to_tag (scheme_extension_table->scheme_extract_one_cc_mark_to_tag)
#define scheme_do_eval (scheme_extension_table->scheme_do_eval)
#define scheme_eval_compiled_stx_string (scheme_extension_table->scheme_eval_compiled_stx_string)
#define scheme_load_compiled_stx_string (scheme_extension_table->scheme_load_compiled_stx_string)
@ -445,6 +446,7 @@
#define scheme_add_fd_handle (scheme_extension_table->scheme_add_fd_handle)
#define scheme_add_fd_eventmask (scheme_extension_table->scheme_add_fd_eventmask)
#define scheme_security_check_file (scheme_extension_table->scheme_security_check_file)
#define scheme_security_check_file_link (scheme_extension_table->scheme_security_check_file_link)
#define scheme_security_check_network (scheme_extension_table->scheme_security_check_network)
#define scheme_get_host_address (scheme_extension_table->scheme_get_host_address)
#define scheme_free_host_address (scheme_extension_table->scheme_free_host_address)

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 871
#define EXPECTED_PRIM_COUNT 875
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

26
src/mzscheme/src/schnapp.inc
View File

@ -1,10 +1,15 @@
/* For non-tail calls, the native context has already
incremented MZ_CONT_MARK_POS. Counter
scheme_do_eval()'s increment, because this
might be the continuation of a tail call. */
if (!SCHEME_INTP(rator)) {
Scheme_Type t;
t = _SCHEME_TYPE(rator);
if (t == scheme_prim_type) {
Scheme_Object *v;
GC_CAN_IGNORE Scheme_Object *v;
GC_CAN_IGNORE Scheme_Primitive_Proc *prim;
GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
@ -19,7 +24,8 @@
v = f(argc, argv, (Scheme_Object *)prim);
#if PRIM_CHECK_VALUE
v = _scheme_force_value(v);
if (v == SCHEME_TAIL_CALL_WAITING)
v = scheme_force_value_same_mark(v);
#endif
#if PRIM_CHECK_MULTI
@ -34,10 +40,22 @@
}
#if PRIM_CHECK_MULTI
return _scheme_apply(rator, argc, argv);
{
GC_CAN_IGNORE Scheme_Object *v;
MZ_CONT_MARK_POS -= 2;
v = _scheme_apply(rator, argc, argv);
MZ_CONT_MARK_POS += 2;
return v;
}
#else
# if PRIM_CHECK_VALUE
return _scheme_apply_multi(rator, argc, argv);
{
GC_CAN_IGNORE Scheme_Object *v;
MZ_CONT_MARK_POS -= 2;
v = _scheme_apply_multi(rator, argc, argv);
MZ_CONT_MARK_POS += 2;
return v;
}
# else
return _scheme_tail_apply(rator, argc, argv);
# endif

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

@ -130,6 +130,7 @@ extern int scheme_starting_up;
void scheme_init_portable_case(void);
void scheme_init_stack_check(void);
void scheme_init_overflow(void);
#ifdef MZ_PRECISE_GC
void scheme_register_traversers(void);
void scheme_init_hash_key_procs(void);
@ -169,7 +170,6 @@ void scheme_init_debug(Scheme_Env *env);
void scheme_init_thread(Scheme_Env *env);
void scheme_init_read(Scheme_Env *env);
void scheme_init_print(Scheme_Env *env);
void scheme_init_image(Scheme_Env *env);
#ifndef NO_SCHEME_THREADS
void scheme_init_sema(Scheme_Env *env);
#endif
@ -262,6 +262,8 @@ extern Scheme_Object *scheme_none_symbol, *scheme_line_symbol, *scheme_block_sym
extern Scheme_Object *scheme_stack_dump_key;
extern Scheme_Object *scheme_default_prompt_tag;
/*========================================================================*/
/* thread state and maintenance */
/*========================================================================*/
@ -358,6 +360,7 @@ typedef struct Scheme_Security_Guard {
struct Scheme_Security_Guard *parent;
Scheme_Object *file_proc; /* who-symbol path mode-symbol -> void */
Scheme_Object *network_proc; /* who-symbol host-string-or-'listen port-k -> void */
Scheme_Object *link_proc; /* who-symbol path path -> void */
} Scheme_Security_Guard;
/* Always allocated on the stack: */
@ -850,7 +853,20 @@ void scheme_clean_native_symtab(void);
Scheme_Object *scheme_handle_stack_overflow(Scheme_Object *(*k)(void));
void scheme_ensure_stack_start(Scheme_Thread *p, void *d);
extern struct Scheme_Overflow_Jmp *scheme_overflow_jmp;
extern void *scheme_overflow_stack_start;
void scheme_ensure_stack_start(void *d);
extern void *scheme_deepest_stack_start;
#ifdef MZ_PRECISE_GC
# define PROMPT_STACK(id) &__gc_var_stack__
# define ADJUST_STACK_START(start) (start)
#else
# define PROMPT_STACK(id) ((void *)(&id))
# define ADJUST_STACK_START(start) (start ? start : scheme_deepest_stack_start)
#endif
void scheme_jmpup_free(Scheme_Jumpup_Buf *);
void *scheme_enlarge_runstack(long size, void *(*k)());
int scheme_check_runstack(long size);
@ -883,7 +899,7 @@ void scheme_init_stack_limit (void);
typedef struct Scheme_Saved_Stack {
MZTAG_IF_REQUIRED
Scheme_Object **runstack_start;
Scheme_Object **runstack;
long runstack_offset;
long runstack_size;
struct Scheme_Saved_Stack *prev;
} Scheme_Saved_Stack;
@ -917,44 +933,54 @@ typedef struct Scheme_Cont_Mark_Set {
#define SCHEME_MARK_SEGMENT_MASK (SCHEME_MARK_SEGMENT_SIZE - 1)
typedef struct Scheme_Stack_State {
Scheme_Object **runstack;
Scheme_Object **runstack_start;
long runstack_size;
Scheme_Saved_Stack *runstack_saved;
long runstack_offset;
MZ_MARK_POS_TYPE cont_mark_pos;
MZ_MARK_STACK_TYPE cont_mark_stack;
Scheme_Object *current_escape_cont_key;
struct Scheme_Prompt *barrier_prompt;
} Scheme_Stack_State;
typedef struct Scheme_Dynamic_Wind {
MZTAG_IF_REQUIRED
int depth;
void *id; /* generated as needed */
void *data;
Scheme_Object *prompt_tag; /* If not NULL, indicates a fake D-W record for prompt boundary */
void (*pre)(void *);
void (*post)(void *);
mz_jmp_buf *saveerr;
int next_meta; /* amount to move forward in the meta-continuation chain */
struct Scheme_Stack_State envss;
struct Scheme_Cont *cont;
struct Scheme_Dynamic_Wind *prev;
} Scheme_Dynamic_Wind;
typedef struct Scheme_Cont {
Scheme_Object so;
short composable;
Scheme_Object *value; /* Set just before jump */
struct Scheme_Overflow *resume_to; /* Set just before jump */
struct Scheme_Cont *use_next_cont; /* Set just before jump */
int common_dw_depth; /* Set just before jump; id common dw record */
Scheme_Object *extra_marks; /* Set just before jump; vector extra keys and marks to add to meta-cont */
struct Scheme_Meta_Continuation *meta_continuation;
Scheme_Jumpup_Buf buf;
long *ok;
Scheme_Dynamic_Wind *dw, *common;
Scheme_Dynamic_Wind *dw;
Scheme_Continuation_Jump_State cjs;
mz_jmp_buf *save_overflow_buf;
int suspend_break;
Scheme_Stack_State ss;
Scheme_Object **runstack_start;
long runstack_size;
Scheme_Saved_Stack *runstack_saved;
Scheme_Object *prompt_tag;
int prompt_depth;
mz_jmp_buf *prompt_buf; /* needed for meta-prompt */
MZ_MARK_POS_TYPE meta_tail_pos; /* to recognize opportunity for meta-tail calls */
MZ_MARK_POS_TYPE cont_mark_pos_bottom; /* to splice cont mark values with meta-cont */
void *prompt_stack_start;
Scheme_Saved_Stack *runstack_copied;
Scheme_Thread **runstack_owner;
Scheme_Cont_Mark *cont_mark_stack_copied;
Scheme_Thread **cont_mark_stack_owner;
Scheme_Cont_Mark **orig_mark_segments;
long cont_mark_shareable, cont_mark_offset;
void *stack_start;
void *o_start;
Scheme_Config *init_config;
Scheme_Object *init_break_cell;
#ifdef MZ_USE_JIT
@ -966,15 +992,11 @@ typedef struct Scheme_Cont {
typedef struct Scheme_Escaping_Cont {
Scheme_Object so;
Scheme_Continuation_Jump_State cjs;
Scheme_Object *mark_key;
struct Scheme_Stack_State envss;
#ifdef MZ_USE_JIT
Scheme_Object *native_trace;
#endif
Scheme_Object *marks_prefix;
mz_jmp_buf *saveerr;
int suspend_break;
} Scheme_Escaping_Cont;
#define SCHEME_CONT_F(obj) (((Scheme_Escaping_Cont *)(obj))->f)
@ -982,15 +1004,13 @@ typedef struct Scheme_Escaping_Cont {
int scheme_escape_continuation_ok(Scheme_Object *);
#define scheme_save_env_stack_w_thread(ss, p) \
(ss.runstack = MZ_RUNSTACK, ss.runstack_start = MZ_RUNSTACK_START, \
(ss.runstack_offset = MZ_RUNSTACK - MZ_RUNSTACK_START, \
ss.cont_mark_stack = MZ_CONT_MARK_STACK, ss.cont_mark_pos = MZ_CONT_MARK_POS, \
ss.runstack_size = p->runstack_size, ss.runstack_saved = p->runstack_saved, \
ss.current_escape_cont_key = p->current_escape_cont_key)
ss.barrier_prompt = p->barrier_prompt)
#define scheme_restore_env_stack_w_thread(ss, p) \
(MZ_RUNSTACK = ss.runstack, MZ_RUNSTACK_START = ss.runstack_start, \
(MZ_RUNSTACK = MZ_RUNSTACK_START + ss.runstack_offset, \
MZ_CONT_MARK_STACK = ss.cont_mark_stack, MZ_CONT_MARK_POS = ss.cont_mark_pos, \
p->runstack_size = ss.runstack_size, p->runstack_saved = ss.runstack_saved, \
p->current_escape_cont_key = ss.current_escape_cont_key)
p->barrier_prompt = ss.barrier_prompt)
#define scheme_save_env_stack(ss) \
scheme_save_env_stack_w_thread(ss, scheme_current_thread)
#define scheme_restore_env_stack(ss) \
@ -998,12 +1018,20 @@ int scheme_escape_continuation_ok(Scheme_Object *);
void scheme_takeover_stacks(Scheme_Thread *p);
typedef struct Scheme_Overflow_Jmp {
MZTAG_IF_REQUIRED
char captured; /* set to 1 if possibly captured in a continuation */
Scheme_Jumpup_Buf cont; /* continuation after value obtained in overflowed */
mz_jmp_buf *savebuf; /* save old error buffer pointer here */
} Scheme_Overflow_Jmp;
typedef struct Scheme_Overflow {
MZTAG_IF_REQUIRED
Scheme_Jumpup_Buf cont; /* continuation after value obtained in overflowed */
char eot; /* set to 1 => pseudo-overflow: continuation is to exit the thread */
Scheme_Overflow_Jmp *jmp; /* overflow data, so it can be shared when an overflow chain is cloned; */
void *id; /* identity of overflow record; generated as needed, and often == jmp */
void *stack_start;
struct Scheme_Overflow *prev; /* old overflow info */
mz_jmp_buf *savebuf; /* save old error buffer pointer here */
int captured; /* set to 1 if possibly captured in a continuation */
} Scheme_Overflow;
#if defined(UNIX_FIND_STACK_BOUNDS) || defined(WINDOWS_FIND_STACK_BOUNDS) \
@ -1014,9 +1042,54 @@ typedef struct Scheme_Overflow {
extern unsigned long scheme_stack_boundary;
#endif
typedef struct Scheme_Meta_Continuation {
MZTAG_IF_REQUIRED
char pseudo; /* if set, don't treat it as a prompt */
char cm_caches; /* cached info in copied cm */
char cm_shared; /* cm is shared, so copy before setting cache entries */
int copy_after_captured; /* for mutating a meta-continuation in set_cont_stack_mark */
Scheme_Object *prompt_tag;
/* The C stack: */
Scheme_Overflow *overflow;
MZ_MARK_POS_TYPE meta_tail_pos; /* to recognize opportunity for meta-tail calls */
MZ_MARK_POS_TYPE cont_mark_pos_bottom; /* to splice cont mark values with meta-cont */
/* Cont mark info: */
MZ_MARK_STACK_TYPE cont_mark_stack;
MZ_MARK_POS_TYPE cont_mark_pos;
long cont_mark_shareable, cont_mark_offset;
Scheme_Cont_Mark *cont_mark_stack_copied;
/* Next: */
struct Scheme_Meta_Continuation *next;
} Scheme_Meta_Continuation;
typedef struct Scheme_Prompt {
Scheme_Object so;
char is_barrier, is_captured;
int depth;
void *stack_boundary; /* where to stop copying the C stack */
void *boundary_overflow_id; /* indicates the C stack segment */
MZ_MARK_STACK_TYPE mark_boundary; /* where to stop copying cont marks */
MZ_MARK_POS_TYPE boundary_mark_pos; /* mark position of prompt */
Scheme_Object **runstack_boundary_start; /* which stack has runstack_boundary */
long runstack_boundary_offset; /* where to stop copying the Scheme stack */
void *boundary_dw_id; /* where to stop copying the dynamic-wind stack */
mz_jmp_buf *prompt_buf; /* to jump directly to the prompt */
long runstack_size; /* needed for restore */
} Scheme_Prompt;
/* Compiler helper: */
#define ESCAPED_BEFORE_HERE return NULL
Scheme_Object *scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set,
Scheme_Object *key,
Scheme_Object *prompt_tag,
Scheme_Meta_Continuation **meta_cont);
Scheme_Object *scheme_compose_continuation(Scheme_Cont *c, int num_rands, Scheme_Object *value);
Scheme_Overflow *scheme_get_thread_end_overflow(void);
void scheme_end_current_thread(void);
void scheme_ensure_dw_id(Scheme_Dynamic_Wind *dw);
void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post, int mc_depth);
/*========================================================================*/
/* semaphores and locks */
/*========================================================================*/
@ -2241,7 +2314,7 @@ Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o);
void scheme_clear_modidx_cache(void);
void scheme_clear_shift_cache(void);
void scheme_clear_cc_ok(void);
void scheme_clear_prompt_cache(void);
/*========================================================================*/
/* errors and exceptions */

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 352
#define MZSCHEME_VERSION_MINOR 6
#define MZSCHEME_VERSION_MINOR 7
#define MZSCHEME_VERSION "352.6" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "352.7" _MZ_SPECIAL_TAG

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

@ -596,13 +596,6 @@ void scheme_reset_jmpup_buf(Scheme_Jumpup_Buf *b)
memset(&b->buf, 0, sizeof(mz_jmp_buf));
}
void scheme_ensure_stack_start(Scheme_Thread *p, void *d)
{
if (!p->stack_start
|| (STK_COMP((unsigned long)p->stack_start, (unsigned long)d)))
p->stack_start = d;
}
#ifdef USE_MZ_CYGWIN_SETJMP
/* We have to define setjmp & longjmp to remain compatible
with MSVC-compiled extensions. It's the mostly same code

128
src/mzscheme/src/startup.inc
View File

@ -2157,15 +2157,21 @@
"(let-syntaxes(((id) expr) ...)"
" body1 body ...))))))"
"(-define-syntax syntax-rules"
"(lambda(x)"
"(syntax-case** syntax-rules #t x() module-identifier=?"
"(lambda(stx)"
"(syntax-case** syntax-rules #t stx() module-identifier=?"
"((_(k ...)((keyword . pattern) template) ...)"
"(andmap identifier?(syntax->list(syntax(k ...))))"
"(with-syntax(((dummy ...)"
"(map(lambda(x)"
"(string->uninterned-symbol(symbol->string(syntax-e x))))"
"(map(lambda(id)"
"(unless(identifier? id)"
"(raise-syntax-error"
" #f"
" \"pattern must start with an identifier, found something else\""
" stx"
" id))"
"(string->uninterned-symbol(symbol->string(syntax-e id))))"
"(syntax->list(syntax(keyword ...))))))"
"(syntax/loc x"
"(syntax/loc stx"
"(lambda(x)"
"(syntax-case** _ #t x(k ...) module-identifier=?"
"((dummy . pattern)(syntax/loc x template))"
@ -2691,6 +2697,34 @@
"(check-for-break)"
"(thunk)))"
"(check-for-break)))"
"(define(select-handler/no-breaks e bpz l)"
"(cond"
"((null? l)"
"(raise e))"
"(((caar l) e)"
"(begin0"
"((cdar l) e)"
"(with-continuation-mark "
" break-enabled-key"
" bpz"
"(check-for-break))))"
"(else"
"(select-handler/no-breaks e bpz(cdr l)))))"
"(define(select-handler/breaks-as-is e bpz l)"
"(cond"
"((null? l)"
"(raise e))"
"(((caar l) e)"
"(with-continuation-mark "
" break-enabled-key"
" bpz"
"(begin"
"(check-for-break)"
"((cdar l) e))))"
"(else"
"(select-handler/breaks-as-is e bpz(cdr l)))))"
"(define handler-prompt-key(make-continuation-prompt-tag))"
"(define false-thread-cell(make-thread-cell #f))"
"(define-syntaxes(with-handlers with-handlers*)"
"(let((wh "
"(lambda(disable-break?)"
@ -2698,43 +2732,35 @@
"(syntax-case stx()"
"((_() expr1 expr ...)(syntax/loc stx(let() expr1 expr ...)))"
"((_((pred handler) ...) expr1 expr ...)"
"(with-syntax(((pred-name ...)(generate-temporaries(map(lambda(x) 'with-handlers-predicate) "
"(syntax->list #'(pred ...)))))"
"((handler-name ...)(generate-temporaries(map(lambda(x) 'with-handlers-handler) "
"(syntax->list #'(handler ...))))))"
"(quasisyntax/loc stx"
"(let((l(list(cons pred handler) ...)))"
"(let((pred-name pred) ..."
"(handler-name handler) ...)"
"(let((bpz(continuation-mark-set-first #f break-enabled-key)))"
"(with-continuation-mark"
" break-enabled-key"
"(make-thread-cell #f)"
"((call/ec "
"(lambda(k)"
" false-thread-cell"
"(call-with-continuation-prompt"
"(lambda()"
"(with-continuation-mark "
" break-enabled-key"
" bpz"
"(parameterize((current-exception-handler"
"(lambda(e)"
"(k"
"(abort-current-continuation"
" handler-prompt-key"
"(lambda()"
"(let loop((l l))"
"(cond"
"((null? l)"
"(raise e))"
"(((caar l) e)"
" #,(if disable-break?"
" #'(begin0"
"((cdar l) e)"
"(with-continuation-mark "
" break-enabled-key"
" bpz"
"(check-for-break)))"
" #'(with-continuation-mark "
" break-enabled-key"
" bpz"
"(begin"
"(check-for-break)"
"((cdar l) e)))))"
"(else"
"(loop(cdr l))))))))))"
"(call-with-values(lambda() expr1 expr ...)"
"(lambda args(lambda()(apply values args)))))))))))))))))))"
"(#,(if disable-break?"
" #'select-handler/no-breaks"
" #'select-handler/breaks-as-is)"
" e bpz"
"(list(cons pred-name handler-name) ...)))))))"
" expr1 expr ...)))"
" handler-prompt-key"
"(lambda(thunk)(thunk))))))))))))))"
"(values(wh #t)(wh #f))))"
"(define-syntax set!-values"
"(lambda(stx)"
@ -2883,40 +2909,26 @@
"((negative? lo)(-(find-between(- hi)(- lo))))"
"(else(find-between lo hi)))))))"
"(define(read-eval-print-loop)"
"(let*((eeh #f)"
"(jump #f)"
"(be? #f)"
"(rep-error-escape-handler(lambda()(jump))))"
"(dynamic-wind"
"(lambda()(set! eeh(error-escape-handler))"
"(set! be?(break-enabled))"
"(error-escape-handler rep-error-escape-handler)"
"(break-enabled #f))"
"(let*((jump-key(gensym))"
"(repl-error-escape-handler"
"(lambda()"
"(let/ec done"
"(let((jump-k(continuation-mark-set-first #f jump-key)))"
"(if jump-k"
"(jump-k)"
" (error 'repl-error-escape-handler \"used out of context\"))))))"
"(parameterize((error-escape-handler repl-error-escape-handler))"
"(let/ec done-k"
"(let repl-loop()"
"(let/ec k"
"(dynamic-wind"
"(lambda()"
"(break-enabled be?)"
"(set! jump k))"
"(lambda()"
"(with-continuation-mark jump-key k"
"(let((v((current-prompt-read))))"
"(when(eof-object? v)(done(void)))"
"(when(eof-object? v)(done-k(void)))"
"(call-with-values"
"(lambda()((current-eval)(if(syntax? v)"
"(namespace-syntax-introduce v)"
" v)))"
"(lambda results(for-each(current-print) results)))))"
"(lambda() "
"(set! be?(break-enabled))"
"(break-enabled #f)"
"(set! jump #f))))"
"(repl-loop))))"
"(lambda()(error-escape-handler eeh)"
"(break-enabled be?)"
"(set! jump #f)"
"(set! eeh #f)))))"
"(lambda results(for-each(current-print) results))))))"
"(repl-loop))))))"
"(define load/cd"
"(lambda(n)"
"(unless(path-string? n)"

193
src/mzscheme/src/startup.ss
View File

@ -2507,16 +2507,22 @@
;; From Dybvig, mostly:
(-define-syntax syntax-rules
(lambda (x)
(syntax-case** syntax-rules #t x () module-identifier=?
(lambda (stx)
(syntax-case** syntax-rules #t stx () module-identifier=?
((_ (k ...) ((keyword . pattern) template) ...)
(andmap identifier? (syntax->list (syntax (k ...))))
(with-syntax (((dummy ...)
(map (lambda (x)
(map (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"pattern must start with an identifier, found something else"
stx
id))
;; Preserve the name, in case it's printed out
(string->uninterned-symbol (symbol->string (syntax-e x))))
(string->uninterned-symbol (symbol->string (syntax-e id))))
(syntax->list (syntax (keyword ...))))))
(syntax/loc x
(syntax/loc stx
(lambda (x)
(syntax-case** _ #t x (k ...) module-identifier=?
((dummy . pattern) (syntax/loc x template))
@ -3098,6 +3104,37 @@
(thunk)))
(check-for-break)))
(define (select-handler/no-breaks e bpz l)
(cond
[(null? l)
(raise e)]
[((caar l) e)
(begin0
((cdar l) e)
(with-continuation-mark
break-enabled-key
bpz
(check-for-break)))]
[else
(select-handler/no-breaks e bpz (cdr l))]))
(define (select-handler/breaks-as-is e bpz l)
(cond
[(null? l)
(raise e)]
[((caar l) e)
(with-continuation-mark
break-enabled-key
bpz
(begin
(check-for-break)
((cdar l) e)))]
[else
(select-handler/breaks-as-is e bpz (cdr l))]))
(define handler-prompt-key (make-continuation-prompt-tag))
(define false-thread-cell (make-thread-cell #f))
(define-syntaxes (with-handlers with-handlers*)
(let ([wh
(lambda (disable-break?)
@ -3105,53 +3142,47 @@
(syntax-case stx ()
[(_ () expr1 expr ...) (syntax/loc stx (let () expr1 expr ...))]
[(_ ([pred handler] ...) expr1 expr ...)
(quasisyntax/loc stx
(let ([l (list (cons pred handler) ...)])
;; Capture current break parameterization, so we can use it to
;; evaluate the body
(let ([bpz (continuation-mark-set-first #f break-enabled-key)])
;; Disable breaks here, so that when the exception handler jumps
;; to run a handler, breaks are disabled for the handler
(with-continuation-mark
break-enabled-key
(make-thread-cell #f)
((call/ec
(lambda (k)
;; Restore the captured break parameterization for
;; evaluating the `with-handlers' body. In this
;; special case, no check for breaks is needed,
;; because bpz is quickly restored past call/ec.
;; Thus, `with-handlers' can evaluate its body in
;; tail position.
(with-continuation-mark
break-enabled-key
bpz
(parameterize ([current-exception-handler
(lambda (e)
(k
(lambda ()
(let loop ([l l])
(cond
[(null? l)
(raise e)]
[((caar l) e)
#,(if disable-break?
#'(begin0
((cdar l) e)
(with-continuation-mark
break-enabled-key
bpz
(check-for-break)))
#'(with-continuation-mark
break-enabled-key
bpz
(begin
(check-for-break)
((cdar l) e))))]
[else
(loop (cdr l))])))))])
(call-with-values (lambda () expr1 expr ...)
(lambda args (lambda () (apply values args)))))))))))))])))])
(with-syntax ([(pred-name ...) (generate-temporaries (map (lambda (x) 'with-handlers-predicate)
(syntax->list #'(pred ...))))]
[(handler-name ...) (generate-temporaries (map (lambda (x) 'with-handlers-handler)
(syntax->list #'(handler ...))))])
(quasisyntax/loc stx
(let ([pred-name pred] ...
[handler-name handler] ...)
;; Capture current break parameterization, so we can use it to
;; evaluate the body
(let ([bpz (continuation-mark-set-first #f break-enabled-key)])
;; Disable breaks here, so that when the exception handler jumps
;; to run a handler, breaks are disabled for the handler
(with-continuation-mark
break-enabled-key
false-thread-cell
(call-with-continuation-prompt
(lambda ()
;; Restore the captured break parameterization for
;; evaluating the `with-handlers' body. In this
;; special case, no check for breaks is needed,
;; because bpz is quickly restored past call/ec.
;; Thus, `with-handlers' can evaluate its body in
;; tail position.
(with-continuation-mark
break-enabled-key
bpz
(parameterize ([current-exception-handler
(lambda (e)
;; Deliver a thunk to the escape handler:
(abort-current-continuation
handler-prompt-key
(lambda ()
(#,(if disable-break?
#'select-handler/no-breaks
#'select-handler/breaks-as-is)
e bpz
(list (cons pred-name handler-name) ...)))))])
expr1 expr ...)))
handler-prompt-key
;; On escape, apply the handler thunk
(lambda (thunk) (thunk))))))))])))])
(values (wh #t) (wh #f))))
(define-syntax set!-values
@ -3315,40 +3346,30 @@
[else (find-between lo hi)])))))
(define (read-eval-print-loop)
(let* ([eeh #f]
[jump #f]
[be? #f]
[rep-error-escape-handler (lambda () (jump))])
(dynamic-wind
(lambda () (set! eeh (error-escape-handler))
(set! be? (break-enabled))
(error-escape-handler rep-error-escape-handler)
(break-enabled #f))
(lambda ()
(let/ec done
(let repl-loop ()
(let/ec k
(dynamic-wind
(lambda ()
(break-enabled be?)
(set! jump k))
(lambda ()
(let ([v ((current-prompt-read))])
(when (eof-object? v) (done (void)))
(call-with-values
(lambda () ((current-eval) (if (syntax? v)
(namespace-syntax-introduce v)
v)))
(lambda results (for-each (current-print) results)))))
(lambda ()
(set! be? (break-enabled))
(break-enabled #f)
(set! jump #f))))
(repl-loop))))
(lambda () (error-escape-handler eeh)
(break-enabled be?)
(set! jump #f)
(set! eeh #f)))))
(let* ([jump-key (gensym)]
[repl-error-escape-handler
(lambda ()
(let ([jump-k (continuation-mark-set-first #f jump-key)])
(if jump-k
(jump-k)
(error 'repl-error-escape-handler "used out of context"))))])
;; This parameterize is outside the loop so that
;; expressions evaluated in the REPL can set the
;; error escape handler. That's why we communicate the
;; actual escape target through a continuation mark.
(parameterize ([error-escape-handler repl-error-escape-handler])
(let/ec done-k
(let repl-loop ()
(let/ec k
(with-continuation-mark jump-key k
(let ([v ((current-prompt-read))])
(when (eof-object? v) (done-k (void)))
(call-with-values
(lambda () ((current-eval) (if (syntax? v)
(namespace-syntax-introduce v)
v)))
(lambda results (for-each (current-print) results))))))
(repl-loop))))))
(define load/cd
(lambda (n)

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

@ -152,72 +152,76 @@ enum {
scheme_global_ref_type, /* 134 */
scheme_cont_mark_chain_type, /* 135 */
scheme_raw_pair_type, /* 136 */
scheme_prompt_type, /* 137 */
scheme_prompt_tag_type, /* 138 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 137 */
_scheme_last_normal_type_, /* 139 */
scheme_rt_weak_array, /* 138 */
scheme_rt_weak_array, /* 140 */
scheme_rt_comp_env, /* 139 */
scheme_rt_constant_binding, /* 140 */
scheme_rt_resolve_info, /* 141 */
scheme_rt_optimize_info, /* 142 */
scheme_rt_compile_info, /* 143 */
scheme_rt_cont_mark, /* 144 */
scheme_rt_saved_stack, /* 145 */
scheme_rt_reply_item, /* 146 */
scheme_rt_closure_info, /* 147 */
scheme_rt_overflow, /* 148 */
scheme_rt_dyn_wind_cell, /* 149 */
scheme_rt_dyn_wind_info, /* 150 */
scheme_rt_dyn_wind, /* 151 */
scheme_rt_dup_check, /* 152 */
scheme_rt_thread_memory, /* 153 */
scheme_rt_input_file, /* 154 */
scheme_rt_input_fd, /* 155 */
scheme_rt_oskit_console_input, /* 156 */
scheme_rt_tested_input_file, /* 157 */
scheme_rt_tested_output_file, /* 158 */
scheme_rt_indexed_string, /* 159 */
scheme_rt_output_file, /* 160 */
scheme_rt_load_handler_data, /* 161 */
scheme_rt_pipe, /* 162 */
scheme_rt_beos_process, /* 163 */
scheme_rt_system_child, /* 164 */
scheme_rt_tcp, /* 165 */
scheme_rt_write_data, /* 166 */
scheme_rt_tcp_select_info, /* 167 */
scheme_rt_namespace_option, /* 168 */
scheme_rt_param_data, /* 169 */
scheme_rt_will, /* 170 */
scheme_rt_will_registration, /* 171 */
scheme_rt_struct_proc_info, /* 172 */
scheme_rt_linker_name, /* 173 */
scheme_rt_param_map, /* 174 */
scheme_rt_finalization, /* 175 */
scheme_rt_finalizations, /* 176 */
scheme_rt_cpp_object, /* 177 */
scheme_rt_cpp_array_object, /* 178 */
scheme_rt_stack_object, /* 179 */
scheme_rt_preallocated_object, /* 180 */
scheme_thread_hop_type, /* 181 */
scheme_rt_srcloc, /* 182 */
scheme_rt_evt, /* 183 */
scheme_rt_syncing, /* 184 */
scheme_rt_comp_prefix, /* 185 */
scheme_rt_user_input, /* 186 */
scheme_rt_user_output, /* 187 */
scheme_rt_compact_port, /* 188 */
scheme_rt_read_special_dw, /* 189 */
scheme_rt_regwork, /* 190 */
scheme_rt_buf_holder, /* 191 */
scheme_rt_parameterization, /* 192 */
scheme_rt_print_params, /* 193 */
scheme_rt_read_params, /* 194 */
scheme_rt_native_code, /* 195 */
scheme_rt_native_code_plus_case, /* 196 */
scheme_rt_jitter_data, /* 197 */
scheme_rt_module_exports, /* 198 */
scheme_rt_comp_env, /* 141 */
scheme_rt_constant_binding, /* 142 */
scheme_rt_resolve_info, /* 143 */
scheme_rt_optimize_info, /* 144 */
scheme_rt_compile_info, /* 145 */
scheme_rt_cont_mark, /* 146 */
scheme_rt_saved_stack, /* 147 */
scheme_rt_reply_item, /* 148 */
scheme_rt_closure_info, /* 149 */
scheme_rt_overflow, /* 150 */
scheme_rt_overflow_jmp, /* 151 */
scheme_rt_meta_cont, /* 152 */
scheme_rt_dyn_wind_cell, /* 153 */
scheme_rt_dyn_wind_info, /* 154 */
scheme_rt_dyn_wind, /* 155 */
scheme_rt_dup_check, /* 156 */
scheme_rt_thread_memory, /* 157 */
scheme_rt_input_file, /* 158 */
scheme_rt_input_fd, /* 159 */
scheme_rt_oskit_console_input, /* 160 */
scheme_rt_tested_input_file, /* 161 */
scheme_rt_tested_output_file, /* 162 */
scheme_rt_indexed_string, /* 163 */
scheme_rt_output_file, /* 164 */
scheme_rt_load_handler_data, /* 165 */
scheme_rt_pipe, /* 166 */
scheme_rt_beos_process, /* 167 */
scheme_rt_system_child, /* 168 */
scheme_rt_tcp, /* 169 */
scheme_rt_write_data, /* 170 */
scheme_rt_tcp_select_info, /* 171 */
scheme_rt_namespace_option, /* 172 */
scheme_rt_param_data, /* 173 */
scheme_rt_will, /* 174 */
scheme_rt_will_registration, /* 175 */
scheme_rt_struct_proc_info, /* 176 */
scheme_rt_linker_name, /* 177 */
scheme_rt_param_map, /* 178 */
scheme_rt_finalization, /* 179 */
scheme_rt_finalizations, /* 180 */
scheme_rt_cpp_object, /* 181 */
scheme_rt_cpp_array_object, /* 182 */
scheme_rt_stack_object, /* 183 */
scheme_rt_preallocated_object, /* 184 */
scheme_thread_hop_type, /* 185 */
scheme_rt_srcloc, /* 186 */
scheme_rt_evt, /* 187 */
scheme_rt_syncing, /* 188 */
scheme_rt_comp_prefix, /* 189 */
scheme_rt_user_input, /* 190 */
scheme_rt_user_output, /* 191 */
scheme_rt_compact_port, /* 192 */
scheme_rt_read_special_dw, /* 193 */
scheme_rt_regwork, /* 194 */
scheme_rt_buf_holder, /* 195 */
scheme_rt_parameterization, /* 196 */
scheme_rt_print_params, /* 197 */
scheme_rt_read_params, /* 198 */
scheme_rt_native_code, /* 199 */
scheme_rt_native_code_plus_case, /* 200 */
scheme_rt_jitter_data, /* 201 */
scheme_rt_module_exports, /* 202 */
#endif
_scheme_last_type_

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

@ -154,6 +154,8 @@ Scheme_Thread_Set *thread_set_top;
static int num_running_threads = 1;
void *scheme_deepest_stack_start;
#ifdef LINK_EXTENSIONS_BY_TABLE
Scheme_Thread **scheme_current_thread_ptr;
volatile int *scheme_fuel_counter_ptr;
@ -367,7 +369,7 @@ typedef struct {
static int num_nsos = 0;
static Scheme_NSO *namespace_options = NULL;
#define SETJMP(p) scheme_setjmpup(&p->jmpup_buf, p, p->stack_start)
#define SETJMP(p) scheme_setjmpup(&p->jmpup_buf, p, ADJUST_STACK_START(p->stack_start))
#define LONGJMP(p) scheme_longjmpup(&p->jmpup_buf)
#define RESETJMP(p) scheme_reset_jmpup_buf(&p->jmpup_buf)
@ -552,7 +554,7 @@ void scheme_init_thread(Scheme_Env *env)
scheme_add_global_constant("make-security-guard",
scheme_make_prim_w_arity(make_security_guard,
"make-security-guard",
3, 3),
3, 4),
env);
scheme_add_global_constant("current-security-guard",
scheme_register_parameter(current_security_guard,
@ -2172,8 +2174,6 @@ void scheme_swap_thread(Scheme_Thread *new_thread)
f(o);
}
}
if (scheme_current_thread->cc_ok)
*(scheme_current_thread->cc_ok) = scheme_current_thread->cc_ok_save;
if ((scheme_current_thread->runstack_owner
&& ((*scheme_current_thread->runstack_owner) != scheme_current_thread))
|| (scheme_current_thread->cont_mark_stack_owner
@ -2190,10 +2190,6 @@ void scheme_swap_thread(Scheme_Thread *new_thread)
cb = can_break_param(scheme_current_thread);
scheme_current_thread->can_break_at_swap = cb;
}
if (scheme_current_thread->cc_ok) {
scheme_current_thread->cc_ok_save = *(scheme_current_thread->cc_ok);
*(scheme_current_thread->cc_ok) = 0;
}
scheme_gmp_tls_load(scheme_current_thread->gmp_tls);
#ifdef RUNSTACK_IS_GLOBAL
scheme_current_thread->runstack = MZ_RUNSTACK;
@ -2307,7 +2303,6 @@ static void thread_is_dead(Scheme_Thread *r)
r->transitive_resumes = NULL;
r->error_buf = NULL;
r->overflow_buf = NULL;
r->spare_runstack = NULL;
}
@ -2407,11 +2402,27 @@ static void remove_thread(Scheme_Thread *r)
r->extra_mrefs = scheme_null;
}
void scheme_end_current_thread(void)
{
remove_thread(scheme_current_thread);
thread_ended_with_activity = 1;
if (scheme_notify_multithread && !scheme_first_thread->next) {
scheme_notify_multithread(0);
have_activity = 0;
}
select_thread();
}
static void start_child(Scheme_Thread * volatile child,
Scheme_Object * volatile child_eval)
{
if (SETJMP(child)) {
/* Initial swap in: */
Scheme_Object * volatile result = NULL;
thread_swap_count++;
#ifdef RUNSTACK_IS_GLOBAL
MZ_RUNSTACK = scheme_current_thread->runstack;
@ -2446,11 +2457,9 @@ static void start_child(Scheme_Thread * volatile child,
mz_jmp_buf newbuf;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
/* check for initial break before we do anything */
scheme_check_break_now();
/* run the main thunk: */
scheme_apply_thread_thunk(child_eval);
/* Run the main thunk: */
/* (checks for break before doing anything else) */
result = scheme_apply_thread_thunk(child_eval);
}
}
@ -2458,22 +2467,40 @@ static void start_child(Scheme_Thread * volatile child,
different thread, which invoked the original thread's
continuation. */
remove_thread(scheme_current_thread);
/* If we still have a meta continuation, then it means we
should be resuming at a prompt, not exiting. */
while (scheme_current_thread->meta_continuation) {
Scheme_Thread *p = scheme_current_thread;
Scheme_Overflow *oflow;
thread_ended_with_activity = 1;
if (scheme_notify_multithread && !scheme_first_thread->next) {
scheme_notify_multithread(0);
have_activity = 0;
p->cjs.val = result;
if (!SAME_OBJ(p->meta_continuation->prompt_tag, scheme_default_prompt_tag)) {
scheme_signal_error("thread ended with meta continuation that isn't for the default prompt");
} else {
oflow = p->meta_continuation->overflow;
p->meta_continuation = p->meta_continuation->next;
if (!oflow->eot) {
p->stack_start = oflow->stack_start;
scheme_longjmpup(&oflow->jmp->cont);
}
}
}
select_thread();
scheme_end_current_thread();
/* Shouldn't get here! */
scheme_signal_error("bad thread switch");
}
}
void scheme_ensure_stack_start(void *d)
{
if (!scheme_deepest_stack_start
|| (STK_COMP((unsigned long)scheme_deepest_stack_start, (unsigned long)d)))
scheme_deepest_stack_start = d;
}
static Scheme_Object *make_subprocess(Scheme_Object *child_thunk,
void *child_start,
Scheme_Config *config,
@ -2487,7 +2514,7 @@ static Scheme_Object *make_subprocess(Scheme_Object *child_thunk,
turn_on_multi = !scheme_first_thread->next;
scheme_ensure_stack_start(scheme_current_thread, child_start);
scheme_ensure_stack_start(child_start);
if (!config)
config = scheme_current_config();
@ -2684,9 +2711,6 @@ static Scheme_Object *thread_k(void)
Scheme_Custodian *mgr;
Scheme_Thread_Cell_Table *cells;
int suspend_to_kill = p->ku.k.i1;
#ifndef MZ_PRECISE_GC
long dummy;
#endif
thunk = (Scheme_Object *)p->ku.k.p1;
config = (Scheme_Config *)p->ku.k.p2;
@ -2699,12 +2723,7 @@ static Scheme_Object *thread_k(void)
p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
result = make_subprocess(thunk,
#ifdef MZ_PRECISE_GC
(void *)&__gc_var_stack__,
#else
(void *)&dummy,
#endif
result = make_subprocess(thunk, PROMPT_STACK(result),
config, cells, break_cell, mgr, !suspend_to_kill);
/* Don't get rid of `result'; it keeps the
@ -2769,16 +2788,17 @@ static Scheme_Object *def_nested_exn_handler(int argc, Scheme_Object *argv[])
{
if (scheme_current_thread->nester) {
Scheme_Thread *p = scheme_current_thread;
p->cjs.jumping_to_continuation = (struct Scheme_Escaping_Cont *)scheme_current_thread;
p->cjs.u.val = argv[0];
p->cjs.jumping_to_continuation = (Scheme_Object *)scheme_current_thread;
p->cjs.val = argv[0];
p->cjs.is_kill = 0;
scheme_longjmp(*p->error_buf, 1);
}
return scheme_void; /* misuse of exception handler */
return scheme_void; /* misuse of exception handler (wrong kind of thread or under prompt) */
}
static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[])
/* private, but declared as public to avoid inlining: */
Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], void *max_bottom)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Thread * volatile np;
@ -2841,22 +2861,12 @@ static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[])
}
np->tail_buffer_size = p->tail_buffer_size;
np->overflow_set = p->overflow_set;
np->o_start = p->o_start;
np->overflow_buf = p->overflow_buf;
/* In case it's not yet set in the main thread... */
scheme_ensure_stack_start((Scheme_Thread *)np, (int *)&failure);
scheme_ensure_stack_start(max_bottom);
np->list_stack = p->list_stack;
np->list_stack_pos = p->list_stack_pos;
scheme_gmp_tls_init(np->gmp_tls);
if (p->cc_ok) {
p->cc_ok_save = *p->cc_ok;
*p->cc_ok = 0;
}
/* np->prev = NULL; - 0ed by allocation */
np->next = scheme_first_thread;
@ -2940,7 +2950,7 @@ static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[])
np->error_buf = &newbuf;
if (scheme_setjmp(newbuf)) {
if (!np->cjs.is_kill)
v = np->cjs.u.val;
v = np->cjs.val;
else
v = NULL;
failure = 1;
@ -2996,9 +3006,6 @@ static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[])
MZ_CONT_MARK_POS = p->cont_mark_pos;
#endif
if (p->cc_ok)
*p->cc_ok = p->cc_ok_save;
if ((p->running & MZTHREAD_KILLED)
|| (p->running & MZTHREAD_USER_SUSPENDED))
scheme_thread_block(0.0);
@ -3018,6 +3025,13 @@ static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[])
return v;
}
static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[])
{
Scheme_Object *result;
result = scheme_call_as_nested_thread(argc, argv, PROMPT_STACK(result));
return result;
}
/*========================================================================*/
/* thread scheduling and termination */
/*========================================================================*/
@ -3373,7 +3387,7 @@ static void exit_or_escape(Scheme_Thread *p)
if (p->nester) {
if (p->running & MZTHREAD_KILLED)
p->running -= MZTHREAD_KILLED;
p->cjs.jumping_to_continuation = (struct Scheme_Escaping_Cont *)p;
p->cjs.jumping_to_continuation = (Scheme_Object *)p;
p->cjs.is_kill = 1;
scheme_longjmp(*p->error_buf, 1);
}
@ -3432,7 +3446,6 @@ void scheme_thread_block(float sleep_time)
Scheme_Thread *next, *p = scheme_current_thread;
Scheme_Object *next_in_set;
Scheme_Thread_Set *t_set;
int dummy;
if (p->running & MZTHREAD_KILLED) {
/* This thread is dead! Give up now. */
@ -3645,11 +3658,6 @@ void scheme_thread_block(float sleep_time)
#endif
if (next) {
if (!p->next) {
/* This is the main process */
scheme_ensure_stack_start(p, (void *)&dummy);
}
scheme_swap_thread(next);
} else if (do_atomic && scheme_on_atomic_timeout) {
scheme_on_atomic_timeout();
@ -6243,12 +6251,16 @@ static Scheme_Object *make_security_guard(int argc, Scheme_Object *argv[])
scheme_wrong_type("make-security-guard", "security-guard", 0, argc, argv);
scheme_check_proc_arity("make-security-guard", 3, 1, argc, argv);
scheme_check_proc_arity("make-security-guard", 4, 2, argc, argv);
if (argc > 3)
scheme_check_proc_arity2("make-security-guard", 3, 3, argc, argv, 1);
sg = MALLOC_ONE_TAGGED(Scheme_Security_Guard);
sg->so.type = scheme_security_guard_type;
sg->parent = (Scheme_Security_Guard *)argv[0];
sg->file_proc = argv[1];
sg->network_proc = argv[2];
if ((argc > 3) && SCHEME_TRUEP(argv[3]))
sg->link_proc = argv[3];
return (Scheme_Object *)sg;
}
@ -6314,6 +6326,33 @@ void scheme_security_check_file(const char *who, const char *filename, int guard
}
}
void scheme_security_check_file_link(const char *who, const char *filename, const char *content)
{
Scheme_Security_Guard *sg;
sg = (Scheme_Security_Guard *)scheme_get_param(scheme_current_config(), MZCONFIG_SECURITY_GUARD);
if (sg->file_proc) {
Scheme_Object *a[3];
a[0] = scheme_intern_symbol(who);
a[1] = scheme_make_sized_path((char *)filename, -1, 1);
a[2] = scheme_make_sized_path((char *)content, -1, 1);
while (sg->parent) {
if (sg->link_proc)
scheme_apply(sg->link_proc, 3, a);
else {
scheme_signal_error("%s: security guard does not allow any link operation; attempted from: %s to: %s",
who,
filename,
content);
}
sg = sg->parent;
}
}
}
void scheme_security_check_network(const char *who, const char *host, int port, int client)
{
Scheme_Security_Guard *sg;
@ -6518,12 +6557,21 @@ static void prepare_thread_for_GC(Scheme_Object *t)
while (o < e && (o != e2)) {
*(o++) = NULL;
}
/* If there's a meta-prompt, we can also zero out past the unused part */
if (p->meta_prompt && (p->meta_prompt->runstack_boundary_start == p->runstack_start)) {
e = p->runstack_start + p->runstack_size;
o = p->runstack_start + p->meta_prompt->runstack_boundary_offset;
while (o < e) {
*(o++) = NULL;
}
}
RUNSTACK_TUNE( size = p->runstack_size - (p->runstack - p->runstack_start); );
for (saved = p->runstack_saved; saved; saved = saved->prev) {
o = saved->runstack_start;
e = saved->runstack;
e = o + saved->runstack_offset;
RUNSTACK_TUNE( size += saved->runstack_size; );
while (o < e) {
*(o++) = NULL;
@ -6565,6 +6613,22 @@ static void prepare_thread_for_GC(Scheme_Object *t)
for (i = stackpos; i < SCHEME_MARK_SEGMENT_SIZE; i++) {
seg[i].key = NULL;
seg[i].val = NULL;
seg[i].cache = NULL;
}
}
{
MZ_MARK_STACK_TYPE pos;
/* also zero out slots before the current bottom */
for (pos = 0; pos < p->cont_mark_stack_bottom; pos++) {
Scheme_Cont_Mark *seg;
int stackpos;
segpos = ((long)pos >> SCHEME_LOG_MARK_SEGMENT_SIZE);
seg = p->cont_mark_stack_segments[segpos];
stackpos = ((long)pos & SCHEME_MARK_SEGMENT_MASK);
seg[stackpos].key = NULL;
seg[stackpos].val = NULL;
seg[stackpos].cache = NULL;
}
}
}
@ -6599,7 +6663,7 @@ static void get_ready_for_GC()
scheme_clear_modidx_cache();
scheme_clear_shift_cache();
scheme_clear_cc_ok();
scheme_clear_prompt_cache();
scheme_clear_rx_buffers();
#ifdef RUNSTACK_IS_GLOBAL
@ -6695,7 +6759,7 @@ static Scheme_Object *current_stats(int argc, Scheme_Object *argv[])
/* C stack */
if (t == scheme_current_thread) {
void *stk_start, *stk_end;
stk_start = t->stack_start;
stk_start = ADJUST_STACK_START(t->stack_start);
stk_end = (void *)&stk_end;
# ifdef STACK_GROWS_UP
sz = (long)stk_end XFORM_OK_MINUS (long)stk_start;
@ -6708,7 +6772,7 @@ static Scheme_Object *current_stats(int argc, Scheme_Object *argv[])
sz = t->jmpup_buf.stack_size;
}
for (overflow = t->overflow; overflow; overflow = overflow->prev) {
sz += overflow->cont.stack_size;
sz += overflow->jmp->cont.stack_size;
}
/* Scheme stack */
@ -6816,7 +6880,9 @@ Scheme_Jumpup_Buf_Holder *scheme_new_jmpupbuf_holder(void)
#ifdef MZ_PRECISE_GC
static unsigned long get_current_stack_start(void)
{
return (unsigned long)scheme_current_thread->stack_start;
Scheme_Thread *p;
p = scheme_current_thread;
return (unsigned long)ADJUST_STACK_START(p->stack_start);
}
#endif

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

@ -222,6 +222,8 @@ scheme_init_type (Scheme_Env *env)
set_name(scheme_thread_cell_type, "<thread-cell>");
set_name(scheme_thread_cell_values_type, "<thread-cell-values>");
set_name(scheme_prompt_tag_type, "<continuation-prompt-tag>");
set_name(scheme_string_converter_type, "<string-converter>");
set_name(scheme_channel_syncer_type, "<channel-syncer>");
@ -341,35 +343,23 @@ static int bad_trav_FIXUP(void *p)
static void MARK_cjs(Scheme_Continuation_Jump_State *cjs)
{
gcMARK(cjs->jumping_to_continuation);
gcMARK(cjs->u.vals);
gcMARK(cjs->val);
}
static void FIXUP_cjs(Scheme_Continuation_Jump_State *cjs)
{
gcFIXUP(cjs->jumping_to_continuation);
gcFIXUP(cjs->u.vals);
gcFIXUP(cjs->val);
}
static void MARK_stack_state(Scheme_Stack_State *ss)
{
Scheme_Object **old = ss->runstack_start;
gcMARK(ss->runstack_start);
ss->runstack = ss->runstack_start + (ss->runstack - old);
gcMARK(ss->runstack_saved);
gcMARK(ss->current_escape_cont_key);
gcMARK(ss->barrier_prompt);
}
static void FIXUP_stack_state(Scheme_Stack_State *ss)
{
Scheme_Object **old = ss->runstack_start;
gcFIXUP(ss->runstack_saved);
gcFIXUP_TYPED_NOW(Scheme_Object **, ss->runstack_start);
ss->runstack = ss->runstack_start + (ss->runstack - old);
gcFIXUP(ss->current_escape_cont_key);
gcFIXUP(ss->barrier_prompt);
}
static void MARK_jmpup(Scheme_Jumpup_Buf *buf)
@ -452,6 +442,8 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_cont_type, cont_proc);
GC_REG_TRAV(scheme_rt_dyn_wind, mark_dyn_wind);
GC_REG_TRAV(scheme_rt_overflow, mark_overflow);
GC_REG_TRAV(scheme_rt_overflow_jmp, mark_overflow_jmp);
GC_REG_TRAV(scheme_rt_meta_cont, meta_cont_proc);
GC_REG_TRAV(scheme_escaping_cont_type, escaping_cont_proc);
GC_REG_TRAV(scheme_char_type, char_obj);
@ -486,6 +478,8 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_lazy_macro_type, second_of_cons);
GC_REG_TRAV(scheme_box_type, small_object);
GC_REG_TRAV(scheme_thread_type, thread_val);
GC_REG_TRAV(scheme_prompt_type, prompt_val);
GC_REG_TRAV(scheme_prompt_tag_type, cons_cell);
GC_REG_TRAV(scheme_cont_mark_set_type, cont_mark_set_val);
GC_REG_TRAV(scheme_sema_type, sema_val);
GC_REG_TRAV(scheme_channel_type, channel_val);

1
src/wxmac/include/base/common.h
View File

@ -365,6 +365,7 @@ extern CGrafPtr wxGetGrafPtr(void);
#define leaveEvt 42
#define wheelEvt 43
#define mouseMenuDown 44
#define unicodeEvt 45
#include "wx_obj.h"

3
src/wxmac/src/mac/wx_app.cc
View File

@ -262,6 +262,7 @@ void wxApp::doMacDispatch(EventRecord *e)
doMacMouseUp(); break;
case keyDown:
case wheelEvt:
case unicodeEvt:
doMacKeyDown(); break;
case autoKey:
doMacAutoKey(); break;
@ -645,6 +646,8 @@ void wxApp::doMacKeyUpDown(Bool down)
key = WXK_WHEEL_UP;
else
key = WXK_WHEEL_DOWN;
} else if (cCurrentEvent.what == unicodeEvt) {
key = cCurrentEvent.message;
} else {
key = (cCurrentEvent.message & keyCodeMask) >> 8;
/* Better way than to use hard-wired key codes? */

7
src/wxmac/src/mac/wx_item.cc
View File

@ -25,7 +25,7 @@
#include "wx_gdi.h"
#include "wx_utils.h"
extern Bool wx_ignore_key;
extern void wxSmuggleOutEvent(EventRef);
Bool wx_propagate_key;
wxItem::wxItem(void)
@ -262,7 +262,10 @@ static OSStatus myEventHandler(EventHandlerCallRef inHandlerCallRef,
if (wx_propagate_key) {
return eventNotHandledErr;
} else {
wx_ignore_key = TRUE;
/* We don't want anyone else to handle this event
at the OS X level, out smuggle out the event
so it can be picked up at the WaitNextEvent level: */
wxSmuggleOutEvent(inEvent);
return noErr;
}
}