Skip to content

Commit

Permalink
bc: add equal-always?
Browse files Browse the repository at this point in the history
  • Loading branch information
@AlexKnauth
AlexKnauth committed Dec 14, 2021
1 parent c42e5bf commit ec621b8
Show file tree
Hide file tree
Showing 6 changed files with 94 additions and 52 deletions.
129 changes: 85 additions & 44 deletions racket/src/bc/src/bool.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,10 +24,8 @@ static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]);
/*
static Scheme_Object *equal_always_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_always_recur_prim (int argc, Scheme_Object *argv[]);
*/
static Scheme_Object *chaperone_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonator_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_impersonator_star_p (int argc, Scheme_Object *argv[]);
Expand All @@ -42,7 +40,12 @@ typedef struct Equal_Info {
Scheme_Object *recur;
Scheme_Object *next, *next_next;
Scheme_Object *insp;
intptr_t for_chaperone; /* 3 => for impersonator */
/* mode
0: 'equal?
1: 'chaperone-of?
3: 'impersonator-of?
5: 'equal-always? */
intptr_t mode;
} Equal_Info;

static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
Expand Down Expand Up @@ -116,14 +119,12 @@ void scheme_init_bool (Scheme_Startup_Env *env)
scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3),
env);

/*
scheme_addto_prim_instance("equal-always?",
scheme_make_prim_w_arity(equal_always, "equal-always?/recur", 2, 2),
scheme_make_prim_w_arity(equal_always_prim, "equal-always?/recur", 2, 2),
env);
scheme_addto_prim_instance("equal-always?/recur",
scheme_make_prim_w_arity(equal_always_recur, "equal-always?/recur", 3, 3),
scheme_make_prim_w_arity(equal_always_recur_prim, "equal-always?/recur", 3, 3),
env);
*/

p = scheme_make_immed_prim(chaperone_p, "chaperone?", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
Expand Down Expand Up @@ -188,7 +189,7 @@ XFORM_NONGCING static void init_equal_info(Equal_Info *eql)
eql->next = NULL;
eql->next_next = NULL;
eql->insp = NULL;
eql->for_chaperone = 0;
eql->mode = 0; /* mode 0: 'equal? */
}

static Scheme_Object *
Expand All @@ -214,6 +215,31 @@ equalish_prim (int argc, Scheme_Object *argv[])
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}

static Scheme_Object *
equal_always_prim (int argc, Scheme_Object *argv[])
{
Equal_Info eql;

init_equal_info(&eql);
eql.mode = 5; /* mode 5: 'equal-always? */

return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}

static Scheme_Object *
equal_always_recur_prim (int argc, Scheme_Object *argv[])
{
Equal_Info eql;

scheme_check_proc_arity("equal-always?/recur", 2, 2, argc, argv);

init_equal_info(&eql);
eql.next_next = argv[2];
eql.mode = 5; /* mode 5: 'equal-always? */

return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}

int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
{
return SAME_OBJ(obj1, obj2);
Expand Down Expand Up @@ -350,7 +376,14 @@ int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
return (is_eqv(obj1, obj2) > 0);
}

XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int for_chaperone)
/* for_chaperone_equalw:
0: 'equal? or 'impersonator-of?
1: 'chaperone-of? or 'equal-always?
result:
-1: unknown
0: known false
1: known true */
XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int for_chaperone_equalw)
{
Scheme_Type t1, t2;
int cmp;
Expand Down Expand Up @@ -403,7 +436,7 @@ XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int
case scheme_windows_path_type:
{
intptr_t l1, l2;
if (for_chaperone) return -1;
if (for_chaperone_equalw) return -1;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
Expand All @@ -412,7 +445,7 @@ XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int
case scheme_char_string_type:
{
intptr_t l1, l2;
if (for_chaperone) return -1;
if (for_chaperone_equalw) return -1;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
Expand Down Expand Up @@ -449,7 +482,7 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2) XFORM_ASSERT_NO_CONV
{
int v;

v = is_fast_equal(obj1, obj2, 0);
v = is_fast_equal(obj1, obj2, 0); /* 0: 'equal? or 'impersonator-of? */
if (v > -1)
return v;

Expand Down Expand Up @@ -575,23 +608,23 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
}

top_after_next:
cmp = is_fast_equal(obj1, obj2, eql->for_chaperone == 1);
if (cmp > -1)
cmp = is_fast_equal(obj1, obj2, eql->mode == 1 || eql->mode == 5); /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
if (cmp > -1) /* cmp 0 or 1: known */
return cmp;

if (eql->for_chaperone
if (eql->mode /* mode 1, 3, or 5: 'chaperone-of?, 'impersonator-of?, or `equal-always? */
&& SCHEME_CHAPERONEP(obj2)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj2) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
|| (eql->for_chaperone > 1))
|| (eql->mode > 1))
&& scheme_is_noninterposing_chaperone(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->prev;
goto top_after_next;
}

if (eql->for_chaperone
if (eql->mode /* mode 1, 3, or 5: 'chaperone-of?, 'impersonator-of?, or `equal-always? */
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
|| (eql->for_chaperone > 1))) {
|| (eql->mode > 1))) {
/* `obj1` and `obj2` are not eq, otherwise is_fast_equal()
would have returned true */
if (SCHEME_CHAPERONEP(obj2)) {
Expand Down Expand Up @@ -621,7 +654,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
obj2 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj2);
goto top_after_next;
}
if (!eql->for_chaperone) {
if (eql->mode == 0 || eql->mode == 5) { /* mode 0 or 5: 'equal? or 'equal-always? */
if (SCHEME_CHAPERONEP(obj1)) {
/* OPT only use prev for unsafe-chaperone-vector, use val otherwise */
obj1 = ((Scheme_Chaperone *)obj1)->prev;
Expand Down Expand Up @@ -654,7 +687,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
case scheme_mutable_pair_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
if (eql->mode == 1 || eql->mode == 5) /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
return 0;
if (union_check(obj1, obj2, eql))
return 1;
Expand All @@ -669,8 +702,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
case scheme_fxvector_type:
{
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
if ((eql->mode == 1 || eql->mode == 5) /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
&& (!SCHEME_IMMUTABLEP(obj1) || !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
Expand All @@ -681,8 +714,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
case scheme_windows_path_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
if ((eql->mode == 1 || eql->mode == 5) /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
&& (!SCHEME_IMMUTABLEP(obj1) || !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
Expand All @@ -692,8 +725,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
case scheme_char_string_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
if ((eql->mode == 1 || eql->mode == 5) /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
&& (!SCHEME_IMMUTABLEP(obj1) || !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
Expand All @@ -719,18 +752,18 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);

if (eql->for_chaperone == 1)
if (eql->mode == 1) /* mode 1: 'chaperone-of? */
procs1 = NULL;
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = scheme_apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs1 = scheme_apply_impersonator_of(eql->mode, procs1, obj1);
if (eql->mode == 1 || eql->mode == 3) /* mode 1 or 3: 'chaperone-of? or 'impersonator-of? */
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2);
procs2 = scheme_apply_impersonator_of(eql->mode, procs2, obj2);
}

if (procs1 || procs2) {
Expand All @@ -741,9 +774,11 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
} else {
/* don't discard `prop:impersonator-of` if checking for `impersonator-of?`
or `chaperone-of?` */
if (eql->for_chaperone) {
if (eql->mode == 1 || eql->mode == 3) { /* mode 1 or 3: 'chaperone-of? or 'impersonator-of? */
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2 && scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2))
if (procs2 && scheme_apply_impersonator_of(eql->mode, procs2, obj2))
/* Second argument is an impersonator, so
`impersonator-of?` or `chaperone-of?` fails */
return 0;
}

Expand Down Expand Up @@ -792,8 +827,9 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
} else if ((eql->mode == 1 || eql->mode == 5) /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
/* Mutable records must be `eq?` for `chaperone-of?` and `equal-always?` */
return 0;
} else {
/* Same types, but doesn't have an equality property
Expand All @@ -817,8 +853,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
case scheme_box_type:
{
SCHEME_USE_FUEL(1);
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
if ((eql->mode == 1 || eql->mode == 5) /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
&& (!SCHEME_IMMUTABLEP(obj1) || !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
Expand All @@ -836,7 +872,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
case scheme_hash_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
if (eql->mode == 1 || eql->mode == 5) /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
return 0;
if (union_check(obj1, obj2, eql))
return 1;
Expand All @@ -861,7 +897,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
case scheme_bucket_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
if (eql->mode == 1 || eql->mode == 5) /* mode 1 or 5: 'chaperone-of? or 'equal-always? */
return 0;
if (union_check(obj1, obj2, eql))
return 1;
Expand All @@ -870,8 +906,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
eql);
}
default:
if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) {
if ((eql->mode == 0 || eql->mode == 5) /* mode 0 or 5: 'equal? or 'equal-always? */
&& ((t1 == scheme_chaperone_type) || (t1 == scheme_proc_chaperone_type))) {
/* both chaperones */
obj1 = ((Scheme_Chaperone *)obj1)->val;
obj2 = ((Scheme_Chaperone *)obj2)->val;
Expand Down Expand Up @@ -1002,7 +1038,7 @@ int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
Equal_Info eql;

init_equal_info(&eql);
eql.for_chaperone = 1;
eql.mode = 1; /* mode 1: 'chaperone-of? */

return is_equal(obj1, obj2, &eql);
}
Expand All @@ -1012,12 +1048,17 @@ int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2)
Equal_Info eql;

init_equal_info(&eql);
eql.for_chaperone = 3;
eql.mode = 3; /* mode 3: 'impersonator-of? */

return is_equal(obj1, obj2, &eql);
}

Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
/* mode
0: 'equal?
1: 'chaperone-of?
3: 'impersonator-of?
5: 'equal-always? */
Scheme_Object *scheme_apply_impersonator_of(int mode, Scheme_Object *procs, Scheme_Object *obj)
{
Scheme_Object *a[1], *v, *oprocs;

Expand All @@ -1029,7 +1070,7 @@ Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *pr

oprocs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);
if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
scheme_contract_error(((mode == 1)? "chaperone-of?" : (mode == 3)? "impersonator-of?" : (mode == 5)? "equal-always?" : "equal?"),
"impersonator-of property procedure returned a value with a different prop:impersonator-of source",
"original value", 1, obj,
"returned value", 1, v,
Expand All @@ -1040,7 +1081,7 @@ Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *pr
if (procs || oprocs)
if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0],
SCHEME_VEC_ELS(procs)[0]))
scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
scheme_contract_error(((mode == 1)? "chaperone-of?" : (mode == 3)? "impersonator-of?" : (mode == 5)? "equal-always?" : "equal?"),
"impersonator-of property procedure returned a value with a different prop:equal+hash source",
"original value", 1, obj,
"returned value", 1, v,
Expand Down
2 changes: 0 additions & 2 deletions racket/src/bc/src/schemef.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1092,7 +1092,6 @@ XFORM_NONGCING MZ_EXTERN int scheme_is_subinspector(Scheme_Object *i, Scheme_Obj
XFORM_NONGCING MZ_EXTERN int scheme_eq(Scheme_Object *obj1, Scheme_Object *obj2);
XFORM_NONGCING MZ_EXTERN int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2);
// MZ_EXTERN int scheme_equal_always(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2);

Expand All @@ -1111,7 +1110,6 @@ MZ_EXTERN void scheme_set_type_equality(Scheme_Type type,
Scheme_Primary_Hash_Proc hash1,
Scheme_Secondary_Hash_Proc hash2);
MZ_EXTERN int scheme_recur_equal(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info);
// MZ_EXTERN int scheme_recur_equal_always(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info);

MZ_EXTERN Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv);
MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta);
Expand Down
2 changes: 0 additions & 2 deletions racket/src/bc/src/schemex.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -895,7 +895,6 @@ int (*scheme_is_subinspector)(Scheme_Object *i, Scheme_Object *sup);
int (*scheme_eq)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_eqv)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_equal)(Scheme_Object *obj1, Scheme_Object *obj2);
// int (*scheme_equal_always)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_chaperone_of)(Scheme_Object *obj1, Scheme_Object *obj2);
int (*scheme_impersonator_of)(Scheme_Object *obj1, Scheme_Object *obj2);
#ifdef MZ_PRECISE_GC
Expand All @@ -912,7 +911,6 @@ void (*scheme_set_type_equality)(Scheme_Type type,
Scheme_Primary_Hash_Proc hash1,
Scheme_Secondary_Hash_Proc hash2);
int (*scheme_recur_equal)(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info);
// int (*scheme_recur_equal_always)(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info);
Scheme_Object *(*scheme_build_list)(int argc, Scheme_Object **argv);
Scheme_Object *(*scheme_build_list_offset)(int argc, Scheme_Object **argv, int delta);
int (*scheme_is_list)(Scheme_Object *obj1);
Expand Down
2 changes: 1 addition & 1 deletion racket/src/bc/src/schminc.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,7 +15,7 @@

#define USE_COMPILED_STARTUP 1

#define EXPECTED_PRIM_COUNT 1529
#define EXPECTED_PRIM_COUNT 1531

#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP
Expand Down
7 changes: 6 additions & 1 deletion racket/src/bc/src/schpriv.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1308,7 +1308,12 @@ Scheme_Object *scheme_chaperone_not_undefined(Scheme_Object *orig_val);

int scheme_is_noninterposing_chaperone(Scheme_Object *obj);

Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj);
/* mode
0: 'equal?
1: 'chaperone-of?
3: 'impersonator-of?
5: 'equal-always? */
Scheme_Object *scheme_apply_impersonator_of(int mode, Scheme_Object *procs, Scheme_Object *obj);

/*========================================================================*/
/* syntax objects */
Expand Down
Loading

0 comments on commit ec621b8

Please sign in to comment.