optimizer: add hidden list-pair? primitive

This is useful in the optimizer to track simultaneously the list? and pair?
types of an expression.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.4.0.14")
+(define version "6.4.0.15")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-test-core/tests/racket/basic.rktl

@@ -4,7 +4,8 @@
 (Section 'basic)
 
 (require racket/flonum
-         racket/function)
+         racket/function
+         (only-in '#%kernel (list-pair? k:list-pair?)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -148,6 +149,13 @@
 (test #f pair? '#(a b))
 (arity-test pair? 1 1)
 
+(test #f k:list-pair? '(a . b))
+(test #f k:list-pair? '(a . 1))
+(test #t k:list-pair? '(a b c))
+(test #f k:list-pair? '())
+(test #f k:list-pair? '#(a b))
+(arity-test k:list-pair? 1 1)
+
 (test '(a) cons 'a '())
 (test '((a) b c d) cons '(a) '(b c d))
 (test '("a" b c) cons "a" '(b c))

pkgs/racket-test-core/tests/racket/optimize.rktl

@@ -12,7 +12,8 @@
          compiler/zo-marshal
          ;; `random` from `racket/base is a Racket function, which makes
          ;; compilation less predictable than a primitive
-         (only-in '#%kernel random))
+         (only-in '#%kernel random
+                            (list-pair? k:list-pair?)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -24,6 +25,7 @@
   (namespace-require 'racket/fixnum)
   (namespace-require 'racket/unsafe/ops)
   (namespace-require 'racket/unsafe/undefined)
+  (namespace-require '(rename '#%kernel k:list-pair? list-pair?))
   (eval '(define-values (prop:thing thing? thing-ref) 
            (make-struct-type-property 'thing)))
   (eval '(struct rock (x) #:property prop:thing 'yes))
@@ -35,7 +37,7 @@
                                             #:first-arg [first-arg #f]
                                             #:second-arg [second-arg #f])
 				(unless (memq name '(eq? eqv? equal? 
-                                                         not null? pair? list?
+                                                         not null? pair? list? k:list-pair?
 							 real? number? boolean?
 							 procedure? symbol? keyword?
 							 string? bytes?
@@ -198,6 +200,11 @@
     (un #f 'list? '(1 2 . 3))
     (un-exact #t 'list? '(1 2 3))
     (un-exact 3 'length '(1 2 3))
+    (un #f 'k:list-pair? 0)
+    (un #f 'k:list-pair? '())
+    (un #f 'k:list-pair? '(1 . 2))
+    (un-exact #t 'k:list-pair? '(1))
+    (un-exact #t 'k:list-pair? '(1 2))
     (un #f 'boolean? 0)
     (un #t 'boolean? #t)
     (un #t 'boolean? #f)
@@ -904,7 +911,7 @@
       ;; Give `s` a minimal location, so that other macro locations
       ;; don't bleed through:
       (datum->syntax #f s (vector 'here #f #f #f #f)))
-    (test same? `(compile ,same? ,expr2) (comp=? (compile (->stx expr1)) (compile (->stx expr2)) same?))]))
+    (test same? `(compile ,same? (,expr1 => ,expr2)) (comp=? (compile (->stx expr1)) (compile (->stx expr2)) same?))]))
 
 (let ([x (compile '(lambda (x) x))])
   (test #t 'fixpt (eq? x (compile x))))
@@ -2852,6 +2859,7 @@
   (test-pred 'pair?)
   (test-pred 'mpair?)
   (test-pred 'list?)
+  (test-pred 'k:list-pair?)
   (test-pred 'box?)
   (test-pred 'number?)
   (test-pred 'real?)
@@ -2881,6 +2889,146 @@
   (test-pred 'immutable?)
   (test-pred 'not))
 
+(let ([test-implies
+       (lambda (pred1 pred2 [val '=>])
+         (cond
+           [(eq? val '=>) 
+            (test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
+                       `(lambda (z) (when (,pred1 z) #t)))
+            (test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
+                       `(lambda (z) (when (,pred2 z) #t))
+                       #f)
+            (test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
+                       `(lambda (z) (when (,pred2 z) #f))
+                       #f)]
+           [(eq? val '!=) 
+            (test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
+                       `(lambda (z) (when (,pred1 z) #f)))
+            (test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
+                       `(lambda (z) (when (,pred2 z) #f)))]
+            [(eq? val '?) 
+            (test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
+                       `(lambda (z) (when (,pred1 z) #t))
+                       #f)
+            (test-comp `(lambda (z) (when (,pred1 z) (,pred2 z)))
+                       `(lambda (z) (when (,pred1 z) #f))
+                       #f)
+            (test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
+                       `(lambda (z) (when (,pred2 z) #t))
+                       #f)
+            (test-comp `(lambda (z) (when (,pred2 z) (,pred1 z)))
+                       `(lambda (z) (when (,pred2 z) #f))
+                       #f)]
+            [else
+              (test '= (list pred1 pred2 val) 'bad-option)]))])
+
+  (test-implies 'null? 'k:list-pair? '!=)
+  (test-implies 'null? 'pair? '!=)
+  (test-implies 'null? 'list?)
+  (test-implies 'k:list-pair? 'pair?)
+  (test-implies 'k:list-pair? 'list?)
+  (test-implies 'list? 'pair? '?)
+)
+
+(test-comp '(lambda (z)
+              (when (and (list? z)
+                         (pair? z))
+                (k:list-pair? z)))
+           '(lambda (z)
+              (when (and (list? z)
+                         (pair? z))
+                #t)))
+(test-comp '(lambda (z)
+              (when (and (list? z)
+                         (not (null? z)))
+                (k:list-pair? z)))
+           '(lambda (z)
+              (when (and (list? z)
+                         (not (null? z)))
+                #t)))
+(test-comp '(lambda (z)
+              (when (and (list? z)
+                         (not (pair? z)))
+                (null? z)))
+           '(lambda (z)
+              (when (and (list? z)
+                         (not (pair? z)))
+                #t)))
+(test-comp '(lambda (z)
+              (when (and (list? z)
+                         (not (k:list-pair? z)))
+                (null? z)))
+           '(lambda (z)
+              (when (and (list? z)
+                         (not (k:list-pair? z)))
+                #t)))
+                      
+
+(let ([test-reduce
+       (lambda (pred-name expr [val #t])
+         (test-comp `(list ',pred-name (,pred-name ,expr))
+                    `(list ',pred-name ,val))
+         (test-comp `(let ([e ,expr])
+                       (list ',pred-name e e (,pred-name e)))
+                    `(let ([e ,expr])
+                       (list ',pred-name e e ,val))))])
+  (test-reduce 'list? 0 #f)
+  (test-reduce 'list? ''())
+  (test-reduce 'list? ''(1))
+  (test-reduce 'list? ''(1 2))
+  #;(test-reduce 'list? ''(1 . 2) #f)
+  (test-reduce 'list? '(list))
+  (test-reduce 'list? '(list 1))
+  (test-reduce 'list? '(list 1 2))
+  #;(test-reduce 'list? '(cons 1 2) #f)
+  (test-reduce 'list? '(cons 1 null))
+  (test-reduce 'list? '(cons 1 (list 2 3)))
+  (test-reduce 'list? '(cdr (list 1 2)))
+  (test-reduce 'list? '(cdr (list 1)))
+
+  (test-reduce 'null? 0 #f)
+  (test-reduce 'null? ''())
+  (test-reduce 'null? ''(1) #f)
+  (test-reduce 'null? ''(1 2) #f)
+  (test-reduce 'null? ''(1 . 2) #f)
+  (test-reduce 'null? '(list))
+  (test-reduce 'null? '(list 1) #f)
+  (test-reduce 'null? '(list 1 2) #f)
+  (test-reduce 'null? '(cons 1 2) #f)
+  (test-reduce 'null? '(cons 1 null) #f)
+  (test-reduce 'null? '(cons 1 (list 2 3)) #f)
+  (test-reduce 'null? '(cdr (list 1 2)) #f)
+  (test-reduce 'null? '(cdr (list 1)))
+
+  (test-reduce 'pair? 0 #f)
+  (test-reduce 'pair? ''() #f)
+  (test-reduce 'pair? ''(1))
+  (test-reduce 'pair? ''(1 2))
+  (test-reduce 'pair? ''(1 . 2))
+  (test-reduce 'pair? '(list) #f)
+  (test-reduce 'pair? '(list 1))
+  (test-reduce 'pair? '(list 1 2))
+  (test-reduce 'pair? '(cons 1 2))
+  (test-reduce 'pair? '(cons 1 null))
+  (test-reduce 'pair? '(cons 1 (list 2 3)))
+  (test-reduce 'pair? '(cdr (list 1 2)))
+  (test-reduce 'pair? '(cdr (list 1)) #f)
+
+  (test-reduce 'k:list-pair? 0 #f)
+  (test-reduce 'k:list-pair? ''() #f)
+  (test-reduce 'k:list-pair? ''(1))
+  (test-reduce 'k:list-pair? ''(1 2))
+  #;(test-reduce 'k:list-pair? ''(1 . 2) #f)
+  (test-reduce 'k:list-pair? '(list) #f)
+  (test-reduce 'k:list-pair? '(list 1))
+  (test-reduce 'k:list-pair? '(list 1 2))
+  #;(test-reduce 'k:list-pair? '(cons 1 2) #f)
+  (test-reduce 'k:list-pair? '(cons 1 null))
+  (test-reduce 'k:list-pair? '(cons 1 (list 2 3)))
+  (test-reduce 'k:list-pair? '(cdr (list 1 2)))
+  (test-reduce 'k:list-pair? '(cdr (list 1)) #f)
+)
+
 (let ([test-bin
        (lambda (bin-name)
          (test-comp `(lambda (z)
@@ -5609,5 +5757,4 @@
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-
 (report-errs)

racket/collects/racket/private/pre-base.rkt

@@ -231,6 +231,7 @@
                               chaperone-procedure* impersonate-procedure*
                               assq assv assoc
                               prop:incomplete-arity prop:method-arity-error
+                              list-pair?
                               random)
              (all-from "reqprov.rkt")
              (all-from-except "for.rkt"

racket/src/racket/src/jitinline.c

@@ -1083,9 +1083,14 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
   } else if (IS_NAMED_PRIM(rator, "odd?")) {
     scheme_generate_arith(jitter, rator, app->rand, NULL, 1, 0, CMP_ODDP, 0, for_branch, branch_short, 0, 0, NULL, dest);
     return 1;
-  } else if (IS_NAMED_PRIM(rator, "list?")) {
+  } else if (IS_NAMED_PRIM(rator, "list?")
+             || IS_NAMED_PRIM(rator, "list-pair?")) {
+    int for_list_pair = 0;
     GC_CAN_IGNORE jit_insn *ref0, *ref1, *ref3, *ref4, *ref6;
 
+    if (IS_NAMED_PRIM(rator, "list-pair?"))
+      for_list_pair = 1;
+
     mz_runstack_skipped(jitter, 1);
     
     scheme_generate_non_tail(app->rand, jitter, 0, 1, 0);
@@ -1104,6 +1109,7 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
     ref1 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
     jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
+    /* The difference between list? and list-pair? is only for null. */
     ref3 = jit_beqi_i(jit_forward(), JIT_R1, scheme_null_type);
     ref4 = jit_bnei_i(jit_forward(), JIT_R1, scheme_pair_type);
     CHECK_LIMIT();
@@ -1116,11 +1122,14 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
       ref0 = jit_patchable_movi_p(JIT_V1, jit_forward());
       (void)jit_calli(sjc.list_p_branch_code);
 
-      mz_patch_branch(ref3);
+      if (!for_list_pair)
+        mz_patch_branch(ref3);
       mz_patch_branch(ref6);
 
       scheme_add_branch_false_movi(for_branch, ref0);
       scheme_add_branch_false(for_branch, ref1);
+      if (for_list_pair)
+        scheme_add_branch_false(for_branch, ref3);
       scheme_add_branch_false(for_branch, ref4);
       scheme_branch_for_true(jitter, for_branch);
     } else {
@@ -1132,10 +1141,13 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
 
       mz_patch_branch(ref1);
       mz_patch_branch(ref4);
+      if (for_list_pair)
+        mz_patch_branch(ref3);
       (void)jit_movi_p(dest, scheme_false);
       ref1 = jit_jmpi(jit_forward());
       
-      mz_patch_branch(ref3);
+      if (!for_list_pair)
+        mz_patch_branch(ref3);
       mz_patch_branch(ref6);
       (void)jit_movi_p(dest, scheme_true);
 

racket/src/racket/src/list.c

@@ -31,11 +31,14 @@ READ_ONLY Scheme_Object scheme_null[1];
 READ_ONLY Scheme_Object *scheme_null_p_proc;
 READ_ONLY Scheme_Object *scheme_pair_p_proc;
 READ_ONLY Scheme_Object *scheme_mpair_p_proc;
+READ_ONLY Scheme_Object *scheme_car_proc;
+READ_ONLY Scheme_Object *scheme_cdr_proc;
 READ_ONLY Scheme_Object *scheme_cons_proc;
 READ_ONLY Scheme_Object *scheme_mcons_proc;
 READ_ONLY Scheme_Object *scheme_list_p_proc;
 READ_ONLY Scheme_Object *scheme_list_proc;
 READ_ONLY Scheme_Object *scheme_list_star_proc;
+READ_ONLY Scheme_Object *scheme_list_pair_p_proc;
 READ_ONLY Scheme_Object *scheme_box_proc;
 READ_ONLY Scheme_Object *scheme_box_immutable_proc;
 READ_ONLY Scheme_Object *scheme_box_p_proc;
@@ -59,6 +62,7 @@ static Scheme_Object *null_p_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *list_p_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *list_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *list_star_prim (int argc, Scheme_Object *argv[]);
+static Scheme_Object *list_pair_p_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *immutablep (int argc, Scheme_Object *argv[]);
 static Scheme_Object *length_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *append_prim (int argc, Scheme_Object *argv[]);
@@ -239,11 +243,15 @@ scheme_init_list (Scheme_Env *env)
                                                             | SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
   scheme_add_global_constant ("cons", p, env);
 
+  REGISTER_SO(scheme_car_proc);
   p = scheme_make_folding_prim(scheme_checked_car, "car", 1, 1, 1);
+  scheme_car_proc = p;
   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
   scheme_add_global_constant ("car", p, env);
 
+  REGISTER_SO(scheme_cdr_proc);
   p = scheme_make_folding_prim(scheme_checked_cdr, "cdr", 1, 1, 1);
+  scheme_cdr_proc = p;
   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
   scheme_add_global_constant ("cdr", p, env);
 
@@ -302,6 +310,13 @@ scheme_init_list (Scheme_Env *env)
                                                             | SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
   scheme_add_global_constant ("list*", p, env);
 
+  REGISTER_SO(scheme_list_pair_p_proc);
+  p = scheme_make_folding_prim(list_pair_p_prim, "list-pair?", 1, 1, 1);
+  scheme_list_pair_p_proc = p;
+  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
+                                                            | SCHEME_PRIM_IS_OMITABLE);
+  scheme_add_global_constant ("list-pair?", p, env);
+
   p = scheme_make_folding_prim(immutablep, "immutable?", 1, 1, 1);
   SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE);
   scheme_add_global_constant("immutable?", p, env);
@@ -1420,6 +1435,15 @@ list_star_prim (int argc, Scheme_Object *argv[])
   LIST_BODY(STAR_LIST_INIT(), cons);
 }
 
+static Scheme_Object *
+list_pair_p_prim (int argc, Scheme_Object *argv[])
+{
+  return ((SCHEME_PAIRP(argv[0])
+           && scheme_is_list(argv[0]))
+          ? scheme_true
+          : scheme_false);
+}
+
 static Scheme_Object *
 immutablep (int argc, Scheme_Object *argv[])
 {

racket/src/racket/src/optimize.c

@@ -2567,14 +2567,15 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
       return scheme_real_p_proc;
     else if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_PRODUCES_NUMBER)
       return scheme_number_p_proc;
-    else if ((SAME_OBJ(rator, scheme_cons_proc)
+    else if (SAME_OBJ(rator, scheme_cons_proc))
-         || SAME_OBJ(rator, scheme_unsafe_cons_list_proc)))
       return scheme_pair_p_proc;
+    else if (SAME_OBJ(rator, scheme_unsafe_cons_list_proc))
+      return scheme_list_pair_p_proc;
     else if (SAME_OBJ(rator, scheme_mcons_proc))
       return scheme_mpair_p_proc;
     else if (SAME_OBJ(rator, scheme_list_proc)) {
       if (argc >= 1)
-        return scheme_pair_p_proc;
+        return scheme_list_pair_p_proc;
       else
         return scheme_null_p_proc;
     } else if (SAME_OBJ(rator, scheme_list_star_proc)) {
@@ -2657,7 +2658,15 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
         if (p && predicate_implies(p, scheme_real_p_proc))
           return scheme_real_p_proc;
       }
-
+    
+      if (SAME_OBJ(app->rator, scheme_cdr_proc)
+          || SAME_OBJ(app->rator, scheme_unsafe_cdr_proc)) {
+        Scheme_Object *p;
+        p = do_expr_implies_predicate(app->rand, info, NULL, fuel-1, ignore_vars);
+        if (SAME_OBJ(p, scheme_list_pair_p_proc))
+          return scheme_list_p_proc;
+      }
+      
       return rator_implies_predicate(app->rator, 1);
     }
     break;
@@ -2689,6 +2698,15 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
         }
       }
 
+      if (SAME_OBJ(app->rator, scheme_cons_proc)) {
+        Scheme_Object *p;
+        p = do_expr_implies_predicate(app->rand2, info, NULL, fuel-1, ignore_vars);
+        if (SAME_OBJ(p, scheme_list_pair_p_proc)
+            || SAME_OBJ(p, scheme_list_p_proc)
+            || SAME_OBJ(p, scheme_null_p_proc))
+          return scheme_list_pair_p_proc;
+      }
+
       return rator_implies_predicate(app->rator, 2);
     }
     break;
@@ -2772,12 +2790,6 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
 
       return do_expr_implies_predicate(seq->array[0], info, _involves_k_cross, fuel-1, ignore_vars);
     }
-  case scheme_pair_type:
-    return scheme_pair_p_proc;
-    break;
-  case scheme_mutable_pair_type:
-    return scheme_mpair_p_proc;
-    break;
   case scheme_vector_type:
     return scheme_vector_p_proc;
     break;
@@ -2799,6 +2811,8 @@ static Scheme_Object *do_expr_implies_predicate(Scheme_Object *expr, Optimize_In
 
     if (SCHEME_NULLP(expr))
       return scheme_null_p_proc;
+    if (scheme_is_list(expr))
+      return scheme_list_pair_p_proc;
     if (SCHEME_PAIRP(expr))
       return scheme_pair_p_proc;
     if (SCHEME_MPAIRP(expr))
@@ -3121,10 +3135,8 @@ static int check_known_variant(Optimize_Info *info, Scheme_Object *app,
         info->escapes = 1;
       }
     } else {
-      if (SAME_TYPE(SCHEME_TYPE(rand), scheme_ir_local_type)) {
+      if (SAME_TYPE(SCHEME_TYPE(rand), scheme_ir_local_type))
-        if (!SCHEME_VAR(rand)->mutated)
+        add_type(info, rand, implies_pred);
-          add_type(info, rand, implies_pred);
-      }
     }
   }
 
@@ -3149,10 +3161,8 @@ static void check_known_rator(Optimize_Info *info, Scheme_Object *rator)
     if (predicate_implies_not(pred, scheme_procedure_p_proc))
       info->escapes = 1;
   } else {
-    if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_local_type)) {
+    if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_local_type))
-      if (!SCHEME_VAR(rator)->mutated)
+      add_type(info, rator, scheme_procedure_p_proc);
-        add_type(info, rator, scheme_procedure_p_proc);
-    }
   }
 }
 
@@ -4501,6 +4511,8 @@ static Scheme_Object *equivalent_exprs(Scheme_Object *a, Scheme_Object *b,
 }
 
 static void add_type(Optimize_Info *info, Scheme_Object *var, Scheme_Object *pred)
+/* This is conceptually an intersection, but `Any` is represented by a
+   missing entry, so the implementation looks like an union. */
 {
   Scheme_Hash_Tree *new_types = info->types;
   Scheme_Object *old_pred;
@@ -4516,12 +4528,46 @@ static void add_type(Optimize_Info *info, Scheme_Object *var, Scheme_Object *pre
   if (old_pred && predicate_implies(old_pred, pred))
     return;
 
+  /* special case: list? and pair? => list-pair? */
+  if (old_pred) {
+    if ((SAME_OBJ(old_pred, scheme_list_p_proc)
+         && (SAME_OBJ(pred, scheme_pair_p_proc)))
+        || (SAME_OBJ(old_pred, scheme_pair_p_proc)
+            && (SAME_OBJ(pred, scheme_list_p_proc)))) {
+      pred = scheme_list_pair_p_proc;
+    }
+  }
+
   if (!new_types)
     new_types = scheme_make_hash_tree(0);
   new_types = scheme_hash_tree_set(new_types, var, pred);
   info->types = new_types;
 }
 
+static void add_type_no(Optimize_Info *info, Scheme_Object *var, Scheme_Object *pred)
+/* Currently only check a few special cases for lists. */
+{
+  Scheme_Hash_Tree *new_types = info->types;
+  Scheme_Object *old_pred;
+  
+  if (SCHEME_VAR(var)->mutated)
+    return;
+
+  old_pred = optimize_get_predicate(info, var, 1);
+
+  if (old_pred && SAME_OBJ(old_pred, scheme_list_p_proc)) {
+    /* list? but not null? => list-pair? */
+    if (SAME_OBJ(pred, scheme_null_p_proc))
+      add_type(info, var, scheme_list_pair_p_proc);
+
+    /* list? but not pair? => null? */
+    /* list? but not list-pair? => null? */
+    if (SAME_OBJ(pred, scheme_pair_p_proc)
+        ||SAME_OBJ(pred, scheme_list_pair_p_proc))
+      add_type(info, var, scheme_null_p_proc);
+  }
+}
+
 static void merge_types(Optimize_Info *src_info, Optimize_Info *info, Scheme_Hash_Tree *skip_vars)
 {
   Scheme_Hash_Tree *types = src_info->types;
@@ -4540,9 +4586,11 @@ static void merge_types(Optimize_Info *src_info, Optimize_Info *info, Scheme_Has
   }
 }
 
-static void intersect_and_merge_types(Optimize_Info *t_info, Optimize_Info *f_info,
+static void merge_branchs_types(Optimize_Info *t_info, Optimize_Info *f_info,
                                       Optimize_Info *base_info)
-/* Add to base_info the intersection of the types of t_info and f_info */
+/* This is conceptually an union, but `Any` is represented by a
+   missing entry, so the implementation looks like an intersection.
+   This adds to base_info the "intersection" of the types of t_info and f_info */
 {
   Scheme_Hash_Tree *t_types = t_info->types, *f_types = f_info->types;
   Scheme_Object *var, *t_pred, *f_pred;
@@ -4566,6 +4614,15 @@ static void intersect_and_merge_types(Optimize_Info *t_info, Optimize_Info *f_in
         add_type(base_info, var, t_pred);
       else if (predicate_implies(t_pred, f_pred))
         add_type(base_info, var, f_pred);
+      else {
+        /* special case: null? or list-pair? => list? */
+       if ((SAME_OBJ(t_pred, scheme_null_p_proc)
+         && (SAME_OBJ(f_pred, scheme_list_pair_p_proc)))
+        || (SAME_OBJ(t_pred, scheme_list_pair_p_proc)
+            && (SAME_OBJ(f_pred, scheme_null_p_proc)))) {
+        add_type(base_info, var, scheme_list_p_proc);
+       }
+      }
     }
     i = scheme_hash_tree_next(f_types, i);
   }
@@ -4583,6 +4640,7 @@ static int relevant_predicate(Scheme_Object *pred)
           || SAME_OBJ(pred, scheme_mpair_p_proc)
           || SAME_OBJ(pred, scheme_box_p_proc)
           || SAME_OBJ(pred, scheme_list_p_proc)
+          || SAME_OBJ(pred, scheme_list_pair_p_proc)      
           || SAME_OBJ(pred, scheme_vector_p_proc)
           || SAME_OBJ(pred, scheme_procedure_p_proc)
           || SAME_OBJ(pred, scheme_syntax_p_proc)
@@ -4608,6 +4666,16 @@ static int predicate_implies(Scheme_Object *pred1, Scheme_Object *pred2)
       && SAME_OBJ(pred1, scheme_null_p_proc))
     return 1;
 
+  /* list-pair? => list? */
+  if (SAME_OBJ(pred2, scheme_list_p_proc)
+      && SAME_OBJ(pred1, scheme_list_pair_p_proc))
+    return 1;
+
+  /* list-pair? => pair? */
+  if (SAME_OBJ(pred2, scheme_pair_p_proc)
+      && SAME_OBJ(pred1, scheme_list_pair_p_proc))
+    return 1;
+
   /* real?, fixnum?, or flonum? => number? */
   if (SAME_OBJ(pred2, scheme_number_p_proc)
       && (SAME_OBJ(pred1, scheme_real_p_proc)
@@ -4645,7 +4713,6 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
     Scheme_App2_Rec *app = (Scheme_App2_Rec *)t;
     if (SCHEME_PRIMP(app->rator)
         && SAME_TYPE(SCHEME_TYPE(app->rand), scheme_ir_local_type)
-        && !SCHEME_VAR(app->rand)->mutated
         && relevant_predicate(app->rator)) {
       /* Looks like a predicate on a local variable. Record that the
          predicate succeeded, which may allow conversion of safe
@@ -4660,8 +4727,7 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
     Scheme_App3_Rec *app = (Scheme_App3_Rec *)t;
     Scheme_Object *pred1, *pred2;
     if (SAME_OBJ(app->rator, scheme_eq_proc)) {
-      if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_ir_local_type)
+      if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_ir_local_type)) {
-          && !SCHEME_VAR(app->rand1)->mutated) {
         pred1 = expr_implies_predicate(app->rand1, info);
         if (!pred1) {
           pred2 = expr_implies_predicate(app->rand2, info);
@@ -4669,8 +4735,7 @@ static void add_types_for_t_branch(Scheme_Object *t, Optimize_Info *info, int fu
             add_type(info, app->rand1, pred2);
         }
       }
-      if (SAME_TYPE(SCHEME_TYPE(app->rand2), scheme_ir_local_type)
+      if (SAME_TYPE(SCHEME_TYPE(app->rand2), scheme_ir_local_type)) {
-          && !SCHEME_VAR(app->rand2)->mutated) {
         pred2 = expr_implies_predicate(app->rand2, info);
         if (!pred2) {
           pred1 = expr_implies_predicate(app->rand1, info);
@@ -4700,8 +4765,15 @@ static void add_types_for_f_branch(Scheme_Object *t, Optimize_Info *info, int fu
 
   if (SAME_TYPE(SCHEME_TYPE(t), scheme_ir_local_type)) {
     add_type(info, t, scheme_not_proc);
-    if (SAME_OBJ(app->rator, scheme_not_proc)) {
+  
-      add_types_for_t_branch(app->rand, info, fuel-1);
+  } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) {
+    Scheme_App2_Rec *app = (Scheme_App2_Rec *)t;
+    if (SCHEME_PRIMP(app->rator)
+        && SAME_TYPE(SCHEME_TYPE(app->rand), scheme_ir_local_type)
+        && relevant_predicate(app->rator)) {
+      /* Looks like a predicate on a local variable. Record that the
+         predicate failed, this is currently useful only for lists. */
+      add_type_no(info, app->rand, app->rator);
     }
 
   } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)) {
@@ -4885,7 +4957,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
     info->single_result = new_single_result;
     if (then_info->kclock > info->kclock)
       info->kclock = then_info->kclock;
-    intersect_and_merge_types(then_info, else_info, info);
+    merge_branchs_types(then_info, else_info, info);
   }
 
   if (then_info->sclock > info->sclock)

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1145
+#define EXPECTED_PRIM_COUNT 1146
 #define EXPECTED_UNSAFE_COUNT 126
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45

racket/src/racket/src/schpriv.h

@@ -509,11 +509,14 @@ extern Scheme_Object *scheme_unsafe_cdr_proc;
 extern Scheme_Object *scheme_unsafe_mcar_proc;
 extern Scheme_Object *scheme_unsafe_mcdr_proc;
 extern Scheme_Object *scheme_unsafe_unbox_proc;
+extern Scheme_Object *scheme_car_proc;
+extern Scheme_Object *scheme_cdr_proc;
 extern Scheme_Object *scheme_cons_proc;
 extern Scheme_Object *scheme_mcons_proc;
 extern Scheme_Object *scheme_list_p_proc;
 extern Scheme_Object *scheme_list_proc;
 extern Scheme_Object *scheme_list_star_proc;
+extern Scheme_Object *scheme_list_pair_p_proc;
 extern Scheme_Object *scheme_vector_proc;
 extern Scheme_Object *scheme_vector_p_proc;
 extern Scheme_Object *scheme_make_vector_proc;

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.4.0.14"
+#define MZSCHEME_VERSION "6.4.0.15"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 4
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 14
+#define MZSCHEME_VERSION_W 15
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)