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

Merge branch 'master' into http-connect-proxy

Browse Source
This commit is contained in:
Tim Brown 2016-08-10 17:00:11 +01:00
commit 29997da340
19 changed files with 930 additions and 255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-doc/scribblings/raco/zo-struct.scrbl
View File

@ -142,6 +142,9 @@ returns.}
@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-type-property-shape struct-shape) ([has-guard? boolean?])]
@defstruct+[(property-predicate-shape struct-shape) ()]
@defstruct+[(property-accessor-shape struct-shape) ()]
@defstruct+[(struct-other-shape struct-shape) ()]
)]{

23
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -1642,6 +1642,29 @@
(m (check) (check2)))
;; ----------------------------------------
;; Check that `syntax-local-lift-values-expression` works rigth when lifts
;; are converted to `let`; in particular, make sure the order is
;; right
(module uses-local-lift-values-at-expansion-time racket/base
(require (for-syntax racket/base))
(begin-for-syntax
(require (for-syntax racket/base))
(define-syntax (m stx)
#`(values #,@(syntax-local-lift-values-expression 3 #'(values 1 2 3)))))
(define-syntax (n stx)
(define-values (a b c) (m))
#`(list #,a #,b #,c))
(provide l)
(define l (n)))
(test '(1 2 3) dynamic-require ''uses-local-lift-values-at-expansion-time 'l)
;; ----------------------------------------
(report-errs)

91
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -4128,6 +4128,97 @@
(a? (a-x (a 1 2)))
5)))
(test-comp '(lambda ()
(make-struct-type 'a #f 0 0 #f)
10)
'(lambda ()
10))
(test-comp '(lambda ()
(make-struct-type-property 'a)
10)
'(lambda ()
10))
(test-comp '(module m racket/base
(define-values (prop:a a? a-ref) (make-struct-type-property 'a))
(lambda (x)
(a? x)
(if a? (if a-ref x 11) 10)))
'(module m racket/base
(define-values (prop:a a? a-ref) (make-struct-type-property 'a))
(lambda (x)
x)))
(test-comp '(module m racket/base
(define (f x) (list (g x) g))
;; Defining and using a property doesn't interrupt a sequence
;; of simultaneous definitions, so `g` above can be inlined
(define-values (prop:a a? a-ref) (make-struct-type-property 'a))
(struct b () #:property prop:a 'a)
(define (g y) (list y)))
'(module m racket/base
(define (f x) (list (list x) g))
(define-values (prop:a a? a-ref) (make-struct-type-property 'a))
(struct b () #:property prop:a 'a)
(define (g y) (list y))))
(test-comp '(module m racket/base
(define (f x) (list (g x) g))
;; A property type with a guard inhibits inlining, because the
;; guard might raise an error
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error))
(struct b () #:property prop:a 'a)
(define (g y) (list y)))
'(module m racket/base
(define (f x) (list (list x) g))
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error))
(struct b () #:property prop:a 'a)
(define (g y) (list y)))
#f)
(module struct-type-property-a racket/base
(provide prop:a)
(define-values (prop:a a? a-ref) (make-struct-type-property 'a)))
(test-comp '(module m racket/base
(require 'struct-type-property-a)
(define (f x) (list (g x) g))
(struct b () #:property prop:a 'a)
(define (g y) (list y)))
'(module m racket/base
(require 'struct-type-property-a)
(define (f x) (list (list x) g))
(struct b () #:property prop:a 'a)
(define (g y) (list y))))
(module struct-type-property-a-with-guard racket/base
(provide prop:a)
(define-values (prop:a a? a-ref) (make-struct-type-property 'a error)))
(test-comp '(module m racket/base
(require 'struct-type-property-a-with-guard)
(define (f x) (list (g x) g))
(struct b () #:property prop:a 'a)
(define (g y) (list y)))
'(module m racket/base
(require 'struct-type-property-a-with-guard)
(define (f x) (list (list x) g))
(struct b () #:property prop:a 'a)
(define (g y) (list y)))
#f)
;; A function with a required optional argument creates a pattern like
;; the ones above, but intermediate points include extra references
;; that make it difficult to check with `test-comp`
#;
(test-comp '(module m racket/base
(define (f x) (list (g #:x x)))
(define (g #:x y) (list y)))
'(module m racket/base
(define (f x) (list (list x)))
(define (g #:x y) (list y))))
(test-comp `(lambda (b)
(let ([v (unbox b)])
(with-continuation-mark 'x 'y (unbox v))))

42
pkgs/racket-test/tests/racket/contract/contract-out.rkt
View File

@ -3,7 +3,7 @@
(for-syntax racket/base))
(parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/contract)])
(make-basic-contract-namespace 'racket/contract 'racket/list)])
(define exn:fail:contract:blame-object
(contract-eval 'exn:fail:contract:blame-object))
@ -1457,5 +1457,45 @@
(λ (x)
(and (exn:fail:contract:blame? x)
(regexp-match? #rx"blaming: bad1-client" (exn-message x)))))
(contract-eval
'(define (find-p/c-prop stx)
(define the-props
(flatten
(let loop ([stx stx])
(cond
[(syntax? stx)
(cons (syntax-property stx 'provide/contract-original-contract)
(loop (syntax-e stx)))]
[(pair? stx)
(cons (loop (car stx)) (loop (cdr stx)))]
[else '()]))))
(remove-duplicates
(for/list ([e (in-list the-props)]
#:when e)
(syntax->datum (vector-ref e 1))))))
(test/spec-passed/result
'provide/contract.prop1
'(let ()
(find-p/c-prop
(expand
'(module test racket
(provide/contract
[x (>/c 5)])
(define x 6)))))
(list '(>/c 5)))
(test/spec-passed/result
'provide/contract.prop2
'(let ()
(find-p/c-prop
(expand
'(module test racket
(provide
(contract-out
[x (>/c 5)]))
(define x 6)))))
(list '(>/c 5)))
)

12
pkgs/zo-lib/compiler/zo-marshal.rkt
View File

@ -627,7 +627,8 @@
[(? (lambda (s) (and (scope? s) (eq? (scope-name s) 'root))))
(out-byte CPT_ROOT_SCOPE out)]
[(struct module-variable (modidx sym pos phase constantness))
(define (to-sym n) (string->symbol (format "struct~a" n)))
(define (to-sym #:prefix [prefix "struct"] n)
(string->symbol (format "~a~a" prefix n)))
(out-byte CPT_MODULE_VAR out)
(out-anything modidx out)
(out-anything sym out)
@ -664,6 +665,15 @@
[(mutator-shape? constantness)
(to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness)
4)))]
[(struct-type-property-shape? constantness)
(to-sym #:prefix "prop"
(if (struct-type-property-shape-has-guard? constantness)
1
0))]
[(property-predicate-shape? constantness)
(to-sym #:prefix "prop" 2)]
[(property-accessor-shape? constantness)
(to-sym #:prefix "prop" 3)]
[(struct-other-shape? constantness)
(to-sym 5)]
[else #f])

9
pkgs/zo-lib/compiler/zo-parse.rkt
View File

@ -780,7 +780,7 @@
(cond
[shape
(cond
[(number? shape)
[(number? shape)
(define n (arithmetic-shift shape -1))
(make-function-shape (if (negative? n)
(make-arity-at-least (sub1 (- n)))
@ -796,6 +796,13 @@
[(3) (make-accessor-shape (arithmetic-shift n -3))]
[(4) (make-mutator-shape (arithmetic-shift n -3))]
[else (make-struct-other-shape)])]
[(and (symbol? shape)
(regexp-match? #rx"^prop" (symbol->string shape)))
(define n (string->number (substring (symbol->string shape) 4)))
(case n
[(0 1) (make-struct-type-property-shape (= n 1))]
[(3) (make-property-predicate-shape)]
[else (make-property-accessor-shape)])]
[else
;; parse symbol as ":"-separated sequence of arities
(make-function-shape

3
pkgs/zo-lib/compiler/zo-structs.rkt
View File

@ -46,6 +46,9 @@
(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-type-property-shape struct-shape) ([has-guard? boolean?]))
(define-form-struct (property-predicate-shape struct-shape) ())
(define-form-struct (property-accessor-shape struct-shape) ())
(define-form-struct (struct-other-shape struct-shape) ())
;; In toplevels of resove prefix:

4
racket/collects/racket/contract/private/out.rkt
View File

@ -38,7 +38,9 @@
(let loop ([stx (true-provide/contract #'orig-stx #f 'contract-out)])
(syntax-case stx (begin provide)
[(begin args ...)
#`(begin #,@(map loop (syntax->list #'(args ...))))]
(syntax-property #`(begin #,@(map loop (syntax->list #'(args ...))))
'provide/contract-original-contract
(syntax-property stx 'provide/contract-original-contract))]
[(provide clause ...)
(identifier? #'x)
(begin (set! provide-clauses (append (syntax->list #'(clause ...))

118
racket/collects/racket/private/kw.rkt
View File

@ -142,31 +142,6 @@
(define-values (prop:named-keyword-procedure named-keyword-procedure? keyword-procedure-name+fail)
(make-struct-type-property 'named-keyword-procedure))
;; Constructor generator for a procedure with a required keyword.
;; (This is used with lift-expression, so that the same constructor
;; is used for each evaluation of a keyword lambda.)
;; The `procedure' property is a per-type method that has exactly
;; the right arity, and that sends all arguments to `missing-kw'.
(define (make-required name fail-proc method? impersonator?)
(let-values ([(s: mk ? -ref -set!)
(make-struct-type (or name 'unknown)
(if impersonator?
(if method?
struct:keyword-method-impersonator
struct:keyword-procedure-impersonator)
(if method?
struct:keyword-method
struct:keyword-procedure))
0 0 #f
(list (cons prop:arity-string
generate-arity-string)
(cons prop:named-keyword-procedure
(cons name fail-proc))
(cons prop:incomplete-arity
#t))
(current-inspector) fail-proc)])
mk))
;; Allows support for new-prop:procedure to extract a field (i.e., this property
;; makes it possible to extract a field for an integer `new-prop:procedure` value):
(define-values (prop:procedure-accessor procedure-accessor? procedure-accessor-ref)
@ -187,8 +162,9 @@
;; value is an integer:
(cons prop:procedure-accessor values))))
;; ----------------------------------------
;; Proxies
(define-values (struct:keyword-procedure-impersonator make-kpp keyword-procedure-impersonator? kpp-ref kpp-set!)
(make-struct-type 'procedure
struct:keyword-procedure
@ -210,6 +186,74 @@
1 0 #f
(list (cons prop:keyword-impersonator (lambda (v) (okmp-ref v 0))))))
;; ----------------------------------------
;; Functions and proxies with required keyword arguments
(define-values (struct:keyword-procedure/arity-error make-kp/ae kp/ae? kp/ae-ref kp/ae-set!)
(make-struct-type 'procedure
struct:keyword-procedure
0 0 #f
(list (cons prop:arity-string generate-arity-string)
(cons prop:incomplete-arity #t))))
(define-values (struct:keyword-method/arity-error make-km/ae km/ae? km/ae-ref km/ae-set!)
(make-struct-type 'procedure
struct:keyword-method
0 0 #f
(list (cons prop:arity-string generate-arity-string)
(cons prop:incomplete-arity #t))))
(define-values (struct:keyword-procedure-impersonator/arity-error make-kpi/ae kpi/ae? kpi/ae-ref kpi/ae-set!)
(make-struct-type 'procedure
struct:keyword-procedure-impersonator
0 0 #f
(list (cons prop:arity-string generate-arity-string)
(cons prop:incomplete-arity #t))))
(define-values (struct:keyword-method-impersonator/arity-error make-kmi/ae kmi/ae? kmi/ae-ref kmi/ae-set!)
(make-struct-type 'procedure
struct:keyword-method-impersonator
0 0 #f
(list (cons prop:arity-string generate-arity-string)
(cons prop:incomplete-arity #t))))
;; Constructor generator for a wrapper on a procedure with a required keyword.
;; The `procedure' property is a per-type method that has exactly
;; the right arity, and that sends all arguments to `missing-kw'.
(define (make-required name fail-proc method? impersonator?)
(let-values ([(s: mk ? -ref -set!)
(make-struct-type (or name 'unknown)
(if impersonator?
(if method?
struct:keyword-method-impersonator/arity-error
struct:keyword-procedure-impersonator/arity-error)
(if method?
struct:keyword-method/arity-error
struct:keyword-procedure/arity-error))
0 0 #f
(list (cons prop:named-keyword-procedure
(cons name fail-proc)))
(current-inspector)
fail-proc)])
mk))
;; Macro variant of `make-required`, used for lambda form with a required
;; keyword. We use a macro so that the `make-struct-type` is visible
;; to the optimizer, which in turn allows it to determine that the first
;; result is a constructor that always succeeds.
;; >> Beware that `name` and `fail-proc` are duplicated in the macro expansion. <<
;; The `name` expresison is expected to be a quoted symbol, and `fail-proc` is
;; expected to be a small procedure, so that duplication is ok.
;; (This macro is used with lift-values-expression, so that the same constructor
;; is used for each evaluation of a keyword lambda.)
(define-syntax (make-required* stx)
(syntax-case stx ()
[(_ struct:km/ae name fail-proc)
#'(make-struct-type name
struct:km/ae
0 0 #f
(list (cons prop:named-keyword-procedure
(cons name fail-proc)))
(current-inspector)
fail-proc)]))
;; ----------------------------------------
(define make-keyword-procedure
@ -467,7 +511,9 @@
[make-okp (if method?
#'make-optional-keyword-method
#'make-optional-keyword-procedure)]
[method? method?]
[struct:kp/ae (if method?
#'struct:keyword-method/arity-error
#'struct:keyword-procedure/arity-error)]
[with-kw-min-args (+ 2 (length plain-ids))]
[with-kw-max-arg (if (null? (syntax-e #'rest))
(+ 2 (length plain-ids) (length opts))
@ -609,11 +655,13 @@
[needed-kws needed-kws]
[no-kws (mk-no-kws #t)]
[with-kws (mk-with-kws)]
[mk-id (with-syntax ([n (or local-name
(syntax-local-infer-name stx))]
[call-fail (mk-kw-arity-stub)])
(syntax-local-lift-expression
#'(make-required 'n call-fail method? #f)))])
[(_ mk-id . _) (with-syntax ([n (or local-name
(syntax-local-infer-name stx)
'unknown)]
[call-fail (mk-kw-arity-stub)])
(syntax-local-lift-values-expression
5
#'(make-required* struct:kp/ae 'n call-fail)))])
(quasisyntax/loc stx
(mk-id
(lambda (given-kws given-argc)
@ -1323,9 +1371,9 @@
(format "\n ~a ~e" kw kw-arg))
kws kw-args))))]
[proc-name (lambda (p) (or (and (named-keyword-procedure? p)
(car (keyword-procedure-name+fail p)))
(object-name p)
p))])
(car (keyword-procedure-name+fail p)))
(object-name p)
p))])
(raise
(exn:fail:contract
(if extra-kw

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

@ -978,7 +978,7 @@ void scheme_set_compilation_variables(Scheme_Comp_Env *frame, Scheme_IR_Local **
for (i = 0; i < count; i++) {
MZ_ASSERT(!frame->vars[i+pos]);
frame->vars[i+pos] = vars[i];
frame->vars[i+pos] = vars[count - i - 1];
}
}
@ -1144,6 +1144,13 @@ Scheme_Object *scheme_intern_struct_proc_shape(int shape)
return scheme_intern_symbol(buf);
}
Scheme_Object *scheme_intern_struct_prop_proc_shape(int shape)
{
char buf[20];
sprintf(buf, "prop%d", shape);
return scheme_intern_symbol(buf);
}
void scheme_dump_env(Scheme_Comp_Env *env)
{
Scheme_Comp_Env *frame;
@ -1588,6 +1595,11 @@ scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
*_inline_variant = mod_constant;
is_constant = 2;
shape = scheme_intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant));
} else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_prop_proc_shape_type)) {
if (_inline_variant)
*_inline_variant = mod_constant;
is_constant = 2;
shape = scheme_intern_struct_prop_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant));
} else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) {
if (_inline_variant) {
/* In case the inline variant includes references to module

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

@ -2031,11 +2031,17 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
if (dm_env)
is_st = 0;
else if (scheme_is_simple_make_struct_type(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED,
NULL, NULL, NULL, NULL,
NULL, NULL, MZ_RUNSTACK, 0,
NULL, NULL, NULL, 5))
is_st = 1;
else if (scheme_is_simple_make_struct_type_property(vals_expr, g, CHECK_STRUCT_TYPE_RESOLVED,
NULL, NULL, NULL, NULL, MZ_RUNSTACK, 0,
NULL, NULL, 5))
is_st = 1;
else
is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 0, 1,
NULL, NULL, NULL, NULL,
NULL, NULL, MZ_RUNSTACK, 0,
NULL, NULL, NULL, 5);
is_st = 0;
for (i = 0; i < g; i++) {
var = SCHEME_VEC_ELS(vec)[i+delta];

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

@ -2568,11 +2568,16 @@ Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Obje
Scheme_Object *p;
if (expected
&& SCHEME_SYMBOLP(expected)
&& SCHEME_SYM_VAL(expected)[0] == 's') {
return (scheme_check_structure_shape(e, expected)
? expected
: NULL);
&& SCHEME_SYMBOLP(expected)) {
if (SCHEME_SYM_VAL(expected)[0] == 's') {
return (scheme_check_structure_shape(e, expected)
? expected
: NULL);
} else if (SCHEME_SYM_VAL(expected)[0] == 'p') {
return (scheme_check_structure_property_shape(e, expected)
? expected
: NULL);
}
}
if (SAME_TYPE(SCHEME_TYPE(e), scheme_inline_variant_type))

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

@ -4558,7 +4558,7 @@ static void setup_accessible_table(Scheme_Module *m)
for (i = 0; i < cnt; i++) {
form = SCHEME_VEC_ELS(m->bodies[0])[i];
if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) {
int checked_st = 0;
int checked_st = 0, is_st_prop = 0, has_guard = 0;
Scheme_Object *is_st = NULL;
Simple_Stuct_Type_Info stinfo;
Scheme_Object *parent_identity;
@ -4597,14 +4597,24 @@ static void setup_accessible_table(Scheme_Module *m)
if (!checked_st) {
if (scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0],
SCHEME_VEC_SIZE(form)-1,
1, 0, 1, NULL, &stinfo, &parent_identity,
CHECK_STRUCT_TYPE_RESOLVED,
NULL, &stinfo, &parent_identity,
NULL, NULL, NULL, NULL, 0,
m->prefix->toplevels, ht,
&is_st,
5)) {
is_st = scheme_make_pair(is_st, parent_identity);
} else
} else {
is_st = NULL;
if (scheme_is_simple_make_struct_type_property(SCHEME_VEC_ELS(form)[0],
SCHEME_VEC_SIZE(form)-1,
CHECK_STRUCT_TYPE_RESOLVED,
&has_guard,
NULL, NULL, NULL, NULL, 0,
m->prefix->toplevels, ht,
5))
is_st_prop = 1;
}
checked_st = 1;
}
if (is_st) {
@ -4614,6 +4624,14 @@ static void setup_accessible_table(Scheme_Module *m)
v = scheme_make_vector(3, v);
SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape);
SCHEME_VEC_ELS(v)[2] = is_st;
} else if (is_st_prop) {
intptr_t shape;
shape = scheme_get_struct_property_proc_shape(k-1, has_guard);
/* Vector of size 4 => struct property shape */
v = scheme_make_vector(4, v);
SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape);
SCHEME_VEC_ELS(v)[2] = scheme_false;
SCHEME_VEC_ELS(v)[3] = scheme_false;
}
}
scheme_hash_set(ht, tl, v);
@ -4843,7 +4861,7 @@ static Scheme_Object *check_accessible_in_module(Scheme_Module *module, intptr_t
if (SCHEME_VEC_SIZE(pos) == 2) {
if (_is_constant)
get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant);
} else {
} else if (SCHEME_VEC_SIZE(pos) == 3) {
/* vector of size 3 => struct proc */
if (_is_constant) {
Scheme_Object *ps;
@ -4851,6 +4869,16 @@ static Scheme_Object *check_accessible_in_module(Scheme_Module *module, intptr_t
ps = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1]),
SCHEME_VEC_ELS(pos)[2]);
*_is_constant = ps;
}
} else {
MZ_ASSERT(SCHEME_VEC_SIZE(pos) == 4);
/* vector of size 4 => struct property proc */
if (_is_constant) {
Scheme_Object *ps;
ps = scheme_make_struct_property_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1]));
*_is_constant = ps;
}
}

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

@ -349,7 +349,7 @@ int scheme_is_functional_nonfailing_primitive(Scheme_Object *rator, int num_args
return 0;
}
static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info)
static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info, int prop_ok)
/* Determines whether `rator` is known to be a struct accessor, etc. */
{
Scheme_Object *c;
@ -364,7 +364,8 @@ static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info
c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
if (!c && info->cp->inline_variants)
c = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos));
if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type)) {
if (c && (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type)
|| (prop_ok && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)))) {
return c;
}
}
@ -378,13 +379,19 @@ int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Inf
Scheme_Object *c;
if ((vals == 1) || (vals == -1)) {
c = get_struct_proc_shape(rator, info);
c = get_struct_proc_shape(rator, info, 1);
if (c) {
int mode = (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK);
int field_count = (SCHEME_PROC_SHAPE_MODE(c) >> STRUCT_PROC_SHAPE_SHIFT);
if (((num_args == 1) && (mode == STRUCT_PROC_SHAPE_PRED))
|| ((num_args == field_count) && (mode == STRUCT_PROC_SHAPE_CONSTR))) {
return 1;
if (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type)) {
int mode = (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK);
int field_count = (SCHEME_PROC_SHAPE_MODE(c) >> STRUCT_PROC_SHAPE_SHIFT);
if (((num_args == 1) && (mode == STRUCT_PROC_SHAPE_PRED))
|| ((num_args == field_count) && (mode == STRUCT_PROC_SHAPE_CONSTR))) {
return 1;
}
} else if (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)) {
if ((SCHEME_PROP_PROC_SHAPE_MODE(c) == STRUCT_PROP_PROC_SHAPE_PRED)
&& (num_args == 1))
return 1;
}
}
}
@ -553,8 +560,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
note_match(app->num_args, vals, warn_info);
}
}
return 0;
if (!SAME_OBJ(scheme_make_struct_type_proc, app->args[0]))
return 0;
}
if (vtype == scheme_application2_type) {
@ -579,7 +587,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
note_match(1, vals, warn_info);
}
}
return 0;
if (!SAME_OBJ(scheme_make_struct_type_property_proc, app->rator))
return 0;
}
if (vtype == scheme_application3_type) {
@ -604,7 +614,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
note_match(2, vals, warn_info);
}
}
return 0;
if (!SAME_OBJ(scheme_make_struct_type_property_proc, app->rator))
return 0;
}
/* check for (set! x x) */
@ -620,10 +632,14 @@ 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, 1, 0, &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 ? opt_info->top_level_consts : NULL),
((opt_info && opt_info->cp) ? opt_info->cp->inline_variants : NULL),
@ -635,6 +651,19 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
}
}
/* check for struct-type property declaration: */
if (!(flags & OMITTABLE_IGNORE_MAKE_STRUCT_TYPE)) {
if (scheme_is_simple_make_struct_type_property(o, vals,
(((flags & OMITTABLE_RESOLVED) ? CHECK_STRUCT_TYPE_RESOLVED : 0)
| CHECK_STRUCT_TYPE_ALWAYS_SUCCEED),
NULL,
(opt_info ? opt_info->top_level_consts : NULL),
((opt_info && opt_info->cp) ? opt_info->cp->inline_variants : NULL),
NULL, NULL, 0, NULL, NULL,
5))
return 1;
}
return 0;
}
@ -964,7 +993,7 @@ static int is_proc_spec_proc(Scheme_Object *p, int init_field_count)
vtype = SCHEME_TYPE(p);
if (vtype == scheme_lambda_type) {
if ((vtype == scheme_lambda_type) || (vtype == scheme_ir_lambda_type)) {
if (((Scheme_Lambda *)p)->num_params >= 1)
return 1;
}
@ -1127,34 +1156,36 @@ static Scheme_Object *skip_clears(Scheme_Object *body)
return body;
}
static int is_constant_super(Scheme_Object *arg,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
Scheme_Object **_parent_identity)
/* Does `arg` produce another structure type (which can serve as a supertype)? */
typedef int (*Ok_Value_Callback)(void *data, Scheme_Object *v, int mode);
#define OK_CONSTANT_SHAPE 1
#define OK_CONSTANT_ENCODED_SHAPE 2
#define OK_CONSTANT_VALIDATE_SHAPE 3
#define OK_CONSTANT_VARIANT 4
#define OK_CONSTANT_VALUE 5
static int is_ok_value(Ok_Value_Callback ok_value, void *data,
Scheme_Object *arg,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table)
/* Does `arg` produce a value that satisfies `ok_value`? */
{
int pos;
Scheme_Object *v;
if (SAME_TYPE(SCHEME_TYPE(arg), scheme_ir_toplevel_type)) {
pos = SCHEME_TOPLEVEL_POS(arg);
if (top_level_consts) {
if (top_level_consts || inline_variants) {
/* This is optimize mode */
v = scheme_hash_get(top_level_consts, scheme_make_integer(pos));
v = NULL;
if (top_level_consts)
v = scheme_hash_get(top_level_consts, scheme_make_integer(pos));
if (!v && inline_variants)
v = scheme_hash_get(inline_variants, scheme_make_integer(pos));
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 (mode == STRUCT_PROC_SHAPE_STRUCT) {
if (_parent_identity)
*_parent_identity = SCHEME_PROC_SHAPE_IDENTITY(v);
return field_count + 1;
}
}
if (v)
return ok_value(data, v, OK_CONSTANT_SHAPE);
}
} else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type)) {
pos = SCHEME_TOPLEVEL_POS(arg);
@ -1165,14 +1196,8 @@ static int is_constant_super(Scheme_Object *arg,
Scheme_Prefix *toplevels;
toplevels = (Scheme_Prefix *)runstack[SCHEME_TOPLEVEL_DEPTH(arg) - rs_delta];
b = (Scheme_Bucket *)toplevels->a[pos];
if (b->val) {
if (SCHEME_STRUCT_TYPEP(b->val)
&& (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) {
Scheme_Struct_Type *st = (Scheme_Struct_Type *)b->val;
if (st->num_slots == st->num_islots)
return st->num_slots + 1;
}
}
if (b->val && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT))
return ok_value(data, b->val, OK_CONSTANT_VALUE);
}
if (symbols) {
/* This is module-export mode; conceptually, this code belongs in
@ -1181,23 +1206,11 @@ 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_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) {
if (_parent_identity)
*_parent_identity = SCHEME_VEC_ELS(v)[2];
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;
}
}
if (v)
return ok_value(data, v, OK_CONSTANT_VARIANT);
} 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 (((Module_Variable *)name)->shape)
return ok_value(data, ((Module_Variable *)name)->shape, OK_CONSTANT_ENCODED_SHAPE);
}
}
if (top_level_table) {
@ -1205,9 +1218,7 @@ static int is_constant_super(Scheme_Object *arg,
define_values_validate() */
v = scheme_hash_get(top_level_table, scheme_make_integer(pos));
if (v) {
int k = SCHEME_INT_VAL(v);
if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT)
return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1;
return ok_value(data, v, OK_CONSTANT_VALIDATE_SHAPE);
}
}
}
@ -1215,8 +1226,181 @@ static int is_constant_super(Scheme_Object *arg,
return 0;
}
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved,
int must_always_succeed, int check_auto,
static int ok_constant_super_value(void *data, Scheme_Object *v, int mode)
/* Is `v` a structure type (which can serve as a supertype)? */
{
Scheme_Object **_parent_identity = (Scheme_Object **)data;
if (mode == OK_CONSTANT_SHAPE) {
if (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 (mode == STRUCT_PROC_SHAPE_STRUCT) {
if (_parent_identity)
*_parent_identity = SCHEME_PROC_SHAPE_IDENTITY(v);
return field_count + 1;
}
}
} else if (mode == OK_CONSTANT_ENCODED_SHAPE) {
intptr_t k;
if (scheme_decode_struct_shape(v, &k)) {
if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT)
return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1;
}
} else if (mode == OK_CONSTANT_VALIDATE_SHAPE) {
int k = SCHEME_INT_VAL(v);
if ((k >= 0)
&& (k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT)
return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1;
} else if (mode == OK_CONSTANT_VARIANT) {
if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) {
if (_parent_identity)
*_parent_identity = SCHEME_VEC_ELS(v)[2];
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 (mode == OK_CONSTANT_VALUE) {
if (SCHEME_STRUCT_TYPEP(v)) {
Scheme_Struct_Type *st = (Scheme_Struct_Type *)v;
if (st->num_slots == st->num_islots)
return st->num_slots + 1;
}
}
return 0;
}
static int is_constant_super(Scheme_Object *arg,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
Scheme_Object **_parent_identity)
/* Does `arg` produce another structure type (which can serve as a supertype)? */
{
return is_ok_value(ok_constant_super_value, _parent_identity,
arg,
top_level_consts,
inline_variants, top_level_table,
runstack, rs_delta,
symbols, symbol_table);
}
static int ok_constant_property_with_guard(void *data, Scheme_Object *v, int mode)
{
intptr_t k = 0;
if (mode == OK_CONSTANT_SHAPE) {
if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_prop_proc_shape_type)) {
k = SCHEME_PROC_SHAPE_MODE(v);
}
} else if (mode == OK_CONSTANT_ENCODED_SHAPE) {
if (!scheme_decode_struct_prop_shape(v, &k))
k = 0;
} else if (mode == OK_CONSTANT_VALIDATE_SHAPE) {
int k = SCHEME_INT_VAL(v);
if (k < 0)
k = -(k+1);
else
k = 0;
} else if (mode == OK_CONSTANT_VARIANT) {
if (SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 4)) {
v = SCHEME_VEC_ELS(v)[1];
if (v && SCHEME_INTP(v))
k = SCHEME_INT_VAL(v);
}
} else if (mode == OK_CONSTANT_VALUE) {
if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_property_type)) {
if (!((Scheme_Struct_Property *)v)->guard)
return 1;
}
}
return (k == STRUCT_PROP_PROC_SHAPE_PROP);
}
static int is_struct_type_property_without_guard(Scheme_Object *arg,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table)
/* 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,
arg,
top_level_consts,
inline_variants, top_level_table,
runstack, rs_delta,
symbols, symbol_table);
}
static int is_simple_property_list(Scheme_Object *a, int resolved,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table)
/* Does `a` produce a property list that always lets `make-struct-type` succeed? */
{
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;
count = ((Scheme_App_Rec *)a)->num_args;
} else if (SAME_TYPE(SCHEME_TYPE(a), scheme_application2_type)) {
if (!SAME_OBJ(((Scheme_App2_Rec *)a)->rator, scheme_list_proc))
return 0;
count = 1;
} else if (SAME_TYPE(SCHEME_TYPE(a), scheme_application3_type)) {
if (!SAME_OBJ(((Scheme_App3_Rec *)a)->rator, scheme_list_proc))
return 0;
count = 2;
} else
return 0;
for (i = 0; i < count; i++) {
if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type))
arg = ((Scheme_App_Rec *)a)->args[i+1];
else if (SAME_TYPE(SCHEME_TYPE(a), scheme_application2_type))
arg = ((Scheme_App2_Rec *)a)->rand;
else {
if (i == 0)
arg = ((Scheme_App3_Rec *)a)->rand1;
else
arg = ((Scheme_App3_Rec *)a)->rand2;
}
if (SAME_TYPE(SCHEME_TYPE(arg), scheme_application3_type)) {
Scheme_App3_Rec *a3 = (Scheme_App3_Rec *)arg;
if (!SAME_OBJ(a3->rator, scheme_cons_proc))
return 0;
if (is_struct_type_property_without_guard(a3->rand1,
top_level_consts,
inline_variants, top_level_table,
runstack, rs_delta,
symbols, symbol_table)) {
if (!scheme_omittable_expr(a3->rand2, 1, 3, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL))
return 0;
} else
return 0;
} else
return 0;
}
return 1;
}
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int flags,
GC_CAN_IGNORE int *_auto_e_depth,
Simple_Stuct_Type_Info *_stinfo,
Scheme_Object **_parent_identity,
@ -1227,13 +1411,18 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
Scheme_Object **_name,
int fuel)
/* Checks whether it's a `make-struct-type' call --- that, if `must_always_succeed` is
true, certainly succeeds (i.e., no exception) --- pending a check of the auto-value
argument if !check_auto. The resulting constructor must always succeed (i.e., no
guards). The result is the auto-value argument or scheme_true if it's simple, NULL if not.
/* Checks whether it's a `make-struct-type' call --- that, if `flags` includes
`CHECK_STRUCT_TYPE_ALWAYS_SUCCEED`, certainly succeeds (i.e., no exception) ---
pending a check of the auto-value argument if `flags` includes `CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK`.
The expression itself must have no side-effects except for errors (but the possibility
of errors means that the expression is not necessarily omittable).
The resulting *constructor* must always succeed (i.e., no guards).
The result is the auto-value argument or scheme_true if it's simple, NULL if not.
The first result of `e` will be a struct type, the second a constructor, and the third a predicate;
the rest are selectors and mutators. */
{
int resolved = (flags & CHECK_STRUCT_TYPE_RESOLVED);
if (!fuel) return NULL;
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
@ -1263,7 +1452,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
&& (SCHEME_INT_VAL(app->args[4]) >= 0)
&& ((app->num_args < 5)
/* auto-field value: */
|| !check_auto
|| (flags & CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK)
|| scheme_omittable_expr(app->args[5], 1, 3, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL))
&& ((app->num_args < 6)
/* no properties... */
@ -1273,8 +1462,14 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
or selectors in a way that matters (although supplying the
`prop:chaperone-unsafe-undefined` property can affect the
constructor in an optimizer-irrelevant way) */
|| (!must_always_succeed
&& scheme_omittable_expr(app->args[6], 1, 4, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL)))
|| (!(flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED)
&& scheme_omittable_expr(app->args[6], 1, 4, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL))
|| ((flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED)
&& is_simple_property_list(app->args[6], resolved,
top_level_consts, inline_variants,
top_level_table,
runstack, rs_delta,
symbols, symbol_table)))
&& ((app->num_args < 7)
/* inspector: */
|| SCHEME_FALSEP(app->args[7])
@ -1333,8 +1528,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
Scheme_Object *auto_e;
Simple_Stuct_Type_Info stinfo;
if (!_stinfo) _stinfo = &stinfo;
auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved,
must_always_succeed, check_auto,
auto_e = scheme_is_simple_make_struct_type(lv->value, 5, flags,
_auto_e_depth, _stinfo, _parent_identity,
top_level_consts, inline_variants, top_level_table,
runstack, rs_delta,
@ -1366,8 +1560,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
Scheme_Object *auto_e;
Simple_Stuct_Type_Info stinfo;
if (!_stinfo) _stinfo = &stinfo;
auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved,
must_always_succeed, check_auto,
auto_e = scheme_is_simple_make_struct_type(e2, 5, flags,
_auto_e_depth, _stinfo, _parent_identity,
top_level_consts, inline_variants, top_level_table,
runstack, rs_delta + lvd->count,
@ -1391,6 +1584,48 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int
return NULL;
}
int scheme_is_simple_make_struct_type_property(Scheme_Object *e, int vals, int flags,
int *_has_guard,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
int fuel)
/* Reports whether `app` is a call to `make-struct-type-property` to
produce a propert with no guard. */
{
int resolved = (flags & CHECK_STRUCT_TYPE_RESOLVED);
if ((vals != 3) && (vals >= 0)) return 0;
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)e;
if (SAME_OBJ(app->rator, scheme_make_struct_type_property_proc)) {
if (SCHEME_SYMBOLP(app->rand)) {
if (_has_guard) *_has_guard = 0;
return 1;
}
}
}
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)e;
if (SAME_OBJ(app->rator, scheme_make_struct_type_property_proc)) {
if (SCHEME_SYMBOLP(app->rand1)
&& (!(flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED)
|| SCHEME_LAMBDAP(app->rand2))
&& (scheme_omittable_expr(app->rator, 1, 4, (resolved ? OMITTABLE_RESOLVED : 0), NULL, NULL))) {
if (_has_guard) *_has_guard = 1;
return 1;
}
}
}
return 0;
}
/*========================================================================*/
/* more utils */
/*========================================================================*/
@ -1436,6 +1671,33 @@ Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity
return ps;
}
intptr_t scheme_get_struct_property_proc_shape(int k, int has_guard)
{
switch (k) {
case 0:
if (has_guard)
return STRUCT_PROP_PROC_SHAPE_GUARDED_PROP;
else
return STRUCT_PROP_PROC_SHAPE_PROP;
case 1:
return STRUCT_PROP_PROC_SHAPE_PRED;
case 2:
default:
return STRUCT_PROP_PROC_SHAPE_GETTER;
}
}
Scheme_Object *scheme_make_struct_property_proc_shape(intptr_t k)
{
Scheme_Object *ps;
ps = scheme_alloc_small_object();
ps->type = scheme_struct_prop_proc_shape_type;
SCHEME_PROP_PROC_SHAPE_MODE(ps) = k;
return ps;
}
XFORM_NONGCING static int is_struct_identity_subtype(Scheme_Object *sub, Scheme_Object *sup)
{
/* A structure identity is a list of symbols, but the symbols are
@ -3831,7 +4093,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
if (SAME_OBJ(scheme_struct_type_p_proc, rator)) {
Scheme_Object *c;
c = get_struct_proc_shape(rand, info);
c = get_struct_proc_shape(rand, info, 0);
if (c && ((SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK)
== STRUCT_PROC_SHAPE_STRUCT)) {
info->preserves_marks = 1;
@ -3935,7 +4197,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
}
/* Using a struct getter or predicate? */
alt = get_struct_proc_shape(rator, info);
alt = get_struct_proc_shape(rator, info, 0);
if (alt) {
int mode = (SCHEME_PROC_SHAPE_MODE(alt) & STRUCT_PROC_SHAPE_MASK);
@ -4987,7 +5249,7 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_ir_local_type)) {
Scheme_Object *shape;
shape = get_struct_proc_shape(app->rator, info);
shape = get_struct_proc_shape(app->rator, info, 0);
if (shape
&& ((SCHEME_PROC_SHAPE_MODE(shape) & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED)
&& SCHEME_PAIRP(SCHEME_PROC_SHAPE_IDENTITY(shape))) {
@ -7914,6 +8176,23 @@ int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Obj
return 0;
}
static Scheme_Hash_Table *set_as_fixed(Scheme_Hash_Table *fixed_table, Optimize_Info *info, int pos)
{
if (!fixed_table) {
fixed_table = scheme_make_hash_table(SCHEME_hash_ptr);
if (!info->top_level_consts) {
Scheme_Hash_Table *consts;
consts = scheme_make_hash_table(SCHEME_hash_ptr);
info->top_level_consts = consts;
}
scheme_hash_set(info->top_level_consts, scheme_false, (Scheme_Object *)fixed_table);
}
scheme_hash_set(fixed_table, scheme_make_integer(pos), scheme_true);
return fixed_table;
}
static Scheme_Object *
module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
@ -7951,7 +8230,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
/* Use `limited_info` for optimization decisions that need to be
rediscovered by the validator. The validator knows shape
information for imported variables, and it know about structure
information for imported variables, and it knows about structure
bindings for later forms. */
limited_info = MALLOC_ONE_RT(Optimize_Info);
#ifdef MZTAG_REQUIRED
@ -8076,8 +8355,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
/* If this expression/definition can't have any side effect
(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;
if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) {
int n, cnst = 0, sproc = 0, sprop = 0, has_guard = 0;
Scheme_Object *sstruct = NULL, *parent_identity = NULL;
Simple_Stuct_Type_Info stinfo;
@ -8088,8 +8367,11 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
cont = scheme_omittable_expr(e, n, -1,
/* ignore APPN_FLAG_OMITTABLE, because the
validator won't be able to reconstruct it
in general */
OMITTABLE_IGNORE_APPN_OMIT,
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),
/* similarly, use `limited_info` instead of `info'
here, because the decision
of omittable should not depend on
@ -8105,7 +8387,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
cnst = 1;
sproc = 1;
}
} else if (scheme_is_simple_make_struct_type(e, n, 0, 0, 1, NULL,
} else if (scheme_is_simple_make_struct_type(e, n, 0, NULL,
&stinfo, &parent_identity,
info->top_level_consts,
info->cp->inline_variants,
@ -8114,9 +8396,24 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
5)) {
sstruct = scheme_make_pair(sstruct, parent_identity);
cnst = 1;
} else if (scheme_is_simple_make_struct_type_property(e, n, 0,
&has_guard,
info->top_level_consts,
info->cp->inline_variants,
NULL, NULL, 0, NULL, NULL,
5)) {
sprop = 1;
cnst = 1;
} else
sstruct = NULL;
if ((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. */
cont = scheme_omittable_expr(e, n, 5, OMITTABLE_IGNORE_APPN_OMIT, limited_info, NULL);
}
if (cnst) {
Scheme_Toplevel *tl;
int i;
@ -8130,6 +8427,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
if (sstruct) {
e2 = scheme_make_struct_proc_shape(scheme_get_struct_proc_shape(i, &stinfo),
sstruct);
} else if (sprop) {
e2 = scheme_make_struct_property_proc_shape(scheme_get_struct_property_proc_shape(i, has_guard));
} else if (sproc) {
e2 = scheme_make_noninline_proc(e);
} else if (SCHEME_LAMBDAP(e)) {
@ -8159,7 +8458,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
}
scheme_hash_set(consts, scheme_make_integer(pos), e2);
if (sstruct) {
if (sstruct || sprop) {
/* include in `limited_info` */
Scheme_Hash_Table *limited_consts = limited_info->top_level_consts;
if (!limited_consts) {
@ -8179,23 +8478,15 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
}
} else {
/* At least mark it as fixed */
if (!fixed_table) {
fixed_table = scheme_make_hash_table(SCHEME_hash_ptr);
if (!info->top_level_consts) {
consts = scheme_make_hash_table(SCHEME_hash_ptr);
info->top_level_consts = consts;
consts = NULL;
}
scheme_hash_set(info->top_level_consts, scheme_false, (Scheme_Object *)fixed_table);
}
scheme_hash_set(fixed_table, scheme_make_integer(tl->position), scheme_true);
fixed_table = set_as_fixed(fixed_table, info, tl->position);
}
}
}
} else {
/* The binding is not inlinable/propagatable, but unless it's
set!ed, it is constant after evaluating the definition. We
map the top-level position to indicate constantness. */
map the top-level position to indicate constantness --- immediately
if `cont`, and later if not. */
Scheme_Object *l, *a;
int pos;
@ -8206,7 +8497,10 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) {
pos = SCHEME_TOPLEVEL_POS(a);
next_pos_ready = pos;
if (cont)
fixed_table = set_as_fixed(fixed_table, info, pos);
else
next_pos_ready = pos;
}
}
}
@ -8321,16 +8615,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
}
if (next_pos_ready > -1) {
if (!fixed_table) {
fixed_table = scheme_make_hash_table(SCHEME_hash_ptr);
if (!info->top_level_consts) {
consts = scheme_make_hash_table(SCHEME_hash_ptr);
info->top_level_consts = consts;
consts = NULL;
}
scheme_hash_set(info->top_level_consts, scheme_false, (Scheme_Object *)fixed_table);
}
scheme_hash_set(fixed_table, scheme_make_integer(next_pos_ready), scheme_true);
fixed_table = set_as_fixed(fixed_table, info, next_pos_ready);
next_pos_ready = -1;
}
}

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

@ -538,6 +538,7 @@ extern Scheme_Object *scheme_call_with_immed_mark_proc;
extern Scheme_Object *scheme_make_struct_type_proc;
extern Scheme_Object *scheme_make_struct_field_accessor_proc;
extern Scheme_Object *scheme_make_struct_field_mutator_proc;
extern Scheme_Object *scheme_make_struct_type_property_proc;
extern Scheme_Object *scheme_struct_to_vector_proc;
extern Scheme_Object *scheme_struct_type_p_proc;
extern Scheme_Object *scheme_current_inspector_proc;
@ -3480,6 +3481,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int flags,
#define OMITTABLE_KEEP_VARS 0x2
#define OMITTABLE_KEEP_MUTABLE_VARS 0x4
#define OMITTABLE_IGNORE_APPN_OMIT 0x8
#define OMITTABLE_IGNORE_MAKE_STRUCT_TYPE 0x10
int scheme_might_invoke_call_cc(Scheme_Object *value);
int scheme_is_liftable(Scheme_Object *o, Scheme_Hash_Tree *exclude_vars, int fuel, int as_rator, int or_escape);
@ -3495,9 +3497,8 @@ typedef struct {
int num_gets, num_sets;
} Simple_Stuct_Type_Info;
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved,
int must_always_succeed,
int check_auto, int *_auto_e_depth,
Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int flags,
int *_auto_e_depth,
Simple_Stuct_Type_Info *_stinfo,
Scheme_Object **_parent_identity,
Scheme_Hash_Table *top_level_consts,
@ -3507,6 +3508,17 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, i
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
Scheme_Object **_name,
int fuel);
int scheme_is_simple_make_struct_type_property(Scheme_Object *app, int vals, int flags,
int *_has_guard,
Scheme_Hash_Table *top_level_consts,
Scheme_Hash_Table *inline_variants,
Scheme_Hash_Table *top_level_table,
Scheme_Object **runstack, int rs_delta,
Scheme_Object **symbols, Scheme_Hash_Table *symbol_table,
int fuel);
#define CHECK_STRUCT_TYPE_RESOLVED 0x1
#define CHECK_STRUCT_TYPE_ALWAYS_SUCCEED 0x2
#define CHECK_STRUCT_TYPE_DELAY_AUTO_CHECK 0x4
Scheme_Object *scheme_intern_struct_proc_shape(int shape);
intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *sinfo);
@ -3528,9 +3540,20 @@ typedef struct Scheme_Struct_Proc_Shape {
#define SCHEME_PROC_SHAPE_MODE(obj) ((Scheme_Struct_Proc_Shape *)obj)->mode
#define SCHEME_PROC_SHAPE_IDENTITY(obj) ((Scheme_Struct_Proc_Shape *)obj)->identity
Scheme_Object *scheme_intern_struct_prop_proc_shape(int shape);
intptr_t scheme_get_struct_property_proc_shape(int k, int has_guard);
Scheme_Object *scheme_make_struct_property_proc_shape(intptr_t k);
#define STRUCT_PROP_PROC_SHAPE_PROP 0
#define STRUCT_PROP_PROC_SHAPE_GUARDED_PROP 1
#define STRUCT_PROP_PROC_SHAPE_PRED 2
#define STRUCT_PROP_PROC_SHAPE_GETTER 3
#define SCHEME_PROP_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_check_structure_property_shape(Scheme_Object *e, Scheme_Object *expected);
int scheme_decode_struct_prop_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_native_closure_is_single_result(Scheme_Object *rator);

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

@ -39,6 +39,7 @@ READ_ONLY Scheme_Object *scheme_impersonator_of_property;
READ_ONLY Scheme_Object *scheme_make_struct_type_proc;
READ_ONLY Scheme_Object *scheme_make_struct_field_accessor_proc;
READ_ONLY Scheme_Object *scheme_make_struct_field_mutator_proc;
READ_ONLY Scheme_Object *scheme_make_struct_type_property_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;
@ -557,11 +558,13 @@ scheme_init_struct (Scheme_Env *env)
scheme_make_struct_type_proc,
env);
scheme_add_global_constant("make-struct-type-property",
scheme_make_prim_w_arity2(make_struct_type_property,
"make-struct-type-property",
1, 4,
3, 3),
REGISTER_SO(scheme_make_struct_type_property_proc);
scheme_make_struct_type_property_proc = scheme_make_prim_w_arity2(make_struct_type_property,
"make-struct-type-property",
1, 4,
3, 3);
scheme_add_global_constant("make-struct-type-property",
scheme_make_struct_type_property_proc,
env);
REGISTER_SO(scheme_make_struct_field_accessor_proc);
@ -3555,7 +3558,8 @@ int scheme_decode_struct_shape(Scheme_Object *expected, intptr_t *_v)
if (!expected || !SCHEME_SYMBOLP(expected))
return 0;
if (SCHEME_SYM_VAL(expected)[0] != 's')
if ((SCHEME_SYM_VAL(expected)[0] != 's')
|| (SCHEME_SYM_LEN(expected) < 6))
return 0;
for (i = 6, v = 0; SCHEME_SYM_VAL(expected)[i]; i++) {
@ -3611,6 +3615,53 @@ int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected)
return 0;
}
int scheme_decode_struct_prop_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] != 'p')
|| (SCHEME_SYM_LEN(expected) < 4))
return 0;
for (i = 4, 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_property_shape(Scheme_Object *e, Scheme_Object *expected)
{
intptr_t _v, v;
int i;
if (!scheme_decode_struct_prop_shape(expected, &_v))
return 0;
v = _v;
if (SAME_TYPE(SCHEME_TYPE(e), scheme_struct_property_type)) {
if (((Scheme_Struct_Property *)e)->guard)
return (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP);
return ((v == STRUCT_PROP_PROC_SHAPE_PROP)
|| (v == STRUCT_PROP_PROC_SHAPE_GUARDED_PROP));
} 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_STRUCT_PROP_PRED)
return (v == STRUCT_PROP_PROC_SHAPE_PRED);
else if (i == SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER)
return (v == STRUCT_PROP_PROC_SHAPE_GETTER);
return 0;
}
static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
int argc, Scheme_Object *argv[])
{

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

@ -224,94 +224,95 @@ enum {
scheme_port_closed_evt_type, /* 193 */
scheme_proc_shape_type, /* 194 */
scheme_struct_proc_shape_type, /* 195 */
scheme_phantom_bytes_type, /* 196 */
scheme_environment_variables_type, /* 197 */
scheme_filesystem_change_evt_type, /* 198 */
scheme_ctype_type, /* 199 */
scheme_plumber_type, /* 200 */
scheme_plumber_handle_type, /* 201 */
scheme_deferred_expr_type, /* 202 */
scheme_will_be_lambda_type, /* 203 */
scheme_syntax_property_preserve_type, /* 204 */
scheme_struct_prop_proc_shape_type, /* 196 */
scheme_phantom_bytes_type, /* 197 */
scheme_environment_variables_type, /* 198 */
scheme_filesystem_change_evt_type, /* 199 */
scheme_ctype_type, /* 200 */
scheme_plumber_type, /* 201 */
scheme_plumber_handle_type, /* 202 */
scheme_deferred_expr_type, /* 203 */
scheme_will_be_lambda_type, /* 204 */
scheme_syntax_property_preserve_type, /* 205 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 205 */
_scheme_last_normal_type_, /* 206 */
/* The remaining tags exist for GC tracing (in non-conservative
mode), but they are not needed for run-time tag tests */
scheme_rt_weak_array, /* 206 */
scheme_rt_weak_array, /* 207 */
scheme_rt_comp_env, /* 207 */
scheme_rt_constant_binding, /* 208 */
scheme_rt_resolve_info, /* 209 */
scheme_rt_unresolve_info, /* 210 */
scheme_rt_optimize_info, /* 211 */
scheme_rt_cont_mark, /* 212 */
scheme_rt_saved_stack, /* 213 */
scheme_rt_reply_item, /* 214 */
scheme_rt_ir_lambda_info, /* 215 */
scheme_rt_overflow, /* 216 */
scheme_rt_overflow_jmp, /* 217 */
scheme_rt_meta_cont, /* 218 */
scheme_rt_dyn_wind_cell, /* 219 */
scheme_rt_dyn_wind_info, /* 220 */
scheme_rt_dyn_wind, /* 221 */
scheme_rt_dup_check, /* 222 */
scheme_rt_thread_memory, /* 223 */
scheme_rt_input_file, /* 224 */
scheme_rt_input_fd, /* 225 */
scheme_rt_oskit_console_input, /* 226 */
scheme_rt_tested_input_file, /* 227 */
scheme_rt_tested_output_file, /* 228 */
scheme_rt_indexed_string, /* 229 */
scheme_rt_output_file, /* 230 */
scheme_rt_load_handler_data, /* 231 */
scheme_rt_pipe, /* 232 */
scheme_rt_beos_process, /* 233 */
scheme_rt_system_child, /* 234 */
scheme_rt_tcp, /* 235 */
scheme_rt_write_data, /* 236 */
scheme_rt_tcp_select_info, /* 237 */
scheme_rt_param_data, /* 238 */
scheme_rt_will, /* 239 */
scheme_rt_linker_name, /* 240 */
scheme_rt_param_map, /* 241 */
scheme_rt_finalization, /* 242 */
scheme_rt_finalizations, /* 243 */
scheme_rt_cpp_object, /* 244 */
scheme_rt_cpp_array_object, /* 245 */
scheme_rt_stack_object, /* 246 */
scheme_rt_preallocated_object, /* 247 */
scheme_thread_hop_type, /* 248 */
scheme_rt_srcloc, /* 249 */
scheme_rt_evt, /* 250 */
scheme_rt_syncing, /* 251 */
scheme_rt_comp_prefix, /* 252 */
scheme_rt_user_input, /* 253 */
scheme_rt_user_output, /* 254 */
scheme_rt_compact_port, /* 255 */
scheme_rt_read_special_dw, /* 256 */
scheme_rt_regwork, /* 257 */
scheme_rt_rx_lazy_string, /* 258 */
scheme_rt_buf_holder, /* 259 */
scheme_rt_parameterization, /* 260 */
scheme_rt_print_params, /* 261 */
scheme_rt_read_params, /* 262 */
scheme_rt_native_code, /* 263 */
scheme_rt_native_code_plus_case, /* 264 */
scheme_rt_jitter_data, /* 265 */
scheme_rt_module_exports, /* 266 */
scheme_rt_delay_load_info, /* 267 */
scheme_rt_marshal_info, /* 268 */
scheme_rt_unmarshal_info, /* 269 */
scheme_rt_runstack, /* 270 */
scheme_rt_sfs_info, /* 271 */
scheme_rt_validate_clearing, /* 272 */
scheme_rt_lightweight_cont, /* 273 */
scheme_rt_export_info, /* 274 */
scheme_rt_cont_jmp, /* 275 */
scheme_rt_letrec_check_frame, /* 276 */
scheme_rt_comp_env, /* 208 */
scheme_rt_constant_binding, /* 209 */
scheme_rt_resolve_info, /* 210 */
scheme_rt_unresolve_info, /* 211 */
scheme_rt_optimize_info, /* 212 */
scheme_rt_cont_mark, /* 213 */
scheme_rt_saved_stack, /* 214 */
scheme_rt_reply_item, /* 215 */
scheme_rt_ir_lambda_info, /* 216 */
scheme_rt_overflow, /* 217 */
scheme_rt_overflow_jmp, /* 218 */
scheme_rt_meta_cont, /* 219 */
scheme_rt_dyn_wind_cell, /* 220 */
scheme_rt_dyn_wind_info, /* 221 */
scheme_rt_dyn_wind, /* 222 */
scheme_rt_dup_check, /* 223 */
scheme_rt_thread_memory, /* 224 */
scheme_rt_input_file, /* 225 */
scheme_rt_input_fd, /* 226 */
scheme_rt_oskit_console_input, /* 227 */
scheme_rt_tested_input_file, /* 228 */
scheme_rt_tested_output_file, /* 229 */
scheme_rt_indexed_string, /* 230 */
scheme_rt_output_file, /* 231 */
scheme_rt_load_handler_data, /* 232 */
scheme_rt_pipe, /* 233 */
scheme_rt_beos_process, /* 234 */
scheme_rt_system_child, /* 235 */
scheme_rt_tcp, /* 236 */
scheme_rt_write_data, /* 237 */
scheme_rt_tcp_select_info, /* 238 */
scheme_rt_param_data, /* 239 */
scheme_rt_will, /* 240 */
scheme_rt_linker_name, /* 241 */
scheme_rt_param_map, /* 242 */
scheme_rt_finalization, /* 243 */
scheme_rt_finalizations, /* 244 */
scheme_rt_cpp_object, /* 245 */
scheme_rt_cpp_array_object, /* 246 */
scheme_rt_stack_object, /* 247 */
scheme_rt_preallocated_object, /* 248 */
scheme_thread_hop_type, /* 249 */
scheme_rt_srcloc, /* 250 */
scheme_rt_evt, /* 251 */
scheme_rt_syncing, /* 252 */
scheme_rt_comp_prefix, /* 253 */
scheme_rt_user_input, /* 254 */
scheme_rt_user_output, /* 255 */
scheme_rt_compact_port, /* 256 */
scheme_rt_read_special_dw, /* 257 */
scheme_rt_regwork, /* 258 */
scheme_rt_rx_lazy_string, /* 259 */
scheme_rt_buf_holder, /* 260 */
scheme_rt_parameterization, /* 261 */
scheme_rt_print_params, /* 262 */
scheme_rt_read_params, /* 263 */
scheme_rt_native_code, /* 264 */
scheme_rt_native_code_plus_case, /* 265 */
scheme_rt_jitter_data, /* 266 */
scheme_rt_module_exports, /* 267 */
scheme_rt_delay_load_info, /* 268 */
scheme_rt_marshal_info, /* 269 */
scheme_rt_unmarshal_info, /* 270 */
scheme_rt_runstack, /* 271 */
scheme_rt_sfs_info, /* 272 */
scheme_rt_validate_clearing, /* 273 */
scheme_rt_lightweight_cont, /* 274 */
scheme_rt_export_info, /* 275 */
scheme_rt_cont_jmp, /* 276 */
scheme_rt_letrec_check_frame, /* 277 */
#endif
_scheme_last_type_

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

@ -740,6 +740,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_proc_shape_type, small_atomic_obj);
GC_REG_TRAV(scheme_struct_proc_shape_type, struct_proc_shape);
GC_REG_TRAV(scheme_struct_prop_proc_shape_type, small_atomic_obj);
GC_REG_TRAV(scheme_environment_variables_type, small_object);
GC_REG_TRAV(scheme_syntax_property_preserve_type, small_object);

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

@ -123,13 +123,19 @@ static void noclear_stack_push(struct Validate_Clearing *vc, int pos)
}
static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int shape)
static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int shape, int for_property)
{
if (!*_st_ht) {
Scheme_Hash_Table *ht;
ht = scheme_make_hash_table_eqv();
*_st_ht = ht;
}
if (for_property) {
/* negative value is for a structure type property: */
shape = -(shape+1);
}
scheme_hash_set(*_st_ht,
scheme_make_integer(pos),
scheme_make_integer(shape));
@ -185,7 +191,9 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
intptr_t k;
tl_state[i] = SCHEME_TOPLEVEL_CONST;
if (scheme_decode_struct_shape(((Module_Variable *)toplevels[i])->shape, &k))
add_struct_mapping(_st_ht, i, k);
add_struct_mapping(_st_ht, i, k, 0);
else if (scheme_decode_struct_prop_shape(((Module_Variable *)toplevels[i])->shape, &k))
add_struct_mapping(_st_ht, i, k, 1);
} else if (mv_flags & SCHEME_MODVAR_FIXED)
tl_state[i] = SCHEME_TOPLEVEL_FIXED;
else
@ -295,7 +303,7 @@ 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;
int i, size, flags, result, is_struct, is_struct_prop, has_guard;
Simple_Stuct_Type_Info stinfo;
Scheme_Object *val, *only_var;
@ -399,7 +407,8 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
only_var = NULL;
}
if (scheme_is_simple_make_struct_type(val, size-1, 1, 0, 1, NULL,
if (scheme_is_simple_make_struct_type(val, size-1, CHECK_STRUCT_TYPE_RESOLVED,
NULL,
&stinfo, NULL,
NULL, NULL, (_st_ht ? *_st_ht : NULL),
NULL, 0, NULL, NULL, NULL, 5)) {
@ -411,6 +420,16 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
is_struct = 0;
}
has_guard = 0;
if (scheme_is_simple_make_struct_type_property(val, size-1, CHECK_STRUCT_TYPE_RESOLVED,
&has_guard,
NULL, NULL, (_st_ht ? *_st_ht : NULL),
NULL, 0, NULL, NULL, 5)) {
is_struct_prop = 1;
} else {
is_struct_prop = 0;
}
result = validate_expr(port, val, stack, tls,
depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map,
@ -430,7 +449,22 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
|| (stinfo.field_count == stinfo.init_field_count))
add_struct_mapping(_st_ht,
SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[i]),
scheme_get_struct_proc_shape(i-1, &stinfo));
scheme_get_struct_proc_shape(i-1, &stinfo),
0);
}
}
/* In any case, treat the bindings as constant */
result = 2;
} else if (is_struct_prop) {
if (_st_ht) {
/* Record `prop:' binding as constant across invocations,
so that it can be recognized for struct declarations,
and so on: */
for (i = 1; i < size; i++) {
add_struct_mapping(_st_ht,
SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[i]),
scheme_get_struct_property_proc_shape(i-1, has_guard),
1);
}
}
/* In any case, treat the bindings as constant */
@ -1385,8 +1419,10 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
} else {
/* check expectation */
if (((tl_state[p] & SCHEME_TOPLEVEL_FLAGS_MASK) < flags)
|| ((tl_state[p] >> 2) > tl_timestamp))
|| ((tl_state[p] >> 2) > tl_timestamp)) {
printf("?? %d\n", p);
scheme_ill_formed_code(port);
}
}
}