diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index b4fcf6a3b0..6610d10169 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -3910,6 +3910,88 @@ (check-escape-position (lambda (e) `(begin0 ,e 1)))) +;; Aritmethic simplifications must not break `with-continuation-mark`: +(let ([f (lambda () + (define retval #f) + (with-continuation-mark + 'contrast-dye 1 + (unsafe-fx+ + 0 + (with-continuation-mark + 'contrast-dye 2 + (begin + (set! retval (continuation-mark-set->list + (current-continuation-marks) + 'contrast-dye)) + 7)))) + retval)]) + (set! f f) + (test '(2 1) + 'contrast-dye + (f))) + +(let ([check-wcm-wrap + (lambda (nontail-wrap) + (test-comp `(lambda (p) + (with-continuation-mark + 'contrast-dye 1 + ,(nontail-wrap `(with-continuation-mark + 'contrast-dye 2 + (p))))) + `(lambda (p) + (with-continuation-mark + 'contrast-dye 1 + (unsafe-fx+ + 0 + (with-continuation-mark + 'contrast-dye 2 + (p)))))))]) + (check-wcm-wrap (lambda (e) + `(unsafe-fx+ 0 ,e))) + (check-wcm-wrap (lambda (e) + `(unsafe-fx+ ,e 0))) + (check-wcm-wrap (lambda (e) + `(unsafe-fx- ,e 0))) + (check-wcm-wrap (lambda (e) + `(unsafe-fx* 1 ,e))) + (check-wcm-wrap (lambda (e) + `(unsafe-fx* ,e 1))) + (check-wcm-wrap (lambda (e) + `(unsafe-fxquotient ,e 1))) + (check-wcm-wrap (lambda (e) + `(unsafe-fl+ 0.0 ,e))) + (check-wcm-wrap (lambda (e) + `(unsafe-fl+ ,e 0.0))) + (check-wcm-wrap (lambda (e) + `(unsafe-fl- ,e 0.0))) + (check-wcm-wrap (lambda (e) + `(unsafe-fl* 1.0 ,e))) + (check-wcm-wrap (lambda (e) + `(unsafe-fl* ,e 1.0))) + (check-wcm-wrap (lambda (e) + `(unsafe-fl/ ,e 1.0)))) + +;; Check `if` reduction in a boolen context: +(let ([f (lambda (x) + (define retval #f) + (not + (with-continuation-mark + 'contrast-dye 1 + (if (with-continuation-mark + 'contrast-dye 2 + (begin + (set! retval (continuation-mark-set->list + (current-continuation-marks) + 'contrast-dye)) + x)) + #t + #f))) + retval)]) + (set! f f) + (test '(2 1) + 'contrast-dye + (f 'x))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test that the `if` is not confused by the ;; predicates that recognize #f. diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 8a9bb686fa..b63ee1b5db 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -4804,12 +4804,12 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz z2 = SAME_OBJ(app->rand2, scheme_make_integer(0)); if (IS_NAMED_PRIM(app->rator, "unsafe-fx+")) { if (z1) - return app->rand2; + return ensure_single_value(app->rand2); else if (z2) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-fx-")) { if (z2) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-fx*")) { if (z1 || z2) { if (z1 && z2) @@ -4820,14 +4820,14 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz return make_discarding_sequence(app->rand2, scheme_make_integer(0), info); } if (SAME_OBJ(app->rand1, scheme_make_integer(1))) - return app->rand2; + return ensure_single_value(app->rand2); if (SAME_OBJ(app->rand2, scheme_make_integer(1))) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-fxquotient")) { if (z1) return make_discarding_sequence(app->rand2, scheme_make_integer(0), info); if (SAME_OBJ(app->rand2, scheme_make_integer(1))) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-fxremainder") || IS_NAMED_PRIM(app->rator, "unsafe-fxmodulo")) { if (z1) @@ -4841,20 +4841,20 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz if (IS_NAMED_PRIM(app->rator, "unsafe-fl+")) { if (z1) - return app->rand2; + return ensure_single_value(app->rand2); else if (z2) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl-")) { if (z2) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl*")) { if (SCHEME_FLOATP(app->rand1) && (SCHEME_FLOAT_VAL(app->rand1) == 1.0)) - return app->rand2; + return ensure_single_value(app->rand2); if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0)) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl/")) { if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0)) - return app->rand1; + return ensure_single_value(app->rand1); } /* Possible improvement: detect 0 and 1 constants even when general @@ -4865,20 +4865,20 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz if (IS_NAMED_PRIM(app->rator, "unsafe-extfl+")) { if (z1) - return app->rand2; + return ensure_single_value(app->rand2); else if (z2) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-extfl-")) { if (z2) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-extfl*")) { if (SCHEME_LONG_DBLP(app->rand1) && long_double_is_1(SCHEME_LONG_DBL_VAL(app->rand1))) - return app->rand2; + return ensure_single_value(app->rand2); if (SCHEME_LONG_DBLP(app->rand2) && long_double_is_1(SCHEME_LONG_DBL_VAL(app->rand2))) - return app->rand1; + return ensure_single_value(app->rand1); } else if (IS_NAMED_PRIM(app->rator, "unsafe-extfl/")) { if (SCHEME_LONG_DBLP(app->rand2) && long_double_is_1(SCHEME_LONG_DBL_VAL(app->rand2))) - return app->rand1; + return ensure_single_value(app->rand1); } #endif } else if (SCHEME_PRIMP(app->rator) @@ -5867,7 +5867,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int if (pred && predicate_implies(pred, scheme_boolean_p_proc)) { info->size -= 2; - return t; + return ensure_single_value(t); } } @@ -5888,7 +5888,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int if (SCHEME_FALSEP(fb) && equivalent_exprs(t, tb, NULL, NULL, 0)) { info->size -= 2; - return t; + return ensure_single_value(t); } /* Convert: expressions like