From c308915047c7781da5da410d05ba9bd2235c7a67 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 4 Aug 2015 21:20:20 -0600 Subject: [PATCH] minor streamlining of foreign-call path JIT-inline `cpointer-tag` and `set-cpointer-tag!`, plus minor shortcuts and GC hints in Racket->C conversion. --- racket/collects/compiler/private/xform.rkt | 1 + racket/src/foreign/foreign.c | 110 ++++++++++++--------- racket/src/foreign/foreign.rktc | 58 +++++++---- racket/src/foreign/rktc-utils.rkt | 10 +- racket/src/racket/src/jit.h | 1 + racket/src/racket/src/jit_ts.c | 4 + racket/src/racket/src/jitcommon.c | 24 +++++ racket/src/racket/src/jitinline.c | 62 ++++++++++++ racket/src/racket/src/schpriv.h | 3 + 9 files changed, 207 insertions(+), 66 deletions(-) diff --git a/racket/collects/compiler/private/xform.rkt b/racket/collects/compiler/private/xform.rkt index 2e62629570..63e8dd4c2a 100644 --- a/racket/collects/compiler/private/xform.rkt +++ b/racket/collects/compiler/private/xform.rkt @@ -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 )) diff --git a/racket/src/foreign/foreign.c b/racket/src/foreign/foreign.c index 1a4772686b..1bf1c897dd 100644 --- a/racket/src/foreign/foreign.c +++ b/racket/src/foreign/foreign.c @@ -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_obj_tag = scheme_make_type(""); - ctype_tag = scheme_ctype_type; + ; ffi_callback_tag = scheme_make_type(""); # 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", diff --git a/racket/src/foreign/foreign.rktc b/racket/src/foreign/foreign.rktc index 135742e75c..22a871fccc 100755 --- a/racket/src/foreign/foreign.rktc +++ b/racket/src/foreign/foreign.rktc @@ -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}{ diff --git a/racket/src/foreign/rktc-utils.rkt b/racket/src/foreign/rktc-utils.rkt index 766e596b07..8b97f7e176 100644 --- a/racket/src/foreign/rktc-utils.rkt +++ b/racket/src/foreign/rktc-utils.rkt @@ -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) diff --git a/racket/src/racket/src/jit.h b/racket/src/racket/src/jit.h index c569fd218f..b42414b727 100644 --- a/racket/src/racket/src/jit.h +++ b/racket/src/racket/src/jit.h @@ -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; diff --git a/racket/src/racket/src/jit_ts.c b/racket/src/racket/src/jit_ts.c index 755fc8a38d..4b5525cae6 100644 --- a/racket/src/racket/src/jit_ts.c +++ b/racket/src/racket/src/jit_ts.c @@ -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 diff --git a/racket/src/racket/src/jitcommon.c b/racket/src/racket/src/jitcommon.c index 2ab2e1c1d3..e0f1fcfe30 100644 --- a/racket/src/racket/src/jitcommon.c +++ b/racket/src/racket/src/jitcommon.c @@ -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 diff --git a/racket/src/racket/src/jitinline.c b/racket/src/racket/src/jitinline.c index 77ef1fc1a5..e35505b524 100644 --- a/racket/src/racket/src/jitinline.c +++ b/racket/src/racket/src/jitinline.c @@ -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; } } diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 3099f85466..0ac3d884b8 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -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