diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 55ea4558b5..bd7c2d7fed 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.90.0.21") +(define version "6.90.0.22") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 555866f0c5..e5bf08b825 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -442,7 +442,9 @@ int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Inf 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))) { + || ((num_args == field_count) + && (mode == STRUCT_PROC_SHAPE_CONSTR) + && (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_NONFAIL_CONSTR))) { return 1; } } else if (SAME_TYPE(SCHEME_TYPE(c), scheme_struct_prop_proc_shape_type)) { @@ -1398,7 +1400,8 @@ static int is_ok_value(Ok_Value_Callback ok_value, void *data, 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; + Scheme_Object **_parent_identity = (Scheme_Object **)((void **)data)[0]; + int *_nonfail_constr = (int *)((void **)data)[1]; if (mode == OK_CONSTANT_SHAPE) { if (SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) { @@ -1407,20 +1410,28 @@ static int ok_constant_super_value(void *data, Scheme_Object *v, int mode) if (mode == STRUCT_PROC_SHAPE_STRUCT) { if (_parent_identity) *_parent_identity = SCHEME_PROC_SHAPE_IDENTITY(v); + if (_nonfail_constr) + *_nonfail_constr = SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_NONFAIL_CONSTR; 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) + if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) { + if (_nonfail_constr) + *_nonfail_constr = k & STRUCT_PROC_SHAPE_NONFAIL_CONSTR; 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) + && (k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) { + if (_nonfail_constr) + *_nonfail_constr = k & STRUCT_PROC_SHAPE_NONFAIL_CONSTR; 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) @@ -1429,15 +1440,21 @@ static int ok_constant_super_value(void *data, Scheme_Object *v, int mode) 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) + if (mode == STRUCT_PROC_SHAPE_STRUCT) { + if (_nonfail_constr) + *_nonfail_constr = SCHEME_INT_VAL(v) & STRUCT_PROC_SHAPE_NONFAIL_CONSTR; 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) + if (st->num_slots == st->num_islots) { + if (_nonfail_constr) + *_nonfail_constr = st->nonfail_constructor; return st->num_slots + 1; + } } } @@ -1449,10 +1466,16 @@ static int is_constant_super(Scheme_Object *arg, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, Scheme_Linklet *enclosing_linklet, - Scheme_Object **_parent_identity) + Scheme_Object **_parent_identity, + int *_nonfail_constr) /* Does `arg` produce another structure type (which can serve as a supertype)? */ { - return is_ok_value(ok_constant_super_value, _parent_identity, + void *data[2]; + + data[0] = _parent_identity; + data[1] = _nonfail_constr; + + return is_ok_value(ok_constant_super_value, data, arg, info, top_level_table, @@ -1591,7 +1614,6 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int 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. */ @@ -1606,7 +1628,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int if ((app->num_args >= 4) && (app->num_args <= 11) && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { - int super_count_plus_one; + int super_count_plus_one, super_nonfail_constr = 1; if (_parent_identity) *_parent_identity = scheme_null; @@ -1614,7 +1636,8 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int super_count_plus_one = is_constant_super(app->args[2], info, top_level_table, runstack, rs_delta + app->num_args, - enclosing_linklet, _parent_identity); + enclosing_linklet, _parent_identity, + &super_nonfail_constr); else super_count_plus_one = 0; @@ -1663,7 +1686,9 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int SCHEME_INT_VAL(app->args[3]))) && ((app->num_args < 10) /* guard: */ - || SCHEME_FALSEP(app->args[10])) + || SCHEME_FALSEP(app->args[10]) + /* Could try to check for procedure with correct arity: */ + || !(flags & CHECK_STRUCT_TYPE_ALWAYS_SUCCEED)) && ((app->num_args < 11) /* constructor name: */ || SCHEME_FALSEP(app->args[11]) @@ -1694,6 +1719,8 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int enclosing_linklet, 1, &authentic)) _stinfo->authentic = authentic; + _stinfo->nonfail_constructor = (super_nonfail_constr + && ((app->num_args < 10) || SCHEME_FALSEP(app->args[10]))); _stinfo->num_gets = 1; _stinfo->num_sets = 1; } @@ -1822,12 +1849,15 @@ intptr_t scheme_get_struct_proc_shape(int k, Simple_Struct_Type_Info *stinfo) if (stinfo->field_count == stinfo->init_field_count) return (STRUCT_PROC_SHAPE_STRUCT | (stinfo->authentic ? STRUCT_PROC_SHAPE_AUTHENTIC : 0) + | (stinfo->nonfail_constructor ? STRUCT_PROC_SHAPE_NONFAIL_CONSTR : 0) | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT)); else return STRUCT_PROC_SHAPE_OTHER; break; case 1: - return STRUCT_PROC_SHAPE_CONSTR | (stinfo->init_field_count << STRUCT_PROC_SHAPE_SHIFT); + return (STRUCT_PROC_SHAPE_CONSTR + | (stinfo->init_field_count << STRUCT_PROC_SHAPE_SHIFT) + | (stinfo->nonfail_constructor ? STRUCT_PROC_SHAPE_NONFAIL_CONSTR : 0)); break; case 2: return (STRUCT_PROC_SHAPE_PRED @@ -3845,10 +3875,11 @@ static int appn_flags(Scheme_Object *rator, Optimize_Info *info) if (SAME_TYPE(SCHEME_TYPE(rator), scheme_proc_shape_type)) { return APPN_FLAG_SFS_TAIL; } else if (SAME_TYPE(SCHEME_TYPE(rator), scheme_struct_proc_shape_type)) { - int ps = SCHEME_PROC_SHAPE_MODE(rator); + int ps = SCHEME_PROC_SHAPE_MODE(rator) & STRUCT_PROC_SHAPE_MASK; if ((ps == STRUCT_PROC_SHAPE_PRED) || (ps == STRUCT_PROC_SHAPE_GETTER) - || (ps == STRUCT_PROC_SHAPE_SETTER)) + || (ps == STRUCT_PROC_SHAPE_SETTER) + || (ps == STRUCT_PROC_SHAPE_CONSTR)) return (APPN_FLAG_IMMED | APPN_FLAG_SFS_TAIL); return 0; } diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 2d8763aaaf..fedf74a727 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1079,6 +1079,7 @@ typedef struct Scheme_Struct_Type { mzshort num_islots; /* initialized + parent-initialized */ mzshort name_pos; char authentic; /* 1 => chaperones/impersonators disallowed */ + char nonfail_constructor; /* 1 => constructor never fails */ Scheme_Object *name; @@ -3042,6 +3043,7 @@ typedef struct { int normal_ops; /* are selectors and predicates in the usual order? */ int indexed_ops; /* do selectors have the index built in (as opposed to taking an index argument)? */ int authentic; /* conservatively 0 is ok */ + int nonfail_constructor; int num_gets, num_sets; int setter_fields; /* if indexed, bitmap for first 32 fields to indicate which have setters */ } Simple_Struct_Type_Info; @@ -3077,8 +3079,9 @@ Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity #define STRUCT_PROC_SHAPE_SETTER 4 #define STRUCT_PROC_SHAPE_OTHER 5 #define STRUCT_PROC_SHAPE_MASK 0xF -#define STRUCT_PROC_SHAPE_AUTHENTIC 0x10 -#define STRUCT_PROC_SHAPE_SHIFT 5 +#define STRUCT_PROC_SHAPE_AUTHENTIC 0x10 +#define STRUCT_PROC_SHAPE_NONFAIL_CONSTR 0x20 +#define STRUCT_PROC_SHAPE_SHIFT 6 typedef struct Scheme_Struct_Proc_Shape { Scheme_Object so; diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index ec39750b46..ca955afdea 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.90.0.21" +#define MZSCHEME_VERSION "6.90.0.22" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 90 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 21 +#define MZSCHEME_VERSION_W 22 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index f39203fabe..84c9b1a3b3 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -3439,6 +3439,10 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex | STRUCT_PROC_SHAPE_STRUCT | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC))) ? STRUCT_PROC_SHAPE_AUTHENTIC + : 0) + | ((st->nonfail_constructor + && (!expected || (v & STRUCT_PROC_SHAPE_NONFAIL_CONSTR))) + ? STRUCT_PROC_SHAPE_NONFAIL_CONSTR : 0)); } else if (!SCHEME_PRIMP(e)) { want_v = -1; @@ -3447,8 +3451,12 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex if ((i == SCHEME_PRIM_STRUCT_TYPE_CONSTR) || (i == SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR)) { st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; - want_v = ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT) - | STRUCT_PROC_SHAPE_CONSTR); + want_v = ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_CONSTR + | ((st->nonfail_constructor + && (!expected || (v & STRUCT_PROC_SHAPE_NONFAIL_CONSTR))) + ? STRUCT_PROC_SHAPE_NONFAIL_CONSTR + : 0)); } else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) { st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; want_v = (STRUCT_PROC_SHAPE_PRED @@ -4737,6 +4745,7 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base, struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0); struct_type->name_pos = depth; struct_type->authentic = 0; + struct_type->nonfail_constructor = 1; struct_type->inspector = scheme_false; struct_type->uninit_val = uninit_val; struct_type->props = NULL; @@ -4803,6 +4812,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base, } struct_type->name = base; + struct_type->nonfail_constructor = (parent_type ? parent_type->nonfail_constructor : 1); struct_type->num_slots = num_fields + num_uninit_fields + (parent_type ? parent_type->num_slots : 0); struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0); @@ -5066,6 +5076,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base, } struct_type->guard = guard; + struct_type->nonfail_constructor = 0; } else if (chaperone_undefined) { struct_type->guard = scheme_undefined; } @@ -5073,6 +5084,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base, if (parent && SCHEME_NP_CHAPERONEP(parent)) { guard = add_struct_type_chaperone_guards(parent, struct_type->guard); struct_type->guard = guard; + struct_type->nonfail_constructor = 0; } if (checked_proc) diff --git a/racket/src/racket/src/validate.c b/racket/src/racket/src/validate.c index f323abecad..8830e55b3a 100644 --- a/racket/src/racket/src/validate.c +++ b/racket/src/racket/src/validate.c @@ -1092,7 +1092,8 @@ static int is_functional_nonfailing_rator(Scheme_Object *rator, int num_args, in v = scheme_hash_get(*_st_ht, scheme_make_integer(pos)); if (v) { int k = SCHEME_INT_VAL(v); - if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_CONSTR) { + if (((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_CONSTR) + && (k & STRUCT_PROC_SHAPE_NONFAIL_CONSTR)) { if (num_args == (k >> STRUCT_PROC_SHAPE_SHIFT)) return 1; } else if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED) {