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

v301.4

Browse Source 
svn: r2046
This commit is contained in:
Matthew Flatt 2006-01-30 19:22:10 +00:00
parent af295c954e
commit adaf67929a
73 changed files with 14483 additions and 3804 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/mzscheme/cmdline.inc
View File

@ -733,6 +733,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
argv[0] = "-v";
else if (!strcmp("--no-init-file", argv[0]))
argv[0] = "-q";
else if (!strcmp("--no-jit", argv[0]))
argv[0] = "-j";
else if (!strcmp("--no-argv", argv[0]))
argv[0] = "-A";
else if (!strcmp("--mute-banner", argv[0]))
@ -955,6 +957,9 @@ static int run_from_cmd_line(int argc, char *_argv[],
case '-':
no_more_switches = 1;
break;
case 'j':
scheme_set_startup_use_jit(0);
break;
case 'b':
scheme_set_binary_mode_stdio(1);
break;
@ -1021,7 +1026,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
#endif
}
#endif /* DONT_PARSE_COMMAND_LINE */
global_env = mk_basic_env();
sch_argv = scheme_make_vector(argc, NULL);
@ -1127,6 +1132,11 @@ static int run_from_cmd_line(int argc, char *_argv[],
" -x, --no-lib-path : Skips trying to set current-library-collection-paths.\n"
" -q, --no-init-file : Skips trying to load " INIT_FILENAME ".\n"
" -A : Skips defining `argv' and `program'.\n"
# ifdef MZ_USE_JIT
" -j, --no-jit : Disables just-in-time compiler.\n"
# else
" -j, --no-jit : No effect, since the just-in-time compiler is unavailable.\n"
# endif
" Language setting switches:\n"
" -g, --case-sens : Identifiers/symbols are initially case-sensitive.\n"
" -G, --case-insens : Identifiers/symbols are initially case-insensitive.\n"

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

@ -175,7 +175,7 @@ $(XSRCDIR)/sema.c: ../src/sema.@LTO@ $(XFORMDEP)
$(XSRCDIR)/setjmpup.c: ../src/setjmpup.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/setjmpup.c $(SRCDIR)/setjmpup.c
$(XSRCDIR)/string.c: ../src/string.@LTO@ $(XFORMDEP)
$(XFORM_SETUP) --cpp "$(CPP) -I$(OBJDIR) $(CPPFLAGS)" -o $(XSRCDIR)/string.c $(SRCDIR)/string.c
$(XFORM_SETUP) --cpp "$(CPP) -I../src $(CPPFLAGS)" -o $(XSRCDIR)/string.c $(SRCDIR)/string.c
$(XSRCDIR)/struct.c: ../src/struct.@LTO@ $(XFORMDEP)
$(XFORM) $(XSRCDIR)/struct.c $(SRCDIR)/struct.c
$(XSRCDIR)/stxobj.c: ../src/stxobj.@LTO@ $(XFORMDEP)

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

@ -128,6 +128,7 @@ scheme_tail_apply_to_list
scheme_tail_eval_expr
scheme_set_tail_buffer_size
scheme_force_value
scheme_force_one_value
scheme_set_cont_mark
scheme_push_continuation_frame
scheme_pop_continuation_frame
@ -183,6 +184,7 @@ scheme_make_noneternal_prim
scheme_make_closed_prim
scheme_make_prim_w_arity
scheme_make_folding_prim
scheme_make_noncm_prim
scheme_make_noneternal_prim_w_arity
scheme_make_closed_prim_w_arity
scheme_make_folding_closed_prim

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

@ -128,6 +128,7 @@ scheme_tail_apply_to_list
scheme_tail_eval_expr
scheme_set_tail_buffer_size
scheme_force_value
scheme_force_one_value
scheme_set_cont_mark
scheme_push_continuation_frame
scheme_pop_continuation_frame
@ -190,6 +191,7 @@ scheme_make_noneternal_prim
scheme_make_closed_prim
scheme_make_prim_w_arity
scheme_make_folding_prim
scheme_make_noncm_prim
scheme_make_noneternal_prim_w_arity
scheme_make_closed_prim_w_arity
scheme_make_folding_closed_prim

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

@ -124,6 +124,7 @@ EXPORTS
scheme_tail_eval_expr
scheme_set_tail_buffer_size
scheme_force_value
scheme_force_one_value
scheme_set_cont_mark
scheme_push_continuation_frame
scheme_pop_continuation_frame
@ -175,6 +176,7 @@ EXPORTS
scheme_make_closed_prim
scheme_make_prim_w_arity
scheme_make_folding_prim
scheme_make_noncm_prim
scheme_make_noneternal_prim_w_arity
scheme_make_closed_prim_w_arity
scheme_make_folding_closed_prim

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

@ -156,6 +156,12 @@ typedef struct FSSpec mzFSSpec;
#define MZ_EXTERN extern MZ_DLLSPEC
#ifndef MZ_PRECISE_GC
# if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_I386)
# define MZ_USE_JIT
# endif
#endif
/* Define _W64 for MSC if needed. */
#if defined(_MSC_VER) && !defined(_W64)
# if !defined(__midl) && (defined(_X86_) || defined(_M_IX86)) && _MSC_VER >= 1300
@ -574,6 +580,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define SCHEME_PRIM_IS_USER_PARAMETER 1024
#define SCHEME_PRIM_IS_METHOD 2048
#define SCHEME_PRIM_IS_POST_DATA 4096
#define SCHEME_PRIM_IS_NONCM 8192
typedef struct Scheme_Object *
(Scheme_Prim)(int argc, struct Scheme_Object *argv[]);
@ -705,7 +712,7 @@ typedef struct {
/* ------------------------------------------------- */
#define SCHEME_PROCP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_proc_struct_type)))
#define SCHEME_PROCP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_native_closure_type)))
#define SCHEME_SYNTAXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_syntax_compiler_type)
#define SCHEME_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prim_type)
#define SCHEME_CLSD_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_closed_prim_type)
@ -780,14 +787,21 @@ typedef long mz_pre_jmp_buf[8];
# define mz_pre_jmp_buf jmp_buf
#endif
#ifdef MZ_USE_JIT
typedef struct { mz_pre_jmp_buf jb; void *stack_frame; } mz_one_jit_jmp_buf;
typedef mz_one_jit_jmp_buf mz_jit_jmp_buf[1];
#else
# define mz_jit_jmp_buf mz_pre_jmp_buf
#endif
#ifdef MZ_PRECISE_GC
typedef struct {
mz_pre_jmp_buf jb;
mz_jit_jmp_buf jb;
long gcvs; /* declared as `long' so it isn't pushed when on the stack! */
long gcvs_cnt;
} mz_jmp_buf;
#else
# define mz_jmp_buf mz_pre_jmp_buf
# define mz_jmp_buf mz_jit_jmp_buf
#endif
/* Like setjmp & longjmp, but you can jmp to a deeper stack position */
@ -877,6 +891,11 @@ typedef struct Scheme_Thread {
struct Scheme_Saved_Stack *runstack_saved;
Scheme_Object **runstack_tmp_keep;
/* in case of bouncing, we keep a recently
released runstack; it's dropped on GC, though */
Scheme_Object **spare_runstack;
long spare_runstack_size;
struct Scheme_Thread **runstack_owner;
struct Scheme_Saved_Stack *runstack_swapped;
@ -930,6 +949,8 @@ typedef struct Scheme_Thread {
Scheme_Object *(*overflow_k)(void);
Scheme_Object *overflow_reply;
/* content of tail_buffer is zeroed on GC, unless
runstack_tmp_keep is set to tail_buffer */
Scheme_Object **tail_buffer;
int tail_buffer_size;
@ -1067,6 +1088,7 @@ enum {
MZCONFIG_ERROR_ESCAPE_HANDLER,
MZCONFIG_ALLOW_SET_UNDEFINED,
MZCONFIG_USE_JIT,
MZCONFIG_CUSTODIAN,
MZCONFIG_INSPECTOR,
@ -1350,18 +1372,27 @@ MZ_EXTERN Scheme_Object *scheme_eval_waiting;
# endif
#endif
#ifdef MZ_USE_JIT
MZ_EXTERN void scheme_jit_longjmp(mz_jit_jmp_buf b, int v);
MZ_EXTERN void scheme_jit_setjmp_prepare(mz_jit_jmp_buf b);
# define scheme_jit_setjmp(b) (scheme_jit_setjmp_prepare(b), scheme_mz_setjmp((b)->jb))
#else
# define scheme_jit_longjmp(b, v) scheme_mz_longjmp(b, v)
# define scheme_jit_setjmp(b) scheme_mz_setjmp(b)
#endif
#ifdef MZ_PRECISE_GC
/* Need to make sure that a __gc_var_stack__ is always available where
setjmp & longjmp are used. */
# define scheme_longjmp(b, v) (((long *)(void*)((b).gcvs))[1] = (b).gcvs_cnt, \
GC_variable_stack = (void **)(void*)(b).gcvs, \
scheme_mz_longjmp((b).jb, v))
scheme_jit_longjmp((b).jb, v))
# define scheme_setjmp(b) ((b).gcvs = (long)__gc_var_stack__, \
(b).gcvs_cnt = (long)(__gc_var_stack__[1]), \
scheme_mz_setjmp((b).jb))
scheme_jit_setjmp((b).jb))
#else
# define scheme_longjmp(b, v) scheme_mz_longjmp(b, v)
# define scheme_setjmp(b) scheme_mz_setjmp(b)
# define scheme_longjmp(b, v) scheme_jit_longjmp(b, v)
# define scheme_setjmp(b) scheme_jit_setjmp(b)
#endif
/*========================================================================*/
@ -1487,10 +1518,12 @@ MZ_EXTERN int scheme_curly_braces_are_parens; /* Defaults to 1 */
MZ_EXTERN int scheme_hash_percent_syntax_only; /* Defaults to 0 */
MZ_EXTERN int scheme_hash_percent_globals_only; /* Defaults to 0 */
MZ_EXTERN int scheme_binary_mode_stdio; /* Windows-MacOS-specific. Defaults to 0 */
MZ_EXTERN int scheme_startup_use_jit;
MZ_EXTERN void scheme_set_case_sensitive(int);
MZ_EXTERN void scheme_set_allow_set_undefined(int);
MZ_EXTERN void scheme_set_binary_mode_stdio(int);
MZ_EXTERN void scheme_set_startup_use_jit(int);
MZ_EXTERN int scheme_get_allow_set_undefined();

44
src/mzscheme/sconfig.h
View File

@ -134,6 +134,10 @@
# define FLUSH_SPARC_REGISTER_WINDOWS
# endif
#ifdef i386
# define MZ_USE_JIT_I386
#endif
# define FLAGS_ALREADY_SET
#endif
@ -238,6 +242,13 @@
# define FLAGS_ALREADY_SET
#if defined(i386)
# define MZ_USE_JIT_I386
#endif
#if defined(powerpc)
# define MZ_USE_JIT_PPC
#endif
#endif
/********************* NetBSD ***********************/
@ -267,6 +278,13 @@
# define USE_DIVIDE_MAKE_INFINITY
#endif
#if defined(i386)
# define MZ_USE_JIT_I386
#endif
#if defined(powerpc)
# define MZ_USE_JIT_PPC
#endif
# define FLAGS_ALREADY_SET
#endif
@ -298,6 +316,8 @@
# define USE_TM_GMTOFF_FIELD
# define MZ_USE_JIT_I386
# define FLAGS_ALREADY_SET
#endif
@ -333,6 +353,8 @@
# define REGISTER_POOR_MACHINE
# define MZ_USE_JIT_I386
# define FLAGS_ALREADY_SET
#endif
@ -566,6 +588,8 @@
# define USE_ICONV_DLL
# define NO_MBTOWC_FUNCTIONS
# define MZ_USE_JIT_I386
# define FLAGS_ALREADY_SET
#endif
@ -611,13 +635,15 @@
# define LINK_EXTENSIONS_BY_TABLE
# define MZ_USE_JIT_I386
# define FLAGS_ALREADY_SET
#endif
/************** Mac OS X ****************/
# if (defined(__APPLE__) && defined(__ppc__) && defined(__MACH__)) || defined(OS_X)
# if defined(OS_X) || defined(XONX)
#ifdef XONX
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-darwin"
@ -658,6 +684,12 @@
# define OS_X 1
# endif
#ifdef __POWERPC__
# define MZ_USE_JIT_PPC
#else
# define MZ_USE_JIT_I386
#endif
# define FLAGS_ALREADY_SET
#endif
@ -681,6 +713,8 @@
# define FLAGS_ALREADY_SET
# define MZ_USE_JIT_I386
# endif
/************ Macintosh with CodeWarrior (not OS X) *************/
@ -1271,6 +1305,14 @@
MzScheme is itself a shared library instead of embedded in
an application */
/***********************/
/* JIT */
/***********************/
/* MZ_USE_JIT_I386 enables the JIT for x86 */
/* MZ_USE_JIT_PPC enables the JIT for PowerPC */
/***********************/
/* Heap Images */
/***********************/

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

@ -29,6 +29,7 @@ OBJS = salloc.@LTO@ \
gmp.@LTO@ \
hash.@LTO@ \
image.@LTO@ \
jit.@LTO@ \
list.@LTO@ \
module.@LTO@ \
network.@LTO@ \
@ -68,6 +69,7 @@ SRCS = $(srcdir)/salloc.c \
$(srcdir)/gmp/gmp.c \
$(srcdir)/hash.c \
$(srcdir)/image.c \
$(srcdir)/jit.c \
$(srcdir)/list.c \
$(srcdir)/module.c \
$(srcdir)/network.c \
@ -169,6 +171,8 @@ hash.@LTO@: $(srcdir)/hash.c
$(CC) $(CFLAGS) -c $(srcdir)/hash.c -o hash.@LTO@
image.@LTO@: $(srcdir)/image.c
$(CC) $(CFLAGS) -c $(srcdir)/image.c -o image.@LTO@
jit.@LTO@: $(srcdir)/jit.c
$(CC) $(CFLAGS) -c $(srcdir)/jit.c -o jit.@LTO@
list.@LTO@: $(srcdir)/list.c
$(CC) $(CFLAGS) -c $(srcdir)/list.c -o list.@LTO@
module.@LTO@: $(srcdir)/module.c
@ -253,6 +257,8 @@ hash.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../inclu
$(srcdir)/../src/stypes.h
image.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/schvers.h
jit.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h $(srcdir)/schvers.h $(srcdir)/codetab.inc
list.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../src/stypes.h
module.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \

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

@ -36,6 +36,7 @@
Scheme_Object scheme_true[1];
Scheme_Object scheme_false[1];
Scheme_Object *scheme_not_prim;
Scheme_Object *scheme_eq_prim;
/* locals */
static Scheme_Object *not_prim (int argc, Scheme_Object *argv[]);
@ -57,6 +58,7 @@ void scheme_init_true_false(void)
void scheme_init_bool (Scheme_Env *env)
{
REGISTER_SO(scheme_not_prim);
REGISTER_SO(scheme_eq_prim);
scheme_not_prim = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
@ -66,11 +68,9 @@ void scheme_init_bool (Scheme_Env *env)
"boolean?",
1, 1, 1),
env);
scheme_add_global_constant("eq?",
scheme_make_folding_prim(eq_prim,
"eq?",
2, 2, 1),
env);
scheme_eq_prim = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
scheme_add_global_constant("eq?", scheme_eq_prim, env);
scheme_add_global_constant("eqv?",
scheme_make_folding_prim(eqv_prim,
"eqv?",

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

@ -237,9 +237,9 @@ void scheme_init_char (Scheme_Env *env)
env);
scheme_add_global_constant("make-known-char-range-list",
scheme_make_prim_w_arity(char_map_list,
"make-known-char-range-list",
0, 0),
scheme_make_noncm_prim(char_map_list,
"make-known-char-range-list",
0, 0),
env);
}

334
src/mzscheme/src/codetab.inc Normal file
View File

@ -0,0 +1,334 @@
/* Implementation of the "symbol table" for mapping code
pointers to function names. */
#ifdef USE_SENORA_GC
# define GC_is_marked(p) GC_base(p)
#else
extern MZ_DLLIMPORT int GC_is_marked(void *);
#endif
#define LOG_KEY_SIZE 4
#define KEY_MASK ((1 << LOG_KEY_SIZE) - 1)
#define KEY_COUNT (1 << LOG_KEY_SIZE)
#define NODE_HEADER_SIZE 2
#define NODE_STARTS_OFFSET 1
#define NODE_GCABLE_OFFSET 2
static void **tree;
static int during_set;
static void *find_symbol(unsigned long v)
{
unsigned long k;
void **t = tree, *val;
int offset = (JIT_WORD_SIZE * 8);
while (offset) {
if (!t)
return NULL;
offset -= LOG_KEY_SIZE;
k = ((v >> offset) & KEY_MASK) + NODE_HEADER_SIZE;
val = t[k];
if (!val)
return NULL;
if (*(Scheme_Type *)val)
return val;
t = (void **)val;
}
printf("Error: walked off end of tree\n");
return NULL;
}
static void add_symbol(unsigned long start, unsigned long end, void *value, int gc_able)
{
unsigned long k1, k2, split_t_start = 0, split_t_end = 0, i;
int m;
int offset = (JIT_WORD_SIZE * 8), split_offset = 0;
void **t1, **t2, **split_t, *val1, *val2;
if (!tree) {
REGISTER_SO(tree);
tree = (void **)scheme_malloc((KEY_COUNT + NODE_HEADER_SIZE) * sizeof(void *));
}
during_set++;
t1 = t2 = tree;
split_t = NULL;
while (offset) {
offset -= LOG_KEY_SIZE;
k1 = ((start >> offset) & KEY_MASK) + NODE_HEADER_SIZE;
if (offset) {
val1 = t1[k1];
if (!val1) {
val1 = (void **)scheme_malloc((KEY_COUNT + NODE_HEADER_SIZE) * sizeof(void *));
t1[k1] = val1;
}
} else
val1 = t1;
k2 = ((end >> offset) & KEY_MASK) + NODE_HEADER_SIZE;
if (offset) {
/* Need to go deeper... */
val2 = t2[k2];
if (!val2) {
val2 = (void **)scheme_malloc((KEY_COUNT + NODE_HEADER_SIZE) * sizeof(void *));
t2[k2] = val2;
}
} else
val2 = t2;
if (!split_t && (val1 != val2)) {
split_t = t1;
split_t_start = k1;
split_t_end = k2;
split_offset = offset;
}
t1 = val1;
t2 = val2;
}
if (!split_t) {
/* assert: t1 == t2 */
split_t = t1;
split_t_start = k1;
split_t_end = k2;
}
/* Mark start bit: */
m = (1 << (k1 - NODE_HEADER_SIZE));
((unsigned short *)t1)[NODE_STARTS_OFFSET] |= m;
if (gc_able)
((unsigned short *)t1)[NODE_GCABLE_OFFSET] |= m;
/* Fill in start and end: */
t1[k1] = value;
t2[k2] = value;
/* Fill in range between branches: */
for (i = split_t_start + 1; i < split_t_end; i++) {
split_t[i] = value;
}
/* Fill in places to right of start branches: */
if (t1 != split_t) {
k1 = ((start >> split_offset) & KEY_MASK) + NODE_HEADER_SIZE;
t1 = split_t[k1];
offset = split_offset;
while (offset) {
offset -= LOG_KEY_SIZE;
k1 = ((start >> offset) & KEY_MASK) + NODE_HEADER_SIZE;
for (i = k1 + 1; i < KEY_COUNT + NODE_HEADER_SIZE; i++) {
t1[i] = value;
}
t1 = t1[k1];
}
}
/* Fill in places to left of end branch: */
if (t2 != split_t) {
k2 = ((end >> split_offset) & KEY_MASK) + NODE_HEADER_SIZE;
t2 = split_t[k2];
offset = split_offset;
while (offset) {
offset -= LOG_KEY_SIZE;
k2 = ((end >> offset) & KEY_MASK) + NODE_HEADER_SIZE;
for (i = NODE_HEADER_SIZE; i < k2; i++) {
t2[i] = value;
}
t2 = t2[k2];
}
}
--during_set;
}
static int do_clear_symbols(void **t, int offset, unsigned long addr, int clearing)
{
int i, m, j;
void *p, *val, **subt;
/* Note: this function might be called (via a GC callback)
while add_symbol is running. */
for (i = 0; i < KEY_COUNT; i++) {
m = (1 << i);
if (((unsigned short *)t)[NODE_STARTS_OFFSET] & m) {
clearing = 0;
if (((unsigned short *)t)[NODE_GCABLE_OFFSET] & m) {
/* GCable pointer starts here */
p = (void *)(addr + (i << offset));
if (!GC_is_marked(p)) {
/* Collected... */
((unsigned short *)t)[NODE_STARTS_OFFSET] -= m;
((unsigned short *)t)[NODE_GCABLE_OFFSET] -= m;
clearing = 1;
}
}
}
val = t[i + NODE_HEADER_SIZE];
if (val) {
if (!*(Scheme_Type *)val) {
subt = (void **)val;
clearing = do_clear_symbols(subt,
offset - LOG_KEY_SIZE,
(addr + (i << offset)),
clearing);
if (!during_set) {
/* If the branch is empty, then drop it. */
for (j = 0; j < KEY_COUNT; j++) {
if (subt[j + NODE_HEADER_SIZE])
break;
}
if (j == KEY_COUNT) {
t[i + NODE_HEADER_SIZE] = NULL;
}
}
} else if (clearing)
t[i + NODE_HEADER_SIZE] = NULL;
}
}
return clearing;
}
static void clear_symbols_for_collected()
{
if (tree) {
do_clear_symbols(tree, (JIT_WORD_SIZE * 8) - LOG_KEY_SIZE, 0, 0);
}
}
/*============================================================*/
/* testing */
/*============================================================*/
#if 0
Scheme_Type a[] = {1};
Scheme_Type b[] = {2};
Scheme_Type c[] = {3};
static char *nameof(void *p)
{
if (p == a) return "a";
if (p == b) return "b";
if (p == c) return "c";
if (!p) return "NULL";
return "?";
}
void *alt_gc;
void *gcs[3];
int GC_is_marked(void *p)
{
if (alt_gc) {
if (p == alt_gc)
return 1;
else
return 0;
} else {
if ((p == gcs[0])
|| (p == gcs[1])
|| (p == gcs[2]))
return 0;
else
return 1;
}
}
void check(int j, int delta, int i, void *expect, unsigned long addr)
{
void *got;
got = find_symbol(addr);
if (i == 2)
expect = NULL;
if (expect != got)
printf("(%d,%d,%d) Expected %s, found %s at %p\n",
j, delta, i,
nameof(expect), nameof(got),
addr);
}
int main()
{
int i, d, delta, j;
for (j = 0; j < 2; j++) {
for (d = 0; d < 16; d++) {
delta = d;
for (i = 0; i < 3; i++) {
if (i != 1)
check(j, delta, 1, NULL, (delta + 0x12341234));
if (!i)
add_symbol(delta + 0x12341200, delta + 0x12341234, a, 1);
check(j, delta, i, a, ((delta + 0x12341234)));
check(j, delta, i, a, ((delta + 0x12341200)));
check(j, delta, i, a, ((delta + 0x12341201)));
check(j, delta, i, a, ((delta + 0x12341210)));
check(j, delta, i, a, ((delta + 0x12341231)));
check(j, delta, i, a, ((delta + 0x12341200)));
if (i != 1)
check(j, delta, i, NULL, ((delta + 0x12341236)));
if (!i)
add_symbol(delta + 0x12341236, delta + 0x12370000, b, 1);
check(j, delta, i, a, ((delta + 0x12341234)));
if (!i)
check(j, delta, i, NULL, ((delta + 0x12341235)));
check(j, delta, i, b, ((delta + 0x12341236)));
check(j, delta, i, b, ((delta + 0x12370000)));
check(j, delta, i, NULL, ((delta + 0x12370001)));
check(j, delta, i, b, ((delta + 0x12351236)));
check(j, delta, i, b, ((delta + 0x12350000)));
check(j, delta, i, b, ((delta + 0x12360000)));
if (!i) {
check(j, delta, i, NULL, ((delta + 0x12341235)));
add_symbol(delta + 0x12341235, delta + 0x12341235, c, 1);
}
check(j, delta, i, a, ((delta + 0x12341234)));
check(j, delta, i == 2 ? 0 : i, c, ((delta + 0x12341235)));
check(j, delta, i, b, ((delta + 0x12341236)));
if (!delta) {
if (!i && !j) {
check(j, delta, i, NULL, ((0x55556666)));
add_symbol(0x55556663, 0x55556669, a, 0); /* Not GCable */
}
}
check(j, delta, 0, a, ((0x55556666)));
check(j, delta, 0, a, ((0x55556663)));
check(j, delta, 0, a, ((0x55556669)));
if (i == 0) {
alt_gc = NULL;
gcs[0] = NULL;
gcs[1] = NULL;
gcs[2] = NULL;
} else {
if (0)
alt_gc = (void *)0x55556663;
gcs[0] = (void *)(delta + 0x12341200);
gcs[1] = (void *)(delta + 0x12341236);
if (i == 2)
gcs[2] = (void *)(delta + 0x12341235);
else
gcs[2] = NULL;
}
clear_symbols_for_collected();
}
}
}
}
#endif

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

File diff suppressed because it is too large Load Diff

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

@ -314,6 +314,8 @@ Scheme_Env *scheme_basic_env()
scheme_init_thread_memory();
#endif
scheme_init_getenv(); /* checks PLTNOJIT */
scheme_make_thread();
#ifdef TIME_STARTUP_PROCESS
@ -342,7 +344,6 @@ Scheme_Env *scheme_basic_env()
scheme_starting_up = 0;
scheme_init_getenv();
#ifdef TIME_STARTUP_PROCESS
printf("done @ %ld\n#endif\n", scheme_get_process_milliseconds());
#endif
@ -2600,6 +2601,7 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp)
{
Resolve_Info *naya;
Scheme_Object *b;
naya = MALLOC_ONE_RT(Resolve_Info);
#ifdef MZTAG_REQUIRED
@ -2610,6 +2612,9 @@ Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp)
naya->next = NULL;
naya->toplevel_pos = -1;
b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT);
naya->use_jit = SCHEME_TRUEP(b);
return naya;
}
@ -2626,6 +2631,7 @@ Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsi
#endif
naya->prefix = info->prefix;
naya->next = info;
naya->use_jit = info->use_jit;
naya->size = size;
naya->oldsize = oldsize;
naya->count = mapc;

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

@ -939,7 +939,7 @@ void scheme_wrong_count_m(const char *name, int minc, int maxc,
p->tail_buffer = tb;
}
/* minc = 1 -> name is really a case-lambda proc */
/* minc = 1 -> name is really a case-lambda or native proc */
if (minc == -1) {
/* Check for is_method in case-lambda */
@ -954,6 +954,26 @@ void scheme_wrong_count_m(const char *name, int minc, int maxc,
/* See note in schpriv.h about the IS_METHOD hack */
is_method = 1;
}
#ifdef MZ_USE_JIT
} else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_native_closure_type)) {
Scheme_Object *pa;
pa = scheme_get_native_arity((Scheme_Object *)name);
if (SCHEME_BOXP(pa)) {
pa = SCHEME_BOX_VAL(pa);
is_method = 1;
}
if (SCHEME_INTP(pa)) {
minc = SCHEME_INT_VAL(pa);
if (minc < 0) {
minc = (-minc) - 1;
maxc = -1;
} else
maxc = minc;
name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
} else {
/* complex; use "no matching case" msg */
}
#endif
}
}

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

@ -127,6 +127,9 @@ volatile int scheme_fuel_counter;
int scheme_stack_grows_up;
int scheme_startup_use_jit = 1;
void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit = v; }
static Scheme_Object *app_symbol;
static Scheme_Object *datum_symbol;
static Scheme_Object *top_symbol;
@ -167,6 +170,7 @@ static Scheme_Object *expand_stx_to_top_form(int argc, Scheme_Object **argv);
static Scheme_Object *top_introduce_stx(int argc, Scheme_Object **argv);
static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv);
static Scheme_Object *use_jit(int argc, Scheme_Object **argv);
static Scheme_Object *app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
@ -429,6 +433,12 @@ scheme_init_eval (Scheme_Env *env)
MZCONFIG_ALLOW_SET_UNDEFINED),
env);
scheme_add_global_constant("eval-jit-enabled",
scheme_register_parameter(use_jit,
"eval-jit-enabled",
MZCONFIG_USE_JIT),
env);
REGISTER_SO(app_symbol);
REGISTER_SO(datum_symbol);
REGISTER_SO(top_symbol);
@ -613,6 +623,7 @@ void *scheme_enlarge_runstack(long size, void *(*k)())
Scheme_Thread *p = scheme_current_thread;
Scheme_Saved_Stack *saved;
void *v;
int cont_count;
saved = MALLOC_ONE_RT(Scheme_Saved_Stack);
@ -629,16 +640,31 @@ void *scheme_enlarge_runstack(long size, void *(*k)())
size = SCHEME_STACK_SIZE;
p->runstack_saved = saved;
if (p->spare_runstack && (size <= p->spare_runstack_size)) {
size = p->spare_runstack_size;
MZ_RUNSTACK_START = p->spare_runstack;
p->spare_runstack = NULL;
} else {
MZ_RUNSTACK_START = scheme_malloc_allow_interior(sizeof(Scheme_Object*) * size);
}
p->runstack_size = size;
MZ_RUNSTACK_START = scheme_malloc_allow_interior(sizeof(Scheme_Object*) * size);
MZ_RUNSTACK = MZ_RUNSTACK_START + size;
cont_count = scheme_cont_capture_count;
v = k();
/* If `k' escapes, the escape handler will restore the stack
pointers. */
p = scheme_current_thread; /* might have changed! */
if (cont_count == scheme_cont_capture_count) {
if (!p->spare_runstack || (p->runstack_size > p->spare_runstack_size)) {
p->spare_runstack = MZ_RUNSTACK_START;
p->spare_runstack_size = p->runstack_size;
}
}
p->runstack_saved = saved->prev;
MZ_RUNSTACK = saved->runstack;
MZ_RUNSTACK_START = saved->runstack_start;
@ -1343,10 +1369,34 @@ static Scheme_Object *link_toplevel(Scheme_Object *expr, Scheme_Env *env,
}
}
static Scheme_Object *resolve_k()
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
Resolve_Info *info = (Resolve_Info *)p->ku.k.p2;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
return scheme_resolve_expr(expr, info);
}
Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info)
{
Scheme_Type type = SCHEME_TYPE(expr);
#ifdef DO_STACK_CHECK
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)expr;
p->ku.k.p2 = (void *)info;
return scheme_handle_stack_overflow(resolve_k);
}
#endif
switch (type) {
case scheme_local_type:
{
@ -1429,6 +1479,326 @@ Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info)
return first;
}
/*========================================================================*/
/* JIT */
/*========================================================================*/
#ifdef MZ_USE_JIT
static Scheme_Object *jit_application(Scheme_Object *o)
{
Scheme_Object *orig, *naya = NULL;
Scheme_App_Rec *app, *app2;
int i, n, size;
app = (Scheme_App_Rec *)o;
n = app->num_args + 1;
for (i = 0; i < n; i++) {
orig = app->args[i];
naya = scheme_jit_expr(orig);
if (!SAME_OBJ(orig, naya))
break;
}
if (i >= n)
return o;
size = (sizeof(Scheme_App_Rec)
+ ((n - 1) * sizeof(Scheme_Object *))
+ n * sizeof(char));
app2 = (Scheme_App_Rec *)scheme_malloc_tagged(size);
memcpy(app2, app, size);
app2->args[i] = naya;
for (i++; i < n; i++) {
orig = app2->args[i];
naya = scheme_jit_expr(orig);
app2->args[i] = naya;
}
return (Scheme_Object *)app2;
}
static Scheme_Object *jit_application2(Scheme_Object *o)
{
Scheme_App2_Rec *app;
Scheme_Object *nrator, *nrand;
app = (Scheme_App2_Rec *)o;
nrator = scheme_jit_expr(app->rator);
nrand = scheme_jit_expr(app->rand);
if (SAME_OBJ(nrator, app->rator)
&& SAME_OBJ(nrand, app->rand))
return o;
app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
memcpy(app, o, sizeof(Scheme_App2_Rec));
app->rator = nrator;
app->rand = nrand;
return (Scheme_Object *)app;
}
static Scheme_Object *jit_application3(Scheme_Object *o)
{
Scheme_App3_Rec *app;
Scheme_Object *nrator, *nrand1, *nrand2;
app = (Scheme_App3_Rec *)o;
nrator = scheme_jit_expr(app->rator);
nrand1 = scheme_jit_expr(app->rand1);
nrand2 = scheme_jit_expr(app->rand2);
if (SAME_OBJ(nrator, app->rator)
&& SAME_OBJ(nrand1, app->rand1)
&& SAME_OBJ(nrand2, app->rand2))
return o;
app = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
memcpy(app, o, sizeof(Scheme_App3_Rec));
app->rator = nrator;
app->rand1 = nrand1;
app->rand2 = nrand2;
return (Scheme_Object *)app;
}
static Scheme_Object *jit_sequence(Scheme_Object *o)
{
Scheme_Object *orig, *naya = NULL;
Scheme_Sequence *seq, *seq2;
int i, n, size;
seq = (Scheme_Sequence *)o;
n = seq->count;
for (i = 0; i < n; i++) {
orig = seq->array[i];
naya = scheme_jit_expr(orig);
if (!SAME_OBJ(orig, naya))
break;
}
if (i >= n)
return o;
size = (sizeof(Scheme_Sequence)
+ ((n - 1) * sizeof(Scheme_Object *)));
seq2 = (Scheme_Sequence *)scheme_malloc_tagged(size);
memcpy(seq2, seq, size);
seq2->array[i] = naya;
for (i++; i < n; i++) {
orig = seq2->array[i];
naya = scheme_jit_expr(orig);
seq2->array[i] = naya;
}
return (Scheme_Object *)seq2;
}
static Scheme_Object *jit_branch(Scheme_Object *o)
{
Scheme_Branch_Rec *b;
Scheme_Object *t, *tb, *fb;
b = (Scheme_Branch_Rec *)o;
t = scheme_jit_expr(b->test);
tb = scheme_jit_expr(b->tbranch);
fb = scheme_jit_expr(b->fbranch);
if (SAME_OBJ(t, b->test)
&& SAME_OBJ(tb, b->tbranch)
&& SAME_OBJ(fb, b->fbranch))
return o;
b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
memcpy(b, o, sizeof(Scheme_Branch_Rec));
b->test = t;
b->tbranch = tb;
b->fbranch = fb;
return (Scheme_Object *)b;
}
static Scheme_Object *jit_let_value(Scheme_Object *o)
{
Scheme_Let_Value *lv = (Scheme_Let_Value *)o;
Scheme_Object *body, *rhs;
rhs = scheme_jit_expr(lv->value);
body = scheme_jit_expr(lv->body);
if (SAME_OBJ(rhs, lv->value)
&& SAME_OBJ(body, lv->body))
return o;
lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
memcpy(lv, o, sizeof(Scheme_Let_Value));
lv->value = rhs;
lv->body = body;
return (Scheme_Object *)lv;
}
static Scheme_Object *jit_let_one(Scheme_Object *o)
{
Scheme_Let_One *lo = (Scheme_Let_One *)o;
Scheme_Object *body, *rhs;
rhs = scheme_jit_expr(lo->value);
body = scheme_jit_expr(lo->body);
if (SAME_OBJ(rhs, lo->value)
&& SAME_OBJ(body, lo->body))
return o;
lo = MALLOC_ONE_TAGGED(Scheme_Let_One);
memcpy(lo, o, sizeof(Scheme_Let_One));
lo->value = rhs;
lo->body = body;
return (Scheme_Object *)lo;
}
static Scheme_Object *jit_let_void(Scheme_Object *o)
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
Scheme_Object *body;
body = scheme_jit_expr(lv->body);
if (SAME_OBJ(body, lv->body))
return o;
lv = MALLOC_ONE_TAGGED(Scheme_Let_Void);
memcpy(lv, o, sizeof(Scheme_Let_Void));
lv->body = body;
return (Scheme_Object *)lv;
}
static Scheme_Object *jit_letrec(Scheme_Object *o)
{
Scheme_Letrec *lr = (Scheme_Letrec *)o, *lr2;
Scheme_Object **procs, **procs2, *v;
int i, count;
count = lr->count;
lr2 = MALLOC_ONE_TAGGED(Scheme_Letrec);
memcpy(lr2, lr, sizeof(Scheme_Letrec));
procs = lr->procs;
procs2 = MALLOC_N(Scheme_Object *, count);
lr2->procs = procs2;
for (i = 0; i < count; i++) {
v = scheme_jit_expr(procs[i]);
procs2[i] = v;
}
v = scheme_jit_expr(lr->body);
lr2->body = v;
return (Scheme_Object *)lr2;
}
static Scheme_Object *jit_wcm(Scheme_Object *o)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b;
k = scheme_jit_expr(wcm->key);
v = scheme_jit_expr(wcm->val);
b = scheme_jit_expr(wcm->body);
if (SAME_OBJ(wcm->key, k)
&& SAME_OBJ(wcm->val, v)
&& SAME_OBJ(wcm->body, b))
return o;
wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
memcpy(wcm, o, sizeof(Scheme_With_Continuation_Mark));
wcm->key = k;
wcm->val = v;
wcm->body = b;
return (Scheme_Object *)wcm;
}
Scheme_Object *scheme_jit_expr(Scheme_Object *expr)
{
Scheme_Type type = SCHEME_TYPE(expr);
switch (type) {
case scheme_syntax_type:
{
Scheme_Syntax_Jitter f;
Scheme_Object *orig, *naya;
f = scheme_syntax_jitters[SCHEME_PINT_VAL(expr)];
orig = SCHEME_IPTR_VAL(expr);
naya = f(orig);
if (SAME_OBJ(orig, naya))
return expr;
return scheme_make_syntax_resolved(SCHEME_PINT_VAL(expr), naya);
}
case scheme_application_type:
return jit_application(expr);
case scheme_application2_type:
return jit_application2(expr);
case scheme_application3_type:
return jit_application3(expr);
case scheme_sequence_type:
return jit_sequence(expr);
case scheme_branch_type:
return jit_branch(expr);
case scheme_with_cont_mark_type:
return jit_wcm(expr);
case scheme_unclosed_procedure_type:
return scheme_jit_closure(expr);
case scheme_let_value_type:
return jit_let_value(expr);
case scheme_let_void_type:
return jit_let_void(expr);
case scheme_letrec_type:
return jit_letrec(expr);
case scheme_let_one_type:
return jit_let_one(expr);
case scheme_closure_type:
{
Scheme_Closure *c = (Scheme_Closure *)expr;
if (ZERO_SIZED_CLOSUREP(c)) {
/* JIT the closure body, producing a native closure: */
return scheme_jit_closure((Scheme_Object *)c->code);
} else
return expr;
}
case scheme_case_closure_type:
{
return scheme_unclose_case_lambda(expr, 1);
}
default:
return expr;
}
}
#else
Scheme_Object *scheme_jit_expr(Scheme_Object *expr)
{
return expr;
}
#endif
/*========================================================================*/
/* compilation info management */
/*========================================================================*/
@ -1694,7 +2064,6 @@ static void *compile_k(void)
}
}
tl_queue = scheme_null;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
@ -1745,7 +2114,7 @@ static void *compile_k(void)
o = call_compile_handler(form, 1);
top = (Scheme_Compilation_Top *)o;
} else {
/* We want to simply compile form, but we have to loop in case
/* We want to simply compile `form', but we have to loop in case
an expression is lifted in the process of compiling: */
int max_let_depth = 0;
Scheme_Object *l, *prev_o = NULL;
@ -3269,6 +3638,38 @@ Scheme_Object *_scheme_apply_closed_prim(Scheme_Object *rator,
#include "schapp.inc"
}
#ifdef MZ_USE_JIT
Scheme_Object *_scheme_apply_from_native(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
{
#define PRIM_CHECK_VALUE 1
#define PRIM_CHECK_MULTI 1
#include "schnapp.inc"
}
Scheme_Object *_scheme_apply_multi_from_native(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
{
#define PRIM_CHECK_VALUE 1
#define PRIM_CHECK_MULTI 0
#include "schnapp.inc"
}
Scheme_Object *_scheme_tail_apply_from_native(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
{
/* It's ok to call primitive and closed primitives directly,
since they implement further tail by trampolining. */
#define PRIM_CHECK_VALUE 0
#define PRIM_CHECK_MULTI 0
#include "schnapp.inc"
}
#endif
Scheme_Object *scheme_check_one_value(Scheme_Object *v)
{
if (v == SCHEME_MULTIPLE_VALUES)
@ -3446,23 +3847,26 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
if (type == scheme_prim_type) {
GC_CAN_IGNORE Scheme_Primitive_Proc *prim;
if (rands == p->tail_buffer) {
if (num_rands < TAIL_COPY_THRESHOLD) {
int i;
Scheme_Object **quick_rands;
#define VACATE_TAIL_BUFFER_USE_RUNSTACK() \
if (rands == p->tail_buffer) { \
if (num_rands < TAIL_COPY_THRESHOLD) { \
int i; \
Scheme_Object **quick_rands; \
\
quick_rands = PUSH_RUNSTACK(p, RUNSTACK, num_rands); \
RUNSTACK_CHANGED(); \
\
for (i = num_rands; i--; ) { \
quick_rands[i] = rands[i]; \
} \
rands = quick_rands; \
} else { \
UPDATE_THREAD_RSPTR_FOR_GC(); \
make_tail_buffer_safe(); \
} \
}
quick_rands = PUSH_RUNSTACK(p, RUNSTACK, num_rands);
RUNSTACK_CHANGED();
for (i = num_rands; i--; ) {
quick_rands[i] = rands[i];
}
rands = quick_rands;
} else {
UPDATE_THREAD_RSPTR_FOR_GC();
make_tail_buffer_safe();
}
}
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR();
@ -3485,7 +3889,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
int i, has_rest, num_params;
DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
data = SCHEME_COMPILED_CLOS_CODE(obj);
if ((RUNSTACK - RUNSTACK_START) < data->max_let_depth) {
@ -3600,7 +4004,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
} else {
if (num_rands) {
if (has_rest) {
/* 0 params and hash_rest => (lambda args E) where args is not in E,
/* 0 params and has_rest => (lambda args E) where args is not in E,
so accept any number of arguments and ignore them. */
} else {
@ -3665,24 +4069,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;
DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
if (rands == p->tail_buffer) {
if (num_rands < TAIL_COPY_THRESHOLD) {
int i;
Scheme_Object **quick_rands;
quick_rands = PUSH_RUNSTACK(p, RUNSTACK, num_rands);
RUNSTACK_CHANGED();
for (i = num_rands; i--; ) {
quick_rands[i] = rands[i];
}
rands = quick_rands;
} else {
UPDATE_THREAD_RSPTR_FOR_GC();
make_tail_buffer_safe();
}
}
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR();
@ -3722,6 +4110,42 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
scheme_wrong_count((char *)seq, -1, -1, num_rands, rands);
return NULL; /* Doesn't get here. */
#ifdef MZ_USE_JIT
} else if (type == scheme_native_closure_type) {
GC_CAN_IGNORE Scheme_Native_Closure_Data *data;
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR();
DO_CHECK_FOR_BREAK(p, );
if (!scheme_native_arity_check(obj, num_rands)) {
scheme_wrong_count_m((const char *)obj, -1, -1,
num_rands, rands, 0);
return NULL;
}
data = ((Scheme_Native_Closure *)obj)->code;
/* Enlarge the runstack? This max_let_depth is in bytes instead of words. */
if (data->max_let_depth > ((unsigned long)RUNSTACK - (unsigned long)RUNSTACK_START)) {
p->ku.k.p1 = (void *)obj;
p->ku.k.i1 = num_rands;
p->ku.k.p2 = (void *)rands;
p->ku.k.i2 = -1;
MZ_CONT_MARK_POS -= 2;
v = (Scheme_Object *)scheme_enlarge_runstack(data->max_let_depth / sizeof(void *),
(void *(*)(void))do_eval_k);
MZ_CONT_MARK_POS += 2;
goto returnv;
}
v = data->code(obj, num_rands, rands);
DEBUG_CHECK_TYPE(v);
#endif
} else if (type == scheme_cont_type) {
Scheme_Cont *c;
Scheme_Dynamic_Wind *dw, *common;
@ -3771,7 +4195,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
}
c->common = common;
/* For dynamaic-winds after `common' in this
/* For dynamic-winds after `common' in this
continuation, execute the post-thunks */
for (dw = p->dw; dw != common; dw = dw->prev) {
if (dw->post) {
@ -3827,6 +4251,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
p->cjs.u.val = value;
p->cjs.jumping_to_continuation = (Scheme_Escaping_Cont *)obj;
scheme_longjmp(MZTHREADELEM(p, error_buf), 1);
return NULL;
} else if (type == scheme_proc_struct_type) {
int is_method;
@ -4298,18 +4723,28 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
/* Close them: */
i = l->count;
while (i--) {
GC_CAN_IGNORE Scheme_Closure *closure;
GC_CAN_IGNORE Scheme_Closure_Data *data;
GC_CAN_IGNORE Scheme_Object *clos;
GC_CAN_IGNORE Scheme_Object **dest;
GC_CAN_IGNORE mzshort *map;
GC_CAN_IGNORE Scheme_Closure_Data *data;
int j;
closure = (Scheme_Closure *)stack[i];
data = (Scheme_Closure_Data *)a[i];
clos = stack[i];
#ifdef MZ_USE_JIT
if (SAME_TYPE(_SCHEME_TYPE(clos), scheme_closure_type)) {
dest = ((Scheme_Closure *)clos)->vals;
} else {
dest = ((Scheme_Native_Closure *)clos)->vals;
}
#else
dest = ((Scheme_Closure *)clos)->vals;
#endif
data = (Scheme_Closure_Data *)a[i];
map = data->closure_map;
j = data->closure_size;
dest = closure->vals;
/* Beware - dest points to the middle of a block */
@ -4446,7 +4881,7 @@ static void *eval_k(void)
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *v, **save_runstack;
Scheme_Env *env;
int isexpr, multi;
int isexpr, multi, use_jit;
v = (Scheme_Object *)p->ku.k.p1;
env = (Scheme_Env *)p->ku.k.p2;
@ -4455,7 +4890,15 @@ static void *eval_k(void)
multi = p->ku.k.i1;
isexpr = p->ku.k.i2;
{
Scheme_Object *b;
b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT);
use_jit = SCHEME_TRUEP(b);
}
if (isexpr) {
if (use_jit)
v = scheme_jit_expr(v);
if (multi)
v = _scheme_eval_linked_expr_multi_wp(v, p);
else
@ -4475,6 +4918,9 @@ static void *eval_k(void)
v = top->code;
if (use_jit)
v = scheme_jit_expr(v);
save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase);
if (multi)
@ -5145,6 +5591,14 @@ static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv)
-1, NULL, NULL, 1);
}
static Scheme_Object *use_jit(int argc, Scheme_Object **argv)
{
return scheme_param_config("eval-jit-enabled",
scheme_make_integer(MZCONFIG_USE_JIT),
argc, argv,
-1, NULL, NULL, 1);
}
static Scheme_Object *
enable_break(int argc, Scheme_Object *argv[])
{

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

@ -123,8 +123,6 @@ Scheme_Object *scheme_values(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_print(int argc, Scheme_Object **argv);
static Scheme_Object *current_prompt_read(int, Scheme_Object **);
static Scheme_Object *get_or_check_arity(Scheme_Object *p, long a);
static Scheme_Object *write_compiled_closure(Scheme_Object *obj);
static Scheme_Object *read_compiled_closure(Scheme_Object *obj);
@ -431,7 +429,7 @@ Scheme_Object *
scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
const char *name,
mzshort mina, mzshort maxa,
short folding,
int flags,
mzshort minr, mzshort maxr)
{
Scheme_Primitive_Proc *prim;
@ -449,7 +447,7 @@ scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
prim->name = name;
prim->mina = mina;
prim->maxa = maxa;
prim->pp.flags = ((folding ? SCHEME_PRIM_IS_FOLDING : 0)
prim->pp.flags = (flags
| (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
| (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0));
@ -485,7 +483,22 @@ scheme_make_folding_prim(Scheme_Prim *fun, const char *name,
short folding)
{
return scheme_make_prim_w_everything(fun, 1, name, mina, maxa,
folding, 1, 1);
(folding
? (SCHEME_PRIM_IS_FOLDING
| SCHEME_PRIM_IS_NONCM)
: 0),
1, 1);
}
Scheme_Object *
scheme_make_noncm_prim(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa)
{
/* A non-cm primitive leaves the mark stack unchanged when it returns,
and it can't return multiple values. */
return scheme_make_prim_w_everything(fun, 1, name, mina, maxa,
SCHEME_PRIM_IS_NONCM,
1, 1);
}
Scheme_Object *
@ -577,11 +590,34 @@ scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close)
{
Scheme_Closure_Data *data;
Scheme_Closure *closure;
Scheme_Object **runstack, **dest;
mzshort *map;
GC_CAN_IGNORE Scheme_Object **runstack;
GC_CAN_IGNORE Scheme_Object **dest;
GC_CAN_IGNORE mzshort *map;
int i;
data = (Scheme_Closure_Data *)code;
#ifdef MZ_USE_JIT
if (data->native_code) {
Scheme_Object *nc;
nc = scheme_make_native_closure(data->native_code);
if (close) {
runstack = MZ_RUNSTACK;
dest = ((Scheme_Native_Closure *)nc)->vals;
map = data->closure_map;
i = data->closure_size;
/* Copy data into the closure: */
while (i--) {
dest[i] = runstack[map[i]];
}
}
return nc;
}
#endif
i = data->closure_size;
@ -613,6 +649,32 @@ scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close)
return (Scheme_Object *)closure;
}
Scheme_Object *scheme_jit_closure(Scheme_Object *code)
{
Scheme_Closure_Data *data = (Scheme_Closure_Data *)code;
#ifdef MZ_USE_JIT
if (!data->native_code) {
Scheme_Native_Closure_Data *ndata;
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
memcpy(data, code, sizeof(Scheme_Closure_Data));
ndata = scheme_generate_lambda(data, 1, NULL);
data->native_code = ndata;
/* If it's zero-sized, then create closure now */
if (!data->closure_size) {
return scheme_make_native_closure(ndata);
}
return (Scheme_Object *)data;
}
#endif
return code;
}
/* Closure_Info is used to store extra closure information
before a closure mapping is resolved. */
typedef struct {
@ -722,9 +784,9 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info)
if (SCHEME_TYPE(data->code) > _scheme_compiled_values_types_)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_FOLDABLE;
/* If the closure is empty, create the closure now */
if (!data->closure_size)
/* If the closure is empty, go ahead and finalize closure */
return scheme_make_closure(NULL, (Scheme_Object *)data, 0);
return scheme_make_closure(NULL, (Scheme_Object *)data, 1);
else
return (Scheme_Object *)data;
}
@ -1204,16 +1266,15 @@ void scheme_clear_cc_ok()
/* procedure application evaluation */
/*========================================================================*/
Scheme_Object *
scheme_force_value(Scheme_Object *obj)
/* Called where _scheme_apply() or _scheme_value() might return a
a tail-call-waiting trampoline token. */
static Scheme_Object *
force_values(Scheme_Object *obj, int multi_ok)
/* Called where _scheme_apply() or _scheme_value() might return a
a tail-call-waiting trampoline token. */
{
if (SAME_OBJ(obj, SCHEME_TAIL_CALL_WAITING)) {
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *v;
/* Watch out for use for use of tail buffer: */
/* Watch out for use of tail buffer: */
if (p->ku.apply.tail_rands == p->tail_buffer) {
GC_CAN_IGNORE Scheme_Object **tb;
p->tail_buffer = NULL; /* so args aren't zeroed */
@ -1221,19 +1282,38 @@ scheme_force_value(Scheme_Object *obj)
p->tail_buffer = tb;
}
v = _scheme_apply_multi(p->ku.apply.tail_rator,
p->ku.apply.tail_num_rands,
p->ku.apply.tail_rands);
return v;
if (multi_ok)
return _scheme_apply_multi(p->ku.apply.tail_rator,
p->ku.apply.tail_num_rands,
p->ku.apply.tail_rands);
else
return _scheme_apply(p->ku.apply.tail_rator,
p->ku.apply.tail_num_rands,
p->ku.apply.tail_rands);
} else if (SAME_OBJ(obj, SCHEME_EVAL_WAITING)) {
Scheme_Thread *p = scheme_current_thread;
return _scheme_eval_linked_expr_multi(p->ku.eval.wait_expr);
if (multi_ok)
return _scheme_eval_linked_expr_multi(p->ku.eval.wait_expr);
else
return _scheme_eval_linked_expr(p->ku.eval.wait_expr);
} else if (obj)
return obj;
else
return scheme_void;
}
Scheme_Object *
scheme_force_value(Scheme_Object *obj)
{
return force_values(obj, 1);
}
Scheme_Object *
scheme_force_one_value(Scheme_Object *obj)
{
return force_values(obj, 0);
}
static void *apply_k(void)
{
Scheme_Thread *p = scheme_current_thread;
@ -1590,7 +1670,7 @@ Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
}
}
static Scheme_Object *get_or_check_arity(Scheme_Object *p, long a)
Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, long a)
/* a == -1 => get arity
a == -2 => check for allowing varargs */
{
@ -1724,6 +1804,103 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, long a)
drop++;
SCHEME_USE_FUEL(1);
goto top;
#ifdef MZ_USE_JIT
} else if (type == scheme_native_closure_type) {
if (a < 0) {
Scheme_Object *pa;
pa = scheme_get_native_arity(p);
if (SCHEME_BOXP(pa)) {
/* Is a method; pa already corrects for it */
pa = SCHEME_BOX_VAL(pa);
}
if (SCHEME_STRUCTP(pa)) {
/* This happens when a non-case-lambda is not yet JITted.
It's an arity-at-least record. Convert it to the
negative-int encoding. */
int v;
pa = ((Scheme_Structure *)pa)->slots[0];
v = -(SCHEME_INT_VAL(pa) + 1);
pa = scheme_make_integer(v);
}
if (SCHEME_INTP(pa)) {
mina = SCHEME_INT_VAL(pa);
if (mina < 0) {
if (a == -2) {
/* Yes, varargs */
return scheme_true;
}
mina = (-mina) - 1;
maxa = -1;
} else {
if (a == -2) {
/* No varargs */
return scheme_false;
}
maxa = mina;
}
} else {
if (a == -2) {
/* Check for varargs */
Scheme_Object *a;
while (!SCHEME_NULLP(pa)) {
a = SCHEME_CAR(pa);
if (SCHEME_STRUCTP(a))
return scheme_true;
pa = SCHEME_CDR(pa);
}
return scheme_false;
} else {
if (drop) {
/* Need to adjust elements (e.g., because this
procedure is a struct's apply handler) */
Scheme_Object *first = scheme_null, *last = NULL, *a;
int v;
while (SCHEME_PAIRP(pa)) {
a = SCHEME_CAR(pa);
if (SCHEME_INTP(a)) {
v = SCHEME_INT_VAL(a);
if (v < drop)
a = NULL;
else {
v -= drop;
a = scheme_make_integer(v);
}
} else {
/* arity-at-least */
a = ((Scheme_Structure *)a)->slots[0];
v = SCHEME_INT_VAL(a);
if (v >= drop) {
a = scheme_make_arity(v - drop, -1);
} else {
a = scheme_make_arity(0, -1);
}
}
if (a) {
a = scheme_make_pair(a, scheme_null);
if (last)
SCHEME_CDR(last) = a;
else
first = a;
last = a;
}
pa = SCHEME_CDR(pa);
}
return first;
}
return pa;
}
}
} else {
if (scheme_native_arity_check(p, a + drop))
return scheme_true;
else
return scheme_false;
}
#endif
} else {
Scheme_Closure_Data *data;
@ -1772,7 +1949,7 @@ int scheme_check_proc_arity2(const char *where, int a,
if (false_ok && SCHEME_FALSEP(p))
return 1;
if (!SCHEME_PROCP(p) || SCHEME_FALSEP(get_or_check_arity(p, a))) {
if (!SCHEME_PROCP(p) || SCHEME_FALSEP(scheme_get_or_check_arity(p, a))) {
if (where) {
char buffer[60];
@ -1925,12 +2102,21 @@ const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error)
goto top;
}
} else {
Scheme_Closure_Data *data;
Scheme_Object *name;
data = SCHEME_COMPILED_CLOS_CODE(p);
if (data->name) {
Scheme_Object *name;
name = data->name;
if (type == scheme_closure_type) {
name = SCHEME_COMPILED_CLOS_CODE(p)->name;
} else {
/* Native closure: */
name = ((Scheme_Native_Closure *)p)->code->u2.name;
if (name && SAME_TYPE(SCHEME_TYPE(name), scheme_unclosed_procedure_type)) {
/* Not yet jitted. Use `name' as the other alternaive of
the union: */
name = ((Scheme_Closure_Data *)name)->name;
}
}
if (name) {
if (SCHEME_VECTORP(name))
name = SCHEME_VEC_ELS(name)[0];
if (for_error < 0) {
@ -2031,7 +2217,7 @@ static Scheme_Object *object_name(int argc, Scheme_Object **argv)
Scheme_Object *scheme_arity(Scheme_Object *p)
{
return get_or_check_arity(p, -1);
return scheme_get_or_check_arity(p, -1);
}
static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
@ -2039,7 +2225,7 @@ static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_type("procedure-arity", "procedure", 0, argc, argv);
return get_or_check_arity(argv[0], -1);
return scheme_get_or_check_arity(argv[0], -1);
}
static Scheme_Object *procedure_arity_includes(int argc, Scheme_Object *argv[])
@ -2051,7 +2237,7 @@ static Scheme_Object *procedure_arity_includes(int argc, Scheme_Object *argv[])
n = scheme_extract_index("procedure-arity-includes?", 1, argc, argv, -2, 0);
return get_or_check_arity(argv[0], n);
return scheme_get_or_check_arity(argv[0], n);
}
static Scheme_Object *
@ -2076,7 +2262,7 @@ apply(int argc, Scheme_Object *argv[])
}
num_rands += (argc - 2);
if (num_rands > p->tail_buffer_size) {
if (1 || num_rands > p->tail_buffer_size) {
rand_vec = MALLOC_N(Scheme_Object *, num_rands);
/* num_rands might be very big, so don't install it as the tail buffer */
} else
@ -2140,7 +2326,7 @@ do_map(int argc, Scheme_Object *argv[], char *name, int make_result,
}
}
if (SCHEME_FALSEP(get_or_check_arity(argv[0], argc - 1))) {
if (SCHEME_FALSEP(scheme_get_or_check_arity(argv[0], argc - 1))) {
char *s;
long aelen;
@ -2969,7 +3155,7 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
Scheme_Cont *cont = (Scheme_Cont *)_cont;
Scheme_Cont_Mark_Chain *first = NULL, *last = NULL;
Scheme_Cont_Mark_Set *set;
Scheme_Object *cache;
Scheme_Object *cache, *nt;
long findpos;
long cmpos;
@ -3043,10 +3229,17 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
if (just_chain)
return (Scheme_Object *)first;
#ifdef MZ_USE_JIT
nt = scheme_native_stack_trace();
#else
nt = NULL;
#endif
set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set);
set->so.type = scheme_cont_mark_set_type;
set->chain = first;
set->cmpos = cmpos;
set->native_stack_trace = nt;
return (Scheme_Object *)set;
}
@ -3193,10 +3386,14 @@ scheme_get_stack_trace(Scheme_Object *mark_set)
Scheme_Object *l, *n, *m, *name, *loc;
Scheme_Object *a[2];
a[0] = mark_set;
a[1] = scheme_stack_dump_key;
l = ((Scheme_Cont_Mark_Set *)mark_set)->native_stack_trace;
l = extract_cc_marks(2, a);
if (!l) {
a[0] = mark_set;
a[1] = scheme_stack_dump_key;
l = extract_cc_marks(2, a);
}
/* Filter out NULLs */
while (SCHEME_PAIRP(l) && !SCHEME_CAR(l)) {
@ -3932,7 +4129,7 @@ static Scheme_Object *time_apply(int argc, Scheme_Object *argv[])
num_rands++;
}
if (SCHEME_FALSEP(get_or_check_arity(argv[0], num_rands))) {
if (SCHEME_FALSEP(scheme_get_or_check_arity(argv[0], num_rands))) {
char *s;
long aelen;
@ -4176,8 +4373,8 @@ static Scheme_Object *read_compiled_closure(Scheme_Object *obj)
if (SCHEME_TYPE(data->code) > _scheme_values_types_)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_FOLDABLE;
/* If the closure is empty, create the closure now */
if (!data->closure_size)
/* If the closure is empty, go ahead and finalize */
return scheme_make_closure(NULL, (Scheme_Object *)data, 0);
else
return (Scheme_Object *)data;

3595
src/mzscheme/src/jit.c Normal file
View File

File diff suppressed because it is too large Load Diff

10
src/mzscheme/src/lightning/README Normal file
View File

@ -0,0 +1,10 @@
This version of lightning version 1.2 is slightly modified for
MzScheme.
For PowerPC, branches can be generated in long-jump mode, so that
patched addresses are not limited to a 2^16 or 2^26 difference from
the current program counter.
For PowerPC, arguments are extracted directly from the original
registers by getarg.

197
src/mzscheme/src/lightning/i386/asm-common.h Normal file
View File

@ -0,0 +1,197 @@
/******************************** -*- C -*- ****************************
*
* Dynamic assembler support
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_asm_common_h
#define __lightning_asm_common_h_
#ifndef _ASM_SAFETY
#define JITFAIL(MSG) 0
#else
#if defined __GNUC__ && (__GNUC__ == 3 ? __GNUC_MINOR__ >= 2 : __GNUC__ > 3)
#define JITFAIL(MSG) jit_fail(MSG, __FILE__, __LINE__, __func__)
#else
#define JITFAIL(MSG) jit_fail(MSG, __FILE__, __LINE__, __FUNCTION__)
#endif
#endif
#if defined __GNUC__ && (__GNUC__ == 3 ? __GNUC_MINOR__ >= 2 : __GNUC__ > 3)
#define JITSORRY(MSG) jit_fail("sorry, unimplemented: " MSG, __FILE__, __LINE__, __func__)
#else
#define JITSORRY(MSG) jit_fail("sorry, unimplemented: " MSG, __FILE__, __LINE__, __FUNCTION__)
#endif
#ifdef __GNUC__
#define JIT_UNUSED __attribute__((unused))
#else
#define JIT_UNUSED
#endif
/* NextStep 2.0 cc is really gcc 1.93 but it defines __GNUC__ = 2 and
does not implement __extension__. But that compiler doesn't define
__GNUC_MINOR__. */
#ifdef __GNUC__
#if __GNUC__ < 2 || (defined(__NeXT__) && !__GNUC_MINOR__)
#define __extension__
#endif
#define _TEMPD(type, var)
#define _TEMP(type, var, val, body) __extension__ ({ \
register struct { type var } _jitl; _jitl.var = val; \
body; \
})
#else
/* Between loading a global and calling a subroutine, we choose the lesser
* evil. */
#define _TEMPD(type, var) static type var;
#define _TEMP(type, var, val, body) ((var = val), body)
#endif
typedef char _sc;
typedef unsigned char _uc;
typedef unsigned short _us;
typedef unsigned int _ui;
typedef long _sl;
typedef unsigned long _ul;
#define _jit_UC(X) ((_uc )(X))
#define _jit_US(X) ((_us )(X))
#define _jit_UI(X) ((_ui )(X))
#define _jit_SL(X) ((_sl )(X))
#define _jit_UL(X) ((_ul )(X))
# define _PUC(X) ((_uc *)(X))
# define _PUS(X) ((_us *)(X))
# define _PUI(X) ((_ui *)(X))
# define _PSL(X) ((_sl *)(X))
# define _PUL(X) ((_ul *)(X))
#define _jit_B(B) _jit_UL(((*_jit.x.uc_pc++)= _jit_UC((B)& 0xff)))
#define _jit_W(W) _jit_UL(((*_jit.x.us_pc++)= _jit_US((W)&0xffff)))
#define _jit_I(I) _jit_UL(((*_jit.x.ui_pc++)= _jit_UI((I) )))
#define _jit_L(L) _jit_UL(((*_jit.x.ul_pc++)= _jit_UL((L) )))
#define _jit_I_noinc(I) _jit_UL(((*_jit.x.ui_pc)= _jit_UI((I) )))
#define _MASK(N) ((unsigned)((1<<(N)))-1)
#define _siP(N,I) (!((((unsigned)(I))^(((unsigned)(I))<<1))&~_MASK(N)))
#define _uiP(N,I) (!(((unsigned)(I))&~_MASK(N)))
#define _suiP(N,I) (_siP(N,I) | _uiP(N,I))
#ifndef _ASM_SAFETY
#define _ck_s(W,I) (_jit_UL(I) & _MASK(W))
#define _ck_u(W,I) (_jit_UL(I) & _MASK(W))
#define _ck_su(W,I) (_jit_UL(I) & _MASK(W))
#define _ck_d(W,I) (_jit_UL(I) & _MASK(W))
#else
#define _ck_s(W,I) (_siP(W,I) ? (_jit_UL(I) & _MASK(W)) : JITFAIL( "signed integer `"#I"' too large for "#W"-bit field"))
#define _ck_u(W,I) (_uiP(W,I) ? (_jit_UL(I) & _MASK(W)) : JITFAIL("unsigned integer `"#I"' too large for "#W"-bit field"))
#define _ck_su(W,I) (_suiP(W,I) ? (_jit_UL(I) & _MASK(W)) : JITFAIL( "integer `"#I"' too large for "#W"-bit field"))
#define _ck_d(W,I) (_siP(W,I) ? (_jit_UL(I) & _MASK(W)) : JITFAIL( "displacement `"#I"' too large for "#W"-bit field"))
#endif
#define _s0P(I) ((I)==0)
#define _s8P(I) _siP(8,I)
#define _s16P(I) _siP(16,I)
#define _u8P(I) _uiP(8,I)
#define _u16P(I) _uiP(16,I)
#define _su8(I) _ck_su(8,I)
#define _su16(I) _ck_su(16,I)
#define _s1(I) _ck_s( 1,I)
#define _s2(I) _ck_s( 2,I)
#define _s3(I) _ck_s( 3,I)
#define _s4(I) _ck_s( 4,I)
#define _s5(I) _ck_s( 5,I)
#define _s6(I) _ck_s( 6,I)
#define _s7(I) _ck_s( 7,I)
#define _s8(I) _ck_s( 8,I)
#define _s9(I) _ck_s( 9,I)
#define _s10(I) _ck_s(10,I)
#define _s11(I) _ck_s(11,I)
#define _s12(I) _ck_s(12,I)
#define _s13(I) _ck_s(13,I)
#define _s14(I) _ck_s(14,I)
#define _s15(I) _ck_s(15,I)
#define _s16(I) _ck_s(16,I)
#define _s17(I) _ck_s(17,I)
#define _s18(I) _ck_s(18,I)
#define _s19(I) _ck_s(19,I)
#define _s20(I) _ck_s(20,I)
#define _s21(I) _ck_s(21,I)
#define _s22(I) _ck_s(22,I)
#define _s23(I) _ck_s(23,I)
#define _s24(I) _ck_s(24,I)
#define _s25(I) _ck_s(25,I)
#define _s26(I) _ck_s(26,I)
#define _s27(I) _ck_s(27,I)
#define _s28(I) _ck_s(28,I)
#define _s29(I) _ck_s(29,I)
#define _s30(I) _ck_s(30,I)
#define _s31(I) _ck_s(31,I)
#define _u1(I) _ck_u( 1,I)
#define _u2(I) _ck_u( 2,I)
#define _u3(I) _ck_u( 3,I)
#define _u4(I) _ck_u( 4,I)
#define _u5(I) _ck_u( 5,I)
#define _u6(I) _ck_u( 6,I)
#define _u7(I) _ck_u( 7,I)
#define _u8(I) _ck_u( 8,I)
#define _u9(I) _ck_u( 9,I)
#define _u10(I) _ck_u(10,I)
#define _u11(I) _ck_u(11,I)
#define _u12(I) _ck_u(12,I)
#define _u13(I) _ck_u(13,I)
#define _u14(I) _ck_u(14,I)
#define _u15(I) _ck_u(15,I)
#define _u16(I) _ck_u(16,I)
#define _u17(I) _ck_u(17,I)
#define _u18(I) _ck_u(18,I)
#define _u19(I) _ck_u(19,I)
#define _u20(I) _ck_u(20,I)
#define _u21(I) _ck_u(21,I)
#define _u22(I) _ck_u(22,I)
#define _u23(I) _ck_u(23,I)
#define _u24(I) _ck_u(24,I)
#define _u25(I) _ck_u(25,I)
#define _u26(I) _ck_u(26,I)
#define _u27(I) _ck_u(27,I)
#define _u28(I) _ck_u(28,I)
#define _u29(I) _ck_u(29,I)
#define _u30(I) _ck_u(30,I)
#define _u31(I) _ck_u(31,I)
#endif /* __lightning_asm_common_h */

1062
src/mzscheme/src/lightning/i386/asm.h Normal file
View File

File diff suppressed because it is too large Load Diff

626
src/mzscheme/src/lightning/i386/core-common.h Normal file
View File

@ -0,0 +1,626 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer support
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_core_common_h
#define __lightning_core_common_h_
typedef struct {
union {
jit_insn *pc;
_uc *uc_pc;
_us *us_pc;
_ui *ui_pc;
_ul *ul_pc;
} x;
struct jit_fp *fp;
struct jit_local_state jitl;
} jit_state;
#if 0
# ifdef jit_init
static jit_state _jit = jit_init ();
# else
static jit_state _jit;
# endif
#endif
#define JIT_NOREG (-1)
#define JIT_R0 JIT_R(0)
#define JIT_R1 JIT_R(1)
#define JIT_R2 JIT_R(2)
#define JIT_V0 JIT_V(0)
#define JIT_V1 JIT_V(1)
#define JIT_V2 JIT_V(2)
#define _jitl _jit.jitl
#define jit_get_ip() (*(jit_code *) &_jit.x.pc)
#define jit_set_ip(ptr) (_jit.x.pc = (ptr), jit_get_ip ())
#define jit_get_label() (_jit.x.pc)
#define jit_forward() (_jit.x.pc)
#define jit_field(struc, f) ( ((long) (&((struc *) 8)->f) ) - 8)
#define jit_ptr_field(struc_p, f) ( ((long) (&((struc_p) 8)->f) ) - 8)
/* realignment via N-byte no-ops */
#ifndef jit_align
#define jit_align(n)
#endif
/* jit_code: union of many possible function pointer types. Returned
* by jit_get_ip().
*/
typedef union jit_code {
char *ptr;
void (*vptr)(void);
char (*cptr)(void);
unsigned char (*ucptr)(void);
short (*sptr)(void);
unsigned short (*usptr)(void);
int (*iptr)(void);
unsigned int (*uiptr)(void);
long (*lptr)(void);
unsigned long (*ulptr)(void);
void * (*pptr)(void);
float (*fptr)(void);
double (*dptr)(void);
} jit_code;
#ifndef jit_fill_delay_after
#define jit_fill_delay_after(branch) (branch)
#endif
#define jit_delay(insn, branch) ((insn), jit_fill_delay_after(branch))
/* ALU synonyms */
#define jit_addi_ui(d, rs, is) jit_addi_i((d), (rs), (is))
#define jit_addr_ui(d, s1, s2) jit_addr_i((d), (s1), (s2))
#define jit_addci_ui(d, rs, is) jit_addci_i((d), (rs), (is))
#define jit_addcr_ui(d, s1, s2) jit_addcr_i((d), (s1), (s2))
#define jit_addxi_ui(d, rs, is) jit_addxi_i((d), (rs), (is))
#define jit_addxr_ui(d, s1, s2) jit_addxr_i((d), (s1), (s2))
#define jit_andi_ui(d, rs, is) jit_andi_i((d), (rs), (is))
#define jit_andr_ui(d, s1, s2) jit_andr_i((d), (s1), (s2))
#define jit_lshi_ui(d, rs, is) jit_lshi_i((d), (rs), (is))
#define jit_lshr_ui(d, s1, s2) jit_lshr_i((d), (s1), (s2))
#define jit_movi_ui(d, rs) jit_movi_i((d), (rs))
#define jit_movr_ui(d, rs) jit_movr_i((d), (rs))
#define jit_ori_ui(d, rs, is) jit_ori_i((d), (rs), (is))
#define jit_orr_ui(d, s1, s2) jit_orr_i((d), (s1), (s2))
#define jit_rsbi_ui(d, rs, is) jit_rsbi_i((d), (rs), (is))
#define jit_rsbr_ui(d, s1, s2) jit_rsbr_i((d), (s1), (s2))
#define jit_subi_ui(d, rs, is) jit_subi_i((d), (rs), (is))
#define jit_subr_ui(d, s1, s2) jit_subr_i((d), (s1), (s2))
#define jit_subci_ui(d, rs, is) jit_subci_i((d), (rs), (is))
#define jit_subcr_ui(d, s1, s2) jit_subcr_i((d), (s1), (s2))
#define jit_subxi_ui(d, rs, is) jit_subxi_i((d), (rs), (is))
#define jit_subxr_ui(d, s1, s2) jit_subxr_i((d), (s1), (s2))
#define jit_xori_ui(d, rs, is) jit_xori_i((d), (rs), (is))
#define jit_xorr_ui(d, s1, s2) jit_xorr_i((d), (s1), (s2))
#define jit_addi_ul(d, rs, is) jit_addi_l((d), (rs), (is))
#define jit_addr_ul(d, s1, s2) jit_addr_l((d), (s1), (s2))
#define jit_addci_ul(d, rs, is) jit_addci_l((d), (rs), (is))
#define jit_addcr_ul(d, s1, s2) jit_addcr_l((d), (s1), (s2))
#define jit_addxi_ul(d, rs, is) jit_addxi_l((d), (rs), (is))
#define jit_addxr_ul(d, s1, s2) jit_addxr_l((d), (s1), (s2))
#define jit_andi_ul(d, rs, is) jit_andi_l((d), (rs), (is))
#define jit_andr_ul(d, s1, s2) jit_andr_l((d), (s1), (s2))
#define jit_lshi_ul(d, rs, is) jit_lshi_l((d), (rs), (is))
#define jit_lshr_ul(d, s1, s2) jit_lshr_l((d), (s1), (s2))
#define jit_movi_ul(d, rs) jit_movi_l((d), (rs))
#define jit_movr_ul(d, rs) jit_movr_l((d), (rs))
#define jit_ori_ul(d, rs, is) jit_ori_l((d), (rs), (is))
#define jit_orr_ul(d, s1, s2) jit_orr_l((d), (s1), (s2))
#define jit_rsbi_ul(d, rs, is) jit_rsbi_l((d), (rs), (is))
#define jit_rsbr_ul(d, s1, s2) jit_rsbr_l((d), (s1), (s2))
#define jit_subi_ul(d, rs, is) jit_subi_l((d), (rs), (is))
#define jit_subr_ul(d, s1, s2) jit_subr_l((d), (s1), (s2))
#define jit_subci_ul(d, rs, is) jit_subci_l((d), (rs), (is))
#define jit_subcr_ul(d, s1, s2) jit_subcr_l((d), (s1), (s2))
#define jit_subxi_ui(d, rs, is) jit_subxi_i((d), (rs), (is))
#define jit_subxi_ul(d, rs, is) jit_subxi_l((d), (rs), (is))
#define jit_subxr_ui(d, s1, s2) jit_subxr_i((d), (s1), (s2))
#define jit_subxr_ul(d, s1, s2) jit_subxr_i((d), (s1), (s2))
#define jit_xori_ul(d, rs, is) jit_xori_l((d), (rs), (is))
#define jit_xorr_ul(d, s1, s2) jit_xorr_l((d), (s1), (s2))
#define jit_addr_p(d, s1, s2) jit_addr_ul((d), (s1), (s2))
#define jit_addi_p(d, rs, is) jit_addi_ul((d), (rs), (long) (is))
#define jit_movr_p(d, rs) jit_movr_ul((d), (rs))
#define jit_subr_p(d, s1, s2) jit_subr_ul((d), (s1), (s2))
#define jit_subi_p(d, rs, is) jit_subi_ul((d), (rs), (long) (is))
#define jit_rsbi_p(d, rs, is) jit_rsbi_ul((d), (rs), (long) (is))
#ifndef jit_movi_p
#define jit_movi_p(d, is) (jit_movi_ul((d), (long) (is)), _jit.x.pc)
#endif
#define jit_patch(pv) jit_patch_at ((pv), (_jit.x.pc))
#ifndef jit_addci_i
#define jit_addci_i(d, rs, is) jit_addi_i((d), (rs), (is))
#define jit_addcr_i(d, s1, s2) jit_addr_i((d), (s1), (s2))
#define jit_addci_l(d, rs, is) jit_addi_l((d), (rs), (is))
#define jit_addcr_l(d, s1, s2) jit_addr_l((d), (s1), (s2))
#endif
#ifndef jit_subcr_i
#define jit_subcr_i(d, s1, s2) jit_subr_i((d), (s1), (s2))
#endif
/* NEG is not mandatory -- pick an appropriate implementation */
#ifndef jit_negr_i
# ifdef JIT_RZERO
# define jit_negr_i(d, rs) jit_subr_i((d), JIT_RZERO, (rs))
# define jit_negr_l(d, rs) jit_subr_l((d), JIT_RZERO, (rs))
# else /* !JIT_RZERO */
# ifndef jit_rsbi_i
# define jit_negr_i(d, rs) (jit_xori_i((d), (rs), -1), jit_addi_l((d), (d), 1))
# define jit_negr_l(d, rs) (jit_xori_l((d), (rs), -1), jit_addi_l((d), (d), 1))
# else /* jit_rsbi_i */
# define jit_negr_i(d, rs) jit_rsbi_i((d), (rs), 0)
# define jit_negr_l(d, rs) jit_rsbi_l((d), (rs), 0)
# endif /* jit_rsbi_i */
# endif /* !JIT_RZERO */
#endif /* !jit_negr_i */
/* RSB is not mandatory */
#ifndef jit_rsbi_i
# define jit_rsbi_i(d, rs, is) (jit_subi_i((d), (rs), (is)), jit_negr_i((d), (d)))
# ifndef jit_rsbi_l
# define jit_rsbi_l(d, rs, is) (jit_subi_l((d), (rs), (is)), jit_negr_l((d), (d)))
# endif
#endif
/* Common 'shortcut' implementations */
#define jit_subi_i(d, rs, is) jit_addi_i((d), (rs), -(is))
#define jit_subi_l(d, rs, is) jit_addi_l((d), (rs), -(is))
#define jit_subci_i(d, rs, is) jit_addci_i((d), (rs), -(is))
#define jit_subci_l(d, rs, is) jit_addci_l((d), (rs), -(is))
#define jit_rsbr_f(d, s1, s2) jit_subr_f((d), (s2), (s1))
#define jit_rsbr_d(d, s1, s2) jit_subr_d((d), (s2), (s1))
#define jit_rsbr_i(d, s1, s2) jit_subr_i((d), (s2), (s1))
#define jit_rsbr_l(d, s1, s2) jit_subr_l((d), (s2), (s1))
#define jit_rsbr_p(d, s1, s2) jit_subr_p((d), (s2), (s1))
/* Unary */
#define jit_notr_c(d, rs) jit_xori_c((d), (rs), 255)
#define jit_notr_uc(d, rs) jit_xori_c((d), (rs), 255)
#define jit_notr_s(d, rs) jit_xori_s((d), (rs), 65535)
#define jit_notr_us(d, rs) jit_xori_s((d), (rs), 65535)
#define jit_notr_i(d, rs) jit_xori_i((d), (rs), ~0)
#define jit_notr_ui(d, rs) jit_xori_i((d), (rs), ~0)
#define jit_notr_l(d, rs) jit_xori_l((d), (rs), ~0L)
#define jit_notr_ul(d, rs) jit_xori_l((d), (rs), ~0L)
#ifndef jit_extr_c_ui
#define jit_extr_c_ui(d, rs) jit_andi_ui((d), (rs), 0xFF)
#endif
#ifndef jit_extr_s_ui
#define jit_extr_s_ui(d, rs) jit_andi_ui((d), (rs), 0xFFFF)
#endif
#ifndef jit_extr_c_i
#define jit_extr_c_i(d, rs) (jit_lshi_i((d), (rs), 24), jit_rshi_i((d), (d), 24))
#endif
#ifndef jit_extr_s_i
#define jit_extr_s_i(d, rs) (jit_lshi_i((d), (rs), 16), jit_rshi_i((d), (d), 16))
#endif
#ifdef jit_addi_l /* sizeof(long) != sizeof(int) */
#ifndef jit_extr_c_l
#define jit_extr_c_l(d, rs) (jit_lshi_l((d), (rs), 56), jit_rshi_l((d), (d), 56))
#endif
#ifndef jit_extr_s_l
#define jit_extr_s_l(d, rs) (jit_lshi_l((d), (rs), 48), jit_rshi_l((d), (d), 48))
#endif
#ifndef jit_extr_i_l
#define jit_extr_i_l(d, rs) (jit_lshi_l((d), (rs), 32), jit_rshi_l((d), (d), 32))
#endif
#ifndef jit_extr_c_ul
#define jit_extr_c_ul(d, rs) jit_andi_l((d), (rs), 0xFF)
#endif
#ifndef jit_extr_s_ul
#define jit_extr_s_ul(d, rs) jit_andi_l((d), (rs), 0xFFFF)
#endif
#ifndef jit_extr_i_ul
#define jit_extr_i_ul(d, rs) jit_andi_l((d), (rs), 0xFFFFFFFFUL)
#endif
#endif
#define jit_extr_c_s(d, rs) jit_extr_c_i((d), (rs))
#define jit_extr_c_us(d, rs) jit_extr_c_ui((d), (rs))
#define jit_extr_uc_s(d, rs) jit_extr_uc_i((d), (rs))
#define jit_extr_uc_us(d, rs) jit_extr_uc_ui((d), (rs))
#define jit_extr_uc_i(d, rs) jit_extr_c_ui((d), (rs))
#define jit_extr_uc_ui(d, rs) jit_extr_c_ui((d), (rs))
#define jit_extr_us_i(d, rs) jit_extr_s_ui((d), (rs))
#define jit_extr_us_ui(d, rs) jit_extr_s_ui((d), (rs))
#define jit_extr_uc_l(d, rs) jit_extr_c_ul((d), (rs))
#define jit_extr_uc_ul(d, rs) jit_extr_c_ul((d), (rs))
#define jit_extr_us_l(d, rs) jit_extr_s_ul((d), (rs))
#define jit_extr_us_ul(d, rs) jit_extr_s_ul((d), (rs))
#define jit_extr_ui_l(d, rs) jit_extr_i_ul((d), (rs))
#define jit_extr_ui_ul(d, rs) jit_extr_i_ul((d), (rs))
/* NTOH/HTON is not mandatory for big endian architectures */
#ifndef jit_ntoh_ui /* big endian */
#define jit_ntoh_ui(d, rs) ((d) == (rs) ? (void)0 : jit_movr_i((d), (rs)))
#define jit_ntoh_us(d, rs) ((d) == (rs) ? (void)0 : jit_movr_i((d), (rs)))
#endif /* big endian */
/* hton is a synonym for ntoh */
#define jit_hton_ui(d, rs) jit_ntoh_ui((d), (rs))
#define jit_hton_us(d, rs) jit_ntoh_us((d), (rs))
/* Stack synonyms */
#define jit_pushr_ui(rs) jit_pushr_i(rs)
#define jit_popr_ui(rs) jit_popr_i(rs)
#define jit_pushr_ul(rs) jit_pushr_l(rs)
#define jit_popr_ul(rs) jit_popr_l(rs)
#define jit_pushr_p(rs) jit_pushr_ul(rs)
#define jit_popr_p(rs) jit_popr_ul(rs)
#define jit_prepare(nint) jit_prepare_i((nint))
#define jit_pusharg_c(rs) jit_pusharg_i(rs)
#define jit_pusharg_s(rs) jit_pusharg_i(rs)
#define jit_pusharg_uc(rs) jit_pusharg_i(rs)
#define jit_pusharg_us(rs) jit_pusharg_i(rs)
#define jit_pusharg_ui(rs) jit_pusharg_i(rs)
#define jit_pusharg_ul(rs) jit_pusharg_l(rs)
#define jit_pusharg_p(rs) jit_pusharg_ul(rs)
/* Memory synonyms */
#ifdef JIT_RZERO
#ifndef jit_ldi_c
#define jit_ldi_c(rd, is) jit_ldxi_c((rd), JIT_RZERO, (is))
#define jit_sti_c(id, rs) jit_stxi_c((id), JIT_RZERO, (rs))
#define jit_ldi_s(rd, is) jit_ldxi_s((rd), JIT_RZERO, (is))
#define jit_sti_s(id, rs) jit_stxi_s((id), JIT_RZERO, (rs))
#define jit_ldi_i(rd, is) jit_ldxi_i((rd), JIT_RZERO, (is))
#define jit_sti_i(id, rs) jit_stxi_i((id), JIT_RZERO, (rs))
#define jit_ldi_l(rd, is) jit_ldxi_l((rd), JIT_RZERO, (is))
#define jit_sti_l(id, rs) jit_stxi_l((id), JIT_RZERO, (rs))
#define jit_ldi_uc(rd, is) jit_ldxi_uc((rd), JIT_RZERO, (is))
#define jit_ldi_us(rd, is) jit_ldxi_us((rd), JIT_RZERO, (is))
#define jit_ldi_ui(rd, is) jit_ldxi_ui((rd), JIT_RZERO, (is))
#define jit_ldi_ul(rd, is) jit_ldxi_ul((rd), JIT_RZERO, (is))
#endif
#ifndef jit_ldr_c
#define jit_ldr_c(rd, rs) jit_ldxr_c((rd), JIT_RZERO, (rs))
#define jit_str_c(rd, rs) jit_stxr_c(JIT_RZERO, (rd), (rs))
#define jit_ldr_s(rd, rs) jit_ldxr_s((rd), JIT_RZERO, (rs))
#define jit_str_s(rd, rs) jit_stxr_s(JIT_RZERO, (rd), (rs))
#define jit_ldr_i(rd, rs) jit_ldxr_i((rd), JIT_RZERO, (rs))
#define jit_str_i(rd, rs) jit_stxr_i(JIT_RZERO, (rd), (rs))
#define jit_ldr_l(rd, rs) jit_ldxr_l((rd), JIT_RZERO, (rs))
#define jit_str_l(rd, rs) jit_stxr_l(JIT_RZERO, (rd), (rs))
#define jit_ldr_uc(rd, rs) jit_ldxr_uc((rd), JIT_RZERO, (rs))
#define jit_ldr_us(rd, rs) jit_ldxr_us((rd), JIT_RZERO, (rs))
#define jit_ldr_ui(rd, rs) jit_ldxr_ui((rd), JIT_RZERO, (rs))
#define jit_ldr_ul(rd, rs) jit_ldxr_ul((rd), JIT_RZERO, (rs))
#endif
#endif
#define jit_str_uc(rd, rs) jit_str_c((rd), (rs))
#define jit_sti_uc(id, rs) jit_sti_c((id), (rs))
#define jit_stxr_uc(d1, d2, rs) jit_stxr_c((d1), (d2), (rs))
#define jit_stxi_uc(id, rd, is) jit_stxi_c((id), (rd), (is))
#define jit_str_us(rd, rs) jit_str_s((rd), (rs))
#define jit_sti_us(id, rs) jit_sti_s((id), (rs))
#define jit_stxr_us(d1, d2, rs) jit_stxr_s((d1), (d2), (rs))
#define jit_stxi_us(id, rd, is) jit_stxi_s((id), (rd), (is))
#define jit_str_ui(rd, rs) jit_str_i((rd), (rs))
#define jit_sti_ui(id, rs) jit_sti_i((id), (rs))
#define jit_stxr_ui(d1, d2, rs) jit_stxr_i((d1), (d2), (rs))
#define jit_stxi_ui(id, rd, is) jit_stxi_i((id), (rd), (is))
#define jit_str_ul(rd, rs) jit_str_l((rd), (rs))
#define jit_sti_ul(id, rs) jit_sti_l((id), (rs))
#define jit_stxr_ul(d1, d2, rs) jit_stxr_l((d1), (d2), (rs))
#define jit_stxi_ul(id, rd, is) jit_stxi_l((id), (rd), (is))
#define jit_str_p(rd, rs) jit_str_l((rd), (rs))
#define jit_sti_p(id, rs) jit_sti_l((id), (rs))
#define jit_stxr_p(d1, d2, rs) jit_stxr_l((d1), (d2), (rs))
#define jit_stxi_p(id, rd, is) jit_stxi_l((id), (rd), (is))
#define jit_ldr_p(rd, rs) jit_ldr_l((rd), (rs))
#define jit_ldi_p(rd, is) jit_ldi_l((rd), (is))
#define jit_ldxr_p(rd, s1, s2) jit_ldxr_l((rd), (s1), (s2))
#define jit_ldxi_p(rd, rs, is) jit_ldxi_l((rd), (rs), (is))
/* Boolean & branch synonyms */
#define jit_eqr_ui(d, s1, s2) jit_eqr_i((d), (s1), (s2))
#define jit_eqi_ui(d, rs, is) jit_eqi_i((d), (rs), (is))
#define jit_ner_ui(d, s1, s2) jit_ner_i((d), (s1), (s2))
#define jit_nei_ui(d, rs, is) jit_nei_i((d), (rs), (is))
#define jit_eqr_ul(d, s1, s2) jit_eqr_l((d), (s1), (s2))
#define jit_eqi_ul(d, rs, is) jit_eqi_l((d), (rs), (is))
#define jit_ner_ul(d, s1, s2) jit_ner_l((d), (s1), (s2))
#define jit_nei_ul(d, rs, is) jit_nei_l((d), (rs), (is))
#define jit_beqr_ui(label, s1, s2) jit_beqr_i((label), (s1), (s2))
#define jit_beqi_ui(label, rs, is) jit_beqi_i((label), (rs), (is))
#define jit_bner_ui(label, s1, s2) jit_bner_i((label), (s1), (s2))
#define jit_bnei_ui(label, rs, is) jit_bnei_i((label), (rs), (is))
#define jit_bmcr_ui(label, s1, s2) jit_bmcr_i((label), (s1), (s2))
#define jit_bmci_ui(label, rs, is) jit_bmci_i((label), (rs), (is))
#define jit_bmsr_ui(label, s1, s2) jit_bmsr_i((label), (s1), (s2))
#define jit_bmsi_ui(label, rs, is) jit_bmsi_i((label), (rs), (is))
#define jit_beqr_ul(label, s1, s2) jit_beqr_l((label), (s1), (s2))
#define jit_beqi_ul(label, rs, is) jit_beqi_l((label), (rs), (is))
#define jit_bner_ul(label, s1, s2) jit_bner_l((label), (s1), (s2))
#define jit_bnei_ul(label, rs, is) jit_bnei_l((label), (rs), (is))
#define jit_bmcr_ul(label, s1, s2) jit_bmcr_l((label), (s1), (s2))
#define jit_bmci_ul(label, rs, is) jit_bmci_l((label), (rs), (is))
#define jit_bmsr_ul(label, s1, s2) jit_bmsr_l((label), (s1), (s2))
#define jit_bmsi_ul(label, rs, is) jit_bmsi_l((label), (rs), (is))
#define jit_ltr_p(d, s1, s2) jit_ltr_ul((d), (s1), (s2))
#define jit_lti_p(d, rs, is) jit_lti_ul((d), (rs), (is))
#define jit_ler_p(d, s1, s2) jit_ler_ul((d), (s1), (s2))
#define jit_lei_p(d, rs, is) jit_lei_ul((d), (rs), (is))
#define jit_gtr_p(d, s1, s2) jit_gtr_ul((d), (s1), (s2))
#define jit_gti_p(d, rs, is) jit_gti_ul((d), (rs), (is))
#define jit_ger_p(d, s1, s2) jit_ger_ul((d), (s1), (s2))
#define jit_gei_p(d, rs, is) jit_gei_ul((d), (rs), (is))
#define jit_eqr_p(d, s1, s2) jit_eqr_ul((d), (s1), (s2))
#define jit_eqi_p(d, rs, is) jit_eqi_ul((d), (rs), (is))
#define jit_ner_p(d, s1, s2) jit_ner_ul((d), (s1), (s2))
#define jit_nei_p(d, rs, is) jit_nei_ul((d), (rs), (is))
#define jit_bltr_p(label, s1, s2) jit_bltr_ul((label), (s1), (s2))
#define jit_blti_p(label, rs, is) jit_blti_ul((label), (rs), (is))
#define jit_bler_p(label, s1, s2) jit_bler_ul((label), (s1), (s2))
#define jit_blei_p(label, rs, is) jit_blei_ul((label), (rs), (is))
#define jit_bgtr_p(label, s1, s2) jit_bgtr_ul((label), (s1), (s2))
#define jit_bgti_p(label, rs, is) jit_bgti_ul((label), (rs), (is))
#define jit_bger_p(label, s1, s2) jit_bger_ul((label), (s1), (s2))
#define jit_bgei_p(label, rs, is) jit_bgei_ul((label), (rs), (is))
#define jit_beqr_p(label, s1, s2) jit_beqr_ul((label), (s1), (s2))
#define jit_beqi_p(label, rs, is) jit_beqi_ul((label), (rs), (is))
#define jit_bner_p(label, s1, s2) jit_bner_ul((label), (s1), (s2))
#define jit_bnei_p(label, rs, is) jit_bnei_ul((label), (rs), (is))
#define jit_retval_ui(rd) jit_retval_i((rd))
#define jit_retval_uc(rd) jit_retval_i((rd))
#define jit_retval_us(rd) jit_retval_i((rd))
#define jit_retval_ul(rd) jit_retval_l((rd))
#define jit_retval_p(rd) jit_retval_ul((rd))
#define jit_retval_c(rd) jit_retval_i((rd))
#define jit_retval_s(rd) jit_retval_i((rd))
/* This was a bug, but we keep it. */
#define jit_retval(rd) jit_retval_i ((rd))
#ifndef jit_finish
#define jit_finish(sub) jit_calli(sub)
#endif
#ifndef jit_finishr
#define jit_finishr(reg) jit_callr(reg)
#endif
#ifndef jit_prolog
#define jit_prolog(numargs)
#endif
#ifndef jit_leaf
#define jit_leaf(numargs) jit_prolog(numargs)
#endif
#ifndef jit_getarg_c
#ifndef JIT_FP
#define jit_getarg_c(reg, ofs) jit_extr_c_i ((reg), (ofs))
#define jit_getarg_i(reg, ofs) jit_movr_i ((reg), (ofs))
#define jit_getarg_l(reg, ofs) jit_movr_l ((reg), (ofs))
#define jit_getarg_p(reg, ofs) jit_movr_p ((reg), (ofs))
#define jit_getarg_s(reg, ofs) jit_extr_s_i ((reg), (ofs))
#define jit_getarg_uc(reg, ofs) jit_extr_uc_ui((reg), (ofs))
#define jit_getarg_ui(reg, ofs) jit_movr_ui ((reg), (ofs))
#define jit_getarg_ul(reg, ofs) jit_extr_uc_ul((reg), (ofs))
#define jit_getarg_us(reg, ofs) jit_extr_us_ul((reg), (ofs))
#else
#define jit_getarg_c(reg, ofs) jit_ldxi_c((reg), JIT_FP, (ofs));
#define jit_getarg_uc(reg, ofs) jit_ldxi_uc((reg), JIT_FP, (ofs));
#define jit_getarg_s(reg, ofs) jit_ldxi_s((reg), JIT_FP, (ofs));
#define jit_getarg_us(reg, ofs) jit_ldxi_us((reg), JIT_FP, (ofs));
#define jit_getarg_i(reg, ofs) jit_ldxi_i((reg), JIT_FP, (ofs));
#define jit_getarg_ui(reg, ofs) jit_ldxi_ui((reg), JIT_FP, (ofs));
#define jit_getarg_l(reg, ofs) jit_ldxi_l((reg), JIT_FP, (ofs));
#define jit_getarg_ul(reg, ofs) jit_ldxi_ul((reg), JIT_FP, (ofs));
#define jit_getarg_p(reg, ofs) jit_ldxi_p((reg), JIT_FP, (ofs));
#endif
#endif
/* Common definitions when sizeof(long) = sizeof(int) */
#ifndef jit_addi_l
#define JIT_LONG_IS_INT
/* ALU */
#define jit_addi_l(d, rs, is) jit_addi_i((d), (rs), (is))
#define jit_addr_l(d, s1, s2) jit_addr_i((d), (s1), (s2))
#define jit_addci_l(d, rs, is) jit_addci_i((d), (rs), (is))
#define jit_addcr_l(d, s1, s2) jit_addcr_i((d), (s1), (s2))
#define jit_addxi_l(d, rs, is) jit_addxi_i((d), (rs), (is))
#define jit_addxr_l(d, s1, s2) jit_addxr_i((d), (s1), (s2))
#define jit_andi_l(d, rs, is) jit_andi_i((d), (rs), (is))
#define jit_andr_l(d, s1, s2) jit_andr_i((d), (s1), (s2))
#define jit_divi_l(d, rs, is) jit_divi_i((d), (rs), (is))
#define jit_divr_l(d, s1, s2) jit_divr_i((d), (s1), (s2))
#define jit_hmuli_l(d, rs, is) jit_hmuli_i((d), (rs), (is))
#define jit_hmulr_l(d, s1, s2) jit_hmulr_i((d), (s1), (s2))
#define jit_lshi_l(d, rs, is) jit_lshi_i((d), (rs), (is))
#define jit_lshr_l(d, s1, s2) jit_lshr_i((d), (s1), (s2))
#define jit_modi_l(d, rs, is) jit_modi_i((d), (rs), (is))
#define jit_modr_l(d, s1, s2) jit_modr_i((d), (s1), (s2))
#define jit_muli_l(d, rs, is) jit_muli_i((d), (rs), (is))
#define jit_mulr_l(d, s1, s2) jit_mulr_i((d), (s1), (s2))
#define jit_ori_l(d, rs, is) jit_ori_i((d), (rs), (is))
#define jit_orr_l(d, s1, s2) jit_orr_i((d), (s1), (s2))
#define jit_rshi_l(d, rs, is) jit_rshi_i((d), (rs), (is))
#define jit_rshr_l(d, s1, s2) jit_rshr_i((d), (s1), (s2))
#define jit_subr_l(d, s1, s2) jit_subr_i((d), (s1), (s2))
#define jit_subcr_l(d, s1, s2) jit_subcr_i((d), (s1), (s2))
#define jit_subxi_l(d, rs, is) jit_subxi_i((d), (rs), (is))
#define jit_subxr_l(d, s1, s2) jit_subxr_i((d), (s1), (s2))
#define jit_xori_l(d, rs, is) jit_xori_i((d), (rs), (is))
#define jit_xorr_l(d, s1, s2) jit_xorr_i((d), (s1), (s2))
#ifndef jit_rsbi_l
#define jit_rsbi_l(d, rs, is) jit_rsbi_i((d), (rs), (is))
#endif
#define jit_divi_ul(d, rs, is) jit_divi_ui((d), (rs), (is))
#define jit_divr_ul(d, s1, s2) jit_divr_ui((d), (s1), (s2))
#define jit_hmuli_ul(d, rs, is) jit_hmuli_ui((d), (rs), (is))
#define jit_hmulr_ul(d, s1, s2) jit_hmulr_ui((d), (s1), (s2))
#define jit_modi_ul(d, rs, is) jit_modi_ui((d), (rs), (is))
#define jit_modr_ul(d, s1, s2) jit_modr_ui((d), (s1), (s2))
#define jit_muli_ul(d, rs, is) jit_muli_ui((d), (rs), (is))
#define jit_mulr_ul(d, s1, s2) jit_mulr_ui((d), (s1), (s2))
#define jit_rshi_ul(d, rs, is) jit_rshi_ui((d), (rs), (is))
#define jit_rshr_ul(d, s1, s2) jit_rshr_ui((d), (s1), (s2))
/* Sign/Zero extension */
#define jit_extr_c_l(d, rs) jit_extr_c_i(d, rs)
#define jit_extr_c_ul(d, rs) jit_extr_c_ui(d, rs)
#define jit_extr_s_l(d, rs) jit_extr_s_i(d, rs)
#define jit_extr_s_ul(d, rs) jit_extr_s_ui(d, rs)
#define jit_extr_i_l(d, rs) jit_movr_i(d, rs)
#define jit_extr_i_ul(d, rs) jit_movr_i(d, rs)
/* Unary */
#define jit_movi_l(d, rs) jit_movi_i((d), (rs))
#define jit_movr_l(d, rs) jit_movr_i((d), (rs))
/* Stack */
#define jit_pushr_l(rs) jit_pushr_i(rs)
#define jit_popr_l(rs) jit_popr_i(rs)
#define jit_pusharg_l(rs) jit_pusharg_i(rs)
/* Memory */
#ifndef JIT_RZERO
#define jit_ldr_l(d, rs) jit_ldr_i((d), (rs))
#define jit_ldi_l(d, is) jit_ldi_i((d), (is))
#define jit_str_l(d, rs) jit_str_i((d), (rs))
#define jit_sti_l(d, is) jit_sti_i((d), (is))
#define jit_ldr_ui(d, rs) jit_ldr_i((d), (rs))
#define jit_ldi_ui(d, is) jit_ldi_i((d), (is))
#define jit_ldr_ul(d, rs) jit_ldr_ui((d), (rs))
#define jit_ldi_ul(d, is) jit_ldi_ui((d), (is))
#endif
#define jit_ldxr_l(d, s1, s2) jit_ldxr_i((d), (s1), (s2))
#define jit_ldxi_l(d, rs, is) jit_ldxi_i((d), (rs), (is))
#define jit_stxr_l(d, s1, s2) jit_stxr_i((d), (s1), (s2))
#define jit_stxi_l(d, rs, is) jit_stxi_i((d), (rs), (is))
#define jit_ldxr_ui(d, s1, s2) jit_ldxr_i((d), (s1), (s2))
#define jit_ldxi_ui(d, rs, is) jit_ldxi_i((d), (rs), (is))
#define jit_ldxr_ul(d, s1, s2) jit_ldxr_ui((d), (s1), (s2))
#define jit_ldxi_ul(d, rs, is) jit_ldxi_ui((d), (rs), (is))
/* Boolean */
#define jit_ltr_l(d, s1, s2) jit_ltr_i((d), (s1), (s2))
#define jit_lti_l(d, rs, is) jit_lti_i((d), (rs), (is))
#define jit_ler_l(d, s1, s2) jit_ler_i((d), (s1), (s2))
#define jit_lei_l(d, rs, is) jit_lei_i((d), (rs), (is))
#define jit_gtr_l(d, s1, s2) jit_gtr_i((d), (s1), (s2))
#define jit_gti_l(d, rs, is) jit_gti_i((d), (rs), (is))
#define jit_ger_l(d, s1, s2) jit_ger_i((d), (s1), (s2))
#define jit_gei_l(d, rs, is) jit_gei_i((d), (rs), (is))
#define jit_eqr_l(d, s1, s2) jit_eqr_i((d), (s1), (s2))
#define jit_eqi_l(d, rs, is) jit_eqi_i((d), (rs), (is))
#define jit_ner_l(d, s1, s2) jit_ner_i((d), (s1), (s2))
#define jit_nei_l(d, rs, is) jit_nei_i((d), (rs), (is))
#define jit_ltr_ul(d, s1, s2) jit_ltr_ui((d), (s1), (s2))
#define jit_lti_ul(d, rs, is) jit_lti_ui((d), (rs), (is))
#define jit_ler_ul(d, s1, s2) jit_ler_ui((d), (s1), (s2))
#define jit_lei_ul(d, rs, is) jit_lei_ui((d), (rs), (is))
#define jit_gtr_ul(d, s1, s2) jit_gtr_ui((d), (s1), (s2))
#define jit_gti_ul(d, rs, is) jit_gti_ui((d), (rs), (is))
#define jit_ger_ul(d, s1, s2) jit_ger_ui((d), (s1), (s2))
#define jit_gei_ul(d, rs, is) jit_gei_ui((d), (rs), (is))
/* Branches */
#define jit_bltr_l(label, s1, s2) jit_bltr_i((label), (s1), (s2))
#define jit_blti_l(label, rs, is) jit_blti_i((label), (rs), (is))
#define jit_bler_l(label, s1, s2) jit_bler_i((label), (s1), (s2))
#define jit_blei_l(label, rs, is) jit_blei_i((label), (rs), (is))
#define jit_bgtr_l(label, s1, s2) jit_bgtr_i((label), (s1), (s2))
#define jit_bgti_l(label, rs, is) jit_bgti_i((label), (rs), (is))
#define jit_bger_l(label, s1, s2) jit_bger_i((label), (s1), (s2))
#define jit_bgei_l(label, rs, is) jit_bgei_i((label), (rs), (is))
#define jit_beqr_l(label, s1, s2) jit_beqr_i((label), (s1), (s2))
#define jit_beqi_l(label, rs, is) jit_beqi_i((label), (rs), (is))
#define jit_bner_l(label, s1, s2) jit_bner_i((label), (s1), (s2))
#define jit_bnei_l(label, rs, is) jit_bnei_i((label), (rs), (is))
#define jit_bmcr_l(label, s1, s2) jit_bmcr_i((label), (s1), (s2))
#define jit_bmci_l(label, rs, is) jit_bmci_i((label), (rs), (is))
#define jit_bmsr_l(label, s1, s2) jit_bmsr_i((label), (s1), (s2))
#define jit_bmsi_l(label, rs, is) jit_bmsi_i((label), (rs), (is))
#define jit_boaddr_l(label, s1, s2) jit_boaddr_i((label), (s1), (s2))
#define jit_boaddi_l(label, rs, is) jit_boaddi_i((label), (rs), (is))
#define jit_bosubr_l(label, s1, s2) jit_bosubr_i((label), (s1), (s2))
#define jit_bosubi_l(label, rs, is) jit_bosubi_i((label), (rs), (is))
#define jit_bltr_ul(label, s1, s2) jit_bltr_ui((label), (s1), (s2))
#define jit_blti_ul(label, rs, is) jit_blti_ui((label), (rs), (is))
#define jit_bler_ul(label, s1, s2) jit_bler_ui((label), (s1), (s2))
#define jit_blei_ul(label, rs, is) jit_blei_ui((label), (rs), (is))
#define jit_bgtr_ul(label, s1, s2) jit_bgtr_ui((label), (s1), (s2))
#define jit_bgti_ul(label, rs, is) jit_bgti_ui((label), (rs), (is))
#define jit_bger_ul(label, s1, s2) jit_bger_ui((label), (s1), (s2))
#define jit_bgei_ul(label, rs, is) jit_bgei_ui((label), (rs), (is))
#define jit_boaddr_ul(label, s1, s2) jit_boaddr_ui((label), (s1), (s2))
#define jit_boaddi_ul(label, rs, is) jit_boaddi_ui((label), (rs), (is))
#define jit_bosubr_ul(label, s1, s2) jit_bosubr_ui((label), (s1), (s2))
#define jit_bosubi_ul(label, rs, is) jit_bosubi_ui((label), (rs), (is))
#define jit_retval_l(rd) jit_retval_i((rd))
#endif
#endif /* __lightning_core_common_h_ */

413
src/mzscheme/src/lightning/i386/core.h Normal file
View File

@ -0,0 +1,413 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer (i386 version)
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_core_h
#define __lightning_core_h
#define JIT_FP _EBP
#define JIT_SP _ESP
#define JIT_RET _EAX
#define JIT_R_NUM 3
#define JIT_V_NUM 3
#define JIT_R(i) (_EAX + (i))
#define JIT_V(i) ((i) == 0 ? _EBX : _ESI + (i) - 1)
struct jit_local_state {
int framesize;
int argssize;
};
/* 3-parameter operation */
#define jit_opr_(d, s1, s2, op1d, op2d) \
( (s2 == d) ? op1d : \
( ((s1 == d) ? (void)0 : (void)MOVLrr(s1, d)), op2d ) \
)
/* 3-parameter operation, with immediate */
#define jit_op_(d, s1, op2d) \
((s1 == d) ? op2d : (MOVLrr(s1, d), op2d)) \
/* 3-parameter operation, optimizable */
#define jit_opo_(d, s1, s2, op1d, op2d, op12d) \
((s2 == d) ? op2d : \
((s1 == d) ? op1d : op12d))
/* 3-parameter operation, optimizable, with immediate */
#define jit_opi_(d, rs, opdi, opdri) \
((rs == d) ? opdi : opdri)
/* An operand is forced into a register */
#define jit_replace(rd, rs, forced, op) \
((rd == forced) ? JITSORRY("Register conflict for " # op) : \
(rs == forced) ? op : (PUSHLr(forced), MOVLrr(rs, forced), op, POPLr(forced)))
/* For LT, LE, ... */
#define jit_replace8(d, op) \
(jit_check8(d) \
? (MOVLir(0, d), op(d)) \
: (PUSHLr(_EAX), MOVLir(0, _EAX), op(_EAX), MOVLrr(_EAX, (d)), POPLr(_EAX)))
#define jit_bool_r(d, s1, s2, op) \
(CMPLrr(s2, s1), jit_replace8(d, op))
#define jit_bool_i(d, rs, is, op) \
(CMPLir(is, rs), jit_replace8(d, op))
/* When CMP with 0 can be replaced with TEST */
#define jit_bool_i0(d, rs, is, op, op0) \
((is) != 0 \
? (CMPLir(is, rs), jit_replace8(d, op)) \
: (TESTLrr(rs, rs), jit_replace8(d, op0)))
/* For BLT, BLE, ... */
#define jit_bra_r(s1, s2, op) (CMPLrr(s2, s1), op, _jit.x.pc)
#define jit_bra_i(rs, is, op) (CMPLir(is, rs), op, _jit.x.pc)
/* When CMP with 0 can be replaced with TEST */
#define jit_bra_i0(rs, is, op, op0) \
( (is) == 0 ? (TESTLrr(rs, rs), op0, _jit.x.pc) : (CMPLir(is, rs), op, _jit.x.pc))
/* Used to implement ldc, stc, ... */
#define jit_check8(rs) ( (rs) <= _EBX )
#define jit_reg8(rs) ( ((rs) == _SI || (rs) == _DI) ? _AL : ((rs) & _BH) | _AL )
#define jit_reg16(rs) ( ((rs) & _BH) | _AX )
/* In jit_replace below, _EBX is dummy */
#define jit_movbrm(rs, dd, db, di, ds) \
(jit_check8(rs) \
? MOVBrm(jit_reg8(rs), dd, db, di, ds) \
: jit_replace(_EBX, rs, _EAX, MOVBrm(_AL, dd, db, di, ds)))
/* Reduce arguments of XOR/OR/TEST */
#define jit_reduce_(op) op
#define jit_reduce(op, is, rs) \
(_u8P(is) && jit_check8(rs) ? jit_reduce_(op##Bir(is, jit_reg8(rs))) : \
(_u16P(is) ? jit_reduce_(op##Wir(is, jit_reg16(rs))) : \
jit_reduce_(op##Lir(is, rs)) ))
/* Helper macros for MUL/DIV/IDIV */
#define jit_might(d, s1, op) \
((s1 == d) ? 0 : op)
#define jit_mulr_ui_(s1, s2) jit_opr_(_EAX, s1, s2, MULLr(s1), MULLr(s2))
#define jit_mulr_i_(s1, s2) jit_opr_(_EAX, s1, s2, IMULLr(s1), IMULLr(s2))
#define jit_muli_i_(is, rs) \
(MOVLir(is, rs == _EAX ? _EDX : _EAX), \
IMULLr(rs == _EAX ? _EDX : rs))
#define jit_muli_ui_(is, rs) \
(MOVLir(is, rs == _EAX ? _EDX : _EAX), \
IMULLr(rs == _EAX ? _EDX : rs))
#define jit_divi_i_(result, d, rs, is) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
jit_might (rs, _EAX, MOVLrr(rs, _EAX)), \
jit_might (rs, _EDX, MOVLrr(rs, _EDX)), \
MOVLir(is, _ECX), \
SARLir(31, _EDX), \
IDIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divr_i_(result, d, s1, s2) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
((s1 == _ECX) ? PUSHLr(_ECX) : 0), \
jit_might (s2, _ECX, MOVLrr(s2, _ECX)), \
((s1 == _ECX) ? POPLr(_EDX) : \
jit_might (s1, _EDX, MOVLrr(s1, _EDX))), \
MOVLrr(_EDX, _EAX), \
SARLir(31, _EDX), \
IDIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divi_ui_(result, d, rs, is) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
jit_might (rs, _EAX, MOVLrr(rs, _EAX)), \
MOVLir(is, _ECX), \
XORLrr(_EDX, _EDX), \
DIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divr_ui_(result, d, s1, s2) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
((s1 == _ECX) ? PUSHLr(_ECX) : 0), \
jit_might (s2, _ECX, MOVLrr(s2, _ECX)), \
((s1 == _ECX) ? POPLr(_EAX) : \
jit_might (s1, _EAX, MOVLrr(s1, _EAX))), \
XORLrr(_EDX, _EDX), \
DIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
/* ALU */
#define jit_addi_i(d, rs, is) jit_opi_((d), (rs), ADDLir((is), (d)), LEALmr((is), (rs), 0, 0, (d)) )
#define jit_addr_i(d, s1, s2) jit_opo_((d), (s1), (s2), ADDLrr((s2), (d)), ADDLrr((s1), (d)), LEALmr(0, (s1), (s2), 1, (d)) )
#define jit_addci_i(d, rs, is) jit_op_ ((d), (rs), ADDLir((is), (d)) )
#define jit_addcr_i(d, s1, s2) jit_opr_((d), (s1), (s2), ADDLrr((s1), (d)), ADDLrr((s2), (d)) )
#define jit_addxi_i(d, rs, is) jit_op_ ((d), (rs), ADCLir((is), (d)) )
#define jit_addxr_i(d, s1, s2) jit_opr_((d), (s1), (s2), ADCLrr((s1), (d)), ADCLrr((s2), (d)) )
#define jit_andi_i(d, rs, is) jit_op_ ((d), (rs), ANDLir((is), (d)) )
#define jit_andr_i(d, s1, s2) jit_opr_((d), (s1), (s2), ANDLrr((s1), (d)), ANDLrr((s2), (d)) )
#define jit_orr_i(d, s1, s2) jit_opr_((d), (s1), (s2), ORLrr((s1), (d)), ORLrr((s2), (d)) )
#define jit_subr_i(d, s1, s2) jit_opr_((d), (s1), (s2), (SUBLrr((s1), (d)), NEGLr(d)), SUBLrr((s2), (d)) )
#define jit_subcr_i(d, s1, s2) jit_subr_i((d), (s1), (s2))
#define jit_subxr_i(d, s1, s2) jit_opr_((d), (s1), (s2), SBBLrr((s1), (d)), SBBLrr((s2), (d)) )
#define jit_subxi_i(d, rs, is) jit_op_ ((d), (rs), SBBLir((is), (d)) )
#define jit_xorr_i(d, s1, s2) jit_opr_((d), (s1), (s2), XORLrr((s1), (d)), XORLrr((s2), (d)) )
/* These can sometimes use byte or word versions! */
#define jit_ori_i(d, rs, is) jit_op_ ((d), (rs), jit_reduce(OR, (is), (d)) )
#define jit_xori_i(d, rs, is) jit_op_ ((d), (rs), jit_reduce(XOR, (is), (d)) )
#define jit_muli_i(d, rs, is) jit_op_ ((d), (rs), IMULLir((is), (d)) )
#define jit_mulr_i(d, s1, s2) jit_opr_((d), (s1), (s2), IMULLrr((s1), (d)), IMULLrr((s2), (d)) )
/* As far as low bits are concerned, signed and unsigned multiplies are
exactly the same. */
#define jit_muli_ui(d, rs, is) jit_op_ ((d), (rs), IMULLir((is), (d)) )
#define jit_mulr_ui(d, s1, s2) jit_opr_((d), (s1), (s2), IMULLrr((s1), (d)), IMULLrr((s2), (d)) )
#define jit_hmuli_i(d, rs, is) \
((d) == _EDX ? ( PUSHLr(_EAX), jit_muli_i_((is), (rs)), POPLr(_EAX) ) : \
((d) == _EAX ? (PUSHLr(_EDX), jit_muli_i_((is), (rs)), MOVLrr(_EDX, _EAX), POPLr(_EDX) ) : \
(PUSHLr(_EDX), PUSHLr(_EAX), jit_muli_i_((is), (rs)), MOVLrr(_EDX, (d)), POPLr(_EAX), POPLr(_EDX) )))
#define jit_hmulr_i(d, s1, s2) \
((d) == _EDX ? ( PUSHLr(_EAX), jit_mulr_i_((s1), (s2)), POPLr(_EAX) ) : \
((d) == _EAX ? (PUSHLr(_EDX), jit_mulr_i_((s1), (s2)), MOVLrr(_EDX, _EAX), POPLr(_EDX) ) : \
(PUSHLr(_EDX), PUSHLr(_EAX), jit_mulr_i_((s1), (s2)), MOVLrr(_EDX, (d)), POPLr(_EAX), POPLr(_EDX) )))
#define jit_hmuli_ui(d, rs, is) \
((d) == _EDX ? ( PUSHLr(_EAX), jit_muli_ui_((is), (rs)), POPLr(_EAX) ) : \
((d) == _EAX ? (PUSHLr(_EDX), jit_muli_ui_((is), (rs)), MOVLrr(_EDX, _EAX), POPLr(_EDX) ) : \
(PUSHLr(_EDX), PUSHLr(_EAX), jit_muli_ui_((is), (rs)), MOVLrr(_EDX, (d)), POPLr(_EAX), POPLr(_EDX) )))
#define jit_hmulr_ui(d, s1, s2) \
((d) == _EDX ? ( PUSHLr(_EAX), jit_mulr_ui_((s1), (s2)), POPLr(_EAX) ) : \
((d) == _EAX ? (PUSHLr(_EDX), jit_mulr_ui_((s1), (s2)), MOVLrr(_EDX, _EAX), POPLr(_EDX) ) : \
(PUSHLr(_EDX), PUSHLr(_EAX), jit_mulr_ui_((s1), (s2)), MOVLrr(_EDX, (d)), POPLr(_EAX), POPLr(_EDX) )))
#define jit_divi_i(d, rs, is) jit_divi_i_(_EAX, (d), (rs), (is))
#define jit_divi_ui(d, rs, is) jit_divi_ui_(_EAX, (d), (rs), (is))
#define jit_modi_i(d, rs, is) jit_divi_i_(_EDX, (d), (rs), (is))
#define jit_modi_ui(d, rs, is) jit_divi_ui_(_EDX, (d), (rs), (is))
#define jit_divr_i(d, s1, s2) jit_divr_i_(_EAX, (d), (s1), (s2))
#define jit_divr_ui(d, s1, s2) jit_divr_ui_(_EAX, (d), (s1), (s2))
#define jit_modr_i(d, s1, s2) jit_divr_i_(_EDX, (d), (s1), (s2))
#define jit_modr_ui(d, s1, s2) jit_divr_ui_(_EDX, (d), (s1), (s2))
/* Shifts */
#define jit_lshi_i(d, rs, is) ((is) <= 3 ? LEALmr(0, 0, (rs), 1 << (is), (d)) : jit_op_ ((d), (rs), SHLLir((is), (d)) ))
#define jit_rshi_i(d, rs, is) jit_op_ ((d), (rs), SARLir((is), (d)) )
#define jit_rshi_ui(d, rs, is) jit_op_ ((d), (rs), SHRLir((is), (d)) )
#define jit_lshr_i(d, r1, r2) jit_replace((r1), (r2), _ECX, jit_op_ ((d), (r1), SHLLrr(_CL, (d)) ))
#define jit_rshr_i(d, r1, r2) jit_replace((r1), (r2), _ECX, jit_op_ ((d), (r1), SARLrr(_CL, (d)) ))
#define jit_rshr_ui(d, r1, r2) jit_replace((r1), (r2), _ECX, jit_op_ ((d), (r1), SHRLrr(_CL, (d)) ))
/* Stack */
#define jit_pushr_i(rs) PUSHLr(rs)
#define jit_popr_i(rs) POPLr(rs)
#define jit_prolog(n) (_jitl.framesize = 8, PUSHLr(_EBP), MOVLrr(_ESP, _EBP), PUSHLr(_EBX), PUSHLr(_ESI), PUSHLr(_EDI))
/* The += allows for stack pollution */
#define jit_prepare_i(ni) (_jitl.argssize += (ni))
#define jit_prepare_f(nf) (_jitl.argssize += (nf))
#define jit_prepare_d(nd) (_jitl.argssize += 2 * (nd))
#define jit_pusharg_i(rs) PUSHLr(rs)
#define jit_finish(sub) ((void)jit_calli((sub)), ADDLir(4 * _jitl.argssize, JIT_SP), _jitl.argssize = 0)
#define jit_finishr(reg) (jit_callr((reg)), ADDLir(4 * _jitl.argssize, JIT_SP), _jitl.argssize = 0)
#define jit_retval_i(rd) ((void)jit_movr_i ((rd), _EAX))
#define jit_arg_c() ((_jitl.framesize += sizeof(int)) - sizeof(int))
#define jit_arg_uc() ((_jitl.framesize += sizeof(int)) - sizeof(int))
#define jit_arg_s() ((_jitl.framesize += sizeof(int)) - sizeof(int))
#define jit_arg_us() ((_jitl.framesize += sizeof(int)) - sizeof(int))
#define jit_arg_i() ((_jitl.framesize += sizeof(int)) - sizeof(int))
#define jit_arg_ui() ((_jitl.framesize += sizeof(int)) - sizeof(int))
#define jit_arg_l() ((_jitl.framesize += sizeof(long)) - sizeof(long))
#define jit_arg_ul() ((_jitl.framesize += sizeof(long)) - sizeof(long))
#define jit_arg_p() ((_jitl.framesize += sizeof(long)) - sizeof(long))
#define jit_arg_f() ((_jitl.framesize += sizeof(float)) - sizeof(float))
#define jit_arg_d() ((_jitl.framesize += sizeof(double)) - sizeof(double))
/* Unary */
#define jit_negr_i(d, rs) jit_opi_((d), (rs), NEGLr(d), (XORLrr((d), (d)), SUBLrr((rs), (d))) )
#define jit_negr_l(d, rs) jit_opi_((d), (rs), NEGLr(d), (XORLrr((d), (d)), SUBLrr((rs), (d))) )
#define jit_movr_i(d, rs) ((void)((rs) == (d) ? 0 : MOVLrr((rs), (d))))
#define jit_movi_i(d, is) ((is) ? MOVLir((is), (d)) : XORLrr ((d), (d)) )
#define jit_movi_p(d, is) (MOVLir((is), (d)), _jit.x.pc)
#define jit_patch_movi(pa,pv) (*_PSL((pa) - 4) = _jit_SL((pv)))
#define jit_ntoh_ui(d, rs) jit_op_((d), (rs), BSWAPLr(d))
#define jit_ntoh_us(d, rs) jit_op_((d), (rs), RORWir(8, d))
/* Boolean */
#define jit_ltr_i(d, s1, s2) jit_bool_r((d), (s1), (s2), SETLr )
#define jit_ler_i(d, s1, s2) jit_bool_r((d), (s1), (s2), SETLEr )
#define jit_gtr_i(d, s1, s2) jit_bool_r((d), (s1), (s2), SETGr )
#define jit_ger_i(d, s1, s2) jit_bool_r((d), (s1), (s2), SETGEr )
#define jit_eqr_i(d, s1, s2) jit_bool_r((d), (s1), (s2), SETEr )
#define jit_ner_i(d, s1, s2) jit_bool_r((d), (s1), (s2), SETNEr )
#define jit_ltr_ui(d, s1, s2) jit_bool_r((d), (s1), (s2), SETBr )
#define jit_ler_ui(d, s1, s2) jit_bool_r((d), (s1), (s2), SETBEr )
#define jit_gtr_ui(d, s1, s2) jit_bool_r((d), (s1), (s2), SETAr )
#define jit_ger_ui(d, s1, s2) jit_bool_r((d), (s1), (s2), SETAEr )
#define jit_lti_i(d, rs, is) jit_bool_i0((d), (rs), (is), SETLr, SETSr )
#define jit_lei_i(d, rs, is) jit_bool_i ((d), (rs), (is), SETLEr )
#define jit_gti_i(d, rs, is) jit_bool_i ((d), (rs), (is), SETGr )
#define jit_gei_i(d, rs, is) jit_bool_i0((d), (rs), (is), SETGEr, SETNSr )
#define jit_eqi_i(d, rs, is) jit_bool_i0((d), (rs), (is), SETEr, SETEr )
#define jit_nei_i(d, rs, is) jit_bool_i0((d), (rs), (is), SETNEr, SETNEr )
#define jit_lti_ui(d, rs, is) jit_bool_i ((d), (rs), (is), SETBr )
#define jit_lei_ui(d, rs, is) jit_bool_i0((d), (rs), (is), SETBEr, SETEr )
#define jit_gti_ui(d, rs, is) jit_bool_i0((d), (rs), (is), SETAr, SETNEr )
#define jit_gei_ui(d, rs, is) jit_bool_i0((d), (rs), (is), SETAEr, INCLr )
/* Jump */
#define jit_bltr_i(label, s1, s2) jit_bra_r((s1), (s2), JLm(label, 0,0,0) )
#define jit_bler_i(label, s1, s2) jit_bra_r((s1), (s2), JLEm(label,0,0,0) )
#define jit_bgtr_i(label, s1, s2) jit_bra_r((s1), (s2), JGm(label, 0,0,0) )
#define jit_bger_i(label, s1, s2) jit_bra_r((s1), (s2), JGEm(label,0,0,0) )
#define jit_beqr_i(label, s1, s2) jit_bra_r((s1), (s2), JEm(label, 0,0,0) )
#define jit_bner_i(label, s1, s2) jit_bra_r((s1), (s2), JNEm(label,0,0,0) )
#define jit_bltr_ui(label, s1, s2) jit_bra_r((s1), (s2), JBm(label, 0,0,0) )
#define jit_bler_ui(label, s1, s2) jit_bra_r((s1), (s2), JBEm(label,0,0,0) )
#define jit_bgtr_ui(label, s1, s2) jit_bra_r((s1), (s2), JAm(label, 0,0,0) )
#define jit_bger_ui(label, s1, s2) jit_bra_r((s1), (s2), JAEm(label,0,0,0) )
#define jit_bmsr_i(label, s1, s2) (TESTLrr((s1), (s2)), JNZm(label,0,0,0), _jit.x.pc)
#define jit_bmcr_i(label, s1, s2) (TESTLrr((s1), (s2)), JZm(label,0,0,0), _jit.x.pc)
#define jit_boaddr_i(label, s1, s2) (ADDLrr((s2), (s1)), JOm(label,0,0,0), _jit.x.pc)
#define jit_bosubr_i(label, s1, s2) (SUBLrr((s2), (s1)), JOm(label,0,0,0), _jit.x.pc)
#define jit_boaddr_ui(label, s1, s2) (ADDLrr((s2), (s1)), JCm(label,0,0,0), _jit.x.pc)
#define jit_bosubr_ui(label, s1, s2) (SUBLrr((s2), (s1)), JCm(label,0,0,0), _jit.x.pc)
#define jit_blti_i(label, rs, is) jit_bra_i0((rs), (is), JLm(label, 0,0,0), JSm(label, 0,0,0) )
#define jit_blei_i(label, rs, is) jit_bra_i ((rs), (is), JLEm(label,0,0,0) )
#define jit_bgti_i(label, rs, is) jit_bra_i ((rs), (is), JGm(label, 0,0,0) )
#define jit_bgei_i(label, rs, is) jit_bra_i0((rs), (is), JGEm(label,0,0,0), JNSm(label,0,0,0) )
#define jit_beqi_i(label, rs, is) jit_bra_i0((rs), (is), JEm(label, 0,0,0), JEm(label, 0,0,0) )
#define jit_bnei_i(label, rs, is) jit_bra_i0((rs), (is), JNEm(label,0,0,0), JNEm(label,0,0,0) )
#define jit_blti_ui(label, rs, is) jit_bra_i ((rs), (is), JBm(label, 0,0,0) )
#define jit_blei_ui(label, rs, is) jit_bra_i0((rs), (is), JBEm(label,0,0,0), JEm(label, 0,0,0) )
#define jit_bgti_ui(label, rs, is) jit_bra_i0((rs), (is), JAm(label, 0,0,0), JNEm(label,0,0,0) )
#define jit_bgei_ui(label, rs, is) jit_bra_i ((rs), (is), JAEm(label,0,0,0) )
#define jit_boaddi_i(label, rs, is) (ADDLir((is), (rs)), JOm(label,0,0,0), _jit.x.pc)
#define jit_bosubi_i(label, rs, is) (SUBLir((is), (rs)), JOm(label,0,0,0), _jit.x.pc)
#define jit_boaddi_ui(label, rs, is) (ADDLir((is), (rs)), JCm(label,0,0,0), _jit.x.pc)
#define jit_bosubi_ui(label, rs, is) (SUBLir((is), (rs)), JCm(label,0,0,0), _jit.x.pc)
#define jit_bmsi_i(label, rs, is) (jit_reduce(TEST, (is), (rs)), JNZm(label,0,0,0), _jit.x.pc)
#define jit_bmci_i(label, rs, is) (jit_reduce(TEST, (is), (rs)), JZm(label,0,0,0), _jit.x.pc)
#define jit_jmpi(label) (JMPm( ((unsigned long) (label)), 0, 0, 0), _jit.x.pc)
#define jit_calli(label) (CALLm( ((unsigned long) (label)), 0, 0, 0), _jit.x.pc)
#define jit_callr(reg) (CALLsr(reg))
#define jit_jmpr(reg) JMPsr(reg)
#define jit_patch_at(jump_pc,v) (*_PSL((jump_pc) - 4) = _jit_SL((jit_insn *)(v) - (jump_pc)))
#define jit_ret() (POPLr(_EDI), POPLr(_ESI), POPLr(_EBX), POPLr(_EBP), RET_())
/* Memory */
#define jit_ldi_c(d, is) MOVSBLmr((is), 0, 0, 0, (d))
#define jit_ldr_c(d, rs) MOVSBLmr(0, (rs), 0, 0, (d))
#define jit_ldxr_c(d, s1, s2) MOVSBLmr(0, (s1), (s2), 1, (d))
#define jit_ldxi_c(d, rs, is) MOVSBLmr((is), (rs), 0, 0, (d))
#define jit_ldi_uc(d, is) MOVZBLmr((is), 0, 0, 0, (d))
#define jit_ldr_uc(d, rs) MOVZBLmr(0, (rs), 0, 0, (d))
#define jit_ldxr_uc(d, s1, s2) MOVZBLmr(0, (s1), (s2), 1, (d))
#define jit_ldxi_uc(d, rs, is) MOVZBLmr((is), (rs), 0, 0, (d))
#define jit_sti_c(id, rs) jit_movbrm((rs), (id), 0, 0, 0)
#define jit_str_c(rd, rs) jit_movbrm((rs), 0, (rd), 0, 0)
#define jit_stxr_c(d1, d2, rs) jit_movbrm((rs), 0, (d1), (d2), 1)
#define jit_stxi_c(id, rd, rs) jit_movbrm((rs), (id), (rd), 0, 0)
#define jit_ldi_s(d, is) MOVSWLmr((is), 0, 0, 0, (d))
#define jit_ldr_s(d, rs) MOVSWLmr(0, (rs), 0, 0, (d))
#define jit_ldxr_s(d, s1, s2) MOVSWLmr(0, (s1), (s2), 1, (d))
#define jit_ldxi_s(d, rs, is) MOVSWLmr((is), (rs), 0, 0, (d))
#define jit_ldi_us(d, is) MOVZWLmr((is), 0, 0, 0, (d))
#define jit_ldr_us(d, rs) MOVZWLmr(0, (rs), 0, 0, (d))
#define jit_ldxr_us(d, s1, s2) MOVZWLmr(0, (s1), (s2), 1, (d))
#define jit_ldxi_us(d, rs, is) MOVZWLmr((is), (rs), 0, 0, (d))
#define jit_sti_s(id, rs) MOVWrm(jit_reg16(rs), (id), 0, 0, 0)
#define jit_str_s(rd, rs) MOVWrm(jit_reg16(rs), 0, (rd), 0, 0)
#define jit_stxr_s(d1, d2, rs) MOVWrm(jit_reg16(rs), 0, (d1), (d2), 1)
#define jit_stxi_s(id, rd, rs) MOVWrm(jit_reg16(rs), (id), (rd), 0, 0)
#define jit_ldi_i(d, is) MOVLmr((is), 0, 0, 0, (d))
#define jit_ldr_i(d, rs) MOVLmr(0, (rs), 0, 0, (d))
#define jit_ldxr_i(d, s1, s2) MOVLmr(0, (s1), (s2), 1, (d))
#define jit_ldxi_i(d, rs, is) MOVLmr((is), (rs), 0, 0, (d))
#define jit_sti_i(id, rs) MOVLrm((rs), (id), 0, 0, 0)
#define jit_str_i(rd, rs) MOVLrm((rs), 0, (rd), 0, 0)
#define jit_stxr_i(d1, d2, rs) MOVLrm((rs), 0, (d1), (d2), 1)
#define jit_stxi_i(id, rd, rs) MOVLrm((rs), (id), (rd), 0, 0)
/* Extra */
#define jit_nop() NOP_()
#define _jit_alignment(pc, n) (((pc ^ _MASK(4)) + 1) & _MASK(n))
#define jit_align(n) NOPi(_jit_alignment(_jit_UL(_jit.x.pc), (n)))
#endif /* __lightning_core_h */

86
src/mzscheme/src/lightning/i386/fp-common.h Normal file
View File

@ -0,0 +1,86 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer floating-point interface
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#define JIT_FPR0 JIT_FPR(0)
#define JIT_FPR1 JIT_FPR(1)
#define JIT_FPR2 JIT_FPR(2)
#define JIT_FPR3 JIT_FPR(3)
#define JIT_FPR4 JIT_FPR(4)
#define JIT_FPR5 JIT_FPR(5)
#ifdef JIT_RZERO
#ifndef jit_ldi_f
#define jit_ldi_f(rd, is) jit_ldxi_f((rd), JIT_RZERO, (is))
#define jit_sti_f(id, rs) jit_stxi_f((id), JIT_RZERO, (rs))
#define jit_ldi_d(rd, is) jit_ldxi_d((rd), JIT_RZERO, (is))
#define jit_sti_d(id, rs) jit_stxi_d((id), JIT_RZERO, (rs))
#endif
#ifndef jit_ldr_f
#define jit_ldr_f(rd, rs) jit_ldxr_f((rd), JIT_RZERO, (rs))
#define jit_str_f(rd, rs) jit_stxr_f((rd), JIT_RZERO, (rs))
#define jit_ldr_d(rd, rs) jit_ldxr_d((rd), JIT_RZERO, (rs))
#define jit_str_d(rd, rs) jit_stxr_d((rd), JIT_RZERO, (rs))
#endif
#endif
#ifndef jit_addr_f
#define jit_addr_f(rd,s1,s2) jit_addr_d(rd,s1,s2)
#define jit_subr_f(rd,s1,s2) jit_subr_d(rd,s1,s2)
#define jit_mulr_f(rd,s1,s2) jit_mulr_d(rd,s1,s2)
#define jit_divr_f(rd,s1,s2) jit_divr_d(rd,s1,s2)
#define jit_movr_f(rd,rs) jit_movr_d(rd,rs)
#define jit_abs_f(rd,rs) jit_abs_d(rd,rs)
#define jit_negr_f(rd,rs) jit_negr_d(rd,rs)
#define jit_sqrt_f(rd,rs) jit_sqrt_d(rd,rs)
#define jit_extr_f_d(rs, rd)
#define jit_extr_d_f(rs, rd)
#define jit_extr_i_f(rd, rs) jit_extr_i_d(rd, rs)
#define jit_roundr_f_i(rd, rs) jit_roundr_d_i(rd, rs)
#define jit_floorr_f_i(rd, rs) jit_floorr_d_i(rd, rs)
#define jit_ceilr_f_i(rd, rs) jit_ceilr_d_i(rd, rs)
#define jit_truncr_f_i(rd, rs) jit_truncr_d_i(rd, rs)
#define jit_ltr_f(d, s1, s2) jit_ltr_d(d, s1, s2)
#define jit_ler_f(d, s1, s2) jit_ler_d(d, s1, s2)
#define jit_eqr_f(d, s1, s2) jit_eqr_d(d, s1, s2)
#define jit_ner_f(d, s1, s2) jit_ner_d(d, s1, s2)
#define jit_ger_f(d, s1, s2) jit_ger_d(d, s1, s2)
#define jit_gtr_f(d, s1, s2) jit_gtr_d(d, s1, s2)
#define jit_unltr_f(d, s1, s2) jit_unltr_d(d, s1, s2)
#define jit_unler_f(d, s1, s2) jit_unler_d(d, s1, s2)
#define jit_uneqr_f(d, s1, s2) jit_uneqr_d(d, s1, s2)
#define jit_ltgtr_f(d, s1, s2) jit_ltgtr_d(d, s1, s2)
#define jit_unger_f(d, s1, s2) jit_unger_d(d, s1, s2)
#define jit_ungtr_f(d, s1, s2) jit_ungtr_d(d, s1, s2)
#define jit_ordr_f(d, s1, s2) jit_ordr_d(d, s1, s2)
#define jit_unordr_f(d, s1, s2) jit_unordr_d(d, s1, s2)
#define jit_retval_f(rs) jit_retval_d(rs)
#endif

347
src/mzscheme/src/lightning/i386/fp.h Normal file
View File

@ -0,0 +1,347 @@
/******************************** -*- C -*- ****************************
*
* Run-time assembler & support macros for the i386 math coprocessor
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002, 2004 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_asm_fp_h
#define __lightning_asm_fp_h
/* We really must map the x87 stack onto a flat register file. In practice,
we can provide something sensible and make it work on the x86 using the
stack like a file of eight registers.
We use six or seven registers so as to have some freedom
for floor, ceil, round, (and log, tan, atn and exp).
Not hard at all, basically play with FXCH. FXCH is mostly free,
so the generated code is not bad. Of course we special case when one
of the operands turns out to be ST0.
Here are the macros that actually do the trick. */
#define JIT_FPR_NUM 6
#define JIT_FPR(i) (i)
#define jit_fxch(rs, op) (((rs) != 0 ? FXCHr(rs) : 0), \
op, ((rs) != 0 ? FXCHr(rs) : 0))
#define jit_fp_unary(rd, s1, op) \
((rd) == (s1) ? jit_fxch ((rd), op) \
: (rd) == 0 ? (FSTPr (0), FLDr ((s1)-1), op) \
: (FLDr ((s1)), op, FSTPr ((rd))))
#define jit_fp_binary(rd, s1, s2, op, opr) \
((rd) == (s1) ? \
((s2) == 0 ? opr(0, (rd)) \
: (s2) == (s1) ? jit_fxch((rd), op(0, 0)) \
: jit_fxch((rd), op((s2), 0))) \
: (rd) == (s2) ? jit_fxch((s1), opr(0, (rd) == 0 ? (s1) : (rd))) \
: (FLDr (s1), op(0, (s2)+1), FSTPr((rd)+1)))
#define jit_addr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FADDrr,FADDrr)
#define jit_subr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FSUBrr,FSUBRrr)
#define jit_mulr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FMULrr,FMULrr)
#define jit_divr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FDIVrr,FDIVRrr)
#define jit_abs_d(rd,rs) jit_fp_unary ((rd), (rs), _OO (0xd9e1))
#define jit_negr_d(rd,rs) jit_fp_unary ((rd), (rs), _OO (0xd9e0))
#define jit_sqrt_d(rd,rs) jit_fp_unary ((rd), (rs), _OO (0xd9fa))
/* - moves:
move FPR0 to FPR3
FST ST3
move FPR3 to FPR0
FXCH ST3
FST ST3
move FPR3 to FPR1
FLD ST1
FST ST4 Stack is rotated, so FPRn becomes STn+1 */
#define jit_movr_d(rd,s1) \
((s1) == (rd) ? 0 \
: (s1) == 0 ? FSTr ((rd)) \
: (rd) == 0 ? (FXCHr ((s1)), FSTr ((s1))) \
: (FLDr ((s1)), FSTr ((rd)+1)))
/* - loads:
load into FPR0
FSTP ST0
FLD [FUBAR]
load into FPR3
FSTP ST3 Save old st0 into destination register
FLD [FUBAR]
FXCH ST3 Get back old st0
(and similarly for immediates, using the stack) */
#define jit_movi_f(rd,immf) \
(_O (0x68), \
*((float *) _jit.x.pc) = (float) immf, \
_jit.x.uc_pc += sizeof (float), \
jit_ldr_f((rd), _ESP), \
ADDLir(4, _ESP))
union jit_double_imm {
double d;
int i[2];
};
#define jit_movi_d(rd,immd) \
(_O (0x68), \
_jit.x.uc_pc[4] = 0x68, \
((union jit_double_imm *) (_jit.x.uc_pc + 5))->d = (double) immd, \
*((int *) _jit.x.uc_pc) = ((union jit_double_imm *) (_jit.x.uc_pc + 5))->i[1], \
_jit.x.uc_pc += 9, \
jit_ldr_d((rd), _ESP), \
ADDLir(8, _ESP))
#define jit_ldi_f(rd, is) \
((rd) == 0 ? (FSTPr (0), FLDSm((is), 0, 0, 0)) \
: (FLDSm((is), 0, 0, 0), FSTPr ((rd) + 1)))
#define jit_ldi_d(rd, is) \
((rd) == 0 ? (FSTPr (0), FLDLm((is), 0, 0, 0)) \
: (FLDLm((is), 0, 0, 0), FSTPr ((rd) + 1)))
#define jit_ldr_f(rd, rs) \
((rd) == 0 ? (FSTPr (0), FLDSm(0, (rs), 0, 0)) \
: (FLDSm(0, (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_ldr_d(rd, rs) \
((rd) == 0 ? (FSTPr (0), FLDLm(0, (rs), 0, 0)) \
: (FLDLm(0, (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_ldxi_f(rd, rs, is) \
((rd) == 0 ? (FSTPr (0), FLDSm((is), (rs), 0, 0)) \
: (FLDSm((is), (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_ldxi_d(rd, rs, is) \
((rd) == 0 ? (FSTPr (0), FLDLm((is), (rs), 0, 0)) \
: (FLDLm((is), (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_ldxr_f(rd, s1, s2) \
((rd) == 0 ? (FSTPr (0), FLDSm(0, (s1), (s2), 1)) \
: (FLDSm(0, (s1), (s2), 1), FSTPr ((rd) + 1)))
#define jit_ldxr_d(rd, s1, s2) \
((rd) == 0 ? (FSTPr (0), FLDLm(0, (s1), (s2), 1)) \
: (FLDLm(0, (s1), (s2), 1), FSTPr ((rd) + 1)))
#define jit_extr_i_d(rd, rs) (PUSHLr((rs)), \
((rd) == 0 ? (FSTPr (0), FILDLm(0, _ESP, 0, 0)) \
: (FILDLm(0, _ESP, 0, 0), FSTPr ((rd) + 1))), \
POPLr((rs)))
#define jit_stxi_f(id, rd, rs) jit_fxch ((rs), FSTSm((id), (rd), 0, 0))
#define jit_stxr_f(d1, d2, rs) jit_fxch ((rs), FSTSm(0, (d1), (d2), 1))
#define jit_stxi_d(id, rd, rs) jit_fxch ((rs), FSTLm((id), (rd), 0, 0))
#define jit_stxr_d(d1, d2, rs) jit_fxch ((rs), FSTLm(0, (d1), (d2), 1))
#define jit_sti_f(id, rs) jit_fxch ((rs), FSTSm((id), 0, 0, 0))
#define jit_str_f(rd, rs) jit_fxch ((rs), FSTSm(0, (rd), 0, 0))
#define jit_sti_d(id, rs) jit_fxch ((rs), FSTLm((id), 0, 0, 0))
#define jit_str_d(rd, rs) jit_fxch ((rs), FSTLm(0, (rd), 0, 0))
/* Assume round to near mode */
#define jit_floorr_d_i(rd, rs) \
(FLDr (rs), jit_floor2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_ceilr_d_i(rd, rs) \
(FLDr (rs), jit_ceil2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_truncr_d_i(rd, rs) \
(FLDr (rs), jit_trunc2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_calc_diff(ofs) \
FISTLm(ofs, _ESP, 0, 0), \
FILDLm(ofs, _ESP, 0, 0), \
FSUBRPr(1), \
FSTPSm(4+ofs, _ESP, 0, 0) \
/* The real meat */
#define jit_floor2(rd, aux) \
(PUSHLr(aux), \
SUBLir(8, _ESP), \
jit_calc_diff(0), \
POPLr(rd), /* floor in rd */ \
POPLr(aux), /* x-round(x) in aux */ \
ADDLir(0x7FFFFFFF, aux), /* carry if x-round(x) < -0 */ \
SBBLir(0, rd), /* subtract 1 if carry */ \
POPLr(aux))
#define jit_ceil2(rd, aux) \
(PUSHLr(aux), \
SUBLir(8, _ESP), \
jit_calc_diff(0), \
POPLr(rd), /* floor in rd */ \
POPLr(aux), /* x-round(x) in aux */ \
TESTLrr(aux, aux), \
SETGr(jit_reg8(aux)), \
SHRLir(1, aux), \
ADCLir(0, rd), \
POPLr(aux))
/* a mingling of the two above */
#define jit_trunc2(rd, aux) \
(PUSHLr(aux), \
SUBLir(12, _ESP), \
FSTSm(0, _ESP, 0, 0), \
jit_calc_diff(4), \
POPLr(aux), \
POPLr(rd), \
TESTLrr(aux, aux), \
POPLr(aux), \
JSSm(_jit.x.pc + 11, 0, 0, 0), \
ADDLir(0x7FFFFFFF, aux), /* 6 */ \
SBBLir(0, rd), /* 3 */ \
JMPSm(_jit.x.pc + 10, 0, 0, 0), /* 2 */ \
TESTLrr(aux, aux), /* 2 */ \
SETGr(jit_reg8(aux)), /* 3 */ \
SHRLir(1, aux), /* 2 */ \
ADCLir(0, rd), /* 3 */ \
POPLr(aux))
/* the easy one */
#define jit_roundr_d_i(rd, rs) \
(PUSHLr(_EAX), \
jit_fxch ((rs), FISTPLm(0, _ESP, 0, 0)), \
POPLr((rd)))
#define jit_fp_test(d, s1, s2, n, _and, res) \
(((s1) == 0 ? FUCOMr((s2)) : (FLDr((s1)), FUCOMPr((s2) + 1))), \
((d) != _EAX ? MOVLrr(_EAX, (d)) : 0), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
((_and) ? ANDLir((_and), _EAX) : MOVLir(0, _EAX)), \
res, \
((d) != _EAX ? _O (0x90 + ((d) & 7)) : 0)) /* xchg */
#define jit_fp_btest(d, s1, s2, n, _and, cmp, res) \
(((s1) == 0 ? FUCOMr((s2)) : (FLDr((s1)), FUCOMPr((s2) + 1))), \
PUSHLr(_EAX), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
((_and) ? ANDLir ((_and), _EAX) : 0), \
((cmp) ? CMPLir ((cmp), _AL) : 0), \
POPLr(_EAX), \
res ((d), 0, 0, 0))
#define jit_nothing_needed(x)
/* After FNSTSW we have 1 if <, 40 if =, 0 if >, 45 if unordered. Here
is how to map the values of the status word's high byte to the
conditions.
< = > unord valid values condition
gt no no yes no 0 STSW & 45 == 0
lt yes no no no 1 STSW & 45 == 1
eq no yes no no 40 STSW & 45 == 40
unord no no no yes 45 bit 2 == 1
ge no yes no no 0, 40 bit 0 == 0
unlt yes no no yes 1, 45 bit 0 == 1
ltgt yes no yes no 0, 1 bit 6 == 0
uneq no yes no yes 40, 45 bit 6 == 1
le yes yes no no 1, 40 odd parity for STSW & 41
ungt no no yes yes 0, 45 even parity for STSW & 41
unle yes yes no yes 1, 40, 45 STSW & 45 != 0
unge no yes yes yes 0, 40, 45 STSW & 45 != 1
ne yes no yes yes 0, 1, 45 STSW & 45 != 40
ord yes yes yes no 0, 1, 40 bit 2 == 0
lt, le, ungt, unge are actually computed as gt, ge, unlt, unle with
the operands swapped; it is more efficient this way. */
#define jit_gtr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 8, 0x45, SETZr (_AL))
#define jit_ger_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 9, 0, SBBBir (-1, _AL))
#define jit_unler_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 8, 0x45, SETNZr (_AL))
#define jit_unltr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 9, 0, ADCBir (0, _AL))
#define jit_ltr_d(d, s1, s2) jit_fp_test((d), (s2), (s1), 8, 0x45, SETZr (_AL))
#define jit_ler_d(d, s1, s2) jit_fp_test((d), (s2), (s1), 9, 0, SBBBir (-1, _AL))
#define jit_unger_d(d, s1, s2) jit_fp_test((d), (s2), (s1), 8, 0x45, SETNZr (_AL))
#define jit_ungtr_d(d, s1, s2) jit_fp_test((d), (s2), (s1), 9, 0, ADCBir (0, _AL))
#define jit_eqr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 8, 0x45, (CMPBir (0x40, _AL), SETEr (_AL)))
#define jit_ner_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 8, 0x45, (CMPBir (0x40, _AL), SETNEr (_AL)))
#define jit_ltgtr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 15, 0, SBBBir (-1, _AL))
#define jit_uneqr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 15, 0, ADCBir (0, _AL))
#define jit_ordr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 11, 0, SBBBir (-1, _AL))
#define jit_unordr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 11, 0, ADCBir (0, _AL))
#define jit_bgtr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0, JZm)
#define jit_bger_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 9, 0, 0, JNCm)
#define jit_bunler_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0, JNZm)
#define jit_bunltr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 9, 0, 0, JCm)
#define jit_bltr_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 8, 0x45, 0, JZm)
#define jit_bler_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 9, 0, 0, JNCm)
#define jit_bunger_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 8, 0x45, 0, JNZm)
#define jit_bungtr_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 9, 0, 0, JCm)
#define jit_beqr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0x40, JZm)
#define jit_bner_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0x40, JNZm)
#define jit_bltgtr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 15, 0, 0, JNCm)
#define jit_buneqr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 15, 0, 0, JCm)
#define jit_bordr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 11, 0, 0, JNCm)
#define jit_bunordr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 11, 0, 0, JCm)
#define jit_getarg_f(rd, ofs) jit_ldxi_f((rd), JIT_FP,(ofs))
#define jit_getarg_d(rd, ofs) jit_ldxi_d((rd), JIT_FP,(ofs))
#define jit_pusharg_d(rs) (jit_subi_i(JIT_SP,JIT_SP,sizeof(double)), jit_str_d(JIT_SP,(rs)))
#define jit_pusharg_f(rs) (jit_subi_i(JIT_SP,JIT_SP,sizeof(float)), jit_str_f(JIT_SP,(rs)))
#define jit_retval_d(op1) jit_movr_d(0, (op1))
#if 0
#define jit_sin() _OO(0xd9fe) /* fsin */
#define jit_cos() _OO(0xd9ff) /* fcos */
#define jit_tan() (_OO(0xd9f2), /* fptan */ \
FSTPr(0)) /* fstp st */
#define jit_atn() (_OO(0xd9e8), /* fld1 */ \
_OO(0xd9f3)) /* fpatan */
#define jit_exp() (_OO(0xd9ea), /* fldl2e */ \
FMULPr(1), /* fmulp */ \
_OO(0xd9c0), /* fld st */ \
_OO(0xd9fc), /* frndint */ \
_OO(0xdce9), /* fsubr */ \
FXCHr(1), /* fxch st(1) */ \
_OO(0xd9f0), /* f2xm1 */ \
_OO(0xd9e8), /* fld1 */ \
_OO(0xdec1), /* faddp */ \
_OO(0xd9fd), /* fscale */ \
FSTPr(1)) /* fstp st(1) */
#define jit_log() (_OO(0xd9ed), /* fldln2 */ \
FXCHr(1), /* fxch st(1) */ \
_OO(0xd9f1)) /* fyl2x */
#endif
#endif /* __lightning_asm_h */

54
src/mzscheme/src/lightning/i386/funcs-common.h Normal file
View File

@ -0,0 +1,54 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer inline functions (common part)
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_funcs_common_h
#define __lightning_funcs_common_h
#include <stdio.h>
#include <stdlib.h>
static int jit_fail(const char *, const char*, int, const char *) JIT_UNUSED;
int
jit_fail(const char *msg, const char *file, int line, const char *function)
{
fprintf(stderr, "%s: In function `%s':\n", file, function);
fprintf(stderr, "%s:%d: %s\n", file, line, msg);
abort();
}
#ifndef jit_start_pfx
#define jit_start_pfx() ( (jit_insn*)0x4)
#define jit_end_pfx() ( (jit_insn*)0x0)
#endif
#endif /* __lightning_funcs_common_h */

91
src/mzscheme/src/lightning/i386/funcs.h Normal file
View File

@ -0,0 +1,91 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer inline functions (i386)
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_funcs_h
#define __lightning_funcs_h
#ifdef __linux__
#include <unistd.h>
#include <sys/mman.h>
#endif
static void
jit_flush_code(void *dest, void *end)
{
/* On the x86, the PROT_EXEC bits are not handled by the MMU.
However, the kernel can emulate this by setting the code
segment's limit to the end address of the highest page
whose PROT_EXEC bit is set.
Linux kernels that do so and that disable by default the
execution of the data and stack segment are becoming more
and more common (Fedora, for example), so we implement our
jit_flush_code as an mprotect. */
#ifdef __linux__
static unsigned long prev_page = 0, prev_length = 0;
int page, length;
#ifdef PAGESIZE
const int page_size = PAGESIZE;
#else
static int page_size = -1;
if (page_size == -1)
page_size = sysconf (_SC_PAGESIZE);
#endif
page = (long) dest & ~(page_size - 1);
length = ((char *) end - (char *) page + page_size - 1) & ~(page_size - 1);
/* Simple-minded attempt at optimizing the common case where a single
chunk of memory is used to compile multiple functions. */
if (page >= prev_page && page + length <= prev_page + prev_length)
return;
mprotect ((void *) page, length, PROT_READ | PROT_WRITE | PROT_EXEC);
/* See if we can extend the previously mprotect'ed memory area towards
higher addresses: the starting address remains the same as before. */
if (page >= prev_page && page <= prev_page + prev_length)
prev_length = page + length - prev_page;
/* See if we can extend the previously mprotect'ed memory area towards
lower addresses: the highest address remains the same as before. */
else if (page < prev_page && page + length <= prev_page + prev_length)
prev_length += prev_page - page, prev_page = page;
/* Nothing to do, replace the area. */
else
prev_page = page, prev_length = length;
#endif
}
#endif /* __lightning_funcs_h */

75
src/mzscheme/src/lightning/lightning.h Normal file
View File

@ -0,0 +1,75 @@
/******************************** -*- C -*- ****************************
*
* lightning main include file
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_h
#define __lightning_h
#ifdef __cplusplus
extern "C" {
#endif
#ifdef MZ_USE_JIT_PPC
#include "ppc/asm-common.h"
#include "ppc/asm.h"
#include "ppc/core.h"
#include "ppc/core-common.h"
#include "ppc/funcs.h"
#include "ppc/funcs-common.h"
#include "ppc/fp.h"
#include "ppc/fp-common.h"
#endif
#ifdef MZ_USE_JIT_I386
#include "i386/asm-common.h"
#include "i386/asm.h"
#include "i386/core.h"
#include "i386/core-common.h"
#include "i386/funcs.h"
#include "i386/funcs-common.h"
#include "i386/fp.h"
#include "i386/fp-common.h"
#endif
#ifndef JIT_R0
#error GNU lightning does not support the current target
#endif
#ifdef __cplusplus
}
#endif
#endif /* __lightning_h */

197
src/mzscheme/src/lightning/ppc/asm-common.h Normal file
View File

@ -0,0 +1,197 @@
/******************************** -*- C -*- ****************************
*
* Dynamic assembler support
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_asm_common_h
#define __lightning_asm_common_h_
#ifndef _ASM_SAFETY
#define JITFAIL(MSG) 0
#else
#if defined __GNUC__ && (__GNUC__ == 3 ? __GNUC_MINOR__ >= 2 : __GNUC__ > 3)
#define JITFAIL(MSG) jit_fail(MSG, __FILE__, __LINE__, __func__)
#else
#define JITFAIL(MSG) jit_fail(MSG, __FILE__, __LINE__, __FUNCTION__)
#endif
#endif
#if defined __GNUC__ && (__GNUC__ == 3 ? __GNUC_MINOR__ >= 2 : __GNUC__ > 3)
#define JITSORRY(MSG) jit_fail("sorry, unimplemented: " MSG, __FILE__, __LINE__, __func__)
#else
#define JITSORRY(MSG) jit_fail("sorry, unimplemented: " MSG, __FILE__, __LINE__, __FUNCTION__)
#endif
#ifdef __GNUC__
#define JIT_UNUSED __attribute__((unused))
#else
#define JIT_UNUSED
#endif
/* NextStep 2.0 cc is really gcc 1.93 but it defines __GNUC__ = 2 and
does not implement __extension__. But that compiler doesn't define
__GNUC_MINOR__. */
#ifdef __GNUC__
#if __GNUC__ < 2 || (defined(__NeXT__) && !__GNUC_MINOR__)
#define __extension__
#endif
#define _TEMPD(type, var)
#define _TEMP(type, var, val, body) __extension__ ({ \
register struct { type var } _jitl; _jitl.var = val; \
body; \
})
#else
/* Between loading a global and calling a subroutine, we choose the lesser
* evil. */
#define _TEMPD(type, var) static type var;
#define _TEMP(type, var, val, body) ((var = val), body)
#endif
typedef char _sc;
typedef unsigned char _uc;
typedef unsigned short _us;
typedef unsigned int _ui;
typedef long _sl;
typedef unsigned long _ul;
#define _jit_UC(X) ((_uc )(X))
#define _jit_US(X) ((_us )(X))
#define _jit_UI(X) ((_ui )(X))
#define _jit_SL(X) ((_sl )(X))
#define _jit_UL(X) ((_ul )(X))
# define _PUC(X) ((_uc *)(X))
# define _PUS(X) ((_us *)(X))
# define _PUI(X) ((_ui *)(X))
# define _PSL(X) ((_sl *)(X))
# define _PUL(X) ((_ul *)(X))
#define _jit_B(B) _jit_UL(((*_jit.x.uc_pc++)= _jit_UC((B)& 0xff)))
#define _jit_W(W) _jit_UL(((*_jit.x.us_pc++)= _jit_US((W)&0xffff)))
#define _jit_I(I) _jit_UL(((*_jit.x.ui_pc++)= _jit_UI((I) )))
#define _jit_L(L) _jit_UL(((*_jit.x.ul_pc++)= _jit_UL((L) )))
#define _jit_I_noinc(I) _jit_UL(((*_jit.x.ui_pc)= _jit_UI((I) )))
#define _MASK(N) ((unsigned)((1<<(N)))-1)
#define _siP(N,I) (!((((unsigned)(I))^(((unsigned)(I))<<1))&~_MASK(N)))
#define _uiP(N,I) (!(((unsigned)(I))&~_MASK(N)))
#define _suiP(N,I) (_siP(N,I) | _uiP(N,I))
#ifndef _ASM_SAFETY
#define _ck_s(W,I) (_jit_UL(I) & _MASK(W))
#define _ck_u(W,I) (_jit_UL(I) & _MASK(W))
#define _ck_su(W,I) (_jit_UL(I) & _MASK(W))
#define _ck_d(W,I) (_jit_UL(I) & _MASK(W))
#else
#define _ck_s(W,I) (_siP(W,I) ? (_jit_UL(I) & _MASK(W)) : JITFAIL( "signed integer `"#I"' too large for "#W"-bit field"))
#define _ck_u(W,I) (_uiP(W,I) ? (_jit_UL(I) & _MASK(W)) : JITFAIL("unsigned integer `"#I"' too large for "#W"-bit field"))
#define _ck_su(W,I) (_suiP(W,I) ? (_jit_UL(I) & _MASK(W)) : JITFAIL( "integer `"#I"' too large for "#W"-bit field"))
#define _ck_d(W,I) (_siP(W,I) ? (_jit_UL(I) & _MASK(W)) : JITFAIL( "displacement `"#I"' too large for "#W"-bit field"))
#endif
#define _s0P(I) ((I)==0)
#define _s8P(I) _siP(8,I)
#define _s16P(I) _siP(16,I)
#define _u8P(I) _uiP(8,I)
#define _u16P(I) _uiP(16,I)
#define _su8(I) _ck_su(8,I)
#define _su16(I) _ck_su(16,I)
#define _s1(I) _ck_s( 1,I)
#define _s2(I) _ck_s( 2,I)
#define _s3(I) _ck_s( 3,I)
#define _s4(I) _ck_s( 4,I)
#define _s5(I) _ck_s( 5,I)
#define _s6(I) _ck_s( 6,I)
#define _s7(I) _ck_s( 7,I)
#define _s8(I) _ck_s( 8,I)
#define _s9(I) _ck_s( 9,I)
#define _s10(I) _ck_s(10,I)
#define _s11(I) _ck_s(11,I)
#define _s12(I) _ck_s(12,I)
#define _s13(I) _ck_s(13,I)
#define _s14(I) _ck_s(14,I)
#define _s15(I) _ck_s(15,I)
#define _s16(I) _ck_s(16,I)
#define _s17(I) _ck_s(17,I)
#define _s18(I) _ck_s(18,I)
#define _s19(I) _ck_s(19,I)
#define _s20(I) _ck_s(20,I)
#define _s21(I) _ck_s(21,I)
#define _s22(I) _ck_s(22,I)
#define _s23(I) _ck_s(23,I)
#define _s24(I) _ck_s(24,I)
#define _s25(I) _ck_s(25,I)
#define _s26(I) _ck_s(26,I)
#define _s27(I) _ck_s(27,I)
#define _s28(I) _ck_s(28,I)
#define _s29(I) _ck_s(29,I)
#define _s30(I) _ck_s(30,I)
#define _s31(I) _ck_s(31,I)
#define _u1(I) _ck_u( 1,I)
#define _u2(I) _ck_u( 2,I)
#define _u3(I) _ck_u( 3,I)
#define _u4(I) _ck_u( 4,I)
#define _u5(I) _ck_u( 5,I)
#define _u6(I) _ck_u( 6,I)
#define _u7(I) _ck_u( 7,I)
#define _u8(I) _ck_u( 8,I)
#define _u9(I) _ck_u( 9,I)
#define _u10(I) _ck_u(10,I)
#define _u11(I) _ck_u(11,I)
#define _u12(I) _ck_u(12,I)
#define _u13(I) _ck_u(13,I)
#define _u14(I) _ck_u(14,I)
#define _u15(I) _ck_u(15,I)
#define _u16(I) _ck_u(16,I)
#define _u17(I) _ck_u(17,I)
#define _u18(I) _ck_u(18,I)
#define _u19(I) _ck_u(19,I)
#define _u20(I) _ck_u(20,I)
#define _u21(I) _ck_u(21,I)
#define _u22(I) _ck_u(22,I)
#define _u23(I) _ck_u(23,I)
#define _u24(I) _ck_u(24,I)
#define _u25(I) _ck_u(25,I)
#define _u26(I) _ck_u(26,I)
#define _u27(I) _ck_u(27,I)
#define _u28(I) _ck_u(28,I)
#define _u29(I) _ck_u(29,I)
#define _u30(I) _ck_u(30,I)
#define _u31(I) _ck_u(31,I)
#endif /* __lightning_asm_common_h */

647
src/mzscheme/src/lightning/ppc/asm.h Normal file
View File

@ -0,0 +1,647 @@
/******************************** -*- C -*- ****************************
*
* Run-time assembler for the PowerPC
*
***********************************************************************/
/***********************************************************************
*
* Copyright 1999, 2000, 2001, 2002 Ian Piumarta
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_asm_h
#define __lightning_asm_h
/* <imm> = [0-9]+ | (.+) -> add i, one parameter (imm)
* <reg> = r<imm> -> add r, one parameter (imm)
* <mem> = <imm>(<reg>) -> add m, two parameters (imm,reg)
* <idx> = <reg>(<reg>) -> add x, two parameters (reg,reg)
*
* `x' operands have two forms. For example `stwu source, rega(regb)'
* could be written as either
* STWUrx(source, rega, regb)
* or
* STWUXrrr(source, rega, regb)
*/
/*** a brief NOTE about halfwords and "shifted" operands
*
* LOGICAL insns require UNSIGNED args in 0..65535, whether or not shifted
*
* ARITHMETIC insns require SIGNED args in -32768..32767, even when shifted
*
* as a special case: "lis/addis" also accepts UNSIGNED arguments in
* 0..65535 since it is often used immediately before "ori" to load a 32-bit
* constant (this is consistent with the GNU rs/6000 and PowerPC assemblers)
*
* thus: lis rD, expression@hi
* ori rD, rD, expression@lo ; load 32-bit constant
*/
typedef unsigned int jit_insn;
#ifndef LIGHTNING_DEBUG
#define _cr0 0
#define _cr1 1
#define _cr2 2
#define _cr3 3
#define _cr4 4
#define _cr5 5
#define _cr6 6
#define _cr7 7
#define _lt 0
#define _gt 1
#define _eq 2
#define _so 3
#define _un 3
#define _d16(D) (_ck_d(16,(_jit_UL(D)-_jit_UL(_jit.x.pc))) & ~3)
#define _d26(D) (_ck_d(26,(_jit_UL(D)-_jit_UL(_jit.x.pc))) & ~3)
/* primitive instruction forms [1, Section A.4] */
#define _FB( OP, BD,AA,LK ) (_jit_I_noinc((_u6(OP)<<26)| _d26(BD)| (_u1(AA)<<1)|_u1(LK)), _jit.x.pc++, 0)
#define _FBA( OP, BD,AA,LK ) _jit_I((_u6(OP)<<26)| (_u26(BD)&~3)| (_u1(AA)<<1)|_u1(LK))
#define _BB( OP,BO,BI, BD,AA,LK ) (_jit_I_noinc((_u6(OP)<<26)|(_u5(BO)<<21)|(_u5(BI)<<16)| _d16(BD)| (_u1(AA)<<1)|_u1(LK)), _jit.x.pc++, 0)
#define _D( OP,RD,RA, DD ) _jit_I((_u6(OP)<<26)|(_u5(RD)<<21)|(_u5(RA)<<16)| _s16(DD) )
#define _Du( OP,RD,RA, DD ) _jit_I((_u6(OP)<<26)|(_u5(RD)<<21)|(_u5(RA)<<16)| _u16(DD) )
#define _Ds( OP,RD,RA, DD ) _jit_I((_u6(OP)<<26)|(_u5(RD)<<21)|(_u5(RA)<<16)| _su16(DD) )
#define _X( OP,RD,RA,RB, XO,RC ) _jit_I((_u6(OP)<<26)|(_u5(RD)<<21)|(_u5(RA)<<16)|( _u5(RB)<<11)| (_u10(XO)<<1)|_u1(RC))
#define _XL( OP,BO,BI, XO,LK ) _jit_I((_u6(OP)<<26)|(_u5(BO)<<21)|(_u5(BI)<<16)|( _u5(00)<<11)| (_u10(XO)<<1)|_u1(LK))
#define _XFX( OP,RD, SR,XO ) _jit_I((_u6(OP)<<26)|(_u5(RD)<<21)| (_u10(SR)<<11)| (_u10(XO)<<1)|_u1(00))
#define _XO( OP,RD,RA,RB,OE,XO,RC ) _jit_I((_u6(OP)<<26)|(_u5(RD)<<21)|(_u5(RA)<<16)|( _u5(RB)<<11)|(_u1(OE)<<10)|( _u9(XO)<<1)|_u1(RC))
#define _M( OP,RS,RA,SH,MB,ME,RC ) _jit_I((_u6(OP)<<26)|(_u5(RS)<<21)|(_u5(RA)<<16)|( _u5(SH)<<11)|(_u5(MB)<< 6)|( _u5(ME)<<1)|_u1(RC))
/* special purpose registers (form XFX) [1, Section 8.2, page 8-138] */
#define SPR_LR ((8<<5)|(0))
/* +++ intrinsic instructions */
#define ADDrrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 266, 0)
#define ADD_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 266, 1)
#define ADDCrrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 10, 0)
#define ADDC_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 10, 1)
#define ADDErrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 138, 0)
#define ADDE_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 138, 1)
#define ADDOrrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 266, 0)
#define ADDO_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 266, 1)
#define ADDIrri(RD, RA, IMM) _D (14, RD, RA, IMM)
#define ADDICrri(RD, RA, IMM) _D (12, RD, RA, IMM)
#define ADDIC_rri(RD, RA, IMM) _D (13, RD, RA, IMM)
#define ADDISrri(RD, RA, IMM) _Ds (15, RD, RA, IMM)
#define ANDrrr(RA, RS, RB) _X (31, RS, RA, RB, 28, 0)
#define AND_rrr(RA, RS, RB) _X (31, RS, RA, RB, 28, 1)
#define ANDCrrr(RA, RS, RB) _X (31, RS, RA, RB, 60, 0)
#define ANDC_rrr(RA, RS, RB) _X (31, RS, RA, RB, 60, 1)
#define ANDI_rri(RA, RS, IMM) _Du (28, RS, RA, IMM)
#define ANDIS_rri(RA, RS, IMM) _Du (29, RS, RA, IMM)
#define Bi(BD) _FB (18, BD, 0, 0)
#define BAi(BD) _FBA (18, BD, 1, 0)
#define BLi(BD) _FB (18, BD, 0, 1)
#define BLAi(BD) _FBA (18, BD, 1, 1)
#define BCiii(BO,BI,BD) _BB (16, BO, BI, BD, 0, 0)
#define BCAiii(BO,BI,BD) _BB (16, BO, BI, BD, 1, 0)
#define BCLiii(BO,BI,BD) _BB (16, BO, BI, BD, 0, 1)
#define BCLAiii(BO,BI,BD) _BB (16, BO, BI, BD, 1, 1)
#define BCCTRii(BO,BI) _XL (19, BO, BI, 528, 0)
#define BCCTRLii(BO,BI) _XL (19, BO, BI, 528, 1)
#define BCLRii(BO,BI) _XL (19, BO, BI, 16, 0)
#define BCLRLii(BO,BI) _XL (19, BO, BI, 16, 1)
#define CMPiirr(CR, LL, RA, RB) _X (31, ((CR)<<2)|(LL), RA, RB, 0, 0)
#define CMPIiiri(CR, LL, RA, IMM) _D (11, ((CR)<<2)|(LL), RA, IMM)
#define CMPLiirr(CR, LL, RA, RB) _X (31, ((CR)<<2)|(LL), RA, RB, 32, 0)
#define CMPLIiiri(CR, LL, RA, IMM) _D (10, ((CR)<<2)|(LL), RA, IMM)
#define CRANDiii(CRD,CRA,CRB) _X (19, CRD, CRA, CRB, 257, 0)
#define CRANDCiii(CRD,CRA,CRB) _X (19, CRD, CRA, CRB, 129, 0)
#define CREQViii(CRD,CRA,CRB) _X (19, CRD, CRA, CRB, 289, 0)
#define CRNANDiii(CRD,CRA,CRB) _X (19, CRD, CRA, CRB, 225, 0)
#define CRNORiii(CRD,CRA,CRB) _X (19, CRD, CRA, CRB, 33, 0)
#define CRORiii(CRD,CRA,CRB) _X (19, CRD, CRA, CRB, 449, 0)
#define CRORCiii(CRD,CRA,CRB) _X (19, CRD, CRA, CRB, 417, 0)
#define CRXORiii(CRD,CRA,CRB) _X (19, CRD, CRA, CRB, 193, 0)
#define DCBSTrr(RA,RB) _X (31, 00, RA, RB, 54, 0)
#define DIVWrrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 491, 0)
#define DIVW_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 491, 1)
#define DIVWOrrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 491, 0)
#define DIVWO_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 491, 1)
#define DIVWUrrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 459, 0)
#define DIVWU_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 459, 1)
#define DIVWUOrrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 459, 0)
#define DIVWUO_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 459, 1)
#define EQVrrr(Ra,RS,RB) _X (31, RS, RA, RB, 284, 0)
#define EQV_rrr(Ra,RS,RB) _X (31, RS, RA, RB, 284, 1)
#define EXTSBrr(RA,RS) _X (31, RS, RA, 0, 954, 0)
#define EXTSB_rr(RA,RS) _X (31, RS, RA, 0, 954, 1)
#define EXTSHrr(RA,RS) _X (31, RS, RA, 0, 922, 0)
#define EXTSH_rr(RA,RS) _X (31, RS, RA, 0, 922, 1)
#define ICBIrr(RA,RB) _X (31, 00, RA, RB, 982, 0)
#define ISYNC() _X (19, 00, 00, 00, 150, 0)
#define LBZrm(RD,ID,RA) _D (34, RD, RA, ID)
#define LBZUrm(RD,ID,RA) _D (35, RD, RA, ID)
#define LBZUXrrr(RD,RA,RB) _X (31, RD, RA, RB, 119, 0)
#define LBZXrrr(RD,RA,RB) _X (31, RD, RA, RB, 87, 0)
#define LHArm(RD,ID,RA) _D (42, RD, RA, ID)
#define LHAUrm(RD,ID,RA) _D (43, RD, RA, ID)
#define LHAUXrrr(RD,RA,RB) _X (31, RD, RA, RB, 375, 0)
#define LHAXrrr(RD,RA,RB) _X (31, RD, RA, RB, 343, 0)
#define LHBRXrrr(RD,RA,RB) _X (31, RD, RA, RB, 790, 0)
#define LHZrm(RD,ID,RA) _D (40, RD, RA, ID)
#define LHZUrm(RD,ID,RA) _D (41, RD, RA, ID)
#define LHZUXrrr(RD,RA,RB) _X (31, RD, RA, RB, 311, 0)
#define LHZXrrr(RD,RA,RB) _X (31, RD, RA, RB, 279, 0)
#define LMWrm(RD,ID,RA) _D (46, RD, RA, ID)
#define LWBRXrrr(RD,RA,RB) _X (31, RD, RA, RB, 534, 0)
#define LWZrm(RD, DISP, RA) _D (32, RD, RA, DISP)
#define LWZUrm(RD, DISP, RA) _D (33, RD, RA, DISP)
#define LWZUXrrr(RD, RA, RB) _X (31, RD, RA, RB, 56, 0)
#define LWZXrrr(RD, RA, RB) _X (31, RD, RA, RB, 23, 0)
#define MCRFii(CD,CS) _X (19, ((CD)<<2), ((CS)<<2), 0, 0, 0)
#define MFCRr(RD) _X (31, RD, 0, 0, 19, 0)
#define MCRXRi(RD) _XFX (31, (RD)<<2, 0, 512)
#define MFSPRri(RD, SPR) _XFX (31, RD, (SPR)<<5, 339)
#define MTSPRir(SPR, RS) _XFX (31, RS, (SPR)<<5, 467)
#define MULHWrrr(RD,RA,RB) _XO (31, RD, RA, RB, 0, 75, 0)
#define MULHW_rrr(RD,RA,RB) _XO (31, RD, RA, RB, 0, 75, 1)
#define MULHWUrrr(RD,RA,RB) _XO (31, RD, RA, RB, 0, 11, 0)
#define MULHWU_rrr(RD,RA,RB) _XO (31, RD, RA, RB, 0, 11, 1)
#define MULLIrri(RD,RA,IM) _D (07, RD, RA, IM)
#define MULLWrrr(RD,RA,RB) _XO (31, RD, RA, RB, 0, 235, 0)
#define MULLW_rrr(RD,RA,RB) _XO (31, RD, RA, RB, 0, 235, 1)
#define MULLWOrrr(RD,RA,RB) _XO (31, RD, RA, RB, 1, 235, 0)
#define MULLWO_rrr(RD,RA,RB) _XO (31, RD, RA, RB, 1, 235, 1)
#define NANDrrr(RA,RS,RB) _X (31, RS, RA, RB, 476, 0)
#define NAND_rrr(RA,RS,RB) _X (31, RS, RA, RB, 476, 1)
#define NEGrr(RD,RA) _XO (31, RD, RA, 0, 0, 104, 0)
#define NEG_rr(RD,RA) _XO (31, RD, RA, 0, 0, 104, 1)
#define NEGOrr(RD,RA) _XO (31, RD, RA, 0, 1, 104, 0)
#define NEGO_rr(RD,RA) _XO (31, RD, RA, 0, 1, 104, 1)
#define NORrrr(RA,RS,RB) _X (31, RS, RA, RB, 124, 0)
#define NOR_rrr(RA,RS,RB) _X (31, RS, RA, RB, 124, 1)
#define ORrrr(RA,RS,RB) _X (31, RS, RA, RB, 444, 0)
#define OR_rrr(RA,RS,RB) _X (31, RS, RA, RB, 444, 1)
#define ORCrrr(RA,RS,RB) _X (31, RS, RA, RB, 412, 0)
#define ORC_rrr(RA,RS,RB) _X (31, RS, RA, RB, 412, 1)
#define ORIrri(RA,RS,IM) _Du (24, RS, RA, IM)
#define ORISrri(RA,RS,IM) _Du (25, RS, RA, IM)
#define RLWIMIrriii(RA,RS,SH,MB,ME) _M (20, RS, RA, SH, MB, ME, 0)
#define RLWIMI_rriii(RA,RS,SH,MB,ME) _M (20, RS, RA, SH, MB, ME, 1)
#define RLWINMrriii(RA,RS,SH,MB,ME) _M (21, RS, RA, SH, MB, ME, 0)
#define RLWINM_rriii(RA,RS,SH,MB,ME) _M (21, RS, RA, SH, MB, ME, 1)
#define RLWNMrrrii(RA,RS,RB,MB,ME) _M (23, RS, RA, RB, MB, ME, 0)
#define RLWNM_rrrii(RA,RS,RB,MB,ME) _M (23, RS, RA, RB, MB, ME, 1)
#define SLWrrr(RA,RS,RB) _X (31, RS, RA, RB, 24, 0)
#define SLW_rrr(RA,RS,RB) _X (31, RS, RA, RB, 24, 1)
#define SRAWrrr(RA,RS,RB) _X (31, RS, RA, RB, 792, 0)
#define SRAW_rrr(RA,RS,RB) _X (31, RS, RA, RB, 792, 1)
#define SRAWIrri(RD, RS, SH) _X (31, RS, RD, SH, 824, 0)
#define SRAWI_rri(RD, RS, SH) _X (31, RS, RD, SH, 824, 1)
#define SRWrrr(RA,RS,RB) _X (31, RS, RA, RB, 536, 0)
#define SRW_rrr(RA,RS,RB) _X (31, RS, RA, RB, 536, 1)
#define STBrm(RS,ID,RA) _D (38, RS, RA, ID)
#define STBUrm(RS,ID,RA) _D (39, RS, RA, ID)
#define STBUXrrr(RS,RA,RB) _X (31, RS, RA, RB, 247, 0)
#define STBXrrr(RS,RA,RB) _X (31, RS, RA, RB, 215, 0)
#define STHrm(RS,ID,RA) _D (44, RS, RA, ID)
#define STHUrm(RS,ID,RA) _D (45, RS, RA, ID)
#define STHBRXrrr(RS,RA,RB) _X (31, RS, RA, RB, 918, 0)
#define STHUXrrr(RS,RA,RB) _X (31, RS, RA, RB, 439, 0)
#define STHXrrr(RS,RA,RB) _X (31, RS, RA, RB, 407, 0)
#define STMWrm(RS,ID,RA) _D (47, RS, RA, ID)
#define STWrm(RS,ID,RA) _D (36, RS, RA, ID)
#define STWBRXrrr(RS,RA,RB) _X (31, RS, RA, RB, 662, 0)
#define STWCXrrr(RS,RA,RB) _X (31, RS, RA, RB, 150, 0)
#define STWCX_rrr(RS,RA,RB) _X (31, RS, RA, RB, 150, 1)
#define STWUrm(RS,ID,RA) _D (37, RS, RA, ID)
#define STWUXrrr(RS,RA,RB) _X (31, RS, RA, RB, 183, 0)
#define STWXrrr(RS,RA,RB) _X (31, RS, RA, RB, 151, 0)
#define SUBFrrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 40, 0)
#define SUBF_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 40, 1)
#define SUBFrrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 40, 0)
#define SUBF_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 40, 1)
#define SUBFErrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 136, 0)
#define SUBFE_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 136, 1)
#define SUBFCrrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 8, 0)
#define SUBFC_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 8, 1)
#define SUBFCOrrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 8, 0)
#define SUBFCO_rrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 8, 1)
#define SUBFICrri(RD, RA, IMM) _D (8, RD, RA, IMM)
#define ADDrrr(RD, RA, RB) _XO (31, RD, RA, RB, 0, 266, 0)
#define ADDOrrr(RD, RA, RB) _XO (31, RD, RA, RB, 1, 266, 0)
#define ADDIrri(RD, RA, IMM) _D (14, RD, RA, IMM)
#define ADDISrri(RD, RA, IMM) _Ds (15, RD, RA, IMM)
#define SYNC() _X (31, 00, 00, 00, 598, 0)
#define TWirr(TO,RA,RB) _X (31, TO, RA, RB, 4, 0)
#define TWIiri(TO,RA,IM) _D (03, TO, RA, IM)
#define XORrrr(RA,RS,RB) _X (31, RS, RA, RB, 316, 0)
#define XOR_rrr(RA,RS,RB) _X (31, RS, RA, RB, 316, 1)
#define XORIrri(RA,RS,IM) _Du (26, RS, RA, IM)
#define XORISrri(RA,RS,IM) _Du (27, RS, RA, IM)
/* simplified mnemonics [1, Appendix F] */
#define MOVEIri2(R,H,L) (LISri(R,H), (L ? ORIrri(R,R,L) : 0))
#define MOVEIri(R,I) (_siP(16,I) ? LIri(R,I) : \
MOVEIri2(R, _HI(I), _LO(I)) )
#define SUBIrri(RD,RA,IM) ADDIrri(RD,RA,-_LO((IM))) /* [1, Section F.2.1] */
#define SUBISrri(RD,RA,IM) ADDISrri(RD,RA,-_LO((IM)))
#define SUBICrri(RD,RA,IM) ADDICrri(RD,RA,-_LO((IM)))
#define SUBIC_rri(RD,RA,IM) ADDIC_rri(RD,RA,-_LO((IM)))
#define SUBrrr(RD,RA,RB) SUBFrrr(RD,RB,RA) /* [1, Section F.2.2] */
#define SUBOrrr(RD,RA,RB) SUBFOrrr(RD,RB,RA)
#define SUB_rrr(RD,RA,RB) SUBF_rrr(RD,RB,RA)
#define SUBCrrr(RD,RA,RB) SUBFCrrr(RD,RB,RA)
#define SUBCOrrr(RD,RA,RB) SUBFCOrrr(RD,RB,RA)
#define SUBC_rrr(RD,RA,RB) SUBFC_rrr(RD,RB,RA)
#define SUBErrr(RD,RA,RB) SUBFErrr(RD,RB,RA)
#define SUBE_rrr(RD,RA,RB) SUBFE_rrr(RD,RB,RA)
#define CMPWIiri(C,RA,IM) CMPIiiri(C,0,RA,IM) /* [1, Table F-2] */
#define CMPWirr(C,RA,RB) CMPiirr(C,0,RA,RB)
#define CMPLWIiri(C,RA,IM) CMPLIiiri(C,0,RA,IM)
#define CMPLWirr(C,RA,RB) CMPLiirr(C,0,RA,RB)
#define CMPWIri(RA,IM) CMPWIiri(0,RA,IM) /* with implicit _cr0 */
#define CMPWrr(RA,RB) CMPWirr(0,RA,RB)
#define CMPLWIri(RA,IM) CMPLWIiri(0,RA,IM)
#define CMPLWrr(RA,RB) CMPLWirr(0,RA,RB)
#define EXTLWIrrii(RA,RS,N,B) RLWINMrriii(RA, RS, B, 0, (N)-1) /* [1, Table F-3] */
#define EXTRWIrrii(RA,RS,N,B) RLWINMrriii(RA, RS, (B)+(N), 32-(N), 31)
#define INSLWIrrii(RA,RS,N,B) RLWIMIrriii(RA, RS, 32-(B), B, (B)+(N)-1)
#define INSRWIrrii(RA,RS,N,B) RLWIMIrriii(RA, RS, 32-((B)+(N)), B, (B)+(N)-1)
#define ROTLWIrri(RA,RS,N) RLWINMrriii(RA, RS, N, 0, 31)
#define ROTRWIrri(RA,RS,N) RLWINMrriii(RA, RS, 32-(N), 0, 31)
#define ROTLWrrr(RA,RS,RB) RLWNMrrrii( RA, RS, RB, 0, 31)
#define SLWIrri(RA,RS,N) RLWINMrriii(RA, RS, N, 0, 31-(N))
#define SRWIrri(RA,RS,N) RLWINMrriii(RA, RS, 32-(N), N, 31)
#define CLRLWIrri(RA,RS,N) RLWINMrriii(RA, RS, 0, N, 31)
#define CLRRWIrri(RA,RS,N) RLWINMrriii(RA, RS, 0, 0, 31-(N))
#define CLRLSLWIrrii(RA,RS,B,N) RLWINMrriii(RA, RS, N, (B)-(N), 31-(N))
/* 9 below inverts the branch condition and the branch prediction.
* This has an incestuous knowledge of JIT_AUX */
#define BC_EXT(A, C, D) ((_siP(16, _jit_UL(D)-_jit_UL(_jit.x.pc)) && !_jitl.long_jumps) \
? BCiii((A), (C), (D)) \
: (BCiii((A)^9, (C), _jit.x.pc+5), \
LISri(JIT_AUX,_HI(D)), \
ORIrri(JIT_AUX,JIT_AUX,_LO(D)), \
MTLRr(JIT_AUX), BLR() ))
#define B_EXT(D) ((_siP(16, _jit_UL(D)-_jit_UL(_jit.x.pc)) && !_jitl.long_jumps) \
? Bi((D)) \
: (LISri(JIT_AUX,_HI(D)), \
ORIrri(JIT_AUX,JIT_AUX,_LO(D)), \
MTLRr(JIT_AUX), BLR()) )
#define BTii(C,D) BC_EXT(12, C, D) /* [1, Table F-5] */
#define BFii(C,D) BC_EXT( 4, C, D)
#define BDNZi(D) BCiii(16, 0, D)
#define BDNZTii(C,D) BC_EXT( 8, C, D)
#define BDNZFii(C,D) BC_EXT( 0, C, D)
#define BDZi(D) BCiii(18, 0, D)
#define BDZTii(C,D) BC_EXT(10, C, D)
#define BDZFii(C,D) BC_EXT( 2, C, D)
#define BCTR() BCCTRii(20, 0) /* [1, Table F-6] */
#define BCTRL() BCCTRLii(20, 0)
#define BLR() BCLRii(20, 0) /* [1, Table F-6] */
#define BLRL() BCLRLii(20, 0)
#define BLTLRi(CR) BCLRii(12, ((CR)<<2)+0) /* [1, Table F-10] */
#define BLELRi(CR) BCLRii( 4, ((CR)<<2)+1)
#define BEQLRi(CR) BCLRii(12, ((CR)<<2)+2)
#define BGELRi(CR) BCLRii( 4, ((CR)<<2)+0)
#define BGTLRi(CR) BCLRii(12, ((CR)<<2)+1)
#define BNLLRi(CR) BCLRii( 4, ((CR)<<2)+0)
#define BNELRi(CR) BCLRii( 4, ((CR)<<2)+2)
#define BNGLRi(CR) BCLRii( 4, ((CR)<<2)+1)
#define BSOLRi(CR) BCLRii(12, ((CR)<<2)+3)
#define BNSLRi(CR) BCLRii( 4, ((CR)<<2)+3)
#define BUNLRi(CR) BCLRii(12, ((CR)<<2)+3)
#define BNULRi(CR) BCLRii( 4, ((CR)<<2)+3)
#define BLTLRLi(CR) BCLRLii(12, ((CR)<<2)+0) /* [1, Table F-10] */
#define BLELRLi(CR) BCLRLii( 4, ((CR)<<2)+1)
#define BEQLRLi(CR) BCLRLii(12, ((CR)<<2)+2)
#define BGELRLi(CR) BCLRLii( 4, ((CR)<<2)+0)
#define BGTLRLi(CR) BCLRLii(12, ((CR)<<2)+1)
#define BNLLRLi(CR) BCLRLii( 4, ((CR)<<2)+0)
#define BNELRLi(CR) BCLRLii( 4, ((CR)<<2)+2)
#define BNGLRLi(CR) BCLRLii( 4, ((CR)<<2)+1)
#define BSOLRLi(CR) BCLRLii(12, ((CR)<<2)+3)
#define BNSLRLi(CR) BCLRLii( 4, ((CR)<<2)+3)
#define BUNLRLi(CR) BCLRLii(12, ((CR)<<2)+3)
#define BNULRLi(CR) BCLRLii( 4, ((CR)<<2)+3)
#define BLTCTRi(CR) BCCTRii(12, ((CR)<<2)+0) /* [1, Table F-10] */
#define BLECTRi(CR) BCCTRii( 4, ((CR)<<2)+1)
#define BEQCTRi(CR) BCCTRii(12, ((CR)<<2)+2)
#define BGECTRi(CR) BCCTRii( 4, ((CR)<<2)+0)
#define BGTCTRi(CR) BCCTRii(12, ((CR)<<2)+1)
#define BNLCTRi(CR) BCCTRii( 4, ((CR)<<2)+0)
#define BNECTRi(CR) BCCTRii( 4, ((CR)<<2)+2)
#define BNGCTRi(CR) BCCTRii( 4, ((CR)<<2)+1)
#define BSOCTRi(CR) BCCTRii(12, ((CR)<<2)+3)
#define BNSCTRi(CR) BCCTRii( 4, ((CR)<<2)+3)
#define BUNCTRi(CR) BCCTRii(12, ((CR)<<2)+3)
#define BNUCTRi(CR) BCCTRii( 4, ((CR)<<2)+3)
#define BLTCTRLi(CR) BCCTRLii(12, ((CR)<<2)+0) /* [1, Table F-10] */
#define BLECTRLi(CR) BCCTRLii( 4, ((CR)<<2)+1)
#define BEQCTRLi(CR) BCCTRLii(12, ((CR)<<2)+2)
#define BGECTRLi(CR) BCCTRLii( 4, ((CR)<<2)+0)
#define BGTCTRLi(CR) BCCTRLii(12, ((CR)<<2)+1)
#define BNLCTRLi(CR) BCCTRLii( 4, ((CR)<<2)+0)
#define BNECTRLi(CR) BCCTRLii( 4, ((CR)<<2)+2)
#define BNGCTRLi(CR) BCCTRLii( 4, ((CR)<<2)+1)
#define BSOCTRLi(CR) BCCTRLii(12, ((CR)<<2)+3)
#define BNSCTRLi(CR) BCCTRLii( 4, ((CR)<<2)+3)
#define BUNCTRLi(CR) BCCTRLii(12, ((CR)<<2)+3)
#define BNUCTRLi(CR) BCCTRLii( 4, ((CR)<<2)+3)
#define BLTLR() BLTLRi(0) /* with implicit _cr0 */
#define BLELR() BLELRi(0)
#define BEQLR() BEQLRi(0)
#define BGELR() BGELRi(0)
#define BGTLR() BGTLRi(0)
#define BNLLR() BNLLRi(0)
#define BNELR() BNELRi(0)
#define BNGLR() BNGLRi(0)
#define BSOLR() BSOLRi(0)
#define BNSLR() BNSLRi(0)
#define BUNLR() BUNLRi(0)
#define BNULR() BNULRi(0)
#define BLTLRL() BLTLRLi(0)
#define BLELRL() BLELRLi(0)
#define BEQLRL() BEQLRLi(0)
#define BGELRL() BGELRLi(0)
#define BGTLRL() BGTLRLi(0)
#define BNLLRL() BNLLRLi(0)
#define BNELRL() BNELRLi(0)
#define BNGLRL() BNGLRLi(0)
#define BSOLRL() BSOLRLi(0)
#define BNSLRL() BNSLRLi(0)
#define BUNLRL() BUNLRLi(0)
#define BNULRL() BNULRLi(0)
#define BLTCTR() BLTCTRi(0)
#define BLECTR() BLECTRi(0)
#define BEQCTR() BEQCTRi(0)
#define BGECTR() BGECTRi(0)
#define BGTCTR() BGTCTRi(0)
#define BNLCTR() BNLCTRi(0)
#define BNECTR() BNECTRi(0)
#define BNGCTR() BNGCTRi(0)
#define BSOCTR() BSOCTRi(0)
#define BNSCTR() BNSCTRi(0)
#define BUNCTR() BUNCTRi(0)
#define BNUCTR() BNUCTRi(0)
#define BLTCTRL() BLTCTRLi(0)
#define BLECTRL() BLECTRLi(0)
#define BEQCTRL() BEQCTRLi(0)
#define BGECTRL() BGECTRLi(0)
#define BGTCTRL() BGTCTRLi(0)
#define BNLCTRL() BNLCTRLi(0)
#define BNECTRL() BNECTRLi(0)
#define BNGCTRL() BNGCTRLi(0)
#define BSOCTRL() BSOCTRLi(0)
#define BNSCTRL() BNSCTRLi(0)
#define BUNCTRL() BUNCTRLi(0)
#define BNUCTRL() BNUCTRLi(0)
#define BLTii(C,D) BC_EXT(12, ((C)<<2)+0, D) /* [1, Table F-11] */
#define BNLii(C,D) BC_EXT( 4, ((C)<<2)+0, D)
#define BGEii(C,D) BC_EXT( 4, ((C)<<2)+0, D)
#define BGTii(C,D) BC_EXT(12, ((C)<<2)+1, D)
#define BNGii(C,D) BC_EXT( 4, ((C)<<2)+1, D)
#define BLEii(C,D) BC_EXT( 4, ((C)<<2)+1, D)
#define BEQii(C,D) BC_EXT(12, ((C)<<2)+2, D)
#define BNEii(C,D) BC_EXT( 4, ((C)<<2)+2, D)
#define BSOii(C,D) BC_EXT(12, ((C)<<2)+3, D)
#define BNSii(C,D) BC_EXT( 4, ((C)<<2)+3, D)
#define BUNii(C,D) BC_EXT(12, ((C)<<2)+3, D)
#define BNUii(C,D) BC_EXT( 4, ((C)<<2)+3, D)
#define BLTi(D) BLTii(0,D) /* with implicit _cr0 */
#define BLEi(D) BLEii(0,D)
#define BEQi(D) BEQii(0,D)
#define BGEi(D) BGEii(0,D)
#define BGTi(D) BGTii(0,D)
#define BNLi(D) BNLii(0,D)
#define BNEi(D) BNEii(0,D)
#define BNGi(D) BNGii(0,D)
#define BSOi(D) BSOii(0,D)
#define BNSi(D) BNSii(0,D)
#define BUNi(D) BUNii(0,D)
#define BNUi(D) BNUii(0,D)
#define BLTLii(C,D) BCLiii(12, ((C)<<2)+0, D) /* [1, Table F-??] */
#define BLELii(C,D) BCLiii( 4, ((C)<<2)+1, D)
#define BEQLii(C,D) BCLiii(12, ((C)<<2)+2, D)
#define BGELii(C,D) BCLiii( 4, ((C)<<2)+0, D)
#define BGTLii(C,D) BCLiii(12, ((C)<<2)+1, D)
#define BNLLii(C,D) BCLiii( 4, ((C)<<2)+0, D)
#define BNELii(C,D) BCLiii( 4, ((C)<<2)+2, D)
#define BNGLii(C,D) BCLiii( 4, ((C)<<2)+1, D)
#define BSOLii(C,D) BCLiii(12, ((C)<<2)+3, D)
#define BNSLii(C,D) BCLiii( 4, ((C)<<2)+3, D)
#define BUNLii(C,D) BCLiii(12, ((C)<<2)+3, D)
#define BNULii(C,D) BCLiii( 4, ((C)<<2)+3, D)
#define BLTLi(D) BLTLii(0,D) /* with implicit _cr0 */
#define BLELi(D) BLELii(0,D)
#define BEQLi(D) BEQLii(0,D)
#define BGELi(D) BGELii(0,D)
#define BGTLi(D) BGTLii(0,D)
#define BNLLi(D) BNLLii(0,D)
#define BNELi(D) BNELii(0,D)
#define BNGLi(D) BNGLii(0,D)
#define BSOLi(D) BSOLii(0,D)
#define BNSLi(D) BNSLii(0,D)
#define BUNLi(D) BUNLii(0,D)
#define BNULi(D) BNULii(0,D)
/* Note: there are many tens of other simplified branches that are not (yet?) defined here */
#define CRSETi(BX) CREQViii(BX, BX, BX) /* [1, Table F-15] */
#define CRCLRi(BX) CRXORiii(BX, BX, BX)
#define CRMOVEii(BX,BY) CRORiii(BX, BY, BY)
#define CRNOTii(BX,BY) CRNORiii(BX, BY, BY)
#define MTLRr(RS) MTSPRir(8, RS) /* [1, Table F-20] */
#define MFLRr(RD) MFSPRri(RD, 8)
#define MTCTRr(RS) MTSPRir(9, RS)
#define MFCTRr(RD) MFSPRri(RD, 9)
#define MTXERr(RS) MTSPRir(1, RS)
#define MFXERr(RD) MFSPRri(RD, 1)
#define NOP() ORIrri(0, 0, 0) /* [1, Section F.9] */
#define LIri(RD,IM) ADDIrri(RD, 0, IM)
#define LISri(RD,IM) ADDISrri(RD, 0, IM)
#define LArm(RD,D,RA) ADDIrri(RD, RA, D)
#define LArrr(RD,RB,RA) ADDIrrr(RD, RA, RB)
#define MRrr(RA,RS) ORrrr(RA, RS, RS)
#define NOTrr(RA,RS) NORrrr(RA, RS, RS)
/* alternative parenthesised forms of extended indexed load/store insns */
#define LBZUrx(RD,RA,RB) LBZUXrrr(RD,RA,RB)
#define LBZrx(RD,RA,RB) LBZXrrr(RD,RA,RB)
#define LHAUrx(RD,RA,RB) LHAUXrrr(RD,RA,RB)
#define LHArx(RD,RA,RB) LHAXrrr(RD,RA,RB)
#define LHBRrx(RD,RA,RB) LHBRXrrr(RD,RA,RB)
#define LHZUrx(RD,RA,RB) LHZUXrrr(RD,RA,RB)
#define LHZrx(RD,RA,RB) LHZXrrr(RD,RA,RB)
#define LWBRrx(RD,RA,RB) LWBRXrrr(RD,RA,RB)
#define LWZUrx(RD, RA, RB) LWZUXrrr(RD, RA, RB)
#define LWZrx(RD, RA, RB) LWZXrrr(RD, RA, RB)
#define STBUrx(RD,RA,RB) STBUXrrr(RD,RA,RB)
#define STBrx(RD,RA,RB) STBXrrr(RD,RA,RB)
#define STHBRrx(RS,RA,RB) STHBRXrrr(RS,RA,RB)
#define STHUrx(RS,RA,RB) STHUXrrr(RS,RA,RB)
#define STHrx(RS,RA,RB) STHXrrr(RS,RA,RB)
#define STWBRrx(RS,RA,RB) STWBRXrrr(RS,RA,RB)
#define STWCrx(RS,RA,RB) STWCXrrr(RS,RA,RB)
#define STWCX_rx(RS,RA,RB) STWCX_rrr(RS,RA,RB)
#define STWUrx(RS,RA,RB) STWUXrrr(RS,RA,RB)
#define STWrx(RS,RA,RB) STWXrrr(RS,RA,RB)
#define LArx(RD,RB,RA) LArrr(RD,RB,RA)
#define _LO(I) (_jit_UL(I) & _MASK(16))
#define _HI(I) (_jit_UL(I) >> (16))
#define _A(OP,RD,RA,RB,RC,XO,RCx) _jit_I((_u6(OP)<<26)|(_u5(RD)<<21)|(_u5(RA)<<16)|( _u5(RB)<<11)|_u5(RC)<<6|(_u5(XO)<<1)|_u1(RCx))
#define LFDrri(RD,RA,imm) _D(50,RD,RA,imm)
#define LFDUrri(RD,RA,imm) _D(51,RD,RA,imm)
#define LFDUxrrr(RD,RA,RB) _X(31,RD,RA,RB,631,0)
#define LFDxrrr(RD,RA,RB) _X(31,RD,RA,RB,599,0)
#define LFSrri(RD,RA,imm) _D(48,RD,RA,imm)
#define LFSUrri(RD,RA,imm) _D(49,RD,RA,imm)
#define LFSUxrrr(RD,RA,RB) _X(31,RD,RA,RB,567,0)
#define LFSxrrr(RD,RA,RB) _X(31,RD,RA,RB,535,0)
#define STFDrri(RS,RA,imm) _D(54,RS,RA,imm)
#define STFDUrri(RS,RA,imm) _D(55,RS,RA,imm)
#define STFDUxrrr(RS,RA,RB) _X(31,RS,RA,RB,759,0)
#define STFDxrrr(RS,RA,RB) _X(31,RS,RA,RB,727,0)
#define STFSrri(RS,RA,imm) _D(52,RS,RA,imm)
#define STFSUrri(RS,RA,imm) _D(53,RS,RA,imm)
#define STFSUxrrr(RS,RA,RB) _X(31,RS,RA,RB,695,0)
#define STFSxrrr(RS,RA,RB) _X(31,RS,RA,RB,663,0)
#define STFIWXrrr(RS,RA,RB) _X(31,RS,RA,RB,983,0)
#define FADDDrrr(RD,RA,RB) _A(63,RD,RA,RB,0,21,0)
#define FADDSrrr(RD,RA,RB) _A(59,RD,RA,RB,0,21,0)
#define FSUBDrrr(RD,RA,RB) _A(63,RD,RA,RB,0,20,0)
#define FSUBSrrr(RD,RA,RB) _A(59,RD,RA,RB,0,20,0)
#define FMULDrrr(RD,RA,RC) _A(63,RD,RA,0,RC,25,0)
#define FMULSrrr(RD,RA,RC) _A(59,RD,RA,0,RC,25,0)
#define FDIVDrrr(RD,RA,RB) _A(63,RD,RA,RB,0,18,0)
#define FDIVSrrr(RD,RA,RB) _A(59,RD,RA,RB,0,25,0)
#define FSQRTDrr(RD,RB) _A(63,RD,0,RB,0,22,0)
#define FSQRTSrr(RD,RB) _A(59,RD,0,RB,0,22,0)
#define FSELrrrr(RD,RA,RB,RC) _A(63,RD,RA,RB,RC,23,0)
#define FCTIWrr(RD,RB) _X(63,RD,0,RB,14,0)
#define FCTIWZrr(RD,RB) _X(63,RD,0,RB,15,0)
#define FRSPrr(RD,RB) _X(63,RD,0,RB,12,0)
#define FABSrr(RD,RB) _X(63,RD,0,RB,264,0)
#define FNABSrr(RD,RB) _X(63,RD,0,RB,136,0)
#define FNEGrr(RD,RB) _X(63,RD,0,RB,40,0)
#define FMOVErr(RD,RB) _X(63,RD,0,RB,72,0)
#define FCMPOrrr(CR,RA,RB) _X(63,_u3((CR)<<2),RA,RB,32,0)
#define FCMPUrrr(CR,RA,RB) _X(63,_u3((CR)<<2),RA,RB,0,0)
#define MTFSFIri(CR,IMM) _X(63,_u5((CR)<<2),0,_u5((IMM)<<1),134,0)
/*** References:
*
* [1] "PowerPC Microprocessor Family: The Programming Environments For 32-Bit Microprocessors", Motorola, 1997.
*/
#endif
#endif /* __ccg_asm_ppc_h */

626
src/mzscheme/src/lightning/ppc/core-common.h Normal file
View File

@ -0,0 +1,626 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer support
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_core_common_h
#define __lightning_core_common_h_
typedef struct {
union {
jit_insn *pc;
_uc *uc_pc;
_us *us_pc;
_ui *ui_pc;
_ul *ul_pc;
} x;
struct jit_fp *fp;
struct jit_local_state jitl;
} jit_state;
#if 0
# ifdef jit_init
static jit_state _jit = jit_init ();
# else
static jit_state _jit;
# endif
#endif
#define JIT_NOREG (-1)
#define JIT_R0 JIT_R(0)
#define JIT_R1 JIT_R(1)
#define JIT_R2 JIT_R(2)
#define JIT_V0 JIT_V(0)
#define JIT_V1 JIT_V(1)
#define JIT_V2 JIT_V(2)
#define _jitl _jit.jitl
#define jit_get_ip() (*(jit_code *) &_jit.x.pc)
#define jit_set_ip(ptr) (_jit.x.pc = (ptr), jit_get_ip ())
#define jit_get_label() (_jit.x.pc)
#define jit_forward() (_jit.x.pc)
#define jit_field(struc, f) ( ((long) (&((struc *) 8)->f) ) - 8)
#define jit_ptr_field(struc_p, f) ( ((long) (&((struc_p) 8)->f) ) - 8)
/* realignment via N-byte no-ops */
#ifndef jit_align
#define jit_align(n)
#endif
/* jit_code: union of many possible function pointer types. Returned
* by jit_get_ip().
*/
typedef union jit_code {
char *ptr;
void (*vptr)(void);
char (*cptr)(void);
unsigned char (*ucptr)(void);
short (*sptr)(void);
unsigned short (*usptr)(void);
int (*iptr)(void);
unsigned int (*uiptr)(void);
long (*lptr)(void);
unsigned long (*ulptr)(void);
void * (*pptr)(void);
float (*fptr)(void);
double (*dptr)(void);
} jit_code;
#ifndef jit_fill_delay_after
#define jit_fill_delay_after(branch) (branch)
#endif
#define jit_delay(insn, branch) ((insn), jit_fill_delay_after(branch))
/* ALU synonyms */
#define jit_addi_ui(d, rs, is) jit_addi_i((d), (rs), (is))
#define jit_addr_ui(d, s1, s2) jit_addr_i((d), (s1), (s2))
#define jit_addci_ui(d, rs, is) jit_addci_i((d), (rs), (is))
#define jit_addcr_ui(d, s1, s2) jit_addcr_i((d), (s1), (s2))
#define jit_addxi_ui(d, rs, is) jit_addxi_i((d), (rs), (is))
#define jit_addxr_ui(d, s1, s2) jit_addxr_i((d), (s1), (s2))
#define jit_andi_ui(d, rs, is) jit_andi_i((d), (rs), (is))
#define jit_andr_ui(d, s1, s2) jit_andr_i((d), (s1), (s2))
#define jit_lshi_ui(d, rs, is) jit_lshi_i((d), (rs), (is))
#define jit_lshr_ui(d, s1, s2) jit_lshr_i((d), (s1), (s2))
#define jit_movi_ui(d, rs) jit_movi_i((d), (rs))
#define jit_movr_ui(d, rs) jit_movr_i((d), (rs))
#define jit_ori_ui(d, rs, is) jit_ori_i((d), (rs), (is))
#define jit_orr_ui(d, s1, s2) jit_orr_i((d), (s1), (s2))
#define jit_rsbi_ui(d, rs, is) jit_rsbi_i((d), (rs), (is))
#define jit_rsbr_ui(d, s1, s2) jit_rsbr_i((d), (s1), (s2))
#define jit_subi_ui(d, rs, is) jit_subi_i((d), (rs), (is))
#define jit_subr_ui(d, s1, s2) jit_subr_i((d), (s1), (s2))
#define jit_subci_ui(d, rs, is) jit_subci_i((d), (rs), (is))
#define jit_subcr_ui(d, s1, s2) jit_subcr_i((d), (s1), (s2))
#define jit_subxi_ui(d, rs, is) jit_subxi_i((d), (rs), (is))
#define jit_subxr_ui(d, s1, s2) jit_subxr_i((d), (s1), (s2))
#define jit_xori_ui(d, rs, is) jit_xori_i((d), (rs), (is))
#define jit_xorr_ui(d, s1, s2) jit_xorr_i((d), (s1), (s2))
#define jit_addi_ul(d, rs, is) jit_addi_l((d), (rs), (is))
#define jit_addr_ul(d, s1, s2) jit_addr_l((d), (s1), (s2))
#define jit_addci_ul(d, rs, is) jit_addci_l((d), (rs), (is))
#define jit_addcr_ul(d, s1, s2) jit_addcr_l((d), (s1), (s2))
#define jit_addxi_ul(d, rs, is) jit_addxi_l((d), (rs), (is))
#define jit_addxr_ul(d, s1, s2) jit_addxr_l((d), (s1), (s2))
#define jit_andi_ul(d, rs, is) jit_andi_l((d), (rs), (is))
#define jit_andr_ul(d, s1, s2) jit_andr_l((d), (s1), (s2))
#define jit_lshi_ul(d, rs, is) jit_lshi_l((d), (rs), (is))
#define jit_lshr_ul(d, s1, s2) jit_lshr_l((d), (s1), (s2))
#define jit_movi_ul(d, rs) jit_movi_l((d), (rs))
#define jit_movr_ul(d, rs) jit_movr_l((d), (rs))
#define jit_ori_ul(d, rs, is) jit_ori_l((d), (rs), (is))
#define jit_orr_ul(d, s1, s2) jit_orr_l((d), (s1), (s2))
#define jit_rsbi_ul(d, rs, is) jit_rsbi_l((d), (rs), (is))
#define jit_rsbr_ul(d, s1, s2) jit_rsbr_l((d), (s1), (s2))
#define jit_subi_ul(d, rs, is) jit_subi_l((d), (rs), (is))
#define jit_subr_ul(d, s1, s2) jit_subr_l((d), (s1), (s2))
#define jit_subci_ul(d, rs, is) jit_subci_l((d), (rs), (is))
#define jit_subcr_ul(d, s1, s2) jit_subcr_l((d), (s1), (s2))
#define jit_subxi_ui(d, rs, is) jit_subxi_i((d), (rs), (is))
#define jit_subxi_ul(d, rs, is) jit_subxi_l((d), (rs), (is))
#define jit_subxr_ui(d, s1, s2) jit_subxr_i((d), (s1), (s2))
#define jit_subxr_ul(d, s1, s2) jit_subxr_i((d), (s1), (s2))
#define jit_xori_ul(d, rs, is) jit_xori_l((d), (rs), (is))
#define jit_xorr_ul(d, s1, s2) jit_xorr_l((d), (s1), (s2))
#define jit_addr_p(d, s1, s2) jit_addr_ul((d), (s1), (s2))
#define jit_addi_p(d, rs, is) jit_addi_ul((d), (rs), (long) (is))
#define jit_movr_p(d, rs) jit_movr_ul((d), (rs))
#define jit_subr_p(d, s1, s2) jit_subr_ul((d), (s1), (s2))
#define jit_subi_p(d, rs, is) jit_subi_ul((d), (rs), (long) (is))
#define jit_rsbi_p(d, rs, is) jit_rsbi_ul((d), (rs), (long) (is))
#ifndef jit_movi_p
#define jit_movi_p(d, is) (jit_movi_ul((d), (long) (is)), _jit.x.pc)
#endif
#define jit_patch(pv) jit_patch_at ((pv), (_jit.x.pc))
#ifndef jit_addci_i
#define jit_addci_i(d, rs, is) jit_addi_i((d), (rs), (is))
#define jit_addcr_i(d, s1, s2) jit_addr_i((d), (s1), (s2))
#define jit_addci_l(d, rs, is) jit_addi_l((d), (rs), (is))
#define jit_addcr_l(d, s1, s2) jit_addr_l((d), (s1), (s2))
#endif
#ifndef jit_subcr_i
#define jit_subcr_i(d, s1, s2) jit_subr_i((d), (s1), (s2))
#endif
/* NEG is not mandatory -- pick an appropriate implementation */
#ifndef jit_negr_i
# ifdef JIT_RZERO
# define jit_negr_i(d, rs) jit_subr_i((d), JIT_RZERO, (rs))
# define jit_negr_l(d, rs) jit_subr_l((d), JIT_RZERO, (rs))
# else /* !JIT_RZERO */
# ifndef jit_rsbi_i
# define jit_negr_i(d, rs) (jit_xori_i((d), (rs), -1), jit_addi_l((d), (d), 1))
# define jit_negr_l(d, rs) (jit_xori_l((d), (rs), -1), jit_addi_l((d), (d), 1))
# else /* jit_rsbi_i */
# define jit_negr_i(d, rs) jit_rsbi_i((d), (rs), 0)
# define jit_negr_l(d, rs) jit_rsbi_l((d), (rs), 0)
# endif /* jit_rsbi_i */
# endif /* !JIT_RZERO */
#endif /* !jit_negr_i */
/* RSB is not mandatory */
#ifndef jit_rsbi_i
# define jit_rsbi_i(d, rs, is) (jit_subi_i((d), (rs), (is)), jit_negr_i((d), (d)))
# ifndef jit_rsbi_l
# define jit_rsbi_l(d, rs, is) (jit_subi_l((d), (rs), (is)), jit_negr_l((d), (d)))
# endif
#endif
/* Common 'shortcut' implementations */
#define jit_subi_i(d, rs, is) jit_addi_i((d), (rs), -(is))
#define jit_subi_l(d, rs, is) jit_addi_l((d), (rs), -(is))
#define jit_subci_i(d, rs, is) jit_addci_i((d), (rs), -(is))
#define jit_subci_l(d, rs, is) jit_addci_l((d), (rs), -(is))
#define jit_rsbr_f(d, s1, s2) jit_subr_f((d), (s2), (s1))
#define jit_rsbr_d(d, s1, s2) jit_subr_d((d), (s2), (s1))
#define jit_rsbr_i(d, s1, s2) jit_subr_i((d), (s2), (s1))
#define jit_rsbr_l(d, s1, s2) jit_subr_l((d), (s2), (s1))
#define jit_rsbr_p(d, s1, s2) jit_subr_p((d), (s2), (s1))
/* Unary */
#define jit_notr_c(d, rs) jit_xori_c((d), (rs), 255)
#define jit_notr_uc(d, rs) jit_xori_c((d), (rs), 255)
#define jit_notr_s(d, rs) jit_xori_s((d), (rs), 65535)
#define jit_notr_us(d, rs) jit_xori_s((d), (rs), 65535)
#define jit_notr_i(d, rs) jit_xori_i((d), (rs), ~0)
#define jit_notr_ui(d, rs) jit_xori_i((d), (rs), ~0)
#define jit_notr_l(d, rs) jit_xori_l((d), (rs), ~0L)
#define jit_notr_ul(d, rs) jit_xori_l((d), (rs), ~0L)
#ifndef jit_extr_c_ui
#define jit_extr_c_ui(d, rs) jit_andi_ui((d), (rs), 0xFF)
#endif
#ifndef jit_extr_s_ui
#define jit_extr_s_ui(d, rs) jit_andi_ui((d), (rs), 0xFFFF)
#endif
#ifndef jit_extr_c_i
#define jit_extr_c_i(d, rs) (jit_lshi_i((d), (rs), 24), jit_rshi_i((d), (d), 24))
#endif
#ifndef jit_extr_s_i
#define jit_extr_s_i(d, rs) (jit_lshi_i((d), (rs), 16), jit_rshi_i((d), (d), 16))
#endif
#ifdef jit_addi_l /* sizeof(long) != sizeof(int) */
#ifndef jit_extr_c_l
#define jit_extr_c_l(d, rs) (jit_lshi_l((d), (rs), 56), jit_rshi_l((d), (d), 56))
#endif
#ifndef jit_extr_s_l
#define jit_extr_s_l(d, rs) (jit_lshi_l((d), (rs), 48), jit_rshi_l((d), (d), 48))
#endif
#ifndef jit_extr_i_l
#define jit_extr_i_l(d, rs) (jit_lshi_l((d), (rs), 32), jit_rshi_l((d), (d), 32))
#endif
#ifndef jit_extr_c_ul
#define jit_extr_c_ul(d, rs) jit_andi_l((d), (rs), 0xFF)
#endif
#ifndef jit_extr_s_ul
#define jit_extr_s_ul(d, rs) jit_andi_l((d), (rs), 0xFFFF)
#endif
#ifndef jit_extr_i_ul
#define jit_extr_i_ul(d, rs) jit_andi_l((d), (rs), 0xFFFFFFFFUL)
#endif
#endif
#define jit_extr_c_s(d, rs) jit_extr_c_i((d), (rs))
#define jit_extr_c_us(d, rs) jit_extr_c_ui((d), (rs))
#define jit_extr_uc_s(d, rs) jit_extr_uc_i((d), (rs))
#define jit_extr_uc_us(d, rs) jit_extr_uc_ui((d), (rs))
#define jit_extr_uc_i(d, rs) jit_extr_c_ui((d), (rs))
#define jit_extr_uc_ui(d, rs) jit_extr_c_ui((d), (rs))
#define jit_extr_us_i(d, rs) jit_extr_s_ui((d), (rs))
#define jit_extr_us_ui(d, rs) jit_extr_s_ui((d), (rs))
#define jit_extr_uc_l(d, rs) jit_extr_c_ul((d), (rs))
#define jit_extr_uc_ul(d, rs) jit_extr_c_ul((d), (rs))
#define jit_extr_us_l(d, rs) jit_extr_s_ul((d), (rs))
#define jit_extr_us_ul(d, rs) jit_extr_s_ul((d), (rs))
#define jit_extr_ui_l(d, rs) jit_extr_i_ul((d), (rs))
#define jit_extr_ui_ul(d, rs) jit_extr_i_ul((d), (rs))
/* NTOH/HTON is not mandatory for big endian architectures */
#ifndef jit_ntoh_ui /* big endian */
#define jit_ntoh_ui(d, rs) ((d) == (rs) ? (void)0 : jit_movr_i((d), (rs)))
#define jit_ntoh_us(d, rs) ((d) == (rs) ? (void)0 : jit_movr_i((d), (rs)))
#endif /* big endian */
/* hton is a synonym for ntoh */
#define jit_hton_ui(d, rs) jit_ntoh_ui((d), (rs))
#define jit_hton_us(d, rs) jit_ntoh_us((d), (rs))
/* Stack synonyms */
#define jit_pushr_ui(rs) jit_pushr_i(rs)
#define jit_popr_ui(rs) jit_popr_i(rs)
#define jit_pushr_ul(rs) jit_pushr_l(rs)
#define jit_popr_ul(rs) jit_popr_l(rs)
#define jit_pushr_p(rs) jit_pushr_ul(rs)
#define jit_popr_p(rs) jit_popr_ul(rs)
#define jit_prepare(nint) jit_prepare_i((nint))
#define jit_pusharg_c(rs) jit_pusharg_i(rs)
#define jit_pusharg_s(rs) jit_pusharg_i(rs)
#define jit_pusharg_uc(rs) jit_pusharg_i(rs)
#define jit_pusharg_us(rs) jit_pusharg_i(rs)
#define jit_pusharg_ui(rs) jit_pusharg_i(rs)
#define jit_pusharg_ul(rs) jit_pusharg_l(rs)
#define jit_pusharg_p(rs) jit_pusharg_ul(rs)
/* Memory synonyms */
#ifdef JIT_RZERO
#ifndef jit_ldi_c
#define jit_ldi_c(rd, is) jit_ldxi_c((rd), JIT_RZERO, (is))
#define jit_sti_c(id, rs) jit_stxi_c((id), JIT_RZERO, (rs))
#define jit_ldi_s(rd, is) jit_ldxi_s((rd), JIT_RZERO, (is))
#define jit_sti_s(id, rs) jit_stxi_s((id), JIT_RZERO, (rs))
#define jit_ldi_i(rd, is) jit_ldxi_i((rd), JIT_RZERO, (is))
#define jit_sti_i(id, rs) jit_stxi_i((id), JIT_RZERO, (rs))
#define jit_ldi_l(rd, is) jit_ldxi_l((rd), JIT_RZERO, (is))
#define jit_sti_l(id, rs) jit_stxi_l((id), JIT_RZERO, (rs))
#define jit_ldi_uc(rd, is) jit_ldxi_uc((rd), JIT_RZERO, (is))
#define jit_ldi_us(rd, is) jit_ldxi_us((rd), JIT_RZERO, (is))
#define jit_ldi_ui(rd, is) jit_ldxi_ui((rd), JIT_RZERO, (is))
#define jit_ldi_ul(rd, is) jit_ldxi_ul((rd), JIT_RZERO, (is))
#endif
#ifndef jit_ldr_c
#define jit_ldr_c(rd, rs) jit_ldxr_c((rd), JIT_RZERO, (rs))
#define jit_str_c(rd, rs) jit_stxr_c(JIT_RZERO, (rd), (rs))
#define jit_ldr_s(rd, rs) jit_ldxr_s((rd), JIT_RZERO, (rs))
#define jit_str_s(rd, rs) jit_stxr_s(JIT_RZERO, (rd), (rs))
#define jit_ldr_i(rd, rs) jit_ldxr_i((rd), JIT_RZERO, (rs))
#define jit_str_i(rd, rs) jit_stxr_i(JIT_RZERO, (rd), (rs))
#define jit_ldr_l(rd, rs) jit_ldxr_l((rd), JIT_RZERO, (rs))
#define jit_str_l(rd, rs) jit_stxr_l(JIT_RZERO, (rd), (rs))
#define jit_ldr_uc(rd, rs) jit_ldxr_uc((rd), JIT_RZERO, (rs))
#define jit_ldr_us(rd, rs) jit_ldxr_us((rd), JIT_RZERO, (rs))
#define jit_ldr_ui(rd, rs) jit_ldxr_ui((rd), JIT_RZERO, (rs))
#define jit_ldr_ul(rd, rs) jit_ldxr_ul((rd), JIT_RZERO, (rs))
#endif
#endif
#define jit_str_uc(rd, rs) jit_str_c((rd), (rs))
#define jit_sti_uc(id, rs) jit_sti_c((id), (rs))
#define jit_stxr_uc(d1, d2, rs) jit_stxr_c((d1), (d2), (rs))
#define jit_stxi_uc(id, rd, is) jit_stxi_c((id), (rd), (is))
#define jit_str_us(rd, rs) jit_str_s((rd), (rs))
#define jit_sti_us(id, rs) jit_sti_s((id), (rs))
#define jit_stxr_us(d1, d2, rs) jit_stxr_s((d1), (d2), (rs))
#define jit_stxi_us(id, rd, is) jit_stxi_s((id), (rd), (is))
#define jit_str_ui(rd, rs) jit_str_i((rd), (rs))
#define jit_sti_ui(id, rs) jit_sti_i((id), (rs))
#define jit_stxr_ui(d1, d2, rs) jit_stxr_i((d1), (d2), (rs))
#define jit_stxi_ui(id, rd, is) jit_stxi_i((id), (rd), (is))
#define jit_str_ul(rd, rs) jit_str_l((rd), (rs))
#define jit_sti_ul(id, rs) jit_sti_l((id), (rs))
#define jit_stxr_ul(d1, d2, rs) jit_stxr_l((d1), (d2), (rs))
#define jit_stxi_ul(id, rd, is) jit_stxi_l((id), (rd), (is))
#define jit_str_p(rd, rs) jit_str_l((rd), (rs))
#define jit_sti_p(id, rs) jit_sti_l((id), (rs))
#define jit_stxr_p(d1, d2, rs) jit_stxr_l((d1), (d2), (rs))
#define jit_stxi_p(id, rd, is) jit_stxi_l((id), (rd), (is))
#define jit_ldr_p(rd, rs) jit_ldr_l((rd), (rs))
#define jit_ldi_p(rd, is) jit_ldi_l((rd), (is))
#define jit_ldxr_p(rd, s1, s2) jit_ldxr_l((rd), (s1), (s2))
#define jit_ldxi_p(rd, rs, is) jit_ldxi_l((rd), (rs), (is))
/* Boolean & branch synonyms */
#define jit_eqr_ui(d, s1, s2) jit_eqr_i((d), (s1), (s2))
#define jit_eqi_ui(d, rs, is) jit_eqi_i((d), (rs), (is))
#define jit_ner_ui(d, s1, s2) jit_ner_i((d), (s1), (s2))
#define jit_nei_ui(d, rs, is) jit_nei_i((d), (rs), (is))
#define jit_eqr_ul(d, s1, s2) jit_eqr_l((d), (s1), (s2))
#define jit_eqi_ul(d, rs, is) jit_eqi_l((d), (rs), (is))
#define jit_ner_ul(d, s1, s2) jit_ner_l((d), (s1), (s2))
#define jit_nei_ul(d, rs, is) jit_nei_l((d), (rs), (is))
#define jit_beqr_ui(label, s1, s2) jit_beqr_i((label), (s1), (s2))
#define jit_beqi_ui(label, rs, is) jit_beqi_i((label), (rs), (is))
#define jit_bner_ui(label, s1, s2) jit_bner_i((label), (s1), (s2))
#define jit_bnei_ui(label, rs, is) jit_bnei_i((label), (rs), (is))
#define jit_bmcr_ui(label, s1, s2) jit_bmcr_i((label), (s1), (s2))
#define jit_bmci_ui(label, rs, is) jit_bmci_i((label), (rs), (is))
#define jit_bmsr_ui(label, s1, s2) jit_bmsr_i((label), (s1), (s2))
#define jit_bmsi_ui(label, rs, is) jit_bmsi_i((label), (rs), (is))
#define jit_beqr_ul(label, s1, s2) jit_beqr_l((label), (s1), (s2))
#define jit_beqi_ul(label, rs, is) jit_beqi_l((label), (rs), (is))
#define jit_bner_ul(label, s1, s2) jit_bner_l((label), (s1), (s2))
#define jit_bnei_ul(label, rs, is) jit_bnei_l((label), (rs), (is))
#define jit_bmcr_ul(label, s1, s2) jit_bmcr_l((label), (s1), (s2))
#define jit_bmci_ul(label, rs, is) jit_bmci_l((label), (rs), (is))
#define jit_bmsr_ul(label, s1, s2) jit_bmsr_l((label), (s1), (s2))
#define jit_bmsi_ul(label, rs, is) jit_bmsi_l((label), (rs), (is))
#define jit_ltr_p(d, s1, s2) jit_ltr_ul((d), (s1), (s2))
#define jit_lti_p(d, rs, is) jit_lti_ul((d), (rs), (is))
#define jit_ler_p(d, s1, s2) jit_ler_ul((d), (s1), (s2))
#define jit_lei_p(d, rs, is) jit_lei_ul((d), (rs), (is))
#define jit_gtr_p(d, s1, s2) jit_gtr_ul((d), (s1), (s2))
#define jit_gti_p(d, rs, is) jit_gti_ul((d), (rs), (is))
#define jit_ger_p(d, s1, s2) jit_ger_ul((d), (s1), (s2))
#define jit_gei_p(d, rs, is) jit_gei_ul((d), (rs), (is))
#define jit_eqr_p(d, s1, s2) jit_eqr_ul((d), (s1), (s2))
#define jit_eqi_p(d, rs, is) jit_eqi_ul((d), (rs), (is))
#define jit_ner_p(d, s1, s2) jit_ner_ul((d), (s1), (s2))
#define jit_nei_p(d, rs, is) jit_nei_ul((d), (rs), (is))
#define jit_bltr_p(label, s1, s2) jit_bltr_ul((label), (s1), (s2))
#define jit_blti_p(label, rs, is) jit_blti_ul((label), (rs), (is))
#define jit_bler_p(label, s1, s2) jit_bler_ul((label), (s1), (s2))
#define jit_blei_p(label, rs, is) jit_blei_ul((label), (rs), (is))
#define jit_bgtr_p(label, s1, s2) jit_bgtr_ul((label), (s1), (s2))
#define jit_bgti_p(label, rs, is) jit_bgti_ul((label), (rs), (is))
#define jit_bger_p(label, s1, s2) jit_bger_ul((label), (s1), (s2))
#define jit_bgei_p(label, rs, is) jit_bgei_ul((label), (rs), (is))
#define jit_beqr_p(label, s1, s2) jit_beqr_ul((label), (s1), (s2))
#define jit_beqi_p(label, rs, is) jit_beqi_ul((label), (rs), (is))
#define jit_bner_p(label, s1, s2) jit_bner_ul((label), (s1), (s2))
#define jit_bnei_p(label, rs, is) jit_bnei_ul((label), (rs), (is))
#define jit_retval_ui(rd) jit_retval_i((rd))
#define jit_retval_uc(rd) jit_retval_i((rd))
#define jit_retval_us(rd) jit_retval_i((rd))
#define jit_retval_ul(rd) jit_retval_l((rd))
#define jit_retval_p(rd) jit_retval_ul((rd))
#define jit_retval_c(rd) jit_retval_i((rd))
#define jit_retval_s(rd) jit_retval_i((rd))
/* This was a bug, but we keep it. */
#define jit_retval(rd) jit_retval_i ((rd))
#ifndef jit_finish
#define jit_finish(sub) jit_calli(sub)
#endif
#ifndef jit_finishr
#define jit_finishr(reg) jit_callr(reg)
#endif
#ifndef jit_prolog
#define jit_prolog(numargs)
#endif
#ifndef jit_leaf
#define jit_leaf(numargs) jit_prolog(numargs)
#endif
#ifndef jit_getarg_c
#ifndef JIT_FP
#define jit_getarg_c(reg, ofs) jit_extr_c_i ((reg), (ofs))
#define jit_getarg_i(reg, ofs) jit_movr_i ((reg), (ofs))
#define jit_getarg_l(reg, ofs) jit_movr_l ((reg), (ofs))
#define jit_getarg_p(reg, ofs) jit_movr_p ((reg), (ofs))
#define jit_getarg_s(reg, ofs) jit_extr_s_i ((reg), (ofs))
#define jit_getarg_uc(reg, ofs) jit_extr_uc_ui((reg), (ofs))
#define jit_getarg_ui(reg, ofs) jit_movr_ui ((reg), (ofs))
#define jit_getarg_ul(reg, ofs) jit_extr_uc_ul((reg), (ofs))
#define jit_getarg_us(reg, ofs) jit_extr_us_ul((reg), (ofs))
#else
#define jit_getarg_c(reg, ofs) jit_ldxi_c((reg), JIT_FP, (ofs));
#define jit_getarg_uc(reg, ofs) jit_ldxi_uc((reg), JIT_FP, (ofs));
#define jit_getarg_s(reg, ofs) jit_ldxi_s((reg), JIT_FP, (ofs));
#define jit_getarg_us(reg, ofs) jit_ldxi_us((reg), JIT_FP, (ofs));
#define jit_getarg_i(reg, ofs) jit_ldxi_i((reg), JIT_FP, (ofs));
#define jit_getarg_ui(reg, ofs) jit_ldxi_ui((reg), JIT_FP, (ofs));
#define jit_getarg_l(reg, ofs) jit_ldxi_l((reg), JIT_FP, (ofs));
#define jit_getarg_ul(reg, ofs) jit_ldxi_ul((reg), JIT_FP, (ofs));
#define jit_getarg_p(reg, ofs) jit_ldxi_p((reg), JIT_FP, (ofs));
#endif
#endif
/* Common definitions when sizeof(long) = sizeof(int) */
#ifndef jit_addi_l
#define JIT_LONG_IS_INT
/* ALU */
#define jit_addi_l(d, rs, is) jit_addi_i((d), (rs), (is))
#define jit_addr_l(d, s1, s2) jit_addr_i((d), (s1), (s2))
#define jit_addci_l(d, rs, is) jit_addci_i((d), (rs), (is))
#define jit_addcr_l(d, s1, s2) jit_addcr_i((d), (s1), (s2))
#define jit_addxi_l(d, rs, is) jit_addxi_i((d), (rs), (is))
#define jit_addxr_l(d, s1, s2) jit_addxr_i((d), (s1), (s2))
#define jit_andi_l(d, rs, is) jit_andi_i((d), (rs), (is))
#define jit_andr_l(d, s1, s2) jit_andr_i((d), (s1), (s2))
#define jit_divi_l(d, rs, is) jit_divi_i((d), (rs), (is))
#define jit_divr_l(d, s1, s2) jit_divr_i((d), (s1), (s2))
#define jit_hmuli_l(d, rs, is) jit_hmuli_i((d), (rs), (is))
#define jit_hmulr_l(d, s1, s2) jit_hmulr_i((d), (s1), (s2))
#define jit_lshi_l(d, rs, is) jit_lshi_i((d), (rs), (is))
#define jit_lshr_l(d, s1, s2) jit_lshr_i((d), (s1), (s2))
#define jit_modi_l(d, rs, is) jit_modi_i((d), (rs), (is))
#define jit_modr_l(d, s1, s2) jit_modr_i((d), (s1), (s2))
#define jit_muli_l(d, rs, is) jit_muli_i((d), (rs), (is))
#define jit_mulr_l(d, s1, s2) jit_mulr_i((d), (s1), (s2))
#define jit_ori_l(d, rs, is) jit_ori_i((d), (rs), (is))
#define jit_orr_l(d, s1, s2) jit_orr_i((d), (s1), (s2))
#define jit_rshi_l(d, rs, is) jit_rshi_i((d), (rs), (is))
#define jit_rshr_l(d, s1, s2) jit_rshr_i((d), (s1), (s2))
#define jit_subr_l(d, s1, s2) jit_subr_i((d), (s1), (s2))
#define jit_subcr_l(d, s1, s2) jit_subcr_i((d), (s1), (s2))
#define jit_subxi_l(d, rs, is) jit_subxi_i((d), (rs), (is))
#define jit_subxr_l(d, s1, s2) jit_subxr_i((d), (s1), (s2))
#define jit_xori_l(d, rs, is) jit_xori_i((d), (rs), (is))
#define jit_xorr_l(d, s1, s2) jit_xorr_i((d), (s1), (s2))
#ifndef jit_rsbi_l
#define jit_rsbi_l(d, rs, is) jit_rsbi_i((d), (rs), (is))
#endif
#define jit_divi_ul(d, rs, is) jit_divi_ui((d), (rs), (is))
#define jit_divr_ul(d, s1, s2) jit_divr_ui((d), (s1), (s2))
#define jit_hmuli_ul(d, rs, is) jit_hmuli_ui((d), (rs), (is))
#define jit_hmulr_ul(d, s1, s2) jit_hmulr_ui((d), (s1), (s2))
#define jit_modi_ul(d, rs, is) jit_modi_ui((d), (rs), (is))
#define jit_modr_ul(d, s1, s2) jit_modr_ui((d), (s1), (s2))
#define jit_muli_ul(d, rs, is) jit_muli_ui((d), (rs), (is))
#define jit_mulr_ul(d, s1, s2) jit_mulr_ui((d), (s1), (s2))
#define jit_rshi_ul(d, rs, is) jit_rshi_ui((d), (rs), (is))
#define jit_rshr_ul(d, s1, s2) jit_rshr_ui((d), (s1), (s2))
/* Sign/Zero extension */
#define jit_extr_c_l(d, rs) jit_extr_c_i(d, rs)
#define jit_extr_c_ul(d, rs) jit_extr_c_ui(d, rs)
#define jit_extr_s_l(d, rs) jit_extr_s_i(d, rs)
#define jit_extr_s_ul(d, rs) jit_extr_s_ui(d, rs)
#define jit_extr_i_l(d, rs) jit_movr_i(d, rs)
#define jit_extr_i_ul(d, rs) jit_movr_i(d, rs)
/* Unary */
#define jit_movi_l(d, rs) jit_movi_i((d), (rs))
#define jit_movr_l(d, rs) jit_movr_i((d), (rs))
/* Stack */
#define jit_pushr_l(rs) jit_pushr_i(rs)
#define jit_popr_l(rs) jit_popr_i(rs)
#define jit_pusharg_l(rs) jit_pusharg_i(rs)
/* Memory */
#ifndef JIT_RZERO
#define jit_ldr_l(d, rs) jit_ldr_i((d), (rs))
#define jit_ldi_l(d, is) jit_ldi_i((d), (is))
#define jit_str_l(d, rs) jit_str_i((d), (rs))
#define jit_sti_l(d, is) jit_sti_i((d), (is))
#define jit_ldr_ui(d, rs) jit_ldr_i((d), (rs))
#define jit_ldi_ui(d, is) jit_ldi_i((d), (is))
#define jit_ldr_ul(d, rs) jit_ldr_ui((d), (rs))
#define jit_ldi_ul(d, is) jit_ldi_ui((d), (is))
#endif
#define jit_ldxr_l(d, s1, s2) jit_ldxr_i((d), (s1), (s2))
#define jit_ldxi_l(d, rs, is) jit_ldxi_i((d), (rs), (is))
#define jit_stxr_l(d, s1, s2) jit_stxr_i((d), (s1), (s2))
#define jit_stxi_l(d, rs, is) jit_stxi_i((d), (rs), (is))
#define jit_ldxr_ui(d, s1, s2) jit_ldxr_i((d), (s1), (s2))
#define jit_ldxi_ui(d, rs, is) jit_ldxi_i((d), (rs), (is))
#define jit_ldxr_ul(d, s1, s2) jit_ldxr_ui((d), (s1), (s2))
#define jit_ldxi_ul(d, rs, is) jit_ldxi_ui((d), (rs), (is))
/* Boolean */
#define jit_ltr_l(d, s1, s2) jit_ltr_i((d), (s1), (s2))
#define jit_lti_l(d, rs, is) jit_lti_i((d), (rs), (is))
#define jit_ler_l(d, s1, s2) jit_ler_i((d), (s1), (s2))
#define jit_lei_l(d, rs, is) jit_lei_i((d), (rs), (is))
#define jit_gtr_l(d, s1, s2) jit_gtr_i((d), (s1), (s2))
#define jit_gti_l(d, rs, is) jit_gti_i((d), (rs), (is))
#define jit_ger_l(d, s1, s2) jit_ger_i((d), (s1), (s2))
#define jit_gei_l(d, rs, is) jit_gei_i((d), (rs), (is))
#define jit_eqr_l(d, s1, s2) jit_eqr_i((d), (s1), (s2))
#define jit_eqi_l(d, rs, is) jit_eqi_i((d), (rs), (is))
#define jit_ner_l(d, s1, s2) jit_ner_i((d), (s1), (s2))
#define jit_nei_l(d, rs, is) jit_nei_i((d), (rs), (is))
#define jit_ltr_ul(d, s1, s2) jit_ltr_ui((d), (s1), (s2))
#define jit_lti_ul(d, rs, is) jit_lti_ui((d), (rs), (is))
#define jit_ler_ul(d, s1, s2) jit_ler_ui((d), (s1), (s2))
#define jit_lei_ul(d, rs, is) jit_lei_ui((d), (rs), (is))
#define jit_gtr_ul(d, s1, s2) jit_gtr_ui((d), (s1), (s2))
#define jit_gti_ul(d, rs, is) jit_gti_ui((d), (rs), (is))
#define jit_ger_ul(d, s1, s2) jit_ger_ui((d), (s1), (s2))
#define jit_gei_ul(d, rs, is) jit_gei_ui((d), (rs), (is))
/* Branches */
#define jit_bltr_l(label, s1, s2) jit_bltr_i((label), (s1), (s2))
#define jit_blti_l(label, rs, is) jit_blti_i((label), (rs), (is))
#define jit_bler_l(label, s1, s2) jit_bler_i((label), (s1), (s2))
#define jit_blei_l(label, rs, is) jit_blei_i((label), (rs), (is))
#define jit_bgtr_l(label, s1, s2) jit_bgtr_i((label), (s1), (s2))
#define jit_bgti_l(label, rs, is) jit_bgti_i((label), (rs), (is))
#define jit_bger_l(label, s1, s2) jit_bger_i((label), (s1), (s2))
#define jit_bgei_l(label, rs, is) jit_bgei_i((label), (rs), (is))
#define jit_beqr_l(label, s1, s2) jit_beqr_i((label), (s1), (s2))
#define jit_beqi_l(label, rs, is) jit_beqi_i((label), (rs), (is))
#define jit_bner_l(label, s1, s2) jit_bner_i((label), (s1), (s2))
#define jit_bnei_l(label, rs, is) jit_bnei_i((label), (rs), (is))
#define jit_bmcr_l(label, s1, s2) jit_bmcr_i((label), (s1), (s2))
#define jit_bmci_l(label, rs, is) jit_bmci_i((label), (rs), (is))
#define jit_bmsr_l(label, s1, s2) jit_bmsr_i((label), (s1), (s2))
#define jit_bmsi_l(label, rs, is) jit_bmsi_i((label), (rs), (is))
#define jit_boaddr_l(label, s1, s2) jit_boaddr_i((label), (s1), (s2))
#define jit_boaddi_l(label, rs, is) jit_boaddi_i((label), (rs), (is))
#define jit_bosubr_l(label, s1, s2) jit_bosubr_i((label), (s1), (s2))
#define jit_bosubi_l(label, rs, is) jit_bosubi_i((label), (rs), (is))
#define jit_bltr_ul(label, s1, s2) jit_bltr_ui((label), (s1), (s2))
#define jit_blti_ul(label, rs, is) jit_blti_ui((label), (rs), (is))
#define jit_bler_ul(label, s1, s2) jit_bler_ui((label), (s1), (s2))
#define jit_blei_ul(label, rs, is) jit_blei_ui((label), (rs), (is))
#define jit_bgtr_ul(label, s1, s2) jit_bgtr_ui((label), (s1), (s2))
#define jit_bgti_ul(label, rs, is) jit_bgti_ui((label), (rs), (is))
#define jit_bger_ul(label, s1, s2) jit_bger_ui((label), (s1), (s2))
#define jit_bgei_ul(label, rs, is) jit_bgei_ui((label), (rs), (is))
#define jit_boaddr_ul(label, s1, s2) jit_boaddr_ui((label), (s1), (s2))
#define jit_boaddi_ul(label, rs, is) jit_boaddi_ui((label), (rs), (is))
#define jit_bosubr_ul(label, s1, s2) jit_bosubr_ui((label), (s1), (s2))
#define jit_bosubi_ul(label, rs, is) jit_bosubi_ui((label), (rs), (is))
#define jit_retval_l(rd) jit_retval_i((rd))
#endif
#endif /* __lightning_core_common_h_ */

299
src/mzscheme/src/lightning/ppc/core.h Normal file
View File

@ -0,0 +1,299 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer (PowerPC version)
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_core_h
#define __lightning_core_h
struct jit_local_state {
int nextarg_puti; /* number of integer args */
int nextarg_putf; /* number of float args */
int nextarg_putd; /* number of double args */
int nextarg_geti; /* Next r20-r25 reg. to be read */
int nextarg_getd; /* The FP args are picked up from FPR1 -> FPR10 */
int nbArgs; /* Number of arguments for the prolog */
int long_jumps; /* 1 => patch or leave room for long jumps */
};
#define JIT_SP 1
#define JIT_RET 3
#define JIT_R_NUM 3
#define JIT_V_NUM 7
#define JIT_R(i) (9+(i))
#define JIT_V(i) (31-(i))
#define JIT_AUX JIT_V(JIT_V_NUM) /* for 32-bit operands & shift counts */
#define jit_pfx_start() (_jit.jitl.trampolines)
#define jit_pfx_end() (_jit.jitl.free)
/* If possible, use the `small' instruction (rd, rs, imm)
* else load imm into r26 and use the `big' instruction (rd, rs, r26)
*/
#define jit_chk_ims(imm, small, big) (_siP(16,(imm)) ? (small) : (MOVEIri(JIT_AUX, imm), (big)) )
#define jit_chk_imu(imm, small, big) (_uiP(16,(imm)) ? (small) : (MOVEIri(JIT_AUX, imm), (big)) )
#define jit_chk_imu15(imm, small, big) (_uiP(15,(imm)) ? (small) : (MOVEIri(JIT_AUX, imm), (big)) )
#define jit_big_ims(imm, big) (MOVEIri(JIT_AUX, imm), (big))
#define jit_big_imu(imm, big) (MOVEIri(JIT_AUX, imm), (big))
/* Helper macros for branches */
#define jit_s_brai(rs, is, jmp) (jit_chk_ims (is, CMPWIri(rs, is), CMPWrr(rs, JIT_AUX)), jmp, _jit.x.pc)
#define jit_s_brar(s1, s2, jmp) ( CMPWrr(s1, s2), jmp, _jit.x.pc)
#define jit_u_brai(rs, is, jmp) (jit_chk_imu (is, CMPLWIri(rs, is), CMPLWrr(rs, JIT_AUX)), jmp, _jit.x.pc)
#define jit_u_brar(s1, s2, jmp) ( CMPLWrr(s1, s2), jmp, _jit.x.pc)
/* Helper macros for boolean tests. */
#define jit_sbooli(d, rs, is, jmp) (jit_chk_ims (is, CMPWIri (rs, is), CMPWrr(rs, JIT_AUX)), MFCRr((d)), EXTRWIrrii((d), (d), 1, (jmp)))
#define jit_sboolr(d, s1, s2, jmp) ( CMPWrr (s1, s2), MFCRr((d)), EXTRWIrrii((d), (d), 1, (jmp)))
#define jit_sbooli2(d, rs, is, jmp) (jit_chk_ims (is, CMPWIri (rs, is), CMPWrr(rs, JIT_AUX)), MFCRr((d)), EXTRWIrrii((d), (d), 1, (jmp)), XORIrri((d), (d), 1))
#define jit_sboolr2(d, s1, s2, jmp) ( CMPWrr (s1, s2), MFCRr((d)), EXTRWIrrii((d), (d), 1, (jmp)), XORIrri((d), (d), 1))
#define jit_ubooli(d, rs, is, jmp) (jit_chk_imu (is, CMPLWIri(rs, is), CMPLWrr(rs, JIT_AUX)), MFCRr((d)), EXTRWIrrii((d), (d), 1, (jmp)))
#define jit_uboolr(d, s1, s2, jmp) ( CMPLWrr (s1, s2), MFCRr((d)), EXTRWIrrii((d), (d), 1, (jmp)))
#define jit_ubooli2(d, rs, is, jmp) (jit_chk_imu (is, CMPLWIri(rs, is), CMPLWrr(rs, JIT_AUX)), MFCRr((d)), EXTRWIrrii((d), (d), 1, (jmp)), XORIrri((d), (d), 1))
#define jit_uboolr2(d, s1, s2, jmp) ( CMPLWrr (s1, s2), MFCRr((d)), EXTRWIrrii((d), (d), 1, (jmp)), XORIrri((d), (d), 1))
/* modulus with immediate
* movei r26, imm
* mtlr r31
* divw r31, rs, r26 (or divwu)
* mullw r31, r31, r26
* sub rs, rs, r26
* mflr r31
*/
#define _jit_mod(div, rs, imm) (MOVEIri(JIT_AUX, (imm)), MTLRr(31), (div), \
MULLWrrr(31, 31, JIT_AUX), SUBrrr((rs), (rs), JIT_AUX), \
MFLRr(31))
/* Patch a movei instruction made of a LIS at lis_pc and an ORI at ori_pc. */
#define jit_patch_movei(lis_pc, ori_pc, dest) \
(*(lis_pc) &= ~_MASK(16), *(lis_pc) |= _HI(dest), \
*(ori_pc) &= ~_MASK(16), *(ori_pc) |= _LO(dest)) \
/* Patch a branch instruction */
#define jit_patch_branch(jump_pc,pv) \
(*(jump_pc) &= ~_MASK(16) | 3, \
*(jump_pc) |= (_jit_UL(pv) - _jit_UL(jump_pc)) & _MASK(16))
#define jit_patch_ucbranch(jump_pc,pv) \
(*(jump_pc) &= ~_MASK(26) | 3, \
(*(jump_pc) |= (_jit_UL((pv)) - _jit_UL(jump_pc)) & _MASK(26)))
#define _jit_b_encoding (18 << 26)
#define _jit_blr_encoding ((19 << 26) | (20 << 21) | (00 << 16) | (00 << 11) | (16 << 1))
#define _jit_is_ucbranch(a) (((*(a) & (63<<26)) == _jit_b_encoding))
#define jit_patch_at(jump_pc, value) ( \
((*(jump_pc - 1) & ~1) == _jit_blr_encoding) \
? jit_patch_movei(((jump_pc) - 4), ((jump_pc) - 3), (value)) \
: ( _jit_is_ucbranch((jump_pc) - 1) \
? jit_patch_ucbranch((jump_pc) - 1, (value)) \
: jit_patch_branch((jump_pc) - 1, (value))))
#define jit_patch_movi(movi_pc, val) \
jit_patch_movei((movi_pc) - 2, (movi_pc) - 1, (val))
#define jit_arg_c() (_jitl.nextarg_geti++)
#define jit_arg_i() (_jitl.nextarg_geti++)
#define jit_arg_l() (_jitl.nextarg_geti++)
#define jit_arg_p() (_jitl.nextarg_geti++)
#define jit_arg_s() (_jitl.nextarg_geti++)
#define jit_arg_uc() (_jitl.nextarg_geti++)
#define jit_arg_ui() (_jitl.nextarg_geti++)
#define jit_arg_ul() (_jitl.nextarg_geti++)
#define jit_arg_us() (_jitl.nextarg_geti++)
/* Check Mach-O-Runtime documentation: Must skip GPR(s) whenever "corresponding" FPR is used */
#define jit_arg_f() (_jitl.nextarg_geti-- ,_jitl.nextarg_getd++)
#define jit_arg_d() (_jitl.nextarg_geti-=2,_jitl.nextarg_getd++)
#define jit_addi_i(d, rs, is) jit_chk_ims((is), ADDICrri((d), (rs), (is)), ADDrrr((d), (rs), JIT_AUX))
#define jit_addr_i(d, s1, s2) ADDrrr((d), (s1), (s2))
#define jit_addci_i(d, rs, is) jit_chk_ims((is), ADDICrri((d), (rs), (is)), ADDCrrr((d), (rs), JIT_AUX))
#define jit_addcr_i(d, s1, s2) ADDCrrr((d), (s1), (s2))
#define jit_addxi_i(d, rs, is) (MOVEIri(JIT_AUX, (is)), ADDErrr((d), (rs), JIT_AUX))
#define jit_addxr_i(d, s1, s2) ADDErrr((d), (s1), (s2))
#define jit_andi_i(d, rs, is) jit_chk_imu((is), ANDI_rri((d), (rs), (is)), ANDrrr((d), (rs), JIT_AUX))
#define jit_andr_i(d, s1, s2) ANDrrr((d), (s1), (s2))
#define jit_bmsi_i(label, rs, is) (jit_chk_imu((is), ANDI_rri(JIT_AUX, (rs), (is)), AND_rrr(JIT_AUX, (rs), JIT_AUX)), BGTi((label)), _jit.x.pc)
#define jit_bmci_i(label, rs, is) (jit_chk_imu((is), ANDI_rri(JIT_AUX, (rs), (is)), AND_rrr(JIT_AUX, (rs), JIT_AUX)), BEQi((label)), _jit.x.pc)
#define jit_bmsr_i(label, s1, s2) ( AND_rrr(JIT_AUX, (s1), (s2)), BGTi((label)), _jit.x.pc)
#define jit_bmcr_i(label, s1, s2) ( AND_rrr(JIT_AUX, (s1), (s2)), BEQi((label)), _jit.x.pc)
#define jit_beqi_i(label, rs, is) jit_s_brai((rs), (is), BEQi((label)) )
#define jit_beqr_i(label, s1, s2) jit_s_brar((s1), (s2), BEQi((label)) )
#define jit_bgei_i(label, rs, is) jit_s_brai((rs), (is), BGEi((label)) )
#define jit_bgei_ui(label, rs, is) jit_u_brai((rs), (is), BGEi((label)) )
#define jit_bger_i(label, s1, s2) jit_s_brar((s1), (s2), BGEi((label)) )
#define jit_bger_ui(label, s1, s2) jit_u_brar((s1), (s2), BGEi((label)) )
#define jit_bgti_i(label, rs, is) jit_s_brai((rs), (is), BGTi((label)) )
#define jit_bgti_ui(label, rs, is) jit_u_brai((rs), (is), BGTi((label)) )
#define jit_bgtr_i(label, s1, s2) jit_s_brar((s1), (s2), BGTi((label)) )
#define jit_bgtr_ui(label, s1, s2) jit_u_brar((s1), (s2), BGTi((label)) )
#define jit_blei_i(label, rs, is) jit_s_brai((rs), (is), BLEi((label)) )
#define jit_blei_ui(label, rs, is) jit_u_brai((rs), (is), BLEi((label)) )
#define jit_bler_i(label, s1, s2) jit_s_brar((s1), (s2), BLEi((label)) )
#define jit_bler_ui(label, s1, s2) jit_u_brar((s1), (s2), BLEi((label)) )
#define jit_blti_i(label, rs, is) jit_s_brai((rs), (is), BLTi((label)) )
#define jit_blti_ui(label, rs, is) jit_u_brai((rs), (is), BLTi((label)) )
#define jit_bltr_i(label, s1, s2) jit_s_brar((s1), (s2), BLTi((label)) )
#define jit_bltr_ui(label, s1, s2) jit_u_brar((s1), (s2), BLTi((label)) )
#define jit_bnei_i(label, rs, is) jit_s_brai((rs), (is), BNEi((label)) )
#define jit_bner_i(label, s1, s2) jit_s_brar((s1), (s2), BNEi((label)) )
#define jit_boaddi_i(label, rs, is) (MOVEIri(JIT_AUX, (is)), ADDOrrr((rs), (rs), JIT_AUX), MCRXRi(0), BGTi((label)), _jit.x.pc) /* GT = bit 1 of XER = OV */
#define jit_bosubi_i(label, rs, is) (MOVEIri(JIT_AUX, (is)), SUBCOrrr((rs), (rs), JIT_AUX), MCRXRi(0), BGTi((label)), _jit.x.pc)
#define jit_boaddr_i(label, s1, s2) ( ADDOrrr((s1), (s1), (s2)), MCRXRi(0), BGTi((label)), _jit.x.pc)
#define jit_bosubr_i(label, s1, s2) ( SUBCOrrr((s1), (s1), (s2)), MCRXRi(0), BGTi((label)), _jit.x.pc)
#define jit_boaddi_ui(label, rs, is) (jit_chk_ims ((is), ADDICri((rs), (rs), is), ADDCrr((rs), JIT_AUX)), MCRXRi(0), BEQi((label)), _jit.x.pc) /* EQ = bit 2 of XER = CA */
#define jit_bosubi_ui(label, rs, is) (jit_chk_ims ((is), SUBICri((rs), (rs), is), SUBCrr((rs), JIT_AUX)), MCRXRi(0), BEQi((label)), _jit.x.pc)
#define jit_boaddr_ui(label, s1, s2) ( ADDCrr((s1), (s1), (s2)), MCRXRi(0), BEQi((label)), _jit.x.pc)
#define jit_bosubr_ui(label, s1, s2) ( SUBCrr((s1), (s1), (s2)), MCRXRi(0), BEQi((label)), _jit.x.pc)
#define jit_calli(label) ((void)jit_movi_p(JIT_AUX, (label)), MTCTRr(JIT_AUX), BCTRL(), _jitl.nextarg_puti = _jitl.nextarg_putf = _jitl.nextarg_putd = 0, _jit.x.pc)
#define jit_callr(reg) (MTCTRr(reg), BCTRL())
#define jit_divi_i(d, rs, is) jit_big_ims((is), DIVWrrr ((d), (rs), JIT_AUX))
#define jit_divi_ui(d, rs, is) jit_big_imu((is), DIVWUrrr((d), (rs), JIT_AUX))
#define jit_divr_i(d, s1, s2) DIVWrrr ((d), (s1), (s2))
#define jit_divr_ui(d, s1, s2) DIVWUrrr((d), (s1), (s2))
#define jit_eqi_i(d, rs, is) (jit_chk_ims((is), SUBIrri(JIT_AUX, (rs), (is)), SUBrrr(JIT_AUX, (rs), JIT_AUX)), SUBFICrri((d), JIT_AUX, 0), ADDErrr((d), (d), JIT_AUX))
#define jit_eqr_i(d, s1, s2) (SUBrrr(JIT_AUX, (s1), (s2)), SUBFICrri((d), JIT_AUX, 0), ADDErrr((d), (d), JIT_AUX))
#define jit_extr_c_i(d, rs) EXTSBrr((d), (rs))
#define jit_extr_s_i(d, rs) EXTSHrr((d), (rs))
#define jit_gei_i(d, rs, is) jit_sbooli2((d), (rs), (is), _lt)
#define jit_gei_ui(d, rs, is) jit_ubooli2((d), (rs), (is), _lt)
#define jit_ger_i(d, s1, s2) jit_sboolr2((d), (s1), (s2), _lt)
#define jit_ger_ui(d, s1, s2) jit_uboolr2((d), (s1), (s2), _lt)
#define jit_gti_i(d, rs, is) jit_sbooli ((d), (rs), (is), _gt)
#define jit_gti_ui(d, rs, is) jit_ubooli ((d), (rs), (is), _gt)
#define jit_gtr_i(d, s1, s2) jit_sboolr ((d), (s1), (s2), _gt)
#define jit_gtr_ui(d, s1, s2) jit_uboolr ((d), (s1), (s2), _gt)
#define jit_hmuli_i(d, rs, is) jit_big_ims((is), MULHWrrr ((d), (rs), JIT_AUX))
#define jit_hmuli_ui(d, rs, is) jit_big_imu((is), MULHWUrrr((d), (rs), JIT_AUX))
#define jit_hmulr_i(d, s1, s2) MULHWrrr ((d), (s1), (s2))
#define jit_hmulr_ui(d, s1, s2) MULHWUrrr((d), (s1), (s2))
#define jit_jmpi(label) (B_EXT((label)), _jit.x.pc)
#define jit_jmpr(reg) (MTLRr(reg), BLR())
#define jit_ldxi_c(d, rs, is) (jit_ldxi_uc((d), (rs), (is)), jit_extr_c_i((d), (d)))
#define jit_ldxr_c(d, s1, s2) (jit_ldxr_uc((d), (s1), (s2)), jit_extr_c_i((d), (d)))
#define jit_ldxi_i(d, rs, is) jit_chk_ims((d), LWZrm((d), (is), (rs)), LWZrx((d), JIT_AUX, (rs)))
#define jit_ldxi_s(d, rs, is) jit_chk_ims((d), LHArm((d), (is), (rs)), LHArx((d), JIT_AUX, (rs)))
#define jit_ldxi_uc(d, rs, is) jit_chk_ims((d), LBZrm((d), (is), (rs)), LBZrx((d), JIT_AUX, (rs)))
#define jit_ldxi_us(d, rs, is) jit_chk_ims((d), LHZrm((d), (is), (rs)), LHZrx((d), JIT_AUX, (rs)))
#define jit_ldxr_i(d, s1, s2) LWZrx((d), (s1), (s2))
#define jit_ldxr_s(d, s1, s2) LHArx((d), (s1), (s2))
#define jit_ldxr_uc(d, s1, s2) LBZrx((d), (s1), (s2))
#define jit_ldxr_us(d, s1, s2) LHZrx((d), (s1), (s2))
#define jit_lei_i(d, rs, is) jit_sbooli2((d), (rs), (is), _gt )
#define jit_lei_ui(d, rs, is) jit_ubooli2((d), (rs), (is), _gt )
#define jit_ler_i(d, s1, s2) jit_sboolr2((d), (s1), (s2), _gt )
#define jit_ler_ui(d, s1, s2) jit_uboolr2((d), (s1), (s2), _gt )
#define jit_lshi_i(d, rs, is) SLWIrri((d), (rs), (is))
#define jit_lshr_i(d, s1, s2) (ANDI_rri(JIT_AUX, (s2), 31), SLWrrr ((d), (s1), JIT_AUX))
#define jit_lti_i(d, rs, is) jit_sbooli ((d), (rs), (is), _lt )
#define jit_lti_ui(d, rs, is) jit_ubooli ((d), (rs), (is), _lt )
#define jit_ltr_i(d, s1, s2) jit_sboolr ((d), (s1), (s2), _lt )
#define jit_ltr_ui(d, s1, s2) jit_uboolr ((d), (s1), (s2), _lt )
#define jit_modi_i(d, rs, is) _jit_mod(jit_divi_i (31, (rs), JIT_AUX), (rs), (is))
#define jit_modi_ui(d, rs, is) _jit_mod(jit_divi_ui(31, (rs), JIT_AUX), (rs), (is))
#define jit_modr_i(d, s1, s2) (DIVWrrr(JIT_AUX, (s1), (s2)), MULLWrrr(JIT_AUX, JIT_AUX, (s2)), SUBrrr((d), (s1), JIT_AUX))
#define jit_modr_ui(d, s1, s2) (DIVWUrrr(JIT_AUX, (s1), (s2)), MULLWrrr(JIT_AUX, JIT_AUX, (s2)), SUBrrr((d), (s1), JIT_AUX))
#define jit_movi_i(d, is) MOVEIri((d), (is))
#define jit_movi_p(d, is) (LISri((d), _HI((is))),ORIrri((d),(d),_LO((is))),_jit.x.pc)
#define jit_movr_i(d, rs) MRrr((d), (rs))
#define jit_muli_i(d, rs, is) jit_chk_ims ((is), MULLIrri((d), (rs), (is)), MULLWrrr((d), (rs), JIT_AUX))
#define jit_muli_ui(d, rs, is) jit_chk_imu15((is), MULLIrri((d), (rs), (is)), MULLWrrr((d), (rs), JIT_AUX))
#define jit_mulr_i(d, s1, s2) MULLWrrr((d), (s1), (s2))
#define jit_mulr_ui(d, s1, s2) MULLWrrr((d), (s1), (s2))
#define jit_nei_i(d, rs, is) (jit_chk_ims((is), SUBIrri(JIT_AUX, (rs), (is)), SUBrrr(JIT_AUX, (rs), JIT_AUX)), ADDICrri((d), JIT_AUX, -1), SUBFErrr((d), (d), JIT_AUX))
#define jit_ner_i(d, s1, s2) (SUBrrr(JIT_AUX, (s1), (s2)), ADDICrri((d), JIT_AUX, -1), SUBFErrr((d), (d), JIT_AUX))
#define jit_nop() NOP()
#define jit_ori_i(d, rs, is) jit_chk_imu((is), ORIrri((d), (rs), (is)), ORrrr((d), (rs), JIT_AUX))
#define jit_orr_i(d, s1, s2) ORrrr((d), (s1), (s2))
#define jit_popr_i(rs) (LWZrm((rs), 0, 1), ADDIrri(1, 1, 4))
#define jit_prepare_i(numi) (_jitl.nextarg_puti = numi)
#define jit_prepare_f(numf) (_jitl.nextarg_putf = numf)
#define jit_prepare_d(numd) (_jitl.nextarg_putd = numd)
#define jit_prolog(n) _jit_prolog(&_jit, (n))
#define jit_pushr_i(rs) STWUrm((rs), -4, 1)
#define jit_pusharg_i(rs) (--_jitl.nextarg_puti, MRrr((3 + _jitl.nextarg_putd * 2 + _jitl.nextarg_putf + _jitl.nextarg_puti), (rs)))
#define jit_ret() _jit_epilog(&_jit)
#define jit_retval_i(rd) MRrr((rd), 3)
#define jit_rsbi_i(d, rs, is) jit_chk_ims((is), SUBFICrri((d), (rs), (is)), SUBFCrrr((d), (rs), JIT_AUX))
#define jit_rshi_i(d, rs, is) SRAWIrri((d), (rs), (is))
#define jit_rshi_ui(d, rs, is) SRWIrri ((d), (rs), (is))
#define jit_rshr_i(d, s1, s2) (ANDI_rri(JIT_AUX, (s2), 31), SRAWrrr ((d), (s1), JIT_AUX))
#define jit_rshr_ui(d, s1, s2) (ANDI_rri(JIT_AUX, (s2), 31), SRWrrr ((d), (s1), JIT_AUX))
#define jit_stxi_c(id, rd, rs) jit_chk_ims((id), STBrm((rs), (id), (rd)), STBrx((rs), (rd), JIT_AUX))
#define jit_stxi_i(id, rd, rs) jit_chk_ims((id), STWrm((rs), (id), (rd)), STWrx((rs), (rd), JIT_AUX))
#define jit_stxi_s(id, rd, rs) jit_chk_ims((id), STHrm((rs), (id), (rd)), STHrx((rs), (rd), JIT_AUX))
#define jit_stxr_c(d1, d2, rs) STBrx((rs), (d1), (d2))
#define jit_stxr_i(d1, d2, rs) STWrx((rs), (d1), (d2))
#define jit_stxr_s(d1, d2, rs) STHrx((rs), (d1), (d2))
#define jit_subr_i(d, s1, s2) SUBrrr((d), (s1), (s2))
#define jit_subcr_i(d, s1, s2) SUBCrrr((d), (s1), (s2))
#define jit_subxi_i(d, rs, is) jit_big_ims((is), SUBErrr((d), (rs), JIT_AUX))
#define jit_subxr_i(d, s1, s2) SUBErrr((d), (s1), (s2))
#define jit_xori_i(d, rs, is) jit_chk_imu((is), XORIrri((d), (rs), (is)), XORrrr((d), (rs), JIT_AUX))
#define jit_xorr_i(d, s1, s2) XORrrr((d), (s1), (s2))
/* Cannot use JIT_RZERO because having 0 in a register field on the PowerPC
* does not mean `a register whose value is 0', but rather `no register at
* all' */
#define jit_negr_i(d, rs) jit_rsbi_i((d), (rs), 0)
#define jit_negr_l(d, rs) jit_rsbi_l((d), (rs), 0)
#define jit_ldr_c(rd, rs) jit_ldxr_c((rd), 0, (rs))
#define jit_str_c(rd, rs) jit_stxr_c(0, (rd), (rs))
#define jit_ldr_s(rd, rs) jit_ldxr_s((rd), 0, (rs))
#define jit_str_s(rd, rs) jit_stxr_s(0, (rd), (rs))
#define jit_ldr_i(rd, rs) jit_ldxr_i((rd), 0, (rs))
#define jit_str_i(rd, rs) jit_stxr_i(0, (rd), (rs))
#define jit_ldr_uc(rd, rs) jit_ldxr_uc((rd), 0, (rs))
#define jit_ldr_us(rd, rs) jit_ldxr_us((rd), 0, (rs))
/* e.g.
* 0x01234567 _HA << 16 = 0x01230000 _LA = 0x00004567 _HA << 16 + LA = 0x01234567
* 0x89abcdef _HA << 16 = 0x89ac0000 _LA = 0xffffcdef _HA << 16 + LA = 0x89abcdef
*/
#define _HA(addr) ((_jit_UL(addr) >> 16) + (_jit_US(_jit_UL(addr)) >> 15))
#define _LA(addr) (_jit_UL(addr) - (_HA(addr) << 16))
#define jit_ldi_c(rd, is) (LISri(JIT_AUX, _HA(is)), jit_ldxi_c((rd), JIT_AUX, _LA(is)))
#define jit_sti_c(id, rs) (LISri(JIT_AUX, _HA(id)), jit_stxi_c(_LA(id), JIT_AUX, (rs)))
#define jit_ldi_s(rd, is) (LISri(JIT_AUX, _HA(is)), jit_ldxi_s((rd), JIT_AUX, _LA(is)))
#define jit_sti_s(id, rs) (LISri(JIT_AUX, _HA(id)), jit_stxi_s(_LA(id), JIT_AUX, (rs)))
#define jit_ldi_i(rd, is) (LISri(JIT_AUX, _HA(is)), jit_ldxi_i((rd), JIT_AUX, _LA(is)))
#define jit_sti_i(id, rs) (LISri(JIT_AUX, _HA(id)), jit_stxi_i(_LA(id), JIT_AUX, (rs)))
#define jit_ldi_uc(rd, is) (LISri(JIT_AUX, _HA(is)), jit_ldxi_uc((rd), JIT_AUX, _LA(is)))
#define jit_ldi_us(rd, is) (LISri(JIT_AUX, _HA(is)), jit_ldxi_us((rd), JIT_AUX, _LA(is)))
#endif /* __lightning_core_h */

86
src/mzscheme/src/lightning/ppc/fp-common.h Normal file
View File

@ -0,0 +1,86 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer floating-point interface
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#define JIT_FPR0 JIT_FPR(0)
#define JIT_FPR1 JIT_FPR(1)
#define JIT_FPR2 JIT_FPR(2)
#define JIT_FPR3 JIT_FPR(3)
#define JIT_FPR4 JIT_FPR(4)
#define JIT_FPR5 JIT_FPR(5)
#ifdef JIT_RZERO
#ifndef jit_ldi_f
#define jit_ldi_f(rd, is) jit_ldxi_f((rd), JIT_RZERO, (is))
#define jit_sti_f(id, rs) jit_stxi_f((id), JIT_RZERO, (rs))
#define jit_ldi_d(rd, is) jit_ldxi_d((rd), JIT_RZERO, (is))
#define jit_sti_d(id, rs) jit_stxi_d((id), JIT_RZERO, (rs))
#endif
#ifndef jit_ldr_f
#define jit_ldr_f(rd, rs) jit_ldxr_f((rd), JIT_RZERO, (rs))
#define jit_str_f(rd, rs) jit_stxr_f((rd), JIT_RZERO, (rs))
#define jit_ldr_d(rd, rs) jit_ldxr_d((rd), JIT_RZERO, (rs))
#define jit_str_d(rd, rs) jit_stxr_d((rd), JIT_RZERO, (rs))
#endif
#endif
#ifndef jit_addr_f
#define jit_addr_f(rd,s1,s2) jit_addr_d(rd,s1,s2)
#define jit_subr_f(rd,s1,s2) jit_subr_d(rd,s1,s2)
#define jit_mulr_f(rd,s1,s2) jit_mulr_d(rd,s1,s2)
#define jit_divr_f(rd,s1,s2) jit_divr_d(rd,s1,s2)
#define jit_movr_f(rd,rs) jit_movr_d(rd,rs)
#define jit_abs_f(rd,rs) jit_abs_d(rd,rs)
#define jit_negr_f(rd,rs) jit_negr_d(rd,rs)
#define jit_sqrt_f(rd,rs) jit_sqrt_d(rd,rs)
#define jit_extr_f_d(rs, rd)
#define jit_extr_d_f(rs, rd)
#define jit_extr_i_f(rd, rs) jit_extr_i_d(rd, rs)
#define jit_roundr_f_i(rd, rs) jit_roundr_d_i(rd, rs)
#define jit_floorr_f_i(rd, rs) jit_floorr_d_i(rd, rs)
#define jit_ceilr_f_i(rd, rs) jit_ceilr_d_i(rd, rs)
#define jit_truncr_f_i(rd, rs) jit_truncr_d_i(rd, rs)
#define jit_ltr_f(d, s1, s2) jit_ltr_d(d, s1, s2)
#define jit_ler_f(d, s1, s2) jit_ler_d(d, s1, s2)
#define jit_eqr_f(d, s1, s2) jit_eqr_d(d, s1, s2)
#define jit_ner_f(d, s1, s2) jit_ner_d(d, s1, s2)
#define jit_ger_f(d, s1, s2) jit_ger_d(d, s1, s2)
#define jit_gtr_f(d, s1, s2) jit_gtr_d(d, s1, s2)
#define jit_unltr_f(d, s1, s2) jit_unltr_d(d, s1, s2)
#define jit_unler_f(d, s1, s2) jit_unler_d(d, s1, s2)
#define jit_uneqr_f(d, s1, s2) jit_uneqr_d(d, s1, s2)
#define jit_ltgtr_f(d, s1, s2) jit_ltgtr_d(d, s1, s2)
#define jit_unger_f(d, s1, s2) jit_unger_d(d, s1, s2)
#define jit_ungtr_f(d, s1, s2) jit_ungtr_d(d, s1, s2)
#define jit_ordr_f(d, s1, s2) jit_ordr_d(d, s1, s2)
#define jit_unordr_f(d, s1, s2) jit_unordr_d(d, s1, s2)
#define jit_retval_f(rs) jit_retval_d(rs)
#endif

211
src/mzscheme/src/lightning/ppc/fp.h Normal file
View File

@ -0,0 +1,211 @@
/******************************** -*- C -*- ****************************
*
* Run-time assembler & support macros for the Sparc math unit
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_asm_fp_h
#define __lightning_asm_fp_h
#define JIT_FPR_NUM 6
#define JIT_FPR(i) (8+(i))
#define JIT_FPFR 0
/* Make space for 1 or 2 words, store address in REG */
#define jit_data(REG, D1) (_FBA (18, 8, 0, 1), _jit_L(D1), MFLRr(REG))
#define jit_addr_d(rd,s1,s2) FADDDrrr((rd),(s1),(s2))
#define jit_subr_d(rd,s1,s2) FSUBDrrr((rd),(s1),(s2))
#define jit_mulr_d(rd,s1,s2) FMULDrrr((rd),(s1),(s2))
#define jit_divr_d(rd,s1,s2) FDIVDrrr((rd),(s1),(s2))
#define jit_addr_f(rd,s1,s2) FADDSrrr((rd),(s1),(s2))
#define jit_subr_f(rd,s1,s2) FSUBSrrr((rd),(s1),(s2))
#define jit_mulr_f(rd,s1,s2) FMULSrrr((rd),(s1),(s2))
#define jit_divr_f(rd,s1,s2) FDIVSrrr((rd),(s1),(s2))
#define jit_movr_d(rd,rs) ( (rd) == (rs) ? 0 : FMOVErr((rd),(rs)))
#define jit_movi_d(reg0,d) do { \
double _v = (d); \
_FBA (18, 12, 0, 1); \
memcpy(_jit.x.uc_pc, &_v, sizeof (double)); \
_jit.x.uc_pc += sizeof (double); \
MFLRr (JIT_AUX); \
jit_ldxi_d((reg0), JIT_AUX, 0); \
} while(0)
#define jit_movr_f(rd,rs) ( (rd) == (rs) ? 0 : FMOVErr((rd),(rs)))
#define jit_movi_f(reg0,f) do { \
float _v = (f); \
_FBA (18, 8, 0, 1); \
memcpy(_jit.x.uc_pc, &_v, sizeof (float)); \
_jit.x.uc_pc += sizeof (float); \
MFLRr (JIT_AUX); \
jit_ldxi_f((reg0), JIT_AUX, 0); \
} while(0)
#define jit_abs_d(rd,rs) FABSrr((rd),(rs))
#define jit_negr_d(rd,rs) FNEGrr((rd),(rs))
#define jit_sqrt_d(rd,rs) FSQRTDrr((rd),(rs))
#define jit_ldxi_f(reg0, rs, is) (_siP(16,(is)) ? LFSrri((reg0),(rs),(is)) : (MOVEIri(JIT_AUX,(is)),LFSxrrr((reg0),(rs),JIT_AUX)))
#define jit_ldxi_d(reg0, rs, is) (_siP(16,(is)) ? LFDrri((reg0),(rs),(is)) : (MOVEIri(JIT_AUX,(is)),LFDxrrr((reg0),(rs),JIT_AUX)))
#define jit_ldxr_f(reg0, s1, s2) LFSxrrr((reg0),(s1),(s2))
#define jit_ldxr_d(reg0, s1, s2) LFDxrrr((reg0),(s1),(s2))
#define jit_ldi_f(reg0, is) (_siP(16,(is)) ? LFSrri((reg0),0,(is)) : (MOVEIri(JIT_AUX,(is)),LFSrri((reg0),JIT_AUX,0)))
#define jit_ldi_d(reg0, is) (_siP(16,(is)) ? LFDrri((reg0),0,(is)) : (MOVEIri(JIT_AUX,(is)),LFDrri((reg0),JIT_AUX,0)))
#define jit_ldr_f(reg0, rs) LFSrri((reg0),(rs),0)
#define jit_ldr_d(reg0, rs) LFDrri((reg0),(rs),0)
#define jit_stxi_f(id, rd, reg0) (_siP(16,(id)) ? STFSrri((reg0),(rd),(id)) : (MOVEIri(JIT_AUX,(id)),STFSrri((reg0),(rd),JIT_AUX)))
#define jit_stxi_d(id, rd, reg0) (_siP(16,(id)) ? STFDrri((reg0),(rd),(id)) : (MOVEIri(JIT_AUX,(id)),STFDrri((reg0),(rd),JIT_AUX)))
#define jit_stxr_f(d1, d2, reg0) STFSxrrr((reg0),(d1),(d2))
#define jit_stxr_d(d1, d2, reg0) STFDxrrr((reg0),(d1),(d2))
#define jit_sti_f(id, reg0) (_siP(16,(id)) ? STFSrri((reg0),0,(id)) : (MOVEIri(JIT_AUX,(id)),STFSrri((reg0),JIT_AUX,0)))
#define jit_sti_d(id, reg0) (_siP(16,(id)) ? STFDrri((reg0),0,(id)) : (MOVEIri(JIT_AUX,(id)),STFDrri((reg0),JIT_AUX,0)))
#define jit_str_f(rd, reg0) STFSrri((reg0),(rd),0)
#define jit_str_d(rd, reg0) STFDrri((reg0),(rd),0)
#define jit_fpboolr(d, s1, s2, rcbit) ( \
FCMPOrrr(_cr0,(s1),(s2)), \
MFCRr((d)), \
EXTRWIrrii((d), (d), 1, (rcbit)))
#define jit_fpboolr_neg(d, s1, s2,rcbit) ( \
FCMPOrrr(_cr0,(s1),(s2)), \
MFCRr((d)), \
EXTRWIrrii((d), (d), 1, (rcbit)), \
XORIrri((d), (d), 1))
#define jit_fpboolur(d, s1, s2, rcbit) ( \
FCMPUrrr(_cr0,(s1),(s2)), \
MFCRr((d)), \
EXTRWIrrii((d), (d), 1, (rcbit)))
#define jit_fpboolur_neg(d, s1, s2,rcbit) ( \
FCMPUrrr(_cr0,(s1),(s2)), \
MFCRr((d)), \
EXTRWIrrii((d), (d), 1, (rcbit)), \
XORIrri((d), (d), 1))
#define jit_fpboolur_or(d, s1, s2, bit1, bit2) (\
FCMPUrrr(_cr0,(s1),(s2)), \
CRORiii((bit1), (bit1), (bit2)), \
MFCRr((d)), \
EXTRWIrrii((d), (d), 1, (bit1)))
#define jit_gtr_d(d, s1, s2) jit_fpboolr ((d),(s1),(s2),_gt)
#define jit_ger_d(d, s1, s2) jit_fpboolr_neg((d),(s1),(s2),_lt)
#define jit_ltr_d(d, s1, s2) jit_fpboolr ((d),(s1),(s2),_lt)
#define jit_ler_d(d, s1, s2) jit_fpboolr_neg((d),(s1),(s2),_gt)
#define jit_eqr_d(d, s1, s2) jit_fpboolr ((d),(s1),(s2),_eq)
#define jit_ner_d(d, s1, s2) jit_fpboolr_neg((d),(s1),(s2),_eq)
#define jit_unordr_d(d, s1, s2) jit_fpboolur ((d),(s1),(s2),_un)
#define jit_ordr_d(d, s1, s2) jit_fpboolur_neg((d),(s1),(s2),_un)
#define jit_unler_d(d, s1, s2) jit_fpboolur_neg ((d), (s1), (s2), _gt)
#define jit_unltr_d(d, s1, s2) jit_fpboolur_or ((d), (s1), (s2), _un, _lt)
#define jit_unger_d(d, s1, s2) jit_fpboolur_neg ((d), (s1), (s2), _lt)
#define jit_ungtr_d(d, s1, s2) jit_fpboolur_or ((d), (s1), (s2), _un, _gt)
#define jit_ltgtr_d(d, s1, s2) jit_fpboolur_or ((d), (s1), (s2), _gt, _lt)
#define jit_uneqr_d(d, s1, s2) jit_fpboolur_or ((d), (s1), (s2), _un, _eq)
#define jit_fpbr(d, s1, s2, rcbit) ( \
FCMPOrrr(_cr0,(s1),(s2)), \
BTii ((rcbit), (d)))
#define jit_fpbr_neg(d, s1, s2,rcbit) ( \
FCMPOrrr(_cr0,(s1),(s2)), \
BFii ((rcbit), (d)))
#define jit_fpbur(d, s1, s2, rcbit) ( \
FCMPUrrr(_cr0,(s1),(s2)), \
BTii ((rcbit), (d)))
#define jit_fpbur_neg(d, s1, s2,rcbit) ( \
FCMPUrrr(_cr0,(s1),(s2)), \
BFii ((rcbit), (d)))
#define jit_fpbur_or(d, s1, s2, bit1, bit2) ( \
FCMPUrrr(_cr0,(s1),(s2)), \
CRORiii((bit1), (bit1), (bit2)), \
BTii ((bit1), (d)))
#define jit_bgtr_d(d, s1, s2) jit_fpbr ((d),(s1),(s2),_gt)
#define jit_bger_d(d, s1, s2) jit_fpbr_neg((d),(s1),(s2),_lt)
#define jit_bltr_d(d, s1, s2) jit_fpbr ((d),(s1),(s2),_lt)
#define jit_bler_d(d, s1, s2) jit_fpbr_neg((d),(s1),(s2),_gt)
#define jit_beqr_d(d, s1, s2) jit_fpbr ((d),(s1),(s2),_eq)
#define jit_bner_d(d, s1, s2) jit_fpbr_neg((d),(s1),(s2),_eq)
#define jit_bunordr_d(d, s1, s2) jit_fpbur ((d),(s1),(s2),_un)
#define jit_bordr_d(d, s1, s2) jit_fpbur_neg((d),(s1),(s2),_un)
#define jit_bunler_d(d, s1, s2) jit_fpbur_neg ((d), (s1), (s2), _gt)
#define jit_bunltr_d(d, s1, s2) jit_fpbur_or ((d), (s1), (s2), _un, _lt)
#define jit_bunger_d(d, s1, s2) jit_fpbur_neg ((d), (s1), (s2), _lt)
#define jit_bungtr_d(d, s1, s2) jit_fpbur_or ((d), (s1), (s2), _un, _gt)
#define jit_bltgtr_d(d, s1, s2) jit_fpbur_or ((d), (s1), (s2), _gt, _lt)
#define jit_buneqr_d(d, s1, s2) jit_fpbur_or ((d), (s1), (s2), _un, _eq)
#define jit_getarg_f(rd, ofs) jit_movr_f((rd),(ofs))
#define jit_getarg_d(rd, ofs) jit_movr_d((rd),(ofs))
#define jit_pusharg_d(rs) (_jitl.nextarg_putd--,jit_movr_d((_jitl.nextarg_putf+_jitl.nextarg_putd+1), (rs)))
#define jit_pusharg_f(rs) (_jitl.nextarg_putf--,jit_movr_f((_jitl.nextarg_putf+_jitl.nextarg_putd+1), (rs)))
#define jit_retval_d(op1) jit_movr_d(1, (op1))
#define jit_retval_f(op1) jit_movr_f(1, (op1))
#define jit_floorr_d_i(rd,rs) (MTFSFIri(7,3), \
FCTIWrr(7,(rs)), \
MOVEIri(JIT_AUX,-4), \
STFIWXrrr(7,JIT_SP,JIT_AUX), \
LWZrm((rd),-4,JIT_SP))
#define jit_ceilr_d_i(rd,rs) (MTFSFIri(7,2), \
FCTIWrr(7,(rs)), \
MOVEIri(JIT_AUX,-4), \
STFIWXrrr(7,JIT_SP,JIT_AUX), \
LWZrm((rd),-4,JIT_SP))
#define jit_roundr_d_i(rd,rs) (MTFSFIri(7,0), \
FCTIWrr(7,(rs)), \
MOVEIri(JIT_AUX,-4), \
STFIWXrrr(7,JIT_SP,JIT_AUX), \
LWZrm((rd),-4,JIT_SP))
#define jit_truncr_d_i(rd,rs) (FCTIWZrr(7,(rs)), \
MOVEIri(JIT_AUX,-4), \
STFIWXrrr(7,JIT_SP,JIT_AUX), \
LWZrm((rd),-4,JIT_SP))
#endif /* __lightning_asm_h */

54
src/mzscheme/src/lightning/ppc/funcs-common.h Normal file
View File

@ -0,0 +1,54 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer inline functions (common part)
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_funcs_common_h
#define __lightning_funcs_common_h
#include <stdio.h>
#include <stdlib.h>
static int jit_fail(const char *, const char*, int, const char *) JIT_UNUSED;
int
jit_fail(const char *msg, const char *file, int line, const char *function)
{
fprintf(stderr, "%s: In function `%s':\n", file, function);
fprintf(stderr, "%s:%d: %s\n", file, line, msg);
abort();
}
#ifndef jit_start_pfx
#define jit_start_pfx() ( (jit_insn*)0x4)
#define jit_end_pfx() ( (jit_insn*)0x0)
#endif
#endif /* __lightning_funcs_common_h */

168
src/mzscheme/src/lightning/ppc/funcs.h Normal file
View File

@ -0,0 +1,168 @@
/******************************** -*- C -*- ****************************
*
* Platform-independent layer inline functions (PowerPC)
*
***********************************************************************/
/***********************************************************************
*
* Copyright 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
* Written by Paolo Bonzini.
*
* This file is part of GNU lightning.
*
* GNU lightning is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; either version 2.1, or (at your option)
* any later version.
*
* GNU lightning is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with GNU lightning; see the file COPYING.LESSER; if not, write to the
* Free Software Foundation, 59 Temple Place - Suite 330, Boston,
* MA 02111-1307, USA.
*
***********************************************************************/
#ifndef __lightning_funcs_h
#define __lightning_funcs_h
#if !defined(__GNUC__) && !defined(__GNUG__)
#error Go get GNU C, I do not know how to flush the cache
#error with this compiler.
#else
static void
jit_flush_code(void *start, void *end)
{
#ifndef LIGHTNING_CROSS
register char *ddest, *idest;
static int cache_line_size;
if (cache_line_size == 0) {
char buffer[8192];
int i, probe;
/* Find out the size of a cache line by zeroing one */
memset(buffer, 0xFF, 8192);
__asm__ __volatile__ ("dcbz 0,%0" : : "r"(buffer + 4096));
/* Probe for the beginning of the cache line. */
for(i = 0, probe = 4096; probe; probe >>= 1)
if (buffer[i | probe] != 0x00)
i |= probe;
/* i is now just before the start of the cache line */
i++;
for(cache_line_size = 1; i + cache_line_size < 8192; cache_line_size <<= 1)
if (buffer[i + cache_line_size] != 0x00)
break;
}
start -= ((long) start) & (cache_line_size - 1);
end -= ((long) end) & (cache_line_size - 1);
/* Force data cache write-backs */
for (ddest = (char *) start; ddest <= (char *) end; ddest += cache_line_size) {
__asm__ __volatile__ ("dcbst 0,%0" : : "r"(ddest));
}
__asm__ __volatile__ ("sync" : : );
/* Now invalidate the instruction cache */
for (idest = (char *) start; idest <= (char *) end; idest += cache_line_size) {
__asm__ __volatile__ ("icbi 0,%0" : : "r"(idest));
}
__asm__ __volatile__ ("isync" : : );
#endif /* !LIGHTNING_CROSS */
}
#endif /* __GNUC__ || __GNUG__ */
#define _jit (*jit)
static void
_jit_epilog(jit_state *jit)
{
int n = _jitl.nbArgs;
int frame_size, ofs;
int first_saved_reg = JIT_AUX - n;
int num_saved_regs = 32 - first_saved_reg;
frame_size = 24 + 32 + 12 + num_saved_regs * 4; /* r24..r31 + args */
frame_size += 15; /* the stack must be quad-word */
frame_size &= ~15; /* aligned */
#ifdef _CALL_DARWIN
LWZrm(0, frame_size + 8, 1); /* lwz r0, x+8(r1) (ret.addr.) */
#else
LWZrm(0, frame_size + 4, 1); /* lwz r0, x+4(r1) (ret.addr.) */
#endif
MTLRr(0); /* mtspr LR, r0 */
ofs = frame_size - num_saved_regs * 4;
LMWrm(first_saved_reg, ofs, 1); /* lmw rI, ofs(r1) */
ADDIrri(1, 1, frame_size); /* addi r1, r1, x */
BLR(); /* blr */
}
/* Emit a prolog for a function.
Upon entrance to the trampoline:
- LR = address where the real code for the function lies
- R3-R8 = parameters
Upon finishing the trampoline:
- R0 = return address for the function
- R25-R20 = parameters (order is reversed, 1st argument is R25)
The +32 in frame_size computation is to accound for the parameter area of
a function frame. The +12 is to make room for two local variables (a
MzScheme-specific change).
On PPC the frame must have space to host the arguments of any callee.
However, as it currently stands, the argument to jit_trampoline (n) is
the number of arguments of the caller we generate. Therefore, the
callee can overwrite a part of the stack (saved register area when it
flushes its own parameter on the stack). The addition of a constant
offset = 32 is enough to hold eight 4 bytes arguments. This is less
than perfect but is a reasonable work around for now.
Better solution must be investigated. */
static void
_jit_prolog(jit_state *jit, int n)
{
int frame_size;
int ofs;
int first_saved_reg = JIT_AUX - n;
int num_saved_regs = 32 - first_saved_reg;
_jitl.nextarg_geti = 3;
_jitl.nextarg_getd = 1;
_jitl.nbArgs = n;
frame_size = 24 + 32 + 12 + num_saved_regs * 4; /* r27..r31 + args */
frame_size += 15; /* the stack must be quad-word */
frame_size &= ~15; /* aligned */
MFLRr(0);
STWUrm(1, -frame_size, 1); /* stwu r1, -x(r1) */
ofs = frame_size - num_saved_regs * 4;
STMWrm(first_saved_reg, ofs, 1); /* stmw rI, ofs(r1) */
#ifdef _CALL_DARWIN
STWrm(0, frame_size + 8, 1); /* stw r0, x+8(r1) */
#else
STWrm(0, frame_size + 4, 1); /* stw r0, x+4(r1) */
#endif
#if 0
for (i = 0; i < n; i++)
MRrr(JIT_AUX-1-i, 3+i); /* save parameters below r24 */
#endif
}
#undef _jit
#endif /* __lightning_funcs_h */

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

@ -26,6 +26,10 @@
/* globals */
Scheme_Object scheme_null[1];
Scheme_Object *scheme_null_p_prim;
Scheme_Object *scheme_pair_p_prim;
Scheme_Object *scheme_car_prim;
Scheme_Object *scheme_cdr_prim;
/* locals */
static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]);
@ -122,74 +126,72 @@ static Scheme_Object *weak_symbol, *equal_symbol;
void
scheme_init_list (Scheme_Env *env)
{
REGISTER_SO(scheme_null_p_prim);
REGISTER_SO(scheme_pair_p_prim);
REGISTER_SO(scheme_car_prim);
REGISTER_SO(scheme_cdr_prim);
scheme_null->type = scheme_null_type;
scheme_add_global_constant ("null", scheme_null, env);
scheme_add_global_constant ("pair?",
scheme_make_folding_prim(pair_p_prim,
"pair?",
1, 1, 1),
env);
scheme_pair_p_prim = scheme_make_folding_prim(pair_p_prim, "pair?", 1, 1, 1);
scheme_add_global_constant ("pair?", scheme_pair_p_prim, env);
scheme_add_global_constant ("cons",
scheme_make_prim_w_arity(cons_prim,
"cons",
2, 2),
env);
scheme_add_global_constant ("car",
scheme_make_prim_w_arity(car_prim,
"car",
1, 1),
env);
scheme_add_global_constant ("cdr",
scheme_make_prim_w_arity(cdr_prim,
"cdr",
1, 1),
env);
scheme_car_prim = scheme_make_noncm_prim(car_prim, "car", 1, 1);
scheme_add_global_constant ("car", scheme_car_prim, env);
scheme_cdr_prim = scheme_make_noncm_prim(cdr_prim, "cdr", 1, 1);
scheme_add_global_constant ("cdr", scheme_cdr_prim, env);
scheme_add_global_constant ("set-car!",
scheme_make_prim_w_arity(set_car_prim,
"set-car!",
2, 2),
scheme_make_noncm_prim(set_car_prim,
"set-car!",
2, 2),
env);
scheme_add_global_constant ("set-cdr!",
scheme_make_prim_w_arity(set_cdr_prim,
"set-cdr!",
2, 2),
scheme_make_noncm_prim(set_cdr_prim,
"set-cdr!",
2, 2),
env);
scheme_add_global_constant ("cons-immutable",
scheme_make_prim_w_arity(cons_immutable,
"cons-immutable",
2, 2),
env);
scheme_add_global_constant ("null?",
scheme_make_folding_prim(null_p_prim,
"null?",
1, 1, 1),
scheme_make_noncm_prim(cons_immutable,
"cons-immutable",
2, 2),
env);
scheme_null_p_prim = scheme_make_folding_prim(null_p_prim, "null?", 1, 1, 1);
scheme_add_global_constant ("null?", scheme_null_p_prim, env);
scheme_add_global_constant ("list?",
scheme_make_prim_w_arity(list_p_prim,
"list?",
1, 1),
scheme_make_noncm_prim(list_p_prim,
"list?",
1, 1),
env);
scheme_add_global_constant ("list",
scheme_make_prim_w_arity(list_prim,
"list",
0, -1),
scheme_make_noncm_prim(list_prim,
"list",
0, -1),
env);
scheme_add_global_constant ("list-immutable",
scheme_make_prim_w_arity(list_immutable_prim,
"list-immutable",
0, -1),
scheme_make_noncm_prim(list_immutable_prim,
"list-immutable",
0, -1),
env);
scheme_add_global_constant ("list*",
scheme_make_prim_w_arity(list_star_prim,
"list*",
1, -1),
scheme_make_noncm_prim(list_star_prim,
"list*",
1, -1),
env);
scheme_add_global_constant ("list*-immutable",
scheme_make_prim_w_arity(list_star_immutable_prim,
"list*-immutable",
1, -1),
scheme_make_noncm_prim(list_star_immutable_prim,
"list*-immutable",
1, -1),
env);
scheme_add_global_constant("immutable?",
scheme_make_folding_prim(immutablep,
@ -197,221 +199,221 @@ scheme_init_list (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant ("length",
scheme_make_prim_w_arity(length_prim,
"length",
1, 1),
scheme_make_noncm_prim(length_prim,
"length",
1, 1),
env);
scheme_add_global_constant ("append",
scheme_make_prim_w_arity(append_prim,
"append",
0, -1),
scheme_make_noncm_prim(append_prim,
"append",
0, -1),
env);
scheme_add_global_constant ("append!",
scheme_make_prim_w_arity(append_bang_prim,
"append!",
0, -1),
scheme_make_noncm_prim(append_bang_prim,
"append!",
0, -1),
env);
scheme_add_global_constant ("reverse",
scheme_make_prim_w_arity(reverse_prim,
"reverse",
1, 1),
scheme_make_noncm_prim(reverse_prim,
"reverse",
1, 1),
env);
scheme_add_global_constant ("reverse!",
scheme_make_prim_w_arity(reverse_bang_prim,
"reverse!",
1, 1),
scheme_make_noncm_prim(reverse_bang_prim,
"reverse!",
1, 1),
env);
scheme_add_global_constant ("list-tail",
scheme_make_prim_w_arity(list_tail_prim,
"list-tail",
2, 2),
scheme_make_noncm_prim(list_tail_prim,
"list-tail",
2, 2),
env);
scheme_add_global_constant ("list-ref",
scheme_make_prim_w_arity(list_ref_prim,
"list-ref",
2, 2),
scheme_make_noncm_prim(list_ref_prim,
"list-ref",
2, 2),
env);
scheme_add_global_constant ("memq",
scheme_make_prim_w_arity(memq,
"memq",
2, 2),
scheme_make_noncm_prim(memq,
"memq",
2, 2),
env);
scheme_add_global_constant ("memv",
scheme_make_prim_w_arity(memv,
"memv",
2, 2),
scheme_make_noncm_prim(memv,
"memv",
2, 2),
env);
scheme_add_global_constant ("member",
scheme_make_prim_w_arity(member,
"member",
2, 2),
scheme_make_noncm_prim(member,
"member",
2, 2),
env);
scheme_add_global_constant ("assq",
scheme_make_prim_w_arity(assq,
"assq",
2, 2),
scheme_make_noncm_prim(assq,
"assq",
2, 2),
env);
scheme_add_global_constant ("assv",
scheme_make_prim_w_arity(assv,
"assv",
2, 2),
scheme_make_noncm_prim(assv,
"assv",
2, 2),
env);
scheme_add_global_constant ("assoc",
scheme_make_prim_w_arity(assoc,
"assoc",
2, 2),
scheme_make_noncm_prim(assoc,
"assoc",
2, 2),
env);
scheme_add_global_constant ("caar",
scheme_make_prim_w_arity(caar_prim,
"caar",
1, 1),
scheme_make_noncm_prim(caar_prim,
"caar",
1, 1),
env);
scheme_add_global_constant ("cadr",
scheme_make_prim_w_arity(cadr_prim,
"cadr",
1, 1),
scheme_make_noncm_prim(cadr_prim,
"cadr",
1, 1),
env);
scheme_add_global_constant ("cdar",
scheme_make_prim_w_arity(cdar_prim,
"cdar",
1, 1),
scheme_make_noncm_prim(cdar_prim,
"cdar",
1, 1),
env);
scheme_add_global_constant ("cddr",
scheme_make_prim_w_arity(cddr_prim,
"cddr",
1, 1),
scheme_make_noncm_prim(cddr_prim,
"cddr",
1, 1),
env);
scheme_add_global_constant ("caaar",
scheme_make_prim_w_arity(caaar_prim,
"caaar",
1, 1),
scheme_make_noncm_prim(caaar_prim,
"caaar",
1, 1),
env);
scheme_add_global_constant ("caadr",
scheme_make_prim_w_arity(caadr_prim,
"caadr",
1, 1),
scheme_make_noncm_prim(caadr_prim,
"caadr",
1, 1),
env);
scheme_add_global_constant ("cadar",
scheme_make_prim_w_arity(cadar_prim,
"cadar",
1, 1),
scheme_make_noncm_prim(cadar_prim,
"cadar",
1, 1),
env);
scheme_add_global_constant ("cdaar",
scheme_make_prim_w_arity(cdaar_prim,
"cdaar",
1, 1),
scheme_make_noncm_prim(cdaar_prim,
"cdaar",
1, 1),
env);
scheme_add_global_constant ("cdadr",
scheme_make_prim_w_arity(cdadr_prim,
"cdadr",
1, 1),
scheme_make_noncm_prim(cdadr_prim,
"cdadr",
1, 1),
env);
scheme_add_global_constant ("cddar",
scheme_make_prim_w_arity(cddar_prim,
"cddar",
1, 1),
scheme_make_noncm_prim(cddar_prim,
"cddar",
1, 1),
env);
scheme_add_global_constant ("caddr",
scheme_make_prim_w_arity(caddr_prim,
"caddr",
1, 1),
scheme_make_noncm_prim(caddr_prim,
"caddr",
1, 1),
env);
scheme_add_global_constant ("cdddr",
scheme_make_prim_w_arity(cdddr_prim,
"cdddr",
1, 1),
scheme_make_noncm_prim(cdddr_prim,
"cdddr",
1, 1),
env);
scheme_add_global_constant ("cddddr",
scheme_make_prim_w_arity(cddddr_prim,
"cddddr",
1, 1),
scheme_make_noncm_prim(cddddr_prim,
"cddddr",
1, 1),
env);
scheme_add_global_constant ("cadddr",
scheme_make_prim_w_arity(cadddr_prim,
"cadddr",
1, 1),
scheme_make_noncm_prim(cadddr_prim,
"cadddr",
1, 1),
env);
scheme_add_global_constant ("cdaddr",
scheme_make_prim_w_arity(cdaddr_prim,
"cdaddr",
1, 1),
scheme_make_noncm_prim(cdaddr_prim,
"cdaddr",
1, 1),
env);
scheme_add_global_constant ("cddadr",
scheme_make_prim_w_arity(cddadr_prim,
"cddadr",
1, 1),
scheme_make_noncm_prim(cddadr_prim,
"cddadr",
1, 1),
env);
scheme_add_global_constant ("cdddar",
scheme_make_prim_w_arity(cdddar_prim,
"cdddar",
1, 1),
scheme_make_noncm_prim(cdddar_prim,
"cdddar",
1, 1),
env);
scheme_add_global_constant ("caaddr",
scheme_make_prim_w_arity(caaddr_prim,
"caaddr",
1, 1),
scheme_make_noncm_prim(caaddr_prim,
"caaddr",
1, 1),
env);
scheme_add_global_constant ("cadadr",
scheme_make_prim_w_arity(cadadr_prim,
"cadadr",
1, 1),
scheme_make_noncm_prim(cadadr_prim,
"cadadr",
1, 1),
env);
scheme_add_global_constant ("caddar",
scheme_make_prim_w_arity(caddar_prim,
"caddar",
1, 1),
scheme_make_noncm_prim(caddar_prim,
"caddar",
1, 1),
env);
scheme_add_global_constant ("cdaadr",
scheme_make_prim_w_arity(cdaadr_prim,
"cdaadr",
1, 1),
scheme_make_noncm_prim(cdaadr_prim,
"cdaadr",
1, 1),
env);
scheme_add_global_constant ("cdadar",
scheme_make_prim_w_arity(cdadar_prim,
"cdadar",
1, 1),
scheme_make_noncm_prim(cdadar_prim,
"cdadar",
1, 1),
env);
scheme_add_global_constant ("cddaar",
scheme_make_prim_w_arity(cddaar_prim,
"cddaar",
1, 1),
scheme_make_noncm_prim(cddaar_prim,
"cddaar",
1, 1),
env);
scheme_add_global_constant ("cdaaar",
scheme_make_prim_w_arity(cdaaar_prim,
"cdaaar",
1, 1),
scheme_make_noncm_prim(cdaaar_prim,
"cdaaar",
1, 1),
env);
scheme_add_global_constant ("cadaar",
scheme_make_prim_w_arity(cadaar_prim,
"cadaar",
1, 1),
scheme_make_noncm_prim(cadaar_prim,
"cadaar",
1, 1),
env);
scheme_add_global_constant ("caadar",
scheme_make_prim_w_arity(caadar_prim,
"caadar",
1, 1),
scheme_make_noncm_prim(caadar_prim,
"caadar",
1, 1),
env);
scheme_add_global_constant ("caaadr",
scheme_make_prim_w_arity(caaadr_prim,
"caaadr",
1, 1),
scheme_make_noncm_prim(caaadr_prim,
"caaadr",
1, 1),
env);
scheme_add_global_constant ("caaaar",
scheme_make_prim_w_arity(caaaar_prim,
"caaaar",
1, 1),
scheme_make_noncm_prim(caaaar_prim,
"caaaar",
1, 1),
env);
scheme_add_global_constant(BOX,
scheme_make_prim_w_arity(box,
BOX,
1, 1),
scheme_make_noncm_prim(box,
BOX,
1, 1),
env);
scheme_add_global_constant("box-immutable",
scheme_make_prim_w_arity(immutable_box,
"box-immutable",
1, 1),
scheme_make_noncm_prim(immutable_box,
"box-immutable",
1, 1),
env);
scheme_add_global_constant(BOXP,
scheme_make_folding_prim(box_p,
@ -419,25 +421,25 @@ scheme_init_list (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant(UNBOX,
scheme_make_prim_w_arity(unbox,
UNBOX,
1, 1),
scheme_make_noncm_prim(unbox,
UNBOX,
1, 1),
env);
scheme_add_global_constant(SETBOX,
scheme_make_prim_w_arity(set_box,
SETBOX,
2, 2),
scheme_make_noncm_prim(set_box,
SETBOX,
2, 2),
env);
scheme_add_global_constant("make-hash-table",
scheme_make_prim_w_arity(make_hash_table,
"make-hash-table",
0, 2),
scheme_make_noncm_prim(make_hash_table,
"make-hash-table",
0, 2),
env);
scheme_add_global_constant("make-immutable-hash-table",
scheme_make_prim_w_arity(make_immutable_hash_table,
"make-immutable-hash-table",
1, 2),
scheme_make_noncm_prim(make_immutable_hash_table,
"make-immutable-hash-table",
1, 2),
env);
scheme_add_global_constant("hash-table?",
scheme_make_folding_prim(hash_table_p,
@ -445,19 +447,19 @@ scheme_init_list (Scheme_Env *env)
1, 3, 1),
env);
scheme_add_global_constant("hash-table-count",
scheme_make_prim_w_arity(hash_table_count,
"hash-table-count",
1, 1),
scheme_make_noncm_prim(hash_table_count,
"hash-table-count",
1, 1),
env);
scheme_add_global_constant("hash-table-copy",
scheme_make_prim_w_arity(hash_table_copy,
"hash-table-copy",
1, 1),
scheme_make_noncm_prim(hash_table_copy,
"hash-table-copy",
1, 1),
env);
scheme_add_global_constant("hash-table-put!",
scheme_make_prim_w_arity(hash_table_put,
"hash-table-put!",
3, 3),
scheme_make_noncm_prim(hash_table_put,
"hash-table-put!",
3, 3),
env);
scheme_add_global_constant("hash-table-get",
scheme_make_prim_w_arity(hash_table_get,
@ -465,41 +467,41 @@ scheme_init_list (Scheme_Env *env)
2, 3),
env);
scheme_add_global_constant("hash-table-remove!",
scheme_make_prim_w_arity(hash_table_remove,
"hash-table-remove!",
2, 2),
scheme_make_noncm_prim(hash_table_remove,
"hash-table-remove!",
2, 2),
env);
scheme_add_global_constant("hash-table-map",
scheme_make_prim_w_arity(hash_table_map,
"hash-table-map",
2, 2),
scheme_make_noncm_prim(hash_table_map,
"hash-table-map",
2, 2),
env);
scheme_add_global_constant("hash-table-for-each",
scheme_make_prim_w_arity(hash_table_for_each,
"hash-table-for-each",
2, 2),
scheme_make_noncm_prim(hash_table_for_each,
"hash-table-for-each",
2, 2),
env);
scheme_add_global_constant("eq-hash-code",
scheme_make_prim_w_arity(eq_hash_code,
"eq-hash-code",
1, 1),
scheme_make_noncm_prim(eq_hash_code,
"eq-hash-code",
1, 1),
env);
scheme_add_global_constant("equal-hash-code",
scheme_make_prim_w_arity(equal_hash_code,
"equal-hash-code",
1, 1),
scheme_make_noncm_prim(equal_hash_code,
"equal-hash-code",
1, 1),
env);
scheme_add_global_constant("make-weak-box",
scheme_make_prim_w_arity(make_weak_box,
"make-weak-box",
1, 1),
scheme_make_noncm_prim(make_weak_box,
"make-weak-box",
1, 1),
env);
scheme_add_global_constant("weak-box-value",
scheme_make_prim_w_arity(weak_box_value,
"weak-box-value",
1, 1),
scheme_make_noncm_prim(weak_box_value,
"weak-box-value",
1, 1),
env);
scheme_add_global_constant("weak-box?",
scheme_make_folding_prim(weak_boxp,
@ -508,14 +510,14 @@ scheme_init_list (Scheme_Env *env)
env);
scheme_add_global_constant("make-ephemeron",
scheme_make_prim_w_arity(make_ephemeron,
"make-ephemeron",
2, 2),
scheme_make_noncm_prim(make_ephemeron,
"make-ephemeron",
2, 2),
env);
scheme_add_global_constant("ephemeron-value",
scheme_make_prim_w_arity(ephemeron_value,
"ephemeron-value",
1, 1),
scheme_make_noncm_prim(ephemeron_value,
"ephemeron-value",
1, 1),
env);
scheme_add_global_constant("ephemeron?",
scheme_make_folding_prim(ephemeronp,

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

@ -70,6 +70,9 @@ static Scheme_Object *provide_expand(Scheme_Object *form, Scheme_Comp_Env *env,
static Scheme_Object *module_execute(Scheme_Object *data);
static Scheme_Object *top_level_require_execute(Scheme_Object *data);
static Scheme_Object *module_jit(Scheme_Object *data);
static Scheme_Object *top_level_require_jit(Scheme_Object *data);
static Scheme_Object *module_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *top_level_require_resolve(Scheme_Object *data, Resolve_Info *info);
@ -195,10 +198,10 @@ void scheme_init_module(Scheme_Env *env)
scheme_register_syntax(MODULE_EXPD,
module_resolve, module_validate,
module_execute, -1);
module_execute, module_jit, -1);
scheme_register_syntax(REQUIRE_EXPD,
top_level_require_resolve, top_level_require_validate,
top_level_require_execute, 2);
top_level_require_execute, top_level_require_jit, 2);
scheme_add_global_keyword("module",
scheme_make_compiled_syntax(module_syntax,
@ -2965,6 +2968,95 @@ module_execute(Scheme_Object *data)
return scheme_void;
}
static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec)
{
Scheme_Object *vec2;
int i;
i = SCHEME_VEC_SIZE(vec);
vec2 = scheme_make_vector(i, NULL);
while (i--) {
SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i];
}
SCHEME_VEC_ELS(vec2)[1] = naya;
return vec2;
}
static Scheme_Object *jit_list(Scheme_Object *orig_l, int in_vec)
{
Scheme_Object *l, *orig, *naya = NULL;
int saw;
for (l = orig_l, saw = 0; SCHEME_PAIRP(l); l = SCHEME_CDR(l), saw++) {
orig = SCHEME_CAR(l);
if (in_vec)
orig = SCHEME_VEC_ELS(orig)[1];
naya = scheme_jit_expr(orig);
if (!SAME_OBJ(orig, naya))
break;
}
if (SCHEME_PAIRP(l)) {
Scheme_Object *first = scheme_null, *last = NULL, *pr;
for (l = orig_l; saw--; l = SCHEME_CDR(l)) {
orig = SCHEME_CAR(l);
pr = scheme_make_pair(orig, scheme_null);
if (last)
SCHEME_CDR(last) = pr;
else
first = pr;
last = pr;
}
if (in_vec)
naya = rebuild_et_vec(naya, SCHEME_CAR(l));
pr = scheme_make_pair(naya, scheme_null);
if (last)
SCHEME_CDR(last) = pr;
else
first = pr;
last = pr;
l = SCHEME_CDR(l);
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
orig = SCHEME_CAR(l);
if (in_vec)
orig = SCHEME_VEC_ELS(orig)[1];
naya = scheme_jit_expr(orig);
if (in_vec) {
if (!SAME_OBJ(orig, naya))
naya = rebuild_et_vec(naya, SCHEME_CAR(l));
else
naya = SCHEME_CAR(l);
}
pr = scheme_make_pair(naya, scheme_null);
SCHEME_CDR(last) = pr;
last = pr;
}
return first;
} else
return orig_l;
}
static Scheme_Object *module_jit(Scheme_Object *data)
{
Scheme_Module *m = (Scheme_Module *)data;
Scheme_Object *l1, *l2;
l1 = jit_list(m->body, 0);
l2 = jit_list(m->et_body, 1);
if (SAME_OBJ(l1, m->body) && SAME_OBJ(l2, m->body))
return data;
m = MALLOC_ONE_TAGGED(Scheme_Module);
memcpy(m, data, sizeof(Scheme_Module));
m->body = l1;
m->et_body = l2;
return (Scheme_Object *)m;
}
static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes)
@ -2987,6 +3079,7 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
if (!SCHEME_NULLP(l))
scheme_ill_formed_code(port);
/* FIXME: validate exp-time code */
}
static Scheme_Object *
@ -3011,6 +3104,8 @@ module_resolve(Scheme_Object *data, Resolve_Info *rslv)
SCHEME_CAR(b) = e;
}
/* Exp-time body was resolved during compilation */
return scheme_make_syntax_resolved(MODULE_EXPD, data);
}
@ -3836,6 +3931,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Compile_Info mrec;
Scheme_Object *names, *l, *code, *m, *vec, *boundname;
Resolve_Prefix *rp;
Resolve_Info *ri;
Scheme_Comp_Env *oenv, *eenv;
int count = 0;
int for_stx;
@ -3922,7 +4018,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Simplify only in compile mode; it is too slow in expand mode. */
rp = scheme_resolve_prefix(1, eenv->prefix, rec[drec].comp);
m = scheme_resolve_expr(m, scheme_resolve_info_create(rp));
ri = scheme_resolve_info_create(rp);
m = scheme_resolve_expr(m, ri);
/* Add code with names and lexical depth to exp-time body: */
vec = scheme_make_vector(5, NULL);
@ -3932,6 +4029,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp;
SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false);
exp_body = scheme_make_pair(vec, exp_body);
if (ri->use_jit)
m = scheme_jit_expr(m);
eval_defmacro(names, count, m, eenv->genv, rhs_env, rp, mrec.max_let_depth, 0,
(for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx,
@ -5431,6 +5531,12 @@ top_level_require_execute(Scheme_Object *data)
return scheme_void;
}
static Scheme_Object *
top_level_require_jit(Scheme_Object *data)
{
return data;
}
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes)

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

@ -415,6 +415,9 @@ int unclosed_proc_MARK(void *p) {
gcMARK(d->name);
gcMARK(d->code);
gcMARK(d->closure_map);
#ifdef MZ_USE_JIT
gcMARK(d->native_code);
#endif
return
gcBYTES_TO_WORDS(sizeof(Scheme_Closure_Data));
@ -426,6 +429,9 @@ int unclosed_proc_FIXUP(void *p) {
gcFIXUP(d->name);
gcFIXUP(d->code);
gcFIXUP(d->closure_map);
#ifdef MZ_USE_JIT
gcFIXUP(d->native_code);
#endif
return
gcBYTES_TO_WORDS(sizeof(Scheme_Closure_Data));
@ -828,6 +834,9 @@ int case_closure_MARK(void *p) {
for (i = c->count; i--; )
gcMARK(c->array[i]);
gcMARK(c->name);
#ifdef MZ_USE_JIT
gcMARK(c->native_code);
#endif
return
gcBYTES_TO_WORDS((sizeof(Scheme_Case_Lambda)
@ -842,6 +851,9 @@ int case_closure_FIXUP(void *p) {
for (i = c->count; i--; )
gcFIXUP(c->array[i]);
gcFIXUP(c->name);
#ifdef MZ_USE_JIT
gcFIXUP(c->native_code);
#endif
return
gcBYTES_TO_WORDS((sizeof(Scheme_Case_Lambda)
@ -1623,6 +1635,7 @@ int cont_mark_set_val_SIZE(void *p) {
int cont_mark_set_val_MARK(void *p) {
Scheme_Cont_Mark_Set *s = (Scheme_Cont_Mark_Set *)p;
gcMARK(s->chain);
gcMARK(s->native_stack_trace);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cont_Mark_Set));
@ -1631,6 +1644,7 @@ int cont_mark_set_val_MARK(void *p) {
int cont_mark_set_val_FIXUP(void *p) {
Scheme_Cont_Mark_Set *s = (Scheme_Cont_Mark_Set *)p;
gcFIXUP(s->chain);
gcFIXUP(s->native_stack_trace);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Cont_Mark_Set));

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

@ -153,6 +153,9 @@ unclosed_proc {
gcMARK(d->name);
gcMARK(d->code);
gcMARK(d->closure_map);
#ifdef MZ_USE_JIT
gcMARK(d->native_code);
#endif
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Closure_Data));
@ -311,6 +314,9 @@ case_closure {
for (i = c->count; i--; )
gcMARK(c->array[i]);
gcMARK(c->name);
#ifdef MZ_USE_JIT
gcMARK(c->native_code);
#endif
size:
gcBYTES_TO_WORDS((sizeof(Scheme_Case_Lambda)
@ -630,6 +636,7 @@ cont_mark_set_val {
mark:
Scheme_Cont_Mark_Set *s = (Scheme_Cont_Mark_Set *)p;
gcMARK(s->chain);
gcMARK(s->native_stack_trace);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Cont_Mark_Set));

42
src/mzscheme/src/numarith.c
View File

@ -26,6 +26,11 @@
#include "nummacs.h"
#include <math.h>
Scheme_Object *scheme_add1_prim;
Scheme_Object *scheme_sub1_prim;
Scheme_Object *scheme_plus_prim;
Scheme_Object *scheme_minus_prim;
static Scheme_Object *plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *mult (int argc, Scheme_Object *argv[]);
@ -38,26 +43,23 @@ static Scheme_Object *quotient_remainder (int argc, Scheme_Object *argv[]);
void scheme_init_numarith(Scheme_Env *env)
{
scheme_add_global_constant("add1",
scheme_make_folding_prim(scheme_add1,
"add1",
1, 1, 1),
env);
scheme_add_global_constant("sub1",
scheme_make_folding_prim(scheme_sub1,
"sub1",
1, 1, 1),
env);
scheme_add_global_constant("+",
scheme_make_folding_prim(plus,
"+",
0, -1, 1),
env);
scheme_add_global_constant("-",
scheme_make_folding_prim(minus,
"-",
1, -1, 1),
env);
REGISTER_SO(scheme_add1_prim);
REGISTER_SO(scheme_sub1_prim);
REGISTER_SO(scheme_plus_prim);
REGISTER_SO(scheme_minus_prim);
scheme_add1_prim = scheme_make_folding_prim(scheme_add1, "add1", 1, 1, 1);
scheme_add_global_constant("add1", scheme_add1_prim, env);
scheme_sub1_prim = scheme_make_folding_prim(scheme_sub1, "sub1", 1, 1, 1);
scheme_add_global_constant("sub1", scheme_sub1_prim, env);
scheme_plus_prim = scheme_make_folding_prim(plus, "+", 0, -1, 1);
scheme_add_global_constant("+", scheme_plus_prim, env);
scheme_minus_prim = scheme_make_folding_prim(minus, "-", 1, -1, 1);
scheme_add_global_constant("-", scheme_minus_prim, env);
scheme_add_global_constant("*",
scheme_make_folding_prim(mult,
"*",

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

@ -2125,7 +2125,7 @@ long scheme_get_char_string(const char *who,
special_is_ok = 1;
got = scheme_get_byte_string_unless(who, port,
s, leftover, 1,
0, 1,
0, 1 /* => peek */,
quick_plus(peek_skip, ahead_skip),
NULL);
if (got > 0) {
@ -2172,11 +2172,13 @@ long scheme_get_char_string(const char *who,
}
} else {
/* Either EOF or SPECIAL -- either one ends the leftover
sequence in an error. */
while (leftover) {
sequence in an error. We may have more leftover chars
than we need, but they haven't been read, yet. */
while (leftover && size) {
buffer[offset++] = '?';
total_got++;
--leftover;
--size;
}
return total_got;
}

384
src/mzscheme/src/portfun.c
View File

@ -182,15 +182,15 @@ scheme_init_port_fun(Scheme_Env *env)
module_symbol = scheme_intern_symbol("module");
scheme_write_proc = scheme_make_prim_w_arity(sch_write,
"write",
1, 2);
scheme_display_proc = scheme_make_prim_w_arity(display,
"display",
1, 2);
scheme_print_proc = scheme_make_prim_w_arity(sch_print,
"print",
scheme_write_proc = scheme_make_noncm_prim(sch_write,
"write",
1, 2);
scheme_display_proc = scheme_make_noncm_prim(display,
"display",
1, 2);
scheme_print_proc = scheme_make_noncm_prim(sch_print,
"print",
1, 2);
/* Made as a closed prim so we can get the arity right: */
default_read_handler = scheme_make_closed_prim_w_arity(sch_default_read_handler,
@ -342,214 +342,214 @@ scheme_init_port_fun(Scheme_Env *env)
env);
scheme_add_global_constant("read",
scheme_make_prim_w_arity(read_f,
"read",
0, 1),
scheme_make_noncm_prim(read_f,
"read",
0, 1),
env);
scheme_add_global_constant("read/recursive",
scheme_make_prim_w_arity(read_recur_f,
"read/recursive",
0, 3),
scheme_make_noncm_prim(read_recur_f,
"read/recursive",
0, 3),
env);
scheme_add_global_constant("read-syntax",
scheme_make_prim_w_arity(read_syntax_f,
"read-syntax",
0, 2),
scheme_make_noncm_prim(read_syntax_f,
"read-syntax",
0, 2),
env);
scheme_add_global_constant("read-syntax/recursive",
scheme_make_prim_w_arity(read_syntax_recur_f,
"read-syntax/recursive",
0, 4),
scheme_make_noncm_prim(read_syntax_recur_f,
"read-syntax/recursive",
0, 4),
env);
scheme_add_global_constant("read-honu",
scheme_make_prim_w_arity(read_honu_f,
"read-honu",
0, 1),
scheme_make_noncm_prim(read_honu_f,
"read-honu",
0, 1),
env);
scheme_add_global_constant("read-honu/recursive",
scheme_make_prim_w_arity(read_honu_recur_f,
"read-honu/recursive",
0, 1),
scheme_make_noncm_prim(read_honu_recur_f,
"read-honu/recursive",
0, 1),
env);
scheme_add_global_constant("read-honu-syntax",
scheme_make_prim_w_arity(read_honu_syntax_f,
"read-honu-syntax",
0, 2),
scheme_make_noncm_prim(read_honu_syntax_f,
"read-honu-syntax",
0, 2),
env);
scheme_add_global_constant("read-honu-syntax/recursive",
scheme_make_prim_w_arity(read_honu_syntax_recur_f,
"read-honu-syntax/recursive",
0, 2),
scheme_make_noncm_prim(read_honu_syntax_recur_f,
"read-honu-syntax/recursive",
0, 2),
env);
scheme_add_global_constant("read-char",
scheme_make_prim_w_arity(read_char,
"read-char",
0, 1),
scheme_make_noncm_prim(read_char,
"read-char",
0, 1),
env);
scheme_add_global_constant("read-char-or-special",
scheme_make_prim_w_arity(read_char_spec,
"read-char-or-special",
0, 1),
scheme_make_noncm_prim(read_char_spec,
"read-char-or-special",
0, 1),
env);
scheme_add_global_constant("read-byte",
scheme_make_prim_w_arity(read_byte,
"read-byte",
0, 1),
scheme_make_noncm_prim(read_byte,
"read-byte",
0, 1),
env);
scheme_add_global_constant("read-byte-or-special",
scheme_make_prim_w_arity(read_byte_spec,
"read-byte-or-special",
0, 1),
scheme_make_noncm_prim(read_byte_spec,
"read-byte-or-special",
0, 1),
env);
scheme_add_global_constant("read-bytes-line",
scheme_make_prim_w_arity(read_byte_line,
"read-bytes-line",
0, 2),
scheme_make_noncm_prim(read_byte_line,
"read-bytes-line",
0, 2),
env);
scheme_add_global_constant("read-line",
scheme_make_prim_w_arity(read_line,
"read-line",
0, 2),
scheme_make_noncm_prim(read_line,
"read-line",
0, 2),
env);
scheme_add_global_constant("read-string",
scheme_make_prim_w_arity(sch_read_string,
"read-string",
1, 2),
scheme_make_noncm_prim(sch_read_string,
"read-string",
1, 2),
env);
scheme_add_global_constant("read-string!",
scheme_make_prim_w_arity(sch_read_string_bang,
"read-string!",
1, 4),
scheme_make_noncm_prim(sch_read_string_bang,
"read-string!",
1, 4),
env);
scheme_add_global_constant("peek-string",
scheme_make_prim_w_arity(sch_peek_string,
"peek-string",
2, 3),
scheme_make_noncm_prim(sch_peek_string,
"peek-string",
2, 3),
env);
scheme_add_global_constant("peek-string!",
scheme_make_prim_w_arity(sch_peek_string_bang,
"peek-string!",
2, 5),
scheme_make_noncm_prim(sch_peek_string_bang,
"peek-string!",
2, 5),
env);
scheme_add_global_constant("read-bytes",
scheme_make_prim_w_arity(sch_read_bytes,
"read-bytes",
1, 2),
scheme_make_noncm_prim(sch_read_bytes,
"read-bytes",
1, 2),
env);
scheme_add_global_constant("read-bytes!",
scheme_make_prim_w_arity(sch_read_bytes_bang,
"read-bytes!",
1, 4),
scheme_make_noncm_prim(sch_read_bytes_bang,
"read-bytes!",
1, 4),
env);
scheme_add_global_constant("peek-bytes",
scheme_make_prim_w_arity(sch_peek_bytes,
"peek-bytes",
2, 3),
scheme_make_noncm_prim(sch_peek_bytes,
"peek-bytes",
2, 3),
env);
scheme_add_global_constant("peek-bytes!",
scheme_make_prim_w_arity(sch_peek_bytes_bang,
"peek-bytes!",
2, 5),
scheme_make_noncm_prim(sch_peek_bytes_bang,
"peek-bytes!",
2, 5),
env);
scheme_add_global_constant("read-bytes-avail!",
scheme_make_prim_w_arity(read_bytes_bang,
"read-bytes-avail!",
1, 4),
scheme_make_noncm_prim(read_bytes_bang,
"read-bytes-avail!",
1, 4),
env);
scheme_add_global_constant("read-bytes-avail!*",
scheme_make_prim_w_arity(read_bytes_bang_nonblock,
"read-bytes-avail!*",
1, 4),
scheme_make_noncm_prim(read_bytes_bang_nonblock,
"read-bytes-avail!*",
1, 4),
env);
scheme_add_global_constant("read-bytes-avail!/enable-break",
scheme_make_prim_w_arity(read_bytes_bang_break,
"read-bytes-avail!/enable-break",
1, 4),
scheme_make_noncm_prim(read_bytes_bang_break,
"read-bytes-avail!/enable-break",
1, 4),
env);
scheme_add_global_constant("peek-bytes-avail!",
scheme_make_prim_w_arity(peek_bytes_bang,
"peek-bytes-avail!",
2, 6),
scheme_make_noncm_prim(peek_bytes_bang,
"peek-bytes-avail!",
2, 6),
env);
scheme_add_global_constant("peek-bytes-avail!*",
scheme_make_prim_w_arity(peek_bytes_bang_nonblock,
"peek-bytes-avail!*",
2, 6),
scheme_make_noncm_prim(peek_bytes_bang_nonblock,
"peek-bytes-avail!*",
2, 6),
env);
scheme_add_global_constant("peek-bytes-avail!/enable-break",
scheme_make_prim_w_arity(peek_bytes_bang_break,
"peek-bytes-avail!/enable-break",
2, 6),
scheme_make_noncm_prim(peek_bytes_bang_break,
"peek-bytes-avail!/enable-break",
2, 6),
env);
scheme_add_global_constant("port-provides-progress-evts?",
scheme_make_prim_w_arity(can_provide_progress_evt,
"port-provides-progress-evts?",
1, 1),
scheme_make_noncm_prim(can_provide_progress_evt,
"port-provides-progress-evts?",
1, 1),
env);
scheme_add_global_constant("write-bytes",
scheme_make_prim_w_arity(write_bytes,
"write-bytes",
1, 4),
scheme_make_noncm_prim(write_bytes,
"write-bytes",
1, 4),
env);
scheme_add_global_constant("write-string",
scheme_make_prim_w_arity(write_string,
"write-string",
1, 4),
scheme_make_noncm_prim(write_string,
"write-string",
1, 4),
env);
scheme_add_global_constant("write-bytes-avail",
scheme_make_prim_w_arity(write_bytes_avail,
"write-bytes-avail",
1, 4),
scheme_make_noncm_prim(write_bytes_avail,
"write-bytes-avail",
1, 4),
env);
scheme_add_global_constant("write-bytes-avail*",
scheme_make_prim_w_arity(write_bytes_avail_nonblock,
"write-bytes-avail*",
1, 4),
scheme_make_noncm_prim(write_bytes_avail_nonblock,
"write-bytes-avail*",
1, 4),
env);
scheme_add_global_constant("write-bytes-avail/enable-break",
scheme_make_prim_w_arity(write_bytes_avail_break,
"write-bytes-avail/enable-break",
1, 4),
scheme_make_noncm_prim(write_bytes_avail_break,
"write-bytes-avail/enable-break",
1, 4),
env);
scheme_add_global_constant("port-writes-atomic?",
scheme_make_prim_w_arity(can_write_atomic,
"port-writes-atomic?",
1, 1),
scheme_make_noncm_prim(can_write_atomic,
"port-writes-atomic?",
1, 1),
env);
scheme_add_global_constant("port-writes-special?",
scheme_make_prim_w_arity(can_write_special,
"port-writes-special?",
1, 1),
scheme_make_noncm_prim(can_write_special,
"port-writes-special?",
1, 1),
env);
scheme_add_global_constant("write-special",
scheme_make_prim_w_arity(scheme_write_special,
"write-special",
1, 2),
scheme_make_noncm_prim(scheme_write_special,
"write-special",
1, 2),
env);
scheme_add_global_constant("write-special-avail*",
scheme_make_prim_w_arity(scheme_write_special_nonblock,
"write-special-avail*",
1, 2),
scheme_make_noncm_prim(scheme_write_special_nonblock,
"write-special-avail*",
1, 2),
env);
scheme_add_global_constant("peek-char",
scheme_make_prim_w_arity(peek_char,
"peek-char",
0, 2),
scheme_make_noncm_prim(peek_char,
"peek-char",
0, 2),
env);
scheme_add_global_constant("peek-char-or-special",
scheme_make_prim_w_arity(peek_char_spec,
"peek-char-or-special",
0, 2),
scheme_make_noncm_prim(peek_char_spec,
"peek-char-or-special",
0, 2),
env);
scheme_add_global_constant("peek-byte",
scheme_make_prim_w_arity(peek_byte,
"peek-byte",
0, 2),
scheme_make_noncm_prim(peek_byte,
"peek-byte",
0, 2),
env);
scheme_add_global_constant("peek-byte-or-special",
scheme_make_prim_w_arity(peek_byte_spec,
"peek-byte-or-special",
0, 3),
scheme_make_noncm_prim(peek_byte_spec,
"peek-byte-or-special",
0, 3),
env);
scheme_add_global_constant("eof-object?",
scheme_make_folding_prim(eof_object_p,
@ -557,77 +557,77 @@ scheme_init_port_fun(Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("byte-ready?",
scheme_make_prim_w_arity(byte_ready_p,
"byte-ready?",
0, 1),
scheme_make_noncm_prim(byte_ready_p,
"byte-ready?",
0, 1),
env);
scheme_add_global_constant("char-ready?",
scheme_make_prim_w_arity(char_ready_p,
"char-ready?",
0, 1),
scheme_make_noncm_prim(char_ready_p,
"char-ready?",
0, 1),
env);
scheme_add_global_constant("write", scheme_write_proc, env);
scheme_add_global_constant("display", scheme_display_proc, env);
scheme_add_global_constant("print", scheme_print_proc, env);
scheme_add_global_constant("newline",
scheme_make_prim_w_arity(newline,
"newline",
0, 1),
scheme_make_noncm_prim(newline,
"newline",
0, 1),
env);
scheme_add_global_constant("write-char",
scheme_make_prim_w_arity(write_char,
"write-char",
1, 2),
scheme_make_noncm_prim(write_char,
"write-char",
1, 2),
env);
scheme_add_global_constant("write-byte",
scheme_make_prim_w_arity(write_byte,
"write-byte",
1, 2),
scheme_make_noncm_prim(write_byte,
"write-byte",
1, 2),
env);
scheme_add_global_constant("port-commit-peeked",
scheme_make_prim_w_arity(peeked_read,
"port-commit-peeked",
3, 4),
scheme_make_noncm_prim(peeked_read,
"port-commit-peeked",
3, 4),
env);
scheme_add_global_constant("port-progress-evt",
scheme_make_prim_w_arity(progress_evt,
"port-progress-evt",
0, 1),
scheme_make_noncm_prim(progress_evt,
"port-progress-evt",
0, 1),
env);
scheme_add_global_constant("write-bytes-avail-evt",
scheme_make_prim_w_arity(write_bytes_avail_evt,
"write-bytes-avail-evt",
1, 4),
scheme_make_noncm_prim(write_bytes_avail_evt,
"write-bytes-avail-evt",
1, 4),
env);
scheme_add_global_constant("write-special-evt",
scheme_make_prim_w_arity(write_special_evt,
"write-special-evt",
2, 2),
scheme_make_noncm_prim(write_special_evt,
"write-special-evt",
2, 2),
env);
scheme_add_global_constant("port-read-handler",
scheme_make_prim_w_arity(port_read_handler,
"port-read-handler",
1, 2),
scheme_make_noncm_prim(port_read_handler,
"port-read-handler",
1, 2),
env);
scheme_add_global_constant("port-display-handler",
scheme_make_prim_w_arity(port_display_handler,
"port-display-handler",
1, 2),
scheme_make_noncm_prim(port_display_handler,
"port-display-handler",
1, 2),
env);
scheme_add_global_constant("port-write-handler",
scheme_make_prim_w_arity(port_write_handler,
"port-write-handler",
1, 2),
scheme_make_noncm_prim(port_write_handler,
"port-write-handler",
1, 2),
env);
scheme_add_global_constant("port-print-handler",
scheme_make_prim_w_arity(port_print_handler,
"port-print-handler",
1, 2),
scheme_make_noncm_prim(port_print_handler,
"port-print-handler",
1, 2),
env);
scheme_add_global_constant("global-port-print-handler",
scheme_register_parameter(global_port_print_handler,
@ -640,7 +640,7 @@ scheme_init_port_fun(Scheme_Env *env)
"load",
1, 1,
0, -1),
env);
env);
scheme_add_global_constant("current-load",
scheme_register_parameter(current_load,
"current-load",
@ -669,24 +669,24 @@ scheme_init_port_fun(Scheme_Env *env)
env);
scheme_add_global_constant("flush-output",
scheme_make_prim_w_arity(flush_output,
"flush-output",
0, 1),
scheme_make_noncm_prim(flush_output,
"flush-output",
0, 1),
env);
scheme_add_global_constant("file-position",
scheme_make_prim_w_arity(scheme_file_position,
"file-position",
1, 2),
scheme_make_noncm_prim(scheme_file_position,
"file-position",
1, 2),
env);
scheme_add_global_constant("file-stream-buffer-mode",
scheme_make_prim_w_arity(scheme_file_buffer,
"file-stream-buffer-mode",
1, 2),
scheme_make_noncm_prim(scheme_file_buffer,
"file-stream-buffer-mode",
1, 2),
env);
scheme_add_global_constant("port-file-identity",
scheme_make_prim_w_arity(scheme_file_identity,
"port-file-identity",
1, 1),
scheme_make_noncm_prim(scheme_file_identity,
"port-file-identity",
1, 1),
env);
scheme_add_global_constant("make-pipe",
@ -696,16 +696,16 @@ scheme_init_port_fun(Scheme_Env *env)
2, 2),
env);
scheme_add_global_constant("pipe-content-length",
scheme_make_prim_w_arity(pipe_length,
"pipe-content-length",
1, 1),
scheme_make_noncm_prim(pipe_length,
"pipe-content-length",
1, 1),
env);
scheme_add_global_constant("port-count-lines!",
scheme_make_prim_w_arity(port_count_lines,
"port-count-lines!",
1, 1),
scheme_make_noncm_prim(port_count_lines,
"port-count-lines!",
1, 1),
env);
scheme_add_global_constant("port-next-location",
scheme_make_prim_w_arity2(port_next_location,

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

@ -123,12 +123,6 @@ static Scheme_Hash_Table *global_constants_ht;
#define ssALL(x, isbox) 1
#define ssALLp(x, isbox) isbox
#ifdef MZ_PRECISE_GC
# define ZERO_SIZED(closure) !(closure->closure_size)
#else
# define ZERO_SIZED(closure) closure->zero_sized
#endif
static Scheme_Hash_Table *cache_ht;
void scheme_init_print(Scheme_Env *env)
@ -1668,14 +1662,29 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
closed = 1;
}
else if (SCHEME_CLOSUREP(obj))
else if (SCHEME_CLOSUREP(obj)
|| SAME_TYPE(SCHEME_TYPE(obj), scheme_native_closure_type))
{
if (compact || !pp->print_unreadable) {
Scheme_Closure *closure = (Scheme_Closure *)obj;
if (compact && ZERO_SIZED(closure)) {
/* Print original code: */
compact = print((Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(closure), notdisplay, compact, ht, symtab, rnht, pp);
} else
int done = 0;
if (compact) {
if (SCHEME_TYPE(obj) == scheme_closure_type) {
Scheme_Closure *closure = (Scheme_Closure *)obj;
if (ZERO_SIZED_CLOSUREP(closure)) {
/* Print original `lambda' code: */
compact = print((Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(closure), notdisplay, compact, ht, symtab, rnht, pp);
done = 1;
}
} else if (SCHEME_TYPE(obj) == scheme_case_closure_type) {
obj = scheme_unclose_case_lambda(obj, 0);
if (!SCHEME_PROCP(obj)) {
/* Print original `case-lambda' code: */
compact = print(obj, notdisplay, compact, ht, symtab, rnht, pp);
done = 1;
}
}
}
if (!done)
cannot_print(pp, notdisplay, obj, ht, compact);
} else {
int len;

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

@ -3633,6 +3633,7 @@ typedef struct CPort {
unsigned char *start;
unsigned long symtab_size;
long base;
int flags;
Scheme_Object *orig_port;
Scheme_Hash_Table **ht;
Scheme_Object **symtab;
@ -4580,7 +4581,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
rp->symtab_size = symtabsize;
rp->ht = ht;
rp->symtab = symtab;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
rp->insp = insp;

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

@ -275,6 +275,7 @@ MZ_EXTERN Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj);
MZ_EXTERN void scheme_set_tail_buffer_size(int s);
MZ_EXTERN Scheme_Object *scheme_force_value(Scheme_Object *);
MZ_EXTERN Scheme_Object *scheme_force_one_value(Scheme_Object *);
MZ_EXTERN void *scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN void scheme_push_continuation_frame(Scheme_Cont_Frame_Data *);
@ -395,6 +396,9 @@ MZ_EXTERN Scheme_Object *scheme_make_folding_prim(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa,
short functional);
MZ_EXTERN Scheme_Object *scheme_make_noncm_prim(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa);
MZ_EXTERN Scheme_Object *scheme_make_noneternal_prim_w_arity(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa);
@ -408,7 +412,7 @@ MZ_EXTERN Scheme_Object *scheme_make_folding_closed_prim(Scheme_Closed_Prim *pri
MZ_EXTERN Scheme_Object *scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
const char *name,
mzshort mina, mzshort maxa,
short folding,
int folding,
mzshort minr, mzshort maxr);
MZ_EXTERN Scheme_Object *scheme_make_closed_prim_w_everything(Scheme_Closed_Prim *fun,
void *data,

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

@ -220,6 +220,7 @@ Scheme_Object *(*scheme_tail_apply_to_list)(Scheme_Object *f, Scheme_Object *l);
Scheme_Object *(*scheme_tail_eval_expr)(Scheme_Object *obj);
void (*scheme_set_tail_buffer_size)(int s);
Scheme_Object *(*scheme_force_value)(Scheme_Object *);
Scheme_Object *(*scheme_force_one_value)(Scheme_Object *);
void *(*scheme_set_cont_mark)(Scheme_Object *key, Scheme_Object *val);
void (*scheme_push_continuation_frame)(Scheme_Cont_Frame_Data *);
void (*scheme_pop_continuation_frame)(Scheme_Cont_Frame_Data *);
@ -319,6 +320,9 @@ Scheme_Object *(*scheme_make_folding_prim)(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa,
short functional);
Scheme_Object *(*scheme_make_noncm_prim)(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa);
Scheme_Object *(*scheme_make_noneternal_prim_w_arity)(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa);
@ -332,7 +336,7 @@ Scheme_Object *(*scheme_make_folding_closed_prim)(Scheme_Closed_Prim *prim,
Scheme_Object *(*scheme_make_prim_w_everything)(Scheme_Prim *fun, int eternal,
const char *name,
mzshort mina, mzshort maxa,
short folding,
int folding,
mzshort minr, mzshort maxr);
Scheme_Object *(*scheme_make_closed_prim_w_everything)(Scheme_Closed_Prim *fun,
void *data,

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

@ -136,6 +136,7 @@
scheme_extension_table->scheme_tail_eval_expr = scheme_tail_eval_expr;
scheme_extension_table->scheme_set_tail_buffer_size = scheme_set_tail_buffer_size;
scheme_extension_table->scheme_force_value = scheme_force_value;
scheme_extension_table->scheme_force_one_value = scheme_force_one_value;
scheme_extension_table->scheme_set_cont_mark = scheme_set_cont_mark;
scheme_extension_table->scheme_push_continuation_frame = scheme_push_continuation_frame;
scheme_extension_table->scheme_pop_continuation_frame = scheme_pop_continuation_frame;
@ -211,6 +212,7 @@
scheme_extension_table->scheme_make_closed_prim = scheme_make_closed_prim;
scheme_extension_table->scheme_make_prim_w_arity = scheme_make_prim_w_arity;
scheme_extension_table->scheme_make_folding_prim = scheme_make_folding_prim;
scheme_extension_table->scheme_make_noncm_prim = scheme_make_noncm_prim;
scheme_extension_table->scheme_make_noneternal_prim_w_arity = scheme_make_noneternal_prim_w_arity;
scheme_extension_table->scheme_make_closed_prim_w_arity = scheme_make_closed_prim_w_arity;
scheme_extension_table->scheme_make_folding_closed_prim = scheme_make_folding_closed_prim;

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

@ -136,6 +136,7 @@
#define scheme_tail_eval_expr (scheme_extension_table->scheme_tail_eval_expr)
#define scheme_set_tail_buffer_size (scheme_extension_table->scheme_set_tail_buffer_size)
#define scheme_force_value (scheme_extension_table->scheme_force_value)
#define scheme_force_one_value (scheme_extension_table->scheme_force_one_value)
#define scheme_set_cont_mark (scheme_extension_table->scheme_set_cont_mark)
#define scheme_push_continuation_frame (scheme_extension_table->scheme_push_continuation_frame)
#define scheme_pop_continuation_frame (scheme_extension_table->scheme_pop_continuation_frame)
@ -211,6 +212,7 @@
#define scheme_make_closed_prim (scheme_extension_table->scheme_make_closed_prim)
#define scheme_make_prim_w_arity (scheme_extension_table->scheme_make_prim_w_arity)
#define scheme_make_folding_prim (scheme_extension_table->scheme_make_folding_prim)
#define scheme_make_noncm_prim (scheme_extension_table->scheme_make_noncm_prim)
#define scheme_make_noneternal_prim_w_arity (scheme_extension_table->scheme_make_noneternal_prim_w_arity)
#define scheme_make_closed_prim_w_arity (scheme_extension_table->scheme_make_closed_prim_w_arity)
#define scheme_make_folding_closed_prim (scheme_extension_table->scheme_make_folding_closed_prim)

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

@ -31,11 +31,14 @@
#ifdef STACK_GROWS_UP
# define STK_COMP(a,b) ((a) > (b))
# define STK_DIFF(a, b) ((a) - (b))
#else
# ifdef STACK_GROWS_DOWN
# define STK_COMP(a,b) ((a) < (b))
# define STK_DIFF(a, b) ((b) - (a))
# else
# define STK_COMP(a,b) (scheme_stack_grows_up == ((a) > (b)))
# define STK_DIFF(a,b) (scheme_stack_grows_up ? ((b) - (a)) : ((a) - (b)))
# endif
#endif

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 852
#define EXPECTED_PRIM_COUNT 853
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

70
src/mzscheme/src/schnapp.inc Normal file
View File

@ -0,0 +1,70 @@
if (!SCHEME_INTP(rator)) {
Scheme_Type t;
t = _SCHEME_TYPE(rator);
if (t == scheme_prim_type) {
Scheme_Object *v;
Scheme_Primitive_Proc *prim;
prim = (Scheme_Primitive_Proc *)rator;
if (argc < prim->mina || (argc > prim->maxa && prim->maxa >= 0)) {
scheme_wrong_count(prim->name, prim->mina, prim->maxa, argc, argv);
return NULL; /* Shouldn't get here */
}
v = prim->prim_val(argc, argv);
#if PRIM_CHECK_VALUE
v = _scheme_force_value(v);
#endif
#if PRIM_CHECK_MULTI
if (v == SCHEME_MULTIPLE_VALUES) {
scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
return NULL; /* Shouldn't get here */
}
#endif
return v;
} else if (t == scheme_closed_prim_type) {
Scheme_Object *v;
Scheme_Closed_Primitive_Proc *prim;
prim = (Scheme_Closed_Primitive_Proc *)rator;
if (argc < prim->mina || (argc > prim->maxa && prim->maxa >= 0)) {
scheme_wrong_count(prim->name, prim->mina, prim->maxa, argc, argv);
return NULL; /* Shouldn't get here */
}
v = prim->prim_val(prim->data, argc, argv);
#if PRIM_CHECK_VALUE
v = _scheme_force_value(v);
#endif
#if PRIM_CHECK_MULTI
if (v == SCHEME_MULTIPLE_VALUES) {
scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
return NULL; /* Shouldn't get here */
}
#endif
return v;
}
}
#if PRIM_CHECK_MULTI
return _scheme_apply(rator, argc, argv);
#else
# ifdef PRIM_CHECK_VALUE
return _scheme_apply_multi(rator, argc, argv);
# else
return _scheme_tail_apply(rator, argc, argv);
# endif
#endif
#undef PRIM_CHECK_VALUE
#undef PRIM_CHECK_MULTI

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

@ -217,10 +217,20 @@ extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_not_prim;
extern Scheme_Object *scheme_eq_prim;
extern Scheme_Object *scheme_null_p_prim;
extern Scheme_Object *scheme_pair_p_prim;
extern Scheme_Object *scheme_car_prim;
extern Scheme_Object *scheme_cdr_prim;
extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax;
extern Scheme_Object *scheme_lambda_syntax;
extern Scheme_Object *scheme_begin_syntax;
extern Scheme_Object *scheme_add1_prim;
extern Scheme_Object *scheme_sub1_prim;
extern Scheme_Object *scheme_plus_prim;
extern Scheme_Object *scheme_minus_prim;
extern Scheme_Object *scheme_def_exit_proc;
extern Scheme_Object *scheme_orig_stdout_port;
@ -782,6 +792,9 @@ typedef struct {
Scheme_Object so;
mzshort count;
Scheme_Object *name; /* see note below */
#ifdef MZ_USE_JIT
struct Scheme_Native_Closure_Data *native_code; /* generated by lightning */
#endif
Scheme_Object *array[1];
} Scheme_Case_Lambda;
/* If count is not 0, then check array[0] for CLOS_IS_METHOD.
@ -790,6 +803,11 @@ typedef struct {
#define scheme_make_prim_w_arity2(f, n, mina, maxa, minr, maxr) \
scheme_make_prim_w_everything(f, 0, n, mina, maxa, 0, minr, maxr)
Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int jit);
Scheme_Object *scheme_native_stack_trace(void);
void scheme_clean_native_symtab(void);
/*========================================================================*/
/* control flow */
/*========================================================================*/
@ -855,6 +873,7 @@ typedef struct Scheme_Cont_Mark_Set {
Scheme_Object so;
struct Scheme_Cont_Mark_Chain *chain;
long cmpos;
Scheme_Object *native_stack_trace;
} Scheme_Cont_Mark_Set;
#define SCHEME_LOG_MARK_SEGMENT_SIZE 8
@ -1386,6 +1405,18 @@ void scheme_install_type_writer(Scheme_Type type, Scheme_Type_Writer f);
Scheme_Object *scheme_make_default_readtable();
Scheme_Object *_scheme_apply_from_native(Scheme_Object *rator,
int argc,
Scheme_Object **argv);
Scheme_Object *_scheme_apply_multi_from_native(Scheme_Object *rator,
int argc,
Scheme_Object **argv);
Scheme_Object *_scheme_tail_apply_from_native(Scheme_Object *rator,
int argc,
Scheme_Object **argv);
void scheme_flush_stack_cache();
/*========================================================================*/
/* compile and link */
/*========================================================================*/
@ -1458,6 +1489,7 @@ typedef struct Resolve_Prefix
typedef struct Resolve_Info
{
MZTAG_IF_REQUIRED
int use_jit;
int size, oldsize, count, pos;
Resolve_Prefix *prefix;
mzshort toplevel_pos; /* -1 mean consult next */
@ -1487,6 +1519,8 @@ typedef void (*Scheme_Syntax_Validater)(Scheme_Object *data, Mz_CPort *port,
typedef struct Scheme_Object *(*Scheme_Syntax_Executer)(struct Scheme_Object *data);
typedef struct Scheme_Object *(*Scheme_Syntax_Jitter)(struct Scheme_Object *data);
typedef struct Scheme_Closure_Data
{
Scheme_Inclhash_Object iso; /* keyex used for flags */
@ -1496,6 +1530,9 @@ typedef struct Scheme_Closure_Data
mzshort *closure_map; /* Actually a Closure_Info* until resolved! */
Scheme_Object *code;
Scheme_Object *name;
#ifdef MZ_USE_JIT
struct Scheme_Native_Closure_Data *native_code; /* generated by lightning */
#endif
} Scheme_Closure_Data;
#define SCHEME_CLOSURE_DATA_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso)
@ -1516,6 +1553,44 @@ typedef struct {
#define SCHEME_COMPILED_CLOS_CODE(c) ((Scheme_Closure *)c)->code
#define SCHEME_COMPILED_CLOS_ENV(c) ((Scheme_Closure *)c)->vals
#ifdef MZ_PRECISE_GC
# define ZERO_SIZED_CLOSUREP(closure) !(closure->closure_size)
#else
# define ZERO_SIZED_CLOSUREP(closure) closure->zero_sized
#endif
typedef struct Scheme_Native_Closure_Data {
MZTAG_IF_REQUIRED
Scheme_Closed_Prim *code;
union {
void *tail_code; /* For non-case-lambda */
mzshort *arities; /* For case-lambda */
} u;
void *arity_code;
mzshort max_let_depth;
mzshort closure_size;
union {
struct Scheme_Closure_Data *orig_code; /* For not-yet-JITted non-case-lambda */
Scheme_Object *name;
} u2;
} Scheme_Native_Closure_Data;
#define SCHEME_NATIVE_CLOSURE_DATA_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso)
typedef struct {
Scheme_Object so;
#ifdef MZ_PRECISE_GC
int closure_size;
#else
short zero_sized;
#endif
Scheme_Native_Closure_Data *code;
Scheme_Object *vals[1];
} Scheme_Native_Closure;
Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *obj, int drop_code,
Scheme_Native_Closure_Data *case_lam);
#define MAX_CONST_LOCAL_POS 64
extern Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][2];
@ -1581,6 +1656,11 @@ Scheme_Object *scheme_make_closure(Scheme_Thread *p,
Scheme_Object *compiled_code,
int close);
Scheme_Object *scheme_make_native_closure(Scheme_Native_Closure_Data *code);
Scheme_Object *scheme_make_native_case_closure(Scheme_Native_Closure_Data *code);
Scheme_Native_Closure_Data *scheme_generate_case_lambda(Scheme_Case_Lambda *cl);
#define scheme_add_good_binding(i,v,f) (f->values[i] = v)
Scheme_Object *scheme_compiled_void();
@ -1611,14 +1691,16 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
#define REF_EXPD 11
#define _COUNT_EXPD_ 12
#define scheme_register_syntax(i, fr, fv, fe, pa) \
#define scheme_register_syntax(i, fr, fv, fe, fj, pa) \
(scheme_syntax_resolvers[i] = fr, \
scheme_syntax_executers[i] = fe, \
scheme_syntax_validaters[i] = fv, \
scheme_syntax_jitters[i] = fj, \
scheme_syntax_protect_afters[i] = pa)
extern Scheme_Syntax_Resolver scheme_syntax_resolvers[_COUNT_EXPD_];
extern Scheme_Syntax_Validater scheme_syntax_validaters[_COUNT_EXPD_];
extern Scheme_Syntax_Executer scheme_syntax_executers[_COUNT_EXPD_];
extern Scheme_Syntax_Jitter scheme_syntax_jitters[_COUNT_EXPD_];
extern int scheme_syntax_protect_afters[_COUNT_EXPD_];
Scheme_Object *scheme_protect_quote(Scheme_Object *expr);
@ -1691,6 +1773,9 @@ Scheme_Object *scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_
Scheme_App_Rec *scheme_malloc_application(int n);
void scheme_finish_application(Scheme_App_Rec *app);
Scheme_Object *scheme_jit_expr(Scheme_Object *);
Scheme_Object *scheme_jit_closure(Scheme_Object *);
#define SCHEME_SYNTAX(obj) SCHEME_PTR1_VAL(obj)
#define SCHEME_SYNTAX_EXP(obj) SCHEME_PTR2_VAL(obj)
@ -2071,6 +2156,10 @@ Scheme_Object *scheme_special_comment_value(Scheme_Object *o);
Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set);
Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, long a);
int scheme_native_arity_check(Scheme_Object *closure, int argc);
Scheme_Object *scheme_get_native_arity(Scheme_Object *closure);
/*========================================================================*/
/* filesystem utilities */
/*========================================================================*/

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

@ -8,7 +8,7 @@
#endif
#define MZSCHEME_VERSION_MAJOR 300
#define MZSCHEME_VERSION_MINOR 3
#define MZSCHEME_VERSION_MAJOR 301
#define MZSCHEME_VERSION_MINOR 4
#define MZSCHEME_VERSION "300.3" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "301.4" _MZ_SPECIAL_TAG

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

@ -383,6 +383,10 @@ int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
int local;
long disguised_b;
#ifdef MZ_USE_JIT
scheme_flush_stack_cache();
#endif
FLUSH_REGISTER_WINDOWS;
if (STK_COMP((unsigned long)start, (unsigned long)&local))
@ -423,6 +427,10 @@ void scheme_longjmpup(Scheme_Jumpup_Buf *b)
long z;
long junk[200];
#ifdef MZ_USE_JIT
scheme_flush_stack_cache();
#endif
uncopy_stack(STK_COMP((unsigned long)&z, DEEPPOS(b)), b, junk);
}

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

@ -2206,6 +2206,15 @@
"(module #%more-scheme #%kernel"
"(require #%small-scheme #%define #%paramz)"
"(require-for-syntax #%kernel #%stx #%stxcase-scheme #%qqstx)"
"(define-syntax case-test"
"(lambda(x)"
"(syntax-case x()"
"((_ x(k))"
"(if(symbol?(syntax-e #'k))"
"(syntax(eq? x 'k))"
"(syntax(eqv? x 'k))))"
"((_ x(k ...))"
"(syntax(memv x '(k ...)))))))"
"(define-syntax case"
"(lambda(x)"
"(syntax-case x(else)"
@ -2214,10 +2223,10 @@
"((_ v(else e1 e2 ...))"
"(syntax/loc x(begin v e1 e2 ...)))"
"((_ v((k ...) e1 e2 ...))"
"(syntax/loc x(if(memv v '(k ...))(begin e1 e2 ...))))"
"(syntax/loc x(if(case-test v(k ...))(begin e1 e2 ...))))"
"((_ v((k ...) e1 e2 ...) c1 c2 ...)"
"(syntax/loc x(let((x v))"
"(if(memv x '(k ...))"
"(if(case-test x(k ...))"
"(begin e1 e2 ...)"
"(case x c1 c2 ...)))))"
"((_ v(bad e1 e2 ...) . rest)"

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

@ -2577,6 +2577,16 @@
(require #%small-scheme #%define #%paramz)
(require-for-syntax #%kernel #%stx #%stxcase-scheme #%qqstx)
(define-syntax case-test
(lambda (x)
(syntax-case x ()
[(_ x (k))
(if (symbol? (syntax-e #'k))
(syntax (eq? x 'k))
(syntax (eqv? x 'k)))]
[(_ x (k ...))
(syntax (memv x '(k ...)))])))
;; From Dybvig:
(define-syntax case
(lambda (x)
@ -2586,10 +2596,10 @@
((_ v (else e1 e2 ...))
(syntax/loc x (begin v e1 e2 ...)))
((_ v ((k ...) e1 e2 ...))
(syntax/loc x (if (memv v '(k ...)) (begin e1 e2 ...))))
(syntax/loc x (if (case-test v (k ...)) (begin e1 e2 ...))))
((_ v ((k ...) e1 e2 ...) c1 c2 ...)
(syntax/loc x (let ((x v))
(if (memv x '(k ...))
(if (case-test x (k ...))
(begin e1 e2 ...)
(case x c1 c2 ...)))))
((_ v (bad e1 e2 ...) . rest)

518
src/mzscheme/src/string.c
View File

@ -329,14 +329,14 @@ scheme_init_string (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("make-string",
scheme_make_prim_w_arity(make_string,
"make-string",
1, 2),
scheme_make_noncm_prim(make_string,
"make-string",
1, 2),
env);
scheme_add_global_constant("string",
scheme_make_prim_w_arity(string,
"string",
0, -1),
scheme_make_noncm_prim(string,
"string",
0, -1),
env);
scheme_add_global_constant("string-length",
scheme_make_folding_prim(string_length,
@ -344,168 +344,168 @@ scheme_init_string (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("string-ref",
scheme_make_prim_w_arity(string_ref,
"string-ref",
2, 2),
scheme_make_noncm_prim(string_ref,
"string-ref",
2, 2),
env);
scheme_add_global_constant("string-set!",
scheme_make_prim_w_arity(string_set,
"string-set!",
3, 3),
scheme_make_noncm_prim(string_set,
"string-set!",
3, 3),
env);
scheme_add_global_constant("string=?",
scheme_make_prim_w_arity(string_eq,
"string=?",
2, -1),
scheme_make_noncm_prim(string_eq,
"string=?",
2, -1),
env);
scheme_add_global_constant("string-locale=?",
scheme_make_prim_w_arity(string_locale_eq,
"string-locale=?",
2, -1),
scheme_make_noncm_prim(string_locale_eq,
"string-locale=?",
2, -1),
env);
scheme_add_global_constant("string-ci=?",
scheme_make_prim_w_arity(string_ci_eq,
"string-ci=?",
2, -1),
scheme_make_noncm_prim(string_ci_eq,
"string-ci=?",
2, -1),
env);
scheme_add_global_constant("string-locale-ci=?",
scheme_make_prim_w_arity(string_locale_ci_eq,
"string-locale-ci=?",
2, -1),
scheme_make_noncm_prim(string_locale_ci_eq,
"string-locale-ci=?",
2, -1),
env);
scheme_add_global_constant("string<?",
scheme_make_prim_w_arity(string_lt,
"string<?",
2, -1),
scheme_make_noncm_prim(string_lt,
"string<?",
2, -1),
env);
scheme_add_global_constant("string-locale<?",
scheme_make_prim_w_arity(string_locale_lt,
"string-locale<?",
2, -1),
scheme_make_noncm_prim(string_locale_lt,
"string-locale<?",
2, -1),
env);
scheme_add_global_constant("string>?",
scheme_make_prim_w_arity(string_gt,
"string>?",
2, -1),
scheme_make_noncm_prim(string_gt,
"string>?",
2, -1),
env);
scheme_add_global_constant("string-locale>?",
scheme_make_prim_w_arity(string_locale_gt,
"string-locale>?",
2, -1),
scheme_make_noncm_prim(string_locale_gt,
"string-locale>?",
2, -1),
env);
scheme_add_global_constant("string<=?",
scheme_make_prim_w_arity(string_lt_eq,
"string<=?",
2, -1),
scheme_make_noncm_prim(string_lt_eq,
"string<=?",
2, -1),
env);
scheme_add_global_constant("string>=?",
scheme_make_prim_w_arity(string_gt_eq,
"string>=?",
2, -1),
scheme_make_noncm_prim(string_gt_eq,
"string>=?",
2, -1),
env);
scheme_add_global_constant("string-ci<?",
scheme_make_prim_w_arity(string_ci_lt,
"string-ci<?",
2, -1),
scheme_make_noncm_prim(string_ci_lt,
"string-ci<?",
2, -1),
env);
scheme_add_global_constant("string-locale-ci<?",
scheme_make_prim_w_arity(string_locale_ci_lt,
"string-locale-ci<?",
2, -1),
scheme_make_noncm_prim(string_locale_ci_lt,
"string-locale-ci<?",
2, -1),
env);
scheme_add_global_constant("string-ci>?",
scheme_make_prim_w_arity(string_ci_gt,
"string-ci>?",
2, -1),
scheme_make_noncm_prim(string_ci_gt,
"string-ci>?",
2, -1),
env);
scheme_add_global_constant("string-locale-ci>?",
scheme_make_prim_w_arity(string_locale_ci_gt,
"string-locale-ci>?",
2, -1),
scheme_make_noncm_prim(string_locale_ci_gt,
"string-locale-ci>?",
2, -1),
env);
scheme_add_global_constant("string-ci<=?",
scheme_make_prim_w_arity(string_ci_lt_eq,
"string-ci<=?",
2, -1),
scheme_make_noncm_prim(string_ci_lt_eq,
"string-ci<=?",
2, -1),
env);
scheme_add_global_constant("string-ci>=?",
scheme_make_prim_w_arity(string_ci_gt_eq,
"string-ci>=?",
2, -1),
scheme_make_noncm_prim(string_ci_gt_eq,
"string-ci>=?",
2, -1),
env);
scheme_add_global_constant("substring",
scheme_make_prim_w_arity(substring,
"substring",
2, 3),
scheme_make_noncm_prim(substring,
"substring",
2, 3),
env);
scheme_add_global_constant("string-append",
scheme_make_prim_w_arity(string_append,
"string-append",
0, -1),
scheme_make_noncm_prim(string_append,
"string-append",
0, -1),
env);
scheme_add_global_constant("string->list",
scheme_make_prim_w_arity(string_to_list,
"string->list",
1, 1),
scheme_make_noncm_prim(string_to_list,
"string->list",
1, 1),
env);
scheme_add_global_constant("list->string",
scheme_make_prim_w_arity(list_to_string,
"list->string",
1, 1),
scheme_make_noncm_prim(list_to_string,
"list->string",
1, 1),
env);
scheme_add_global_constant("string-copy",
scheme_make_prim_w_arity(string_copy,
"string-copy",
1, 1),
scheme_make_noncm_prim(string_copy,
"string-copy",
1, 1),
env);
scheme_add_global_constant("string-copy!",
scheme_make_prim_w_arity(string_copy_bang,
"string-copy!",
3, 5),
scheme_make_noncm_prim(string_copy_bang,
"string-copy!",
3, 5),
env);
scheme_add_global_constant("string-fill!",
scheme_make_prim_w_arity(string_fill,
"string-fill!",
2, 2),
scheme_make_noncm_prim(string_fill,
"string-fill!",
2, 2),
env);
scheme_add_global_constant("string->immutable-string",
scheme_make_prim_w_arity(string_to_immutable,
"string->immutable-string",
1, 1),
scheme_make_noncm_prim(string_to_immutable,
"string->immutable-string",
1, 1),
env);
scheme_add_global_constant("string-upcase",
scheme_make_prim_w_arity(string_upcase,
"string-upcase",
1, 1),
scheme_make_noncm_prim(string_upcase,
"string-upcase",
1, 1),
env);
scheme_add_global_constant("string-downcase",
scheme_make_prim_w_arity(string_downcase,
"string-downcase",
1, 1),
scheme_make_noncm_prim(string_downcase,
"string-downcase",
1, 1),
env);
scheme_add_global_constant("string-titlecase",
scheme_make_prim_w_arity(string_titlecase,
"string-titlecase",
1, 1),
scheme_make_noncm_prim(string_titlecase,
"string-titlecase",
1, 1),
env);
scheme_add_global_constant("string-foldcase",
scheme_make_prim_w_arity(string_foldcase,
"string-foldcase",
1, 1),
scheme_make_noncm_prim(string_foldcase,
"string-foldcase",
1, 1),
env);
scheme_add_global_constant("string-locale-upcase",
scheme_make_prim_w_arity(string_locale_upcase,
"string-locale-upcase",
1, 1),
scheme_make_noncm_prim(string_locale_upcase,
"string-locale-upcase",
1, 1),
env);
scheme_add_global_constant("string-locale-downcase",
scheme_make_prim_w_arity(string_locale_downcase,
"string-locale-downcase",
1, 1),
scheme_make_noncm_prim(string_locale_downcase,
"string-locale-downcase",
1, 1),
env);
scheme_add_global_constant("current-locale",
@ -514,20 +514,20 @@ scheme_init_string (Scheme_Env *env)
MZCONFIG_LOCALE),
env);
scheme_add_global_constant("locale-string-encoding",
scheme_make_prim_w_arity(locale_string_encoding,
"locale-string-encoding",
0, 0),
scheme_make_noncm_prim(locale_string_encoding,
"locale-string-encoding",
0, 0),
env);
scheme_add_global_constant("system-language+country",
scheme_make_prim_w_arity(system_language_country,
"system-language+country",
0, 0),
scheme_make_noncm_prim(system_language_country,
"system-language+country",
0, 0),
env);
scheme_add_global_constant("bytes-converter?",
scheme_make_prim_w_arity(byte_converter_p,
"bytes-converter?",
1, 1),
scheme_make_noncm_prim(byte_converter_p,
"bytes-converter?",
1, 1),
env);
scheme_add_global_constant("bytes-convert",
scheme_make_prim_w_arity2(byte_string_convert,
@ -542,14 +542,14 @@ scheme_init_string (Scheme_Env *env)
2, 2),
env);
scheme_add_global_constant("bytes-open-converter",
scheme_make_prim_w_arity(byte_string_open_converter,
"bytes-open-converter",
2, 2),
scheme_make_noncm_prim(byte_string_open_converter,
"bytes-open-converter",
2, 2),
env);
scheme_add_global_constant("bytes-close-converter",
scheme_make_prim_w_arity(byte_string_close_converter,
"bytes-close-converter",
1, 1),
scheme_make_noncm_prim(byte_string_close_converter,
"bytes-close-converter",
1, 1),
env);
scheme_add_global_constant("format",
@ -558,14 +558,14 @@ scheme_init_string (Scheme_Env *env)
1, -1, 1),
env);
scheme_add_global_constant("printf",
scheme_make_prim_w_arity(sch_printf,
"printf",
1, -1),
scheme_make_noncm_prim(sch_printf,
"printf",
1, -1),
env);
scheme_add_global_constant("fprintf",
scheme_make_prim_w_arity(sch_fprintf,
"fprintf",
2, -1),
scheme_make_noncm_prim(sch_fprintf,
"fprintf",
2, -1),
env);
scheme_add_global_constant("byte?",
@ -580,14 +580,14 @@ scheme_init_string (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("make-bytes",
scheme_make_prim_w_arity(make_byte_string,
"make-bytes",
1, 2),
scheme_make_noncm_prim(make_byte_string,
"make-bytes",
1, 2),
env);
scheme_add_global_constant("bytes",
scheme_make_prim_w_arity(byte_string,
"bytes",
0, -1),
scheme_make_noncm_prim(byte_string,
"bytes",
0, -1),
env);
scheme_add_global_constant("bytes-length",
scheme_make_folding_prim(byte_string_length,
@ -595,124 +595,124 @@ scheme_init_string (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("bytes-ref",
scheme_make_prim_w_arity(byte_string_ref,
"bytes-ref",
2, 2),
scheme_make_noncm_prim(byte_string_ref,
"bytes-ref",
2, 2),
env);
scheme_add_global_constant("bytes-set!",
scheme_make_prim_w_arity(byte_string_set,
"bytes-set!",
3, 3),
scheme_make_noncm_prim(byte_string_set,
"bytes-set!",
3, 3),
env);
scheme_add_global_constant("bytes=?",
scheme_make_prim_w_arity(byte_string_eq,
"bytes=?",
2, -1),
scheme_make_noncm_prim(byte_string_eq,
"bytes=?",
2, -1),
env);
scheme_add_global_constant("bytes<?",
scheme_make_prim_w_arity(byte_string_lt,
"bytes<?",
2, -1),
scheme_make_noncm_prim(byte_string_lt,
"bytes<?",
2, -1),
env);
scheme_add_global_constant("bytes>?",
scheme_make_prim_w_arity(byte_string_gt,
"bytes>?",
2, -1),
scheme_make_noncm_prim(byte_string_gt,
"bytes>?",
2, -1),
env);
scheme_add_global_constant("subbytes",
scheme_make_prim_w_arity(byte_substring,
"subbytes",
2, 3),
scheme_make_noncm_prim(byte_substring,
"subbytes",
2, 3),
env);
scheme_add_global_constant("bytes-append",
scheme_make_prim_w_arity(byte_string_append,
"bytes-append",
0, -1),
scheme_make_noncm_prim(byte_string_append,
"bytes-append",
0, -1),
env);
scheme_add_global_constant("bytes->list",
scheme_make_prim_w_arity(byte_string_to_list,
"bytes->list",
1, 1),
scheme_make_noncm_prim(byte_string_to_list,
"bytes->list",
1, 1),
env);
scheme_add_global_constant("list->bytes",
scheme_make_prim_w_arity(list_to_byte_string,
"list->bytes",
1, 1),
scheme_make_noncm_prim(list_to_byte_string,
"list->bytes",
1, 1),
env);
scheme_add_global_constant("bytes-copy",
scheme_make_prim_w_arity(byte_string_copy,
"bytes-copy",
1, 1),
scheme_make_noncm_prim(byte_string_copy,
"bytes-copy",
1, 1),
env);
scheme_add_global_constant("bytes-copy!",
scheme_make_prim_w_arity(byte_string_copy_bang,
"bytes-copy!",
3, 5),
scheme_make_noncm_prim(byte_string_copy_bang,
"bytes-copy!",
3, 5),
env);
scheme_add_global_constant("bytes-fill!",
scheme_make_prim_w_arity(byte_string_fill,
"bytes-fill!",
2, 2),
scheme_make_noncm_prim(byte_string_fill,
"bytes-fill!",
2, 2),
env);
scheme_add_global_constant("bytes->immutable-bytes",
scheme_make_prim_w_arity(byte_string_to_immutable,
"bytes->immutable-bytes",
1, 1),
scheme_make_noncm_prim(byte_string_to_immutable,
"bytes->immutable-bytes",
1, 1),
env);
scheme_add_global_constant("bytes-utf-8-index",
scheme_make_prim_w_arity(byte_string_utf8_index,
"bytes-utf-8-index",
2, 4),
scheme_make_noncm_prim(byte_string_utf8_index,
"bytes-utf-8-index",
2, 4),
env);
scheme_add_global_constant("bytes-utf-8-length",
scheme_make_prim_w_arity(byte_string_utf8_length,
"bytes-utf-8-length",
1, 4),
scheme_make_noncm_prim(byte_string_utf8_length,
"bytes-utf-8-length",
1, 4),
env);
scheme_add_global_constant("bytes-utf-8-ref",
scheme_make_prim_w_arity(byte_string_utf8_ref,
"bytes-utf-8-ref",
2, 4),
scheme_make_noncm_prim(byte_string_utf8_ref,
"bytes-utf-8-ref",
2, 4),
env);
scheme_add_global_constant("bytes->string/utf-8",
scheme_make_prim_w_arity(byte_string_to_char_string,
"bytes->string/utf-8",
1, 4),
scheme_make_noncm_prim(byte_string_to_char_string,
"bytes->string/utf-8",
1, 4),
env);
scheme_add_global_constant("bytes->string/locale",
scheme_make_prim_w_arity(byte_string_to_char_string_locale,
"bytes->string/locale",
1, 4),
scheme_make_noncm_prim(byte_string_to_char_string_locale,
"bytes->string/locale",
1, 4),
env);
scheme_add_global_constant("bytes->string/latin-1",
scheme_make_prim_w_arity(byte_string_to_char_string_latin1,
"bytes->string/latin-1",
1, 4),
scheme_make_noncm_prim(byte_string_to_char_string_latin1,
"bytes->string/latin-1",
1, 4),
env);
scheme_add_global_constant("string->bytes/utf-8",
scheme_make_prim_w_arity(char_string_to_byte_string,
"string->bytes/utf-8",
1, 4),
scheme_make_noncm_prim(char_string_to_byte_string,
"string->bytes/utf-8",
1, 4),
env);
scheme_add_global_constant("string->bytes/locale",
scheme_make_prim_w_arity(char_string_to_byte_string_locale,
"string->bytes/locale",
1, 4),
scheme_make_noncm_prim(char_string_to_byte_string_locale,
"string->bytes/locale",
1, 4),
env);
scheme_add_global_constant("string->bytes/latin-1",
scheme_make_prim_w_arity(char_string_to_byte_string_latin1,
"string->bytes/latin-1",
1, 4),
scheme_make_noncm_prim(char_string_to_byte_string_latin1,
"string->bytes/latin-1",
1, 4),
env);
scheme_add_global_constant("string-utf-8-length",
scheme_make_prim_w_arity(char_string_utf8_length,
"string-utf-8-length",
1, 3),
scheme_make_noncm_prim(char_string_utf8_length,
"string-utf-8-length",
1, 3),
env);
@ -720,38 +720,38 @@ scheme_init_string (Scheme_Env *env)
more problems than it solves... */
scheme_add_global_constant("version",
scheme_make_prim_w_arity(version,
"version",
0, 0),
scheme_make_noncm_prim(version,
"version",
0, 0),
env);
scheme_add_global_constant("banner",
scheme_make_prim_w_arity(banner,
"banner",
0, 0),
scheme_make_noncm_prim(banner,
"banner",
0, 0),
env);
scheme_add_global_constant("getenv",
scheme_make_prim_w_arity(sch_getenv,
"getenv",
1, 1),
scheme_make_noncm_prim(sch_getenv,
"getenv",
1, 1),
env);
scheme_add_global_constant("putenv",
scheme_make_prim_w_arity(sch_putenv,
"putenv",
2, 2),
scheme_make_noncm_prim(sch_putenv,
"putenv",
2, 2),
env);
/* Don't make these folding, since they're platform-specific: */
scheme_add_global_constant("system-type",
scheme_make_prim_w_arity(system_type,
"system-type",
0, 1),
scheme_make_noncm_prim(system_type,
"system-type",
0, 1),
env);
scheme_add_global_constant("system-library-subpath",
scheme_make_prim_w_arity(system_library_subpath,
"system-library-subpath",
0, 1),
scheme_make_noncm_prim(system_library_subpath,
"system-library-subpath",
0, 1),
env);
scheme_add_global_constant("current-command-line-arguments",
@ -765,45 +765,6 @@ scheme_init_string (Scheme_Env *env)
#endif
}
void
scheme_init_getenv(void)
{
#ifndef GETENV_FUNCTION
FILE *f = fopen("Environment", "r");
if (f) {
Scheme_Object *p = scheme_make_file_input_port(f);
mz_jmp_buf *savebuf, newbuf;
savebuf = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
while (1) {
Scheme_Object *v = scheme_read(p);
if (SCHEME_EOFP(v))
break;
if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v))
&& SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) {
Scheme_Object *key = SCHEME_CAR(v);
Scheme_Object *val = SCHEME_CADR(v);
if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) {
Scheme_Object *a[2];
a[0] = key;
a[1] = val;
sch_putenv(2, a);
v = NULL;
}
}
if (v)
scheme_signal_error("bad environment specification: %V", v);
}
}
scheme_current_thread->error_buf = savebuf;
scheme_close_input_port(p);
}
#endif
}
/**********************************************************************/
/* UTF-8 char constructors */
/**********************************************************************/
@ -1940,6 +1901,53 @@ static int mzPUTENV(char *var, char *val, char *together)
# define mzPUTENV(var, val, s) MSC_IZE(putenv)(s)
#endif
void
scheme_init_getenv(void)
{
#ifndef GETENV_FUNCTION
FILE *f = fopen("Environment", "r");
if (f) {
Scheme_Object *p = scheme_make_file_input_port(f);
mz_jmp_buf *savebuf, newbuf;
savebuf = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
while (1) {
Scheme_Object *v = scheme_read(p);
if (SCHEME_EOFP(v))
break;
if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v))
&& SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) {
Scheme_Object *key = SCHEME_CAR(v);
Scheme_Object *val = SCHEME_CADR(v);
if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) {
Scheme_Object *a[2];
a[0] = key;
a[1] = val;
sch_putenv(2, a);
v = NULL;
}
}
if (v)
scheme_signal_error("bad environment specification: %V", v);
}
}
scheme_current_thread->error_buf = savebuf;
scheme_close_input_port(p);
if (scheme_hash_get(putenv_str_table, (Scheme_Object *)"PLTNOMZJIT")) {
scheme_set_startup_use_jit(0);
}
}
#else
if (mzGETENV("PLTNOMZJIT")) {
scheme_set_startup_use_jit(0);
}
#endif
}
static Scheme_Object *sch_getenv(int argc, Scheme_Object *argv[])
{
char *s;

90
src/mzscheme/src/stxobj.c
View File

@ -364,78 +364,78 @@ void scheme_init_stx(Scheme_Env *env)
env);
scheme_add_global_constant("syntax-original?",
scheme_make_prim_w_arity(syntax_original_p,
"syntax-original?",
1, 1),
scheme_make_noncm_prim(syntax_original_p,
"syntax-original?",
1, 1),
env);
scheme_add_global_constant("syntax-property",
scheme_make_prim_w_arity(syntax_property,
"syntax-property",
2, 3),
scheme_make_noncm_prim(syntax_property,
"syntax-property",
2, 3),
env);
scheme_add_global_constant("syntax-property-symbol-keys",
scheme_make_prim_w_arity(syntax_property_keys,
"syntax-property-symbol-keys",
1, 1),
scheme_make_noncm_prim(syntax_property_keys,
"syntax-property-symbol-keys",
1, 1),
env);
scheme_add_global_constant("syntax-track-origin",
scheme_make_prim_w_arity(syntax_track_origin,
"syntax-track-origin",
3, 3),
scheme_make_noncm_prim(syntax_track_origin,
"syntax-track-origin",
3, 3),
env);
scheme_add_global_constant("bound-identifier=?",
scheme_make_prim_w_arity(bound_eq,
"bound-identifier=?",
2, 2),
scheme_make_noncm_prim(bound_eq,
"bound-identifier=?",
2, 2),
env);
scheme_add_global_constant("free-identifier=?",
scheme_make_prim_w_arity(free_eq,
"free-identifier=?",
2, 2),
scheme_make_noncm_prim(free_eq,
"free-identifier=?",
2, 2),
env);
scheme_add_global_constant("module-identifier=?",
scheme_make_prim_w_arity(module_eq,
"module-identifier=?",
2, 2),
scheme_make_noncm_prim(module_eq,
"module-identifier=?",
2, 2),
env);
scheme_add_global_constant("module-transformer-identifier=?",
scheme_make_prim_w_arity(module_trans_eq,
"module-transformer-identifier=?",
2, 2),
scheme_make_noncm_prim(module_trans_eq,
"module-transformer-identifier=?",
2, 2),
env);
scheme_add_global_constant("module-template-identifier=?",
scheme_make_prim_w_arity(module_templ_eq,
"module-template-identifier=?",
2, 2),
scheme_make_noncm_prim(module_templ_eq,
"module-template-identifier=?",
2, 2),
env);
scheme_add_global_constant("identifier-binding",
scheme_make_prim_w_arity(module_binding,
"identifier-binding",
1, 1),
scheme_make_noncm_prim(module_binding,
"identifier-binding",
1, 1),
env);
scheme_add_global_constant("identifier-transformer-binding",
scheme_make_prim_w_arity(module_trans_binding,
"identifier-transformer-binding",
1, 1),
scheme_make_noncm_prim(module_trans_binding,
"identifier-transformer-binding",
1, 1),
env);
scheme_add_global_constant("identifier-template-binding",
scheme_make_prim_w_arity(module_templ_binding,
"identifier-template-binding",
1, 1),
scheme_make_noncm_prim(module_templ_binding,
"identifier-template-binding",
1, 1),
env);
scheme_add_global_constant("identifier-binding-export-position",
scheme_make_prim_w_arity(module_binding_pos,
"identifier-binding-export-position",
1, 1),
scheme_make_noncm_prim(module_binding_pos,
"identifier-binding-export-position",
1, 1),
env);
scheme_add_global_constant("identifier-transformer-binding-export-position",
scheme_make_prim_w_arity(module_trans_binding_pos,
"identifier-transformer-binding-export-position",
1, 1),
scheme_make_noncm_prim(module_trans_binding_pos,
"identifier-transformer-binding-export-position",
1, 1),
env);
scheme_add_global_constant("syntax-source-module",
@ -445,9 +445,9 @@ void scheme_init_stx(Scheme_Env *env)
env);
scheme_add_global_constant("syntax-recertify",
scheme_make_prim_w_arity(syntax_recertify,
"syntax-recertify",
4, 4),
scheme_make_noncm_prim(syntax_recertify,
"syntax-recertify",
4, 4),
env);
REGISTER_SO(barrier_symbol);

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

@ -44,170 +44,171 @@ enum {
scheme_cont_type, /* 30 */
scheme_escaping_cont_type, /* 31 */
scheme_proc_struct_type, /* 32 */
scheme_native_closure_type, /* 33 */
/* structure types (overlaps with procs) */
scheme_structure_type, /* 33 */
scheme_structure_type, /* 34 */
/* basic types */
scheme_char_type, /* 34 */
scheme_integer_type, /* 35 */
scheme_bignum_type, /* 36 */
scheme_rational_type, /* 37 */
scheme_float_type, /* 38 */
scheme_double_type, /* 39 */
scheme_complex_izi_type, /* 40 */
scheme_complex_type, /* 41 */
scheme_char_string_type, /* 42 */
scheme_byte_string_type, /* 43 */
scheme_path_type, /* 44 */
scheme_symbol_type, /* 45 */
scheme_keyword_type, /* 46 */
scheme_null_type, /* 47 */
scheme_pair_type, /* 48 */
scheme_vector_type, /* 49 */
scheme_inspector_type, /* 50 */
scheme_input_port_type, /* 51 */
scheme_output_port_type, /* 52 */
scheme_eof_type, /* 53 */
scheme_true_type, /* 54 */
scheme_false_type, /* 55 */
scheme_void_type, /* 56 */
scheme_syntax_compiler_type, /* 57 */
scheme_macro_type, /* 58 */
scheme_box_type, /* 59 */
scheme_thread_type, /* 60 */
scheme_stx_offset_type, /* 61 */
scheme_cont_mark_set_type, /* 62 */
scheme_sema_type, /* 63 */
scheme_hash_table_type, /* 64 */
scheme_cpointer_type, /* 65 */
scheme_weak_box_type, /* 66 */
scheme_ephemeron_type, /* 67 */
scheme_struct_type_type, /* 68 */
scheme_module_index_type, /* 69 */
scheme_set_macro_type, /* 70 */
scheme_listener_type, /* 71 */
scheme_namespace_type, /* 72 */
scheme_config_type, /* 73 */
scheme_stx_type, /* 74 */
scheme_will_executor_type, /* 75 */
scheme_custodian_type, /* 76 */
scheme_random_state_type, /* 77 */
scheme_regexp_type, /* 78 */
scheme_bucket_type, /* 79 */
scheme_bucket_table_type, /* 80 */
scheme_subprocess_type, /* 81 */
scheme_compilation_top_type, /* 82 */
scheme_wrap_chunk_type, /* 83 */
scheme_eval_waiting_type, /* 84 */
scheme_tail_call_waiting_type, /* 85 */
scheme_undefined_type, /* 86 */
scheme_struct_property_type, /* 87 */
scheme_multiple_values_type, /* 88 */
scheme_placeholder_type, /* 89 */
scheme_case_lambda_sequence_type, /* 90 */
scheme_begin0_sequence_type, /* 91 */
scheme_rename_table_type, /* 92 */
scheme_module_type, /* 93 */
scheme_svector_type, /* 94 */
scheme_lazy_macro_type, /* 95 */
scheme_resolve_prefix_type, /* 96 */
scheme_security_guard_type, /* 97 */
scheme_indent_type, /* 98 */
scheme_udp_type, /* 99 */
scheme_udp_evt_type, /* 100 */
scheme_tcp_accept_evt_type, /* 101 */
scheme_id_macro_type, /* 102 */
scheme_evt_set_type, /* 103 */
scheme_wrap_evt_type, /* 104 */
scheme_handle_evt_type, /* 105 */
scheme_nack_guard_evt_type, /* 106 */
scheme_semaphore_repost_type, /* 107 */
scheme_channel_type, /* 108 */
scheme_channel_put_type, /* 109 */
scheme_thread_resume_type, /* 110 */
scheme_thread_suspend_type, /* 111 */
scheme_thread_dead_type, /* 112 */
scheme_poll_evt_type, /* 113 */
scheme_nack_evt_type, /* 114 */
scheme_module_registry_type, /* 115 */
scheme_thread_set_type, /* 116 */
scheme_string_converter_type, /* 117 */
scheme_alarm_type, /* 118 */
scheme_thread_cell_type, /* 119 */
scheme_channel_syncer_type, /* 120 */
scheme_special_comment_type, /* 121 */
scheme_write_evt_type, /* 122 */
scheme_always_evt_type, /* 123 */
scheme_never_evt_type, /* 124 */
scheme_progress_evt_type, /* 125 */
scheme_certifications_type, /* 126 */
scheme_already_comp_type, /* 127 */
scheme_readtable_type, /* 128 */
scheme_intdef_context_type, /* 129 */
scheme_lexical_rib_type, /* 130 */
scheme_thread_cell_values_type, /* 131 */
scheme_global_ref_type, /* 132 */
scheme_cont_mark_chain_type, /* 133 */
scheme_char_type, /* 35 */
scheme_integer_type, /* 36 */
scheme_bignum_type, /* 37 */
scheme_rational_type, /* 38 */
scheme_float_type, /* 39 */
scheme_double_type, /* 40 */
scheme_complex_izi_type, /* 41 */
scheme_complex_type, /* 42 */
scheme_char_string_type, /* 43 */
scheme_byte_string_type, /* 44 */
scheme_path_type, /* 45 */
scheme_symbol_type, /* 46 */
scheme_keyword_type, /* 47 */
scheme_null_type, /* 48 */
scheme_pair_type, /* 49 */
scheme_vector_type, /* 50 */
scheme_inspector_type, /* 51 */
scheme_input_port_type, /* 52 */
scheme_output_port_type, /* 53 */
scheme_eof_type, /* 54 */
scheme_true_type, /* 55 */
scheme_false_type, /* 56 */
scheme_void_type, /* 57 */
scheme_syntax_compiler_type, /* 58 */
scheme_macro_type, /* 59 */
scheme_box_type, /* 60 */
scheme_thread_type, /* 61 */
scheme_stx_offset_type, /* 62 */
scheme_cont_mark_set_type, /* 63 */
scheme_sema_type, /* 64 */
scheme_hash_table_type, /* 65 */
scheme_cpointer_type, /* 66 */
scheme_weak_box_type, /* 67 */
scheme_ephemeron_type, /* 68 */
scheme_struct_type_type, /* 69 */
scheme_module_index_type, /* 70 */
scheme_set_macro_type, /* 71 */
scheme_listener_type, /* 72 */
scheme_namespace_type, /* 73 */
scheme_config_type, /* 74 */
scheme_stx_type, /* 75 */
scheme_will_executor_type, /* 76 */
scheme_custodian_type, /* 77 */
scheme_random_state_type, /* 78 */
scheme_regexp_type, /* 79 */
scheme_bucket_type, /* 80 */
scheme_bucket_table_type, /* 81 */
scheme_subprocess_type, /* 82 */
scheme_compilation_top_type, /* 83 */
scheme_wrap_chunk_type, /* 84 */
scheme_eval_waiting_type, /* 85 */
scheme_tail_call_waiting_type, /* 86 */
scheme_undefined_type, /* 87 */
scheme_struct_property_type, /* 88 */
scheme_multiple_values_type, /* 89 */
scheme_placeholder_type, /* 90 */
scheme_case_lambda_sequence_type, /* 91 */
scheme_begin0_sequence_type, /* 92 */
scheme_rename_table_type, /* 93 */
scheme_module_type, /* 94 */
scheme_svector_type, /* 95 */
scheme_lazy_macro_type, /* 96 */
scheme_resolve_prefix_type, /* 97 */
scheme_security_guard_type, /* 98 */
scheme_indent_type, /* 99 */
scheme_udp_type, /* 100 */
scheme_udp_evt_type, /* 101 */
scheme_tcp_accept_evt_type, /* 102 */
scheme_id_macro_type, /* 103 */
scheme_evt_set_type, /* 104 */
scheme_wrap_evt_type, /* 105 */
scheme_handle_evt_type, /* 106 */
scheme_nack_guard_evt_type, /* 107 */
scheme_semaphore_repost_type, /* 108 */
scheme_channel_type, /* 109 */
scheme_channel_put_type, /* 110 */
scheme_thread_resume_type, /* 111 */
scheme_thread_suspend_type, /* 112 */
scheme_thread_dead_type, /* 113 */
scheme_poll_evt_type, /* 114 */
scheme_nack_evt_type, /* 115 */
scheme_module_registry_type, /* 116 */
scheme_thread_set_type, /* 117 */
scheme_string_converter_type, /* 118 */
scheme_alarm_type, /* 119 */
scheme_thread_cell_type, /* 120 */
scheme_channel_syncer_type, /* 121 */
scheme_special_comment_type, /* 122 */
scheme_write_evt_type, /* 123 */
scheme_always_evt_type, /* 124 */
scheme_never_evt_type, /* 125 */
scheme_progress_evt_type, /* 126 */
scheme_certifications_type, /* 127 */
scheme_already_comp_type, /* 128 */
scheme_readtable_type, /* 129 */
scheme_intdef_context_type, /* 130 */
scheme_lexical_rib_type, /* 131 */
scheme_thread_cell_values_type, /* 132 */
scheme_global_ref_type, /* 133 */
scheme_cont_mark_chain_type, /* 134 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 134 */
_scheme_last_normal_type_, /* 135 */
scheme_rt_comp_env, /* 135 */
scheme_rt_constant_binding, /* 136 */
scheme_rt_resolve_info, /* 137 */
scheme_rt_compile_info, /* 138 */
scheme_rt_cont_mark, /* 139 */
scheme_rt_saved_stack, /* 140 */
scheme_rt_reply_item, /* 141 */
scheme_rt_closure_info, /* 142 */
scheme_rt_overflow, /* 143 */
scheme_rt_dyn_wind_cell, /* 144 */
scheme_rt_dyn_wind_info, /* 145 */
scheme_rt_dyn_wind, /* 146 */
scheme_rt_dup_check, /* 147 */
scheme_rt_thread_memory, /* 148 */
scheme_rt_input_file, /* 149 */
scheme_rt_input_fd, /* 150 */
scheme_rt_oskit_console_input, /* 151 */
scheme_rt_tested_input_file, /* 152 */
scheme_rt_tested_output_file, /* 153 */
scheme_rt_indexed_string, /* 154 */
scheme_rt_output_file, /* 155 */
scheme_rt_load_handler_data, /* 156 */
scheme_rt_pipe, /* 157 */
scheme_rt_beos_process, /* 158 */
scheme_rt_system_child, /* 159 */
scheme_rt_tcp, /* 160 */
scheme_rt_write_data, /* 161 */
scheme_rt_tcp_select_info, /* 162 */
scheme_rt_namespace_option, /* 163 */
scheme_rt_param_data, /* 164 */
scheme_rt_will, /* 165 */
scheme_rt_will_registration, /* 166 */
scheme_rt_struct_proc_info, /* 167 */
scheme_rt_linker_name, /* 168 */
scheme_rt_param_map, /* 169 */
scheme_rt_finalization, /* 170 */
scheme_rt_finalizations, /* 171 */
scheme_rt_cpp_object, /* 172 */
scheme_rt_cpp_array_object, /* 173 */
scheme_rt_stack_object, /* 174 */
scheme_rt_preallocated_object, /* 175 */
scheme_thread_hop_type, /* 176 */
scheme_rt_srcloc, /* 177 */
scheme_rt_evt, /* 178 */
scheme_rt_syncing, /* 179 */
scheme_rt_comp_prefix, /* 180 */
scheme_rt_user_input, /* 181 */
scheme_rt_user_output, /* 182 */
scheme_rt_compact_port, /* 183 */
scheme_rt_read_special_dw, /* 184 */
scheme_rt_regwork, /* 185 */
scheme_rt_buf_holder, /* 186 */
scheme_rt_parameterization, /* 187 */
scheme_rt_print_params, /* 188 */
scheme_rt_read_params, /* 189 */
scheme_rt_comp_env, /* 136 */
scheme_rt_constant_binding, /* 137 */
scheme_rt_resolve_info, /* 138 */
scheme_rt_compile_info, /* 139 */
scheme_rt_cont_mark, /* 140 */
scheme_rt_saved_stack, /* 141 */
scheme_rt_reply_item, /* 142 */
scheme_rt_closure_info, /* 143 */
scheme_rt_overflow, /* 144 */
scheme_rt_dyn_wind_cell, /* 145 */
scheme_rt_dyn_wind_info, /* 146 */
scheme_rt_dyn_wind, /* 147 */
scheme_rt_dup_check, /* 148 */
scheme_rt_thread_memory, /* 149 */
scheme_rt_input_file, /* 150 */
scheme_rt_input_fd, /* 151 */
scheme_rt_oskit_console_input, /* 152 */
scheme_rt_tested_input_file, /* 153 */
scheme_rt_tested_output_file, /* 154 */
scheme_rt_indexed_string, /* 155 */
scheme_rt_output_file, /* 156 */
scheme_rt_load_handler_data, /* 157 */
scheme_rt_pipe, /* 158 */
scheme_rt_beos_process, /* 159 */
scheme_rt_system_child, /* 160 */
scheme_rt_tcp, /* 161 */
scheme_rt_write_data, /* 162 */
scheme_rt_tcp_select_info, /* 163 */
scheme_rt_namespace_option, /* 164 */
scheme_rt_param_data, /* 165 */
scheme_rt_will, /* 166 */
scheme_rt_will_registration, /* 167 */
scheme_rt_struct_proc_info, /* 168 */
scheme_rt_linker_name, /* 169 */
scheme_rt_param_map, /* 170 */
scheme_rt_finalization, /* 171 */
scheme_rt_finalizations, /* 172 */
scheme_rt_cpp_object, /* 173 */
scheme_rt_cpp_array_object, /* 174 */
scheme_rt_stack_object, /* 175 */
scheme_rt_preallocated_object, /* 176 */
scheme_thread_hop_type, /* 177 */
scheme_rt_srcloc, /* 178 */
scheme_rt_evt, /* 179 */
scheme_rt_syncing, /* 180 */
scheme_rt_comp_prefix, /* 181 */
scheme_rt_user_input, /* 182 */
scheme_rt_user_output, /* 183 */
scheme_rt_compact_port, /* 184 */
scheme_rt_read_special_dw, /* 185 */
scheme_rt_regwork, /* 186 */
scheme_rt_buf_holder, /* 187 */
scheme_rt_parameterization, /* 188 */
scheme_rt_print_params, /* 189 */
scheme_rt_read_params, /* 190 */
#endif
_scheme_last_type_

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

@ -225,6 +225,9 @@ static void clean_symbol_table(void)
clean_one_symbol_table(scheme_keyword_table);
clean_one_symbol_table(scheme_parallel_symbol_table);
scheme_clear_ephemerons();
# ifdef MZ_USE_JIT
scheme_clean_native_symtab();
# endif
}
#endif
@ -283,18 +286,18 @@ scheme_init_symbol (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("string->symbol",
scheme_make_prim_w_arity(string_to_symbol_prim,
"string->symbol",
1, 1), env);
scheme_make_noncm_prim(string_to_symbol_prim,
"string->symbol",
1, 1), env);
scheme_add_global_constant("string->uninterned-symbol",
scheme_make_prim_w_arity(string_to_uninterned_symbol_prim,
"string->uninterned-symbol",
1, 1),
scheme_make_noncm_prim(string_to_uninterned_symbol_prim,
"string->uninterned-symbol",
1, 1),
env);
scheme_add_global_constant("symbol->string",
scheme_make_prim_w_arity(symbol_to_string_prim,
"symbol->string",
1, 1),
scheme_make_noncm_prim(symbol_to_string_prim,
"symbol->string",
1, 1),
env);
scheme_add_global_constant("keyword?",
@ -303,19 +306,19 @@ scheme_init_symbol (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("string->keyword",
scheme_make_prim_w_arity(string_to_keyword_prim,
"string->keyword",
1, 1), env);
scheme_make_noncm_prim(string_to_keyword_prim,
"string->keyword",
1, 1), env);
scheme_add_global_constant("keyword->string",
scheme_make_prim_w_arity(keyword_to_string_prim,
"keyword->string",
1, 1),
scheme_make_noncm_prim(keyword_to_string_prim,
"keyword->string",
1, 1),
env);
scheme_add_global_constant("gensym",
scheme_make_prim_w_arity(gensym,
"gensym",
0, 1),
scheme_make_noncm_prim(gensym,
"gensym",
0, 1),
env);
}

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

@ -42,6 +42,7 @@ Scheme_Object scheme_undefined[1];
Scheme_Syntax_Resolver scheme_syntax_resolvers[_COUNT_EXPD_];
Scheme_Syntax_Validater scheme_syntax_validaters[_COUNT_EXPD_];
Scheme_Syntax_Executer scheme_syntax_executers[_COUNT_EXPD_];
Scheme_Syntax_Jitter scheme_syntax_jitters[_COUNT_EXPD_];
int scheme_syntax_protect_afters[_COUNT_EXPD_];
/* locals */
@ -132,6 +133,16 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, char *stack
static void bangboxvalue_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes);
static Scheme_Object *define_values_jit(Scheme_Object *data);
static Scheme_Object *ref_jit(Scheme_Object *data);
static Scheme_Object *set_jit(Scheme_Object *data);
static Scheme_Object *define_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 *begin0_jit(Scheme_Object *data);
static Scheme_Object *quote_syntax_jit(Scheme_Object *data);
static Scheme_Object *bangboxvalue_jit(Scheme_Object *data);
static Scheme_Object *named_let_syntax (Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Compile_Expand_Info *rec, int drec);
@ -215,35 +226,35 @@ scheme_init_syntax (Scheme_Env *env)
scheme_register_syntax(DEFINE_VALUES_EXPD,
define_values_resolve, define_values_validate,
define_values_execute, 1);
define_values_execute, define_values_jit, 1);
scheme_register_syntax(SET_EXPD,
set_resolve, set_validate,
set_execute, 2);
set_execute, set_jit, 2);
scheme_register_syntax(REF_EXPD,
ref_resolve, ref_validate,
ref_execute, 0);
ref_execute, ref_jit, 0);
scheme_register_syntax(DEFINE_SYNTAX_EXPD,
define_syntaxes_resolve, define_syntaxes_validate,
define_syntaxes_execute, 4);
define_syntaxes_execute, define_syntaxes_jit, 4);
scheme_register_syntax(DEFINE_FOR_SYNTAX_EXPD,
define_for_syntaxes_resolve, define_for_syntaxes_validate,
define_for_syntaxes_execute, 4);
define_for_syntaxes_execute, define_for_syntaxes_jit, 4);
scheme_register_syntax(CASE_LAMBDA_EXPD,
case_lambda_resolve, case_lambda_validate,
case_lambda_execute, -1);
case_lambda_execute, case_lambda_jit, -1);
scheme_register_syntax(BEGIN0_EXPD,
begin0_resolve, begin0_validate,
begin0_execute, -1);
begin0_execute, begin0_jit, -1);
scheme_register_syntax(QUOTE_SYNTAX_EXPD,
NULL, quote_syntax_validate,
quote_syntax_execute, 2);
quote_syntax_execute, quote_syntax_jit, 2);
scheme_register_syntax(BOXENV_EXPD,
NULL, bangboxenv_validate,
bangboxenv_execute, 1);
bangboxenv_execute, NULL, 1);
scheme_register_syntax(BOXVAL_EXPD,
NULL, bangboxvalue_validate,
bangboxvalue_execute, 2);
bangboxvalue_execute, bangboxvalue_jit, 2);
scheme_install_type_writer(scheme_let_value_type, write_let_value);
scheme_install_type_reader(scheme_let_value_type, read_let_value);
@ -722,6 +733,16 @@ define_values_execute(Scheme_Object *data)
return define_execute(SCHEME_CAR(data), SCHEME_CDR(data), 0, NULL, NULL);
}
static Scheme_Object *define_values_jit(Scheme_Object *data)
{
Scheme_Object *orig = SCHEME_CDR(data), *naya;
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else
return scheme_make_pair(SCHEME_CAR(data), naya);
}
static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
{
@ -1161,6 +1182,23 @@ set_execute (Scheme_Object *data)
return scheme_void;
}
static Scheme_Object *set_jit(Scheme_Object *data)
{
Scheme_Object *orig_val, *naya_val;
orig_val = SCHEME_CDR(data);
orig_val = SCHEME_CDR(orig_val);
naya_val = scheme_jit_expr(orig_val);
if (SAME_OBJ(naya_val, orig_val))
return data;
else
return scheme_make_pair(SCHEME_CAR(data),
scheme_make_pair(SCHEME_CADR(data),
naya_val));
}
static void set_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
{
@ -1400,6 +1438,11 @@ ref_execute (Scheme_Object *tl)
return o;
}
static Scheme_Object *ref_jit(Scheme_Object *data)
{
return data;
}
static void ref_validate(Scheme_Object *tl, Mz_CPort *port,
char *stack, int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
{
@ -1500,11 +1543,45 @@ static Scheme_Object *
case_lambda_execute(Scheme_Object *expr)
{
Scheme_Case_Lambda *seqin, *seqout;
int i;
int i, cnt;
Scheme_Thread *p = scheme_current_thread;
seqin = (Scheme_Case_Lambda *)expr;
#ifdef MZ_USE_JIT
if (seqin->native_code) {
Scheme_Native_Closure_Data *ndata;
Scheme_Native_Closure *nc, *na;
Scheme_Closure_Data *data;
Scheme_Object *val;
GC_CAN_IGNORE Scheme_Object **runstack;
GC_CAN_IGNORE mzshort *map;
int j, jcnt;
ndata = seqin->native_code;
nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata);
cnt = seqin->count;
for (i = 0; i < cnt; i++) {
val = seqin->array[i];
if (!SCHEME_PROCP(val)) {
data = (Scheme_Closure_Data *)val;
na = (Scheme_Native_Closure *)scheme_make_native_closure(data->native_code);
runstack = MZ_RUNSTACK;
jcnt = data->closure_size;
map = data->closure_map;
for (j = 0; j < jcnt; j++) {
na->vals[j] = runstack[map[j]];
}
val = (Scheme_Object *)na;
}
nc->vals[i] = val;
}
return (Scheme_Object *)nc;
}
#endif
seqout = (Scheme_Case_Lambda *)
scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
+ (seqin->count - 1) * sizeof(Scheme_Object *));
@ -1512,7 +1589,8 @@ case_lambda_execute(Scheme_Object *expr)
seqout->count = seqin->count;
seqout->name = seqin->name;
for (i = 0; i < seqin->count; i++) {
cnt = seqin->count;
for (i = 0; i < cnt; i++) {
if (SAME_TYPE(SCHEME_TYPE(seqin->array[i]), scheme_closure_type)) {
/* An empty closure, created at compile time */
seqout->array[i] = seqin->array[i];
@ -1526,6 +1604,76 @@ case_lambda_execute(Scheme_Object *expr)
return (Scheme_Object *)seqout;
}
static Scheme_Object *case_lambda_jit(Scheme_Object *expr)
{
#ifdef MZ_USE_JIT
Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr;
if (!seqin->native_code) {
Scheme_Case_Lambda *seqout;
Scheme_Native_Closure_Data *ndata;
Scheme_Object *val;
int i, cnt, size, all_closed = 1;
cnt = seqin->count;
size = sizeof(Scheme_Case_Lambda) + ((cnt - 1) * sizeof(Scheme_Object *));
seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size);
memcpy(seqout, seqin, size);
for (i = 0; i < cnt; i++) {
val = seqout->array[i];
if (SCHEME_PROCP(val)) {
/* Undo creation of empty closure */
val = (Scheme_Object *)((Scheme_Closure *)val)->code;
seqout->array[i] = val;
}
if (((Scheme_Closure_Data *)val)->closure_size)
all_closed = 0;
}
/* Generating the code may cause empty closures to be formed: */
ndata = scheme_generate_case_lambda(seqout);
seqout->native_code = ndata;
if (all_closed) {
/* Native closures do not refer back to the original bytecode,
so no need to worry about clearing the reference. */
Scheme_Native_Closure *nc;
nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata);
for (i = 0; i < cnt; i++) {
val = seqout->array[i];
if (!SCHEME_PROCP(val)) {
val = scheme_make_native_closure(((Scheme_Closure_Data *)val)->native_code);
}
nc->vals[i] = val;
}
return (Scheme_Object *)nc;
} else {
/* The case-lambda data must point to the original closure-data
record, because that's where the closure maps are kept. But
we don't need the bytecode, anymore. So clone the
closure-data record and drop the bytecode in thte clone. */
for (i = 0; i < cnt; i++) {
val = seqout->array[i];
if (!SCHEME_PROCP(val)) {
Scheme_Closure_Data *data;
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
memcpy(data, val, sizeof(Scheme_Closure_Data));
data->code = NULL;
seqout->array[i] = (Scheme_Object *)data;
}
}
}
return (Scheme_Object *)seqout;
}
#endif
return expr;
}
static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
{
@ -1540,18 +1688,65 @@ static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stac
static Scheme_Object *
case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv)
{
int i;
int i, all_closed = 1;
Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
for (i = 0; i < seq->count; i++) {
Scheme_Object *le;
le = scheme_resolve_expr(seq->array[i], rslv);
le = seq->array[i];
((Scheme_Closure_Data *)le)->name = scheme_false; /* inidcates that it's a case */
le = scheme_resolve_expr(le, rslv);
seq->array[i] = le;
if (!SCHEME_PROCP(le))
all_closed = 0;
}
if (all_closed) {
/* Produce closure directly */
return case_lambda_execute(expr);
}
return scheme_make_syntax_resolved(CASE_LAMBDA_EXPD, expr);
}
Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int jit)
{
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)expr;
Scheme_Closure *c;
int i;
for (i = cl->count; i--; ) {
c = (Scheme_Closure *)cl->array[i];
if (!ZERO_SIZED_CLOSUREP(c)) {
break;
}
}
if (i < 0) {
/* We can reconstruct a case-lambda syntactic form. */
Scheme_Case_Lambda *cl2;
cl2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
+ ((cl->count - 1) * sizeof(Scheme_Object*)));
cl2->so.type = scheme_case_lambda_sequence_type;
cl2->count = cl->count;
cl2->name = cl->name;
for (i = cl->count; i--; ) {
c = (Scheme_Closure *)cl->array[i];
cl2->array[i] = (Scheme_Object *)c->code;
}
if (jit)
return case_lambda_jit((Scheme_Object *)cl2);
else
return (Scheme_Object *)cl2;
}
return expr;
}
static void case_lambda_check_line(Scheme_Object *line, Scheme_Object *form, Scheme_Comp_Env *env)
{
Scheme_Object *body, *args;
@ -1816,6 +2011,21 @@ bangboxvalue_execute(Scheme_Object *data)
return val;
}
static Scheme_Object *bangboxvalue_jit(Scheme_Object *data)
{
Scheme_Object *orig, *naya;
orig = SCHEME_CDR(data);
orig = SCHEME_CDR(orig);
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else
return cons(SCHEME_CAR(data),
cons(SCHEME_CADR(data),
naya));
}
static void bangboxvalue_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
{
@ -2878,6 +3088,41 @@ begin0_execute(Scheme_Object *obj)
return v;
}
static Scheme_Object *begin0_jit(Scheme_Object *data)
{
Scheme_Sequence *seq = (Scheme_Sequence *)data, *seq2;
Scheme_Object *old, *naya = NULL;
int i, j, count;
count = seq->count;
for (i = 0; i < count; i++) {
old = seq->array[i];
naya = scheme_jit_expr(old);
if (!SAME_OBJ(old, naya))
break;
}
if (i >= count)
return data;
seq2 = (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence)
+ (count - 1)
* sizeof(Scheme_Object *));
seq2->so.type = scheme_begin0_sequence_type;
seq2->count = count;
for (j = 0; j < i; j++) {
seq2->array[j] = seq->array[j];
}
seq2->array[i] = naya;
for (i++; i < count; i++) {
old = seq->array[i];
naya = scheme_jit_expr(old);
seq2->array[i] = naya;
}
return (Scheme_Object *)seq2;
}
static void begin0_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
{
@ -3113,13 +3358,19 @@ quote_syntax_execute(Scheme_Object *obj)
globs = (Scheme_Object **)MZ_RUNSTACK[c];
stx = globs[i+p+1];
if (!stx) {
stx = ((Scheme_Object **)SCHEME_CDR(globs[p]))[i];
stx = scheme_add_rename(stx, SCHEME_CAR(globs[p]));
stx = globs[p];
stx = scheme_add_rename(((Scheme_Object **)SCHEME_CDR(stx))[i],
SCHEME_CAR(stx));
globs[i+p+1] = stx;
}
return stx;
}
Scheme_Object *quote_syntax_jit(Scheme_Object *data)
{
return data;
}
static void quote_syntax_validate(Scheme_Object *obj, Mz_CPort *port, char *stack,
int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
{
@ -3241,6 +3492,43 @@ define_for_syntaxes_execute(Scheme_Object *form)
return do_define_syntaxes_execute(form, NULL, 1);
}
static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr)
{
Scheme_Object *orig, *naya, *data = expr;
Scheme_Object *a, *ad, *add;
a = SCHEME_CAR(data);
data = SCHEME_CDR(data);
ad = SCHEME_CAR(data);
data = SCHEME_CDR(data);
add = SCHEME_CAR(data);
data = SCHEME_CDR(data);
orig = SCHEME_CDR(data);
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
return expr;
else {
return cons(a,
cons(ad,
cons(add,
cons(SCHEME_CAR(data),
naya))));
}
}
static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr)
{
return do_define_syntaxes_jit(expr);
}
static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr)
{
return do_define_syntaxes_jit(expr);
}
static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, int depth, int letlimit, int delta,
int num_toplevels, int num_stxes,
@ -3536,6 +3824,7 @@ Scheme_Object *scheme_bind_syntaxes(const char *where, Scheme_Object *names, Sch
Scheme_Object **results, *l;
Scheme_Comp_Env *eenv;
Resolve_Prefix *rp;
Resolve_Info *ri;
int vc, nc, j, i;
Scheme_Compile_Info mrec;
@ -3555,7 +3844,14 @@ Scheme_Object *scheme_bind_syntaxes(const char *where, Scheme_Object *names, Sch
For letrec-syntaxes+values, don't simplify because it's too expensive. */
rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, 0);
a = scheme_resolve_expr(a, scheme_resolve_info_create(rp));
ri = scheme_resolve_info_create(rp);
a = scheme_resolve_expr(a, ri);
/* To JIT:
if (ri->use_jit) a = scheme_jit_expr(a);
but it's not likely that a let-syntax-bound macro is going
to run lots of times, so JITting is probably not worth it. */
a = eval_letmacro_rhs(a, rhs_env, mrec.max_let_depth, rp, eenv->genv->phase, certs);
@ -4001,8 +4297,8 @@ static Scheme_Object *write_case_lambda(Scheme_Object *obj)
static Scheme_Object *read_case_lambda(Scheme_Object *obj)
{
Scheme_Object *s;
int count, i;
Scheme_Object *s, *a;
int count, i, all_closed = 1;
Scheme_Case_Lambda *cl;
if (!SCHEME_PAIRP(obj)) return NULL;
@ -4023,9 +4319,20 @@ static Scheme_Object *read_case_lambda(Scheme_Object *obj)
s = SCHEME_CDR(obj);
for (i = 0; i < count; i++, s = SCHEME_CDR(s)) {
cl->array[i] = SCHEME_CAR(s);
a = SCHEME_CAR(s);
cl->array[i] = a;
if (!SCHEME_PROCP(a))
all_closed = 0;
}
if (all_closed) {
/* Empty closure: produce procedure value directly.
(We assume that this was generated by a direct write of
a case-lambda data record in print.c, and that it's not
in a CASE_LAMBDA_EXPD syntax record.) */
return case_lambda_execute((Scheme_Object *)cl);
}
return (Scheme_Object *)cl;
}

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

@ -689,24 +689,28 @@ void scheme_init_thread(Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("sync",
scheme_make_prim_w_arity(sch_sync,
"sync",
1, -1),
scheme_make_prim_w_arity2(sch_sync,
"sync",
1, -1,
0, -1),
env);
scheme_add_global_constant("sync/timeout",
scheme_make_prim_w_arity(sch_sync_timeout,
"sync/timeout",
2, -1),
scheme_make_prim_w_arity2(sch_sync_timeout,
"sync/timeout",
2, -1,
0, -1),
env);
scheme_add_global_constant("sync/enable-break",
scheme_make_prim_w_arity(sch_sync_enable_break,
"sync/enable-break",
1, -1),
scheme_make_prim_w_arity2(sch_sync_enable_break,
"sync/enable-break",
1, -1,
0, -1),
env);
scheme_add_global_constant("sync/timeout/enable-break",
scheme_make_prim_w_arity(sch_sync_timeout_enable_break,
"sync/timeout/enable-break",
2, -1),
scheme_make_prim_w_arity2(sch_sync_timeout_enable_break,
"sync/timeout/enable-break",
2, -1,
0, -1),
env);
scheme_add_global_constant("choice-evt",
scheme_make_prim_w_arity(evts_to_evt,
@ -2126,6 +2130,7 @@ void scheme_swap_thread(Scheme_Thread *new_thread)
printf("death\n");
swapping = 1;
#endif
if (!swap_no_setjmp && SETJMP(scheme_current_thread)) {
/* We're back! */
/* See also initial swap in in start_child() */
@ -2163,6 +2168,7 @@ void scheme_swap_thread(Scheme_Thread *new_thread)
swap_no_setjmp = 0;
/* We're leaving... */
if (scheme_current_thread->init_break_cell) {
int cb;
cb = can_break_param(scheme_current_thread);
@ -5867,6 +5873,8 @@ static void make_initial_config(Scheme_Thread *p)
init_param(cells, paramz, MZCONFIG_HONU_MODE, scheme_false);
init_param(cells, paramz, MZCONFIG_USE_JIT, scheme_startup_use_jit ? scheme_true : scheme_false);
{
Scheme_Object *s;
s = scheme_make_immutable_sized_utf8_string("", 0);
@ -6516,6 +6524,8 @@ static void prepare_thread_for_GC(Scheme_Object *t)
if (p->values_buffer)
memset(p->values_buffer, 0, sizeof(Scheme_Object*) * p->values_buffer_size);
p->spare_runstack = NULL;
/* zero ununsed part of list stack */
scheme_clean_list_stack(p);
}

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

@ -109,6 +109,7 @@ scheme_init_type (Scheme_Env *env)
set_name(scheme_prim_type, "<primitive>");
set_name(scheme_closed_prim_type, "<primitive-closure>");
set_name(scheme_closure_type, "<procedure>");
set_name(scheme_native_closure_type, "<procedure>");
set_name(scheme_cont_type, "<continuation>");
set_name(scheme_tail_call_waiting_type, "<tail-call-waiting>");
set_name(scheme_null_type, "<empty-list>");

54
src/mzscheme/src/vector.c
View File

@ -54,19 +54,19 @@ scheme_init_vector (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("make-vector",
scheme_make_prim_w_arity(make_vector,
"make-vector",
1, 2),
scheme_make_noncm_prim(make_vector,
"make-vector",
1, 2),
env);
scheme_add_global_constant("vector",
scheme_make_prim_w_arity(vector,
"vector",
0, -1),
scheme_make_noncm_prim(vector,
"vector",
0, -1),
env);
scheme_add_global_constant("vector-immutable",
scheme_make_prim_w_arity(vector_immutable,
"vector-immutable",
0, -1),
scheme_make_noncm_prim(vector_immutable,
"vector-immutable",
0, -1),
env);
scheme_add_global_constant("vector-length",
scheme_make_folding_prim(vector_length,
@ -74,34 +74,34 @@ scheme_init_vector (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("vector-ref",
scheme_make_prim_w_arity(vector_ref,
"vector-ref",
2, 2),
scheme_make_noncm_prim(vector_ref,
"vector-ref",
2, 2),
env);
scheme_add_global_constant("vector-set!",
scheme_make_prim_w_arity(vector_set,
"vector-set!",
3, 3),
scheme_make_noncm_prim(vector_set,
"vector-set!",
3, 3),
env);
scheme_add_global_constant("vector->list",
scheme_make_prim_w_arity(vector_to_list,
"vector->list",
1, 1),
scheme_make_noncm_prim(vector_to_list,
"vector->list",
1, 1),
env);
scheme_add_global_constant("list->vector",
scheme_make_prim_w_arity(list_to_vector,
"list->vector",
1, 1),
scheme_make_noncm_prim(list_to_vector,
"list->vector",
1, 1),
env);
scheme_add_global_constant("vector-fill!",
scheme_make_prim_w_arity(vector_fill,
"vector-fill!",
2, 2),
scheme_make_noncm_prim(vector_fill,
"vector-fill!",
2, 2),
env);
scheme_add_global_constant("vector->immutable-vector",
scheme_make_prim_w_arity(vector_to_immutable,
"vector->immutable-vector",
1, 1),
scheme_make_noncm_prim(vector_to_immutable,
"vector->immutable-vector",
1, 1),
env);
}

6
src/mzscheme/utils/xctocc
View File

@ -430,7 +430,7 @@ sub ReadFields {
($methpre, $methprecall, $methpostcall, $methpost)
= split('/', $methodpostmacros);
($gluepre, $glueprecall, $gluepostcall, $gluepost)
($gluepre, $glueprecall, $gluepostcall, $gluepost, $gluepostschemebind)
= split('/', $gluepostmacros);
$methpre = &Wash($methpre);
@ -442,6 +442,7 @@ sub ReadFields {
$glueprecall = &Wash($glueprecall);
$gluepost = &Wash($gluepost);
$gluepostcall = &Wash($gluepostcall);
$gluepostschemebind = &Wash($gluepostschemebind);
if ($virtualonly && ($vexception ne '')) {
$exception = &Wash($vexception);
@ -1839,6 +1840,9 @@ sub PrintFunction
print " WITH_REMEMBERED_STACK(objscheme_register_primpointer(p[0], &((Scheme_Class_Object *)p[0])";
print "->primdata));\n";
}
if ($gluepostschemebind ne undef) {
print " " . &ApplyMacros($gluepostschemebind) . "\n";
}
print " return scheme_void;\n";
print "}\n";
} else {

3
src/worksp-vc70/libmzsch/libmzsch.vcproj
View File

@ -209,6 +209,9 @@
<File
RelativePath="..\..\Mzscheme\Src\image.c">
</File>
<File
RelativePath="..\..\Mzscheme\Src\jit.c">
</File>
<File
RelativePath="..\..\Mzscheme\Src\module.c">
</File>

3
src/worksp/libmzsch/libmzsch.vcproj
View File

@ -178,6 +178,9 @@
<File
RelativePath="..\..\Mzscheme\Src\image.c">
</File>
<File
RelativePath="..\..\Mzscheme\Src\jit.c">
</File>
<File
RelativePath="..\..\Mzscheme\Src\List.c">
</File>

2
src/wxwindow/include/msw/wx_item.h
View File

@ -54,7 +54,7 @@ class wxItem: public wxbItem
virtual Bool MSWOnDraw(DRAWITEMSTRUCT *WXUNUSED(item)) { return FALSE; };
virtual Bool MSWOnMeasure(MEASUREITEMSTRUCT *WXUNUSED(item)) { return FALSE; };
void GetLabelExtent(const char *string, double *x, double *y);
void GetLabelExtent(const char *string, double *x, double *y, wxFont *fnt = NULL);
void SetFont(wxFont *f);
};

2
src/wxwindow/src/msw/wx_gbox.cxx
View File

@ -58,7 +58,7 @@ wxGroupBox::wxGroupBox(wxPanel *panel, char *Title, long _style, wxFont *_font):
double label_height = 0;
int char_width, ignored;
GetTextExtent(wxStripMenuCodes(the_label), &label_width, &label_height, NULL, NULL, font);
GetLabelExtent(wxStripMenuCodes(the_label), &label_width, &label_height);
wxGetCharSize((HWND)ms_handle, &char_width, &ignored, font);
label_width += 3 * char_width; /* space before & after label */
width = label_width;

8
src/wxwindow/src/msw/wx_item.cxx
View File

@ -539,13 +539,15 @@ int wxGetControlFontSize()
return 8;
}
void wxItem::GetLabelExtent(const char *string, double *x, double *y)
void wxItem::GetLabelExtent(const char *string, double *x, double *y, wxFont *fnt)
{
GetTextExtent(string, x, y, NULL, NULL, font);
if (!fnt)
fnt = font;
GetTextExtent(string, x, y, NULL, NULL, fnt);
if (y && ms_handle) {
/* Keep min height consistent, even with substitutions */
int cx, cy;
wxGetCharSize((HWND)ms_handle, &cx, &cy, font);
wxGetCharSize((HWND)ms_handle, &cx, &cy, fnt);
if (*y < cy)
*y = cy;
}

4
src/wxwindow/src/msw/wx_lbox.cxx
View File

@ -404,7 +404,7 @@ void wxListBox::SetSize(int x, int y, int width, int height, int sizeFlags)
// Find size of label
wxGetCharSize((HWND)ms_handle, &clx, &cly, label_font);
GetWindowText(static_label, buf, 300);
GetTextExtent(wxStripMenuCodes(buf), &label_width, &label_height, NULL, NULL, label_font);
GetLabelExtent(wxStripMenuCodes(buf), &label_width, &label_height, label_font);
// Given size is total label + edit size, find individual
// control sizes on that basis.
@ -524,7 +524,7 @@ void wxListBox::SetLabel(char *label)
::ScreenToClient(cparent->handle, &point);
}
GetTextExtent((LPSTR)label, &w, &h, NULL, NULL, label_font);
GetLabelExtent((LPSTR)label, &w, &h, label_font);
MoveWindow(static_label, point.x, point.y, (int)(w + 10), (int)h,
TRUE);
SetWindowTextW(static_label, wxWIDE_STRING(label));

2
src/wxwindow/src/msw/wx_messg.cxx
View File

@ -168,7 +168,7 @@ void wxMessage::SetSize(int x, int y, int width, int height, int sizeFlags)
y = currentY;
GetWindowTextW((HWND)ms_handle, buf, 300);
GetTextExtent(wxStripMenuCodes(wxNARROW_STRING(buf)), &current_width, &cyf, NULL, NULL,font);
GetLabelExtent(wxStripMenuCodes(wxNARROW_STRING(buf)), &current_width, &cyf);
GetSize(&ww, &hh);

2
src/wxwindow/src/msw/wx_tabc.cxx
View File

@ -66,7 +66,7 @@ wxTabChoice::wxTabChoice(wxPanel *panel, wxFunction func, char *label,
wxGetCharSize(cparent->handle, &cx, &cy, font);
for (i = 0; i < n; i++) {
GetTextExtent(wxStripMenuCodes(choices[i]), &current_width, &cyf, NULL, NULL, font);
GetLabelExtent(wxStripMenuCodes(choices[i]), &current_width, &cyf);
if (current_width < 40)
current_width = 40;
total_width += current_width + cy;