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

352.5

Browse Source 
svn: r4169
This commit is contained in:
Matthew Flatt 2006-08-28 09:42:12 +00:00
parent 2c8ab78953
commit 86900d573a
23 changed files with 5639 additions and 4425 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/README
View File

@ -122,7 +122,9 @@ the Unix instructions below, but note the following:
For cross compilation, set the compiler variables to a compiler For cross compilation, set the compiler variables to a compiler
for the target platform compiler, but also set CC_FOR_BUILD to a for the target platform compiler, but also set CC_FOR_BUILD to a
compiler for the host platform (for building binaries to execute compiler for the host platform (for building binaries to execute
during the build process). during the build process). If the target machine's stack grows up,
you'll have to supply --enable-stackup; if the target machine is
big-endian, you may have to supply --enable-bigendian.
If you re-run `configure' after running `make', then products of If you re-run `configure' after running `make', then products of
the `make' may be incorrect due to changes in the compiler command the `make' may be incorrect due to changes in the compiler command

30
src/configure vendored
View File

@ -875,6 +875,8 @@ Optional Features:
--enable-float include support for single-precision floats --enable-float include support for single-precision floats
--enable-floatinstead compile to use single-precision by default --enable-floatinstead compile to use single-precision by default
--enable-pthread link MrEd with pthreads (sometimes needed for GL) --enable-pthread link MrEd with pthreads (sometimes needed for GL)
--enable-stackup assume "up" if stack direction cannot be determined
--enable-bigendian assume "big" if endianness cannot be determined
--enable-oskit compile OSKit-based MzScheme kernel --enable-oskit compile OSKit-based MzScheme kernel
--enable-smalloskit compile small OSKit-based MzScheme kernel --enable-smalloskit compile small OSKit-based MzScheme kernel
--enable-wbuild compile and use wbuild for .w sources --enable-wbuild compile and use wbuild for .w sources
@ -1466,6 +1468,16 @@ fi;
if test "${enable_pthread+set}" = set; then if test "${enable_pthread+set}" = set; then
enableval="$enable_pthread" enableval="$enable_pthread"
fi;
# Check whether --enable-stackup or --disable-stackup was given.
if test "${enable_stackup+set}" = set; then
enableval="$enable_stackup"
fi;
# Check whether --enable-bigendian or --disable-bigendian was given.
if test "${enable_bigendian+set}" = set; then
enableval="$enable_bigendian"
fi; fi;
# Check whether --enable-oskit or --disable-oskit was given. # Check whether --enable-oskit or --disable-oskit was given.
@ -8323,7 +8335,7 @@ int grows_down_p(int n, void *cmp) {
return grows_down_p(n - 1, cmp); return grows_down_p(n - 1, cmp);
} }
int main() { int main() {
return grows_down_p(); return grows_down_p(0, 0);
} }
_ACEOF _ACEOF
rm -f conftest$ac_exeext rm -f conftest$ac_exeext
@ -8352,8 +8364,11 @@ echo "$as_me:$LINENO: result: $stack_direction" >&5
echo "${ECHO_T}$stack_direction" >&6 echo "${ECHO_T}$stack_direction" >&6
if test "${stack_direction}" = "unknown" ; then if test "${stack_direction}" = "unknown" ; then
echo configure: cannot determine stack direction if test "${enable_stackup}" = "yes" ; then
exit 1 stack_direction=up
else
echo configure: warning: cannot determine stack direction, assuming down
fi
fi fi
if test "${stack_direction}" = "up" ; then if test "${stack_direction}" = "up" ; then
@ -8590,12 +8605,15 @@ case $ac_cv_c_bigendian in
no) no)
endianness=little ;; endianness=little ;;
*) *)
endiannes=unknown ;; endianness=unknown ;;
esac esac
if test "${endianness}" = "unknown" ; then if test "${endianness}" = "unknown" ; then
echo configure: cannot determine endianness if test "${enable_bigendian}" = "yes" ; then
exit 1 endianness=big
else
echo configure: warning: cannot determine endianness, assuming little
fi
fi fi
if test "${endianness}" = "big" ; then if test "${endianness}" = "big" ; then

4
src/mred/wxs/wxs_madm.cxx
View File

@ -217,6 +217,10 @@ typedef void *(*CAPOFunc)(void*);
// No OnScroll, because it's handled more primitively to better support
// interactive scrolling on Mac OS X and Windows
// @ v "on-scroll" : void OnScroll(wxScrollEvent!); : JMPDECL/SETJMP/RESETJMP

4
src/mred/wxs/wxs_madm.xc
View File

@ -72,6 +72,10 @@ typedef void *(*CAPOFunc)(void*);
@ v "on-scroll-on-change" : void OnScrollOnChange(); @ v "on-scroll-on-change" : void OnScrollOnChange();
// No OnScroll, because it's handled more primitively to better support
// interactive scrolling on Mac OS X and Windows
// @ v "on-scroll" : void OnScroll(wxScrollEvent!); : JMPDECL/SETJMP/RESETJMP
@ "is-focus-on?" : bool IsFocusOn(); @ "is-focus-on?" : bool IsFocusOn();
@ "force-display-focus" : void ForceDisplayFocus(bool); @ "force-display-focus" : void ForceDisplayFocus(bool);

20
src/mzscheme/configure.ac
View File

@ -52,6 +52,8 @@ AC_ARG_ENABLE(float, [ --enable-float include support for single-pre
AC_ARG_ENABLE(floatinstead, [ --enable-floatinstead compile to use single-precision by default]) AC_ARG_ENABLE(floatinstead, [ --enable-floatinstead compile to use single-precision by default])
AC_ARG_ENABLE(pthread, [ --enable-pthread link MrEd with pthreads (sometimes needed for GL)]) AC_ARG_ENABLE(pthread, [ --enable-pthread link MrEd with pthreads (sometimes needed for GL)])
AC_ARG_ENABLE(stackup, [ --enable-stackup assume "up" if stack direction cannot be determined])
AC_ARG_ENABLE(bigendian, [ --enable-bigendian assume "big" if endianness cannot be determined])
AC_ARG_ENABLE(oskit, [ --enable-oskit compile OSKit-based MzScheme kernel]) AC_ARG_ENABLE(oskit, [ --enable-oskit compile OSKit-based MzScheme kernel])
AC_ARG_ENABLE(smalloskit, [ --enable-smalloskit compile small OSKit-based MzScheme kernel]) AC_ARG_ENABLE(smalloskit, [ --enable-smalloskit compile small OSKit-based MzScheme kernel])
@ -766,13 +768,16 @@ AC_TRY_RUN(
return grows_down_p(n - 1, cmp); return grows_down_p(n - 1, cmp);
} }
int main() { int main() {
return grows_down_p(); return grows_down_p(0, 0);
}, stack_direction=up, stack_direction=down, stack_direction=unknown) }, stack_direction=up, stack_direction=down, stack_direction=unknown)
AC_MSG_RESULT($stack_direction) AC_MSG_RESULT($stack_direction)
if test "${stack_direction}" = "unknown" ; then if test "${stack_direction}" = "unknown" ; then
echo configure: cannot determine stack direction if test "${enable_stackup}" = "yes" ; then
exit 1 stack_direction=up
else
echo configure: warning: cannot determine stack direction, assuming down
fi
fi fi
if test "${stack_direction}" = "up" ; then if test "${stack_direction}" = "up" ; then
@ -782,10 +787,13 @@ if test "${stack_direction}" = "down" ; then
AC_DEFINE(STACK_DIRECTION,-1,[Stack direction down]) AC_DEFINE(STACK_DIRECTION,-1,[Stack direction down])
fi fi
AC_C_BIGENDIAN(endianness=big, endianness=little, endiannes=unknown) AC_C_BIGENDIAN(endianness=big, endianness=little, endianness=unknown)
if test "${endianness}" = "unknown" ; then if test "${endianness}" = "unknown" ; then
echo configure: cannot determine endianness if test "${enable_bigendian}" = "yes" ; then
exit 1 endianness=big
else
echo configure: warning: cannot determine endianness, assuming little
fi
fi fi
if test "${endianness}" = "big" ; then if test "${endianness}" = "big" ; then

57
src/mzscheme/gc2/newgc.c
View File

@ -315,14 +315,15 @@ static struct mpage *page_map[1 << USEFUL_ADDR_BITS];
entire nursery on every GC. The latter is useful because it simplifies entire nursery on every GC. The latter is useful because it simplifies
the allocation process (which is also a speed hack, come to think of it) the allocation process (which is also a speed hack, come to think of it)
gen0_pages is the list of very large nursery pages. gen0_alloc_page is gen0_pages is the list of very large nursery pages. GC_gen0_alloc_page is
the member of this list we are currently allocating on. The size count the member of this list we are currently allocating on. The size count
helps us trigger collection quickly when we're running out of space; see helps us trigger collection quickly when we're running out of space; see
the test in allocate_big. the test in allocate_big.
*/ */
static struct mpage *gen0_pages = NULL; static struct mpage *gen0_pages = NULL;
static struct mpage *gen0_alloc_page = NULL; static struct mpage *GC_gen0_alloc_page = NULL;
static struct mpage *gen0_big_pages = NULL; static struct mpage *gen0_big_pages = NULL;
static unsigned long GC_gen0_alloc_page_size = 0;
static unsigned long gen0_current_size = 0; static unsigned long gen0_current_size = 0;
static unsigned long gen0_max_size = 0; static unsigned long gen0_max_size = 0;
@ -439,20 +440,24 @@ inline static void *allocate(size_t sizeb, int type)
sizeb = gcWORDS_TO_BYTES(sizew); sizeb = gcWORDS_TO_BYTES(sizew);
alloc_retry: alloc_retry:
newsize = gen0_alloc_page->size + sizeb; newsize = GC_gen0_alloc_page_size + sizeb;
if(newsize > GEN0_PAGE_SIZE) { if(newsize > GEN0_PAGE_SIZE) {
if(gen0_alloc_page->next) gen0_current_size += (GC_gen0_alloc_page_size - HEADER_SIZEB);
gen0_alloc_page = gen0_alloc_page->next; GC_gen0_alloc_page->size = GC_gen0_alloc_page_size;
else if (avoid_collection) { if(GC_gen0_alloc_page->next) {
GC_gen0_alloc_page = GC_gen0_alloc_page->next;
GC_gen0_alloc_page_size = GC_gen0_alloc_page->size;
} else if (avoid_collection) {
struct mpage *work; struct mpage *work;
work = malloc_pages(GEN0_PAGE_SIZE, APAGE_SIZE); work = malloc_pages(GEN0_PAGE_SIZE, APAGE_SIZE);
work->size = GEN0_PAGE_SIZE; work->size = GEN0_PAGE_SIZE;
work->big_page = 1; work->big_page = 1;
gen0_alloc_page->prev = work; GC_gen0_alloc_page->prev = work;
work->next = gen0_alloc_page; work->next = GC_gen0_alloc_page;
gen0_alloc_page = work; GC_gen0_alloc_page = work;
GC_gen0_alloc_page_size = GC_gen0_alloc_page->size;
pagemap_add(work); pagemap_add(work);
work->size = HEADER_SIZEB; work->size = HEADER_SIZEB;
work->big_page = 0; work->big_page = 0;
@ -460,7 +465,7 @@ inline static void *allocate(size_t sizeb, int type)
garbage_collect(0); garbage_collect(0);
goto alloc_retry; goto alloc_retry;
} else { } else {
void *retval = PTR(NUM(gen0_alloc_page) + gen0_alloc_page->size); void *retval = PTR(NUM(GC_gen0_alloc_page) + GC_gen0_alloc_page_size);
if (type == PAGE_ATOMIC) if (type == PAGE_ATOMIC)
*((void **)retval) = NULL; /* init objhead */ *((void **)retval) = NULL; /* init objhead */
@ -470,8 +475,7 @@ inline static void *allocate(size_t sizeb, int type)
info = (struct objhead *)retval; info = (struct objhead *)retval;
info->type = type; info->type = type;
info->size = sizew; info->size = sizew;
gen0_alloc_page->size = newsize; GC_gen0_alloc_page_size = newsize;
gen0_current_size += sizeb;
return PTR(NUM(retval) + WORD_SIZE); return PTR(NUM(retval) + WORD_SIZE);
} }
@ -495,20 +499,19 @@ void *GC_malloc_one_small_tagged(size_t sizeb)
sizeb += WORD_SIZE; sizeb += WORD_SIZE;
sizeb = ALIGN_BYTES_SIZE(sizeb); sizeb = ALIGN_BYTES_SIZE(sizeb);
newsize = gen0_alloc_page->size + sizeb; newsize = GC_gen0_alloc_page_size + sizeb;
if(newsize > GEN0_PAGE_SIZE) { if(newsize > GEN0_PAGE_SIZE) {
return GC_malloc_one_tagged(sizeb - WORD_SIZE); return GC_malloc_one_tagged(sizeb - WORD_SIZE);
} else { } else {
void *retval = PTR(NUM(gen0_alloc_page) + gen0_alloc_page->size); void *retval = PTR(NUM(GC_gen0_alloc_page) + GC_gen0_alloc_page_size);
struct objhead *info = (struct objhead *)retval; struct objhead *info = (struct objhead *)retval;
bzero(retval, sizeb); bzero(retval, sizeb);
/* info->type = type; */ /* We know that the type field is already 0 */ /* info->type = type; */ /* We know that the type field is already 0 */
info->size = (sizeb >> gcLOG_WORD_SIZE); info->size = (sizeb >> gcLOG_WORD_SIZE);
gen0_alloc_page->size = newsize; GC_gen0_alloc_page_size = newsize;
gen0_current_size += sizeb;
return PTR(NUM(retval) + WORD_SIZE); return PTR(NUM(retval) + WORD_SIZE);
} }
@ -520,19 +523,18 @@ void *GC_malloc_one_small_dirty_tagged(size_t sizeb)
sizeb += WORD_SIZE; sizeb += WORD_SIZE;
sizeb = ALIGN_BYTES_SIZE(sizeb); sizeb = ALIGN_BYTES_SIZE(sizeb);
newsize = gen0_alloc_page->size + sizeb; newsize = GC_gen0_alloc_page_size + sizeb;
if(newsize > GEN0_PAGE_SIZE) { if(newsize > GEN0_PAGE_SIZE) {
return GC_malloc_one_tagged(sizeb - WORD_SIZE); return GC_malloc_one_tagged(sizeb - WORD_SIZE);
} else { } else {
void *retval = PTR(NUM(gen0_alloc_page) + gen0_alloc_page->size); void *retval = PTR(NUM(GC_gen0_alloc_page) + GC_gen0_alloc_page_size);
struct objhead *info = (struct objhead *)retval; struct objhead *info = (struct objhead *)retval;
*(void **)info = NULL; /* client promises the initialize the rest */ *(void **)info = NULL; /* client promises the initialize the rest */
info->size = (sizeb >> gcLOG_WORD_SIZE); info->size = (sizeb >> gcLOG_WORD_SIZE);
gen0_alloc_page->size = newsize; GC_gen0_alloc_page_size = newsize;
gen0_current_size += sizeb;
return PTR(NUM(retval) + WORD_SIZE); return PTR(NUM(retval) + WORD_SIZE);
} }
@ -545,7 +547,7 @@ void *GC_malloc_pair(void *car, void *cdr)
void *retval; void *retval;
sizeb = ALIGN_BYTES_SIZE(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object))) + WORD_SIZE); sizeb = ALIGN_BYTES_SIZE(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object))) + WORD_SIZE);
newsize = gen0_alloc_page->size + sizeb; newsize = GC_gen0_alloc_page_size + sizeb;
if(newsize > GEN0_PAGE_SIZE) { if(newsize > GEN0_PAGE_SIZE) {
park[0] = car; park[0] = car;
@ -558,7 +560,7 @@ void *GC_malloc_pair(void *car, void *cdr)
} else { } else {
struct objhead *info; struct objhead *info;
retval = PTR(NUM(gen0_alloc_page) + gen0_alloc_page->size); retval = PTR(NUM(GC_gen0_alloc_page) + GC_gen0_alloc_page_size);
info = (struct objhead *)retval; info = (struct objhead *)retval;
((void **)retval)[0] = NULL; /* objhead */ ((void **)retval)[0] = NULL; /* objhead */
@ -566,8 +568,7 @@ void *GC_malloc_pair(void *car, void *cdr)
/* info->type = type; */ /* We know that the type field is already 0 */ /* info->type = type; */ /* We know that the type field is already 0 */
info->size = (sizeb >> gcLOG_WORD_SIZE); info->size = (sizeb >> gcLOG_WORD_SIZE);
gen0_alloc_page->size = newsize; GC_gen0_alloc_page_size = newsize;
gen0_current_size += sizeb;
retval = PTR(NUM(retval) + WORD_SIZE); retval = PTR(NUM(retval) + WORD_SIZE);
} }
@ -640,7 +641,8 @@ inline static void resize_gen0(unsigned long new_size)
} }
/* we're going to allocate onto the first page now */ /* we're going to allocate onto the first page now */
gen0_alloc_page = gen0_pages; GC_gen0_alloc_page = gen0_pages;
GC_gen0_alloc_page_size = GC_gen0_alloc_page->size;
/* set the two size variables */ /* set the two size variables */
gen0_max_size = alloced_size; gen0_max_size = alloced_size;
@ -1848,7 +1850,7 @@ long GC_get_memory_use(void *o)
retval = custodian_usage(arg); retval = custodian_usage(arg);
} }
} else { } else {
retval = gen0_current_size + memory_in_use; retval = gen0_current_size + (GC_gen0_alloc_page_size - HEADER_SIZEB) + memory_in_use;
} }
return retval; return retval;
@ -2216,7 +2218,8 @@ void GC_dump_with_traces(int flags,
GCPRINT(GCOUTF, "End MzScheme3m\n"); GCPRINT(GCOUTF, "End MzScheme3m\n");
GCWARN((GCOUTF, "Generation 0: %li of %li bytes used\n", GCWARN((GCOUTF, "Generation 0: %li of %li bytes used\n",
gen0_current_size, gen0_max_size)); gen0_current_size + (GC_gen0_alloc_page_size - HEADER_SIZEB),
gen0_max_size));
for(i = 0; i < PAGE_TYPES; i++) { for(i = 0; i < PAGE_TYPES; i++) {
unsigned long total_use = 0, count = 0; unsigned long total_use = 0, count = 0;

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

@ -984,7 +984,7 @@ typedef struct Scheme_Thread {
struct { struct {
Scheme_Object *tail_rator; Scheme_Object *tail_rator;
Scheme_Object **tail_rands; Scheme_Object **tail_rands;
int tail_num_rands; long tail_num_rands;
} apply; } apply;
struct { struct {
Scheme_Object **array; Scheme_Object **array;

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

@ -252,7 +252,7 @@ eval.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../inclu
file.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ file.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c
fun.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ fun.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schmap.inc
hash.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ hash.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/../src/stypes.h
image.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \ image.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \

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

File diff suppressed because it is too large Load Diff

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

@ -247,7 +247,7 @@ static void register_traversers(void);
#endif #endif
/* Lookahead types for evaluating application arguments. */ /* Lookahead types for evaluating application arguments. */
/* 4 cases + else => magic number for some compilers doing a switch */ /* 4 cases + else => magic number for some compilers doing a switch? */
enum { enum {
SCHEME_EVAL_CONSTANT = 0, SCHEME_EVAL_CONSTANT = 0,
SCHEME_EVAL_GLOBAL, SCHEME_EVAL_GLOBAL,
@ -1972,6 +1972,8 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
info = scheme_optimize_info_add_frame(info, 0, 0, 0); info = scheme_optimize_info_add_frame(info, 0, 0, 0);
info->inline_fuel >>= 1; info->inline_fuel >>= 1;
p = scheme_optimize_expr(p, info); p = scheme_optimize_expr(p, info);
info->next->single_result = info->single_result;
info->next->preserves_marks = info->preserves_marks;
scheme_optimize_info_done(info); scheme_optimize_info_done(info);
return p; return p;
} }
@ -2021,7 +2023,9 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
#endif #endif
Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc, Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc,
Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3) Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
int *_flags)
/* If not app, app2, or app3, just return a known procedure, if any */
{ {
int offset = 0; int offset = 0;
@ -2046,11 +2050,17 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)le; Scheme_Closure_Data *data = (Scheme_Closure_Data *)le;
int sz; int sz;
if (!app && !app2 && !app3) {
return le;
}
*_flags = SCHEME_CLOSURE_DATA_FLAGS(data);
if (data->num_params == argc) { if (data->num_params == argc) {
sz = scheme_closure_body_size(data, 1); sz = scheme_closure_body_size(data, 1);
if ((sz >= 0) && (sz <= (info->inline_fuel * (argc + 2)))) { if ((sz >= 0) && (sz <= (info->inline_fuel * (argc + 2)))) {
le = scheme_optimize_clone(data->code, info, offset, argc); le = scheme_optimize_clone(0, data->code, info, offset, argc);
if (le) { if (le) {
LOG_INLINE(fprintf(stderr, "Inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???")); LOG_INLINE(fprintf(stderr, "Inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
return apply_inlined(le, data, info, argc, app, app2, app3); return apply_inlined(le, data, info, argc, app, app2, app3);
@ -2064,6 +2074,11 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
} }
} }
} }
if (le && SCHEME_PRIMP(le)) {
if (((Scheme_Prim_Proc_Header *)le)->flags & SCHEME_PRIM_IS_NONCM)
*_flags = (CLOS_PRESERVES_MARKS | CLOS_SINGLE_RESULT);
}
return NULL; return NULL;
} }
@ -2121,7 +2136,7 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
{ {
Scheme_Object *le; Scheme_Object *le;
Scheme_App_Rec *app; Scheme_App_Rec *app;
int i, n, all_vals = 1; int i, n, all_vals = 1, rator_flags = 0;
app = (Scheme_App_Rec *)o; app = (Scheme_App_Rec *)o;
@ -2132,7 +2147,7 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
if (!i) { if (!i) {
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL); le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
if (le) if (le)
return le; return le;
} }
@ -2152,6 +2167,13 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
info->size += 1; info->size += 1;
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
if (rator_flags & CLOS_RESULT_TENTATIVE) {
info->preserves_marks = -info->preserves_marks;
info->single_result = -info->single_result;
}
return (Scheme_Object *)app; return (Scheme_Object *)app;
} }
@ -2159,13 +2181,14 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
{ {
Scheme_App2_Rec *app; Scheme_App2_Rec *app;
Scheme_Object *le; Scheme_Object *le;
int rator_flags = 0;
app = (Scheme_App2_Rec *)o; app = (Scheme_App2_Rec *)o;
le = check_app_let_rator(o, app->rator, info, 1); le = check_app_let_rator(o, app->rator, info, 1);
if (le) return le; if (le) return le;
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL); le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
if (le) if (le)
return le; return le;
@ -2182,6 +2205,13 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
info->size += 1; info->size += 1;
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
if (rator_flags & CLOS_RESULT_TENTATIVE) {
info->preserves_marks = -info->preserves_marks;
info->single_result = -info->single_result;
}
return (Scheme_Object *)app; return (Scheme_Object *)app;
} }
@ -2190,13 +2220,14 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
Scheme_App3_Rec *app; Scheme_App3_Rec *app;
Scheme_Object *le; Scheme_Object *le;
int all_vals = 1; int all_vals = 1;
int rator_flags = 0;
app = (Scheme_App3_Rec *)o; app = (Scheme_App3_Rec *)o;
le = check_app_let_rator(o, app->rator, info, 2); le = check_app_let_rator(o, app->rator, info, 2);
if (le) return le; if (le) return le;
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app); le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
if (le) if (le)
return le; return le;
@ -2229,18 +2260,117 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
info->size += 1; info->size += 1;
/* Check for (call-with-values (lambda () M) N): */
if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) {
if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_compiled_unclosed_procedure_type)) {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)app->rand1;
if (!data->num_params) {
/* Convert to apply-values form: */
return scheme_optimize_apply_values(app->rand2, data->code, info,
((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT)
? ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)
? -1
: 1)
: 0));
}
}
}
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
if (rator_flags & CLOS_RESULT_TENTATIVE) {
info->preserves_marks = -info->preserves_marks;
info->single_result = -info->single_result;
}
return (Scheme_Object *)app; return (Scheme_Object *)app;
} }
Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
Optimize_Info *info,
int e_single_result)
/* f and e are already optimized */
{
Scheme_Object *f_is_proc = NULL;
info->preserves_marks = 0;
info->single_result = 0;
{
Scheme_Object *rev;
if (SAME_TYPE(SCHEME_TYPE(f), scheme_local_type)) {
rev = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(f), 1);
} else
rev = f;
if (rev) {
int rator2_flags;
Scheme_Object *o_f;
o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags);
if (o_f) {
f_is_proc = rev;
if (SAME_TYPE(SCHEME_TYPE(o_f), scheme_compiled_unclosed_procedure_type)) {
Scheme_Closure_Data *data2 = (Scheme_Closure_Data *)o_f;
int flags = SCHEME_CLOSURE_DATA_FLAGS(data2);
info->preserves_marks = !!(flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(flags & CLOS_SINGLE_RESULT);
if (flags & CLOS_RESULT_TENTATIVE) {
info->preserves_marks = -info->preserves_marks;
info->single_result = -info->single_result;
}
}
}
}
if (!f_is_proc && SCHEME_PROCP(f)) {
f_is_proc = f;
}
}
if (f_is_proc && (e_single_result > 0)) {
/* Just make it an application (N M): */
Scheme_App2_Rec *app2;
Scheme_Object *cloned;
app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
app2->iso.so.type = scheme_application2_type;
/* We'd like to try to inline here. The problem is that
e (the argument) has been optimized already,
which means it's in the wrong coordinate system.
If we can shift-clone it, then it will be back in the right
coordinates. */
cloned = scheme_optimize_clone(1, e, info, 0, 0);
if (cloned) {
app2->rator = f_is_proc;
app2->rand = cloned;
return optimize_application2((Scheme_Object *)app2, info);
} else {
app2->rator = f;
app2->rand = e;
return (Scheme_Object *)app2;
}
}
return scheme_make_syntax_compiled(APPVALS_EXPD, cons(f, e));
}
static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info) static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info)
{ {
Scheme_Sequence *s = (Scheme_Sequence *)o; Scheme_Sequence *s = (Scheme_Sequence *)o;
Scheme_Object *le; Scheme_Object *le;
int i; int i;
int drop = 0; int drop = 0, preserves_marks = 0, single_result = 0;
for (i = s->count; i--; ) { for (i = s->count; i--; ) {
le = scheme_optimize_expr(s->array[i], info); le = scheme_optimize_expr(s->array[i], info);
if (i == s->count - 1) {
single_result = info->single_result;
preserves_marks = info->preserves_marks;
}
/* Inlining and constant propagation can expose /* Inlining and constant propagation can expose
omittable expressions. */ omittable expressions. */
@ -2253,6 +2383,9 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info)
} }
} }
info->preserves_marks = preserves_marks;
info->single_result = single_result;
if (drop + 1 == s->count) { if (drop + 1 == s->count) {
return s->array[drop]; return s->array[drop];
} else if (drop) { } else if (drop) {
@ -2283,8 +2416,11 @@ int scheme_compiled_duplicate_ok(Scheme_Object *fb)
|| SAME_OBJ(fb, scheme_true) || SAME_OBJ(fb, scheme_true)
|| SCHEME_FALSEP(fb) || SCHEME_FALSEP(fb)
|| SCHEME_SYMBOLP(fb) || SCHEME_SYMBOLP(fb)
|| SCHEME_KEYWORDP(fb)
|| SCHEME_EOFP(fb)
|| SCHEME_INTP(fb) || SCHEME_INTP(fb)
|| SCHEME_NULLP(fb) || SCHEME_NULLP(fb)
|| (SCHEME_CHARP(fb) && (SCHEME_CHAR_VAL(fb) < 256))
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type) || SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type)
/* Values that are hashed by the printer to avoid /* Values that are hashed by the printer to avoid
duplication: */ duplication: */
@ -2299,6 +2435,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
{ {
Scheme_Branch_Rec *b; Scheme_Branch_Rec *b;
Scheme_Object *t, *tb, *fb; Scheme_Object *t, *tb, *fb;
int preserves_marks = 1, single_result = 1;
b = (Scheme_Branch_Rec *)o; b = (Scheme_Branch_Rec *)o;
@ -2338,8 +2475,17 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
tb = scheme_optimize_expr(tb, info); tb = scheme_optimize_expr(tb, info);
if (!info->preserves_marks) preserves_marks = 0;
if (!info->single_result) single_result = 0;
fb = scheme_optimize_expr(fb, info); fb = scheme_optimize_expr(fb, info);
if (!info->preserves_marks) preserves_marks = 0;
if (!info->single_result) single_result = 0;
info->preserves_marks = preserves_marks;
info->single_result = single_result;
/* Try optimize: (if x x #f) => x */ /* Try optimize: (if x x #f) => x */
if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type) if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type)
&& SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type) && SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type)
@ -2386,6 +2532,9 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info)
b = scheme_optimize_expr(wcm->body, info); b = scheme_optimize_expr(wcm->body, info);
/* info->single_result is already set */
info->preserves_marks = 0;
wcm->key = k; wcm->key = k;
wcm->val = v; wcm->val = v;
wcm->body = b; wcm->body = b;
@ -2423,6 +2572,9 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
} }
#endif #endif
info->preserves_marks = 1;
info->single_result = 1;
switch (type) { switch (type) {
case scheme_local_type: case scheme_local_type:
{ {
@ -2519,31 +2671,11 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
} }
} }
Scheme_Object *scheme_optimize_list(Scheme_Object *expr, Optimize_Info *info) Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_Info *info, int delta, int closure_depth)
{
Scheme_Object *first = scheme_null, *last = NULL;
while (SCHEME_PAIRP(expr)) {
Scheme_Object *pr;
pr = scheme_make_pair(scheme_optimize_expr(SCHEME_CAR(expr), info),
scheme_null);
if (last)
SCHEME_CDR(last) = pr;
else
first = pr;
last = pr;
expr = SCHEME_CDR(expr);
}
return first;
}
Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, int delta, int closure_depth)
/* Past closure_depth, need to reverse optimize to unoptimzed with respect to info; /* Past closure_depth, need to reverse optimize to unoptimzed with respect to info;
delta is the amount to skip in info to get to the frame that bound the code */ delta is the amount to skip in info to get to the frame that bound the code.
If dup_ok is 1, then the old copy will be dropped, so it's ok to "duplicate"
any constant. */
{ {
int t; int t;
@ -2566,7 +2698,7 @@ Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, i
f = scheme_syntax_cloners[SCHEME_PINT_VAL(expr)]; f = scheme_syntax_cloners[SCHEME_PINT_VAL(expr)];
if (!f) return NULL; if (!f) return NULL;
return f((Scheme_Object *)SCHEME_IPTR_VAL(expr), info, delta, closure_depth); return f(dup_ok, (Scheme_Object *)SCHEME_IPTR_VAL(expr), info, delta, closure_depth);
} }
case scheme_application2_type: case scheme_application2_type:
{ {
@ -2575,11 +2707,11 @@ Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, i
app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec); app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
app2->iso.so.type = scheme_application2_type; app2->iso.so.type = scheme_application2_type;
expr = scheme_optimize_clone(app->rator, info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, app->rator, info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
app2->rator = expr; app2->rator = expr;
expr = scheme_optimize_clone(app->rand, info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, app->rand, info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
app2->rand = expr; app2->rand = expr;
@ -2593,7 +2725,7 @@ Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, i
app2 = scheme_malloc_application(app->num_args + 1); app2 = scheme_malloc_application(app->num_args + 1);
for (i = app->num_args + 1; i--; ) { for (i = app->num_args + 1; i--; ) {
expr = scheme_optimize_clone(app->args[i], info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, app->args[i], info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
app2->args[i] = expr; app2->args[i] = expr;
} }
@ -2607,15 +2739,15 @@ Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, i
app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec); app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
app2->iso.so.type = scheme_application3_type; app2->iso.so.type = scheme_application3_type;
expr = scheme_optimize_clone(app->rator, info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, app->rator, info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
app2->rator = expr; app2->rator = expr;
expr = scheme_optimize_clone(app->rand1, info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, app->rand1, info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
app2->rand1 = expr; app2->rand1 = expr;
expr = scheme_optimize_clone(app->rand2, info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, app->rand2, info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
app2->rand2 = expr; app2->rand2 = expr;
@ -2649,7 +2781,7 @@ Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, i
lv2->position = lv->position; lv2->position = lv->position;
lv2->flags = flags; lv2->flags = flags;
expr = scheme_optimize_clone(lv->value, info, delta, closure_depth + head->count); expr = scheme_optimize_clone(dup_ok, lv->value, info, delta, closure_depth + head->count);
if (!expr) return NULL; if (!expr) return NULL;
lv2->value = expr; lv2->value = expr;
@ -2666,7 +2798,7 @@ Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, i
else else
head2->body = body; head2->body = body;
expr = scheme_optimize_clone(body, info, delta, closure_depth + head->count); expr = scheme_optimize_clone(dup_ok, body, info, delta, closure_depth + head->count);
if (!expr) return NULL; if (!expr) return NULL;
if (prev) if (prev)
@ -2687,7 +2819,7 @@ Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, i
seq2->count = seq->count; seq2->count = seq->count;
for (i = seq->count; i--; ) { for (i = seq->count; i--; ) {
expr = scheme_optimize_clone(seq->array[i], info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, seq->array[i], info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
seq2->array[i] = expr; seq2->array[i] = expr;
} }
@ -2701,28 +2833,28 @@ Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, i
b2 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); b2 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b2->so.type = scheme_branch_type; b2->so.type = scheme_branch_type;
expr = scheme_optimize_clone(b->test, info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, b->test, info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
b2->test = expr; b2->test = expr;
expr = scheme_optimize_clone(b->tbranch, info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, b->tbranch, info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
b2->tbranch = expr; b2->tbranch = expr;
expr = scheme_optimize_clone(b->fbranch, info, delta, closure_depth); expr = scheme_optimize_clone(dup_ok, b->fbranch, info, delta, closure_depth);
if (!expr) return NULL; if (!expr) return NULL;
b2->fbranch = expr; b2->fbranch = expr;
return (Scheme_Object *)b2; return (Scheme_Object *)b2;
} }
case scheme_compiled_unclosed_procedure_type: case scheme_compiled_unclosed_procedure_type:
return scheme_clone_closure_compilation(expr, info, delta, closure_depth); return scheme_clone_closure_compilation(dup_ok, expr, info, delta, closure_depth);
case scheme_compiled_toplevel_type: case scheme_compiled_toplevel_type:
case scheme_compiled_quote_syntax_type: case scheme_compiled_quote_syntax_type:
return expr; return expr;
default: default:
if (t > _scheme_compiled_values_types_) { if (t > _scheme_compiled_values_types_) {
if (scheme_compiled_duplicate_ok(expr)) if (dup_ok || scheme_compiled_duplicate_ok(expr))
return expr; return expr;
} }
} }
@ -4172,6 +4304,38 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
} }
} }
static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env)
{
Scheme_Object *l, *id, *form = lam;
int cnt = 0;
DupCheckRecord r;
lam = SCHEME_STX_CDR(lam);
if (!SCHEME_STX_PAIRP(lam)) return -1;
l = SCHEME_STX_CAR(lam);
lam = SCHEME_STX_CDR(lam);
if (!SCHEME_STX_PAIRP(lam)) return -1;
while (SCHEME_STX_PAIRP(lam)) { lam = SCHEME_STX_CDR(lam); }
if (!SCHEME_STX_NULLP(lam)) return -1;
scheme_begin_dup_symbol_check(&r, env);
while (SCHEME_STX_PAIRP(l)) {
id = SCHEME_STX_CAR(l);
scheme_check_identifier("lambda", id, NULL, env, form);
scheme_dup_symbol_check(&r, NULL, id, "argument", form);
l = SCHEME_STX_CDR(l);
cnt++;
}
if (!SCHEME_STX_NULLP(l)) return -1;
return cnt;
}
static Scheme_Object * static Scheme_Object *
compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
Scheme_Compile_Expand_Info *rec, int drec) Scheme_Compile_Expand_Info *rec, int drec)
@ -4197,8 +4361,8 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
form, form,
scheme_sys_wraps(env), scheme_sys_wraps(env),
0, 2); 0, 2);
} else if (!SCHEME_STX_PAIRP(form) /* will end in error */ } else if (!SCHEME_STX_PAIRP(form)) {
|| SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(form))) { /* will end in error */
if (rec[drec].comp) if (rec[drec].comp)
return compile_application(form, env, rec, drec); return compile_application(form, env, rec, drec);
else { else {
@ -4207,90 +4371,146 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
/* naya will be prefixed and returned... */ /* naya will be prefixed and returned... */
} }
} else if (rec[drec].comp) { } else if (rec[drec].comp) {
Scheme_Object *name; Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form;
name = SCHEME_STX_CAR(form); name = SCHEME_STX_CAR(form);
origname = name;
name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL);
/* look for ((lambda (x) ...) ...); */ /* look for ((lambda (x) ...) ...); */
/* rator as a macro has to be a parenthesized expr, otherwise the if (SAME_OBJ(gval, scheme_lambda_syntax)) {
parens for application would have been the macro call. */ Scheme_Object *argsnbody;
if (SCHEME_STX_PAIRP(name) && SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(name))) {
Scheme_Object *gval, *origname = name;
name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL);
if (SAME_OBJ(gval, scheme_lambda_syntax)) {
Scheme_Object *argsnbody;
argsnbody = SCHEME_STX_CDR(name); argsnbody = SCHEME_STX_CDR(name);
if (SCHEME_STX_PAIRP(argsnbody)) { if (SCHEME_STX_PAIRP(argsnbody)) {
Scheme_Object *args, *body; Scheme_Object *args, *body;
args = SCHEME_STX_CAR(argsnbody); args = SCHEME_STX_CAR(argsnbody);
body = SCHEME_STX_CDR(argsnbody); body = SCHEME_STX_CDR(argsnbody);
if (SCHEME_STX_PAIRP(body)) { if (SCHEME_STX_PAIRP(body)) {
int pl; int pl;
pl = scheme_stx_proper_list_length(args); pl = scheme_stx_proper_list_length(args);
if (pl >= 0) { if (pl >= 0) {
Scheme_Object *bindings = scheme_null, *last = NULL; Scheme_Object *bindings = scheme_null, *last = NULL;
Scheme_Object *rest; Scheme_Object *rest;
int al; int al;
rest = SCHEME_STX_CDR(form); rest = SCHEME_STX_CDR(form);
al = scheme_stx_proper_list_length(rest); al = scheme_stx_proper_list_length(rest);
if (al == pl) { if (al == pl) {
DupCheckRecord r; DupCheckRecord r;
scheme_begin_dup_symbol_check(&r, env); scheme_begin_dup_symbol_check(&r, env);
while (!SCHEME_STX_NULLP(args)) { while (!SCHEME_STX_NULLP(args)) {
Scheme_Object *v, *n; Scheme_Object *v, *n;
n = SCHEME_STX_CAR(args); n = SCHEME_STX_CAR(args);
scheme_check_identifier("lambda", n, NULL, env, name); scheme_check_identifier("lambda", n, NULL, env, name);
/* If we don't check here, the error is in terms of `let': */ /* If we don't check here, the error is in terms of `let': */
scheme_dup_symbol_check(&r, NULL, n, "argument", name); scheme_dup_symbol_check(&r, NULL, n, "argument", name);
v = SCHEME_STX_CAR(rest); v = SCHEME_STX_CAR(rest);
v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null); v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null);
if (last) if (last)
SCHEME_CDR(last) = v; SCHEME_CDR(last) = v;
else else
bindings = v; bindings = v;
last = v; last = v;
args = SCHEME_STX_CDR(args); args = SCHEME_STX_CDR(args);
rest = SCHEME_STX_CDR(rest); rest = SCHEME_STX_CDR(rest);
} }
body = scheme_datum_to_syntax(cons(let_values_symbol, body = scheme_datum_to_syntax(cons(let_values_symbol,
cons(bindings, cons(bindings,
body)), body)),
form, form,
scheme_sys_wraps(env), scheme_sys_wraps(env),
0, 2); 0, 2);
/* Copy certifications from lambda to `body'. */ /* Copy certifications from lambda to `body'. */
body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1); body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1);
return scheme_compile_expand_expr(body, env, rec, drec, 0); return scheme_compile_expand_expr(body, env, rec, drec, 0);
} else { } else {
#if 0 #if 0
scheme_wrong_syntax(scheme_application_stx_string, NULL, form, scheme_wrong_syntax(scheme_application_stx_string, NULL, form,
"procedure application: bad ((lambda (...) ...) ...) syntax"); "procedure application: bad ((lambda (...) ...) ...) syntax");
return NULL; return NULL;
#endif #endif
} }
} }
} }
}
} }
}
if (NOT_SAME_OBJ(name, origname)) { orig_rest_form = SCHEME_STX_CDR(form);
form = SCHEME_STX_CDR(form);
form = scheme_datum_to_syntax(scheme_make_immutable_pair(name, form), forms, forms, 0, 2); /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */
if (SCHEME_STX_SYMBOLP(name)) {
Scheme_Object *at_first, *at_second, *the_end, *cwv_stx;
at_first = SCHEME_STX_CDR(form);
if (SCHEME_STX_PAIRP(at_first)) {
at_second = SCHEME_STX_CDR(at_first);
if (SCHEME_STX_PAIRP(at_second)) {
the_end = SCHEME_STX_CDR(at_second);
if (SCHEME_STX_NULLP(the_end)) {
Scheme_Object *orig_at_second = at_second;
cwv_stx = scheme_datum_to_syntax(scheme_intern_symbol("call-with-values"),
scheme_false, scheme_sys_wraps(env), 0, 0);
if (scheme_stx_module_eq(name, cwv_stx, 0)) {
Scheme_Object *first, *orig_first;
orig_first = SCHEME_STX_CAR(at_first);
first = scheme_check_immediate_macro(orig_first, env, rec, drec, 0, &gval, NULL, NULL);
if (SAME_OBJ(gval, scheme_lambda_syntax)
&& SCHEME_STX_PAIRP(first)
&& (arg_count(first, env) == 0)) {
Scheme_Object *second, *orig_second;
orig_second = SCHEME_STX_CAR(at_second);
second = scheme_check_immediate_macro(orig_second, env, rec, drec, 0, &gval, NULL, NULL);
if (SAME_OBJ(gval, scheme_lambda_syntax)
&& SCHEME_STX_PAIRP(second)
&& (arg_count(second, env) >= 0)) {
Scheme_Object *lhs;
second = SCHEME_STX_CDR(second);
lhs = SCHEME_STX_CAR(second);
second = SCHEME_STX_CDR(second);
first = SCHEME_STX_CDR(first);
first = SCHEME_STX_CDR(first);
/* Convert to let-values: */
name = icons(let_values_symbol,
icons(icons(icons(lhs, icons(icons(begin_symbol, first),
scheme_null)),
scheme_null),
second));
form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2);
return scheme_compile_expand_expr(form, env, rec, drec, 0);
}
if (!SAME_OBJ(second, orig_second)) {
at_second = scheme_datum_to_syntax(icons(second, the_end), at_second, at_second, 0, 2);
}
}
if (!SAME_OBJ(first, orig_first)
|| !SAME_OBJ(at_second, orig_at_second)) {
at_first = scheme_datum_to_syntax(icons(first, at_second), at_first, at_first, 0, 2);
}
}
}
}
} }
rest_form = at_first;
} else {
rest_form = orig_rest_form;
}
if (NOT_SAME_OBJ(name, origname)
|| NOT_SAME_OBJ(rest_form, orig_rest_form)) {
form = scheme_datum_to_syntax(scheme_make_immutable_pair(name, rest_form), forms, forms, 0, 2);
} }
return compile_application(form, env, rec, drec); return compile_application(form, env, rec, drec);
@ -6468,7 +6688,7 @@ static void *eval_k(void)
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
Scheme_Object *v, **save_runstack; Scheme_Object *v, **save_runstack;
Scheme_Env *env; Scheme_Env *env;
int isexpr, multi, use_jit; int isexpr, multi, use_jit, as_tail;
v = (Scheme_Object *)p->ku.k.p1; v = (Scheme_Object *)p->ku.k.p1;
env = (Scheme_Env *)p->ku.k.p2; env = (Scheme_Env *)p->ku.k.p2;
@ -6476,6 +6696,7 @@ static void *eval_k(void)
p->ku.k.p2 = NULL; p->ku.k.p2 = NULL;
multi = p->ku.k.i1; multi = p->ku.k.i1;
isexpr = p->ku.k.i2; isexpr = p->ku.k.i2;
as_tail = p->ku.k.i3;
{ {
Scheme_Object *b; Scheme_Object *b;
@ -6508,7 +6729,30 @@ static void *eval_k(void)
save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase); save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase);
if (multi) if (as_tail) {
/* Cons up a closure to capture the prefix */
Scheme_Closure_Data *data;
mzshort *map;
int i, sz;
sz = (save_runstack XFORM_OK_MINUS MZ_RUNSTACK);
map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * sz);
for (i = 0; i < sz; i++) {
map[i] = i;
}
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
data->iso.so.type = scheme_compiled_unclosed_procedure_type;
data->num_params = 0;
data->max_let_depth = top->max_let_depth + sz;
data->closure_size = sz;
data->closure_map = map;
data->code = v;
v = scheme_make_closure(p, (Scheme_Object *)data, 1);
v = _scheme_tail_apply(v, 0, NULL);
} else if (multi)
v = _scheme_eval_linked_expr_multi_wp(v, p); v = _scheme_eval_linked_expr_multi_wp(v, p);
else else
v = _scheme_eval_linked_expr_wp(v, p); v = _scheme_eval_linked_expr_wp(v, p);
@ -6522,7 +6766,7 @@ static void *eval_k(void)
} }
static Scheme_Object *_eval(Scheme_Object *obj, Scheme_Env *env, static Scheme_Object *_eval(Scheme_Object *obj, Scheme_Env *env,
int isexpr, int multi, int top) int isexpr, int multi, int top, int as_tail)
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
@ -6530,6 +6774,7 @@ static Scheme_Object *_eval(Scheme_Object *obj, Scheme_Env *env,
p->ku.k.p2 = env; p->ku.k.p2 = env;
p->ku.k.i1 = multi; p->ku.k.i1 = multi;
p->ku.k.i2 = isexpr; p->ku.k.i2 = isexpr;
p->ku.k.i3 = as_tail;
if (top) if (top)
return (Scheme_Object *)scheme_top_level_do(eval_k, 1); return (Scheme_Object *)scheme_top_level_do(eval_k, 1);
@ -6539,32 +6784,32 @@ static Scheme_Object *_eval(Scheme_Object *obj, Scheme_Env *env,
Scheme_Object *scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env) Scheme_Object *scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env)
{ {
return _eval(obj, env, 0, 0, 1); return _eval(obj, env, 0, 0, 1, 0);
} }
Scheme_Object *scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env) Scheme_Object *scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env)
{ {
return _eval(obj, env, 0, 1, 1); return _eval(obj, env, 0, 1, 1, 0);
} }
Scheme_Object *_scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env) Scheme_Object *_scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env)
{ {
return _eval(obj, env, 0, 0, 0); return _eval(obj, env, 0, 0, 0, 0);
} }
Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env) Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env)
{ {
return _eval(obj, env, 0, 1, 0); return _eval(obj, env, 0, 1, 0, 0);
} }
Scheme_Object *scheme_eval_linked_expr(Scheme_Object *obj) Scheme_Object *scheme_eval_linked_expr(Scheme_Object *obj)
{ {
return _eval(obj, NULL, 1, 0, 1); return _eval(obj, NULL, 1, 0, 1, 0);
} }
Scheme_Object *scheme_eval_linked_expr_multi(Scheme_Object *obj) Scheme_Object *scheme_eval_linked_expr_multi(Scheme_Object *obj)
{ {
return _eval(obj, NULL, 1, 1, 1); return _eval(obj, NULL, 1, 1, 1, 0);
} }
/* for mzc: */ /* for mzc: */
@ -6713,34 +6958,16 @@ Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj)
return scheme_tail_eval(obj); return scheme_tail_eval(obj);
} }
static Scheme_Object *
do_default_eval_handler(Scheme_Env *env, int argc, Scheme_Object **argv)
{
Scheme_Object *v;
v = _compile(argv[0], env, 0, 1, 0, 0);
return _eval(v, env, 0, 1, 0);
}
static Scheme_Object *
do_default_compile_handler(Scheme_Env *env, int argc, Scheme_Object **argv)
{
return _compile(argv[0], env, SCHEME_FALSEP(argv[1]), 0, 0, 0);
}
/* local functions */ /* local functions */
static Scheme_Object * static Scheme_Object *
sch_eval(const char *who, int argc, Scheme_Object *argv[]) sch_eval(const char *who, int argc, Scheme_Object *argv[])
{ {
if (argc == 1) { if (argc == 1) {
return _scheme_apply_multi(scheme_get_param(scheme_current_config(), MZCONFIG_EVAL_HANDLER), return _scheme_tail_apply(scheme_get_param(scheme_current_config(), MZCONFIG_EVAL_HANDLER),
1, argv); 1, argv);
} else { } else {
Scheme_Config *config; Scheme_Config *config;
Scheme_Cont_Frame_Data cframe;
Scheme_Object *v;
if (SCHEME_TYPE(argv[1]) != scheme_namespace_type) if (SCHEME_TYPE(argv[1]) != scheme_namespace_type)
scheme_wrong_type(who, "namespace", 1, argc, argv); scheme_wrong_type(who, "namespace", 1, argc, argv);
@ -6748,15 +6975,10 @@ sch_eval(const char *who, int argc, Scheme_Object *argv[])
config = scheme_extend_config(scheme_current_config(), config = scheme_extend_config(scheme_current_config(),
MZCONFIG_ENV, MZCONFIG_ENV,
argv[1]); argv[1]);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
v = _scheme_apply_multi(scheme_get_param(config, MZCONFIG_EVAL_HANDLER), return _scheme_tail_apply(scheme_get_param(config, MZCONFIG_EVAL_HANDLER),
1, argv); 1, argv);
scheme_pop_continuation_frame(&cframe);
return v;
} }
} }
@ -6799,16 +7021,24 @@ Scheme_Object *
scheme_default_eval_handler(int argc, Scheme_Object **argv) scheme_default_eval_handler(int argc, Scheme_Object **argv)
{ {
Scheme_Env *env; Scheme_Env *env;
Scheme_Object *v;
env = scheme_get_env(NULL); env = scheme_get_env(NULL);
return do_default_eval_handler(env, argc, argv);
v = _compile(argv[0], env, 0, 1, 0, 0);
/* Returns a tail apply: */
return _eval(v, env, 0, 1, 0, 1);
} }
Scheme_Object * Scheme_Object *
scheme_default_compile_handler(int argc, Scheme_Object **argv) scheme_default_compile_handler(int argc, Scheme_Object **argv)
{ {
Scheme_Env *env; Scheme_Env *env;
env = scheme_get_env(NULL); env = scheme_get_env(NULL);
return do_default_compile_handler(env, argc, argv);
return _compile(argv[0], env, SCHEME_FALSEP(argv[1]), 0, 0, 0);
} }
static Scheme_Object * static Scheme_Object *
@ -7416,6 +7646,9 @@ void scheme_pop_prefix(Scheme_Object **rs)
where the abstract values are "not available", "value", "boxed where the abstract values are "not available", "value", "boxed
value", "syntax object", or "global array". */ value", "syntax object", or "global array". */
/* FIXME: validation doesn't check CLOS_SINGLE_RESULT or
CLOS_PRESERVES_MARKS. (Maybe check them in the JIT pass?) */
#define VALID_NOT 0 #define VALID_NOT 0
#define VALID_VAL 1 #define VALID_VAL 1
#define VALID_BOX 2 #define VALID_BOX 2

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

@ -72,6 +72,7 @@ int scheme_defining_primitives; /* set to 1 during start-up */
Scheme_Object scheme_void[1]; /* the void constant */ Scheme_Object scheme_void[1]; /* the void constant */
Scheme_Object *scheme_values_func; /* the function bound to `values' */ Scheme_Object *scheme_values_func; /* the function bound to `values' */
Scheme_Object *scheme_void_proc; Scheme_Object *scheme_void_proc;
Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
Scheme_Object *scheme_tail_call_waiting; Scheme_Object *scheme_tail_call_waiting;
@ -221,11 +222,14 @@ scheme_init_fun (Scheme_Env *env)
"ormap", "ormap",
2, -1), 2, -1),
env); env);
REGISTER_SO(scheme_call_with_values_proc);
scheme_call_with_values_proc = scheme_make_prim_w_arity2(call_with_values,
"call-with-values",
2, 2,
0, -1);
scheme_add_global_constant("call-with-values", scheme_add_global_constant("call-with-values",
scheme_make_prim_w_arity2(call_with_values, scheme_call_with_values_proc,
"call-with-values",
2, 2,
0, -1),
env); env);
REGISTER_SO(scheme_values_func); REGISTER_SO(scheme_values_func);
@ -796,6 +800,9 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
data = (Scheme_Closure_Data *)_data; data = (Scheme_Closure_Data *)_data;
info->single_result = 1;
info->preserves_marks = 1;
info = scheme_optimize_info_add_frame(info, data->num_params, data->num_params, info = scheme_optimize_info_add_frame(info, data->num_params, data->num_params,
SCHEME_LAMBDA_FRAME); SCHEME_LAMBDA_FRAME);
@ -807,6 +814,16 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
code = scheme_optimize_expr(data->code, info); code = scheme_optimize_expr(data->code, info);
if (info->single_result)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SINGLE_RESULT;
else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT)
SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_SINGLE_RESULT;
if (info->preserves_marks)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_PRESERVES_MARKS;
else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS)
SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_PRESERVES_MARKS;
data->code = code; data->code = code;
/* Remembers positions of used vars (and unsets usage for this level) */ /* Remembers positions of used vars (and unsets usage for this level) */
@ -828,7 +845,7 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
return (Scheme_Object *)data; return (Scheme_Object *)data;
} }
Scheme_Object *scheme_clone_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int delta, int closure_depth) Scheme_Object *scheme_clone_closure_compilation(int dup_ok, Scheme_Object *_data, Optimize_Info *info, int delta, int closure_depth)
{ {
Scheme_Closure_Data *data, *data2; Scheme_Closure_Data *data, *data2;
Scheme_Object *body; Scheme_Object *body;
@ -837,7 +854,7 @@ Scheme_Object *scheme_clone_closure_compilation(Scheme_Object *_data, Optimize_I
data = (Scheme_Closure_Data *)_data; data = (Scheme_Closure_Data *)_data;
body = scheme_optimize_clone(data->code, info, delta, closure_depth + data->num_params); body = scheme_optimize_clone(dup_ok, data->code, info, delta, closure_depth + data->num_params);
if (!body) return NULL; if (!body) return NULL;
data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data); data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
@ -1951,6 +1968,10 @@ scheme_apply_multi_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **ra
Scheme_Object * Scheme_Object *
scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands) scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{ {
/* NOTE: apply_values_execute (in syntax.c) and
tail_call_with_values_from_multiple_result (in jit.c)
assume that this function won't allocate when
num_rands <= p->tail_buffer_size. */
int i; int i;
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
@ -2984,173 +3005,37 @@ apply(int argc, Scheme_Object *argv[])
return SCHEME_TAIL_CALL_WAITING; return SCHEME_TAIL_CALL_WAITING;
} }
static Scheme_Object * #define DO_MAP map
do_map(int argc, Scheme_Object *argv[], char *name, int make_result, #define MAP_NAME "map"
int and_mode, int or_mode) #define MAP_MODE
/* common code for `map', `for-each', `andmap' and `ormap' */ #include "schmap.inc"
{ #undef MAP_MODE
# define NUM_QUICK_ARGS 3 #undef MAP_NAME
# define NUM_QUICK_RES 5 #undef DO_MAP
int i, size = 0, l, pos;
int can_multi;
Scheme_Object *quick1[NUM_QUICK_ARGS], *quick2[NUM_QUICK_ARGS];
Scheme_Object *quick3[NUM_QUICK_RES], **working, **args, **resarray;
Scheme_Object *v, *retval;
int cc;
can_multi = (!make_result && !and_mode && !or_mode); #define DO_MAP for_each
#define MAP_NAME "for-each"
#define FOR_EACH_MODE
#include "schmap.inc"
#undef FOR_EACH_MODE
#undef MAP_NAME
#undef DO_MAP
if (!SCHEME_PROCP(argv[0])) #define DO_MAP andmap
scheme_wrong_type(name, "procedure", 0, argc, argv); #define MAP_NAME "andmap"
#define AND_MODE
#include "schmap.inc"
#undef AND_MODE
#undef MAP_NAME
#undef DO_MAP
for (i = 1; i < argc; i++) { #define DO_MAP ormap
if (!SCHEME_LISTP (argv[i])) #define MAP_NAME "ormap"
scheme_wrong_type(name, "list", i, argc, argv); #define OR_MODE
#include "schmap.inc"
l = scheme_proper_list_length(argv[i]); #undef OR_MODE
#undef MAP_NAME
if (l < 0) #undef DO_MAP
scheme_wrong_type(name, "proper list", i, argc, argv);
if (i == 1)
size = l;
else if (size != l) {
char *argstr;
long alen;
argstr = scheme_make_args_string("", -1, argc, argv, &alen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: all lists must have same size%t",
name, argstr, alen);
return NULL;
}
}
if (SCHEME_FALSEP(scheme_get_or_check_arity(argv[0], argc - 1))) {
char *s;
long aelen;
s = scheme_make_arity_expect_string(argv[0], argc - 1, NULL, &aelen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: arity mismatch for %t", name,
s, aelen);
return NULL;
}
if (argc <= (NUM_QUICK_ARGS + 1)) {
args = quick1;
working = quick2;
} else {
args = MALLOC_N(Scheme_Object *, argc - 1);
working = MALLOC_N(Scheme_Object *, argc - 1);
}
if (size <= NUM_QUICK_RES) {
resarray = quick3;
} else {
if (make_result)
resarray = MALLOC_N(Scheme_Object *, size);
else
resarray = NULL;
}
/* Copy argc into working array */
for (i = 1; i < argc; i++) {
working[i-1] = argv[i];
}
--argc;
if (and_mode)
retval = scheme_true;
else if (or_mode)
retval = scheme_false;
else
retval = scheme_void;
pos = 0;
while (pos < size) {
/* collect args to apply */
for (i = 0; i < argc ; i++) {
if (!SCHEME_PAIRP(working[i])) {
/* There was a mutation! */
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: argument list mutated",
name);
return NULL;
}
args[i] = SCHEME_CAR(working[i]);
working[i] = SCHEME_CDR(working[i]);
}
cc = scheme_cont_capture_count;
if (can_multi)
v = _scheme_apply_multi(argv[0], argc, args);
else
v = _scheme_apply(argv[0], argc, args);
if (cc != scheme_cont_capture_count) {
/* Copy arrays to avoid messing with other continuations */
if (make_result && (size > NUM_QUICK_RES)) {
Scheme_Object **naya;
naya = MALLOC_N(Scheme_Object *, size);
memcpy(naya, resarray, pos * sizeof(Scheme_Object *));
resarray = naya;
}
if (argc > NUM_QUICK_ARGS) {
Scheme_Object **naya;
args = MALLOC_N(Scheme_Object *, argc);
naya = MALLOC_N(Scheme_Object *, argc);
memcpy(naya, working, argc * sizeof(Scheme_Object *));
working = naya;
}
}
if (make_result) {
resarray[pos] = v;
} else if (and_mode) {
if (SCHEME_FALSEP(v))
return scheme_false;
retval = v;
} else if (or_mode) {
if (SCHEME_TRUEP(v))
return v;
}
pos++;
}
if (make_result)
retval = scheme_build_list(size, resarray);
return retval;
}
static Scheme_Object *
map (int argc, Scheme_Object *argv[])
{
return do_map(argc, argv, "map", 1, 0, 0);
}
static Scheme_Object *
for_each (int argc, Scheme_Object *argv[])
{
return do_map(argc, argv, "for-each", 0, 0, 0);
}
static Scheme_Object *
andmap(int argc, Scheme_Object *argv[])
{
return do_map(argc, argv, "andmap", 0, 1, 0);
}
static Scheme_Object *
ormap(int argc, Scheme_Object *argv[])
{
return do_map(argc, argv, "ormap", 0, 0, 1);
}
static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[]) static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[])
{ {

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

File diff suppressed because it is too large Load Diff

2
src/mzscheme/src/lightning/i386/core.h
View File

@ -108,7 +108,7 @@ struct jit_local_state {
#define _jit_bra_l(rs, is, op) (CMPQir(is, rs), op, _jit.x.pc) #define _jit_bra_l(rs, is, op) (CMPQir(is, rs), op, _jit.x.pc)
#ifdef JIT_X86_64 #ifdef JIT_X86_64
# define jit_bra_l(rs, is, op) (_u32P((long)(is)) \ # define jit_bra_l(rs, is, op) (_s32P((long)(is)) \
? _jit_bra_l(rs, is, op) \ ? _jit_bra_l(rs, is, op) \
: (jit_movi_l(JIT_REXTMP, is), jit_bra_qr(JIT_REXTMP, rs, op))) : (jit_movi_l(JIT_REXTMP, is), jit_bra_qr(JIT_REXTMP, rs, op)))
#else #else

45
src/mzscheme/src/list.c
View File

@ -53,10 +53,6 @@ static Scheme_Object *member (int argc, Scheme_Object *argv[]);
static Scheme_Object *assv (int argc, Scheme_Object *argv[]); static Scheme_Object *assv (int argc, Scheme_Object *argv[]);
static Scheme_Object *assq (int argc, Scheme_Object *argv[]); static Scheme_Object *assq (int argc, Scheme_Object *argv[]);
static Scheme_Object *assoc (int argc, Scheme_Object *argv[]); static Scheme_Object *assoc (int argc, Scheme_Object *argv[]);
static Scheme_Object *caar_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *cadr_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *cdar_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *cddr_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *caaar_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *caaar_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *caadr_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *caadr_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *cadar_prim (int argc, Scheme_Object *argv[]); static Scheme_Object *cadar_prim (int argc, Scheme_Object *argv[]);
@ -257,26 +253,23 @@ scheme_init_list (Scheme_Env *env)
"assoc", "assoc",
2, 2), 2, 2),
env); env);
scheme_add_global_constant ("caar",
scheme_make_noncm_prim(caar_prim, p = scheme_make_noncm_prim(scheme_checked_caar, "caar", 1, 1);
"caar", SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
1, 1), scheme_add_global_constant ("caar", p, env);
env);
scheme_add_global_constant ("cadr", p = scheme_make_noncm_prim(scheme_checked_cadr, "cadr", 1, 1);
scheme_make_noncm_prim(cadr_prim, SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
"cadr", scheme_add_global_constant ("cadr", p, env);
1, 1),
env); p = scheme_make_noncm_prim(scheme_checked_cdar, "cdar", 1, 1);
scheme_add_global_constant ("cdar", SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_make_noncm_prim(cdar_prim, scheme_add_global_constant ("cdar", p, env);
"cdar",
1, 1), p = scheme_make_noncm_prim(scheme_checked_cddr, "cddr", 1, 1);
env); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("cddr", scheme_add_global_constant ("cddr", p, env);
scheme_make_noncm_prim(cddr_prim,
"cddr",
1, 1),
env);
scheme_add_global_constant ("caaar", scheme_add_global_constant ("caaar",
scheme_make_noncm_prim(caaar_prim, scheme_make_noncm_prim(caaar_prim,
"caaar", "caaar",
@ -1223,8 +1216,8 @@ GEN_ASS(assq, assq, SAME_OBJ)
GEN_ASS(assoc, assoc, scheme_equal) GEN_ASS(assoc, assoc, scheme_equal)
#define LISTFUNC2(name, C, D) \ #define LISTFUNC2(name, C, D) \
static Scheme_Object * \ Scheme_Object * \
name ## _prim (int argc, Scheme_Object *argv[]) \ scheme_checked_ ## name (int argc, Scheme_Object *argv[]) \
{ \ { \
if (!(SCHEME_PAIRP(argv[0]) \ if (!(SCHEME_PAIRP(argv[0]) \
&& SCHEME_PAIRP(D(argv[0])))) \ && SCHEME_PAIRP(D(argv[0])))) \

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

@ -3176,11 +3176,41 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port,
/* FIXME: validate exp-time code */ /* FIXME: validate exp-time code */
} }
static int set_code_closure_flags(Scheme_Object *clones,
int set_flags, int mask_flags)
{
Scheme_Object *clone, *orig, *first;
Scheme_Closure_Data *data;
int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS;
/* The first in a clone pair is the one that is consulted for
references. The second one is the original, and its the one whose
flags are updated by optimization. So consult the original, and set
flags in both. */
while (clones) {
first = SCHEME_CAR(clones);
clone = SCHEME_CAR(first);
orig = SCHEME_CDR(first);
data = (Scheme_Closure_Data *)orig;
flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
data = (Scheme_Closure_Data *)clone;
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
clones = SCHEME_CDR(clones);
}
return flags;
}
static Scheme_Object * static Scheme_Object *
module_optimize(Scheme_Object *data, Optimize_Info *info) module_optimize(Scheme_Object *data, Optimize_Info *info)
{ {
Scheme_Module *m = (Scheme_Module *)data; Scheme_Module *m = (Scheme_Module *)data;
Scheme_Object *e, *b, *vars, *start_simltaneous_b; Scheme_Object *e, *b, *vars, *start_simltaneous_b;
Scheme_Object *cl_first = NULL, *cl_last = NULL;
Scheme_Hash_Table *consts = NULL, *ready_table = NULL; Scheme_Hash_Table *consts = NULL, *ready_table = NULL;
int cont; int cont;
@ -3215,7 +3245,16 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
Scheme_Object *e2; Scheme_Object *e2;
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) {
e2 = scheme_optimize_clone(e, info, 0, 0); e2 = scheme_optimize_clone(1, e, info, 0, 0);
if (e2) {
Scheme_Object *pr;
pr = scheme_make_raw_pair(scheme_make_raw_pair(e2, e), NULL);
if (cl_last)
SCHEME_CDR(cl_last) = pr;
else
cl_first = pr;
cl_last = pr;
}
} else { } else {
e2 = e; e2 = e;
} }
@ -3272,6 +3311,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
if (!cont) { if (!cont) {
/* If we have new constants, re-optimize to inline: */ /* If we have new constants, re-optimize to inline: */
if (consts) { if (consts) {
int flags;
if (!info->top_level_consts) { if (!info->top_level_consts) {
info->top_level_consts = consts; info->top_level_consts = consts;
} else { } else {
@ -3285,8 +3326,16 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
} }
} }
/* Same as in letrec: assume CLOS_SINGLE_RESULT and
CLOS_PRESERVES_MARKS for all, but then assume not for all
if any turn out not (i.e., approximate fix point). */
(void)set_code_closure_flags(cl_first,
CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE,
0xFFFF);
while (1) { while (1) {
/* Re-optimize this expression: */ /* Re-optimize this expression. We can optimize anything without
shift-cloning, since there are no local variables in scope. */
e = scheme_optimize_expr(SCHEME_CAR(start_simltaneous_b), info); e = scheme_optimize_expr(SCHEME_CAR(start_simltaneous_b), info);
SCHEME_CAR(start_simltaneous_b) = e; SCHEME_CAR(start_simltaneous_b) = e;
@ -3294,8 +3343,14 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
break; break;
start_simltaneous_b = SCHEME_CDR(start_simltaneous_b); start_simltaneous_b = SCHEME_CDR(start_simltaneous_b);
} }
flags = set_code_closure_flags(cl_first, 0, 0xFFFF);
(void)set_code_closure_flags(cl_first,
(flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)),
~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE));
} }
cl_last = cl_first = NULL;
consts = NULL; consts = NULL;
start_simltaneous_b = SCHEME_CDR(b); start_simltaneous_b = SCHEME_CDR(b);
} }

6
src/mzscheme/src/regexp.c
View File

@ -2178,7 +2178,7 @@ static unsigned char *add_range(unsigned char *r, int *_j, RoomState *rs,
return add_byte_range(lo, hi, count, r, _j, rs, did_alt, 0); return add_byte_range(lo, hi, count, r, _j, rs, did_alt, 0);
} }
static int translate(unsigned char *s, int len, unsigned char **result) static int translate(unsigned char *s, int len, char **result)
{ {
int j; int j;
RoomState rs; RoomState rs;
@ -2468,7 +2468,7 @@ static int translate(unsigned char *s, int len, unsigned char **result)
} }
r[j] = 0; r[j] = 0;
*result = r; *result = (char *)r;
return j; return j;
} }
@ -2497,7 +2497,7 @@ static Scheme_Object *do_make_regexp(const char *who, int is_byte, int argc, Sch
slen = SCHEME_BYTE_STRTAG_VAL(bs); slen = SCHEME_BYTE_STRTAG_VAL(bs);
if (!is_byte) { if (!is_byte) {
slen = translate((unsigned char *)s, slen, (unsigned char **)&s); slen = translate((unsigned char *)s, slen, &s);
#if 0 #if 0
/* Debugging, to see the translated regexp: */ /* Debugging, to see the translated regexp: */
{ {

167
src/mzscheme/src/schmap.inc Normal file
View File

@ -0,0 +1,167 @@
/* common code for `map', `for-each', `andmap' and `ormap' */
/*
DO_MAP = C function name
MAP_NAME = Scheme function name as string
MAP_MODE => map
FOR_EACH_MODE => for-each
AND_MODE => and mode
OR_MODE => or mode
*/
static Scheme_Object *
DO_MAP(int argc, Scheme_Object *argv[])
{
# define NUM_QUICK_ARGS 3
# define NUM_QUICK_RES 5
int i, size = 0, l, pos;
Scheme_Object *quick1[NUM_QUICK_ARGS], *quick2[NUM_QUICK_ARGS];
Scheme_Object **working, **args;
# ifdef MAP_MODE
Scheme_Object *quick3[NUM_QUICK_RES], **resarray;
# endif
# ifndef FOR_EACH_MODE
Scheme_Object *v;
# endif
int cc;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_type(MAP_NAME, "procedure", 0, argc, argv);
for (i = 1; i < argc; i++) {
l = scheme_proper_list_length(argv[i]);
if (l < 0)
scheme_wrong_type(MAP_NAME, "proper list", i, argc, argv);
if (i == 1)
size = l;
else if (size != l) {
char *argstr;
long alen;
argstr = scheme_make_args_string("", -1, argc, argv, &alen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: all lists must have same size%t",
MAP_NAME, argstr, alen);
return NULL;
}
}
if (SCHEME_FALSEP(scheme_get_or_check_arity(argv[0], argc - 1))) {
char *s;
long aelen;
s = scheme_make_arity_expect_string(argv[0], argc - 1, NULL, &aelen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: arity mismatch for %t", MAP_NAME,
s, aelen);
return NULL;
}
if (argc <= (NUM_QUICK_ARGS + 1)) {
args = quick1;
working = quick2;
} else {
args = MALLOC_N(Scheme_Object *, argc - 1);
working = MALLOC_N(Scheme_Object *, argc - 1);
}
#ifdef MAP_MODE
if (size <= NUM_QUICK_RES)
resarray = quick3;
else
resarray = MALLOC_N(Scheme_Object *, size);
#endif
/* Copy argc into working array */
for (i = 1; i < argc; i++) {
working[i-1] = argv[i];
}
--argc;
pos = 0;
while (pos < size) {
/* collect args to apply */
for (i = 0; i < argc ; i++) {
if (!SCHEME_PAIRP(working[i])) {
/* There was a mutation! */
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: argument list mutated",
MAP_NAME);
return NULL;
}
args[i] = SCHEME_CAR(working[i]);
working[i] = SCHEME_CDR(working[i]);
}
cc = scheme_cont_capture_count;
#ifdef MAP_MODE
v = _scheme_apply(argv[0], argc, args);
#else
# ifdef FOR_EACH_MODE
if (pos + 1 == size) {
return _scheme_tail_apply(argv[0], argc, args);
} else {
_scheme_apply_multi(argv[0], argc, args);
}
# else
if (pos + 1 == size) {
return _scheme_tail_apply(argv[0], argc, args);
} else {
v = _scheme_apply(argv[0], argc, args);
}
# endif
#endif
if (cc != scheme_cont_capture_count) {
/* Copy arrays to avoid messing with other continuations */
#ifdef MAP_MODE
if (size > NUM_QUICK_RES) {
Scheme_Object **naya;
naya = MALLOC_N(Scheme_Object *, size);
memcpy(naya, resarray, pos * sizeof(Scheme_Object *));
resarray = naya;
}
#endif
if ((argc > NUM_QUICK_ARGS) && (pos + 1 < size)) {
Scheme_Object **naya;
args = MALLOC_N(Scheme_Object *, argc);
naya = MALLOC_N(Scheme_Object *, argc);
memcpy(naya, working, argc * sizeof(Scheme_Object *));
working = naya;
}
}
#ifdef MAP_MODE
resarray[pos] = v;
#endif
#ifdef AND_MODE
if (SCHEME_FALSEP(v))
return scheme_false;
#endif
#ifdef OR_MODE
if (SCHEME_TRUEP(v))
return v;
#endif
pos++;
}
#ifdef MAP_MODE
return scheme_build_list(size, resarray);
#endif
#ifdef FOR_EACH_MODE
return scheme_void;
#endif
#ifdef AND_MODE
return scheme_true;
#endif
#ifdef OR_MODE
return scheme_false;
#endif
}

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

@ -217,6 +217,7 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
extern Scheme_Object *scheme_values_func; extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_void_proc; extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_call_with_values_proc;
extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax; extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax;
extern Scheme_Object *scheme_lambda_syntax; extern Scheme_Object *scheme_lambda_syntax;
@ -1505,9 +1506,11 @@ typedef struct Scheme_Comp_Env
#define CLOS_HAS_REST 1 #define CLOS_HAS_REST 1
#define CLOS_HAS_REF_ARGS 2 #define CLOS_HAS_REF_ARGS 2
#define CLOS_ONLY_LOCALS 4 #define CLOS_PRESERVES_MARKS 4
#define CLOS_FOLDABLE 8 #define CLOS_FOLDABLE 8
#define CLOS_IS_METHOD 16 #define CLOS_IS_METHOD 16
#define CLOS_SINGLE_RESULT 32
#define CLOS_RESULT_TENTATIVE 64
typedef struct Scheme_Compile_Expand_Info typedef struct Scheme_Compile_Expand_Info
{ {
@ -1574,6 +1577,9 @@ typedef struct Optimize_Info
char letrec_not_twice, enforce_const; char letrec_not_twice, enforce_const;
Scheme_Hash_Table *top_level_consts; Scheme_Hash_Table *top_level_consts;
/* Set by expression optimization: */
int single_result, preserves_marks; /* negative means "tentative", due to fixpoint in progress */
char **stat_dists; /* (pos, depth) => used? */ char **stat_dists; /* (pos, depth) => used? */
int *sd_depths; int *sd_depths;
int used_toplevel; int used_toplevel;
@ -1581,7 +1587,7 @@ typedef struct Optimize_Info
} Optimize_Info; } Optimize_Info;
typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info); typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info);
typedef struct Scheme_Object *(*Scheme_Syntax_Cloner)(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); typedef struct Scheme_Object *(*Scheme_Syntax_Cloner)(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
typedef struct Scheme_Object *(*Scheme_Syntax_Shifter)(Scheme_Object *data, int delta, int after_depth); typedef struct Scheme_Object *(*Scheme_Syntax_Shifter)(Scheme_Object *data, int delta, int after_depth);
typedef struct CPort Mz_CPort; typedef struct CPort Mz_CPort;
@ -1629,7 +1635,7 @@ typedef struct {
#define ZERO_SIZED_CLOSUREP(closure) !(closure->code->closure_size) #define ZERO_SIZED_CLOSUREP(closure) !(closure->code->closure_size)
typedef struct Scheme_Native_Closure_Data { typedef struct Scheme_Native_Closure_Data {
MZTAG_IF_REQUIRED Scheme_Inclhash_Object iso; /* type tag only set when needed, but flags always needed */
Scheme_Closed_Prim *code; Scheme_Closed_Prim *code;
union { union {
void *tail_code; /* For non-case-lambda */ void *tail_code; /* For non-case-lambda */
@ -1757,7 +1763,8 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
#define REQUIRE_EXPD 8 #define REQUIRE_EXPD 8
#define DEFINE_FOR_SYNTAX_EXPD 9 #define DEFINE_FOR_SYNTAX_EXPD 9
#define REF_EXPD 10 #define REF_EXPD 10
#define _COUNT_EXPD_ 11 #define APPVALS_EXPD 11
#define _COUNT_EXPD_ 12
#define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, sh, pa) \ #define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, sh, pa) \
(scheme_syntax_optimizers[i] = fo, \ (scheme_syntax_optimizers[i] = fo, \
@ -1783,10 +1790,13 @@ Scheme_Object *scheme_make_syntax_resolved(int idx, Scheme_Object *data);
Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data); Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data);
Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *); Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *);
Scheme_Object *scheme_optimize_list(Scheme_Object *, Optimize_Info *);
Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline); Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline);
Scheme_Object *scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info); Scheme_Object *scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info);
Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
Optimize_Info *info,
int e_single_result);
int scheme_compiled_duplicate_ok(Scheme_Object *o); int scheme_compiled_duplicate_ok(Scheme_Object *o);
int scheme_compiled_propagate_ok(Scheme_Object *o, Optimize_Info *info); int scheme_compiled_propagate_ok(Scheme_Object *o, Optimize_Info *info);
@ -1820,9 +1830,9 @@ void scheme_optimize_mutated(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated); Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated);
int scheme_optimize_is_used(Optimize_Info *info, int pos); int scheme_optimize_is_used(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_clone(Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth); Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth);
Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth); Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth);
Scheme_Object *scheme_clone_closure_compilation(Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth); Scheme_Object *scheme_clone_closure_compilation(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth);
Scheme_Object *scheme_shift_closure_compilation(Scheme_Object *obj, int delta, int after_depth); Scheme_Object *scheme_shift_closure_compilation(Scheme_Object *obj, int delta, int after_depth);
int scheme_closure_body_size(Scheme_Closure_Data *closure_data, int check_assign); int scheme_closure_body_size(Scheme_Closure_Data *closure_data, int check_assign);
@ -2512,6 +2522,10 @@ void scheme_count_generic(Scheme_Object *o, long *s, long *e, Scheme_Hash_Table
Scheme_Object *scheme_checked_car(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_car(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_cdr(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_cdr(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_caar(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_cadr(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_cdar(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_cddr(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_vector_set(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_vector_set(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_string_ref(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_string_ref(int argc, Scheme_Object *argv[]);

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 352 #define MZSCHEME_VERSION_MAJOR 352
#define MZSCHEME_VERSION_MINOR 4 #define MZSCHEME_VERSION_MINOR 5
#define MZSCHEME_VERSION "352.4" _MZ_SPECIAL_TAG #define MZSCHEME_VERSION "352.5" _MZ_SPECIAL_TAG

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

@ -357,9 +357,9 @@ static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev)
if (c->cont) { if (c->cont) {
#ifdef STACK_GROWS_UP #ifdef STACK_GROWS_UP
top_delta = ((unsigned long)c->stack_from top_delta = (((unsigned long)c->cont->buf.stack_from
- ((unsigned long)c->cont->buf.stack_from + c->cont->buf.stack_size)
+ c->cont->buf.stack_size)); - (unsigned long)c->stack_from);
#else #else
bottom_delta = ((unsigned long)c->stack_from bottom_delta = ((unsigned long)c->stack_from
+ c->stack_size + c->stack_size

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

@ -2554,8 +2554,7 @@
"((_() expr1 expr ...)(syntax/loc stx(let() expr1 expr ...)))" "((_() expr1 expr ...)(syntax/loc stx(let() expr1 expr ...)))"
"((_((pred handler) ...) expr1 expr ...)" "((_((pred handler) ...) expr1 expr ...)"
"(quasisyntax/loc stx" "(quasisyntax/loc stx"
"(let((l(list(cons pred handler) ...))" "(let((l(list(cons pred handler) ...)))"
"(body(lambda() expr1 expr ...)))"
"(let((bpz(continuation-mark-set-first #f break-enabled-key)))" "(let((bpz(continuation-mark-set-first #f break-enabled-key)))"
"(with-continuation-mark" "(with-continuation-mark"
" break-enabled-key" " break-enabled-key"
@ -2589,7 +2588,7 @@
"((cdar l) e)))))" "((cdar l) e)))))"
"(else" "(else"
"(loop(cdr l))))))))))" "(loop(cdr l))))))))))"
"(call-with-values body" "(call-with-values(lambda() expr1 expr ...)"
"(lambda args(lambda()(apply values args)))))))))))))))))))" "(lambda args(lambda()(apply values args)))))))))))))))))))"
"(values(wh #t)(wh #f))))" "(values(wh #t)(wh #f))))"
"(define-syntax set!-values" "(define-syntax set!-values"

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

@ -2943,8 +2943,7 @@
[(_ () expr1 expr ...) (syntax/loc stx (let () expr1 expr ...))] [(_ () expr1 expr ...) (syntax/loc stx (let () expr1 expr ...))]
[(_ ([pred handler] ...) expr1 expr ...) [(_ ([pred handler] ...) expr1 expr ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([l (list (cons pred handler) ...)] (let ([l (list (cons pred handler) ...)])
[body (lambda () expr1 expr ...)])
;; Capture current break parameterization, so we can use it to ;; Capture current break parameterization, so we can use it to
;; evaluate the body ;; evaluate the body
(let ([bpz (continuation-mark-set-first #f break-enabled-key)]) (let ([bpz (continuation-mark-set-first #f break-enabled-key)])
@ -2988,7 +2987,7 @@
((cdar l) e))))] ((cdar l) e))))]
[else [else
(loop (cdr l))])))))]) (loop (cdr l))])))))])
(call-with-values body (call-with-values (lambda () expr1 expr ...)
(lambda args (lambda () (apply values args)))))))))))))])))]) (lambda args (lambda () (apply values args)))))))))))))])))])
(values (wh #t) (wh #f)))) (values (wh #t) (wh #f))))

326
src/mzscheme/src/syntax.c
View File

@ -97,6 +97,7 @@ static Scheme_Object *define_syntaxes_execute(Scheme_Object *expr);
static Scheme_Object *define_for_syntaxes_execute(Scheme_Object *expr); static Scheme_Object *define_for_syntaxes_execute(Scheme_Object *expr);
static Scheme_Object *case_lambda_execute(Scheme_Object *expr); static Scheme_Object *case_lambda_execute(Scheme_Object *expr);
static Scheme_Object *begin0_execute(Scheme_Object *data); static Scheme_Object *begin0_execute(Scheme_Object *data);
static Scheme_Object *apply_values_execute(Scheme_Object *data);
static Scheme_Object *bangboxenv_execute(Scheme_Object *data); static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
static Scheme_Object *bangboxvalue_execute(Scheme_Object *data); static Scheme_Object *bangboxvalue_execute(Scheme_Object *data);
@ -108,14 +109,17 @@ static Scheme_Object *define_syntaxes_optimize(Scheme_Object *expr, Optimize_Inf
static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info); static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info);
static Scheme_Object *case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info); static Scheme_Object *case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info);
static Scheme_Object *begin0_optimize(Scheme_Object *data, Optimize_Info *info); static Scheme_Object *begin0_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *apply_values_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *begin0_clone(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); static Scheme_Object *begin0_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *set_clone(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); static Scheme_Object *set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *begin0_shift(Scheme_Object *data, int delta, int after_depth); static Scheme_Object *begin0_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth); static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *ref_shift(Scheme_Object *data, int delta, int after_depth); static Scheme_Object *ref_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *case_lambda_shift(Scheme_Object *data, int delta, int after_depth); static Scheme_Object *case_lambda_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *apply_values_shift(Scheme_Object *data, int delta, int after_depth);
static Scheme_Object *define_values_resolve(Scheme_Object *data, Resolve_Info *info); static Scheme_Object *define_values_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *ref_resolve(Scheme_Object *data, Resolve_Info *info); static Scheme_Object *ref_resolve(Scheme_Object *data, Resolve_Info *info);
@ -124,6 +128,7 @@ static Scheme_Object *define_syntaxes_resolve(Scheme_Object *expr, Resolve_Info
static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *expr, Resolve_Info *info); static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *expr, Resolve_Info *info);
static Scheme_Object *case_lambda_resolve(Scheme_Object *expr, Resolve_Info *info); static Scheme_Object *case_lambda_resolve(Scheme_Object *expr, Resolve_Info *info);
static Scheme_Object *begin0_resolve(Scheme_Object *data, Resolve_Info *info); static Scheme_Object *begin0_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *apply_values_resolve(Scheme_Object *data, Resolve_Info *info);
static void define_values_validate(Scheme_Object *data, Mz_CPort *port, static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls, char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
@ -153,6 +158,10 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls, char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts); int num_toplevels, int num_stxes, int num_lifts);
static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls, char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta, int depth, int letlimit, int delta,
@ -169,6 +178,7 @@ static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr);
static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr); static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr);
static Scheme_Object *case_lambda_jit(Scheme_Object *expr); static Scheme_Object *case_lambda_jit(Scheme_Object *expr);
static Scheme_Object *begin0_jit(Scheme_Object *data); static Scheme_Object *begin0_jit(Scheme_Object *data);
static Scheme_Object *apply_values_jit(Scheme_Object *data);
static Scheme_Object *bangboxvalue_jit(Scheme_Object *data); static Scheme_Object *bangboxvalue_jit(Scheme_Object *data);
static Scheme_Object *expand_lam(int argc, Scheme_Object **argv); static Scheme_Object *expand_lam(int argc, Scheme_Object **argv);
@ -277,6 +287,12 @@ scheme_init_syntax (Scheme_Env *env)
begin0_execute, begin0_jit, begin0_execute, begin0_jit,
begin0_clone, begin0_shift, -1); begin0_clone, begin0_shift, -1);
scheme_register_syntax(APPVALS_EXPD,
apply_values_optimize,
apply_values_resolve, apply_values_validate,
apply_values_execute, apply_values_jit,
apply_values_clone, apply_values_shift, 1);
scheme_register_syntax(BOXENV_EXPD, scheme_register_syntax(BOXENV_EXPD,
NULL, NULL, bangboxenv_validate, NULL, NULL, bangboxenv_validate,
bangboxenv_execute, NULL, bangboxenv_execute, NULL,
@ -1378,6 +1394,9 @@ set_optimize(Scheme_Object *data, Optimize_Info *info)
val = scheme_optimize_expr(val, info); val = scheme_optimize_expr(val, info);
info->preserves_marks = 1;
info->single_result = 1;
if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
int pos, delta; int pos, delta;
@ -1398,7 +1417,7 @@ set_optimize(Scheme_Object *data, Optimize_Info *info)
} }
static Scheme_Object * static Scheme_Object *
set_clone(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth) set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
{ {
Scheme_Object *var, *val, *set_undef; Scheme_Object *var, *val, *set_undef;
@ -1407,10 +1426,10 @@ set_clone(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth
var = SCHEME_CAR(data); var = SCHEME_CAR(data);
val = SCHEME_CDR(data); val = SCHEME_CDR(data);
val = scheme_optimize_clone(val, info, delta, closure_depth); val = scheme_optimize_clone(dup_ok, val, info, delta, closure_depth);
if (!val) return NULL; if (!val) return NULL;
if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
var = scheme_optimize_clone(var, info, delta, closure_depth); var = scheme_optimize_clone(dup_ok, var, info, delta, closure_depth);
if (!var) return NULL; if (!var) return NULL;
} }
@ -1650,7 +1669,7 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
} }
/**********************************************************************/ /**********************************************************************/
/* #%variable-reference */ /* #%variable-reference */
/**********************************************************************/ /**********************************************************************/
static Scheme_Object * static Scheme_Object *
@ -1685,8 +1704,11 @@ static void ref_validate(Scheme_Object *tl, Mz_CPort *port,
} }
static Scheme_Object * static Scheme_Object *
ref_optimize(Scheme_Object *tl, Optimize_Info *rslv) ref_optimize(Scheme_Object *tl, Optimize_Info *info)
{ {
info->preserves_marks = 1;
info->single_result = 1;
return scheme_make_syntax_compiled(REF_EXPD, tl); return scheme_make_syntax_compiled(REF_EXPD, tl);
} }
@ -1782,6 +1804,134 @@ ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
return form; return form;
} }
/**********************************************************************/
/* apply-values */
/**********************************************************************/
static Scheme_Object *apply_values_execute(Scheme_Object *data)
{
Scheme_Object *f, *v;
f = SCHEME_CAR(data);
f = _scheme_eval_linked_expr_multi(f);
if (!SCHEME_PROCP(f)) {
Scheme_Object *a[1];
a[0] = f;
scheme_wrong_type("call-with-values", "procedure", -1, 1, a);
return NULL;
}
v = _scheme_eval_linked_expr_multi(SCHEME_CDR(data));
if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
Scheme_Thread *p = scheme_current_thread;
int num_rands = p->ku.multiple.count;
if (num_rands > p->tail_buffer_size) {
/* scheme_tail_apply will allocate */
if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
p->values_buffer = NULL;
}
return scheme_tail_apply(f, num_rands, p->ku.multiple.array);
} else {
Scheme_Object *a[1];
a[0] = v;
return scheme_tail_apply(f, 1, a);
}
}
static Scheme_Object *apply_values_jit(Scheme_Object *data)
{
Scheme_Object *f, *e;
f = scheme_jit_expr(SCHEME_CAR(data));
e = scheme_jit_expr(SCHEME_CDR(data));
if (SAME_OBJ(f, SCHEME_CAR(data))
&& SAME_OBJ(e, SCHEME_CAR(data)))
return data;
else
return scheme_make_pair(f, e);
}
static Scheme_Object *
apply_values_optimize(Scheme_Object *data, Optimize_Info *info)
{
Scheme_Object *f, *e;
f = SCHEME_CAR(data);
e = SCHEME_CDR(data);
f = scheme_optimize_expr(f, info);
e = scheme_optimize_expr(e, info);
return scheme_optimize_apply_values(f, e, info, info->single_result);
}
static Scheme_Object *
apply_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
Scheme_Object *f, *e;
f = SCHEME_CAR(data);
e = SCHEME_CDR(data);
f = scheme_resolve_expr(f, rslv);
e = scheme_resolve_expr(e, rslv);
return scheme_make_syntax_resolved(APPVALS_EXPD, cons(f, e));
}
static Scheme_Object *
apply_values_shift(Scheme_Object *data, int delta, int after_depth)
{
Scheme_Object *e;
e = scheme_optimize_shift(SCHEME_CAR(data), delta, after_depth);
SCHEME_CAR(data) = e;
e = scheme_optimize_shift(SCHEME_CDR(data), delta, after_depth);
SCHEME_CAR(data) = e;
return scheme_make_syntax_compiled(APPVALS_EXPD, data);
}
static Scheme_Object *
apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
{
Scheme_Object *f, *e;
f = SCHEME_CAR(data);
e = SCHEME_CDR(data);
f = scheme_optimize_clone(dup_ok, f, info, delta, closure_depth);
if (!f) return NULL;
e = scheme_optimize_clone(dup_ok, e, info, delta, closure_depth);
if (!e) return NULL;
return scheme_make_syntax_compiled(APPVALS_EXPD, cons(f, e));
}
static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts)
{
Scheme_Object *f, *e;
f = SCHEME_CAR(data);
e = SCHEME_CDR(data);
scheme_validate_expr(port, f, stack, ht, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0);
scheme_validate_expr(port, e, stack, ht, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0);
}
/**********************************************************************/ /**********************************************************************/
/* case-lambda */ /* case-lambda */
/**********************************************************************/ /**********************************************************************/
@ -1976,6 +2126,9 @@ case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info)
seq->array[i] = le; seq->array[i] = le;
} }
info->preserves_marks = 1;
info->single_result = 1;
return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr); return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr);
} }
@ -2421,6 +2574,71 @@ int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info)
return 0; return 0;
} }
static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start,
Scheme_Compiled_Let_Value *pre_body,
Optimize_Info *body_info)
{
Scheme_Compiled_Let_Value *clv;
Scheme_Object *value, *clone, *pr;
Scheme_Object *last = NULL, *first = NULL;
clv = retry_start;
while (1) {
value = clv->value;
if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) {
clone = scheme_optimize_clone(1, value, body_info, 0, 0);
if (clone) {
pr = scheme_make_raw_pair(scheme_make_raw_pair(value, clone), NULL);
if (last)
SCHEME_CDR(last) = pr;
else
first = pr;
last = pr;
}
}
if (clv == pre_body)
break;
clv = (Scheme_Compiled_Let_Value *)clv->body;
}
return first;
}
static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
Scheme_Compiled_Let_Value *pre_body,
Scheme_Object *clones,
int set_flags, int mask_flags)
{
Scheme_Compiled_Let_Value *clv;
Scheme_Object *value, *first;
int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS;
/* The first in a clone pair is the one that is consulted for
references. The second one is the clone, and its the one whose
flags are updated by optimization. So consult the clone, and set
flags in both. */
clv = retry_start;
while (clones) {
value = retry_start->value;
first = SCHEME_CAR(clones);
if (SAME_OBJ(value, SCHEME_CAR(first))) {
Scheme_Closure_Data *data;
data = (Scheme_Closure_Data *)SCHEME_CDR(first);
flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
data = (Scheme_Closure_Data *)SCHEME_CAR(first);
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
clones = SCHEME_CDR(clones);
}
if (clv == pre_body)
break;
clv = (Scheme_Compiled_Let_Value *)clv->body;
}
return flags;
}
Scheme_Object * Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
{ {
@ -2448,6 +2666,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
} else { } else {
info = scheme_optimize_info_add_frame(info, 1, 0, 0); info = scheme_optimize_info_add_frame(info, 1, 0, 0);
body = scheme_optimize_expr(clv->value, info); body = scheme_optimize_expr(clv->value, info);
info->next->single_result = info->single_result;
info->next->preserves_marks = info->preserves_marks;
scheme_optimize_info_done(info); scheme_optimize_info_done(info);
return body; return body;
} }
@ -2510,7 +2730,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
if ((vpos < head->count) && (vpos >= pos)) if ((vpos < head->count) && (vpos >= pos))
value = NULL; value = NULL;
else { else {
/* Convert value back to a pre-optimized local coordinate. /* Convert value back to a pre-optimized local coordinates.
This must be done with respect to body_info, not This must be done with respect to body_info, not
rhs_info, because we attach the value to body_info: */ rhs_info, because we attach the value to body_info: */
value = scheme_optimize_reverse(body_info, vpos, 1); value = scheme_optimize_reverse(body_info, vpos, 1);
@ -2531,37 +2751,59 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
&& !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5)))) { && !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5)))) {
if (did_set_value) { if (did_set_value) {
/* Next RHS ends a reorderable sequence. /* Next RHS ends a reorderable sequence.
Re-optimize from retry_start to pre_body, inclusive. */ Re-optimize from retry_start to pre_body, inclusive.
For procedures, assume CLOS_SINGLE_RESULT and CLOS_PRESERVES_MARKS for all,
but then assume not for all if any turn out not (i.e., approximate fix point). */
int flags;
Scheme_Object *clones, *cl, *cl_first;
/* Set-flags loop: */
clones = make_clones(retry_start, pre_body, body_info);
(void)set_code_flags(retry_start, pre_body, clones,
CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE,
0xFFFF);
/* Re-optimize loop: */
clv = retry_start;
cl = clones;
while (1) { while (1) {
value = retry_start->value; value = clv->value;
if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) { if (cl)
cl_first = SCHEME_CAR(cl);
else
cl_first = NULL;
if (cl_first && SAME_OBJ(value, SCHEME_CAR(cl_first))) {
/* Try optimization. */
Scheme_Object *self_value; Scheme_Object *self_value;
self_value = scheme_optimize_clone(value, body_info, 0, 0); int sz;
if (self_value) {
/* Try optimization. */
int sz;
/* Drop old size, and remove old inline fuel: */ cl = SCHEME_CDR(cl);
sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 0); self_value = SCHEME_CDR(cl_first);
body_info->size -= (sz + 1);
/* Setting letrec_not_twice prevents inlinining /* Drop old size, and remove old inline fuel: */
of letrec bindings in this RHS. There's a small sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 0);
chance that we miss some optimizations, but we body_info->size -= (sz + 1);
avoid the possibility of N^2 behavior. */
body_info->letrec_not_twice = 1; /* Setting letrec_not_twice prevents inlinining
of letrec bindings in this RHS. There's a small
value = scheme_optimize_expr(self_value, body_info); chance that we miss some optimizations, but we
avoid the possibility of N^2 behavior. */
body_info->letrec_not_twice = 0; body_info->letrec_not_twice = 1;
retry_start->value = value; value = scheme_optimize_expr(self_value, body_info);
}
body_info->letrec_not_twice = 0;
clv->value = value;
} }
if (retry_start == pre_body) if (clv == pre_body)
break; break;
retry_start = (Scheme_Compiled_Let_Value *)retry_start->body; clv = (Scheme_Compiled_Let_Value *)clv->body;
} }
/* Check flags loop: */
flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF);
/* Reset-flags loop: */
(void)set_code_flags(retry_start, pre_body, clones,
(flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)),
~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE));
} }
retry_start = NULL; retry_start = NULL;
did_set_value = 0; did_set_value = 0;
@ -2580,6 +2822,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
pre_body->body = body; pre_body->body = body;
info->size += 1; info->size += 1;
info->single_result = body_info->single_result;
info->preserves_marks = body_info->preserves_marks;
/* Clear used flags where possible */ /* Clear used flags where possible */
if (all_simple) { if (all_simple) {
body = head->body; body = head->body;
@ -2637,6 +2882,9 @@ scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info)
form = scheme_optimize_expr((Scheme_Object *)b3, sub_info); form = scheme_optimize_expr((Scheme_Object *)b3, sub_info);
info->single_result = sub_info->single_result;
info->preserves_marks = sub_info->preserves_marks;
scheme_optimize_info_done(sub_info); scheme_optimize_info_done(sub_info);
return form; return form;
@ -3720,15 +3968,15 @@ Scheme_Object *scheme_compiled_void()
static Scheme_Object * static Scheme_Object *
begin0_execute(Scheme_Object *obj) begin0_execute(Scheme_Object *obj)
{ {
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *v, **mv; Scheme_Object *v, **mv;
int i, mc, apos; int i, mc, apos;
i = ((Scheme_Sequence *)obj)->count; i = ((Scheme_Sequence *)obj)->count;
v = _scheme_eval_linked_expr_multi_wp(((Scheme_Sequence *)obj)->array[0], p); v = _scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[0]);
i--; i--;
if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) { if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
Scheme_Thread *p = scheme_current_thread;
mv = p->ku.multiple.array; mv = p->ku.multiple.array;
mc = p->ku.multiple.count; mc = p->ku.multiple.count;
if (SAME_OBJ(mv, p->values_buffer)) if (SAME_OBJ(mv, p->values_buffer))
@ -3740,10 +3988,11 @@ begin0_execute(Scheme_Object *obj)
apos = 1; apos = 1;
while (i--) { while (i--) {
(void)_scheme_eval_linked_expr_multi_wp(((Scheme_Sequence *)obj)->array[apos++], p); (void)_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++]);
} }
if (mv) { if (mv) {
Scheme_Thread *p = scheme_current_thread;
p->ku.multiple.array = mv; p->ku.multiple.array = mv;
p->ku.multiple.count = mc; p->ku.multiple.count = mc;
} }
@ -3815,13 +4064,16 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info)
((Scheme_Sequence *)obj)->array[i] = le; ((Scheme_Sequence *)obj)->array[i] = le;
} }
/* Optimization of expression 0 has already set single_result */
info->preserves_marks = 1;
return scheme_make_syntax_compiled(BEGIN0_EXPD, obj); return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
} }
static Scheme_Object * static Scheme_Object *
begin0_clone(Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth) begin0_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth)
{ {
obj = scheme_optimize_clone(obj, info, delta, closure_depth); obj = scheme_optimize_clone(dup_ok, obj, info, delta, closure_depth);
if (!obj) return NULL; if (!obj) return NULL;
return scheme_make_syntax_compiled(BEGIN0_EXPD, obj); return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
} }