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

expander & bytecode compiler: performance tweaks

Browse Source
This commit is contained in:
Matthew Flatt 2018-03-15 17:47:07 -06:00
parent 11e3d7a1f8
commit 600469d164
19 changed files with 13469 additions and 13316 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
racket/src/expander/common/intern.rkt
View File

@ -9,10 +9,12 @@
;; the table after failing to find an entry (and if the transaction
;; fails, we look again for an entry).
(struct weak-intern-table (box))
(struct weak-intern-table (box)
#:authentic)
(struct table (ht ; integer[hash code] -> list of weak boxes
count ; number of items in the table (= sum of list lengths)
prune-at)) ; count at which we should try to prune empty weak boxes
prune-at) ; count at which we should try to prune empty weak boxes
#:authentic)
(define (make-weak-intern-table)
(weak-intern-table (box (table (hasheqv) 0 128))))

18
racket/src/expander/expand/lift-context.rkt
View File

@ -56,8 +56,9 @@
(struct lift-context (convert ; takes a list of ids and rhs to produce a lifted-bind
lifts ; box of list of lifted-binds and maybe other forms
module*-ok?)) ; if used to capture module lifts, allow `module*`?
(struct lifted-bind (ids keys rhs))
module*-ok?) ; if used to capture module lifts, allow `module*`?
#:authentic)
(struct lifted-bind (ids keys rhs) #:authentic)
(define (make-lift-context convert #:module*-ok? [module*-ok? #f])
(lift-context convert (box null) module*-ok?))
@ -137,9 +138,10 @@
;; ----------------------------------------
(struct module-lift-context (wrt-phase ; phase of target for lifts
lifts ; box of list of lifted
module*-ok?)) ; whether `module*` is allowed
(struct module-lift-context (wrt-phase ; phase of target for lifts
lifts ; box of list of lifted
module*-ok?) ; whether `module*` is allowed
#:authentic)
(define (make-module-lift-context phase module*-ok?)
(module-lift-context phase (box null) module*-ok?))
@ -176,7 +178,8 @@
(struct require-lift-context (do-require ; callback to process a lifted require
wrt-phase ; phase of target for lifts
requires)) ; records lifted requires
requires) ; records lifted requires
#:authentic)
(define (make-require-lift-context wrt-phase do-require)
(require-lift-context do-require wrt-phase (box null)))
@ -194,7 +197,8 @@
(struct to-module-lift-context (wrt-phase ; phase of target for lifts
provides
end-as-expressions?
ends))
ends)
#:authentic)
(define (make-to-module-lift-context phase
#:shared-module-ends ends

3
racket/src/expander/expand/reference-record.rkt
View File

@ -18,7 +18,8 @@
(struct reference-record ([already-bound #:mutable]
[reference-before-bound #:mutable]
[all-referenced? #:mutable])
#:transparent)
#:authentic
#:transparent)
(define (make-reference-record)
(reference-record (seteq) (seteq) #f))

2
racket/src/expander/expand/require+provide.rkt
View File

@ -55,7 +55,7 @@
#:authentic)
;; A `required` represents an identifier required into a module
(struct required (id phase can-be-shadowed? as-transformer?))
(struct required (id phase can-be-shadowed? as-transformer?) #:authentic)
;; A `nominal` supports a reverse mapping of bindings to nominal info
(struct nominal (module provide-phase require-phase sym) #:transparent #:authentic)

8
racket/src/expander/host/correlate.rkt
View File

@ -88,10 +88,10 @@
[else (error 'correlated->list "not a list")])))
(define (correlated->datum e)
(datum-map e (lambda (tail? d)
(if (syntax? d)
(syntax->datum d)
d))))
(datum-map e (lambda (tail? d) d) (lambda (tail? d)
(if (syntax? d)
(syntax->datum d)
d))))
(define (correlated-property-symbol-keys e)
(syntax-property-symbol-keys e))

9
racket/src/expander/namespace/module.rkt
View File

@ -77,7 +77,8 @@
inspector ; declaration-time inspector
submodule-names ; associated submodules (i.e, when declared together)
supermodule-name ; associated supermodule (i.e, when declared together)
get-all-variables)) ; for `module->indirect-exports`
get-all-variables) ; for `module->indirect-exports`
#:authentic)
;; [*] Beware that tabels in `provides` may map non-interned symbols
;; to provided bindings, in case something like a lifted
@ -93,7 +94,8 @@
inspector ; declaration-time inspector
extra-inspector ; optional extra inspector
extra-inspectorsss) ; optional extra inspector sets per variable per import
#:transparent)
#:authentic
#:transparent)
(define (make-module #:source-name [source-name #f]
#:self self
@ -140,7 +142,8 @@
phase-level-to-state ; phase-level -> #f, 'available, or 'started
[made-available? #:mutable] ; no #f in `phase-level-to-state`?
[attached? #:mutable] ; whether the instance has been attached elsewhere
data-box)) ; for use by module implementation
data-box) ; for use by module implementation
#:authentic)
(define (make-module-instance m-ns m)
(module-instance m-ns ; namespace

4
racket/src/expander/namespace/namespace.rkt
View File

@ -63,6 +63,7 @@
module-instances) ; union resolved-module-path -> module-instance [shared among modules]
;; ; 0-phase -> resolved-module-path -> module-instance
;; ; where the first option is for cross phase persistent modules
#:authentic
#:property prop:custom-write
(lambda (ns port mode)
(write-string "#<namespace" port)
@ -79,7 +80,8 @@
(write-string ">" port)))
(struct definitions (variables ; linklet instance
transformers)) ; sym -> val
transformers) ; sym -> val
#:authentic)
(define (make-namespace)
(new-namespace))

1
racket/src/expander/namespace/provided.rkt
View File

@ -10,6 +10,7 @@
;; Wrapper for provides that are protected or syntax
(struct provided (binding protected? syntax?)
#:authentic
#:transparent
#:property prop:serialize
(lambda (p ser-push! state)

6
racket/src/expander/syntax/binding-table.rkt
View File

@ -47,7 +47,8 @@
(lambda (twbb ser-push! state)
(ser-push! 'tag '#:table-with-bulk-bindings)
(ser-push! (table-with-bulk-bindings-syms/serialize twbb))
(ser-push! (table-with-bulk-bindings-bulk-bindings twbb))))
(ser-push! (table-with-bulk-bindings-bulk-bindings twbb)))
#:authentic)
(define (deserialize-table-with-bulk-bindings syms bulk-bindings)
(table-with-bulk-bindings syms syms bulk-bindings))
@ -67,7 +68,8 @@
;; bulk bindings are pruned dependong on whether all scopes
;; in `scopes` are reachable, and we shouldn't get here
;; when looking for scopes
(error "shouldn't get here")))
(error "shouldn't get here"))
#:authentic)
(define (deserialize-bulk-binding-at scopes bulk)
(bulk-binding-at scopes bulk))

1
racket/src/expander/syntax/binding.rkt
View File

@ -51,6 +51,7 @@
[else
(same-binding? ab bb)]))
;; By tradition, equate "unbound" with "bound at the top level"
(define (toplevel-as-symbol b)
(if (and (module-binding? b)
(top-level-module-path-index? (module-binding-module b)))

32
racket/src/expander/syntax/datum-map.rkt
View File

@ -1,16 +1,21 @@
#lang racket/base
(require "../common/prefab.rkt"
"../common/inline.rkt")
"../common/inline.rkt"
racket/fixnum)
(provide datum-map
datum-has-elements?)
;; `(datum-map v f)` walks over `v`, traversing objects that
;; `datum->syntax` traverses to convert context to syntax objects.
;; `datum->syntax` traverses to convert content to syntax objects.
;;
;; `(f tail? d)` is called to each datum `d`, where `tail?`
;; indicates that the value is a pair/null in a `cdr` --- so that it
;; doesn't need to be wrapped for `datum->syntax`, for example
;; `(f tail? d)` is called on each datum `d`, where `tail?`
;; indicates that the value is a pair/null in a `cdr` --- so that it
;; doesn't need to be wrapped for `datum->syntax`, for example
;;
;; `gf` is like `f`, but `gf` is used when the argument might be
;; syntax; if `gf` is provided, `f` can assume that its argument
;; is not syntax
;;
;; If a `seen` argument is provided, then it should be an `eq?`-based
;; hash table, and cycle checking is enabled; when a cycle is
@ -20,21 +25,22 @@
;; The inline version uses `f` only in an application position to
;; help avoid allocating a closure. It also covers only the most common
;; cases, defering to the general (not inlined) function for other cases.
(define-inline (datum-map s f [seen #f])
(define-inline (datum-map s f [gf f] [seen #f])
(let loop ([tail? #f] [s s] [prev-depth 0])
(define depth (add1 prev-depth)) ; avoid cycle-checking overhead for shallow cases
(define depth (fx+ 1 prev-depth)) ; avoid cycle-checking overhead for shallow cases
(cond
[(and seen (depth . > . 32))
(datum-map-slow tail? s (lambda (tail? s) (f tail? s)) seen)]
[(and seen (depth . fx> . 32))
(datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen)]
[(null? s) (f tail? s)]
[(pair? s)
(f tail? (cons (loop #f (car s) depth)
(loop #t (cdr s) depth)))]
[(or (symbol? s) (boolean? s) (number? s))
(f #f s)]
[(symbol? s) (f #f s)]
[(boolean? s) (f #f s)]
[(number? s) (f #f s)]
[(or (vector? s) (box? s) (prefab-struct-key s) (hash? s))
(datum-map-slow tail? s (lambda (tail? s) (f tail? s)) seen)]
[else (f #f s)])))
(datum-map-slow tail? s (lambda (tail? s) (gf tail? s)) seen)]
[else (gf #f s)])))
(define (datum-map-slow tail? s f seen)
(let loop ([tail? tail?] [s s] [prev-seen seen])

23
racket/src/expander/syntax/preserved.rkt
View File

@ -19,18 +19,17 @@
(preserved-property-value v))
(define (check-value-to-preserve v syntax?)
(datum-map v
(lambda (tail? v)
(unless (or (null? v) (boolean? v) (symbol? v) (number? v)
(char? v) (string? v) (bytes? v) (regexp? v)
(syntax? v)
(pair? v) (vector? v) (box? v) (hash? v)
(immutable-prefab-struct-key v))
(raise-arguments-error 'write
"disallowed value in preserved syntax property"
"value" v))
v)
disallow-cycles))
(define (check-preserve tail? v)
(unless (or (null? v) (boolean? v) (symbol? v) (number? v)
(char? v) (string? v) (bytes? v) (regexp? v)
(syntax? v)
(pair? v) (vector? v) (box? v) (hash? v)
(immutable-prefab-struct-key v))
(raise-arguments-error 'write
"disallowed value in preserved syntax property"
"value" v))
v)
(datum-map v check-preserve check-preserve disallow-cycles))
(define disallow-cycles
(hash 'cycle-fail

4
racket/src/expander/syntax/scope.rkt
View File

@ -395,8 +395,10 @@
(define (syntax-e s)
(define content (syntax-e/no-taint s))
;; Since we just called `syntax-e/no-taint`, we know that
;; `(syntax-scope-propagations+tamper s)` is not a propagation
(cond
[(not (tamper-armed? (syntax-tamper s))) content]
[(not (tamper-armed? (syntax-scope-propagations+tamper s))) content]
[(datum-has-elements? content) (taint-content content)]
[else content]))

4
racket/src/expander/syntax/syntax.rkt
View File

@ -229,6 +229,7 @@
(define-inline (syntax-map s f d->s s-e [seen #f])
(let loop ([s s])
(datum-map s
f
(lambda (tail? v)
(cond
[(syntax? v) (d->s v (loop (s-e v)))]
@ -236,11 +237,12 @@
seen)))
;; `(non-syntax-map s f s->)` is like `(syntax-map s f d->s)`, except that
;; when a syntax object is found, it is just passed to `d` --- so there's
;; when a syntax object is found, it is just passed to `s->` --- so there's
;; no `d->s` or `s-e`, since they would not be called
(define-inline (non-syntax-map s f [s-> (lambda (x) x)] [seen #f])
(datum-map s
f
(lambda (tail? v)
(cond
[(syntax? v) (s-> v)]

19
racket/src/racket/src/numarith.c
View File

@ -27,6 +27,10 @@
#include "nummacs.h"
#include <math.h>
READ_ONLY Scheme_Object *scheme_unsafe_fx_plus_proc;
READ_ONLY Scheme_Object *scheme_unsafe_fx_minus_proc;
READ_ONLY Scheme_Object *scheme_unsafe_fx_times_proc;
static Scheme_Object *plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *mult (int argc, Scheme_Object *argv[]);
@ -184,17 +188,20 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
p = scheme_make_folding_prim(fx_plus, "fx+", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM);
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fx+", p, env);
p = scheme_make_folding_prim(fx_minus, "fx-", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM);
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fx-", p, env);
p = scheme_make_folding_prim(fx_mult, "fx*", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM);
| SCHEME_PRIM_PRODUCES_FIXNUM
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("fx*", p, env);
p = scheme_make_folding_prim(fx_div, "fxquotient", 2, 2, 1);
@ -350,19 +357,25 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
Scheme_Object *p;
int flags;
REGISTER_SO(scheme_unsafe_fx_plus_proc);
p = scheme_make_folding_prim(unsafe_fx_plus, "unsafe-fx+", 2, 2, 1);
scheme_unsafe_fx_plus_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fx+", p, env);
REGISTER_SO(scheme_unsafe_fx_minus_proc);
p = scheme_make_folding_prim(unsafe_fx_minus, "unsafe-fx-", 2, 2, 1);
scheme_unsafe_fx_minus_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-fx-", p, env);
REGISTER_SO(scheme_unsafe_fx_times_proc);
p = scheme_make_folding_prim(unsafe_fx_mult, "unsafe-fx*", 2, 2, 1);
scheme_unsafe_fx_times_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);

112
racket/src/racket/src/optimize.c
View File

@ -540,6 +540,25 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
}
}
/* check for struct-type declaration: */
if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) {
Scheme_Object *auto_e;
int auto_e_depth;
auto_e = scheme_is_simple_make_struct_type(o, vals,
(((flags & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0)
| CHECK_STRUCT_TYPE_ALWAYS_SUCCEED
| CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK),
&auto_e_depth,
NULL, NULL,
opt_info,
NULL, NULL, 0, NULL, NULL,
5);
if (auto_e) {
if (scheme_omittable_expr(auto_e, 1, fuel - 1, flags, opt_info, warn_info))
return 1;
}
}
if (vtype == scheme_branch_type) {
Scheme_Branch_Rec *b;
b = (Scheme_Branch_Rec *)o;
@ -687,25 +706,6 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
return 1;
}
/* check for struct-type declaration: */
if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) {
Scheme_Object *auto_e;
int auto_e_depth;
auto_e = scheme_is_simple_make_struct_type(o, vals,
(((flags & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0)
| CHECK_STRUCT_TYPE_ALWAYS_SUCCEED
| CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK),
&auto_e_depth,
NULL, NULL,
opt_info,
NULL, NULL, 0, NULL, NULL,
5);
if (auto_e) {
if (scheme_omittable_expr(auto_e, 1, fuel - 1, flags, opt_info, warn_info))
return 1;
}
}
/* check for struct-type property declaration: */
if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) {
if (scheme_is_simple_make_struct_type_property(o, vals,
@ -1389,7 +1389,8 @@ static int is_ok_value(Ok_Value_Callback ok_value, void *data,
return ok_value(data, v, OK_CONSTANT_VALIDATE_SHAPE);
}
}
}
} else if (SCHEME_TYPE(arg) > _scheme_ir_values_types_)
return ok_value(data, arg, OK_CONSTANT_VALUE);
return 0;
}
@ -1459,7 +1460,7 @@ static int is_constant_super(Scheme_Object *arg,
enclosing_linklet);
}
static int ok_constant_property_with_guard(void *data, Scheme_Object *v, int mode)
static int ok_constant_property_without_guard(void *data, Scheme_Object *v, int mode)
{
intptr_t k = 0;
@ -1499,7 +1500,7 @@ static int is_struct_type_property_without_guard(Scheme_Object *arg,
Scheme_Linklet *enclosing_linklet)
/* Does `arg` produce a structure type property that has no guard (so that any value is ok)? */
{
return is_ok_value(ok_constant_property_with_guard, NULL,
return is_ok_value(ok_constant_property_without_guard, NULL,
arg,
info,
top_level_table,
@ -1517,7 +1518,7 @@ static int is_simple_property_list(Scheme_Object *a, int resolved,
{
Scheme_Object *arg;
int i, count;
if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) {
if (!SAME_OBJ(((Scheme_App_Rec *)a)->args[0], scheme_list_proc))
return 0;
@ -1571,7 +1572,7 @@ static int is_simple_property_list(Scheme_Object *a, int resolved,
return 0;
}
}
return 1;
}
@ -4661,6 +4662,11 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
SCHEME_APPN_FLAGS(new) |= (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL);
return finish_optimize_application3(new, info, context);
}
} else if ((mode == STRUCT_PROC_SHAPE_PRED) && pred && predicate_implies_not(pred, alt)) {
/* We know that the predicate will fail */
return replace_tail_inside(make_discarding_sequence(rand, scheme_false, info),
inside,
app->rand);
}
/* Register type based on getter succeeding: */
@ -5064,6 +5070,10 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
check_known_both_try(info, app_o, rator, rand1, rand2, "fxmin", scheme_fixnum_p_proc, scheme_unsafe_fx_min_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "fxmax", scheme_fixnum_p_proc, scheme_unsafe_fx_max_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "fx+", scheme_fixnum_p_proc, scheme_unsafe_fx_plus_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "fx-", scheme_fixnum_p_proc, scheme_unsafe_fx_minus_proc, info->unsafe_mode);
check_known_both_try(info, app_o, rator, rand1, rand2, "fx*", scheme_fixnum_p_proc, scheme_unsafe_fx_times_proc, info->unsafe_mode);
rator = app->rator; /* in case it was updated */
check_known_both(info, app_o, rator, rand1, rand2, "string-append", scheme_string_p_proc, scheme_true, info->unsafe_mode);
@ -5159,13 +5169,13 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
SCHEME_APPN_FLAGS(new_app) |= (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL);
return finish_optimize_application(new_app, info, context);
}
}
/* Register type based on setter succeeding: */
if (!SCHEME_NULLP(SCHEME_PROC_SHAPE_IDENTITY(alt))
&& SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_ir_local_type))
add_type(info, app->rand1, scheme_make_struct_proc_shape(STRUCT_PROC_SHAPE_PRED,
SCHEME_PROC_SHAPE_IDENTITY(alt)));
/* Register type based on setter succeeding: */
if (!SCHEME_NULLP(SCHEME_PROC_SHAPE_IDENTITY(alt))
&& SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_ir_local_type))
add_type(info, app->rand1, scheme_make_struct_proc_shape(STRUCT_PROC_SHAPE_PRED,
SCHEME_PROC_SHAPE_IDENTITY(alt)));
}
}
}
@ -5754,12 +5764,15 @@ static int predicate_implies_not(Scheme_Object *pred1, Scheme_Object *pred2)
return 0;
/* we don't track structure-type identity precisely enough to know
that structures don't rule out other structures --- or even other
prdicates (such as `procedure?`) */
if (SAME_TYPE(SCHEME_TYPE(pred1), scheme_struct_proc_shape_type)
|| SAME_TYPE(SCHEME_TYPE(pred2), scheme_struct_proc_shape_type))
that structures don't rule out other structures; among the
tracked predicates, only `procedure?` is compatible with
structures */
if ((SAME_TYPE(SCHEME_TYPE(pred1), scheme_struct_proc_shape_type)
|| SAME_OBJ(pred1, scheme_procedure_p_proc))
&& (SAME_TYPE(SCHEME_TYPE(pred2), scheme_struct_proc_shape_type)
|| SAME_OBJ(pred2, scheme_procedure_p_proc)))
return 0;
/* Otherwise, with our current set of predicates, overlapping matches happen
only when one implies the other: */
return (!predicate_implies(pred1, pred2) && !predicate_implies(pred2, pred1));
@ -8882,6 +8895,9 @@ Scheme_Linklet *scheme_optimize_linklet(Scheme_Linklet *linklet,
Optimize_Info *limited_info;
Optimize_Info_Sequence info_seq;
Scheme_Hash_Tree **iu;
/* For now, treat unsafe mode as a hint that cooperation with the validator
is not needed. We may eventually give up on the validator completely. */
int support_validation = !unsafe_mode;
info = optimize_info_create(linklet, enforce_const, can_inline, unsafe_mode);
info->context = (Scheme_Object *)linklet;
@ -9051,23 +9067,27 @@ Scheme_Linklet *scheme_optimize_linklet(Scheme_Linklet *linklet,
n = SCHEME_DEFN_VAR_COUNT(defn);
e = SCHEME_DEFN_RHS(defn);
limited_info->cross = info->cross;
if (support_validation)
limited_info->cross = info->cross;
cont = scheme_omittable_expr(e, n, -1,
/* ignore APPN_FLAG_OMITTABLE, because the
validator won't be able to reconstruct it
in general; also, don't recognize struct-type
functions, since they weren't recognized
as immediate calls */
(OMITTABLE_IGNORE_APPN_OMIT
| OMITTABLE_IGNORE_MAKE_STRUCT_TYPE),
(support_validation
/* ignore APPN_FLAG_OMITTABLE, because the
validator won't be able to reconstruct it
in general; also, don't recognize struct-type
functions, since they weren't recognized
as immediate calls */
? (OMITTABLE_IGNORE_APPN_OMIT
| OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)
: 0),
/* similarly, use `limited_info` instead of `info'
here, because the decision
of omittable should not depend on
information that's only available at
optimization time: */
limited_info,
(support_validation ? limited_info : info),
info);
info->cross = limited_info->cross;
if (support_validation)
info->cross = limited_info->cross;
if (n == 1) {
if (ir_propagate_ok(e, info, 0, NULL))
@ -9094,7 +9114,7 @@ Scheme_Linklet *scheme_optimize_linklet(Scheme_Linklet *linklet,
} else
sstruct = NULL;
if ((sstruct || sprop) && !cont) {
if (support_validation && (sstruct || sprop) && !cont) {
/* Since the `make-struct-type` or `make-struct-tye-property` form is immediate
enough that the validator can see it, re-check whether we can continue
a group of simultaneously defined variables. */

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

@ -634,6 +634,9 @@ extern Scheme_Object *scheme_unsafe_fx_lt_eq_proc;
extern Scheme_Object *scheme_unsafe_fx_gt_eq_proc;
extern Scheme_Object *scheme_unsafe_fx_min_proc;
extern Scheme_Object *scheme_unsafe_fx_max_proc;
extern Scheme_Object *scheme_unsafe_fx_plus_proc;
extern Scheme_Object *scheme_unsafe_fx_minus_proc;
extern Scheme_Object *scheme_unsafe_fx_times_proc;
extern Scheme_Object *scheme_not_proc;
extern Scheme_Object *scheme_true_object_p_proc;

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

File diff suppressed because it is too large Load Diff

16
racket/src/racket/src/struct.c
View File

@ -3437,7 +3437,9 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
else
want_v = ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_STRUCT
| (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0));
| ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
? STRUCT_PROC_SHAPE_AUTHENTIC
: 0));
} else if (!SCHEME_PRIMP(e)) {
want_v = -1;
} else {
@ -3450,7 +3452,9 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
} else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) {
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
want_v = (STRUCT_PROC_SHAPE_PRED
| (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0));
| ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
? STRUCT_PROC_SHAPE_AUTHENTIC
: 0));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) {
int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]);
int parent_slots;
@ -3464,13 +3468,17 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
pos = 0; /* => unknown, since simple struct info can't track it */
want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_SETTER
| (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0));
| ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
? STRUCT_PROC_SHAPE_AUTHENTIC
: 0));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) {
int pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(e)[1]);
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_GETTER
| (st->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0));
| ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
? STRUCT_PROC_SHAPE_AUTHENTIC
: 0));
} else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
|| (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER)
|| (i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)) {