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

track import "shapes" as procedure or structure type

Browse Source 
Shape information allows the linker to check the importing
module's compile-time expectation against the run-time
value of its imports. The JIT, in turn, can rely on that
checking to better inline structure-type predicates, etc.,
and to more directy call JIT-generated code across
module boundaries.

In addition to checking the "shape" of an import, the import's
JITted vs. non-JITted state must be consistent. To prevent shifts
in JIT state, the `eval-jit-enabled' parameter is now restricted
in its effect to top-level bindings.
This commit is contained in:
Matthew Flatt 2012-10-30 09:28:15 -06:00
parent 6b436cac5a
commit d7bf677645
35 changed files with 870 additions and 443 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/compiler/decompile.rkt
View File

@ -78,7 +78,20 @@
(let-values ([(n b) (module-path-index-split modidx)])
(and (not n) (not b))))
(string->symbol (format "_~a" sym))
(string->symbol (format "_~s@~s~a" sym (mpi->string modidx)
(string->symbol (format "_~s~a@~s~a"
sym
(match constantness
['constant ":c"]
['fixed ":f"]
[(function-shape a pm?)
(if pm? ":P" ":p")]
[(struct-type-shape c) ":t"]
[(constructor-shape a) ":mk"]
[(predicate-shape) ":?"]
[(accessor-shape c) ":ref"]
[(mutator-shape c) ":set!"]
[else ""])
(mpi->string modidx)
(if (zero? phase)
""
(format "/~a" phase)))))]

42
collects/compiler/zo-marshal.rkt
View File

@ -604,13 +604,51 @@
[(? void?)
(out-byte CPT_VOID out)]
[(struct module-variable (modidx sym pos phase constantness))
(define (to-sym n) (string->symbol (format "struct~a" n)))
(out-byte CPT_MODULE_VAR out)
(out-anything modidx out)
(out-anything sym out)
(out-anything (cond
[(function-shape? constantness)
(let ([a (function-shape-arity constantness)])
(cond
[(arity-at-least? a)
(bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1)
(if (function-shape-preserves-marks? constantness) 1 0))]
[(list? a)
(string->symbol (apply
string-append
(add-between
(for/list ([a (in-list a)])
(define n (if (arity-at-least? a)
(- (add1 (arity-at-least-value a)))
a))
(number->string n))
":")))]
[else
(bitwise-ior (arithmetic-shift a 1)
(if (function-shape-preserves-marks? constantness) 1 0))]))]
[(struct-type-shape? constantness)
(to-sym (arithmetic-shift (struct-type-shape-field-count constantness)
4))]
[(constructor-shape? constantness)
(to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness)
4)))]
[(predicate-shape? constantness) (to-sym 2)]
[(accessor-shape? constantness)
(to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness)
4)))]
[(mutator-shape? constantness)
(to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness)
4)))]
[(struct-other-shape? constantness)
(to-sym 5)]
[else #f])
out)
(case constantness
[(constant) (out-number -4 out)]
[(#f) (void)]
[(fixed) (out-number -5 out)]
[else (void)])
[else (out-number -4 out)])
(unless (zero? phase)
(out-number -2 out)
(out-number phase out))

28
collects/compiler/zo-parse.rkt
View File

@ -856,6 +856,7 @@
[(module-var)
(let ([mod (read-compact cp)]
[var (read-compact cp)]
[shape (read-compact cp)]
[pos (read-compact-number cp)])
(let-values ([(flags mod-phase pos)
(let loop ([pos pos])
@ -869,6 +870,33 @@
[else (values 0 0 pos)]))])
(make-module-variable mod var pos mod-phase
(cond
[shape
(cond
[(number? shape)
(define n (arithmetic-shift shape -1))
(make-function-shape (if (negative? n)
(make-arity-at-least (sub1 (- n)))
n)
(odd? shape))]
[(and (symbol? shape)
(regexp-match? #rx"^struct" (symbol->string shape)))
(define n (string->number (substring (symbol->string shape) 6)))
(case (bitwise-and n #x7)
[(0) (make-struct-type-shape (arithmetic-shift n -3))]
[(1) (make-constructor-shape (arithmetic-shift n -3))]
[(2) (make-predicate-shape)]
[(3) (make-accessor-shape (arithmetic-shift n -3))]
[(4) (make-mutator-shape (arithmetic-shift n -3))]
[else (make-struct-other-shape)])]
[else
;; parse symbol as ":"-separated sequence of arities
(make-function-shape
(for/list ([s (regexp-split #rx":" (symbol->string shape))])
(define i (string->number s))
(if (negative? i)
(make-arity-at-least (sub1 (- i)))
i))
#f)])]
[(not (zero? (bitwise-and #x1 flags))) 'constant]
[(not (zero? (bitwise-and #x2 flags))) 'fixed]
[else #f]))))]

15
collects/compiler/zo-structs.rkt
View File

@ -38,13 +38,26 @@
[(_ id . rest)
(define-form-struct* id (id zo) . rest)]))
(define-form-struct function-shape ([arity procedure-arity?]
[preserves-marks? boolean?]))
(define-form-struct struct-shape ())
(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?]))
(define-form-struct (predicate-shape struct-shape) ())
(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (struct-other-shape struct-shape) ())
;; In toplevels of resove prefix:
(define-form-struct global-bucket ([name symbol?])) ; top-level binding
(define-form-struct module-variable ([modidx module-path-index?]
[sym symbol?]
[pos exact-integer?]
[phase exact-nonnegative-integer?]
[constantness (or/c #f 'constant 'fixed)]))
[constantness (or/c #f 'constant 'fixed
function-shape?
struct-shape?)]))
;; Syntax object
(define ((alist/c k? v?) l)

14
collects/scribblings/raco/decompile.scrbl
View File

@ -25,7 +25,19 @@ Many forms in the decompiled code, such as @racket[module],
variables imported from other modules are prefixed with @litchar{_},
which helps expose the difference between uses of local variables
versus other variables. Variables imported from other modules,
moreover, have a suffix that indicates the source module.
moreover, have a suffix starting with @litchar["@"] that indicates
the source module. Finally, imported variables with constantness
have a midfix:
@litchar{:c} to indicate constant shape across all instantiations,
@litchar{:f} to indicate a fixed value after initialization,
@litchar{:p} to indicate a procedure,
@litchar{:P} to indicate a procedure that preserves continuation
marks on return,
@litchar{:t} to indicate a structure type,
@litchar{:mk} to indicate a structure constructor,
@litchar{:?} to indicate a structure predicate,
@litchar{:ref} to indicate a structure accessor, or
@litchar{:set!} to indicate a structure mutator.
Non-local variables are always accessed indirectly though an implicit
@racketidfont{#%globals} or @racketidfont{#%modvars} variable that

34
collects/scribblings/raco/zo-struct.scrbl
View File

@ -73,19 +73,43 @@ structures that are produced by @racket[zo-parse] and consumed by
[sym symbol?]
[pos exact-integer?]
[phase exact-nonnegative-integer?]
[constantness (or/c #f 'constant 'fixed)])]{
[constantness (or/c #f 'constant 'fixed
function-shape? struct-shape?)])]{
Represents a top-level variable, and used only in a @racket[prefix].
The @racket[pos] may record the variable's offset within its module,
or it can be @racket[-1] if the variable is always located by name.
The @racket[phase] indicates the phase level of the definition within
its module. The @racket[constantness] field is either @racket['constant]
its module. The @racket[constantness] field is either @racket['constant],
a @racket[function-shape] value, or a @racket[struct-shape] value
to indicate that
variable's value is always the same for every instantiation of its module,
variable's value is always the same for every instantiation of its module;
@racket['fixed] to indicate
that it doesn't change within a particular instantiation of the module,
that it doesn't change within a particular instantiation of the module;
or @racket[#f] to indicate that the variable's value
can change even for one particular instantiation of its module.}
can change even for one particular instantiation of its module.}
@defstruct+[function-shape
([arity procedure-arity?]
[preserves-marks? boolean?])]{
Represents the shape of an expected import, which should be a function
having the arity specified by @racket[arity]. The
@racket[preserves-marks?] field is true if calling the function is
expected to leave continuation marks unchanged by the time it
returns.}
@deftogether[(
@defstruct+[struct-shape ()]
@defstruct+[(struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])]
@defstruct+[(constructor-shape struct-shape) ([arity exact-nonnegative-integer?])]
@defstruct+[(predicate-shape struct-shape) ()]
@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])]
@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])]
@defstruct+[(struct-other-shape struct-shape) ()]
)]{
Represents the shape of an expected import as a structure-type
binding, constructor, etc.}
@defstruct+[(stx zo) ([encoded wrapped?])]{
Wraps a syntax object in a @racket[prefix].}

3
collects/scribblings/reference/eval.scrbl
View File

@ -531,7 +531,8 @@ which allows such optimizations.}
A @tech{parameter} that determines whether the native-code just-in-time
compiler (@deftech{JIT}) is enabled for code (compiled or not) that is passed to
the default evaluation handler. A true parameter value is effective
only on platforms for which the JIT is supported.
only on platforms for which the JIT is supported, and changing the value
from its initial setting affects only forms that are outside of @racket[module].
The default is @racket[#t], unless the JIT is not supported by the
current platform, unless it is disabled through the

2
collects/tests/racket/module.rktl
View File

@ -875,7 +875,7 @@
;; Triger JIT generation with constant function as `a':
(go a-s)
;; Check that we don't crash when trying to use a different `a':
(err/rt-test (go am-s)))
(err/rt-test (go am-s) exn:fail?))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

20
collects/tests/racket/optimize.rktl
View File

@ -1808,6 +1808,11 @@
(struct a (x y))
(struct b a (z)))
(module struct-c-for-optimize racket/base
(require 'struct-a-for-optimize)
(provide (struct-out c))
(struct c a (q)))
(test-comp '(module m racket/base
(require 'struct-a-for-optimize)
(begin0
@ -1830,6 +1835,21 @@
(b? (b-z (b 1 2 3))))
5)))
(test-comp '(module m racket/base
(require 'struct-c-for-optimize)
(begin0
(list (c? (c-q (c 1 2 3))))
c?
c
c-q
(c 1 2 3)
5))
'(module m racket/base
(require 'struct-c-for-optimize)
(begin0
(list (c? (c-q (c 1 2 3))))
5)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check bytecode verification of lifted functions

26
src/racket/src/compenv.c
View File

@ -925,7 +925,8 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx,
Scheme_Object *stxsym, Scheme_Object *insp,
int pos, intptr_t mod_phase, int is_constant)
int pos, intptr_t mod_phase, int is_constant,
Scheme_Object *shape)
/* is_constant == 2 => constant over all instantiations and phases */
{
Scheme_Object *val;
@ -961,6 +962,7 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
mv->insp = insp;
mv->pos = pos;
mv->mod_phase = (int)mod_phase;
mv->shape = shape;
if (is_constant > 1)
SCHEME_MODVAR_FLAGS(mv) |= SCHEME_MODVAR_CONST;
@ -1669,6 +1671,11 @@ static void check_taint(Scheme_Object *find_id)
"cannot use identifier tainted by macro transformation");
}
static Scheme_Object *intern_struct_proc_shape(int shape) {
char buf[20];
sprintf(buf, "struct%d", shape);
return scheme_intern_symbol(buf);
}
/*********************************************************************/
/*
@ -1703,7 +1710,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0, is_constant;
Scheme_Bucket *b;
Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase;
Scheme_Object *find_id_sym = NULL, *rename_insp = NULL, *mod_constant = NULL;
Scheme_Object *find_id_sym = NULL, *rename_insp = NULL, *mod_constant = NULL, *shape;
Scheme_Env *genv;
intptr_t phase;
@ -1987,7 +1994,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
check_taint(src_find_id);
return scheme_hash_module_variable(genv, genv->module->self_modidx, find_id,
genv->module->insp,
-1, genv->mod_phase, 0);
-1, genv->mod_phase, 0,
NULL);
}
} else
return NULL;
@ -1995,19 +2003,25 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
check_taint(src_find_id);
shape = NULL;
if (mod_constant) {
if (SAME_OBJ(mod_constant, scheme_constant_key))
is_constant = 2;
else if (SAME_OBJ(mod_constant, scheme_fixed_key))
is_constant = 1;
else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) {
else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_proc_shape_type)) {
is_constant = 2;
shape = SCHEME_PTR_VAL(mod_constant);
} else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) {
if (_inline_variant)
*_inline_variant = mod_constant;
is_constant = 2;
shape = intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant));
} else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) {
if (_inline_variant)
*_inline_variant = mod_constant;
is_constant = 2;
shape = scheme_get_or_check_procedure_shape(mod_constant, NULL);
} else {
if (flags & SCHEME_ELIM_CONST)
return mod_constant;
@ -2028,7 +2042,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
return scheme_hash_module_variable(env->genv, modidx, find_id,
(rename_insp ? rename_insp : genv->module->insp),
modpos, SCHEME_INT_VAL(mod_defn_phase),
is_constant);
is_constant, shape);
}
if (!modname
@ -2039,7 +2053,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id,
genv->module->insp,
modpos, genv->mod_phase,
is_constant);
is_constant, shape);
}
b = scheme_bucket_from_table(genv->toplevel, (char *)find_global_id);

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

@ -756,7 +756,8 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In
/* Create a module variable reference, so that idx is preserved: */
bucket = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx,
name, env->genv->module->insp,
-1, env->genv->mod_phase, 0);
-1, env->genv->mod_phase, 0,
NULL);
}
/* Get indirection through the prefix: */
bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec, 0, NULL);
@ -5269,7 +5270,8 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
preserved within the module. */
c = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx,
c, env->genv->module->insp,
-1, env->genv->mod_phase, 0);
-1, env->genv->mod_phase, 0,
NULL);
} else {
c = (Scheme_Object *)scheme_global_bucket(c, env->genv);
}

223
src/racket/src/cstartup.inc
View File

@ -1,5 +1,5 @@
{
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,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,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,
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,
@ -99,7 +99,7 @@
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,51,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,52,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,
@ -112,7 +112,7 @@
161,17,224,17,226,17,82,18,142,18,147,18,14,19,25,19,162,19,172,19,98,
21,120,21,129,21,122,22,140,22,154,22,175,22,187,22,232,22,239,22,1,23,
49,23,62,23,124,25,35,26,180,26,165,27,147,28,154,28,161,28,23,29,141,
29,241,30,66,31,149,31,234,31,169,32,195,32,68,33,0,0,241,37,0,0,
29,241,30,66,31,149,31,234,31,169,32,195,32,68,33,0,0,245,37,0,0,
67,35,37,117,116,105,108,115,72,112,97,116,104,45,115,116,114,105,110,103,63,
64,98,115,98,115,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,
104,71,114,101,114,111,111,116,45,112,97,116,104,1,20,102,105,110,100,45,101,
@ -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,9,88,163,8,32,
42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,8,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,
@ -522,64 +522,64 @@
0,20,26,144,9,2,1,2,1,29,11,11,11,9,9,11,11,11,10,43,80,
158,36,36,20,113,159,40,16,30,2,2,2,3,2,4,2,5,2,6,2,7,
2,8,2,9,2,10,2,11,2,12,2,13,2,14,2,15,2,16,2,17,30,
2,20,76,102,105,110,100,45,108,105,110,107,115,45,112,97,116,104,33,4,30,
2,21,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,
107,101,121,6,30,2,21,1,23,101,120,116,101,110,100,45,112,97,114,97,109,
101,116,101,114,105,122,97,116,105,111,110,3,2,22,2,23,2,24,30,2,20,
1,21,101,120,99,101,112,116,105,111,110,45,104,97,110,100,108,101,114,45,107,
101,121,2,2,25,2,26,2,27,2,28,2,29,2,30,2,31,16,0,37,39,
36,16,0,36,16,13,2,9,2,10,2,8,2,3,2,26,2,24,2,22,2,
17,2,23,2,25,2,15,2,14,2,16,49,11,11,11,16,13,2,13,2,11,
2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7,2,27,2,2,2,
5,16,13,11,11,11,11,11,11,11,11,11,11,11,11,11,16,13,2,13,2,
11,2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7,2,27,2,2,
2,5,49,49,37,12,11,11,16,0,16,0,16,0,36,36,11,12,11,11,16,
0,16,0,16,0,36,36,16,30,20,15,16,2,32,0,88,163,36,37,45,11,
2,2,222,33,57,80,159,36,36,37,20,15,16,2,249,22,144,7,7,92,7,
92,80,159,36,37,37,20,15,16,2,88,163,36,37,54,38,2,4,223,0,33,
62,80,159,36,38,37,20,15,16,2,88,163,36,38,58,38,2,5,223,0,33,
64,80,159,36,39,37,20,15,16,2,20,25,96,2,6,88,163,8,36,39,8,
25,8,32,9,223,0,33,71,88,163,36,38,47,52,9,223,0,33,72,88,163,
36,37,46,52,9,223,0,33,73,80,159,36,40,37,20,15,16,2,27,248,22,
169,15,248,22,156,8,27,28,249,22,152,9,247,22,164,8,2,34,6,1,1,
59,6,1,1,58,250,22,190,7,6,14,14,40,91,94,126,97,93,42,41,126,
97,40,46,42,41,23,196,2,23,196,1,88,163,8,36,38,48,11,2,7,223,
0,33,77,80,159,36,41,37,20,15,16,2,32,0,88,163,8,36,38,47,11,
2,8,222,33,78,80,159,36,42,37,20,15,16,2,32,0,88,163,8,36,39,
48,11,2,9,222,33,80,80,159,36,43,37,20,15,16,2,32,0,88,163,8,
36,38,46,11,2,10,222,33,81,80,159,36,44,37,20,15,16,2,88,163,45,
39,49,8,128,16,2,11,223,0,33,83,80,159,36,45,37,20,15,16,2,88,
163,45,40,50,8,128,16,2,13,223,0,33,85,80,159,36,47,37,20,15,16,
2,248,22,160,15,70,108,105,110,107,115,45,102,105,108,101,80,159,36,48,37,
20,15,16,2,247,22,140,2,80,158,36,49,20,15,16,2,2,86,80,158,36,
50,20,15,16,2,248,80,159,37,52,37,88,163,36,36,49,8,240,16,0,6,
0,9,223,1,33,87,80,159,36,51,37,20,15,16,2,247,22,140,2,80,158,
36,55,20,15,16,2,2,86,80,158,36,56,20,15,16,2,88,163,36,37,44,
8,240,0,240,94,0,2,24,223,0,33,98,80,159,36,57,37,20,15,16,2,
88,163,36,38,56,8,240,0,0,128,0,2,25,223,0,33,100,80,159,36,59,
37,20,15,16,2,88,163,36,40,59,8,240,0,128,160,0,2,12,223,0,33,
111,80,159,36,46,37,20,15,16,2,32,0,88,163,36,39,50,11,2,26,222,
33,112,80,159,36,8,24,37,20,15,16,2,32,0,88,163,36,38,53,11,2,
27,222,33,113,80,159,36,8,25,37,20,15,16,2,32,0,88,163,36,38,54,
11,2,28,222,33,114,80,159,36,8,26,37,20,15,16,2,20,27,158,32,0,
88,163,36,37,44,11,2,29,222,33,115,32,0,88,163,36,37,44,11,2,29,
222,33,116,80,159,36,8,27,37,20,15,16,2,88,163,8,36,37,51,16,2,
52,8,240,0,64,0,0,2,41,223,0,33,117,80,159,36,8,30,39,20,15,
16,2,88,163,8,36,37,51,16,2,52,8,240,0,128,0,0,2,41,223,0,
33,118,80,159,36,8,31,39,20,15,16,2,88,163,8,36,37,56,16,4,52,
36,37,36,2,41,223,0,33,119,80,159,36,8,32,39,20,15,16,2,20,25,
96,2,30,88,163,36,36,53,16,2,8,32,8,240,0,64,0,0,9,223,0,
33,120,88,163,36,37,54,16,2,8,32,8,240,0,128,0,0,9,223,0,33,
121,88,163,36,38,55,16,4,8,32,36,37,36,9,223,0,33,122,80,159,36,
8,28,37,20,15,16,2,88,163,8,36,37,55,16,4,36,42,38,36,2,41,
223,0,33,123,80,159,36,8,33,39,20,15,16,2,88,163,8,36,39,54,16,
4,52,36,38,36,2,31,223,0,33,125,80,159,36,8,29,37,95,29,94,2,
18,68,35,37,107,101,114,110,101,108,11,29,94,2,18,69,35,37,109,105,110,
45,115,116,120,11,2,20,9,9,9,36,0};
EVAL_ONE_SIZED_STR((char *)expr, 10007);
2,20,76,102,105,110,100,45,108,105,110,107,115,45,112,97,116,104,33,11,4,
30,2,21,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
45,107,101,121,11,6,30,2,21,1,23,101,120,116,101,110,100,45,112,97,114,
97,109,101,116,101,114,105,122,97,116,105,111,110,11,3,2,22,2,23,2,24,
30,2,20,1,21,101,120,99,101,112,116,105,111,110,45,104,97,110,100,108,101,
114,45,107,101,121,11,2,2,25,2,26,2,27,2,28,2,29,2,30,2,31,
16,0,37,39,36,16,0,36,16,13,2,9,2,10,2,8,2,3,2,26,2,
24,2,22,2,17,2,23,2,25,2,15,2,14,2,16,49,11,11,11,16,13,
2,13,2,11,2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7,2,
27,2,2,2,5,16,13,11,11,11,11,11,11,11,11,11,11,11,11,11,16,
13,2,13,2,11,2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7,
2,27,2,2,2,5,49,49,37,12,11,11,16,0,16,0,16,0,36,36,11,
12,11,11,16,0,16,0,16,0,36,36,16,30,20,15,16,2,32,0,88,163,
36,37,45,11,2,2,222,33,57,80,159,36,36,37,20,15,16,2,249,22,144,
7,7,92,7,92,80,159,36,37,37,20,15,16,2,88,163,36,37,54,38,2,
4,223,0,33,62,80,159,36,38,37,20,15,16,2,88,163,36,38,58,38,2,
5,223,0,33,64,80,159,36,39,37,20,15,16,2,20,25,96,2,6,88,163,
8,36,39,8,25,8,32,9,223,0,33,71,88,163,36,38,47,52,9,223,0,
33,72,88,163,36,37,46,52,9,223,0,33,73,80,159,36,40,37,20,15,16,
2,27,248,22,169,15,248,22,156,8,27,28,249,22,152,9,247,22,164,8,2,
34,6,1,1,59,6,1,1,58,250,22,190,7,6,14,14,40,91,94,126,97,
93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,88,163,8,36,38,48,
11,2,7,223,0,33,77,80,159,36,41,37,20,15,16,2,32,0,88,163,8,
36,38,47,11,2,8,222,33,78,80,159,36,42,37,20,15,16,2,32,0,88,
163,8,36,39,48,11,2,9,222,33,80,80,159,36,43,37,20,15,16,2,32,
0,88,163,8,36,38,46,11,2,10,222,33,81,80,159,36,44,37,20,15,16,
2,88,163,45,39,49,8,128,16,2,11,223,0,33,83,80,159,36,45,37,20,
15,16,2,88,163,45,40,50,8,128,16,2,13,223,0,33,85,80,159,36,47,
37,20,15,16,2,248,22,160,15,70,108,105,110,107,115,45,102,105,108,101,80,
159,36,48,37,20,15,16,2,247,22,140,2,80,158,36,49,20,15,16,2,2,
86,80,158,36,50,20,15,16,2,248,80,159,37,52,37,88,163,36,36,49,8,
240,16,0,6,0,9,223,1,33,87,80,159,36,51,37,20,15,16,2,247,22,
140,2,80,158,36,55,20,15,16,2,2,86,80,158,36,56,20,15,16,2,88,
163,36,37,44,8,240,0,240,94,0,2,24,223,0,33,98,80,159,36,57,37,
20,15,16,2,88,163,36,38,56,8,240,0,0,128,0,2,25,223,0,33,100,
80,159,36,59,37,20,15,16,2,88,163,36,40,59,8,240,0,128,160,0,2,
12,223,0,33,111,80,159,36,46,37,20,15,16,2,32,0,88,163,36,39,50,
11,2,26,222,33,112,80,159,36,8,24,37,20,15,16,2,32,0,88,163,36,
38,53,11,2,27,222,33,113,80,159,36,8,25,37,20,15,16,2,32,0,88,
163,36,38,54,11,2,28,222,33,114,80,159,36,8,26,37,20,15,16,2,20,
27,158,32,0,88,163,36,37,44,11,2,29,222,33,115,32,0,88,163,36,37,
44,11,2,29,222,33,116,80,159,36,8,27,37,20,15,16,2,88,163,8,36,
37,51,16,2,52,8,240,0,64,0,0,2,41,223,0,33,117,80,159,36,8,
30,39,20,15,16,2,88,163,8,36,37,51,16,2,52,8,240,0,128,0,0,
2,41,223,0,33,118,80,159,36,8,31,39,20,15,16,2,88,163,8,36,37,
56,16,4,52,36,37,36,2,41,223,0,33,119,80,159,36,8,32,39,20,15,
16,2,20,25,96,2,30,88,163,36,36,53,16,2,8,32,8,240,0,64,0,
0,9,223,0,33,120,88,163,36,37,54,16,2,8,32,8,240,0,128,0,0,
9,223,0,33,121,88,163,36,38,55,16,4,8,32,36,37,36,9,223,0,33,
122,80,159,36,8,28,37,20,15,16,2,88,163,8,36,37,55,16,4,36,42,
38,36,2,41,223,0,33,123,80,159,36,8,33,39,20,15,16,2,88,163,8,
36,39,54,16,4,52,36,38,36,2,31,223,0,33,125,80,159,36,8,29,37,
95,29,94,2,18,68,35,37,107,101,114,110,101,108,11,29,94,2,18,69,35,
37,109,105,110,45,115,116,120,11,2,20,9,9,9,36,0};
EVAL_ONE_SIZED_STR((char *)expr, 10011);
}
{
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,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,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,51,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,52,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,
@ -616,7 +616,7 @@
12,186,12,249,12,12,13,26,13,184,13,197,13,75,14,117,15,199,15,63,16,
120,16,128,16,137,16,160,17,166,17,194,17,207,17,113,18,120,18,174,18,196,
18,216,18,15,19,25,19,39,19,76,19,174,19,176,19,26,20,213,27,10,28,
34,28,58,28,0,0,46,32,0,0,66,35,37,98,111,111,116,70,100,108,108,
34,28,58,28,0,0,56,32,0,0,66,35,37,98,111,111,116,70,100,108,108,
45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116,45,108,111,97,100,
47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117,111,116,101,68,35,
37,112,97,114,97,109,122,29,94,2,4,2,5,11,1,20,112,97,114,97,109,
@ -962,57 +962,58 @@
249,22,33,11,80,159,39,57,37,20,18,159,11,80,158,36,55,248,80,159,37,
8,27,37,249,22,33,11,80,159,39,57,37,159,36,20,113,159,36,16,1,11,
16,0,20,26,144,9,2,1,2,1,29,11,11,11,9,9,11,11,11,10,38,
80,158,36,36,20,113,159,41,16,28,2,2,2,3,30,2,6,2,7,6,30,
2,6,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,
122,97,116,105,111,110,3,30,2,8,72,112,97,116,104,45,115,116,114,105,110,
103,63,196,11,2,9,30,2,8,71,114,101,114,111,111,116,45,112,97,116,104,
196,12,30,2,8,75,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120,
196,8,2,10,2,11,2,12,2,13,2,14,2,15,2,16,2,17,2,18,2,
19,2,20,2,21,2,22,30,2,23,2,7,6,30,2,8,79,112,97,116,104,
45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,196,10,30,2,8,73,
102,105,110,100,45,99,111,108,45,102,105,108,101,196,3,30,2,8,76,110,111,
114,109,97,108,45,99,97,115,101,45,112,97,116,104,196,7,2,24,2,25,30,
2,23,74,114,101,112,97,114,97,109,101,116,101,114,105,122,101,7,16,0,37,
39,36,16,0,36,16,15,2,16,2,17,2,9,2,13,2,18,2,19,2,12,
2,3,2,11,2,2,2,14,2,15,2,10,2,20,2,22,51,11,11,11,16,
3,2,24,2,21,2,25,16,3,11,11,11,16,3,2,24,2,21,2,25,39,
39,37,12,11,11,16,0,16,0,16,0,36,36,11,12,11,11,16,0,16,0,
16,0,36,36,16,23,20,15,16,2,248,22,164,8,69,115,111,45,115,117,102,
102,105,120,80,159,36,36,37,20,15,16,2,88,163,36,38,8,43,8,189,3,
2,3,223,0,33,54,80,159,36,37,37,20,15,16,2,32,0,88,163,8,36,
41,52,11,2,10,222,33,55,80,159,36,44,37,20,15,16,2,20,27,158,32,
0,88,163,8,36,37,42,11,2,11,222,192,32,0,88,163,8,36,37,42,11,
2,11,222,192,80,159,36,45,37,20,15,16,2,247,22,143,2,80,159,36,41,
37,20,15,16,2,8,128,8,80,159,36,46,37,20,15,16,2,249,22,168,8,
8,128,8,11,80,159,36,47,37,20,15,16,2,88,163,8,36,37,50,8,128,
32,2,14,223,0,33,56,80,159,36,48,37,20,15,16,2,88,163,8,36,38,
55,8,128,32,2,15,223,0,33,57,80,159,36,49,37,20,15,16,2,247,22,
75,80,159,36,50,37,20,15,16,2,248,22,18,74,109,111,100,117,108,101,45,
108,111,97,100,105,110,103,80,159,36,51,37,20,15,16,2,11,80,158,36,52,
20,15,16,2,11,80,158,36,53,20,15,16,2,32,0,88,163,36,38,8,25,
11,2,20,222,33,63,80,159,36,54,37,20,15,16,2,11,80,158,36,55,20,
15,16,2,88,164,8,34,37,45,8,240,0,0,40,0,1,21,112,114,101,112,
45,112,108,97,110,101,116,45,114,101,115,111,108,118,101,114,33,37,224,1,0,
33,64,80,159,36,8,28,39,20,15,16,2,88,163,36,37,50,8,240,0,0,
3,0,67,103,101,116,45,100,105,114,223,0,33,65,80,159,36,8,29,39,20,
15,16,2,88,163,36,37,49,8,240,0,0,64,0,72,112,97,116,104,45,115,
115,45,62,114,107,116,223,0,33,66,80,159,36,8,30,39,20,15,16,2,88,
163,8,36,37,45,8,240,0,0,4,0,9,223,0,33,67,80,159,36,8,31,
39,20,15,16,2,88,163,36,37,45,8,240,0,128,0,0,9,223,0,33,68,
80,159,36,8,32,39,20,15,16,2,27,11,20,19,158,36,90,159,37,10,89,
161,37,36,10,20,25,96,2,22,88,163,8,36,38,54,8,32,9,224,2,1,
33,69,88,163,36,39,49,11,9,223,0,33,70,88,163,36,40,8,32,16,4,
8,240,44,240,0,0,8,240,204,241,0,0,37,36,9,224,2,1,33,85,207,
80,159,36,56,37,20,15,16,2,88,163,36,36,45,16,2,8,130,8,8,184,
32,2,24,223,0,33,86,80,159,36,8,25,37,20,15,16,2,20,27,158,88,
163,8,36,36,45,16,2,36,8,168,32,2,25,223,0,33,87,88,163,8,36,
36,45,16,2,36,8,168,32,2,25,223,0,33,88,80,159,36,8,26,37,96,
29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,2,4,69,35,37,
109,105,110,45,115,116,120,11,2,8,2,23,9,9,9,36,0};
EVAL_ONE_SIZED_STR((char *)expr, 8458);
80,158,36,36,20,113,159,41,16,28,2,2,2,3,30,2,6,2,7,11,6,
30,2,6,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,
105,122,97,116,105,111,110,11,3,30,2,8,72,112,97,116,104,45,115,116,114,
105,110,103,63,38,196,11,2,9,30,2,8,71,114,101,114,111,111,116,45,112,
97,116,104,40,196,12,30,2,8,75,112,97,116,104,45,97,100,100,45,115,117,
102,102,105,120,40,196,8,2,10,2,11,2,12,2,13,2,14,2,15,2,16,
2,17,2,18,2,19,2,20,2,21,2,22,30,2,23,2,7,11,6,30,2,
8,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,
40,196,10,30,2,8,73,102,105,110,100,45,99,111,108,45,102,105,108,101,44,
196,3,30,2,8,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,
104,38,196,7,2,24,2,25,30,2,23,74,114,101,112,97,114,97,109,101,116,
101,114,105,122,101,11,7,16,0,37,39,36,16,0,36,16,15,2,16,2,17,
2,9,2,13,2,18,2,19,2,12,2,3,2,11,2,2,2,14,2,15,2,
10,2,20,2,22,51,11,11,11,16,3,2,24,2,21,2,25,16,3,11,11,
11,16,3,2,24,2,21,2,25,39,39,37,12,11,11,16,0,16,0,16,0,
36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,23,20,15,16,2,248,
22,164,8,69,115,111,45,115,117,102,102,105,120,80,159,36,36,37,20,15,16,
2,88,163,36,38,8,43,8,189,3,2,3,223,0,33,54,80,159,36,37,37,
20,15,16,2,32,0,88,163,8,36,41,52,11,2,10,222,33,55,80,159,36,
44,37,20,15,16,2,20,27,158,32,0,88,163,8,36,37,42,11,2,11,222,
192,32,0,88,163,8,36,37,42,11,2,11,222,192,80,159,36,45,37,20,15,
16,2,247,22,143,2,80,159,36,41,37,20,15,16,2,8,128,8,80,159,36,
46,37,20,15,16,2,249,22,168,8,8,128,8,11,80,159,36,47,37,20,15,
16,2,88,163,8,36,37,50,8,128,32,2,14,223,0,33,56,80,159,36,48,
37,20,15,16,2,88,163,8,36,38,55,8,128,32,2,15,223,0,33,57,80,
159,36,49,37,20,15,16,2,247,22,75,80,159,36,50,37,20,15,16,2,248,
22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,36,51,
37,20,15,16,2,11,80,158,36,52,20,15,16,2,11,80,158,36,53,20,15,
16,2,32,0,88,163,36,38,8,25,11,2,20,222,33,63,80,159,36,54,37,
20,15,16,2,11,80,158,36,55,20,15,16,2,88,164,8,34,37,45,8,240,
0,0,40,0,1,21,112,114,101,112,45,112,108,97,110,101,116,45,114,101,115,
111,108,118,101,114,33,37,224,1,0,33,64,80,159,36,8,28,39,20,15,16,
2,88,163,36,37,50,8,240,0,0,3,0,67,103,101,116,45,100,105,114,223,
0,33,65,80,159,36,8,29,39,20,15,16,2,88,163,36,37,49,8,240,0,
0,64,0,72,112,97,116,104,45,115,115,45,62,114,107,116,223,0,33,66,80,
159,36,8,30,39,20,15,16,2,88,163,8,36,37,45,8,240,0,0,4,0,
9,223,0,33,67,80,159,36,8,31,39,20,15,16,2,88,163,36,37,45,8,
240,0,128,0,0,9,223,0,33,68,80,159,36,8,32,39,20,15,16,2,27,
11,20,19,158,36,90,159,37,10,89,161,37,36,10,20,25,96,2,22,88,163,
8,36,38,54,8,32,9,224,2,1,33,69,88,163,36,39,49,11,9,223,0,
33,70,88,163,36,40,8,32,16,4,8,240,44,240,0,0,8,240,204,241,0,
0,37,36,9,224,2,1,33,85,207,80,159,36,56,37,20,15,16,2,88,163,
36,36,45,16,2,8,130,8,8,184,32,2,24,223,0,33,86,80,159,36,8,
25,37,20,15,16,2,20,27,158,88,163,8,36,36,45,16,2,36,8,168,32,
2,25,223,0,33,87,88,163,8,36,36,45,16,2,36,8,168,32,2,25,223,
0,33,88,80,159,36,8,26,37,96,29,94,2,4,68,35,37,107,101,114,110,
101,108,11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,8,2,
23,9,9,9,36,0};
EVAL_ONE_SIZED_STR((char *)expr, 8468);
}
{
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,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,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,

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

@ -1307,7 +1307,7 @@ void scheme_wrong_count_m(const char *name, int minc, int maxc,
#ifdef MZ_USE_JIT
} else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_native_closure_type)) {
Scheme_Object *pa;
pa = scheme_get_native_arity((Scheme_Object *)name);
pa = scheme_get_native_arity((Scheme_Object *)name, -1);
if (SCHEME_BOXP(pa)) {
pa = SCHEME_BOX_VAL(pa);
is_method = 1;
@ -1405,7 +1405,7 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc,
#ifdef MZ_USE_JIT
} else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)proc), scheme_native_closure_type)) {
Scheme_Object *pa;
pa = scheme_get_native_arity((Scheme_Object *)proc);
pa = scheme_get_native_arity((Scheme_Object *)proc, -1);
if (SCHEME_BOXP(pa)) {
pa = SCHEME_BOX_VAL(pa);
}

91
src/racket/src/eval.c
View File

@ -787,8 +787,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
int pos, int mod_phase,
Scheme_Env *env,
Scheme_Object **exprs, int which,
char *import_map,
int flags)
int flags, Scheme_Object *shape)
{
Scheme_Object *modname;
Scheme_Env *menv;
@ -831,11 +830,20 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
if (self) {
exprs[which] = varname;
} else {
Scheme_Object *v = modname;
if (mod_phase != 0)
v = scheme_make_pair(v, scheme_make_integer(mod_phase));
v = scheme_make_pair(varname, v);
exprs[which] = v;
if (flags & SCHEME_MODVAR_CONST) {
Scheme_Object *v;
v = scheme_make_vector((mod_phase != 0) ? 4 : 3, modname);
SCHEME_VEC_ELS(v)[1] = varname;
SCHEME_VEC_ELS(v)[2] = (shape ? shape : scheme_false);
if (mod_phase != 0)
SCHEME_VEC_ELS(v)[3] = scheme_make_integer(mod_phase);
} else {
Scheme_Object *v = modname;
if (mod_phase != 0)
v = scheme_make_pair(v, scheme_make_integer(mod_phase));
v = scheme_make_pair(varname, v);
exprs[which] = v;
}
}
}
@ -844,17 +852,15 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
const char *bad_reason = NULL;
if (!bkt->val) {
bad_reason = "uninitialized";
bad_reason = "is uninitialized";
} else if (flags) {
if (flags & SCHEME_MODVAR_CONST) {
/* The fact that the link target is consistent is a fine
sanity check, but the check is not good enough for the JIT
to rely on it. To be useful for the JIT, we'd have to make
sure that every link goes to the same value. Since we can't
currently guarantee that, all the JIT assumes is that the
value is "fixed". */
if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_CONSISTENT))
bad_reason = "not constant across all instantiations";
bad_reason = "is not a procedure or structure-type constant across all instantiations";
else if (shape && SCHEME_TRUEP(shape)) {
if (!scheme_get_or_check_procedure_shape(bkt->val, shape))
bad_reason = "has the wrong procedure or structure-type shape";
}
} else {
if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_IMMUTATED))
bad_reason = "not constant";
@ -864,7 +870,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
if (bad_reason) {
scheme_wrong_syntax("link", NULL, varname,
"bad variable linkage;\n"
" reference to a variable that is %s\n"
" reference to a variable that %s\n"
" reference phase level: %d\n"
" variable module: %D\n"
" variable phase: %d\n"
@ -880,17 +886,13 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
((Scheme_Bucket_With_Flags *)bkt)->flags |= GLOB_IS_LINKED;
}
if (!self && !(import_map[which >> 3] & (1 << (which & 0x7))))
import_map[which >> 3] |= (1 << (which & 0x7));
return (Scheme_Object *)bkt;
}
static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env,
Scheme_Object *src_modidx,
Scheme_Object *dest_modidx,
Scheme_Object *insp,
char *import_map)
Scheme_Object *insp)
{
Scheme_Object *expr = exprs[which];
@ -903,10 +905,10 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env
((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)env;
}
return (Scheme_Object *)b;
} else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr)) {
/* Simplified module reference */
Scheme_Object *modname, *varname;
int mod_phase = 0;
} else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr) || SCHEME_VECTORP(expr)) {
/* Simplified module reference (as installed by link_module_variable) */
Scheme_Object *modname, *varname, *shape;
int mod_phase = 0, flags = 0;
if (SCHEME_SYMBOLP(expr)) {
if (!env->module) {
/* compiled as a module variable, but instantiated in a non-module
@ -917,13 +919,20 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env
modname = env->module->modname;
mod_phase = env->mod_phase;
}
} else {
} else if (SCHEME_PAIRP(expr)) {
varname = SCHEME_CAR(expr);
modname = SCHEME_CDR(expr);
if (SCHEME_PAIRP(modname)) {
mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname));
modname = SCHEME_CAR(modname);
}
}
} else {
modname = SCHEME_VEC_ELS(expr)[0];
varname = SCHEME_VEC_ELS(expr)[1];
flags = SCHEME_MODVAR_CONST;
shape = SCHEME_VEC_ELS(expr)[2];
if (SCHEME_VEC_SIZE(expr) > 3)
mod_phase = SCHEME_INT_VAL(SCHEME_VEC_ELS(expr)[3]);
}
return link_module_variable(modname,
varname,
@ -931,8 +940,7 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env
-1, mod_phase,
env,
NULL, 0,
import_map,
0);
flags, shape);
} else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) {
Scheme_Bucket *b = (Scheme_Bucket *)expr;
Scheme_Env *home;
@ -948,7 +956,7 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env
-1, home->mod_phase,
env,
exprs, which,
import_map, 0);
0, NULL);
} else {
Module_Variable *mv = (Module_Variable *)expr;
@ -962,8 +970,7 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env
mv->pos, mv->mod_phase,
env,
exprs, which,
import_map,
SCHEME_MODVAR_FLAGS(mv) & 0x3);
SCHEME_MODVAR_FLAGS(mv) & 0x3, mv->shape);
}
}
@ -1900,7 +1907,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
is_st = 0;
else
is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 1,
NULL, NULL, NULL, NULL,
NULL, NULL,
NULL, NULL, MZ_RUNSTACK, 0,
NULL, NULL, 5);
@ -5495,7 +5502,10 @@ Scheme_Object *scheme_eval_clone(Scheme_Object *expr)
reduce the overhead of cross-module references. */
switch (SCHEME_TYPE(expr)) {
case scheme_module_type:
return scheme_module_eval_clone(expr);
if (scheme_startup_use_jit)
return scheme_module_jit(expr);
else
return scheme_module_eval_clone(expr);
break;
case scheme_define_syntaxes_type:
case scheme_begin_for_syntax_type:
@ -5543,8 +5553,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
{
Scheme_Object **rs_save, **rs, *v;
Scheme_Prefix *pf;
char *import_map;
int i, j, tl_map_len, import_map_len;
int i, j, tl_map_len;
rs_save = rs = MZ_RUNSTACK;
@ -5565,13 +5574,6 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
i += rp->num_lifts;
tl_map_len = ((rp->num_toplevels + rp->num_lifts) + 31) / 32;
import_map_len = (rp->num_toplevels + 7) / 8;
if (import_map_len) {
import_map = GC_malloc_atomic(import_map_len);
memset(import_map, 0, import_map_len);
} else
import_map = NULL;
pf = scheme_malloc_tagged(sizeof(Scheme_Prefix)
+ ((i-mzFLEX_DELTA) * sizeof(Scheme_Object *))
@ -5580,7 +5582,6 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
pf->num_slots = i;
pf->num_toplevels = rp->num_toplevels;
pf->num_stxes = rp->num_stxes;
pf->import_map = import_map;
--rs;
MZ_RUNSTACK = rs;
rs[0] = (Scheme_Object *)pf;
@ -5588,7 +5589,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
for (i = 0; i < rp->num_toplevels; i++) {
v = rp->toplevels[i];
if (genv || SCHEME_FALSEP(v))
v = link_toplevel(rp->toplevels, i, genv ? genv : dummy_env, src_modidx, now_modidx, insp, import_map);
v = link_toplevel(rp->toplevels, i, genv ? genv : dummy_env, src_modidx, now_modidx, insp);
pf->a[i] = v;
}

187
src/racket/src/fun.c
View File

@ -1918,14 +1918,18 @@ Scheme_Object *scheme_syntax_taint_rearm(Scheme_Object *stx, Scheme_Object *from
/* arity */
/*========================================================================*/
Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
static Scheme_Object *make_arity(mzshort mina, mzshort maxa, int mode)
{
if (mina == maxa)
return scheme_make_integer(mina);
else if (maxa == -1) {
Scheme_Object *p[1];
p[0] = scheme_make_integer(mina);
return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
if (mode == -3) {
return scheme_make_integer(-(mina+1));
} else {
Scheme_Object *p[1];
p[0] = scheme_make_integer(mina);
return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
}
} else {
int i;
Scheme_Object *l = scheme_null;
@ -1938,13 +1942,18 @@ Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
}
}
static Scheme_Object *clone_arity(Scheme_Object *a, int delta)
Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
{
return make_arity(mina, maxa, -1);
}
static Scheme_Object *clone_arity(Scheme_Object *a, int delta, int mode)
{
if (SCHEME_PAIRP(a)) {
Scheme_Object *m, *l;
m = scheme_copy_list(a);
for (l = m; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = clone_arity(SCHEME_CAR(l), delta);
a = clone_arity(SCHEME_CAR(l), delta, mode);
SCHEME_CAR(l) = a;
}
return m;
@ -1953,8 +1962,12 @@ static Scheme_Object *clone_arity(Scheme_Object *a, int delta)
a = scheme_struct_ref(a, 0);
if (delta)
a = scheme_bin_minus(a, scheme_make_integer(delta));
p[0] = a;
return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
if (mode == -3) {
return scheme_make_integer(-(SCHEME_INT_VAL(a)+1));
} else {
p[0] = a;
return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
}
} else if (SCHEME_NULLP(a))
return a;
else if (delta)
@ -1965,7 +1978,8 @@ static Scheme_Object *clone_arity(Scheme_Object *a, int delta)
static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok)
/* a == -1 => get arity
a == -2 => check for allowing bignum */
a == -2 => check for allowing bignum
a == -3 => like -1, but alternate representation using negative numbers for arity-at-least */
{
Scheme_Type type;
mzshort mina, maxa;
@ -1995,20 +2009,25 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
} else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
mina = 0;
maxa = -1;
} else if (type == scheme_case_closure_type) {
} else if ((type == scheme_case_closure_type)
|| (type == scheme_case_lambda_sequence_type)) {
Scheme_Case_Lambda *seq;
Scheme_Closure_Data *data;
int i;
Scheme_Object *first, *last = NULL, *v;
if (a == -1)
if ((a == -1) || (a == -3))
first = scheme_null;
else
first = scheme_false;
seq = (Scheme_Case_Lambda *)p;
for (i = 0; i < seq->count; i++) {
data = SCHEME_COMPILED_CLOS_CODE(seq->array[i]);
v = seq->array[i];
if (SAME_TYPE(SCHEME_TYPE(v), scheme_unclosed_procedure_type))
data = (Scheme_Closure_Data *)v;
else
data = SCHEME_COMPILED_CLOS_CODE(v);
mina = maxa = data->num_params;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
if (mina)
@ -2028,7 +2047,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (maxa > 0)
maxa -= drop;
v = scheme_make_pair(scheme_make_arity(mina, maxa), scheme_null);
v = scheme_make_pair(make_arity(mina, maxa, a), scheme_null);
if (!last)
first = v;
else
@ -2052,8 +2071,8 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (drop)
bign = scheme_bin_plus(bign, scheme_make_integer(drop));
}
if (a == -1)
return clone_arity(((Scheme_Structure *)p)->slots[1], drop);
if ((a == -1) || (a == -3))
return clone_arity(((Scheme_Structure *)p)->slots[1], drop, a);
else {
/* Check arity (or for varargs) */
Scheme_Object *v;
@ -2089,7 +2108,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
} else {
p = scheme_extract_struct_procedure(p, -1, NULL, &is_method);
if (!SCHEME_PROCP(p)) {
if (a == -1)
if ((a == -1) || (a == -3))
return scheme_null;
else
return scheme_false;
@ -2104,7 +2123,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (a < 0) {
Scheme_Object *pa;
pa = scheme_get_native_arity(p);
pa = scheme_get_native_arity(p, a);
if (SCHEME_BOXP(pa)) {
/* Is a method; pa already corrects for it */
@ -2152,35 +2171,35 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (drop) {
/* Need to adjust elements (e.g., because this
procedure is a struct's apply handler) */
Scheme_Object *first = scheme_null, *last = NULL, *a;
Scheme_Object *first = scheme_null, *last = NULL, *ae;
int v;
while (SCHEME_PAIRP(pa)) {
a = SCHEME_CAR(pa);
if (SCHEME_INTP(a)) {
v = SCHEME_INT_VAL(a);
ae = SCHEME_CAR(pa);
if (SCHEME_INTP(ae)) {
v = SCHEME_INT_VAL(ae);
if (v < drop)
a = NULL;
ae = NULL;
else {
v -= drop;
a = scheme_make_integer(v);
ae = scheme_make_integer(v);
}
} else {
/* arity-at-least */
a = ((Scheme_Structure *)a)->slots[0];
v = SCHEME_INT_VAL(a);
ae = ((Scheme_Structure *)ae)->slots[0];
v = SCHEME_INT_VAL(ae);
if (v >= drop) {
a = scheme_make_arity(v - drop, -1);
ae = make_arity(v - drop, -1, a);
} else {
a = scheme_make_arity(0, -1);
ae = make_arity(0, -1, a);
}
}
if (a) {
a = scheme_make_pair(a, scheme_null);
if (ae) {
ae = scheme_make_pair(ae, scheme_null);
if (last)
SCHEME_CDR(last) = a;
SCHEME_CDR(last) = ae;
else
first = a;
last = a;
first = ae;
last = ae;
}
pa = SCHEME_CDR(pa);
}
@ -2203,7 +2222,11 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
} else {
Scheme_Closure_Data *data;
data = SCHEME_COMPILED_CLOS_CODE(p);
if (type == scheme_unclosed_procedure_type)
data = (Scheme_Closure_Data *)p;
else
data = SCHEME_COMPILED_CLOS_CODE(p);
mina = maxa = data->num_params;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
if (mina)
@ -2215,12 +2238,12 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (cases) {
int count = cases_count, i;
if (a == -1) {
Scheme_Object *arity, *a, *last = NULL;
if ((a == -1) || (a == -3)) {
Scheme_Object *arity, *ae, *last = NULL;
arity = scheme_alloc_list(count);
for (i = 0, a = arity; i < count; i++) {
for (i = 0, ae = arity; i < count; i++) {
Scheme_Object *av;
int mn, mx;
mn = cases[2 * i];
@ -2231,16 +2254,16 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (mx > 0)
mx -= drop;
av = scheme_make_arity(mn, mx);
av = make_arity(mn, mx, a);
SCHEME_CAR(a) = av;
last = a;
a = SCHEME_CDR(a);
SCHEME_CAR(ae) = av;
last = ae;
ae = SCHEME_CDR(ae);
}
}
/* If drop > 0, might have found no matches */
if (!SCHEME_NULLP(a)) {
if (!SCHEME_NULLP(ae)) {
if (last)
SCHEME_CDR(last) = scheme_null;
else
@ -2272,7 +2295,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
return scheme_false;
}
if (a == -1) {
if ((a == -1) || (a == -3)) {
if (mina < drop)
return scheme_null;
else
@ -2280,7 +2303,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
if (maxa > 0)
maxa -= drop;
return scheme_make_arity(mina, maxa);
return make_arity(mina, maxa, a);
}
if (a == -2)
@ -2357,6 +2380,82 @@ int scheme_check_proc_arity(const char *where, int a,
return scheme_check_proc_arity2(where, a, which, argc, argv, 0);
}
int scheme_closure_preserves_marks(Scheme_Object *p)
{
Scheme_Type type = SCHEME_TYPE(p);
Scheme_Closure_Data *data;
if (type == scheme_native_closure_type)
return scheme_native_closure_preserves_marks(p);
else if (type == scheme_closure_type) {
data = SCHEME_COMPILED_CLOS_CODE(p);
} else if (type == scheme_unclosed_procedure_type) {
data = (Scheme_Closure_Data *)p;
} else
return 0;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS)
return 1;
return 0;
}
Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected)
/* result is interned --- a symbol or fixnum */
{
Scheme_Object *p;
if (expected
&& SCHEME_SYMBOLP(expected)
&& SCHEME_SYM_VAL(expected)[0] == 's') {
return (scheme_check_structure_shape(e, expected)
? expected
: NULL);
}
if (SAME_TYPE(SCHEME_TYPE(e), scheme_inline_variant_type))
e = SCHEME_VEC_ELS(e)[1];
p = scheme_get_or_check_arity(e, -3);
if (SCHEME_PAIRP(p)) {
/* encode as a symbol */
int sz = 32, c = 0;
char *b, *naya;
b = (char *)scheme_malloc_atomic(sz);
while (SCHEME_PAIRP(p)) {
if (sz - c < 10) {
sz *= 2;
naya = (char *)scheme_malloc_atomic(sz);
memcpy(naya, b, c);
b = naya;
}
if (c)
b[c++] = ':';
c += sprintf(b XFORM_OK_PLUS c, "%" PRIdPTR, SCHEME_INT_VAL(SCHEME_CAR(p)));
p = SCHEME_CDR(p);
}
b[c] = c;
p = scheme_intern_exact_symbol(b, c);
} else {
/* Integer encoding, but shift to use low bit to indicate whether
it preserves marks, which is useful information for the JIT. */
intptr_t i = SCHEME_INT_VAL(p);
i <<= 1;
if (scheme_closure_preserves_marks(e)) {
i |= 0x1;
}
p = scheme_make_integer(i);
}
if (expected && !SAME_OBJ(expected, p))
return NULL;
return p;
}
/*========================================================================*/
/* basic function primitives */
/*========================================================================*/
@ -2934,7 +3033,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
lists that include arity-at-least records. */
orig = get_or_check_arity(argv[0], -1, NULL, 1);
aty = clone_arity(argv[1], 0);
aty = clone_arity(argv[1], 0, -1);
if (!is_subarity(aty, orig)) {
scheme_contract_error("procedure-reduce-arity",

52
src/racket/src/jit.c
View File

@ -469,14 +469,9 @@ Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc
pos = SCHEME_TOPLEVEL_POS(o);
if (local_only) {
/* Usually, we look for local bindings only, because module caching means
that JIT-generated code can be linked to different other modules that
may have different bindings, even though we expect them binding to be
consistent. */
if (pos < globs->num_toplevels) {
if (globs->import_map[pos >> 3] & (1 << (pos & 7)))
return NULL;
}
/* Look for local bindings when the JIT depends on information that is not
validated across module boundaries. */
scheme_signal_error("internal error: import map not available");
}
return globs->a[pos];
@ -506,6 +501,23 @@ Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *ji
return NULL;
}
int scheme_native_closure_preserves_marks(Scheme_Object *p)
{
Scheme_Native_Closure_Data *ndata = ((Scheme_Native_Closure *)p)->code;
if (ndata->closure_size >= 0) { /* not case-lambda */
if (lambda_has_been_jitted(ndata)) {
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) & NATIVE_PRESERVES_MARKS)
return 1;
} else {
if (SCHEME_CLOSURE_DATA_FLAGS(ndata->u2.orig_code) & CLOS_PRESERVES_MARKS)
return 1;
}
}
return 0;
}
int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack_start)
{
if (SCHEME_PRIMP(a)) {
@ -525,20 +537,12 @@ int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack
&& SAME_TYPE(SCHEME_TYPE(a), scheme_toplevel_type)
&& ((SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST)) {
Scheme_Object *p;
p = scheme_extract_global(a, jitter->nc, 1);
p = scheme_extract_global(a, jitter->nc, 0);
if (p) {
p = ((Scheme_Bucket *)p)->val;
if (p && SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) {
Scheme_Native_Closure_Data *ndata = ((Scheme_Native_Closure *)p)->code;
if (ndata->closure_size >= 0) { /* not case-lambda */
if (lambda_has_been_jitted(ndata)) {
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) & NATIVE_PRESERVES_MARKS)
return 1;
} else {
if (SCHEME_CLOSURE_DATA_FLAGS(ndata->u2.orig_code) & CLOS_PRESERVES_MARKS)
return 1;
}
}
if (scheme_native_closure_preserves_marks(p))
return 1;
}
}
}
@ -747,7 +751,7 @@ static int is_a_procedure(Scheme_Object *v, mz_jit_state *jitter)
if (jitter->nc) {
Scheme_Object *p;
p = scheme_extract_global(v, jitter->nc, 1);
p = scheme_extract_global(v, jitter->nc, 0);
if (p) {
p = ((Scheme_Bucket *)p)->val;
return SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type);
@ -3930,7 +3934,7 @@ int scheme_native_arity_check(Scheme_Object *closure, int argc)
return sjc.check_arity_code(closure, argc + 1, 0 EXTRA_NATIVE_ARGUMENT);
}
Scheme_Object *scheme_get_native_arity(Scheme_Object *closure)
Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode)
{
int cnt;
@ -3951,7 +3955,11 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure)
has_rest = 1;
} else
has_rest = 0;
a = scheme_make_arity(v, has_rest ? -1 : v);
if (mode == -3) {
if (has_rest) v = -(v+1);
a = scheme_make_integer(v);
} else
a = scheme_make_arity(v, has_rest ? -1 : v);
l = scheme_make_pair(a, l);
}
if (is_method)

2
src/racket/src/jitcall.c
View File

@ -1652,7 +1652,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
&& ((SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST)) {
Scheme_Object *p;
p = scheme_extract_global(rator, jitter->nc, 1);
p = scheme_extract_global(rator, jitter->nc, 0);
if (p) {
p = ((Scheme_Bucket *)p)->val;
if (can_direct_native(p, num_rands, &extract_case)) {

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

@ -356,7 +356,7 @@ static Scheme_Object *extract_struct_constant(mz_jit_state *jitter, Scheme_Objec
{
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);
rator = scheme_extract_global(rator, jitter->nc, 0);
if (rator)
return ((Scheme_Bucket *)rator)->val;
}

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

@ -550,8 +550,8 @@ Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context)
if (!context)
data->u.jit_clone = data2;
}
}
/* If it's zero-sized, then create closure now */
if (!data2->closure_size)
return scheme_make_native_closure(data2->u.native_code);

59
src/racket/src/module.c
View File

@ -573,7 +573,7 @@ void scheme_finish_kernel(Scheme_Env *env)
running[1] = 1;
env->running = running;
env->attached = 1;
/* Since this is the first module rename, it's registered as
the kernel module rename: */
rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL, NULL, NULL);
@ -4069,6 +4069,19 @@ static int is_procedure_expression(Scheme_Object *e)
|| (t == scheme_case_lambda_sequence_type));
}
static void get_procedure_shape(Scheme_Object *e, Scheme_Object **_c)
{
Scheme_Object *p, *v;
p = scheme_get_or_check_procedure_shape(e, NULL);
v = scheme_alloc_small_object();
v->type = scheme_proc_shape_type;
SCHEME_PTR_VAL(v) = p;
*_c = v;
}
static void setup_accessible_table(Scheme_Module *m)
{
if (!m->exp_infos[0]->accessible) {
@ -4121,7 +4134,8 @@ 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, st_count = 0, st_icount = 0;
int checked_st = 0, is_st = 0;
Simple_Stuct_Type_Info stinfo;
for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) {
tl = SCHEME_VEC_ELS(form)[k];
if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) {
@ -4146,8 +4160,9 @@ static void setup_accessible_table(Scheme_Module *m)
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);
/* that it's a procedure: */
v = scheme_make_vector(2, v);
SCHEME_VEC_ELS(v)[1] = SCHEME_VEC_ELS(form)[0];
} else {
/* record that it's fixed for any given instantiation: */
v = scheme_make_pair(v, scheme_fixed_key);
@ -4156,15 +4171,18 @@ static void setup_accessible_table(Scheme_Module *m)
if (!checked_st) {
is_st = !!scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0],
SCHEME_VEC_SIZE(form)-1,
1, 1, NULL, &st_count, &st_icount,
NULL,
1, 1, NULL, &stinfo,
NULL, NULL, NULL, 0,
m->prefix->toplevels, ht,
5);
checked_st = 1;
}
if (is_st)
v = scheme_make_pair(v, scheme_make_struct_proc_shape(k-1, st_count, st_icount));
if (is_st) {
intptr_t shape;
shape = scheme_get_struct_proc_shape(k-1, &stinfo);
v = scheme_make_vector(3, v);
SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape);
}
}
scheme_hash_set(ht, tl, v);
}
@ -4376,6 +4394,20 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
if (SCHEME_PAIRP(pos)) {
if (_is_constant) *_is_constant = SCHEME_CDR(pos);
pos = SCHEME_CAR(pos);
} else if (SCHEME_VECTORP(pos)) {
if (SCHEME_VEC_SIZE(pos) == 2) {
if (_is_constant)
get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant);
} else {
if (_is_constant) {
Scheme_Object *ps;
ps = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1]));
*_is_constant = ps;
}
}
pos = SCHEME_VEC_ELS(pos)[0];
}
}
@ -4521,6 +4553,11 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem
setup_accessible_table(m);
pos = scheme_hash_get(m->exp_infos[0]->accessible, varname);
if (SCHEME_PAIRP(pos))
pos = SCHEME_CAR(pos);
else if (SCHEME_VECTORP(pos))
pos = SCHEME_VEC_ELS(pos)[0];
if (pos && (SCHEME_INT_VAL(pos) >= 0))
return SCHEME_INT_VAL(pos);
@ -8011,8 +8048,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env
sets m->comp_prefix to NULL, which is how optimize & resolve
know to avoid re-optimizing and re-resolving. */
o = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT);
use_jit = SCHEME_TRUEP(o);
/* Note: don't use MZCONFIG_USE_JIT for module bodies */
use_jit = scheme_startup_use_jit;
oi = scheme_optimize_info_create(env->prefix, 1);
scheme_optimize_info_enforce_const(oi, rec[drec].comp_flags & COMP_ENFORCE_CONSTS);
@ -8644,7 +8681,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
unbounds = scheme_make_pair(eenv->prefix->unbound, unbounds);
m = scheme_sfs(m, NULL, max_let_depth);
if (scheme_resolve_info_use_jit(ri))
if (scheme_startup_use_jit /* Note: not scheme_resolve_info_use_jit(ri) */)
m = scheme_jit_expr(m);
rp = scheme_prefix_eval_clone(rp);

1
src/racket/src/mzclpf_post.inc
View File

@ -18,7 +18,6 @@
if (!pf->next_final) {
/* We're the first to look at this prefix... */
gcMARK2(pf->import_map, gc);
if (pf->num_stxes) {
/* Mark all syntax-object references */
for (i = pf->num_stxes+1; i--;) {

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

@ -42,6 +42,7 @@ static int module_var_MARK(void *p, struct NewGC *gc) {
gcMARK2(mv->modidx, gc);
gcMARK2(mv->sym, gc);
gcMARK2(mv->insp, gc);
gcMARK2(mv->shape, gc);
return
gcBYTES_TO_WORDS(sizeof(Module_Variable));
@ -53,6 +54,7 @@ static int module_var_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(mv->modidx, gc);
gcFIXUP2(mv->sym, gc);
gcFIXUP2(mv->insp, gc);
gcFIXUP2(mv->shape, gc);
return
gcBYTES_TO_WORDS(sizeof(Module_Variable));
@ -2362,7 +2364,6 @@ static int prefix_val_MARK(void *p, struct NewGC *gc) {
int i;
for (i = pf->num_slots; i--; )
gcMARK2(pf->a[i], gc);
gcMARK2(pf->import_map, gc);
return
gcBYTES_TO_WORDS((sizeof(Scheme_Prefix)
+ ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *))
@ -2375,7 +2376,6 @@ static int prefix_val_FIXUP(void *p, struct NewGC *gc) {
int i;
for (i = pf->num_slots; i--; )
gcFIXUP2(pf->a[i], gc);
gcFIXUP2(pf->import_map, gc);
return
gcBYTES_TO_WORDS((sizeof(Scheme_Prefix)
+ ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *))

2
src/racket/src/mzmarksrc.c
View File

@ -20,6 +20,7 @@ module_var {
gcMARK2(mv->modidx, gc);
gcMARK2(mv->sym, gc);
gcMARK2(mv->insp, gc);
gcMARK2(mv->shape, gc);
size:
gcBYTES_TO_WORDS(sizeof(Module_Variable));
@ -949,7 +950,6 @@ prefix_val {
int i;
for (i = pf->num_slots; i--; )
gcMARK2(pf->a[i], gc);
gcMARK2(pf->import_map, gc);
size:
gcBYTES_TO_WORDS((sizeof(Scheme_Prefix)
+ ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *))

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

@ -118,8 +118,6 @@ static Scheme_Object *optimize_shift(Scheme_Object *obj, int delta, int after_de
static int compiled_proc_body_size(Scheme_Object *o, int less_args);
READ_ONLY static Scheme_Object *struct_proc_shape_other;
typedef struct Scheme_Once_Used {
Scheme_Object so;
Scheme_Object *expr;
@ -145,9 +143,6 @@ void scheme_init_optimize()
#ifdef MZ_PRECISE_GC
register_traversers();
#endif
REGISTER_SO(struct_proc_shape_other);
struct_proc_shape_other = scheme_make_struct_proc_shape(3, 0, 0);
}
/*========================================================================*/
@ -433,7 +428,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
Scheme_Object *auto_e;
int auto_e_depth;
auto_e = scheme_is_simple_make_struct_type(o, vals, resolved, 0, &auto_e_depth,
NULL, NULL, NULL,
NULL,
(opt_info ? opt_info->top_level_consts : NULL),
NULL, NULL, 0, NULL, NULL,
5);
@ -447,12 +442,13 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
return 0;
}
static int is_current_inspector_call(Scheme_Object *a)
static int is_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))
&& (SAME_OBJ(app->args[0], scheme_current_inspector_proc)
|| SAME_OBJ(app->args[0], scheme_make_inspector_proc)))
return 1;
}
return 0;
@ -535,7 +531,8 @@ static int ok_proc_creator_args(Scheme_Object *rator, Scheme_Object *rand1, Sche
return 0;
}
static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved, int field_count)
static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved,
Simple_Stuct_Type_Info *_stinfo)
{
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e;
@ -546,30 +543,47 @@ static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int
&& is_local_ref(app->args[1], delta, 1)
&& is_local_ref(app->args[2], delta+1, 1)
&& is_local_ref(app->args[3], delta+2, 1)) {
int i;
int i, num_gets = 0, num_sets = 0, normal_ops = 1;
for (i = app->num_args; i > 3; i--) {
if (is_local_ref(app->args[i], delta, 5)) {
/* ok */
} else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application_type)) {
normal_ops = 0;
} else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application_type)
&& _stinfo->normal_ops && !_stinfo->indexed_ops) {
Scheme_App_Rec *app3 = (Scheme_App_Rec *)app->args[i];
int delta2 = delta + (resolved ? app3->num_args : 0);
if (app3->num_args == 3) {
if (!ok_proc_creator_args(app3->args[0], app3->args[1], app3->args[2], app3->args[3],
delta2, field_count))
delta2, _stinfo->field_count))
break;
if (SAME_OBJ(app3->args[0], scheme_make_struct_field_mutator_proc)) {
if (num_gets) normal_ops = 0;
num_sets++;
} else
num_gets++;
} else
break;
} else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) {
} else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)
&& _stinfo->normal_ops && !_stinfo->indexed_ops) {
Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i];
int delta2 = delta + (resolved ? 2 : 0);
if (!ok_proc_creator_args(app3->rator, app3->rand1, app3->rand2, NULL,
delta2, field_count))
delta2, _stinfo->field_count))
break;
if (SAME_OBJ(app3->rator, scheme_make_struct_field_mutator_proc)) {
if (num_gets) normal_ops = 0;
num_sets++;
} else
num_gets++;
} else
break;
}
if (i <= 3)
if (i <= 3) {
_stinfo->normal_ops = normal_ops;
_stinfo->indexed_ops = 1;
_stinfo->num_gets = num_gets;
_stinfo->num_sets = num_sets;
return 1;
}
}
}
@ -637,15 +651,21 @@ static int is_constant_super(Scheme_Object *arg,
name = symbols[pos];
if (SCHEME_SYMBOLP(name)) {
v = scheme_hash_get(symbol_table, name);
if (v && SCHEME_PAIRP(v)) {
v = SCHEME_CDR(v);
if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) {
int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK);
int field_count = (SCHEME_PROC_SHAPE_MODE(v) >> STRUCT_PROC_SHAPE_SHIFT);
if (v && SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) {
v = SCHEME_VEC_ELS(v)[1];
if (v && SCHEME_INTP(v)) {
int mode = (SCHEME_INT_VAL(v) & STRUCT_PROC_SHAPE_MASK);
int field_count = (SCHEME_INT_VAL(v) >> STRUCT_PROC_SHAPE_SHIFT);
if (mode == STRUCT_PROC_SHAPE_STRUCT)
return field_count + 1;
}
}
} else if (SAME_TYPE(SCHEME_TYPE(name), scheme_module_variable_type)) {
intptr_t k;
if (scheme_decode_struct_shape(((Module_Variable *)name)->shape, &k)) {
if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT)
return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1;
}
}
}
if (top_level_table) {
@ -663,8 +683,7 @@ static int is_constant_super(Scheme_Object *arg,
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved,
int check_auto,
GC_CAN_IGNORE int *_auto_e_depth,
int *_field_count, int *_init_field_count,
int *_uses_super,
Simple_Stuct_Type_Info *_stinfo,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
@ -714,7 +733,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
|| (SCHEME_SYMBOLP(app->args[7])
&& !strcmp("prefab", SCHEME_SYM_VAL(app->args[7]))
&& !SCHEME_SYM_WEIRDP(app->args[7]))
|| is_current_inspector_call(app->args[7]))
|| is_inspector_call(app->args[7]))
&& ((app->num_args < 8)
/* propcedure property: */
|| SCHEME_FALSEP(app->args[8])
@ -730,19 +749,22 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
/* constructor name: */
|| SCHEME_FALSEP(app->args[11])
|| SCHEME_SYMBOLP(app->args[11]))) {
int super_count = (super_count_plus_one
? (super_count_plus_one - 1)
: 0);
if (_auto_e_depth)
*_auto_e_depth = (resolved ? app->num_args : 0);
if (_field_count)
*_field_count = SCHEME_INT_VAL(app->args[3]) + super_count;
if (_init_field_count)
*_init_field_count = (SCHEME_INT_VAL(app->args[3])
+ SCHEME_INT_VAL(app->args[4])
+ super_count);
if (_uses_super)
*_uses_super = (super_count_plus_one ? 1 : 0);
if (_stinfo) {
int super_count = (super_count_plus_one
? (super_count_plus_one - 1)
: 0);
_stinfo->field_count = SCHEME_INT_VAL(app->args[3]) + super_count;
_stinfo->init_field_count = (SCHEME_INT_VAL(app->args[3])
+ SCHEME_INT_VAL(app->args[4])
+ super_count);
_stinfo->uses_super = (super_count_plus_one ? 1 : 0);
_stinfo->normal_ops = 1;
_stinfo->indexed_ops = 0;
_stinfo->num_gets = 1;
_stinfo->num_sets = 1;
}
return ((app->num_args < 5) ? scheme_true : app->args[5]);
}
}
@ -758,13 +780,13 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type)) {
Scheme_Object *auto_e;
int ifc;
Simple_Stuct_Type_Info stinfo;
int lh_delta = ((SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR))
? lh->count
: 0);
if (!_stinfo) _stinfo = &stinfo;
auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto,
_auto_e_depth, _field_count, &ifc,
_uses_super,
_auto_e_depth, _stinfo,
top_level_consts, top_level_table,
runstack, rs_delta + lh_delta,
symbols, symbol_table,
@ -772,10 +794,9 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
if (auto_e) {
/* 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, ifc)) {
if (is_values_with_accessors_and_mutators(lv->body, vals, resolved, _stinfo)) {
if (_auto_e_depth && lh_delta)
*_auto_e_depth += lh_delta;
if (_init_field_count) *_init_field_count = ifc;
return auto_e;
}
}
@ -795,10 +816,10 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
e2 = skip_clears(lv->value);
if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type)) {
Scheme_Object *auto_e;
int ifc;
Simple_Stuct_Type_Info stinfo;
if (!_stinfo) _stinfo = &stinfo;
auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto,
_auto_e_depth, _field_count, &ifc,
_uses_super,
_auto_e_depth, _stinfo,
top_level_consts, top_level_table,
runstack, rs_delta + lvd->count,
symbols, symbol_table,
@ -807,9 +828,8 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
/* 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, ifc)) {
if (is_values_with_accessors_and_mutators(e2, vals, resolved, _stinfo)) {
if (_auto_e_depth) *_auto_e_depth += lvd->count;
if (_init_field_count) *_init_field_count = ifc;
return auto_e;
}
}
@ -822,29 +842,37 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
return NULL;
}
Scheme_Object *scheme_make_struct_proc_shape(int k, int field_count, int init_field_count)
intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *stinfo)
{
Scheme_Object *ps;
switch (k) {
case 0:
if (field_count == init_field_count)
k = STRUCT_PROC_SHAPE_STRUCT | (field_count << STRUCT_PROC_SHAPE_SHIFT);
if (stinfo->field_count == stinfo->init_field_count)
return STRUCT_PROC_SHAPE_STRUCT | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT);
else
k = STRUCT_PROC_SHAPE_OTHER;
return STRUCT_PROC_SHAPE_OTHER;
break;
case 1:
k = STRUCT_PROC_SHAPE_CONSTR | (init_field_count << STRUCT_PROC_SHAPE_SHIFT);
return STRUCT_PROC_SHAPE_CONSTR | (stinfo->init_field_count << STRUCT_PROC_SHAPE_SHIFT);
break;
case 2:
k = STRUCT_PROC_SHAPE_PRED;
return STRUCT_PROC_SHAPE_PRED;
break;
default:
if (struct_proc_shape_other)
return struct_proc_shape_other;
k = STRUCT_PROC_SHAPE_OTHER;
if (stinfo && stinfo->normal_ops && stinfo->indexed_ops) {
if (k - 3 < stinfo->num_gets)
return STRUCT_PROC_SHAPE_GETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT);
else
return STRUCT_PROC_SHAPE_SETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT);
}
}
return STRUCT_PROC_SHAPE_OTHER;
}
Scheme_Object *scheme_make_struct_proc_shape(intptr_t k)
{
Scheme_Object *ps;
ps = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Small_Object));
ps->type = scheme_struct_proc_shape_type;
SCHEME_PROC_SHAPE_MODE(ps) = k;
@ -5062,7 +5090,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
(including raising an exception), then continue the group of
simultaneous definitions: */
if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) {
int n, cnst = 0, sproc = 0, sstruct = 0, field_count = 0, init_field_count = 0;
int n, cnst = 0, sproc = 0, sstruct = 0;
Simple_Stuct_Type_Info stinfo;
vars = SCHEME_VEC_ELS(e)[0];
e = SCHEME_VEC_ELS(e)[1];
@ -5084,7 +5113,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
sproc = 1;
}
} else if (scheme_is_simple_make_struct_type(e, n, 0, 1, NULL,
&field_count, &init_field_count, NULL,
&stinfo,
info->top_level_consts,
NULL, NULL, 0, NULL, NULL,
5)) {
@ -5103,7 +5132,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
Scheme_Object *e2;
if (sstruct) {
e2 = scheme_make_struct_proc_shape(i, field_count, init_field_count);
e2 = scheme_make_struct_proc_shape(scheme_get_struct_proc_shape(i, &stinfo));
} else if (sproc) {
e2 = scheme_make_noninline_proc(e);
} else if (IS_COMPILED_PROC(e)) {

3
src/racket/src/print.c
View File

@ -2909,10 +2909,11 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print(mv->modidx, notdisplay, 1, ht, mt, pp);
}
print(mv->sym, notdisplay, 1, ht, mt, pp);
print(mv->shape ? mv->shape : scheme_false, notdisplay, 1, ht, mt, pp);
if (flags & 0x3) {
print_compact_number(pp, -3-(flags&0x3));
}
if (((Module_Variable *)obj)->mod_phase) {
if (mv->mod_phase) {
print_compact_number(pp, -2);
print_compact_number(pp, mv->mod_phase);
}

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

@ -4692,11 +4692,12 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
case CPT_MODULE_VAR:
{
Module_Variable *mv;
Scheme_Object *mod, *var;
Scheme_Object *mod, *var, *shape;
int pos;
mod = read_compact(port, 0);
var = read_compact(port, 0);
shape = read_compact(port, 0);
pos = read_compact_number(port);
mv = MALLOC_ONE_TAGGED(Module_Variable);
@ -4705,6 +4706,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
mod = scheme_intern_resolved_module_path(mod);
mv->modidx = mod;
mv->sym = var;
mv->shape = shape;
if (pos < -3) {
pos = -(pos + 3);
SCHEME_MODVAR_FLAGS(mv) = pos;

7
src/racket/src/regexp.c
View File

@ -5088,13 +5088,6 @@ static Scheme_Object *do_make_regexp(const char *who, int is_byte, int pcre, int
1);
((regexp *)re)->source = src;
}
{
Scheme_Object *b;
b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT);
if (SCHEME_TRUEP(b))
((regexp *)re)->flags |= REGEXP_JIT;
}
return re;
}

2
src/racket/src/resolve.c
View File

@ -2505,7 +2505,7 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
m = ((Module_Variable *)m)->sym;
}
}
tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m;
tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m;
}
}
}

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

@ -375,6 +375,7 @@ extern Scheme_Object *scheme_make_struct_field_accessor_proc;
extern Scheme_Object *scheme_make_struct_field_mutator_proc;
extern Scheme_Object *scheme_struct_type_p_proc;
extern Scheme_Object *scheme_current_inspector_proc;
extern Scheme_Object *scheme_make_inspector_proc;
extern Scheme_Object *scheme_varref_const_p_proc;
extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax;
@ -2135,7 +2136,6 @@ typedef struct Scheme_Prefix
Scheme_Object so; /* scheme_prefix_type */
int num_slots, num_toplevels, num_stxes;
struct Scheme_Prefix *next_final; /* for special GC handling */
char *import_map; /* bitmap indicating which toplevels are imported */
Scheme_Object *a[mzFLEX_ARRAY_DECL]; /* array of objects */
/* followed by an array of `int's for tl_map uses */
} Scheme_Prefix;
@ -2865,25 +2865,40 @@ 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);
typedef struct {
int uses_super;
int field_count, init_field_count;
int normal_ops, indexed_ops, num_gets, num_sets;
} Simple_Stuct_Type_Info;
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved,
int check_auto, int *_auto_e_depth,
int *_field_count, int *_init_field_count,
int *_uses_super,
Simple_Stuct_Type_Info *_stinfo,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
int fuel);
Scheme_Object *scheme_make_struct_proc_shape(int k, int field_count, int init_field_count);
intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *sinfo);
Scheme_Object *scheme_make_struct_proc_shape(intptr_t k);
#define STRUCT_PROC_SHAPE_STRUCT 0
#define STRUCT_PROC_SHAPE_PRED 1
#define STRUCT_PROC_SHAPE_OTHER 2
#define STRUCT_PROC_SHAPE_CONSTR 3
#define STRUCT_PROC_SHAPE_MASK 0x7
#define STRUCT_PROC_SHAPE_SHIFT 3
#define STRUCT_PROC_SHAPE_CONSTR 1
#define STRUCT_PROC_SHAPE_PRED 2
#define STRUCT_PROC_SHAPE_GETTER 3
#define STRUCT_PROC_SHAPE_SETTER 4
#define STRUCT_PROC_SHAPE_OTHER 5
#define STRUCT_PROC_SHAPE_MASK 0xF
#define STRUCT_PROC_SHAPE_SHIFT 4
#define SCHEME_PROC_SHAPE_MODE(obj) (((Scheme_Small_Object *)(obj))->u.int_val)
Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected);
int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected);
int scheme_decode_struct_shape(Scheme_Object *shape, intptr_t *_v);
int scheme_closure_preserves_marks(Scheme_Object *p);
int scheme_native_closure_preserves_marks(Scheme_Object *p);
int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which);
int scheme_get_eval_type(Scheme_Object *obj);
@ -3193,6 +3208,7 @@ typedef struct Module_Variable {
Scheme_Object *modidx;
Scheme_Object *sym;
Scheme_Object *insp; /* for checking protected/unexported access */
Scheme_Object *shape; /* NULL or a symbol encoding "type" information */
int pos, mod_phase;
} Module_Variable;
@ -3271,7 +3287,8 @@ int scheme_resolved_module_path_value_matches(Scheme_Object *rmp, Scheme_Object
Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx,
Scheme_Object *stxsym, Scheme_Object *insp,
int pos, intptr_t mod_phase, int is_constant);
int pos, intptr_t mod_phase, int is_constant,
Scheme_Object *shape);
Scheme_Env *scheme_get_kernel_env();
@ -3409,7 +3426,7 @@ Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set);
Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a);
int scheme_native_arity_check(Scheme_Object *closure, int argc);
Scheme_Object *scheme_get_native_arity(Scheme_Object *closure);
Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode);
struct Scheme_Logger {
Scheme_Object so;

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

@ -30,7 +30,6 @@ typedef struct regexp {
#define REGEXP_IS_PCRE 0x02
#define REGEXP_ANCH 0x04
#define REGEXP_MUST_CI 0x08
#define REGEXP_JIT 0x10
#ifdef INDIRECT_TO_PROGRAM
# define N_ITO_DELTA(prog, extra, re) extra

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.1.3"
#define MZSCHEME_VERSION "5.3.1.4"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -40,6 +40,7 @@ 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_struct_type_p_proc;
READ_ONLY Scheme_Object *scheme_current_inspector_proc;
READ_ONLY Scheme_Object *scheme_make_inspector_proc;
READ_ONLY Scheme_Object *scheme_recur_symbol;
READ_ONLY Scheme_Object *scheme_display_symbol;
READ_ONLY Scheme_Object *scheme_write_special_symbol;
@ -715,11 +716,11 @@ scheme_init_struct (Scheme_Env *env)
/*** Inspectors ****/
scheme_add_global_constant("make-inspector",
scheme_make_prim_w_arity(make_inspector,
"make-inspector",
0, 1),
env);
REGISTER_SO(scheme_make_inspector_proc);
scheme_make_inspector_proc = scheme_make_prim_w_arity(make_inspector,
"make-inspector",
0, 1);
scheme_add_global_constant("make-inspector", scheme_make_inspector_proc, env);
scheme_add_global_constant("make-sibling-inspector",
scheme_make_prim_w_arity(make_sibling_inspector,
"make-sibling-inspector",
@ -3109,6 +3110,69 @@ chaperone_prop_getter_p(int argc, Scheme_Object *argv[])
? scheme_true : scheme_false);
}
int scheme_decode_struct_shape(Scheme_Object *expected, intptr_t *_v)
{
intptr_t v;
int i;
if (!expected || !SCHEME_SYMBOLP(expected))
return 0;
if (SCHEME_SYM_VAL(expected)[0] != 's')
return 0;
for (i = 6, v = 0; SCHEME_SYM_VAL(expected)[i]; i++) {
v = (v * 10) + (SCHEME_SYM_VAL(expected)[i] - '0');
}
*_v = v;
return 1;
}
int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected)
{
intptr_t _v, v;
int i;
Scheme_Struct_Type *st;
if (!scheme_decode_struct_shape(expected, &_v))
return 0;
v = _v;
if (SCHEME_STRUCT_TYPEP(e)) {
st = (Scheme_Struct_Type *)e;
if (st->num_slots != st->num_islots)
return (v == STRUCT_PROC_SHAPE_OTHER);
return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_STRUCT));
} else if (!SCHEME_PRIMP(e))
return 0;
i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK);
if ((i == SCHEME_PRIM_STRUCT_TYPE_CONSTR)
|| (i == SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR)) {
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
return (v == ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_CONSTR));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) {
return (v == STRUCT_PROC_SHAPE_PRED);
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) {
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_SETTER));
} else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) {
st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT)
| STRUCT_PROC_SHAPE_GETTER));
} else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
|| (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER)
|| (i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
return (v == STRUCT_PROC_SHAPE_OTHER);
return 0;
}
static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
int argc, Scheme_Object *argv[])
{

149
src/racket/src/stypes.h
View File

@ -198,84 +198,85 @@ enum {
scheme_serialized_tcp_fd_type, /* 178 */
scheme_serialized_file_fd_type, /* 179 */
scheme_port_closed_evt_type, /* 180 */
scheme_struct_proc_shape_type, /* 181 */
scheme_proc_shape_type, /* 181 */
scheme_struct_proc_shape_type, /* 182 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 182 */
_scheme_last_normal_type_, /* 183 */
scheme_rt_weak_array, /* 183 */
scheme_rt_weak_array, /* 184 */
scheme_rt_comp_env, /* 184 */
scheme_rt_constant_binding, /* 185 */
scheme_rt_resolve_info, /* 186 */
scheme_rt_unresolve_info, /* 187 */
scheme_rt_optimize_info, /* 188 */
scheme_rt_compile_info, /* 189 */
scheme_rt_cont_mark, /* 190 */
scheme_rt_saved_stack, /* 191 */
scheme_rt_reply_item, /* 192 */
scheme_rt_closure_info, /* 193 */
scheme_rt_overflow, /* 194 */
scheme_rt_overflow_jmp, /* 195 */
scheme_rt_meta_cont, /* 196 */
scheme_rt_dyn_wind_cell, /* 197 */
scheme_rt_dyn_wind_info, /* 198 */
scheme_rt_dyn_wind, /* 199 */
scheme_rt_dup_check, /* 200 */
scheme_rt_thread_memory, /* 201 */
scheme_rt_input_file, /* 202 */
scheme_rt_input_fd, /* 203 */
scheme_rt_oskit_console_input, /* 204 */
scheme_rt_tested_input_file, /* 205 */
scheme_rt_tested_output_file, /* 206 */
scheme_rt_indexed_string, /* 207 */
scheme_rt_output_file, /* 208 */
scheme_rt_load_handler_data, /* 209 */
scheme_rt_pipe, /* 210 */
scheme_rt_beos_process, /* 211 */
scheme_rt_system_child, /* 212 */
scheme_rt_tcp, /* 213 */
scheme_rt_write_data, /* 214 */
scheme_rt_tcp_select_info, /* 215 */
scheme_rt_param_data, /* 216 */
scheme_rt_will, /* 217 */
scheme_rt_linker_name, /* 218 */
scheme_rt_param_map, /* 219 */
scheme_rt_finalization, /* 220 */
scheme_rt_finalizations, /* 221 */
scheme_rt_cpp_object, /* 222 */
scheme_rt_cpp_array_object, /* 223 */
scheme_rt_stack_object, /* 224 */
scheme_rt_preallocated_object, /* 225 */
scheme_thread_hop_type, /* 226 */
scheme_rt_srcloc, /* 227 */
scheme_rt_evt, /* 228 */
scheme_rt_syncing, /* 229 */
scheme_rt_comp_prefix, /* 230 */
scheme_rt_user_input, /* 231 */
scheme_rt_user_output, /* 232 */
scheme_rt_compact_port, /* 233 */
scheme_rt_read_special_dw, /* 234 */
scheme_rt_regwork, /* 235 */
scheme_rt_rx_lazy_string, /* 236 */
scheme_rt_buf_holder, /* 237 */
scheme_rt_parameterization, /* 238 */
scheme_rt_print_params, /* 239 */
scheme_rt_read_params, /* 240 */
scheme_rt_native_code, /* 241 */
scheme_rt_native_code_plus_case, /* 242 */
scheme_rt_jitter_data, /* 243 */
scheme_rt_module_exports, /* 244 */
scheme_rt_delay_load_info, /* 245 */
scheme_rt_marshal_info, /* 246 */
scheme_rt_unmarshal_info, /* 247 */
scheme_rt_runstack, /* 248 */
scheme_rt_sfs_info, /* 249 */
scheme_rt_validate_clearing, /* 250 */
scheme_rt_avl_node, /* 251 */
scheme_rt_lightweight_cont, /* 252 */
scheme_rt_export_info, /* 253 */
scheme_rt_cont_jmp, /* 254 */
scheme_rt_comp_env, /* 185 */
scheme_rt_constant_binding, /* 186 */
scheme_rt_resolve_info, /* 187 */
scheme_rt_unresolve_info, /* 188 */
scheme_rt_optimize_info, /* 189 */
scheme_rt_compile_info, /* 190 */
scheme_rt_cont_mark, /* 191 */
scheme_rt_saved_stack, /* 192 */
scheme_rt_reply_item, /* 193 */
scheme_rt_closure_info, /* 194 */
scheme_rt_overflow, /* 195 */
scheme_rt_overflow_jmp, /* 196 */
scheme_rt_meta_cont, /* 197 */
scheme_rt_dyn_wind_cell, /* 198 */
scheme_rt_dyn_wind_info, /* 199 */
scheme_rt_dyn_wind, /* 200 */
scheme_rt_dup_check, /* 201 */
scheme_rt_thread_memory, /* 202 */
scheme_rt_input_file, /* 203 */
scheme_rt_input_fd, /* 204 */
scheme_rt_oskit_console_input, /* 205 */
scheme_rt_tested_input_file, /* 206 */
scheme_rt_tested_output_file, /* 207 */
scheme_rt_indexed_string, /* 208 */
scheme_rt_output_file, /* 209 */
scheme_rt_load_handler_data, /* 210 */
scheme_rt_pipe, /* 211 */
scheme_rt_beos_process, /* 212 */
scheme_rt_system_child, /* 213 */
scheme_rt_tcp, /* 214 */
scheme_rt_write_data, /* 215 */
scheme_rt_tcp_select_info, /* 216 */
scheme_rt_param_data, /* 217 */
scheme_rt_will, /* 218 */
scheme_rt_linker_name, /* 219 */
scheme_rt_param_map, /* 220 */
scheme_rt_finalization, /* 221 */
scheme_rt_finalizations, /* 222 */
scheme_rt_cpp_object, /* 223 */
scheme_rt_cpp_array_object, /* 224 */
scheme_rt_stack_object, /* 225 */
scheme_rt_preallocated_object, /* 226 */
scheme_thread_hop_type, /* 227 */
scheme_rt_srcloc, /* 228 */
scheme_rt_evt, /* 229 */
scheme_rt_syncing, /* 230 */
scheme_rt_comp_prefix, /* 231 */
scheme_rt_user_input, /* 232 */
scheme_rt_user_output, /* 233 */
scheme_rt_compact_port, /* 234 */
scheme_rt_read_special_dw, /* 235 */
scheme_rt_regwork, /* 236 */
scheme_rt_rx_lazy_string, /* 237 */
scheme_rt_buf_holder, /* 238 */
scheme_rt_parameterization, /* 239 */
scheme_rt_print_params, /* 240 */
scheme_rt_read_params, /* 241 */
scheme_rt_native_code, /* 242 */
scheme_rt_native_code_plus_case, /* 243 */
scheme_rt_jitter_data, /* 244 */
scheme_rt_module_exports, /* 245 */
scheme_rt_delay_load_info, /* 246 */
scheme_rt_marshal_info, /* 247 */
scheme_rt_unmarshal_info, /* 248 */
scheme_rt_runstack, /* 249 */
scheme_rt_sfs_info, /* 250 */
scheme_rt_validate_clearing, /* 251 */
scheme_rt_avl_node, /* 252 */
scheme_rt_lightweight_cont, /* 253 */
scheme_rt_export_info, /* 254 */
scheme_rt_cont_jmp, /* 255 */
#endif
_scheme_last_type_

1
src/racket/src/type.c
View File

@ -710,6 +710,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_noninline_proc_type, small_object);
GC_REG_TRAV(scheme_prune_context_type, small_object);
GC_REG_TRAV(scheme_proc_shape_type, small_object);
GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj);
}

46
src/racket/src/validate.c
View File

@ -122,6 +122,19 @@ static void noclear_stack_push(struct Validate_Clearing *vc, int pos)
vc->ncstackpos += 1;
}
static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int field_count)
{
if (!*_st_ht) {
Scheme_Hash_Table *ht;
ht = scheme_make_hash_table_eqv();
*_st_ht = ht;
}
scheme_hash_set(*_st_ht,
scheme_make_integer(pos),
scheme_make_integer(field_count));
}
void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
int depth,
int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map,
@ -155,9 +168,14 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
for (i = 0; i < num_toplevels; i++) {
if (SAME_TYPE(SCHEME_TYPE(toplevels[i]), scheme_module_variable_type)) {
int mv_flags = SCHEME_MODVAR_FLAGS(toplevels[i]);
if (mv_flags & SCHEME_MODVAR_CONST)
if (mv_flags & SCHEME_MODVAR_CONST) {
intptr_t k;
tl_state[i] = SCHEME_TOPLEVEL_CONST;
else if (mv_flags & SCHEME_MODVAR_FIXED)
if (scheme_decode_struct_shape(((Module_Variable *)toplevels[i])->shape, &k)) {
if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT)
add_struct_mapping(&st_ht, i, k >> STRUCT_PROC_SHAPE_SHIFT);
}
} else if (mv_flags & SCHEME_MODVAR_FIXED)
tl_state[i] = SCHEME_TOPLEVEL_FIXED;
else
tl_state[i] = SCHEME_TOPLEVEL_READY;
@ -258,7 +276,8 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
Scheme_Hash_Tree *procs,
Scheme_Hash_Table **_st_ht)
{
int i, size, flags, result, is_struct, field_count, field_icount, uses_super;
int i, size, flags, result, is_struct;
Simple_Stuct_Type_Info stinfo;
Scheme_Object *val, *only_var;
val = SCHEME_VEC_ELS(data)[0];
@ -361,8 +380,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
}
if (scheme_is_simple_make_struct_type(val, size-1, 1, 1, NULL,
&field_count, &field_icount,
&uses_super,
&stinfo,
NULL, (_st_ht ? *_st_ht : NULL),
NULL, 0, NULL, NULL, 5)) {
/* This set of bindings is constant across invocations, but
@ -371,30 +389,22 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
is_struct = 1;
} else {
is_struct = 0;
uses_super = 0;
field_count = 0;
field_icount = 0;
}
result = validate_expr(port, val, stack, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp + (uses_super ? 1 : 0),
tl_state, tl_timestamp + (stinfo.uses_super ? 1 : 0),
NULL, !!only_var, 0, vc, 0, 0, NULL,
size-1, NULL);
if (is_struct) {
if (_st_ht && (field_count == field_icount)) {
if (_st_ht && (stinfo.field_count == stinfo.init_field_count)) {
/* record `struct:' binding as constant across invocations,
so that it can be recognized for sub-struct declarations */
if (!*_st_ht) {
Scheme_Hash_Table *ht;
ht = scheme_make_hash_table_eqv();
*_st_ht = ht;
}
scheme_hash_set(*_st_ht,
scheme_make_integer(SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[1])),
scheme_make_integer(field_count));
add_struct_mapping(_st_ht,
SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[1]),
stinfo.field_count);
}
/* In any case, treat the bindings as constant */
result = 2;