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

cs: repairs to variable-reference-constant?

Browse Source 
Further correct the implementation of `variable-reference-constant?`
on bindings to primitive variable.

This repair affects method-call ctype caching in `ffi/unsafe/objc`.
Add some logging there to make problems easier to detect. Also,
add and improve linklet-evel performance logging for comparing
the traditional Racket VM to Racket-on-Chez.
This commit is contained in:
Matthew Flatt 2018-07-01 15:24:35 -06:00
parent 0f32765fe4
commit a1098bdb46
15 changed files with 352 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test-core/tests/racket/namespac.rktl
View File

@ -147,7 +147,7 @@
(test #f
variable-reference->module-path-index (#%variable-reference test))
(test (module-path-index-join ''#%runtime #f)
(test (module-path-index-join ''#%kernel #f)
variable-reference->module-path-index (#%variable-reference +))
(require (only-in racket/unsafe/ops
[unsafe-fx+ $$unsafe-fx+]))

93
racket/collects/ffi/unsafe/objc.rkt
View File

@ -98,8 +98,10 @@
(define (strcpy s)
(let* ([n (cast s _string _bytes)]
[p (malloc 'raw (add1 (bytes-length n)))])
(memcpy p n (add1 (bytes-length n)))
[len (bytes-length n)]
[p (malloc 'raw (add1 len))])
(memcpy p n len)
(ptr-set! p _byte len 0)
p))
(define (allocate-class-pair-the-hard-way superclass name)
@ -508,7 +510,7 @@
[send send/typed]
[(send-arg ...) send-args])
(quasisyntax/loc stx
((send (type-vector #,result-type type ...))
((send (type-vector '(tag ...) #,result-type type ...))
send-arg ... #,(register-selector (combine #'(tag ...)))
arg ...)))))
@ -530,13 +532,13 @@
(let ([m #'method])
(check-method-name m stx)
(quasisyntax/loc stx
((objc_msgSend/typed (type-vector t)) target #,(register-selector (syntax-e m)))))]
((objc_msgSend/typed (type-vector 'method t)) target #,(register-selector (syntax-e m)))))]
[(_ target method)
(not (keyword? (syntax-e #'target)))
(let ([m #'method])
(check-method-name m stx)
(quasisyntax/loc stx
((objc_msgSend/typed (type-vector _id)) target #,(register-selector (syntax-e m)))))]
((objc_msgSend/typed (type-vector 'method _id)) target #,(register-selector (syntax-e m)))))]
[(_ #:type result-type target method/arg ...)
(build-send stx #'result-type
#'objc_msgSend/typed #'(target)
@ -561,37 +563,39 @@
prims)))))
(define-syntax (type-vector stx)
(let ([types (cdr (syntax->list stx))])
(let ([vec-exp (quasisyntax/loc stx (vector . #,types))]
[type-exprs (cdr (syntax->list stx))])
(cond
[(andmap liftable-type? type-exprs)
;; Recognized types => simple lift
(syntax-local-lift-expression #`(intern-type-vector #,vec-exp))]
[(andmap (lambda (type-expr)
(and (identifier? type-expr)
(pair? (identifier-binding type-expr))))
type-exprs)
;; Types bound as imports => lift with cache and `#%variable-reference-constant?` check
(let* ([expanded-type-exprs
(map (lambda (type-expr)
(local-expand type-expr 'expression #f))
type-exprs)]
[expanded-vec-exp #`(vector . #,expanded-type-exprs)])
(cond
[(andmap identifier? expanded-type-exprs)
(let ([saved-vector-id (syntax-local-lift-expression #'(box #f))])
(quasisyntax/loc stx
(or (unbox #,saved-vector-id)
(maybe-cache-type-vector-in-box
#,expanded-vec-exp
#,saved-vector-id
(vector #,@(for/list ([expanded-type-expr (in-list expanded-type-exprs)])
#`(variable-reference-constant? (#%variable-reference #,expanded-type-expr))))))))]
[else expanded-vec-exp]))]
[else
;; General case: construct type vector every time
vec-exp]))))
(syntax-case stx ()
[(_ who . types)
(let* ([type-exprs (syntax->list #'types)]
[vec-exp (quasisyntax/loc stx (vector . #,type-exprs))])
(cond
[(andmap liftable-type? type-exprs)
;; Recognized types => simple lift
(syntax-local-lift-expression #`(intern-type-vector #,vec-exp))]
[(andmap (lambda (type-expr)
(and (identifier? type-expr)
(pair? (identifier-binding type-expr))))
type-exprs)
;; Types bound as imports => lift with cache and `#%variable-reference-constant?` check
(let* ([expanded-type-exprs
(map (lambda (type-expr)
(local-expand type-expr 'expression #f))
type-exprs)]
[expanded-vec-exp #`(vector . #,expanded-type-exprs)])
(cond
[(andmap identifier? expanded-type-exprs)
(let ([saved-vector-id (syntax-local-lift-expression #'(box #f))])
(quasisyntax/loc stx
(or (unbox #,saved-vector-id)
(maybe-cache-type-vector-in-box
who
#,expanded-vec-exp
#,saved-vector-id
(vector #,@(for/list ([expanded-type-expr (in-list expanded-type-exprs)])
#`(variable-reference-constant? (#%variable-reference #,expanded-type-expr))))))))]
[else expanded-vec-exp]))]
[else
;; General case: construct type vector every time
vec-exp]))]))
(define type-vectors (make-hash))
(define (intern-type-vector v)
@ -600,10 +604,15 @@
(hash-set! type-vectors v v)
v)))
(define (maybe-cache-type-vector-in-box vec saved-vec-box const?s)
(when (for/and ([c? (in-vector const?s)])
c?)
(set-box! saved-vec-box vec))
(define-logger ffi/unsafe/objc)
(define (maybe-cache-type-vector-in-box who vec saved-vec-box const?s)
(cond
[(for/and ([c? (in-vector const?s)])
c?)
(set-box! saved-vec-box vec)]
[else
(log-ffi/unsafe/objc-debug "not a known-constant type vector for ~s" who)])
vec)
;; ----------------------------------------
@ -907,7 +916,7 @@
(let ([m #'method])
(check-method-name m stx)
(quasisyntax/loc stx
((objc_msgSendSuper/typed (type-vector t))
((objc_msgSendSuper/typed (type-vector 'method t))
(make-objc_super self super-class)
#,(register-selector (syntax-e m)))))]
[(_ method)
@ -915,7 +924,7 @@
(let ([m #'method])
(check-method-name m stx)
(quasisyntax/loc stx
((objc_msgSendSuper/typed (type-vector _id))
((objc_msgSendSuper/typed (type-vector 'method _id))
(make-objc_super self super-class)
#,(register-selector (syntax-e m)))))]
[(_ #:type result-type method/arg ...)

2
racket/src/cs/Makefile
View File

@ -5,7 +5,7 @@ RACKET = ../../bin/racket
SCHEME = scheme
# Controls whether Racket layers are built as unsafe:
UNSAFE_COMP = # --unsafe
UNSAFE_COMP = --unsafe
# Controls whether Racket layers are built with expression-level debugging:
DEBUG_COMP = # --debug

20
racket/src/cs/linklet.sls
View File

@ -229,9 +229,10 @@
(define (code-from-bytevector bv)
(let ([i (open-bytevector-input-port bv)])
(performance-region
'outer
((load-compiled-from-port i)))))
(let ([r (load-compiled-from-port i)])
(performance-region
'outer
(r)))))
(define-values (lookup-code insert-code delete-code)
(let ([get-procs!-maker
@ -757,7 +758,7 @@
(linklet-bundle-hash b))
(define-record variable-reference (instance ; the use-site instance
var-or-info)) ; the referenced variable
var-or-info)) ; the referenced variable, 'constant, 'mutable, #f, or 'primitive
(define variable-reference->instance
(case-lambda
@ -775,12 +776,21 @@
(if (eq? i #!bwp)
(variable-reference->instance vr #t)
i))]
[(eq? v 'primitive)
;; FIXME: We don't have the right primitive instance name
;; ... but '#%kernel is usually right.
'|#%kernel|]
[else
;; Local variable, so same as use-site
(variable-reference->instance vr #t)]))]))
(define (variable-reference-constant? vr)
(eq? (variable-reference-var-or-info vr) 'constant))
(let ([v (variable-reference-var-or-info vr)])
(cond
[(variable? v)
(and (variable-constance v) #t)]
[(eq? v 'mutable) #f]
[else (and v #t)])))
(define (variable-reference-from-unsafe? vr)
#f)

17
racket/src/cs/linklet/performance.ss
View File

@ -43,15 +43,19 @@
(define (linklet-performance-report!)
(when measure-performance?
(let ([total 0])
(let* ([total (apply + (hash-table-map region-times (lambda (k v) (round (inexact->exact v)))))]
[gc-total (apply + (hash-table-map region-gc-times (lambda (k v) v)))]
[name-len (apply max (hash-table-map region-times (lambda (k v) (string-length (symbol->string k)))))]
[len (string-length (number->string total))]
[gc-len (string-length (number->string gc-total))])
(define (pad v w)
(let ([s (chez:format "~a" v)])
(string-append (make-string (max 0 (- w (string-length s))) #\space)
s)))
(define (report label n n-extra units extra)
(chez:printf ";; ~a: ~a~a ~a~a\n"
(pad label 15)
(pad (round (inexact->exact n)) 5)
(chez:printf ";; ~a: ~a~a ~a~a\n"
(pad label name-len)
(pad (round (inexact->exact n)) len)
n-extra
units
extra))
@ -61,16 +65,15 @@
(for-each (lambda (p)
(let ([label (car p)]
[n (cdr p)])
(set! total (+ total n))
(report label n
(chez:format " [~a]" (pad (hashtable-ref region-gc-times label 0) 5))
(chez:format " [~a]" (pad (hashtable-ref region-gc-times label 0) gc-len))
'ms
(let ([c (hashtable-ref region-counts label 0)])
(if (zero? c)
""
(chez:format " ; ~a times" c))))))
(ht->sorted-list region-times))
(report 'total total "" 'ms "")
(report 'total total (#%format " [~a]" gc-total) 'ms "")
(chez:printf ";;\n")
(for-each (lambda (p) (report (car p) (/ (cdr p) 1024 1024) "" 'MB ""))
(ht->sorted-list region-memories)))))

3
racket/src/expander/expand/expr.rkt
View File

@ -737,10 +737,9 @@
(raise-syntax-error #f "identifier does not refer to a variable" var-id s))
(if (expand-context-to-parsed? ctx)
(parsed-#%variable-reference (keep-properties-only~ s)
;; Intentionally not using `parsed-primitive-id`;
;; see also `variable-reference->namespace`
(cond
[(top-m) (parsed-top-id var-id binding #f)]
[primitive? (parsed-primitive-id var-id binding #f)]
[else (parsed-id var-id binding #f)]))
s)]
[else

3
racket/src/expander/namespace/variable-reference.rkt
View File

@ -38,8 +38,7 @@
(cond
[(symbol? inst)
;; This case happens for `(#%variable-reference id)` where `id`
;; refers directly to a primitive. The expander doesn't currently
;; generate that, but just in case... We get a namespace for a
;; refers directly to a primitive. We get a namespace for a
;; primitive instance; that might not be the same module as
;; reorted by `identifier-binding`, but close enough.
(module->namespace `',inst (instance-data (variable-reference->instance vr #t)))]

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

@ -3701,12 +3701,14 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
GC_CAN_IGNORE ffi_cif *cif;
int i, nargs, save_errno;
Scheme_Object *lock = scheme_false;
Scheme_Performance_State perf_state;
# ifdef MZ_USE_PLACES
int orig_place = MZ_USE_FFIPOLL_COND;
# define FFI_CALL_VEC_SIZE 9
# else /* MZ_USE_PLACES undefined */
# define FFI_CALL_VEC_SIZE 8
# endif /* MZ_USE_PLACES */
scheme_performance_record_start(&perf_state);
if (!curry) {
cp = unwrap_cpointer_property(argv[ARGPOS(0)]);
if (!SCHEME_FFIANYPTRP(cp))
@ -3784,6 +3786,8 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
a[0] = data;
scheme_performance_record_end("comp-ffi", &perf_state);
if (curry) {
return scheme_make_prim_closure_w_arity(make_ffi_call_from_curried,
1, a,
@ -4137,6 +4141,7 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
GC_CAN_IGNORE closure_and_cif *cl_cif_args;
GC_CAN_IGNORE ffi_callback_t do_callback;
GC_CAN_IGNORE void *callback_data;
Scheme_Performance_State perf_state;
# ifdef MZ_USE_MZRT
int keep_queue = 0;
void *constant_reply = NULL;
@ -4164,6 +4169,8 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
return NULL;
}
scheme_performance_record_start(&perf_state);
if (((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]))) {
# ifdef MZ_USE_MZRT
if (!ffi_sync_queue) {
@ -4265,6 +4272,8 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
# endif /* MZ_USE_MZRT */
scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL);
scheme_performance_record_end("comp-ffi-back", &perf_state);
return (Scheme_Object*)data;
#undef ARGPOS
}

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

@ -2872,12 +2872,14 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
GC_CAN_IGNORE ffi_cif *cif;
int i, nargs, save_errno;
Scheme_Object *lock = scheme_false;
Scheme_Performance_State perf_state;
@@@IFDEF{MZ_USE_PLACES}{
int orig_place = MZ_USE_FFIPOLL_COND;
@DEFINE{FFI_CALL_VEC_SIZE 9}
}{
@DEFINE{FFI_CALL_VEC_SIZE 8}
}
scheme_performance_record_start(&perf_state);
if (!curry) {
cp = unwrap_cpointer_property(argv[ARGPOS(0)]);
if (!SCHEME_FFIANYPTRP(cp))
@ -2955,6 +2957,8 @@ static Scheme_Object *ffi_call_or_curry(const char *who, int curry, int argc, Sc
scheme_register_finalizer(data, free_fficall_data, cif, NULL, NULL);
a[0] = data;
scheme_performance_record_end("comp-ffi", &perf_state);
if (curry) {
return scheme_make_prim_closure_w_arity(make_ffi_call_from_curried,
1, a,
@ -3298,6 +3302,7 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
GC_CAN_IGNORE closure_and_cif *cl_cif_args;
GC_CAN_IGNORE ffi_callback_t do_callback;
GC_CAN_IGNORE void *callback_data;
Scheme_Performance_State perf_state;
@@IFDEF{MZ_USE_MZRT}{
int keep_queue = 0;
void *constant_reply = NULL;
@ -3324,6 +3329,8 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
/* all checks are done */
return NULL;
}
scheme_performance_record_start(&perf_state);
if (((argc > ARGPOS(5)) && SCHEME_TRUEP(argv[ARGPOS(5)]))) {
@@IFDEF{MZ_USE_MZRT}{
@ -3422,6 +3429,8 @@ static Scheme_Object *ffi_callback_or_curry(const char *who, int curry, int argc
}
scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL);
scheme_performance_record_end("comp-ffi-back", &perf_state);
return (Scheme_Object*)data;
#undef ARGPOS
}

6
racket/src/racket/src/jitstate.c
View File

@ -218,6 +218,7 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
intptr_t size_pre_retained = 0, size_pre_retained_double = 0, num_retained = 0, num_retained_double = 0, padding;
int mappings_size = JIT_INIT_MAPPINGS_SIZE;
int ok, max_extra_pushed = 0;
Scheme_Performance_State perf_state;
#ifdef SET_DEFAULT_LONG_JUMPS
int use_long_jumps = default_long_jumps;
#endif
@ -232,6 +233,8 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
fnl_obj = NULL;
#endif
scheme_performance_record_start(&perf_state);
if (!jit_buffer_cache_registered) {
jit_buffer_cache_registered = 1;
REGISTER_SO(jit_buffer_cache);
@ -316,6 +319,7 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
then switch over to long-jump mode. */
if (check_long_mode((uintptr_t)buffer, size)) {
/* start over */
scheme_performance_record_end("jit", &perf_state);
return scheme_generate_one(old_jitter, generate, data, gcable,
save_ptr, ndata);
}
@ -368,6 +372,7 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
if (!use_long_jumps) {
if (check_long_mode((uintptr_t)buffer, size)) {
/* start over */
scheme_performance_record_end("jit", &perf_state);
return scheme_generate_one(old_jitter, generate, data, gcable,
save_ptr, ndata);
}
@ -431,6 +436,7 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
if (known_size) {
/* That was in the permanent area, so return: */
jit_flush_code(buffer, jit_get_raw_ip());
scheme_performance_record_end("jit", &perf_state);
return buffer;
} else {
/* Allocate permanent area and jit again: */

204
racket/src/racket/src/linklet.c
View File

@ -1166,6 +1166,9 @@ static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Sche
{
Scheme_Config *config;
int enforce_const, set_undef, can_inline;
Scheme_Performance_State perf_state;
scheme_performance_record_start(&perf_state);
config = scheme_current_config();
enforce_const = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS));
@ -1202,6 +1205,8 @@ static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Sche
if (validate_compile_result)
scheme_validate_linklet(NULL, linklet);
scheme_performance_record_end("compile", &perf_state);
return linklet;
}
@ -1351,6 +1356,9 @@ static void *instantiate_linklet_k(void)
int depth;
Scheme_Object *b, *v;
Scheme_Hash_Tree *source_names;
Scheme_Performance_State perf_state;
scheme_performance_record_start(&perf_state);
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
@ -1403,6 +1411,8 @@ static void *instantiate_linklet_k(void)
if (!multi)
v = scheme_check_one_value(v);
scheme_performance_record_end("instantiate", &perf_state);
return (void *)v;
}
@ -1713,6 +1723,200 @@ int check_pruned_prefix(void *p) XFORM_SKIP_PROC
}
#endif
/*========================================================================*/
/* Recorindg performance times */
/*========================================================================*/
static intptr_t nested_delta, nested_gc_delta;
static int perf_reg, perf_count;
typedef struct {
const char *name;
intptr_t accum;
intptr_t gc_accum;
intptr_t count;
} Performance_Entry;
#define MAX_PERF_ENTRIES 16
static Performance_Entry perf_entries[MAX_PERF_ENTRIES];
static char *do_tab(int len, char *tab, int max_len)
{
int i;
len = max_len - len;
if (len < 0)
len = 0;
for (i = 0; i < len; i++) {
tab[i] = ' ';
}
tab[i] = 0;
return tab;
}
static int numlen(intptr_t n)
{
int len = 1;
while (n >= 10) {
n = n / 10;
len++;
}
return len;
}
static char *tab_number(intptr_t n, char *tab, int max_len)
{
return do_tab(numlen(n), tab, max_len);
}
static char *tab_string(const char *s, char *tab, int max_len)
{
return do_tab(strlen(s), tab, max_len);
}
static void sort_perf(int lo, int hi)
{
int i, pivot;
if (lo >= hi)
return;
pivot = lo;
for (i = lo + 1; i < hi; i++) {
if (perf_entries[i].accum < perf_entries[pivot].accum) {
Performance_Entry tmp = perf_entries[pivot];
perf_entries[pivot] = perf_entries[i];
perf_entries[i] = perf_entries[pivot+1];
perf_entries[pivot+1] = tmp;
pivot++;
}
}
sort_perf(lo, pivot);
sort_perf(pivot+1, hi);
}
static void show_perf()
{
intptr_t total = 0, gc_total = 0;
int i, name_len = 0, len, gc_len;
char name_tab[16], tab[10], gc_tab[10];
sort_perf(0, perf_count);
for (i = 0; i < perf_count; i++) {
len = strlen(perf_entries[i].name);
if (len > name_len) name_len = len;
total += perf_entries[i].accum;
gc_total += perf_entries[i].gc_accum;
}
len = numlen(total);
gc_len = numlen(gc_total);
if (name_len >= sizeof(name_tab))
name_len = sizeof(name_tab) - 1;
if (len >= sizeof(tab))
len = sizeof(tab) - 1;
if (gc_len >= sizeof(gc_tab))
gc_len = sizeof(gc_tab) -1;
for (i = 0; i < perf_count; i++) {
fprintf(stderr, ";; %s%s: %s%"PRIdPTR " [%s%"PRIdPTR"] ms ; %"PRIdPTR" times\n",
tab_string(perf_entries[i].name, name_tab, name_len),
perf_entries[i].name,
tab_number(perf_entries[i].accum, tab, len),
perf_entries[i].accum,
tab_number(perf_entries[i].gc_accum, gc_tab, gc_len),
perf_entries[i].gc_accum,
perf_entries[i].count);
}
fprintf(stderr, ";; %stotal: %s%"PRIdPTR " [%s%"PRIdPTR"] ms\n",
tab_string("total", name_tab, name_len),
tab_number(total, tab, len),
total,
tab_number(gc_total, gc_tab, gc_len),
gc_total);
}
void scheme_performance_record_start(GC_CAN_IGNORE Scheme_Performance_State *perf_state)
{
#if defined(MZ_USE_PLACES)
if (scheme_current_place_id != 0)
return;
#endif
if (!perf_reg) {
if (scheme_getenv("PLT_LINKLET_TIMES")) {
perf_reg = 1;
scheme_atexit(show_perf);
} else {
perf_reg = -1;
}
}
if (perf_reg < 0)
return;
perf_state->gc_start = scheme_total_gc_time;
perf_state->start = scheme_get_process_milliseconds();
perf_state->old_nested_delta = nested_delta;
perf_state->old_nested_gc_delta = nested_gc_delta;
nested_delta = 0;
nested_gc_delta = 0;
}
void scheme_performance_record_end(const char *who, GC_CAN_IGNORE Scheme_Performance_State *perf_state)
{
int i;
intptr_t d, gc_d;
#if defined(MZ_USE_PLACES)
if (scheme_current_place_id != 0)
return;
#endif
if (perf_reg < 0)
return;
for (i = 0; i < MAX_PERF_ENTRIES; i++) {
if (perf_entries[i].name) {
if (!strcmp(perf_entries[i].name, who))
break;
} else
break;
}
if (i >= MAX_PERF_ENTRIES)
return;
d = (scheme_get_process_milliseconds() - perf_state->start);
gc_d = (scheme_total_gc_time - perf_state->gc_start);
perf_state->old_nested_delta += d;
perf_state->old_nested_gc_delta += gc_d;
d -= nested_delta;
gc_d -= nested_gc_delta;
nested_delta = perf_state->old_nested_delta;
nested_gc_delta = perf_state->old_nested_gc_delta;
if (!perf_entries[i].name) {
perf_entries[i].name = who;
perf_count++;
}
perf_entries[i].accum += d;
perf_entries[i].gc_accum += gc_d;
perf_entries[i].count++;
}
/*========================================================================*/
/* precise GC traversers */
/*========================================================================*/

18
racket/src/racket/src/read.c
View File

@ -3854,7 +3854,10 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
Scheme_Object *dir;
Scheme_Config *config;
char hash_code[20];
Scheme_Performance_State perf_state;
scheme_performance_record_start(&perf_state);
while (1) {
bundle_pos = SCHEME_INT_VAL(scheme_file_position(1, &port)) - 2; /* -2 for "#~" */
@ -4125,11 +4128,14 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
v = bundle_list_to_hierarchical_directory(bundles);
if (!v)
scheme_read_err(port, "read (compiled): bad shape for bundle-directory tree");
scheme_performance_record_end("read", &perf_state);
return v;
}
/* otherwise, continue reading bundles */
} else
} else {
scheme_performance_record_end("read", &perf_state);
return result;
}
} else {
scheme_read_err(port, "read (compiled): found bad mode");
}
@ -4163,6 +4169,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
v = bundle_list_to_hierarchical_directory(bundles);
if (!v)
scheme_read_err(port, "read (compiled): bad shape for bundle-directory tree");
scheme_performance_record_end("read", &perf_state);
return v;
}
} else {
@ -4226,7 +4233,10 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in
Scheme_Object * volatile v_exn;
Scheme_Hash_Table ** volatile ht;
mz_jmp_buf newbuf, * volatile savebuf;
Scheme_Performance_State perf_state;
scheme_performance_record_start(&perf_state);
/* Remove from cache-clearing chain: */
if (!delay_info->perma_cache) {
if (delay_info->clear_bytes_prev)
@ -4353,7 +4363,9 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in
}
scheme_end_atomic_no_swap();
scheme_performance_record_end("demand-read", &perf_state);
if (v) {
/* Although `which` is a symbol-table index for `v`,
we don't actually record v, because the delayed

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

@ -3847,6 +3847,14 @@ void *scheme_environment_variables_to_block(Scheme_Object *env, int *_need_free)
int scheme_compare_equal(void *v1, void *v2);
typedef struct Scheme_Performance_State {
intptr_t start, gc_start;
intptr_t old_nested_delta, old_nested_gc_delta;
} Scheme_Performance_State;
void scheme_performance_record_start(Scheme_Performance_State *perf_state);
void scheme_performance_record_end(const char *who, Scheme_Performance_State *perf_state);
/*========================================================================*/
/* places */
/*========================================================================*/

4
racket/src/racket/src/startup.inc
View File

@ -67960,7 +67960,9 @@ static const char *startup_source =
"(keep-properties-only~ s_720)"
"(if ok?_61"
"(let-values()(parsed-top-id4.1 var-id_0 binding_30 #f))"
"(let-values()(parsed-id2.1 var-id_0 binding_30 #f))))"
"(if primitive?_12"
"(let-values()(parsed-primitive-id3.1 var-id_0 binding_30 #f))"
"(let-values()(parsed-id2.1 var-id_0 binding_30 #f)))))"
" s_720))))))))"
"(let-values()"
"(if(expand-context-to-parsed? ctx_103)"

26
racket/src/schemify/schemify.rkt
View File

@ -479,11 +479,20 @@
`(,(if allow-set!-undefined? 'variable-set! 'variable-set!/check-undefined) ,(export-id ex) ,(schemify rhs) '#f)
`(set! ,id ,(schemify rhs)))]
[`(variable-reference-constant? (#%variable-reference ,id))
(let ([id (unwrap id)])
(and (not (hash-ref mutated id #f))
(let ([im (hash-ref imports id #f)])
(or (not im)
(known-constant? (import-lookup im))))))]
(define u-id (unwrap id))
(cond
[(hash-ref mutated u-id #f) #f]
[else
(define im (hash-ref imports u-id #f))
(cond
[(not im)
;; Not imported and not mutable => a constant or local defined
;; in this linklet or a direct primitive reference
#t]
[(known-constant? (import-lookup im)) #t]
[else
;; Not statically known
`(variable-reference-constant? ,(schemify `(#%variable-reference ,id)))])])]
[`(variable-reference-from-unsafe? (#%variable-reference))
unsafe-mode?]
[`(#%variable-reference)
@ -500,9 +509,10 @@
,v)
`(make-instance-variable-reference
instance-variable-reference
',(if (hash-ref mutated u #f)
'mutable
'immutable)))]
',(cond
[(hash-ref mutated u #f) 'mutable]
[(hash-ref prim-knowns u #f) 'primitive]
[else 'constant])))]
[`(equal? ,exp1 ,exp2)
(let ([exp1 (schemify exp1)]
[exp2 (schemify exp2)])