fix letrec compilation when call/cc is used on the RHS of something that otherwise looks like it could be let*; add #%in annotations to decompiler output

svn: r11329

collects/compiler/decompile.ss

@@ -237,10 +237,11 @@
     [(struct application (rator rands))
      (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
                           stack)])
+       (annotate-inline
         `(,(decompile-expr rator globs stack)
           ,@(map (lambda (rand)
                    (decompile-expr rand globs stack))
-                rands)))]
+                 rands))))]
     [(struct apply-values (proc args-expr))
      `(#%apply-values ,(decompile-expr proc globs stack) 
                       ,(decompile-expr args-expr globs stack))]
@@ -284,6 +285,28 @@
          ,(decompile-expr body globs (append captures
                                              (append vars rest-vars)))))]))
 
+(define (annotate-inline a)
+  (if (and (symbol? (car a))
+           (case (length a)
+             [(2) (memq (car a) '(not null? pair? mpair? symbol?
+                                      syntax? char? boolean?
+                                      number? real? exact-integer?
+                                      fixnum? inexact-real?
+                                      procedure? vector? box? string? bytes? eof-object?
+                                      zero? negative? exact-nonnegative-integer?  
+                                      exact-positive-integer?
+                                      car cdr caar cadr cdar cddr
+                                      mcar mcdr unbox syntax-e
+                                      add1 sub1 - abs bitwise-not))]
+             [(3) (memq (car a) '(eq? = <= < >= >
+                                      bitwise-bit-set? char=?
+                                      + - * / min max bitwise-and bitwise-ior
+                                      arithmetic-shift vector-ref string-ref bytes-ref
+                                      set-mcar! set-mcdr! cons mcons))]
+             [(4) (memq (car a) '(vector-set! string-set! bytes-set!))]))
+      (cons '#%in a)
+      a))
+
 ;; ----------------------------------------
 
 #;

collects/scribblings/mzc/decompile.scrbl

@@ -32,8 +32,7 @@ Many forms in the decompiled code, such as @scheme[module],
  variable will be defined before the access.
 
  Uses of core primitives are shown without a leading @litchar{_}, and
- they are never wrapped with @schemeidfont{#%checked}. Applications of
+ they are never wrapped with @schemeidfont{#%checked}.}
- some primitives are inlined by the JIT compiler.}
 
  @item{Local-variable access may be wrapped with
  @schemeidfont{#%sfs-clear}, which indicates that the variable-stack
@@ -70,6 +69,12 @@ Many forms in the decompiled code, such as @scheme[module],
  it may even contain cyclic references to itself or other constant
  closures.}
 
+ @item{Some applications of core primitives are annotated with
+ @schemeidfont{#%in}, which indicates that the JIT compiler will
+ inline the operation. (Inlining information is not part of the
+ bytecode, but is instead based on an enumeration of primitives that
+ the JIT is known to handle specially.)}
+
  @item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to
  @scheme[(call-with-values (lambda () _expr) _proc)], but the run-time
  system avoids allocating a closure for @scheme[_expr].}

collects/tests/mzscheme/basic.ss

@@ -1827,6 +1827,13 @@
               (void)))
         count))
 
+;; Letrec must allocate early, though:
+(test #f 'letrec+call/cc
+      (letrec ((x (call-with-current-continuation list)))
+        (if (pair? x)
+            ((car x) (lambda () x))
+            (pair? (x)))))
+
 (arity-test call/cc 1 2)
 (arity-test call/ec 1 1)
 (err/rt-test (call/cc 4))

src/mzscheme/src/syntax.c

@@ -2719,11 +2719,24 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
 /*                  let, let-values, letrec, etc.                     */
 /**********************************************************************/
 
-static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
+static int is_liftable_prim(Scheme_Object *v)
+{
+  if (SCHEME_PRIMP(v)) {
+    if ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK)
+        >= SCHEME_PRIM_OPT_IMMEDIATE)
+      return 1;
+  }
+
+  return 0;
+}
+
+static int is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator)
 {
   Scheme_Type t = SCHEME_TYPE(o);
 
   switch (t) {
+  case scheme_compiled_unclosed_procedure_type:
+    return !as_rator;
   case scheme_compiled_toplevel_type:
     return 1;
   case scheme_local_type:
@@ -2733,9 +2746,9 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
   case scheme_branch_type:
     if (fuel) {
       Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o;
-      if (is_liftable(b->test, bind_count, fuel - 1)
+      if (is_liftable(b->test, bind_count, fuel - 1, 0)
-	  && is_liftable(b->tbranch, bind_count, fuel - 1)
+	  && is_liftable(b->tbranch, bind_count, fuel - 1, as_rator)
-	  && is_liftable(b->fbranch, bind_count, fuel - 1))
+	  && is_liftable(b->fbranch, bind_count, fuel - 1, as_rator))
 	return 1;
     }
     break;
@@ -2743,8 +2756,12 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
     {
       Scheme_App_Rec *app = (Scheme_App_Rec *)o;
       int i;
+      if (!is_liftable_prim(app->args[0]))
+        return 0;
+      if (bind_count >= 0)
+        bind_count += app->num_args;
       for (i = app->num_args + 1; i--; ) {
-	if (!is_liftable(app->args[i], bind_count + app->num_args, fuel - 1))
+	if (!is_liftable(app->args[i], bind_count, fuel - 1, 1))
 	  return 0;
       }
       return 1;
@@ -2752,16 +2769,24 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
   case scheme_application2_type:
     {
       Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
-      if (is_liftable(app->rator, bind_count + 1, fuel - 1)
+      if (!is_liftable_prim(app->rator))
-	  && is_liftable(app->rand, bind_count + 1, fuel - 1))
+        return 0;
+      if (bind_count >= 0)
+        bind_count += 1;
+      if (is_liftable(app->rator, bind_count, fuel - 1, 1)
+	  && is_liftable(app->rand, bind_count, fuel - 1, 1))
 	return 1;
     }
   case scheme_application3_type:
     {
       Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
-      if (is_liftable(app->rator, bind_count + 2, fuel - 1)
+      if (!is_liftable_prim(app->rator))
-	  && is_liftable(app->rand1, bind_count + 2, fuel - 1)
+        return 0;
-	  && is_liftable(app->rand2, bind_count + 2, fuel - 1))
+      if (bind_count >= 0)
+        bind_count += 2;
+      if (is_liftable(app->rator, bind_count, fuel - 1, 1)
+	  && is_liftable(app->rand1, bind_count, fuel - 1, 1)
+	  && is_liftable(app->rand2, bind_count, fuel - 1, 1))
 	return 1;
     }
   default:
@@ -2915,6 +2940,11 @@ static int expr_size(Scheme_Object *o)
     return 1;
 }
 
+static int might_invoke_call_cc(Scheme_Object *value)
+{
+  return !is_liftable(value, -1, 10, 0);
+}
+
 Scheme_Object *
 scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
 {
@@ -3010,7 +3040,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
 
     if (is_rec && !not_simply_let_star) {
       /* Keep track of whether we can simplify to let*: */
-      if (scheme_optimize_any_uses(rhs_info, pos, head->count))
+      if (might_invoke_call_cc(value)
+          || scheme_optimize_any_uses(rhs_info, pos, head->count))
         not_simply_let_star = 1;
     }
 
@@ -3103,7 +3134,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
 	&& !body_info->letrec_not_twice
 	&& ((i < 1) 
 	    || (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1, 1)
-		&& !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5)))) {
+		&& !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5, 1)))) {
       if (did_set_value) {
 	/* Next RHS ends a reorderable sequence. 
 	   Re-optimize from retry_start to pre_body, inclusive.
@@ -3420,7 +3451,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
         if (is_proc)
           is_lift = 0;
         else
-          is_lift = is_liftable(clv->value, head->count, 5);
+          is_lift = is_liftable(clv->value, head->count, 5, 1);
       
         if (!is_proc && !is_lift) {
           recbox = 1;