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

minor streamlining of foreign-call path

Browse Source 
JIT-inline `cpointer-tag` and `set-cpointer-tag!`, plus minor
shortcuts and GC hints in Racket->C conversion.
This commit is contained in:
Matthew Flatt 2015-08-04 21:20:20 -06:00
parent d34416ea02
commit c308915047
9 changed files with 207 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
racket/collects/compiler/private/xform.rkt
View File

@ -956,6 +956,7 @@
'(exit
scheme_wrong_type scheme_wrong_number scheme_wrong_syntax
scheme_wrong_count scheme_wrong_count_m scheme_wrong_rator scheme_read_err
scheme_wrong_contract scheme_contract_error
scheme_raise_exn scheme_signal_error
scheme_raise_out_of_memory
))

110
racket/src/foreign/foreign.c
View File

@ -1075,7 +1075,7 @@ XFORM_NONGCING static int is_gcable_pointer(Scheme_Object *o) {
* type by the basetype field.)
*/
/* ctype structure definition */
static Scheme_Type ctype_tag;
#define ctype_tag scheme_ctype_type
typedef struct ctype_struct {
Scheme_Object so;
Scheme_Object* basetype;
@ -1705,6 +1705,13 @@ static Scheme_Object *foreign_cpointer_tag(int argc, Scheme_Object *argv[])
}
#undef MYNAME
Scheme_Object *scheme_cpointer_tag(Scheme_Object *ptr)
{
Scheme_Object *a[1];
a[0] = ptr;
return foreign_cpointer_tag(1, a);
}
#define MYNAME "set-cpointer-tag!"
static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *argv[])
{
@ -1717,6 +1724,14 @@ static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *arg
}
#undef MYNAME
void scheme_set_cpointer_tag(Scheme_Object *ptr, Scheme_Object *val)
{
Scheme_Object *a[2];
a[0] = ptr;
a[1] = val;
(void)foreign_set_cpointer_tag_bang(2, a);
}
#define MYNAME "cpointer-gcable?"
static Scheme_Object *foreign_cpointer_gcable_p(int argc, Scheme_Object *argv[])
{
@ -1817,13 +1832,14 @@ static Scheme_Object *C2SCHEME(Scheme_Object *already_ptr, Scheme_Object *type,
}
#undef REF_CTYPE
static void wrong_value(const char *who, const char *type, Scheme_Object *val)
static void *wrong_value(const char *who, const char *type, Scheme_Object *val)
{
scheme_contract_error(who,
"given value does not fit primitive C type",
"C type", 0, type,
"given value", 1, val,
NULL);
return NULL;
}
/* On big endian machines we need to know whether we're pulling a value from an
@ -1839,14 +1855,20 @@ static void wrong_value(const char *who, const char *type, Scheme_Object *val)
* then a struct or array value will be *copied* into dst. */
static void* SCHEME2C(const char *who,
Scheme_Object *type, void *dst, intptr_t delta,
Scheme_Object *val, intptr_t *basetype_p, intptr_t *_offset,
Scheme_Object *val, GC_CAN_IGNORE intptr_t *basetype_p, GC_CAN_IGNORE intptr_t *_offset,
int ret_loc)
{
if (!SCHEME_CTYPEP(type))
scheme_wrong_contract(who, "ctype?", 0, 1, &type);
/* redundant check:
if (!SCHEME_CTYPEP(type))
scheme_wrong_contract(who, "ctype?", 0, 1, &type); */
while (CTYPE_USERP(type)) {
if (!SCHEME_FALSEP(CTYPE_USER_S2C(type)))
val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
GC_CAN_IGNORE Scheme_Object *f = CTYPE_USER_S2C(type);
if (!SCHEME_FALSEP(f)) {
if (SAME_TYPE(SCHEME_TYPE(f), scheme_native_closure_type))
val = _scheme_apply_native(f, 1, (Scheme_Object**)(&val));
else
val = _scheme_apply(f, 1, (Scheme_Object**)(&val));
}
type = CTYPE_BASETYPE(type);
}
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
@ -1861,10 +1883,10 @@ static void* SCHEME2C(const char *who,
else if (SCHEME_FALSEP(val))
((void**)W_OFFSET(dst,delta))[0] = NULL;
else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
wrong_value(who, "_fpointer", val);
return wrong_value(who, "_fpointer", val);
} else switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void:
if (!ret_loc) wrong_value(who, "_void", val);;
if (!ret_loc) return wrong_value(who, "_void", val);;
break;
case FOREIGN_int8:
# ifdef SCHEME_BIG_ENDIAN
@ -1878,7 +1900,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(get_byte_val(val,&(((Tsint8*)W_OFFSET(dst,delta))[0])))) wrong_value(who, "_int8", val);;
if (!(get_byte_val(val,&(((Tsint8*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_int8", val);;
return NULL;
case FOREIGN_uint8:
# ifdef SCHEME_BIG_ENDIAN
@ -1892,7 +1914,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(get_ubyte_val(val,&(((Tuint8*)W_OFFSET(dst,delta))[0])))) wrong_value(who, "_uint8", val);;
if (!(get_ubyte_val(val,&(((Tuint8*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_uint8", val);;
return NULL;
case FOREIGN_int16:
# ifdef SCHEME_BIG_ENDIAN
@ -1906,7 +1928,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(get_short_val(val,&(((Tsint16*)W_OFFSET(dst,delta))[0])))) wrong_value(who, "_int16", val);;
if (!(get_short_val(val,&(((Tsint16*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_int16", val);;
return NULL;
case FOREIGN_uint16:
# ifdef SCHEME_BIG_ENDIAN
@ -1920,7 +1942,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(get_ushort_val(val,&(((Tuint16*)W_OFFSET(dst,delta))[0])))) wrong_value(who, "_uint16", val);;
if (!(get_ushort_val(val,&(((Tuint16*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_uint16", val);;
return NULL;
case FOREIGN_int32:
# ifdef SCHEME_BIG_ENDIAN
@ -1934,7 +1956,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(scheme_get_realint_val(val,&(((Tsint32*)W_OFFSET(dst,delta))[0])))) wrong_value(who, "_int32", val);;
if (!(scheme_get_realint_val(val,&(((Tsint32*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_int32", val);;
return NULL;
case FOREIGN_uint32:
# ifdef SCHEME_BIG_ENDIAN
@ -1948,7 +1970,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(scheme_get_unsigned_realint_val(val,&(((Tuint32*)W_OFFSET(dst,delta))[0])))) wrong_value(who, "_uint32", val);;
if (!(scheme_get_unsigned_realint_val(val,&(((Tuint32*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_uint32", val);;
return NULL;
case FOREIGN_int64:
# ifdef SCHEME_BIG_ENDIAN
@ -1962,7 +1984,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(scheme_get_long_long_val(val,&(((Tsint64*)W_OFFSET(dst,delta))[0])))) wrong_value(who, "_int64", val);;
if (!(scheme_get_long_long_val(val,&(((Tsint64*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_int64", val);;
return NULL;
case FOREIGN_uint64:
# ifdef SCHEME_BIG_ENDIAN
@ -1976,7 +1998,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(scheme_get_unsigned_long_long_val(val,&(((Tuint64*)W_OFFSET(dst,delta))[0])))) wrong_value(who, "_uint64", val);;
if (!(scheme_get_unsigned_long_long_val(val,&(((Tuint64*)W_OFFSET(dst,delta))[0])))) return wrong_value(who, "_uint64", val);;
return NULL;
case FOREIGN_fixint:
# ifdef SCHEME_BIG_ENDIAN
@ -1996,7 +2018,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(Tsint32, SCHEME_INT_VAL(val));
(((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_fixint", val);;
return wrong_value(who, "_fixint", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_ufixint:
@ -2017,7 +2039,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(Tuint32, SCHEME_UINT_VAL(val));
(((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_ufixint", val);;
return wrong_value(who, "_ufixint", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_fixnum:
@ -2038,7 +2060,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(intptr_t, SCHEME_INT_VAL(val));
(((intptr_t*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_fixnum", val);;
return wrong_value(who, "_fixnum", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_ufixnum:
@ -2059,7 +2081,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(uintptr_t, SCHEME_UINT_VAL(val));
(((uintptr_t*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_ufixnum", val);;
return wrong_value(who, "_ufixnum", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_float:
@ -2080,7 +2102,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(float, SCHEME_FLOAT_VAL(val));
(((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_float", val);;
return wrong_value(who, "_float", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_double:
@ -2101,7 +2123,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(double, SCHEME_FLOAT_VAL(val));
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_double", val);;
return wrong_value(who, "_double", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_longdouble:
@ -2122,7 +2144,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_NO_TYPE_CAST(mz_long_double, SCHEME_MAYBE_LONG_DBL_VAL(val));
(((mz_long_double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_longdouble", val);;
return wrong_value(who, "_longdouble", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_doubleS:
@ -2143,7 +2165,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(double, scheme_real_to_double(val));
(((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_double*", val);;
return wrong_value(who, "_double*", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_bool:
@ -2164,7 +2186,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(int, SCHEME_TRUEP(val));
(((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_bool", val);;
return wrong_value(who, "_bool", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_stdbool:
@ -2185,7 +2207,7 @@ static void* SCHEME2C(const char *who,
tmp = MZ_TYPE_CAST(stdbool, SCHEME_TRUEP(val));
(((stdbool*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_stdbool", val);;
return wrong_value(who, "_stdbool", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_string_ucs_4:
@ -2212,7 +2234,7 @@ static void* SCHEME2C(const char *who,
return tmp;
}
} else {
wrong_value(who, "_string/ucs-4", val);;
return wrong_value(who, "_string/ucs-4", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_string_utf_16:
@ -2239,7 +2261,7 @@ static void* SCHEME2C(const char *who,
return tmp;
}
} else {
wrong_value(who, "_string/utf-16", val);;
return wrong_value(who, "_string/utf-16", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_bytes:
@ -2266,7 +2288,7 @@ static void* SCHEME2C(const char *who,
return tmp;
}
} else {
wrong_value(who, "_bytes", val);;
return wrong_value(who, "_bytes", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_path:
@ -2293,7 +2315,7 @@ static void* SCHEME2C(const char *who,
return tmp;
}
} else {
wrong_value(who, "_path", val);;
return wrong_value(who, "_path", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_symbol:
@ -2320,7 +2342,7 @@ static void* SCHEME2C(const char *who,
return tmp;
}
} else {
wrong_value(who, "_symbol", val);;
return wrong_value(who, "_symbol", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_pointer:
@ -2351,7 +2373,7 @@ static void* SCHEME2C(const char *who,
return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
}
} else {
wrong_value(who, "_pointer", val);;
return wrong_value(who, "_pointer", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_gcpointer:
@ -2382,7 +2404,7 @@ static void* SCHEME2C(const char *who,
return _offset ? tmp : (void*)W_OFFSET(tmp, toff);
}
} else {
wrong_value(who, "_gcpointer", val);;
return wrong_value(who, "_gcpointer", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_scheme:
@ -2409,7 +2431,7 @@ static void* SCHEME2C(const char *who,
return tmp;
}
} else {
wrong_value(who, "_scheme", val);;
return wrong_value(who, "_scheme", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_fpointer:
@ -2424,7 +2446,7 @@ static void* SCHEME2C(const char *who,
((int*)W_OFFSET(dst,delta))[0] = 0;
}
# endif /* FFI_CALLBACK_NEED_INT_CLEAR */
if (!(ret_loc)) wrong_value(who, "_fpointer", val);;
if (!(ret_loc)) return wrong_value(who, "_fpointer", val);;
break;
case FOREIGN_struct:
case FOREIGN_array:
@ -2433,14 +2455,14 @@ static void* SCHEME2C(const char *who,
if (!SCHEME_FFIANYPTRP(val)) {
switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_struct:
wrong_value(who, "(_struct ....)", val);
return wrong_value(who, "(_struct ....)", val);
break;
case FOREIGN_array:
wrong_value(who, "(_array ....)", val);
return wrong_value(who, "(_array ....)", val);
break;
default:
case FOREIGN_union:
wrong_value(who, "(_union ....)", val);
return wrong_value(who, "(_union ....)", val);
break;
}
}
@ -4322,7 +4344,7 @@ void scheme_init_foreign_globals()
{
ffi_lib_tag = scheme_make_type("<ffi-lib>");
ffi_obj_tag = scheme_make_type("<ffi-obj>");
ctype_tag = scheme_ctype_type;
;
ffi_callback_tag = scheme_make_type("<ffi-callback>");
# ifdef MZ_PRECISE_GC
GC_register_traversers(ffi_lib_tag, ffi_lib_SIZE, ffi_lib_MARK, ffi_lib_FIXUP, 1, 0);
@ -4448,9 +4470,9 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global_constant("cpointer?",
scheme_make_immed_prim(foreign_cpointer_p, "cpointer?", 1, 1), menv);
scheme_add_global_constant("cpointer-tag",
scheme_make_noncm_prim(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
scheme_make_inline_noncm_prim(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
scheme_add_global_constant("set-cpointer-tag!",
scheme_make_noncm_prim(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv);
scheme_make_inline_noncm_prim(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global_constant("cpointer-gcable?",
scheme_make_noncm_prim(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), menv);
scheme_add_global_constant("ctype-sizeof",
@ -4819,9 +4841,9 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global_constant("cpointer?",
scheme_make_immed_prim((Scheme_Prim *)unimplemented, "cpointer?", 1, 1), menv);
scheme_add_global_constant("cpointer-tag",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), menv);
scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), menv);
scheme_add_global_constant("set-cpointer-tag!",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), menv);
scheme_make_inline_noncm_prim((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global_constant("cpointer-gcable?",
scheme_make_noncm_prim((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), menv);
scheme_add_global_constant("ctype-sizeof",

58
racket/src/foreign/foreign.rktc
View File

@ -200,7 +200,7 @@ END_XFORM_SKIP;
/*****************************************************************************/
/* Library objects */
@cdefstruct[ffi-lib
@cdefstruct[ffi-lib []
[handle "NON_GCBALE_PTR(void)"]
[name "Scheme_Object*"]
[objects "Scheme_Hash_Table*"]
@ -271,7 +271,7 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *opened_libs);
/*****************************************************************************/
/* Pull pointers (mostly functions) out of ffi-lib objects */
@cdefstruct[ffi-obj
@cdefstruct[ffi-obj []
[obj "NON_GCBALE_PTR(void)"]
[name "char*"]
[lib "NON_GCBALE_PTR(ffi_lib_struct)"]]
@ -973,7 +973,7 @@ XFORM_NONGCING static int is_gcable_pointer(Scheme_Object *o) {
* integer is not really needed, since it is possible to identify the
* type by the basetype field.)
*/
@cdefstruct[ctype
@cdefstruct[ctype [#:tag "scheme_ctype_type"]
[basetype "Scheme_Object*"]
[scheme_to_c "Scheme_Object*"]
[c_to_scheme "Scheme_Object*"]]
@ -1354,7 +1354,7 @@ static void wrong_intptr(const char *who, int which, int argc, Scheme_Object **a
/*****************************************************************************/
/* Callback type */
@cdefstruct[ffi-callback
@cdefstruct[ffi-callback []
[callback "NON_GCBALE_PTR(void)"]
[proc "Scheme_Object*"]
[itypes "Scheme_Object*"]
@ -1461,7 +1461,7 @@ int scheme_is_cpointer(Scheme_Object *cp) {
: scheme_false);
}
@cdefine[cpointer-tag 1]{
@cdefine[cpointer-tag 1 #:kind inline_noncm]{
Scheme_Object *tag = NULL;
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
@ -1471,7 +1471,14 @@ int scheme_is_cpointer(Scheme_Object *cp) {
return (tag == NULL) ? scheme_false : tag;
}
@cdefine[set-cpointer-tag! 2]{
Scheme_Object *scheme_cpointer_tag(Scheme_Object *ptr)
{
Scheme_Object *a[1];
a[0] = ptr;
return foreign_cpointer_tag(1, a);
}
@cdefine[set-cpointer-tag! 2 #:kind inline_noncm]{
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPTRP(cp))
@ -1480,6 +1487,14 @@ int scheme_is_cpointer(Scheme_Object *cp) {
return scheme_void;
}
void scheme_set_cpointer_tag(Scheme_Object *ptr, Scheme_Object *val)
{
Scheme_Object *a[2];
a[0] = ptr;
a[1] = val;
(void)foreign_set_cpointer_tag_bang(2, a);
}
@cdefine[cpointer-gcable? 1]{
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
@ -1555,13 +1570,14 @@ static Scheme_Object *C2SCHEME(Scheme_Object *already_ptr, Scheme_Object *type,
}
#undef REF_CTYPE
static void wrong_value(const char *who, const char *type, Scheme_Object *val)
static void *wrong_value(const char *who, const char *type, Scheme_Object *val)
{
scheme_contract_error(who,
"given value does not fit primitive C type",
"C type", 0, type,
"given value", 1, val,
NULL);
return NULL;
}
/* On big endian machines we need to know whether we're pulling a value from an
@ -1577,14 +1593,20 @@ static void wrong_value(const char *who, const char *type, Scheme_Object *val)
* then a struct or array value will be *copied* into dst. */
static void* SCHEME2C(const char *who,
Scheme_Object *type, void *dst, intptr_t delta,
Scheme_Object *val, intptr_t *basetype_p, intptr_t *_offset,
Scheme_Object *val, GC_CAN_IGNORE intptr_t *basetype_p, GC_CAN_IGNORE intptr_t *_offset,
int ret_loc)
{
if (!SCHEME_CTYPEP(type))
scheme_wrong_contract(who, "ctype?", 0, 1, &type);
/* redundant check:
if (!SCHEME_CTYPEP(type))
scheme_wrong_contract(who, "ctype?", 0, 1, &type); */
while (CTYPE_USERP(type)) {
if (!SCHEME_FALSEP(CTYPE_USER_S2C(type)))
val = _scheme_apply(CTYPE_USER_S2C(type), 1, (Scheme_Object**)(&val));
GC_CAN_IGNORE Scheme_Object *f = CTYPE_USER_S2C(type);
if (!SCHEME_FALSEP(f)) {
if (SAME_TYPE(SCHEME_TYPE(f), scheme_native_closure_type))
val = _scheme_apply_native(f, 1, (Scheme_Object**)(&val));
else
val = _scheme_apply(f, 1, (Scheme_Object**)(&val));
}
type = CTYPE_BASETYPE(type);
}
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
@ -1599,11 +1621,11 @@ static void* SCHEME2C(const char *who,
else if (SCHEME_FALSEP(val))
((void**)W_OFFSET(dst,delta))[0] = NULL;
else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
wrong_value(who, "_fpointer", val);
return wrong_value(who, "_fpointer", val);
} else switch (CTYPE_PRIMLABEL(type)) {
@(map-types #:semicolons? #f
(define (wrong-type obj type)
@list{wrong_value(who, "_@type", val);})
@list{return wrong_value(who, "_@type", val);})
@list{
case FOREIGN_@|cname|:
@(let* ([x (and ctype @list{(((@|ctype|*)W_OFFSET(dst,delta))[0])})]
@ -1684,14 +1706,14 @@ static void* SCHEME2C(const char *who,
if (!SCHEME_FFIANYPTRP(val)) {
switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_struct:
wrong_value(who, "(_struct ....)", val);
return wrong_value(who, "(_struct ....)", val);
break;
case FOREIGN_array:
wrong_value(who, "(_array ....)", val);
return wrong_value(who, "(_array ....)", val);
break;
default:
case FOREIGN_union:
wrong_value(who, "(_union ....)", val);
return wrong_value(who, "(_union ....)", val);
break;
}
}
@ -3472,7 +3494,7 @@ void scheme_init_foreign_globals()
{
@(maplines (lambda (x)
(if (equal? (cadr x) "ctype")
@list{ctype_tag = scheme_ctype_type}
@list{}
@list{@(cadr x)_tag = scheme_make_type("<@(car x)>")}))
(reverse (cstructs)))
@@IFDEF{MZ_PRECISE_GC}{

10
racket/src/foreign/rktc-utils.rkt
View File

@ -79,7 +79,7 @@
;; Struct definitions
(provide cstructs)
(define cstructs (make-parameter '()))
(define (_cdefstruct name slots types)
(define (_cdefstruct name slots types #:tag [tag #f])
(define cname (regexp-replace* #rx"-" (symbol->string name) "_"))
(define mname (string-upcase (regexp-replace* #rx"_" cname "")))
(define predname (string->symbol (format "~a?" name)))
@ -94,7 +94,9 @@
}})
(cstructs (cons (list* name cname slots) (cstructs)))
@list{/* @name structure definition */
static Scheme_Type @|cname|_tag;
@(if tag
@list{#define @|cname|_tag @tag}
@list{static Scheme_Type @|cname|_tag;})
typedef struct @|cname|_struct {
Scheme_Object so;
@(maplines (lambda (s t) @list{@t @s}) slots types)
@ -114,8 +116,8 @@
END_XFORM_SKIP;
#endif})
(provide cdefstruct)
(define-syntax-rule (cdefstruct name [slot type] ...)
(_cdefstruct `name (list `slot ...) (list type ...)))
(define-syntax-rule (cdefstruct name [arg ...] [slot type] ...)
(_cdefstruct `name (list `slot ...) (list type ...) arg ...))
;; Tagged object allocation
(define (_cmake var type . values)

1
racket/src/racket/src/jit.h
View File

@ -341,6 +341,7 @@ struct scheme_jit_common_record {
void *bad_app_vals_target;
void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code;
void *bad_char_to_integer_code, *slow_integer_to_char_code;
void *slow_cpointer_tag_code, *slow_set_cpointer_tag_code;
void *values_code;
void *list_p_code, *list_p_branch_code;
void *list_length_code;

4
racket/src/racket/src/jit_ts.c
View File

@ -112,6 +112,8 @@ define_ts_iS_s(scheme_check_not_undefined, FSRC_MARKS)
define_ts_iS_s(scheme_check_assign_not_undefined, FSRC_MARKS)
define_ts_iS_s(scheme_foreign_ptr_ref, FSRC_MARKS)
define_ts_iS_v(scheme_foreign_ptr_set, FSRC_MARKS)
define_ts_s_s(scheme_cpointer_tag, FSRC_MARKS)
define_ts_ss_v(scheme_set_cpointer_tag, FSRC_MARKS)
#endif
#ifdef JITCALL_TS_PROCS
@ -250,4 +252,6 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts_scheme_check_assign_not_undefined scheme_check_assign_not_undefined
# define ts_scheme_foreign_ptr_ref scheme_foreign_ptr_ref
# define ts_scheme_foreign_ptr_set scheme_foreign_ptr_set
# define ts_scheme_cpointer_tag scheme_cpointer_tag
# define ts_scheme_set_cpointer_tag scheme_set_cpointer_tag
#endif

24
racket/src/racket/src/jitcommon.c
View File

@ -3332,6 +3332,30 @@ static int common13(mz_jit_state *jitter, void *_data)
scheme_jit_register_sub_func(jitter, sjc.slow_ptr_set_code, scheme_false);
CHECK_LIMIT();
/* *** slow_cpointer_tag_code *** */
sjc.slow_cpointer_tag_code = jit_get_ip();
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
mz_prepare(1);
jit_pusharg_p(JIT_R0);
mz_finish_prim_lwe(ts_scheme_cpointer_tag, refr);
jit_retval(JIT_R0);
mz_epilog(JIT_R2);
scheme_jit_register_sub_func(jitter, sjc.slow_cpointer_tag_code, scheme_false);
CHECK_LIMIT();
/* *** slow_cpointer_tag_code *** */
sjc.slow_set_cpointer_tag_code = jit_get_ip();
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
mz_prepare(2);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_R0);
mz_finish_prim_lwe(ts_scheme_set_cpointer_tag, refr);
mz_epilog(JIT_R2);
scheme_jit_register_sub_func(jitter, sjc.slow_set_cpointer_tag_code, scheme_false);
CHECK_LIMIT();
/* *** force_value_same_mark_code *** */
/* Helper for futures: a synthetic functon that just forces values,
which will bounce back to the runtime thread (but with lightweight

62
racket/src/racket/src/jitinline.c
View File

@ -1975,6 +1975,39 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
mz_patch_ucbranch(refdone);
__END_TINY_JUMPS__(1);
return 1;
} else if (IS_NAMED_PRIM(rator, "cpointer-tag")) {
GC_CAN_IGNORE jit_insn *ref, *refslow, *refdone;
mz_runstack_skipped(jitter, 1);
scheme_generate_non_tail(app->rand, jitter, 0, 1, 0);
CHECK_LIMIT();
mz_runstack_unskipped(jitter, 1);
mz_rs_sync();
__START_TINY_JUMPS__(1);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
refslow = jit_get_ip();
__END_TINY_JUMPS__(1);
(void)jit_calli(sjc.slow_cpointer_tag_code);
__START_TINY_JUMPS__(1);
jit_movr_p(dest, JIT_R0);
refdone = jit_jmpi(jit_forward());
mz_patch_branch(ref);
(void)mz_bnei_t(refslow, JIT_R0, scheme_cpointer_type, JIT_R1);
CHECK_LIMIT();
jit_ldxi_p(dest, JIT_R0, (intptr_t)&SCHEME_CPTR_TYPE((Scheme_Object *)0x0));
ref = jit_bnei_p(jit_forward(), dest, NULL);
(void)jit_movi_p(dest, scheme_false);
mz_patch_branch(ref);
CHECK_LIMIT();
mz_patch_ucbranch(refdone);
__END_TINY_JUMPS__(1);
return 1;
} else if (IS_NAMED_PRIM(rator, "future?")) {
generate_inlined_type_test(jitter, app, scheme_future_type, scheme_future_type, 1, for_branch, branch_short, need_sync, dest);
@ -3664,6 +3697,35 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
jit_retval(dest);
CHECK_LIMIT();
return 1;
} else if (IS_NAMED_PRIM(rator, "set-cpointer-tag!")) {
GC_CAN_IGNORE jit_insn *ref, *refslow, *refdone;
LOG_IT(("inlined set-cpointer-tag!\n"));
scheme_generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
CHECK_LIMIT();
__START_TINY_JUMPS__(1);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
refslow = jit_get_ip();
__END_TINY_JUMPS__(1);
(void)jit_calli(sjc.slow_set_cpointer_tag_code);
__START_TINY_JUMPS__(1);
refdone = jit_jmpi(jit_forward());
mz_patch_branch(ref);
(void)mz_bnei_t(refslow, JIT_R0, scheme_cpointer_type, JIT_R1);
CHECK_LIMIT();
jit_stxi_p((intptr_t)&SCHEME_CPTR_TYPE((Scheme_Object *)0x0), JIT_R0, JIT_R1);
mz_patch_ucbranch(refdone);
__END_TINY_JUMPS__(1);
if (!result_ignored)
(void)jit_movi_p(dest, scheme_void);
return 1;
}
}

3
racket/src/racket/src/schpriv.h
View File

@ -664,6 +664,9 @@ XFORM_NONGCING extern void *scheme_extract_pointer(Scheme_Object *v);
Scheme_Object *scheme_foreign_ptr_ref(int argc, Scheme_Object **argv);
void scheme_foreign_ptr_set(int argc, Scheme_Object **argv);
Scheme_Object *scheme_cpointer_tag(Scheme_Object *ptr);
void scheme_set_cpointer_tag(Scheme_Object *ptr, Scheme_Object *val);
void scheme_kickoff_green_thread_time_slice_timer(intptr_t usec);
#ifdef UNIX_PROCESSES