optimizer: fix interaction of arithmetic reductions and wcm

Also fix a similar problem with branches reduction in a Boolean context.

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.

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