From 17665d33a287b378e2ac47234e54445c243528a6 Mon Sep 17 00:00:00 2001
From: Gustavo Massaccesi <gustavo@oma.org.ar>
Date: Sat, 13 Dec 2014 18:28:13 -0300
Subject: [PATCH] Remove dead code after errors

For example, reduce (begin x (error 'e) y) ==> (begin x (error 'e)) and
(f (error 'e) y ) ==> (begin f (error 'e)).

Also, reduce (if (error 'e) x y) ==> (error 'e) and propagate the type information
and clocks when only one branch produce an error.
---
 .../tests/racket/optimize.rktl                | 179 +++++++-
 racket/src/racket/src/optimize.c              | 390 ++++++++++++++----
 2 files changed, 479 insertions(+), 90 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl
index 0ba677e052..abe0933782 100644
--- a/pkgs/racket-test-core/tests/racket/optimize.rktl
+++ b/pkgs/racket-test-core/tests/racket/optimize.rktl
@@ -2722,6 +2722,7 @@
 ;; operations on mutable values:
 (let ()
   (define (check-omit-ok expr [yes? #t])
+    (displayln (list expr 1 '!))
     ;; can omit:
     (test-comp `(module m racket/base
                   (require racket/unsafe/ops)
@@ -2733,6 +2734,7 @@
                     ,expr
                     (f x)))
                yes?)
+    (displayln (list expr 2 '!))
     ;; cannot reorder:
     (test-comp `(module m racket/base
                   (require racket/unsafe/ops)
@@ -2745,7 +2747,9 @@
                   (define (f x)
                     (vector-ref x x)
                     (f x ,expr)))
-               #f))
+               #f)
+     (displayln (list expr 3 '!))
+  )
   (map check-omit-ok
        '((unsafe-vector-ref x x)
          (unsafe-vector*-ref x x)
@@ -3017,7 +3021,180 @@
                 #t
                 (letrec ([z (lambda () z)]) (f z) #f)
                 (letrec ([z (lambda () z)]) (f z) #t))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check remotion of dead code after error
+(test-comp '(lambda () (random) (error 'error))
+           '(lambda () (random) (error 'error) 5))
+(test-comp '(lambda () (random) (error 'error))
+           '(lambda () (random) (error 'error) (random) 5))
+(test-comp '(lambda () (error 'error))
+           '(lambda () 5 (error 'error) 5))
+(test-comp '(lambda (f) (f) (f) (error 'error))
+           '(lambda (f) (f) (f) (error 'error) (f)))
+
+(test-comp '(lambda (f) (begin0 (f) (random) (error 'error)))
+           '(lambda (f) (begin0 (f) (random) (error 'error) (random) (f))))
+(test-comp '(lambda (f) (error 'error))
+           '(lambda (f) (begin0 (error 'error) (random) (f))))
+(test-comp '(lambda (f) (error 'error))
+           '(lambda (f) (begin0 7 (error 'error) (random) (f))))
+
+(test-comp '(lambda (n)
+              (let ([p (begin (error 'error) (fl+ n n))])
+                (if (flonum? p)
+                    (fl+ p p)
+                    'bad)))
+           '(lambda (n)
+              (let ([p (begin (error 'error) (fl- n n))])
+                (if (flonum? p)
+                    (fl+ p p)
+                    'bad))))
+
+(test-comp '(lambda () (if (error 'error) 1 2))
+           '(lambda () (if (error 'error) 1 2) 5))
+(test-comp '(lambda () (error 'error))
+           '(lambda () (if (error 'error) 1 2) 5))
+(test-comp '(lambda (x) (if x (error 'error) 0) 3)
+           '(lambda (x) (if x (error 'error) 0) 4)
+           #f)
+(test-comp '(lambda (x) (if x 0 (error 'error)) 3)
+           '(lambda (x) (if x 0 (error 'error)) 4)
+           #f)
+(test-comp '(lambda (x) (if x (error 'error 1) (error 'error 2)))
+           '(lambda (x) (if x (error 'error 1) (error 'error 2)) 5))
+
+(test-comp '(lambda (x) (if x (error 'error) (car x)) (unsafe-car x))
+           '(lambda (x) (if x (error 'error) (car x)) (car x)))
+(test-comp '(lambda (x) (if x (car x) (error 'error)) (unsafe-car x))
+           '(lambda (x) (if x (car x) (error 'error)) (car x)))
+(test-comp '(lambda (x) (if x (begin (car x) (error 'error)) 0) (unsafe-car x))
+           '(lambda (x) (if x (begin (car x) (error 'error)) 0) (car x))
+           #f)
+(test-comp '(lambda (x) (if x 0 (begin (car x) (error 'error))) (unsafe-car x))
+           '(lambda (x) (if x 0 (begin (car x) (error 'error))) (car x))
+           #f)
+
+(test-comp '(lambda (x) (if (car x) (error 'error) 0) (unsafe-car x))
+           '(lambda (x) (if (car x) (error 'error) 0) (car x)))
+(test-comp '(lambda (x) (if (car x) 0 (error 'error)) (unsafe-car x))
+           '(lambda (x) (if (car x) 0 (error 'error)) (car x)))
+
+(test-comp '(lambda (f) (error 'error))
+           '(lambda (f) (with-continuation-mark (error 'error) 'v (f))))
+(test-comp '(lambda (f) (values (f)) (error 'error))
+           '(lambda (f) (with-continuation-mark (f) (error 'error) (f))))
+
+(test-comp '(lambda (f x) (f x x) (set! x 3) (error 'error))
+           '(lambda (f x) (f x x) (set! x 3) (set! x (error 'error)) 5))
+(test-comp '(lambda (f x) (error 'error))
+           '(lambda (f x) (set! x (error 'error)) 5))
+(test-comp '(lambda (f) (let ([x (random)]) (f x x) (set! x 3) (error 'error)))
+           '(lambda (f) (let ([x (random)]) (f x x) (set! x 3) (set! x (error 'error)) 5)))
+(test-comp '(lambda (f) (let ([x (random)]) (error 'error)))
+           '(lambda (f) (let ([x (random)]) (set! x (error 'error)) 5)))
+
+#;(test-comp '(lambda (f) (error 'error))
+           '(lambda (f) (call-with-values (error 'error) (f))))
+#;(test-comp '(lambda (g) (g) (error 'error))
+           '(lambda (g) (call-with-values (g) (error 'error))))
+
+(test-comp '(lambda () (error 'error))
+           '(lambda () ((error 'error) 0) 5))
+(test-comp '(lambda () (error 'error))
+           '(lambda () (car (error 'error)) 5))
+(test-comp '(lambda () (error 'error))
+           '(lambda () (not (error 'error)) 5))
+(test-comp '(lambda (f) (values (f)) (error 'error))
+           '(lambda (f) ((f) (error 'error)) 5))
            
+(test-comp '(lambda () (error 'error))
+           '(lambda () ((error 'error) 0 1) 5))
+(test-comp '(lambda () (error 'error))
+           '(lambda () (cons (error 'error) 1) 5))
+(test-comp '(lambda () (error 'error))
+           '(lambda () (cons 0 (error 'error)) 5))
+(test-comp '(lambda (f) (f) (error 'error))
+           '(lambda (f) (f) (cons (error 'error) (f)) 5))
+(test-comp '(lambda (f) (values (f)) (error 'error))
+           '(lambda (f) (cons (f) (error 'error)) 5))
+(test-comp '(lambda (f) (values (f)) (error 'error))
+           '(lambda (f) ((f) (error 'error) (f)) 5))
+(test-comp '(lambda (f g) (values (f)) (values (g)) (error 'error))
+           '(lambda (f g) ((f) (g) (error 'error)) 5))
+
+(test-comp '(lambda (f) (error 'error))
+           '(lambda (f) ((error 'error) (f) (f) (f)) 5))
+(test-comp '(lambda (f) (values (f)) (error 'error))
+           '(lambda (f) ((f) (error 'error) (f) (f)) 5))
+(test-comp '(lambda (f) (values (f)) (values (f)) (error 'error))
+           '(lambda (f) ((f) (f) (error 'error) (f)) 5))
+(test-comp '(lambda (f) (values (f)) (values (f)) (values (f)) (error 'error))
+           '(lambda (f) ((f) (f) (f) (error 'error)) 5))
+
+(test-comp '(lambda (f) (let ([x (error 'error)]) #f))
+           '(lambda (f) (let ([x (error 'error)]) (f x x)) 5))
+(test-comp '(lambda (f) (let ([x (error 'error)] [y #f]) #f))
+           '(lambda (f) (let ([x (error 'error)] [y (random)]) (f x x y y)) 5))
+(test-comp '(lambda (f) (let ([x (random)] [y (random)]) (f x x y y) (error 'error)))
+           '(lambda (f) (let ([x (random)] [y (random)]) (f x x y y) (error 'error)) 5))
+(test-comp '(lambda (f) (let-values ([(x) (error 'error)] [(y) #f] [(z) #f] ) #f))
+           '(lambda (f) (let-values ([(x) (error 'error)] [(y z) (f)]) (f x x y y z z)) 5))
+(test-comp '(lambda (f) (let-values ([(x) (error 'error)] [(y) #f] [(z) #f]) #f))
+           '(lambda (f) (let-values ([(x y) (values (error 'error) (random))] [(z) (f)]) (f x x y y z z)) 5))
+(test-comp '(lambda (f) (let-values ([(x) (begin (random) (error 'error))] [(y) #f] [(z) #f]) #f))
+           '(lambda (f) (let-values ([(x y) (values (random) (error 'error))] [(z) (f)]) (f x x y y z z)) 5))
+;alternative reduction:
+#;(test-comp '(lambda (f) (let-values ([(x) (random)] [(y) (error 'error)] [(z) #f]) #f))
+             '(lambda (f) (let-values ([(x y) (values (random) (error 'error))] [(z) (f)]) (f x x y y z z)) 5))
+
+(test-comp '(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)]) (f x y) (error 'error)))
+           '(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)]) (f x y) (error 'error)) 5))
+(test-comp '(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)] [z (error 'error)]) #f))
+           '(lambda (f) (letrec ([x (lambda() y)] [y (lambda () x)] [z (error 'error)]) (f x y z)) 5))
+(test-comp '(lambda (f) (letrec ([x (lambda() y)] [z (error 'error)] [y #f]) #f))
+           '(lambda (f) (letrec ([x (lambda() y)] [z (error 'error)] [y (lambda () x)]) (f x y z)) 5))
+(test-comp '(lambda (f) (letrec ([z (error 'error)] [x #f] [y #f]) #f))
+           '(lambda (f) (letrec ([z (error 'error)] [x (lambda() y)] [y (lambda () x)]) (f x y z)) 5))
+
+(test-comp `(module m racket/base
+              (define x 5)
+              (set! x 3)
+              (error 'error))
+           `(module m racket/base
+              (define x 5)
+              (set! x 3)
+              (set! x (error 'error))))
+
+(test-comp `(module m racket/base
+              (module bad racket/base
+                (error 'error))
+              (random)
+              5)
+           `(module m racket/base
+              (module bad racket/base
+                (error 'error))
+              (random))
+           #f)
+
+#;(test-comp `(module m racket/base
+              f
+              (error 'error))
+           `(module m racket/base
+              f
+              (error 'error)
+              (define f 5))
+           #f)
+           
+(test-comp `(module m racket/base
+              (define f 5)
+              (error 'error))
+           `(module m racket/base
+              (define f 5)
+              (error 'error)
+              (set! f 0))
+           #f)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check splitting of definitions
 (test-comp `(module m racket/base
diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c
index a9df8f7fb1..41d3c683d7 100644
--- a/racket/src/racket/src/optimize.c
+++ b/racket/src/racket/src/optimize.c
@@ -71,6 +71,9 @@ struct Optimize_Info
 
   /* Set by expression optimization: */
   int single_result, preserves_marks; /* negative means "tentative", due to fixpoint in progress */
+  int escapes; /* flag to signal that the expression allways escapes. When escapes is 1, it's assumed
+                  that single_result and preserves_marks are also 1, and that it's not necesary to
+                  use optimize_ignored before including the expression. */
 
   char **stat_dists; /* (pos, depth) => used? */
   int *sd_depths;
@@ -2209,6 +2212,15 @@ static int is_nonsaving_primitive(Scheme_Object *rator, int n)
   return 0;
 }
 
+static int is_allways_escaping_primitive(Scheme_Object *rator)
+{
+  if (SCHEME_PRIMP(rator)
+      && (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_ALWAYS_ESCAPES)) {
+        return 1;
+  }
+  return 0;
+}
+
 #define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm))
 
 static int wants_local_type_arguments(Scheme_Object *rator, int argpos)
@@ -2570,10 +2582,12 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
 
   /* Check for (apply ... (list ...)) early: */
   le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args], info);
-  if (le) return scheme_optimize_expr(le, info, context);
+  if (le)
+    return scheme_optimize_expr(le, info, context);
 
   le = check_app_let_rator(o, app->args[0], info, app->num_args, context);
-  if (le) return le;
+  if (le)
+    return le;
 
   n = app->num_args + 1;
 
@@ -2583,7 +2597,7 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
     if (!i) {
       le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 0);
       if (le)
-	return le;
+        return le;
     }
 
     sub_context = OPT_CONTEXT_SINGLED;
@@ -2597,6 +2611,25 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
     optimize_info_seq_step(info, &info_seq);
     le = scheme_optimize_expr(app->args[i], info, sub_context);
     app->args[i] = le;
+    if (info->escapes) {
+      int j;
+      Scheme_Object *e, *l;
+      optimize_info_seq_done(info, &info_seq);
+
+      l = scheme_make_pair(app->args[i], scheme_null);
+
+      for (j = i - 1; j >= 0; j--) {
+        e = app->args[j];
+        e = optimize_ignored(e, info, 0, 1, 1, 5);
+        if (e) {
+          if (!single_valued_noncm_expression(e, 5))
+            e = ensure_single_value(e);
+          l = scheme_make_pair(e, l);
+        }
+      }
+      return scheme_make_sequence_compilation(l, 1);
+    }
+
 
     if (!i) {
       /* Maybe found "((lambda" after optimizing; try again */
@@ -2672,6 +2705,10 @@ static Scheme_Object *finish_optimize_any_application(Scheme_Object *app, Scheme
 
   if (SAME_OBJ(rator, scheme_void_proc))
     return make_discarding_sequence(app, scheme_void, info, 0);
+  
+  if (is_allways_escaping_primitive(rator)) {
+    info->escapes = 1;
+  }
 
   return app;
 }
@@ -2895,7 +2932,8 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
   app = (Scheme_App2_Rec *)o;
 
   le = check_app_let_rator(o, app->rator, info, 1, context);
-  if (le) return le;
+  if (le)
+    return le;
 
   le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 0);
   if (le)
@@ -2907,6 +2945,10 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
 
   le = scheme_optimize_expr(app->rator, info, sub_context);
   app->rator = le;
+  if (info->escapes) {
+    optimize_info_seq_done(info, &info_seq);
+    return app->rator;
+  }
 
   {
     /* Maybe found "((lambda" after optimizing; try again */
@@ -2927,8 +2969,11 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
 
   le = scheme_optimize_expr(app->rand, info, sub_context);
   app->rand = le;
-
   optimize_info_seq_done(info, &info_seq);
+  if (info->escapes) {
+    info->size += 1;
+    return make_discarding_first_sequence(app->rator, app->rand, info, 0);
+  }
 
   return finish_optimize_application2(app, info, context, rator_flags);
 }
@@ -3203,10 +3248,12 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
 
   /* Check for (apply ... (list ...)) early: */
   le = direct_apply((Scheme_Object *)app, app->rator, app->rand2, info);
-  if (le) return scheme_optimize_expr(le, info, context);
+  if (le)
+    return scheme_optimize_expr(le, info, context);
 
   le = check_app_let_rator(o, app->rator, info, 2, context);
-  if (le) return le;
+  if (le) 
+    return le;
 
   le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 0);
   if (le)
@@ -3218,6 +3265,10 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
 
   le = scheme_optimize_expr(app->rator, info, sub_context);
   app->rator = le;
+  if (info->escapes) {
+    optimize_info_seq_done(info, &info_seq);
+    return app->rator;
+  }
 
   {
     /* Maybe found "((lambda" after optimizing; try again */
@@ -3236,6 +3287,10 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
 
   le = scheme_optimize_expr(app->rand1, info, sub_context);
   app->rand1 = le;
+  if (info->escapes) {
+    info->size += 1;
+    return make_discarding_first_sequence(app->rator, app->rand1, info, 0);
+  }
 
   /* 2nd arg */
 
@@ -3249,8 +3304,14 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
 
   le = scheme_optimize_expr(app->rand2, info, sub_context);
   app->rand2 = le;
-
   optimize_info_seq_done(info, &info_seq);
+  if (info->escapes) {
+    info->size += 1;
+    return make_discarding_first_sequence(app->rator,
+                                          make_discarding_first_sequence(app->rand1, app->rand2,
+                                                                         info, 0),
+                                             info, 0);
+  }
 
   /* Check for (apply ... (list ...)) after some optimizations: */
   le = direct_apply((Scheme_Object *)app, app->rator, app->rand2, info);
@@ -3606,7 +3667,7 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i
   Optimize_Info_Sequence info_seq;
 
   optimize_info_seq_init(info, &info_seq);
-
+  
   count = s->count;
   for (i = 0; i < count; i++) {
     prev_size = info->size;
@@ -3616,21 +3677,35 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i
                               ((i + 1 == count)
                                ? scheme_optimize_tail_context(context)
                                : 0));
-    if (i == s->count - 1) {
+
+    if (i + 1 == count) {
       single_result = info->single_result;
       preserves_marks = info->preserves_marks;
-    }
-
-    /* Inlining and constant propagation can expose omittable expressions. */
-    if (i + 1 != count)
-      le = optimize_ignored(le, info, 0, -1, 1, 5);
-
-    if (!le) {
-      drop++;
-      info->size = prev_size;
-      s->array[i] = NULL;
-    } else {
       s->array[i] = le;
+    } else {
+      if (!info->escapes) {
+        /* Inlining and constant propagation can expose omittable expressions. */
+        le = optimize_ignored(le, info, 0, -1, 1, 5);
+        if (!le) {
+          drop++;
+          info->size = prev_size;
+          s->array[i] = NULL;
+        } else {
+          s->array[i] = le;
+        }
+      } else {
+        int j;
+        
+        single_result = info->single_result;
+        preserves_marks = info->preserves_marks;
+        /* Move to last position in case the begin form is droped */
+        s->array[count - 1] = le;
+        for (j = i; j < count - 1; j++) {
+          drop++;
+          s->array[j] = NULL;
+        }
+        break;
+      }
     }
   }
 
@@ -3784,13 +3859,26 @@ static void add_types(Scheme_Object *t, Optimize_Info *info, int fuel)
   }
 }
 
+static int or_tentative(int x, int y)
+{
+  if (x && y) {
+    if ((x < 0) || (y < 0))
+      return -1;
+    else
+      return 1;
+  } else {
+    return 0;
+  }
+}
+
 static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int context)
 {
   Scheme_Branch_Rec *b;
   Scheme_Object *t, *tb, *fb;
-  Scheme_Hash_Tree *old_types;
-  int preserves_marks = 1, single_result = 1, init_vclock, init_kclock, init_sclock;
-  int same_then_vclock, then_kclock, then_sclock;
+  Scheme_Hash_Tree *init_types, *then_types;
+  int init_vclock, init_kclock, init_sclock;
+  int then_escapes, then_preserves_marks, then_single_result;
+  int then_vclock, then_kclock, then_sclock;
   Optimize_Info_Sequence info_seq;
 
   b = (Scheme_Branch_Rec *)o;
@@ -3823,6 +3911,11 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
 
   t = scheme_optimize_expr(t, info, OPT_CONTEXT_BOOLEAN | OPT_CONTEXT_SINGLED);
 
+  if (info->escapes) {
+    optimize_info_seq_done(info, &info_seq);
+    return t;
+  }
+
   /* Try to lift out `let`s and `begin`s around a test: */
   {
     Scheme_Object *inside = NULL, *t2 = t;
@@ -3893,29 +3986,25 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
   optimize_info_seq_step(info, &info_seq);
 
   info->vclock += 1; /* model branch as clock increment */
+
   init_vclock = info->vclock;
   init_kclock = info->kclock;
   init_sclock = info->sclock;
+  init_types = info->types;
 
-  old_types = info->types;
   add_types(t, info, 5);
 
   tb = scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context));
 
-  if (!info->preserves_marks)
-    preserves_marks = 0;
-  else if (info->preserves_marks < 0)
-    preserves_marks = -1;
-  if (!info->single_result)
-    single_result = 0;
-  else if (info->single_result < 0)
-    single_result = -1;
-
-  same_then_vclock = (init_vclock == info->vclock);
-
-  info->types = old_types;
+  then_types = info->types;
+  then_preserves_marks = info->preserves_marks;
+  then_single_result = info->single_result;
+  then_escapes = info->escapes;
+  then_vclock = info->vclock;
   then_kclock = info->kclock;
   then_sclock = info->sclock;
+
+  info->types = init_types;
   info->vclock = init_vclock;
   info->kclock = init_kclock;
   info->sclock = init_sclock;
@@ -3924,31 +4013,42 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
 
   fb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context));
 
-  if (!info->preserves_marks)
-    preserves_marks = 0;
-  else if (preserves_marks && (info->preserves_marks < 0))
-    preserves_marks = -1;
-  if (!info->single_result)
-    single_result = 0;
-  else if (single_result && (info->single_result < 0))
-    single_result = -1;
+  if (info->escapes && then_escapes) {
+    /* both branches escaped */
+    info->preserves_marks = 1;
+    info->single_result = 1;
+    info->kclock = init_kclock;
+    info->types = init_types; /* not sure if this is necesary */
 
-  if (then_kclock > info->kclock)
+  } else if (info->escapes) {
+    info->preserves_marks = then_preserves_marks;
+    info->single_result = then_single_result;
     info->kclock = then_kclock;
+    info->types = then_types;
+    info->escapes = 0;
+
+  } else if (then_escapes) {
+    info->escapes = 0;
+
+  } else {
+    then_preserves_marks = or_tentative(then_preserves_marks, info->preserves_marks);
+    info->preserves_marks = then_preserves_marks;
+    then_single_result = or_tentative(then_single_result, info->single_result);
+    info->single_result = then_single_result;
+    if (then_kclock > info->kclock)
+      info->kclock = then_kclock;
+    info->types = init_types; /* could try to take an intersection here ... */
+  }
+
   if (then_sclock > info->sclock)
     info->sclock = then_sclock;
 
-  info->types = old_types; /* could try to take an intersection here ... */
-
-  if (same_then_vclock && (init_vclock == info->vclock)) {
+  if ((init_vclock == then_vclock) && (init_vclock == info->vclock)) {
     /* we can rewind the vclock to just after the test, because the
        `if` as a whole has no effect */
     info->vclock--;
   }
 
-  info->preserves_marks = preserves_marks;
-  info->single_result = single_result;
-
   optimize_info_seq_done(info, &info_seq);
 
   /* Try optimize: (if x x #f) => x */
@@ -4023,10 +4123,21 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co
 
   k = scheme_optimize_expr(wcm->key, info, OPT_CONTEXT_SINGLED);
 
+  if (info->escapes) {
+    optimize_info_seq_done(info, &info_seq);
+    return k;
+  }
+
   optimize_info_seq_step(info, &info_seq);
 
   v = scheme_optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED);
 
+  if (info->escapes) {
+    optimize_info_seq_done(info, &info_seq);
+    info->size += 1;
+    return make_discarding_first_sequence(k, v, info, 0);
+  }
+
   /* The presence of a key can be detected by other expressions,
      to increment vclock to prevent expressions incorrectly
      moving under the mark: */
@@ -4090,6 +4201,9 @@ set_optimize(Scheme_Object *data, Optimize_Info *info, int context)
 
   val = scheme_optimize_expr(val, info, OPT_CONTEXT_SINGLED);
 
+  if (info->escapes)
+      return val;
+
   info->preserves_marks = 1;
   info->single_result = 1;
 
@@ -4226,12 +4340,21 @@ apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context)
 
   f = scheme_optimize_expr(f, info, OPT_CONTEXT_SINGLED);
 
+  if (info->escapes) {
+    optimize_info_seq_done(info, &info_seq);
+    return f;
+  }
   optimize_info_seq_step(info, &info_seq);
 
   e = scheme_optimize_expr(e, info, 0);
 
   optimize_info_seq_done(info, &info_seq);
 
+  if (info->escapes) {
+    info->size += 1;
+    return make_discarding_first_sequence(f, e, info, 0);
+  }
+
   info->size += 1;
   info->vclock += 1;
   info->kclock += 1;
@@ -4398,23 +4521,70 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context)
       preserves_marks = info->preserves_marks;
       kclock = info->kclock;
       sclock = info->sclock;
+      s->array[0] = le;
+    } else {
+      /* Inlining and constant propagation can expose omittable expressions: */
+      le = optimize_ignored(le, info, 0, -1, 1, 5);
+      if (!le) {
+        drop++;
+        info->size = prev_size;
+        s->array[i] = NULL;
+      } else {
+        s->array[i] = le;
+      }
     }
 
-    /* Inlining and constant propagation can expose omittable expressions: */
-    if (i)
-      le = optimize_ignored(le, info, 0, -1, 1, 5);
-
-    if (!le) {
-      drop++;
-      info->size = prev_size;
-      s->array[i] = NULL;
-    } else {
-      s->array[i] = le;
+    if (info->escapes) {
+      int j;
+      single_result = info->single_result;
+      preserves_marks = info->preserves_marks;
+      for (j = i + 1; j < count; j++) {
+        drop++;
+        s->array[j] = NULL;
+      }
+      break;
     }
   }
 
   optimize_info_seq_done(info, &info_seq);
 
+  if (info->escapes) {
+    /* In case of an error, optimize (begin0 ... <error> ...) => (begin ... <error>) */
+    Scheme_Sequence *s2;
+    int j = 0;
+
+    info->single_result = 1;
+    info->preserves_marks = 1;
+
+    if (i != 0) {
+      /* We will ignore the first expresion too */
+      le = optimize_ignored(s->array[0], info, 0, -1, 1, 5);
+      if (!le) {
+        drop++;
+        info->size = prev_size;
+        s->array[0] = NULL;
+      } else {
+        s->array[0] = le;
+      }
+    }
+
+    if ((count - drop) == 1) {
+      /* If it's only one expression we can drop the begin0 */
+      return s->array[i];
+    }
+
+    s2 = scheme_malloc_sequence(count - drop);
+    s2->so.type = scheme_sequence_type;
+    s2->count = count - drop;
+
+    for (i = 0; i < count; i++) {
+      if (s->array[i]) {
+        s2->array[j++] = s->array[i];
+      }
+    }
+    return (Scheme_Object *)s2;
+  }
+
   info->preserves_marks = 1;
   info->single_result = single_result;
 
@@ -4454,7 +4624,8 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context)
           s2->array[j++] = s->array[i];
         }
       }
-      s2->array[j++] = expr;
+      if (!info->escapes)
+        s2->array[j++] = expr;
 
       expr = (Scheme_Object *)s2;
     }
@@ -5044,7 +5215,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
   Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start;
   Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL, *once_used;
   int i, j, pos, is_rec, not_simply_let_star = 0, undiscourage, split_shift, skip_opts = 0;
-  int did_set_value, checked_once, skip_depth, unused_clauses;
+  int did_set_value, checked_once, skip_depth, unused_clauses, found_escapes;
   int remove_last_one = 0, inline_fuel, rev_bind_order;
   int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
 
@@ -5107,15 +5278,15 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
         && (((Scheme_Local *)clv->body)->position == 0)) {
       if (worth_lifting(clv->value)) {
         if (post_bind) {
-	  /* Just drop the let */
-	  return scheme_optimize_expr(clv->value, info, context);
+          /* Just drop the let */
+          return scheme_optimize_expr(clv->value, info, context);
 	} else {
-	  info = optimize_info_add_frame(info, 1, 0, 0);
-	  body = scheme_optimize_expr(clv->value, info, context);
+          info = optimize_info_add_frame(info, 1, 0, 0);
+          body = scheme_optimize_expr(clv->value, info, context);
           info->next->single_result = info->single_result;
           info->next->preserves_marks = info->preserves_marks;
-	  optimize_info_done(info, NULL);
-	  return body;
+          optimize_info_done(info, NULL);
+          return body;
 	}
       }
     }
@@ -5299,6 +5470,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
   retry_start = NULL;
   ready_pairs_start = NULL;
   did_set_value = 0;
+  found_escapes = 0;
   for (i = head->num_clauses; i--; ) {
     pre_body = (Scheme_Compiled_Let_Value *)body;
     pos = pre_body->position;
@@ -5331,12 +5503,24 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
     }
 
     if (!skip_opts) {
-      optimize_info_seq_step(rhs_info, &info_seq);
-      value = scheme_optimize_expr(pre_body->value, rhs_info,
-                                   ((pre_body->count == 1)
-                                    ? OPT_CONTEXT_SINGLED
-                                    : 0));
-      pre_body->value = value;
+      if (!found_escapes) {
+        optimize_info_seq_step(rhs_info, &info_seq);
+        value = scheme_optimize_expr(pre_body->value, rhs_info,
+                                     ((pre_body->count == 1)
+                                      ? OPT_CONTEXT_SINGLED
+                                      : 0));
+        pre_body->value = value;
+        if (rhs_info->escapes)
+          found_escapes = 1;
+      } else {
+        optimize_info_seq_step(rhs_info, &info_seq);
+        value = scheme_false;
+        pre_body->value = value;
+        body_info->single_result = 1;
+        body_info->preserves_marks = 1;
+        body_info->escapes = 1;
+        body_info->size++;
+      }
     } else {
       value = pre_body->value;
       --skip_opts;
@@ -5366,7 +5550,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
        !rev_bind_order, so checks are needed to make sure that's ok. */
     skip_depth = (is_rec ? (pre_body->position + pre_body->count) : 0);
     if ((pre_body->count != 1)
-        && is_values_apply(value, pre_body->count, rhs_info, skip_depth, 1)
+        && (found_escapes
+            || (is_values_apply(value, pre_body->count, rhs_info, skip_depth, 1)
         && ((!is_rec && no_mutable_bindings(pre_body)
              && (rev_bind_order
                  /* When !rev_bind_order, the transformation reorders the arguments
@@ -5378,7 +5563,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
                an identifier in a way that could expose reordering: */
             || scheme_omittable_expr(value, pre_body->count, -1, 0, rhs_info, info,
                                      skip_depth, 0,
-                                     rev_bind_order ? ID_OMIT : NO_MUTABLE_ID_OMIT))) {
+                                     rev_bind_order ? ID_OMIT : NO_MUTABLE_ID_OMIT))))) {
       if (!pre_body->count && !i) {
         /* We want to drop the clause entirely, but doing it
            here messes up the loop for letrec. So wait and
@@ -5421,7 +5606,20 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
         }
 
         naya = (Scheme_Compiled_Let_Value *)rest;
-        unpack_values_application(value, naya, rev_bind_order, rhs_info, NULL);
+        if (!found_escapes) {
+          unpack_values_application(value, naya, rev_bind_order, rhs_info, NULL);
+        } else {
+          Scheme_Compiled_Let_Value *naya2 = naya;
+          int i;
+          for (i = 0; i < pre_body->count; i++) {
+            if (!i)
+              naya2->value = value;
+            else
+              naya2->value = scheme_false;
+            naya2 = (Scheme_Compiled_Let_Value *)naya2->body;
+          }
+        }
+
         if (prev_body)
           prev_body->body = (Scheme_Object *)naya;
         else
@@ -5430,7 +5628,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
         i += (pre_body->count - 1);
         if (pre_body->count) {
           /* We're backing up. Since the RHSs have been optimized
-             already, don re-optimize. */
+             already, don't re-optimize. */
           skip_opts = pre_body->count - 1;
           pre_body = naya;
           body = (Scheme_Object *)naya;
@@ -5513,7 +5711,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
           cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
 
         optimize_propagate(body_info, pos, value, cnt == 1);
-	did_set_value = 1;
+        did_set_value = 1;
         checked_once = 1;
       } else if (value && !is_rec) {
         int cnt, ct;
@@ -5589,8 +5787,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
       Scheme_Object *prop_later = NULL;
 
       if (did_set_value) {
-	/* Next RHS ends a reorderable sequence.
-	   Re-optimize from retry_start to pre_body, inclusive.
+        /* Next RHS ends a reorderable sequence.
+           Re-optimize from retry_start to pre_body, inclusive.
            For procedures, assume CLOS_SINGLE_RESULT and CLOS_PRESERVES_MARKS for all,
            but then assume not for all if any turn out not (i.e., approximate fix point). */
         int flags;
@@ -5609,17 +5807,17 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
         /* Re-optimize loop: */
         clv = retry_start;
         cl = clones;
-	while (1) {
-	  value = clv->value;
+        while (1) {
+         value = clv->value;
           if (cl) {
             cl_first = SCHEME_CAR(cl);
             if (!cl_first)
               cl = SCHEME_CDR(cl);
           } else
             cl_first = NULL;
-	  if (cl_first && SAME_OBJ(value, SCHEME_CAR(cl_first))) {
+          if (cl_first && SAME_OBJ(value, SCHEME_CAR(cl_first))) {
             /* Try optimization. */
-	    Scheme_Object *self_value;
+            Scheme_Object *self_value;
             int sz;
             char use_psize;
 
@@ -5631,7 +5829,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
             }
 
             cl = SCHEME_CDR(cl);
-	    self_value = SCHEME_CDR(cl_first);
+            self_value = SCHEME_CDR(cl_first);
 
             /* Drop old size, and remove old inline fuel: */
             sz = compiled_proc_body_size(value, 0);
@@ -5754,7 +5952,15 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
   } else if (split_shift)
     optimize_info_done(rhs_info, body_info);
 
-  body = scheme_optimize_expr(body, body_info, scheme_optimize_tail_context(context));
+  if (!found_escapes) {
+    body = scheme_optimize_expr(body, body_info, scheme_optimize_tail_context(context));
+  } else {
+    body = scheme_false;
+    body_info->single_result = 1;
+    body_info->preserves_marks = 1;
+    body_info->escapes = 1;
+    body_info->size++;
+  }
   if (head->num_clauses)
     pre_body->body = body;
   else
@@ -6021,6 +6227,7 @@ optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int cont
   info->vclock = init_vclock;
   info->kclock = init_kclock;
   info->sclock = init_sclock;
+  info->escapes = 0;
 
   info->size++;
 
@@ -6884,6 +7091,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
 
   optimize_info_seq_done(info, &info_seq);
 
+  info->escapes = 0;
+
   return data;
 }
 
@@ -6929,6 +7138,7 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in
 
   info->preserves_marks = 1;
   info->single_result = 1;
+  info->escapes = 0;
 
   switch (type) {
   case scheme_local_type:
@@ -8140,6 +8350,7 @@ static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int
   naya->vclock = info->vclock;
   naya->kclock = info->kclock;
   naya->sclock = info->sclock;
+  naya->escapes = info->escapes;
   naya->init_kclock = info->kclock;
   naya->use_psize = info->use_psize;
   naya->logger = info->logger;
@@ -8174,6 +8385,7 @@ static void optimize_info_done(Optimize_Info *info, Optimize_Info *parent)
   parent->vclock = info->vclock;
   parent->kclock = info->kclock;
   parent->sclock = info->sclock;
+  parent->escapes = info->escapes;
   parent->psize += info->psize;
   parent->shift_fuel = info->shift_fuel;
   if (info->has_nonleaf)