From 736e6efc2d173480ad0b81afd8ce589af392edc1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Oct 2012 08:50:37 -0700 Subject: [PATCH] recognize `struct' bindings as constant The JIT takes advantage of known-constant bindings to avoid the check that a variable is still bound to a structure predicate, selector, or mutator; that makes the code short enough to really inline. The inlined version takes about half the time of the indirect version. The compiler does not yet track bindings precisely enough to recognize constants for sub-type declarations. --- .../shootout/binarytrees-normal.rkt | 49 ++ src/racket/src/cstartup.inc | 62 +-- src/racket/src/eval.c | 10 +- src/racket/src/jit.h | 11 + src/racket/src/jitcommon.c | 382 ++++++++++------ src/racket/src/jitinline.c | 121 ++++- src/racket/src/module.c | 39 +- src/racket/src/optimize.c | 421 ++++++++++++------ src/racket/src/schpriv.h | 3 + src/racket/src/schvers.h | 4 +- src/racket/src/struct.c | 19 +- src/racket/src/validate.c | 7 +- 12 files changed, 783 insertions(+), 345 deletions(-) create mode 100644 collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt diff --git a/collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt b/collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt new file mode 100644 index 0000000000..15a4143d17 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt @@ -0,0 +1,49 @@ +#lang racket/base + +;;; The Computer Language Benchmarks Game +;;; http://shootout.alioth.debian.org/ +;;; Derived from the Chicken variant by Sven Hartrumpf + +(require racket/cmdline racket/require (for-syntax racket/base) + (filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name "")) + racket/unsafe/ops)) + +(struct leaf (val)) +(struct node leaf (left right)) + +(define (make item d) + (if (fx= d 0) + (leaf item) + (let ([item2 (fx* item 2)] [d2 (fx- d 1)]) + (node item (make (fx- item2 1) d2) (make item2 d2))))) + +(define (check t) + (let loop ([t t] [acc 0]) + (let ([acc (fx+ (leaf-val t) acc)]) + (if (node? t) + (loop (node-left t) + (fx- acc (loop (node-right t) 0))) + acc)))) + +(define min-depth 4) + +(define (main n) + (let ([max-depth (max (+ min-depth 2) n)]) + (let ([stretch-depth (+ max-depth 1)]) + (printf "stretch tree of depth ~a\t check: ~a\n" + stretch-depth + (check (make 0 stretch-depth)))) + (let ([long-lived-tree (make 0 max-depth)]) + (for ([d (in-range 4 (+ max-depth 1) 2)]) + (let ([iterations (expt 2 (+ (- max-depth d) min-depth))]) + (printf "~a\t trees of depth ~a\t check: ~a\n" + (* 2 iterations) + d + (for/fold ([c 0]) ([i (in-range iterations)]) + (fx+ c (fx+ (check (make i d)) + (check (make (fx- 0 i) d)))))))) + (printf "long lived tree of depth ~a\t check: ~a\n" + max-depth + (check long-lived-tree))))) + +(command-line #:args (n) (main (string->number n))) diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index aa06b8fe50..e08d4734b2 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,14 +1,14 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, -27,0,31,0,38,0,42,0,49,0,54,0,61,0,66,0,69,0,74,0,83, +21,0,25,0,29,0,36,0,41,0,54,0,61,0,66,0,69,0,74,0,83, 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, 163,0,170,0,192,0,194,0,208,0,19,1,48,1,59,1,70,1,96,1,129, 1,162,1,221,1,21,2,99,2,155,2,160,2,180,2,73,3,93,3,145,3, 211,3,100,4,242,4,40,5,51,5,130,5,0,0,92,7,0,0,69,35,37, -109,105,110,45,115,116,120,29,11,11,11,72,112,97,114,97,109,101,116,101,114, -105,122,101,63,97,110,100,66,100,101,102,105,110,101,63,108,101,116,66,117,110, -108,101,115,115,64,99,111,110,100,66,108,101,116,114,101,99,64,108,101,116,42, +109,105,110,45,115,116,120,29,11,11,11,66,100,101,102,105,110,101,63,97,110, +100,63,108,101,116,66,117,110,108,101,115,115,64,99,111,110,100,72,112,97,114, +97,109,101,116,101,114,105,122,101,66,108,101,116,114,101,99,64,108,101,116,42, 62,111,114,64,119,104,101,110,68,104,101,114,101,45,115,116,120,29,11,11,11, 65,113,117,111,116,101,29,94,2,15,68,35,37,107,101,114,110,101,108,11,29, 94,2,15,68,35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105, @@ -16,12 +16,12 @@ 108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,1, 20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121, 61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240, -85,88,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16, -20,2,8,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2, -2,10,2,2,2,3,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97, -37,11,8,240,85,88,0,0,93,159,2,16,36,37,16,2,2,13,161,2,2, -37,2,13,2,2,2,13,96,11,11,8,240,85,88,0,0,16,0,96,38,11, -8,240,85,88,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14, +110,88,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16, +20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,10,2,2, +2,7,2,2,2,8,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97, +37,11,8,240,110,88,0,0,93,159,2,16,36,37,16,2,2,13,161,2,2, +37,2,13,2,2,2,13,96,38,11,8,240,110,88,0,0,16,0,96,11,11, +8,240,110,88,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14, 2,2,11,11,11,8,32,8,31,8,30,8,29,27,248,22,163,4,195,249,22, 156,4,80,158,39,36,251,22,89,2,18,248,22,104,199,12,249,22,79,2,19, 248,22,106,201,27,248,22,163,4,195,249,22,156,4,80,158,39,36,251,22,89, @@ -30,14 +30,14 @@ 81,194,248,22,80,193,249,22,156,4,80,158,39,36,251,22,89,2,18,248,22, 80,199,249,22,79,2,4,248,22,81,201,11,18,100,10,13,16,6,36,2,14, 2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2,20,3,1, -8,101,110,118,49,55,50,57,54,16,4,11,11,2,21,3,1,8,101,110,118, -49,55,50,57,55,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,14, +8,101,110,118,49,55,51,51,57,16,4,11,11,2,21,3,1,8,101,110,118, +49,55,51,52,48,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,14, 159,37,36,37,28,248,22,87,248,22,81,194,248,22,80,193,249,22,156,4,80, 158,39,36,250,22,89,2,22,248,22,89,249,22,89,248,22,89,2,23,248,22, 80,201,251,22,89,2,18,2,23,2,23,249,22,79,2,11,248,22,81,204,18, 100,11,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29, -16,4,11,11,2,20,3,1,8,101,110,118,49,55,50,57,57,16,4,11,11, -2,21,3,1,8,101,110,118,49,55,51,48,48,248,22,163,4,193,27,248,22, +16,4,11,11,2,20,3,1,8,101,110,118,49,55,51,52,50,16,4,11,11, +2,21,3,1,8,101,110,118,49,55,51,52,51,248,22,163,4,193,27,248,22, 163,4,194,249,22,79,248,22,89,248,22,80,196,248,22,81,195,27,248,22,81, 248,22,163,4,23,197,1,249,22,156,4,80,158,39,36,28,248,22,64,248,22, 157,4,248,22,80,23,198,2,27,249,22,2,32,0,88,163,8,36,37,43,11, @@ -51,7 +51,7 @@ 249,22,2,32,0,88,163,8,36,37,47,11,9,222,33,43,248,22,163,4,248, 22,80,201,248,22,81,198,27,248,22,81,248,22,163,4,196,27,248,22,163,4, 248,22,80,195,249,22,156,4,80,158,40,36,28,248,22,87,195,250,22,90,2, -22,9,248,22,81,199,250,22,89,2,6,248,22,89,248,22,80,199,250,22,90, +22,9,248,22,81,199,250,22,89,2,5,248,22,89,248,22,80,199,250,22,90, 2,10,248,22,81,201,248,22,81,202,27,248,22,81,248,22,163,4,23,197,1, 27,249,22,1,22,93,249,22,2,22,163,4,248,22,163,4,248,22,80,199,248, 22,183,4,249,22,156,4,80,158,41,36,251,22,89,1,22,119,105,116,104,45, @@ -63,12 +63,12 @@ 193,20,14,159,37,36,37,249,22,156,4,80,158,39,36,27,248,22,163,4,248, 22,80,197,28,249,22,152,9,62,61,62,248,22,157,4,248,22,104,196,250,22, 89,2,22,248,22,89,249,22,89,21,93,2,27,248,22,80,199,250,22,90,2, -8,249,22,89,2,27,249,22,89,248,22,113,203,2,27,248,22,81,202,251,22, +7,249,22,89,2,27,249,22,89,248,22,113,203,2,27,248,22,81,202,251,22, 89,2,18,28,249,22,152,9,248,22,157,4,248,22,80,200,64,101,108,115,101, -10,248,22,80,197,250,22,90,2,22,9,248,22,81,200,249,22,79,2,8,248, +10,248,22,80,197,250,22,90,2,22,9,248,22,81,200,249,22,79,2,7,248, 22,81,202,99,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30, -8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,51,50,50,16,4, -11,11,2,21,3,1,8,101,110,118,49,55,51,50,51,18,158,94,10,64,118, +8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,51,54,53,16,4, +11,11,2,21,3,1,8,101,110,118,49,55,51,54,54,18,158,94,10,64,118, 111,105,100,8,48,27,248,22,81,248,22,163,4,196,249,22,156,4,80,158,39, 36,28,248,22,64,248,22,157,4,248,22,80,197,250,22,89,2,28,248,22,89, 248,22,80,199,248,22,104,198,27,248,22,157,4,248,22,80,197,250,22,89,2, @@ -81,25 +81,25 @@ 11,2,12,36,46,37,16,0,36,16,1,2,13,37,11,11,11,16,0,16,0, 16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,11,16,5,11, 20,15,16,2,20,14,159,36,36,37,80,158,36,36,36,20,113,159,36,16,1, -2,13,16,1,33,33,10,16,5,2,7,88,163,8,36,37,53,37,9,223,0, +2,13,16,1,33,33,10,16,5,2,6,88,163,8,36,37,53,37,9,223,0, 33,34,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2,12,88,163,8, 36,37,53,37,9,223,0,33,35,36,20,113,159,36,16,1,2,13,16,0,11, 16,5,2,4,88,163,8,36,37,53,37,9,223,0,33,36,36,20,113,159,36, 16,1,2,13,16,1,33,37,11,16,5,2,11,88,163,8,36,37,56,37,9, 223,0,33,38,36,20,113,159,36,16,1,2,13,16,1,33,39,11,16,5,2, -6,88,163,8,36,37,58,37,9,223,0,33,42,36,20,113,159,36,16,1,2, +5,88,163,8,36,37,58,37,9,223,0,33,42,36,20,113,159,36,16,1,2, 13,16,0,11,16,5,2,9,88,163,8,36,37,53,37,9,223,0,33,44,36, 20,113,159,36,16,1,2,13,16,0,11,16,5,2,10,88,163,8,36,37,54, 37,9,223,0,33,45,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2, -3,88,163,8,36,37,56,37,9,223,0,33,46,36,20,113,159,36,16,1,2, -13,16,0,11,16,5,2,8,88,163,8,36,37,58,37,9,223,0,33,47,36, -20,113,159,36,16,1,2,13,16,1,33,49,11,16,5,2,5,88,163,8,36, +8,88,163,8,36,37,56,37,9,223,0,33,46,36,20,113,159,36,16,1,2, +13,16,0,11,16,5,2,7,88,163,8,36,37,58,37,9,223,0,33,47,36, +20,113,159,36,16,1,2,13,16,1,33,49,11,16,5,2,3,88,163,8,36, 37,54,37,9,223,0,33,50,36,20,113,159,36,16,1,2,13,16,0,11,16, 0,94,2,16,2,17,93,2,16,9,9,36,0}; EVAL_ONE_SIZED_STR((char *)expr, 2028); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,126,0,0,0,1,0,0,8,0,21,0, 26,0,43,0,55,0,77,0,106,0,121,0,139,0,151,0,167,0,181,0,203, 0,219,0,236,0,2,1,13,1,19,1,28,1,35,1,42,1,54,1,70,1, @@ -373,7 +373,7 @@ 95,23,195,1,23,197,1,249,22,164,2,195,88,163,8,36,38,48,11,9,223, 3,33,96,28,197,86,94,20,18,159,11,80,158,42,49,193,20,18,159,11,80, 158,42,50,196,86,94,20,18,159,11,80,158,42,55,193,20,18,159,11,80,158, -42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,8,88,163,8,32, +42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,9,88,163,8,32, 37,8,40,8,240,0,240,94,0,9,224,1,2,33,97,0,7,35,114,120,34, 47,43,34,28,248,22,142,7,23,195,2,27,249,22,175,15,2,99,196,28,192, 28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,145,7,198,249,22,7, @@ -579,7 +579,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 10007); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,12,0,0,0,1,0,0,15,0,40,0, 57,0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,179, 1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115, @@ -606,7 +606,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 501); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,89,0,0,0,1,0,0,7,0,18,0, 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,63,1,94,1,101,1, @@ -1012,7 +1012,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 8458); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,98,1,0, 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, @@ -1020,7 +1020,7 @@ 114,107,11,29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2, 74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,2,66, 35,37,98,111,111,116,11,29,94,2,2,68,35,37,101,120,112,111,98,115,11, -29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,111,90, +29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,136,90, 0,0,100,159,2,3,36,36,159,2,4,36,36,159,2,5,36,36,159,2,6, 36,36,159,2,7,36,36,159,2,8,36,36,159,2,9,36,36,159,2,9,36, 36,16,0,159,36,20,113,159,36,16,1,11,16,0,20,26,144,9,2,1,2, diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 98c293b3f7..0f54e2ca8b 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1889,10 +1889,15 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, g = scheme_current_thread->ku.multiple.count; if (i == g) { + int is_st; + values = scheme_current_thread->ku.multiple.array; scheme_current_thread->ku.multiple.array = NULL; if (SAME_OBJ(values, scheme_current_thread->values_buffer)) scheme_current_thread->values_buffer = NULL; + + is_st = scheme_is_simple_make_struct_type(vals_expr, g, 1, 1); + for (i = 0; i < g; i++) { var = SCHEME_VEC_ELS(vec)[i+delta]; if (dm_env) { @@ -1913,7 +1918,10 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, 1); if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; + if (is_st) + ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_IMMUTATED | GLOB_IS_CONSISTENT); + else + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; } } } diff --git a/src/racket/src/jit.h b/src/racket/src/jit.h index edd9ebe0f6..24e92ff4e7 100644 --- a/src/racket/src/jit.h +++ b/src/racket/src/jit.h @@ -1266,6 +1266,17 @@ void scheme_jit_release_native_code(void *fnlized, void *p); int scheme_do_generate_common(mz_jit_state *jitter, void *_data); int scheme_do_generate_more_common(mz_jit_state *jitter, void *_data); +int scheme_save_struct_temp(mz_jit_state *jitter, int reg); +int scheme_restore_struct_temp(mz_jit_state *jitter, int reg); +int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, + Branch_Info *branch_info, int branch_short, + int result_ignored, + int check_proc, int check_arg_fixnum, + int type_pos, int field_pos, + int pop_and_jump, + jit_insn *refslow, jit_insn *refslow2, + jit_insn *bref_false, jit_insn *bref_true); + /**********************************************************************/ /* jit */ /**********************************************************************/ diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index 80711c9918..e9e99a72c7 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -101,21 +101,25 @@ static Scheme_Object *vector_check_chaperone_of(Scheme_Object *o, Scheme_Object return o; } -static int save_struct_temp(mz_jit_state *jitter) +static int save_struct_temp(mz_jit_state *jitter, int reg) { #ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_V(3), JIT_V1); + jit_movr_p(JIT_V(3), reg); #endif #ifdef MZ_USE_JIT_I386 # ifdef X86_ALIGN_STACK - mz_set_local_p(JIT_V1, JIT_LOCAL3); + mz_set_local_p(reg, JIT_LOCAL3); # else - jit_pushr_p(JIT_V1); + jit_pushr_p(reg); # endif #endif return 1; } +int scheme_save_struct_temp(mz_jit_state *jitter, int reg) { + return save_struct_temp(jitter, reg); +} + static int restore_struct_temp(mz_jit_state *jitter, int reg) { #ifdef MZ_USE_JIT_PPC @@ -131,6 +135,10 @@ static int restore_struct_temp(mz_jit_state *jitter, int reg) return 1; } +int scheme_restore_struct_temp(mz_jit_state *jitter, int reg) { + return restore_struct_temp(jitter, reg); +} + static void allocate_values(int count, Scheme_Thread *p) { Scheme_Object **a; @@ -1418,6 +1426,227 @@ static int gen_struct_slow(mz_jit_state *jitter, int kind, int ok_proc, return 1; } +int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, + Branch_Info *branch_info, int branch_short, + int result_ignored, + int check_proc, int check_arg_fixnum, + int type_pos, int field_pos, + int pop_and_jump, + GC_CAN_IGNORE jit_insn *refslow, GC_CAN_IGNORE jit_insn *refslow2, + GC_CAN_IGNORE jit_insn *bref_false, GC_CAN_IGNORE jit_insn *bref_true) +/* kind: pred (1), get (2), or set (3) + R0 is (potential) struct proc, R1 is (potential) struct. + In set mode, value to install is saved as a temp. */ +{ + GC_CAN_IGNORE jit_insn *ref2, *ref3, *bref1, *bref2, *refretry; + GC_CAN_IGNORE jit_insn *bref3, *bref4, *bref8, *ref9, *refdone; + + __START_SHORT_JUMPS__(branch_short); + + if (check_proc) { + (void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); + jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); + (void)jit_bnei_i(refslow, JIT_R2, ((kind == 3) + ? SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER + : ((kind == 1) + ? SCHEME_PRIM_STRUCT_TYPE_PRED + : SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER))); + } + + CHECK_LIMIT(); + /* Check argument: */ + if (kind == 1) { + bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1); + refretry = _jit.x.pc; + jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); + __START_INNER_TINY__(1); + ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); + ref3 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_struct_type); + ref9 = jit_beqi_i(jit_forward(), JIT_R2, scheme_chaperone_type); + __END_INNER_TINY__(1); + bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type); + CHECK_LIMIT(); + __START_INNER_TINY__(1); + mz_patch_branch(ref9); + jit_ldxi_p(JIT_R1, JIT_R1, &SCHEME_CHAPERONE_VAL(0x0)); + (void)jit_jmpi(refretry); + mz_patch_branch(ref3); + __END_INNER_TINY__(1); + } else { + if (check_arg_fixnum) { + (void)jit_bmsi_ul(refslow2, JIT_R1, 0x1); + } + jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); + __START_INNER_TINY__(1); + ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); + __END_INNER_TINY__(1); + (void)jit_bnei_i(refslow2, JIT_R2, scheme_proc_struct_type); + bref1 = bref2 = NULL; + } + __START_INNER_TINY__(1); + mz_patch_branch(ref2); + __END_INNER_TINY__(1); + CHECK_LIMIT(); + + if (type_pos != 0) { + /* Put argument struct type in R2, target struct type in V1 */ + jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); + if (type_pos < 0) { + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (kind >= 2) { + jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); + } + } + CHECK_LIMIT(); + + if (type_pos < 0) { + /* common case: types are the same */ + if (kind >= 2) { + __START_INNER_TINY__(1); + bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1); + __END_INNER_TINY__(1); + } else + bref8 = NULL; + } else + bref8 = NULL; + + jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->name_pos); + if (type_pos < 0) { + jit_ldxi_i(JIT_V1, JIT_V1, &((Scheme_Struct_Type *)0x0)->name_pos); + /* Now R2 is argument depth, V1 is target depth */ + if (kind == 1) { + bref3 = jit_bltr_i(jit_forward(), JIT_R2, JIT_V1); + } else { + (void)jit_bltr_i(refslow2, JIT_R2, JIT_V1); + bref3 = NULL; + } + } else { + if (type_pos != 0) { + (void)jit_blti_i(refslow2, JIT_R2, type_pos); + } + bref3 = NULL; + } + CHECK_LIMIT(); + /* Lookup argument type at target type depth, put it in R2: */ + if (type_pos < 0) { + jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE); + jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types); + } + } else { + bref3 = NULL; + bref8 = NULL; + } + jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Structure *)0x0)->stype); + if (type_pos < 0) { + jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2); + } else { + jit_ldxi_p(JIT_R2, JIT_V1, (type_pos << JIT_LOG_WORD_SIZE) + (intptr_t)&(((Scheme_Struct_Type *)0x0)->parent_types)); + } + CHECK_LIMIT(); + + /* (Re-)load target type into V1: */ + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (kind >= 2) { + jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); + } + + if (kind == 1) { + bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1); + + /* True branch: */ + if (!for_branch) { + (void)jit_movi_p(JIT_R0, scheme_true); + } else if (branch_info) { + scheme_branch_for_true(jitter, branch_info); + } else { + mz_patch_ucbranch(bref_true); +#ifdef MZ_USE_JIT_I386 +# ifndef X86_ALIGN_STACK + jit_popr_p(JIT_V1); +# endif +#endif + } + if (pop_and_jump) + mz_epilog(JIT_V1); + else if (!for_branch) { + __START_INNER_TINY__(1); + refdone = jit_jmpi(jit_forward()); + __END_INNER_TINY__(1); + } + + /* False branch: */ + if (branch_info) { + scheme_add_branch_false(branch_info, bref1); + scheme_add_branch_false(branch_info, bref2); + if (bref3) + scheme_add_branch_false(branch_info, bref3); + scheme_add_branch_false(branch_info, bref4); + } else { + mz_patch_branch(bref1); + mz_patch_branch(bref2); + if (bref3) + mz_patch_branch(bref3); + mz_patch_branch(bref4); + if (for_branch) { + mz_patch_branch(bref_false); + if (pop_and_jump) { + restore_struct_temp(jitter, JIT_V1); + mz_epilog_without_jmp(); + } + jit_jmpr(JIT_V1); + } else { + (void)jit_movi_p(JIT_R0, scheme_false); + if (pop_and_jump) + mz_epilog(JIT_V1); + } + if (!pop_and_jump) { + __START_INNER_TINY__(1); + mz_patch_ucbranch(refdone); + __END_INNER_TINY__(1); + } + } + } else { + (void)jit_bner_p(refslow2, JIT_R2, JIT_V1); + bref4 = NULL; + if (bref8) { + __START_INNER_TINY__(1); + mz_patch_branch(bref8); + __END_INNER_TINY__(1); + } + /* Extract field */ + if (field_pos < 0) { + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field); + jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); + jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots); + } else { + field_pos = (field_pos << JIT_LOG_WORD_SIZE) + (uintptr_t)&((Scheme_Structure *)0x0)->slots; + } + if (kind == 3) { + restore_struct_temp(jitter, JIT_R0); + if (field_pos < 0) + jit_stxr_p(JIT_V1, JIT_R1, JIT_R0); + else + jit_stxi_p(field_pos, JIT_R1, JIT_R0); + if (!result_ignored) + (void)jit_movi_p(JIT_R0, scheme_void); + } else { + if (field_pos < 0) + jit_ldxr_p(JIT_R0, JIT_R1, JIT_V1); + else + jit_ldxi_p(JIT_R0, JIT_R1, field_pos); + } + if (pop_and_jump) + mz_epilog(JIT_V1); + } + CHECK_LIMIT(); + + __END_SHORT_JUMPS__(branch_short); + + return 1; +} + static int common4(mz_jit_state *jitter, void *_data) { int i, ii, iii; @@ -1570,8 +1799,8 @@ static int common4(mz_jit_state *jitter, void *_data) for (i = 0; i < 4; i++) { /* pred, pred_branch, get, or set */ void *code; int kind, for_branch; - GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *refslow, *refslow2, *bref1, *bref2, *refretry; - GC_CAN_IGNORE jit_insn *bref3, *bref4, *bref5, *bref6, *bref8, *ref9; + GC_CAN_IGNORE jit_insn *ref, *refslow, *refslow2; + GC_CAN_IGNORE jit_insn *bref5, *bref6; if ((ii == 1) && (i == 1)) continue; /* no multi variant of pred branch */ if ((ii == 2) && (i == 1)) continue; /* no tail variant of pred branch */ @@ -1592,7 +1821,7 @@ static int common4(mz_jit_state *jitter, void *_data) for_branch = 1; sjc.struct_pred_branch_code = jit_get_ip().ptr; /* Save target address for false branch: */ - save_struct_temp(jitter); + save_struct_temp(jitter, JIT_V1); } else if (i == 2) { kind = 2; for_branch = 0; @@ -1612,7 +1841,7 @@ static int common4(mz_jit_state *jitter, void *_data) else sjc.struct_set_code = jit_get_ip().ptr; /* Save value to install: */ - save_struct_temp(jitter); + save_struct_temp(jitter, JIT_V1); } mz_prolog(JIT_V1); @@ -1637,140 +1866,13 @@ static int common4(mz_jit_state *jitter, void *_data) /* Continue trying fast path: check proc */ mz_patch_branch(ref); - (void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); - jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); - jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); - (void)jit_bnei_i(refslow, JIT_R2, ((kind == 3) - ? SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER - : ((kind == 1) - ? SCHEME_PRIM_STRUCT_TYPE_PRED - : SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER))); - CHECK_LIMIT(); - /* Check argument: */ - if (kind == 1) { - bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1); - refretry = _jit.x.pc; - jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); - __START_INNER_TINY__(1); - ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); - ref3 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_struct_type); - ref9 = jit_beqi_i(jit_forward(), JIT_R2, scheme_chaperone_type); - __END_INNER_TINY__(1); - bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type); - CHECK_LIMIT(); - __START_INNER_TINY__(1); - mz_patch_branch(ref9); - jit_ldxi_p(JIT_R1, JIT_R1, &SCHEME_CHAPERONE_VAL(0x0)); - (void)jit_jmpi(refretry); - mz_patch_branch(ref3); - __END_INNER_TINY__(1); - } else { - (void)jit_bmsi_ul(refslow2, JIT_R1, 0x1); - jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); - __START_INNER_TINY__(1); - ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); - __END_INNER_TINY__(1); - (void)jit_bnei_i(refslow2, JIT_R2, scheme_proc_struct_type); - bref1 = bref2 = NULL; - } - __START_INNER_TINY__(1); - mz_patch_branch(ref2); - __END_INNER_TINY__(1); - CHECK_LIMIT(); - - /* Put argument struct type in R2, target struct type in V1 */ - jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind >= 2) { - jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); - } - CHECK_LIMIT(); - - /* common case: types are the same */ - if (kind >= 2) { - __START_INNER_TINY__(1); - bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1); - __END_INNER_TINY__(1); - } else - bref8 = NULL; - - jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->name_pos); - jit_ldxi_i(JIT_V1, JIT_V1, &((Scheme_Struct_Type *)0x0)->name_pos); - /* Now R2 is argument depth, V1 is target depth */ - if (kind == 1) { - bref3 = jit_bltr_i(jit_forward(), JIT_R2, JIT_V1); - } else { - (void)jit_bltr_i(refslow2, JIT_R2, JIT_V1); - bref3 = NULL; - } - CHECK_LIMIT(); - /* Lookup argument type at target type depth, put it in R2: */ - jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE); - jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types); - jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Structure *)0x0)->stype); - jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2); - CHECK_LIMIT(); - - /* Re-load target type into V1: */ - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind >= 2) { - jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); - } - - if (kind == 1) { - bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1); - - /* True branch: */ - if (!for_branch) { - (void)jit_movi_p(JIT_R0, scheme_true); - } else { - mz_patch_ucbranch(bref6); -#ifdef MZ_USE_JIT_I386 -# ifndef X86_ALIGN_STACK - jit_popr_p(JIT_V1); -# endif -#endif - } - mz_epilog(JIT_V1); - - /* False branch: */ - mz_patch_branch(bref1); - mz_patch_branch(bref2); - mz_patch_branch(bref3); - mz_patch_branch(bref4); - if (for_branch) { - mz_patch_branch(bref5); - restore_struct_temp(jitter, JIT_V1); - mz_epilog_without_jmp(); - jit_jmpr(JIT_V1); - } else { - (void)jit_movi_p(JIT_R0, scheme_false); - mz_epilog(JIT_V1); - } - } else { - (void)jit_bner_p(refslow2, JIT_R2, JIT_V1); - bref4 = NULL; - __START_INNER_TINY__(1); - mz_patch_branch(bref8); - __END_INNER_TINY__(1); - /* Extract field */ - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field); - jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); - jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots); - if (kind == 3) { - restore_struct_temp(jitter, JIT_R0); - jit_stxr_p(JIT_V1, JIT_R1, JIT_R0); - (void)jit_movi_p(JIT_R0, scheme_void); - } else { - jit_ldxr_p(JIT_R0, JIT_R1, JIT_V1); - } - mz_epilog(JIT_V1); - } - CHECK_LIMIT(); - __END_SHORT_JUMPS__(1); + scheme_generate_struct_op(jitter, kind, for_branch, NULL, 1, 0, + 1, 1, -1, -1, + 1, refslow, refslow2, bref5, bref6); + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, code, scheme_false); } } diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index e835bc0e3b..5dde16f57c 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -352,12 +352,27 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app return 1; } +static Scheme_Object *extract_struct_constant(mz_jit_state *jitter, Scheme_Object *rator) +{ + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_toplevel_type) + && (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST) { + rator = scheme_extract_global(rator, jitter->nc, 1); + if (rator) + return ((Scheme_Bucket *)rator)->val; + } + + return NULL; +} + static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, Branch_Info *for_branch, int branch_short, - int is_tail, int multi_ok) + int is_tail, int multi_ok, int result_ignored) /* de-sync'd ok; for branch, sync'd before */ { + GC_CAN_IGNORE jit_insn *ref, *ref2, *refslow; + Scheme_Object *inline_rator; + LOG_IT(("inlined struct op\n")); if (!rand2) { @@ -381,24 +396,49 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, /* R0 is [potential] predicate/getter/setting, R1 is struct. V1 is value for setting. */ + if ((kind == INLINE_STRUCT_PROC_PRED) /* REMOVEME */ + || (kind == INLINE_STRUCT_PROC_GET) + || (kind == INLINE_STRUCT_PROC_SET)) { + inline_rator = extract_struct_constant(jitter, rator); + if (inline_rator && (kind != INLINE_STRUCT_PROC_PRED)) { + __START_SHORT_JUMPS__(1); + ref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1); + refslow = _jit.x.pc; + if (kind == INLINE_STRUCT_PROC_SET) + scheme_restore_struct_temp(jitter, JIT_V1); + __END_SHORT_JUMPS__(1); + } else { + ref = NULL; + refslow = NULL; + } + } else { + inline_rator = NULL; + ref = NULL; + refslow = NULL; + } + if (for_branch) { scheme_prepare_branch_jump(jitter, for_branch); CHECK_LIMIT(); - __START_SHORT_JUMPS__(for_branch->branch_short); - scheme_add_branch_false_movi(for_branch, jit_patchable_movi_p(JIT_V1, jit_forward())); - __END_SHORT_JUMPS__(for_branch->branch_short); - (void)jit_calli(sjc.struct_pred_branch_code); - __START_SHORT_JUMPS__(for_branch->branch_short); - scheme_branch_for_true(jitter, for_branch); - __END_SHORT_JUMPS__(for_branch->branch_short); - CHECK_LIMIT(); + if (!inline_rator) { + __START_SHORT_JUMPS__(for_branch->branch_short); + scheme_add_branch_false_movi(for_branch, jit_patchable_movi_p(JIT_V1, jit_forward())); + __END_SHORT_JUMPS__(for_branch->branch_short); + (void)jit_calli(sjc.struct_pred_branch_code); + __START_SHORT_JUMPS__(for_branch->branch_short); + scheme_branch_for_true(jitter, for_branch); + __END_SHORT_JUMPS__(for_branch->branch_short); + CHECK_LIMIT(); + } } else if (kind == INLINE_STRUCT_PROC_PRED) { - if (is_tail) { - (void)jit_calli(sjc.struct_pred_tail_code); - } else if (multi_ok) { - (void)jit_calli(sjc.struct_pred_multi_code); - } else { - (void)jit_calli(sjc.struct_pred_code); + if (!inline_rator) { + if (is_tail) { + (void)jit_calli(sjc.struct_pred_tail_code); + } else if (multi_ok) { + (void)jit_calli(sjc.struct_pred_multi_code); + } else { + (void)jit_calli(sjc.struct_pred_code); + } } } else if (kind == INLINE_STRUCT_PROC_GET) { if (is_tail) { @@ -446,6 +486,48 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, scheme_signal_error("internal error: unknown struct-op mode"); } + if (inline_rator) { + int pos, tpos, jkind; + + inline_rator = ((Scheme_Primitive_Closure *)inline_rator)->val[0]; + if (kind == INLINE_STRUCT_PROC_PRED) { + pos = 0; + tpos = ((Scheme_Struct_Type *)inline_rator)->name_pos; + } else { + pos = ((Struct_Proc_Info *)inline_rator)->field; + tpos = ((Struct_Proc_Info *)inline_rator)->struct_type->name_pos; + } + + if (ref) { + __START_SHORT_JUMPS__(1); + ref2 = jit_jmpi(jit_forward()); + mz_patch_ucbranch(ref); + __END_SHORT_JUMPS__(1); + } else + ref2 = NULL; + + if (kind == INLINE_STRUCT_PROC_GET) + jkind = 2; + else if (kind == INLINE_STRUCT_PROC_SET) { + scheme_save_struct_temp(jitter, JIT_V1); + jkind = 3; + } else + jkind = 1; + + scheme_generate_struct_op(jitter, jkind, !!for_branch, + for_branch, branch_short, + result_ignored, + 0, 0, + tpos, pos, + 0, refslow, refslow, NULL, NULL); + + if (ref2) { + __START_SHORT_JUMPS__(1); + mz_patch_ucbranch(ref2); + __END_SHORT_JUMPS__(1); + } + } + return 1; } @@ -836,7 +918,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in int k; k = inlineable_struct_prim(rator, jitter, 1, 1); if (k == INLINE_STRUCT_PROC_PRED) { - generate_inlined_struct_op(1, jitter, rator, app->rand, NULL, for_branch, branch_short, is_tail, multi_ok); + generate_inlined_struct_op(1, jitter, rator, app->rand, NULL, for_branch, branch_short, is_tail, multi_ok, + result_ignored); scheme_direct_call_count++; return 1; } else if (((k == INLINE_STRUCT_PROC_GET) @@ -844,7 +927,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in || (k == INLINE_STRUCT_PROC_PROP_PRED) || (k == INLINE_STRUCT_PROC_CONSTR)) && !for_branch) { - generate_inlined_struct_op(k, jitter, rator, app->rand, NULL, for_branch, branch_short, is_tail, multi_ok); + generate_inlined_struct_op(k, jitter, rator, app->rand, NULL, for_branch, branch_short, is_tail, multi_ok, + result_ignored); scheme_direct_call_count++; return 1; } @@ -2066,7 +2150,8 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i int k; k = inlineable_struct_prim(rator, jitter, 2, 2); if (k) { - generate_inlined_struct_op(k, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, is_tail, multi_ok); + generate_inlined_struct_op(k, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, is_tail, multi_ok, + result_ignored); scheme_direct_call_count++; return 1; } diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 1f1244d329..3a9e466d01 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -4121,6 +4121,7 @@ static void setup_accessible_table(Scheme_Module *m) for (i = 0; i < cnt; i++) { form = SCHEME_VEC_ELS(m->bodies[0])[i]; if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { + int checked_st = 0, is_st = 0; for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { tl = SCHEME_VEC_ELS(form)[k]; if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { @@ -4135,21 +4136,31 @@ static void setup_accessible_table(Scheme_Module *m) won't generate such modules, but synthesized module bytecode might leave bindings out of the `toplevels' table. */ } else { - if ((SCHEME_VEC_SIZE(form) == 2) - && scheme_compiled_duplicate_ok(SCHEME_VEC_ELS(form)[0], 1)) { - /* record simple constant from cross-module propagation: */ - v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(form)[0]), scheme_inline_variant_type)) { - /* record a potentially inlineable function */ - if (SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] != (Scheme_Object *)m->prefix) - SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] = (Scheme_Object *)m->prefix; - v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); - } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { - /* record that it's constant across all instantiations: */ - v = scheme_make_pair(v, scheme_constant_key); + if (SCHEME_VEC_SIZE(form) == 2) { + if (scheme_compiled_duplicate_ok(SCHEME_VEC_ELS(form)[0], 1)) { + /* record simple constant from cross-module propagation: */ + v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); + } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(form)[0]), scheme_inline_variant_type)) { + /* record a potentially inlineable function */ + if (SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] != (Scheme_Object *)m->prefix) + SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] = (Scheme_Object *)m->prefix; + v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); + } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { + /* record that it's constant across all instantiations: */ + v = scheme_make_pair(v, scheme_constant_key); + } else { + /* record that it's fixed for any given instantiation: */ + v = scheme_make_pair(v, scheme_fixed_key); + } } else { - /* record that it's fixed for any given instantiation: */ - v = scheme_make_pair(v, scheme_fixed_key); + if (!checked_st) { + is_st = scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], + SCHEME_VEC_SIZE(form)-1, + 1, 1); + checked_st = 1; + } + if (is_st) + v = scheme_make_pair(v, scheme_constant_key); } scheme_hash_set(ht, tl, v); } diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 639d9d48c3..6d3c11976d 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -149,59 +149,6 @@ void scheme_init_optimize() /* utils */ /*========================================================================*/ -static int is_current_inspector_call(Scheme_Object *a) -{ - if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { - Scheme_App_Rec *app = (Scheme_App_Rec *)a; - if (!app->num_args - && SAME_OBJ(app->args[0], scheme_current_inspector_proc)) - return 1; - } - return 0; -} - -static int is_proc_spec_proc(Scheme_Object *p) -{ - Scheme_Type vtype; - - if (SCHEME_PROCP(p)) { - p = scheme_get_or_check_arity(p, -1); - if (SCHEME_INTP(p)) { - return (SCHEME_INT_VAL(p) >= 1); - } else if (SCHEME_STRUCTP(p) - && scheme_is_struct_instance(scheme_arity_at_least, p)) { - p = ((Scheme_Structure *)p)->slots[0]; - if (SCHEME_INTP(p)) - return (SCHEME_INT_VAL(p) >= 1); - } - return 0; - } - - vtype = SCHEME_TYPE(p); - - if (vtype == scheme_unclosed_procedure_type) { - if (((Scheme_Closure_Data *)p)->num_params >= 1) - return 1; - } - - return 0; -} - -static void note_match(int actual, int expected, Optimize_Info *warn_info) -{ - if (!warn_info || (expected == -1)) - return; - - if (actual != expected) { - scheme_log(warn_info->logger, - SCHEME_LOG_WARNING, - 0, - "warning%s: %d values produced when %d expected", - scheme_optimize_context_to_string(warn_info->context), - actual, expected); - } -} - int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals) /* return 2 => results are a constant when arguments are constants */ { @@ -220,6 +167,21 @@ int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expec return 0; } +static void note_match(int actual, int expected, Optimize_Info *warn_info) +{ + if (!warn_info || (expected == -1)) + return; + + if (actual != expected) { + scheme_log(warn_info->logger, + SCHEME_LOG_WARNING, + 0, + "warning%s: %d values produced when %d expected", + scheme_optimize_context_to_string(warn_info->context), + actual, expected); + } +} + int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, Optimize_Info *warn_info, int deeper_than, int no_id) /* Checks whether the bytecode `o' returns `vals' values with no @@ -358,33 +320,16 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, } if (vtype == scheme_application_type) { - /* Look for multiple values, or for `make-struct-type'. - (The latter is especially useful to Honu.) */ Scheme_App_Rec *app = (Scheme_App_Rec *)o; - if ((app->num_args >= 4) && (app->num_args <= 10) + + if ((app->num_args >= 4) && (app->num_args <= 11) && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { note_match(5, vals, warn_info); - if ((vals == 5) || (vals < 0)) { - /* Look for (make-struct-type sym #f non-neg-int non-neg-int [omitable null]) */ - if (SCHEME_SYMBOLP(app->args[1]) - && SCHEME_FALSEP(app->args[2]) - && SCHEME_INTP(app->args[3]) - && (SCHEME_INT_VAL(app->args[3]) >= 0) - && SCHEME_INTP(app->args[4]) - && (SCHEME_INT_VAL(app->args[4]) >= 0) - && ((app->num_args < 5) - || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0), 0)) - && ((app->num_args < 6) - || SCHEME_NULLP(app->args[6])) - && ((app->num_args < 7) - || SCHEME_FALSEP(app->args[7]) - || is_current_inspector_call(app->args[7])) - && ((app->num_args < 8) - || SCHEME_FALSEP(app->args[8]) - || is_proc_spec_proc(app->args[8])) - && ((app->num_args < 9) - || SCHEME_NULLP(app->args[9]))) { + if (scheme_is_simple_make_struct_type(o, vals, resolved, 0)) { + if ((app->num_args < 5) + /* auto-field value: */ + || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? app->num_args : 0), 0)) { return 1; } } @@ -445,6 +390,216 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 0; } +static int is_current_inspector_call(Scheme_Object *a) +{ + if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)a; + if (!app->num_args + && SAME_OBJ(app->args[0], scheme_current_inspector_proc)) + return 1; + } + return 0; +} + +static int is_proc_spec_proc(Scheme_Object *p) +{ + Scheme_Type vtype; + + if (SCHEME_PROCP(p)) { + p = scheme_get_or_check_arity(p, -1); + if (SCHEME_INTP(p)) { + return (SCHEME_INT_VAL(p) >= 1); + } else if (SCHEME_STRUCTP(p) + && scheme_is_struct_instance(scheme_arity_at_least, p)) { + p = ((Scheme_Structure *)p)->slots[0]; + if (SCHEME_INTP(p)) + return (SCHEME_INT_VAL(p) >= 1); + } + return 0; + } + + vtype = SCHEME_TYPE(p); + + if (vtype == scheme_unclosed_procedure_type) { + if (((Scheme_Closure_Data *)p)->num_params >= 1) + return 1; + } + + return 0; +} + +static int is_local_ref(Scheme_Object *e, int p, int r) +{ + return (SAME_TYPE(SCHEME_TYPE(e), scheme_local_type) + && (SCHEME_LOCAL_POS(e) >= p) + && (SCHEME_LOCAL_POS(e) < (p + r))); +} + +static int is_int_list(Scheme_Object *o, int up_to) +{ + if (SCHEME_PAIRP(o)) { + char *s, quick[8]; + Scheme_Object *e; + if (up_to <= 8) + s = quick; + else + s = (char *)scheme_malloc_atomic(up_to); + memset(s, 0, up_to); + while (SCHEME_PAIRP(o)) { + e = SCHEME_CAR(o); + o = SCHEME_CDR(o); + if (!SCHEME_INTP(e) + || (SCHEME_INT_VAL(e) < 0) + || (SCHEME_INT_VAL(e) > up_to) + || s[SCHEME_INT_VAL(e)]) + return 0; + s[SCHEME_INT_VAL(e)] = 1; + } + } + + return SCHEME_NULLP(o); +} + +static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved) +{ + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + int delta = (resolved ? app->num_args : 0); + if (SAME_OBJ(app->args[0], scheme_values_func) + && (app->num_args == vals)) { + int i; + for (i = app->num_args; i > 0; i--) { + if (is_local_ref(app->args[1], delta, 5)) { + /* ok */ + } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) { + Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i]; + int delta2 = delta + (resolved ? 2 : 0); + if (SAME_OBJ(app3->rator, scheme_make_struct_field_accessor_proc)) { + if (!is_local_ref(app3->rand1, delta2+3, 1) + && SCHEME_SYMBOLP(app3->rand2)) + break; + } else if (SAME_OBJ(app3->rator, scheme_make_struct_field_mutator_proc)) { + if (!is_local_ref(app3->rand1, delta2+4, 1) + && SCHEME_SYMBOLP(app3->rand2)) + break; + } else + break; + } + } + if (i <= 0) + return 1; + } + } + + return 0; +} + +static Scheme_Object *skip_clears(Scheme_Object *body) +{ + if (SAME_TYPE(SCHEME_TYPE(body), scheme_sequence_type)) { + Scheme_Sequence *seq = (Scheme_Sequence *)body; + int i; + for (i = seq->count - 1; i--; ) { + if (!SAME_TYPE(SCHEME_TYPE(seq->array[i]), scheme_local_type)) + break; + } + if (i < 0) + return seq->array[seq->count-1]; + } + return body; +} + +int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, int check_auto) +/* Checks whether it's a `make-struct-type' call that certainly succeeds + (i.e., no exception) --- pending a check of argument 5 if !check_auto */ +{ + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { + if ((vals == 5) || (vals < 0)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + + if ((app->num_args >= 4) && (app->num_args <= 11) + && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { + if (SCHEME_SYMBOLP(app->args[1]) + && SCHEME_FALSEP(app->args[2]) /* super = #f */ + && SCHEME_INTP(app->args[3]) + && (SCHEME_INT_VAL(app->args[3]) >= 0) + && SCHEME_INTP(app->args[4]) + && (SCHEME_INT_VAL(app->args[4]) >= 0) + && ((app->num_args < 5) + /* auto-field value: */ + || !check_auto + || scheme_omittable_expr(app->args[5], 1, 3, resolved, NULL, -1, 0)) + && ((app->num_args < 6) + /* no properties: */ + || SCHEME_NULLP(app->args[6])) + && ((app->num_args < 7) + /* inspector: */ + || SCHEME_FALSEP(app->args[7]) + || is_current_inspector_call(app->args[7])) + && ((app->num_args < 8) + /* propcedure property: */ + || SCHEME_FALSEP(app->args[8]) + || is_proc_spec_proc(app->args[8])) + && ((app->num_args < 9) + /* immutables: */ + || is_int_list(app->args[9], + SCHEME_INT_VAL(app->args[3]))) + && ((app->num_args < 10) + /* guard: */ + || SCHEME_FALSEP(app->args[10])) + && ((app->num_args < 11) + /* constructor name: */ + || SCHEME_FALSEP(app->args[11]) + || SCHEME_SYMBOLP(app->args[11]))) { + return 1; + } + } + } + } + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_let_void_type)) { + /* check for (let-values ([(: mk ? ref- set-!) (make-struct-type ...)]) (values ...)) + as generated by the expansion of `struct' */ + Scheme_Let_Header *lh = (Scheme_Let_Header *)e; + if ((lh->count == 5) && (lh->num_clauses == 1)) { + if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { + Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; + if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type) + && scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto)) { + /* We have (let-values ([... (make-struct-type)]) ....), so make sure body + just uses `make-struct-field-{accessor,mutator}'. */ + if (is_values_with_accessors_and_mutators(lv->body, vals, resolved)) + return 1; + } + } + } + } + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_let_void_type)) { + /* same thing, but in resolved form */ + Scheme_Let_Void *lvd = (Scheme_Let_Void *)e; + if (lvd->count == 5) { + if (SAME_TYPE(SCHEME_TYPE(lvd->body), scheme_let_value_type)) { + Scheme_Let_Value *lv = (Scheme_Let_Value *)lvd->body; + if ((lv->position == 0) && (lv->count == 5)) { + Scheme_Object *e2; + e2 = skip_clears(lv->value); + if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type) + && scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto)) { + /* We have (let-values ([... (make-struct-type)]) ....), so make sure body + just uses `make-struct-field-{accessor,mutator}'. */ + e2 = skip_clears(lv->body); + if (is_values_with_accessors_and_mutators(e2, vals, resolved)) + return 1; + } + } + } + } + } + + return 0; +} + static int single_valued_noncm_expression(Scheme_Object *expr, int fuel) /* Non-omittable but single-valued expresions that are not sensitive to being in tail position. */ @@ -4550,21 +4705,19 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) e = SCHEME_VEC_ELS(e)[1]; n = scheme_list_length(vars); - if (n == 1) { - if (IS_COMPILED_PROC(e)) { - Scheme_Toplevel *tl; + if ((n == 1) && IS_COMPILED_PROC(e)) { + Scheme_Toplevel *tl; - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); - - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { - int pos; - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - pos = tl->position; - scheme_hash_set(consts, - scheme_make_integer(pos), - estimate_closure_size(e)); - } + tl = (Scheme_Toplevel *)SCHEME_CAR(vars); + + if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { + int pos; + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + pos = tl->position; + scheme_hash_set(consts, + scheme_make_integer(pos), + estimate_closure_size(e)); } } } @@ -4625,56 +4778,60 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) cnst = 1; sproc = 1; } + } else if (scheme_is_simple_make_struct_type(e, n, 0, 1)) { + cnst = 1; } if (cnst) { Scheme_Toplevel *tl; + while (n--) { + tl = (Scheme_Toplevel *)SCHEME_CAR(vars); + vars = SCHEME_CDR(vars); - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); + if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { + Scheme_Object *e2; - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { - Scheme_Object *e2; - - if (sproc) { - e2 = scheme_make_noninline_proc(e); - } else if (IS_COMPILED_PROC(e)) { - e2 = optimize_clone(1, e, info, 0, 0); - if (e2) { - Scheme_Object *pr; - pr = scheme_make_raw_pair(scheme_make_raw_pair(e2, e), NULL); - if (cl_last) - SCHEME_CDR(cl_last) = pr; - else - cl_first = pr; - cl_last = pr; - } else + if (sproc) { e2 = scheme_make_noninline_proc(e); - } else { - e2 = e; - } + } else if (IS_COMPILED_PROC(e)) { + e2 = optimize_clone(1, e, info, 0, 0); + if (e2) { + Scheme_Object *pr; + pr = scheme_make_raw_pair(scheme_make_raw_pair(e2, e), NULL); + if (cl_last) + SCHEME_CDR(cl_last) = pr; + else + cl_first = pr; + cl_last = pr; + } else + e2 = scheme_make_noninline_proc(e); + } else { + e2 = e; + } - if (e2) { - int pos; - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - pos = tl->position; - scheme_hash_set(consts, scheme_make_integer(pos), e2); - if (!re_consts) - re_consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(re_consts, scheme_make_integer(i_m), - scheme_make_integer(pos)); - } else { - /* At least mark it as fixed */ + if (e2) { + int pos; + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + pos = tl->position; + scheme_hash_set(consts, scheme_make_integer(pos), e2); + if (!re_consts) + re_consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(re_consts, scheme_make_integer(i_m), + scheme_make_integer(pos)); + } else { + /* At least mark it as fixed */ - if (!fixed_table) { - fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(consts, scheme_false, (Scheme_Object *)fixed_table); - } - scheme_hash_set(fixed_table, scheme_make_integer(tl->position), scheme_true); - } - } + if (!fixed_table) { + fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(consts, scheme_false, (Scheme_Object *)fixed_table); + } + scheme_hash_set(fixed_table, scheme_make_integer(tl->position), scheme_true); + } + } + } } else { /* The binding is not inlinable/propagatable, but unless it's set!ed, it is constant after evaluating the definition. We diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index c81e6053a8..0311f11072 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -371,6 +371,8 @@ extern Scheme_Object *scheme_hash_ref_proc; extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; +extern Scheme_Object *scheme_make_struct_field_accessor_proc; +extern Scheme_Object *scheme_make_struct_field_mutator_proc; extern Scheme_Object *scheme_current_inspector_proc; extern Scheme_Object *scheme_varref_const_p_proc; @@ -2869,6 +2871,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, int scheme_might_invoke_call_cc(Scheme_Object *value); int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator); int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals); +int scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, int check_auto); int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which); diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index eec864f698..b3c0fa8679 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.3.1.2" +#define MZSCHEME_VERSION "5.3.1.3" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Z 1 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 02c7e349a2..501a8481c1 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -36,6 +36,8 @@ READ_ONLY Scheme_Object *scheme_equal_property; READ_ONLY Scheme_Object *scheme_no_arity_property; READ_ONLY Scheme_Object *scheme_impersonator_of_property; READ_ONLY Scheme_Object *scheme_make_struct_type_proc; +READ_ONLY Scheme_Object *scheme_make_struct_field_accessor_proc; +READ_ONLY Scheme_Object *scheme_make_struct_field_mutator_proc; READ_ONLY Scheme_Object *scheme_current_inspector_proc; READ_ONLY Scheme_Object *scheme_recur_symbol; READ_ONLY Scheme_Object *scheme_display_symbol; @@ -553,15 +555,20 @@ scheme_init_struct (Scheme_Env *env) 3, 3), env); + REGISTER_SO(scheme_make_struct_field_accessor_proc); + scheme_make_struct_field_accessor_proc = scheme_make_prim_w_arity(make_struct_field_accessor, + "make-struct-field-accessor", + 2, 3); scheme_add_global_constant("make-struct-field-accessor", - scheme_make_prim_w_arity(make_struct_field_accessor, - "make-struct-field-accessor", - 2, 3), + scheme_make_struct_field_accessor_proc, env); + + REGISTER_SO(scheme_make_struct_field_mutator_proc); + scheme_make_struct_field_mutator_proc = scheme_make_prim_w_arity(make_struct_field_mutator, + "make-struct-field-mutator", + 2, 3); scheme_add_global_constant("make-struct-field-mutator", - scheme_make_prim_w_arity(make_struct_field_mutator, - "make-struct-field-mutator", - 2, 3), + scheme_make_struct_field_mutator_proc, env); scheme_add_global_constant("wrap-evt", diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index a17a87389c..820ab6da3c 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -363,6 +363,8 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, tl_state, tl_timestamp, NULL, !!only_var, 0, vc, 0, 0, NULL, size-1); + if (scheme_is_simple_make_struct_type(val, size-1, 1, 1)) + result = 2; flags = SCHEME_TOPLEVEL_READY; if (result == 2) { @@ -1412,7 +1414,10 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, check_self_call_valid(app->args[0], port, vc, delta, stack); if (result) { - r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); + if (scheme_is_simple_make_struct_type((Scheme_Object *)app, expected_results, 1, 1)) + r = 2; + else + r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); result = validate_join(result, r); } }