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

fixed JIT inling bug for XXXX-set!, fast-path for read-byte and read-char, and fast common case for number->string

Browse Source 
svn: r3294
This commit is contained in:
Matthew Flatt 2006-06-09 01:28:04 +00:00
parent 90581cc4f6
commit cfc786cf66
9 changed files with 205 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -583,6 +583,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define SCHEME_PRIM_IS_CLOSURE 4096
#define SCHEME_PRIM_IS_NONCM 8192
#define SCHEME_PRIM_IS_UNARY_INLINED 16384
#define SCHEME_PRIM_IS_MIN_NARY_INLINED 32768
#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER 0
#define SCHEME_PRIM_STRUCT_TYPE_CONSTR 64

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

@ -1023,6 +1023,10 @@ static int eq_testable_constant(Scheme_Object *v)
|| SAME_OBJ(v, scheme_true)
|| SCHEME_VOIDP(v))
return 1;
if (SCHEME_CHARP(v) && (SCHEME_CHAR_VAL(v) < 256))
return 1;
return 0;
}

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

@ -1013,8 +1013,7 @@ static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app)
static int inlined_nary_prim(Scheme_Object *o, Scheme_Object *_app)
{
return (SCHEME_PRIMP(o)
&& ((SCHEME_PRIM_PROC_FLAGS(o) & (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED))
== (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED))
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_MIN_NARY_INLINED)
&& (((Scheme_App_Rec *)_app)->num_args == ((Scheme_Primitive_Proc *)o)->mina));
}
@ -2665,8 +2664,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!SCHEME_PRIMP(rator))
return 0;
if ((SCHEME_PRIM_PROC_FLAGS(rator) & (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED))
!= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED))
if (!(SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_MIN_NARY_INLINED))
return 0;
if (app->num_args != ((Scheme_Primitive_Proc *)rator)->mina)

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

@ -992,7 +992,7 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
Scheme_Hash_Table *checked, *next_checked, *prev_checked;
Scheme_Object *past_checkeds, *future_checkeds, *future_todos, *past_to_modchains;
Scheme_Module *m2;
int same_namespace, skip_notify = 0, phase;
int same_namespace, set_env_for_notify = 0, phase;
if (!SCHEME_NAMESPACEP(argv[0]))
scheme_wrong_type("namespace-attach-module", "namespace", 0, argc, argv);
@ -1004,7 +1004,7 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
if (!SCHEME_NAMESPACEP(argv[2]))
scheme_wrong_type("namespace-attach-module", "namespace", 2, argc, argv);
to_env = (Scheme_Env *)argv[2];
skip_notify = 1;
set_env_for_notify = 1;
} else
to_env = scheme_get_env(NULL);
@ -1274,9 +1274,23 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
#f for to_modchain if there's more to do. */
}
if (!skip_notify) {
/* Notify module name resolver of attached modules: */
resolver = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER);
/* Notify module name resolver of attached modules: */
{
Scheme_Cont_Frame_Data cframe;
Scheme_Config *config;
config = scheme_current_config();
if (set_env_for_notify) {
config = scheme_extend_config(scheme_current_config(),
MZCONFIG_ENV,
(Scheme_Object *)to_env);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
}
resolver = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER);
while (!SCHEME_NULLP(notifies)) {
a[0] = scheme_false;
a[1] = SCHEME_CAR(notifies);
@ -1286,6 +1300,10 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
notifies = SCHEME_CDR(notifies);
}
if (set_env_for_notify) {
scheme_pop_continuation_frame(&cframe);
}
}
return scheme_void;

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

@ -1367,6 +1367,34 @@ number_to_string (int argc, Scheme_Object *argv[])
} else
radix = 10;
if (SCHEME_INTP(o) && ((radix == 10) || (radix == 16))) {
/* Fast path for common case. */
mzchar num[32];
int pos = 32;
long v = SCHEME_INT_VAL(o);
if (v) {
int neg, digit;
if (v < 0) {
neg = 1;
v = -v;
} else
neg = 0;
while (v) {
digit = (v % radix);
if (digit < 10)
num[--pos] = digit + '0';
else
num[--pos] = (digit - 10) + 'a';
v = v / radix;
}
if (neg)
num[--pos] = '-';
} else {
num[--pos] = '0';
}
return scheme_make_sized_offset_char_string(num, pos, 32 - pos, 1);
}
return scheme_make_utf8_string/*_without_copying*/(number_to_allocated_string(radix, o, 1));
}
@ -1476,7 +1504,7 @@ static char *double_to_string (double d, int alloc)
return s;
}
char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc)
static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc)
{
char *s;

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

@ -1337,6 +1337,9 @@ long scheme_get_byte_string_unless(const char *who,
Scheme_Get_String_Fun gs;
Scheme_Peek_String_Fun ps;
/* See also get_one_byte, below. Any change to this function
may require a change to 1-byte specialization of get_one_byte. */
/* back-door argument: */
special_is_ok = 0;
@ -1434,8 +1437,11 @@ long scheme_get_byte_string_unless(const char *who,
if (check_special && ip->ungotten_special) {
if (!special_ok) {
if (!peek && ip->progress_evt)
post_progress(ip);
if (!peek) {
if (ip->progress_evt)
post_progress(ip);
ip->ungotten_special = NULL;
}
scheme_bad_time_for_special(who, port);
}
if (!peek) {
@ -2240,6 +2246,103 @@ long scheme_get_char_string(const char *who,
}
}
static
#ifndef NO_INLINE_KEYWORD
MSC_IZE(inline)
#endif
long get_one_byte(const char *who,
Scheme_Object *port,
char *buffer, long offset,
int only_avail)
{
Scheme_Input_Port *ip;
long gc;
int special_ok = special_is_ok;
Scheme_Get_String_Fun gs;
special_is_ok = 0;
ip = (Scheme_Input_Port *)port;
CHECK_PORT_CLOSED(who, "input", port, ip->closed);
if (ip->input_lock)
scheme_wait_input_allowed(ip, only_avail);
if (ip->ungotten_count) {
buffer[offset] = ip->ungotten[--ip->ungotten_count];
gc = 1;
} else if (ip->peeked_read && pipe_char_count(ip->peeked_read)) {
int ch;
ch = scheme_get_byte(ip->peeked_read);
buffer[offset] = ch;
gc = 1;
} else if (ip->ungotten_special) {
if (ip->progress_evt)
post_progress(ip);
if (!special_ok) {
ip->ungotten_special = NULL;
scheme_bad_time_for_special(who, port);
return 0;
}
ip->special = ip->ungotten_special;
ip->ungotten_special = NULL;
if (ip->p.position >= 0)
ip->p.position++;
if (ip->p.count_lines)
inc_pos((Scheme_Port *)ip, 1);
return SCHEME_SPECIAL;
} else {
if (ip->pending_eof > 1) {
ip->pending_eof = 1;
return EOF;
} else {
/* Call port's get function. */
gs = ip->get_string_fun;
gc = gs(ip, buffer, offset, 1, 0, NULL);
if (ip->progress_evt && (gc > 0))
post_progress(ip);
if (gc < 1) {
if (gc == SCHEME_SPECIAL) {
if (special_ok) {
if (ip->p.position >= 0)
ip->p.position++;
if (ip->p.count_lines)
inc_pos((Scheme_Port *)ip, 1);
return SCHEME_SPECIAL;
} else {
scheme_bad_time_for_special(who, port);
return 0;
}
} else if (gc == EOF) {
ip->p.utf8state = 0;
return EOF;
} else {
/* didn't get anything the first try, so use slow path: */
special_is_ok = special_ok;
return scheme_get_byte_string_unless(who, port,
buffer, offset, 1,
0, 0, NULL, NULL);
}
}
}
}
/****************************************************/
/* Adjust position information for chars got so far */
/****************************************************/
if (ip->p.position >= 0)
ip->p.position++;
if (ip->p.count_lines)
do_count_lines((Scheme_Port *)ip, buffer, offset, 1);
return gc;
}
int
scheme_getc(Scheme_Object *port)
{
@ -2248,11 +2351,18 @@ scheme_getc(Scheme_Object *port)
int v, delta = 0;
while(1) {
v = scheme_get_byte_string_unless("read-char", port,
s, delta, 1,
0,
delta > 0, scheme_make_integer(delta-1),
NULL);
if (delta) {
v = scheme_get_byte_string_unless("read-char", port,
s, delta, 1,
0,
delta > 0, scheme_make_integer(delta-1),
NULL);
} else {
v = get_one_byte("read-char", port,
s, 0,
0);
}
if ((v == EOF) || (v == SCHEME_SPECIAL)) {
if (!delta)
return v;
@ -2290,11 +2400,9 @@ scheme_get_byte(Scheme_Object *port)
char s[1];
int v;
v = scheme_get_byte_string_unless("read-byte", port,
s, 0, 1,
0,
0, 0,
NULL);
v = get_one_byte("read-byte", port,
s, 0,
0);
if ((v == EOF) || (v == SCHEME_SPECIAL))
return v;
@ -4487,21 +4595,27 @@ static long fd_get_string(Scheme_Input_Port *port,
Scheme_FD *fip;
long bc;
if (scheme_unless_ready(unless))
if (unless && scheme_unless_ready(unless))
return SCHEME_UNLESS_READY;
fip = (Scheme_FD *)port->port_data;
if (fip->bufcount) {
bc = ((size <= fip->bufcount)
? size
: fip->bufcount);
if (size == 1) {
buffer[offset] = fip->buffer[fip->buffpos++];
--fip->bufcount;
return 1;
} else {
bc = ((size <= fip->bufcount)
? size
: fip->bufcount);
memcpy(buffer + offset, fip->buffer + fip->buffpos, bc);
fip->buffpos += bc;
fip->bufcount -= bc;
memcpy(buffer + offset, fip->buffer + fip->buffpos, bc);
fip->buffpos += bc;
fip->bufcount -= bc;
return bc;
return bc;
}
} else {
if ((nonblock == 2) && (fip->flush == MZ_FLUSH_ALWAYS))
return 0;

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

@ -771,7 +771,14 @@ string_get_or_peek_bytes(Scheme_Input_Port *port,
is = (Scheme_Indexed_String *) port->port_data;
if (is->index + skip >= is->size)
return EOF;
else {
else if (size == 1) {
int pos = is->index;
if (buffer)
buffer[offset] = is->string[pos + skip];
if (!peek)
is->index = pos + 1;
return 1;
} else {
long l, delta;
delta = is->index + skip;

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

@ -369,8 +369,7 @@ scheme_init_string (Scheme_Env *env)
p = scheme_make_noncm_prim(scheme_checked_string_set, "string-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_MIN_NARY_INLINED;
scheme_add_global_constant("string-set!", p, env);
scheme_add_global_constant("string=?",
@ -614,7 +613,7 @@ scheme_init_string (Scheme_Env *env)
env);
p = scheme_make_folding_prim(byte_string_p, "bytes?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_MIN_NARY_INLINED;
scheme_add_global_constant("bytes?", p, env);
scheme_add_global_constant("make-bytes",
@ -638,8 +637,7 @@ scheme_init_string (Scheme_Env *env)
scheme_add_global_constant("bytes-ref", p, env);
p = scheme_make_noncm_prim(scheme_checked_byte_string_set, "bytes-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_MIN_NARY_INLINED;
scheme_add_global_constant("bytes-set!", p, env);
scheme_add_global_constant("bytes=?",

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

@ -82,8 +82,7 @@ scheme_init_vector (Scheme_Env *env)
p = scheme_make_noncm_prim(scheme_checked_vector_set,
"vector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_MIN_NARY_INLINED;
scheme_add_global_constant("vector-set!", p, env);
scheme_add_global_constant("vector->list",