JIT opts for or and and

svn: r2151

src/mzscheme/src/bool.c

@@ -37,6 +37,9 @@ Scheme_Object scheme_true[1];
 Scheme_Object scheme_false[1];
 
 Scheme_Object *scheme_not_prim;
+Scheme_Object *scheme_eq_prim;
+Scheme_Object *scheme_eqv_prim;
+Scheme_Object *scheme_equal_prim;
 
 /* locals */
 static Scheme_Object *not_prim (int argc, Scheme_Object *argv[]);
@@ -60,6 +63,9 @@ void scheme_init_bool (Scheme_Env *env)
   Scheme_Object *p;
 
   REGISTER_SO(scheme_not_prim);
+  REGISTER_SO(scheme_eq_prim);
+  REGISTER_SO(scheme_eqv_prim);
+  REGISTER_SO(scheme_equal_prim);
 
   p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
   scheme_not_prim = p;
@@ -75,18 +81,14 @@ void scheme_init_bool (Scheme_Env *env)
 
   p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
+  scheme_eq_prim = p;
   scheme_add_global_constant("eq?", p, env);
 
-  scheme_add_global_constant("eqv?",
+  scheme_eqv_prim = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1);
-			     scheme_make_folding_prim(eqv_prim,
+  scheme_add_global_constant("eqv?", scheme_eqv_prim, env);
-						      "eqv?",
+  
-						      2, 2, 1),
+  scheme_equal_prim = scheme_make_prim_w_arity(equal_prim, "equal?", 2, 2);
-			     env);
+  scheme_add_global_constant("equal?", scheme_equal_prim, env);
-  scheme_add_global_constant("equal?",
-			     scheme_make_prim_w_arity(equal_prim,
-						      "equal?",
-						      2, 2),
-			     env);
 }
 
 static Scheme_Object *

src/mzscheme/src/env.c

@@ -122,6 +122,7 @@ static int env_uid_counter;
 #define ARBITRARY_USE 1
 #define CONSTRAINED_USE 2
 #define WAS_SET_BANGED 4
+/* See also SCHEME_USE_COUNT_MASK */
 
 typedef struct Compile_Data {
   char **stat_dists; /* (pos, depth) => used? */
@@ -1488,12 +1489,24 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
 /* Generates a Scheme_Local record for a static distance coodinate, and also
    marks the variable as used for closures. */
 {
-  COMPILE_DATA(frame)->use[i] |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING))
+  int cnt, u;
-				   ? CONSTRAINED_USE
+
-				   : ARBITRARY_USE)
+  u = COMPILE_DATA(frame)->use[i];
-				  | ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF))
+  
-				     ? WAS_SET_BANGED
+  u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING))
-				     : 0));
+	 ? CONSTRAINED_USE
+	 : ARBITRARY_USE)
+	| ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF))
+	   ? WAS_SET_BANGED
+	   : 0));
+
+  cnt = ((u & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
+  if (cnt < SCHEME_USE_COUNT_INF)
+    cnt++;
+  u -= (u & SCHEME_USE_COUNT_MASK);
+  u |= (cnt << SCHEME_USE_COUNT_SHIFT);
+  
+  COMPILE_DATA(frame)->use[i] = u;
   
   if (!COMPILE_DATA(frame)->stat_dists) {
     int k, *ia;
@@ -2532,6 +2545,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
       v[i] |= SCHEME_WAS_USED;
     if (old & WAS_SET_BANGED)
       v[i] |= SCHEME_WAS_SET_BANGED;
+    v[i] |= (old & SCHEME_USE_COUNT_MASK);
   }
 
   return v;

src/mzscheme/src/eval.c

@@ -992,6 +992,16 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *info)
   return (Scheme_Object *)app;
 }
 
+static int eq_testable_constant(Scheme_Object *v)
+{
+  if (SCHEME_SYMBOLP(v)
+      || SCHEME_FALSEP(v)
+      || SAME_OBJ(v, scheme_true)
+      || SCHEME_VOIDP(v))
+    return 1;
+  return 0;
+}
+
 static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *info)
 {
   Scheme_App3_Rec *app;
@@ -1011,6 +1021,15 @@ static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *info)
   le = scheme_resolve_expr(app->rand2, info);
   app->rand2 = le;
 
+  /* Optimize `equal?' or `eqv?' test on certain types
+     to `eq?'. This is especially helpful for the JIT. */
+  if ((SAME_OBJ(app->rator, scheme_equal_prim)
+       || SAME_OBJ(app->rator, scheme_eqv_prim))
+      && (eq_testable_constant(app->rand1)
+	  || eq_testable_constant(app->rand2))) {
+    app->rator = scheme_eq_prim;
+  }
+
   et = scheme_get_eval_type(app->rand2);
   et = et << 3;
   et += scheme_get_eval_type(app->rand1);
@@ -1058,7 +1077,7 @@ static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info)
 
   /* Try optimize: (if (not x) y z) => (if x z y) */
   /*  Done here because `not' is easily recognized at this
-      point, and we haven't yet resolved Scheme-stack locations
+      point. Also, we haven't yet resolved Scheme-stack locations,
       so it's ok to remove an application. */
   while (1) {
     if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) {
@@ -1076,9 +1095,46 @@ static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info)
       break;
   }
 
-  t = scheme_resolve_expr(t, info);
+  if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_let_void_type)) {
+    /* Maybe convert: (let ([x M]) (if x x N)) => (if M #t N) */
+    t = scheme_resolve_lets_for_test(t, info);
+  } else
+    t = scheme_resolve_expr(t, info);
+
   tb = scheme_resolve_expr(tb, info);
   fb = scheme_resolve_expr(fb, info);
+
+  /* Try optimize: (if x x #f) => x */
+  if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type)
+      && SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type)
+      && (SCHEME_LOCAL_POS(t) == SCHEME_LOCAL_POS(tb))
+      && SCHEME_FALSEP(fb)) {
+    return t;
+  }
+
+  /* Convert: (if (if M N #f) M2 K) => (if M (if N M2 K) K)
+     for simple constants K. This is useful to expose simple
+     tests to the JIT. */
+  if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)
+      && (SCHEME_VOIDP(fb)
+	  || SAME_OBJ(fb, scheme_true)
+	  || SCHEME_FALSEP(fb)
+	  || SCHEME_SYMBOLP(fb)
+	  || SCHEME_INTP(fb)
+	  || SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type))) {
+    Scheme_Branch_Rec *b2 = (Scheme_Branch_Rec *)t;
+    if (SCHEME_FALSEP(b2->fbranch)) {
+      Scheme_Branch_Rec *b3;
+      b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
+      b3->so.type = scheme_branch_type;
+      b3->test = b2->tbranch;
+      b3->tbranch = tb;
+      b3->fbranch = fb;
+      t = b2->test;
+      tb = (Scheme_Object *)b3;
+    }
+  }
+
   b->test = t;
   b->tbranch = tb;
   b->fbranch = fb;

src/mzscheme/src/schpriv.h

@@ -221,6 +221,9 @@ extern Scheme_Object *scheme_lambda_syntax;
 extern Scheme_Object *scheme_begin_syntax;
 
 extern Scheme_Object *scheme_not_prim;
+extern Scheme_Object *scheme_eq_prim;
+extern Scheme_Object *scheme_eqv_prim;
+extern Scheme_Object *scheme_equal_prim;
 
 extern Scheme_Object *scheme_def_exit_proc;
 
@@ -1713,6 +1716,7 @@ Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);
 int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed);
 
 Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info);
+Scheme_Object *scheme_resolve_lets_for_test(Scheme_Object *form, Resolve_Info *info);
 
 Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify);
 
@@ -1784,6 +1788,10 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
 #define SCHEME_WAS_USED 1
 #define SCHEME_WAS_SET_BANGED 2
 
+#define SCHEME_USE_COUNT_MASK  0x70
+#define SCHEME_USE_COUNT_SHIFT 4
+#define SCHEME_USE_COUNT_INF   (SCHEME_USE_COUNT_MASK >> SCHEME_USE_COUNT_SHIFT)
+
 /* flags reported by scheme_resolve_info_flags */
 #define SCHEME_INFO_BOXED 1
 

src/mzscheme/src/syntax.c

@@ -2343,6 +2343,43 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
   return first;
 }
 
+Scheme_Object *
+scheme_resolve_lets_for_test(Scheme_Object *form, Resolve_Info *info)
+/* Special case for when the `let' expression appears in an `if' test */
+{
+  Scheme_Let_Header *head = (Scheme_Let_Header *)form;
+
+  /* Special case: (let ([x M]) (if x x N)), where x is not in N,
+     to (if M #t #f), since we're in a test position. */
+  if (!SCHEME_LET_RECURSIVE(head) && (head->count == 1) && (head->num_clauses == 1)) {
+    Scheme_Compiled_Let_Value *clv;
+    clv = (Scheme_Compiled_Let_Value *)head->body;
+    if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type)
+	&& (((clv->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT)
+	    == 2)) {
+      Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)clv->body;
+      if (SAME_TYPE(SCHEME_TYPE(b->test), scheme_local_type)
+	  && SAME_TYPE(SCHEME_TYPE(b->tbranch), scheme_local_type)
+	  && !SCHEME_LOCAL_POS(b->test)
+	  && !SCHEME_LOCAL_POS(b->tbranch)) {
+	Scheme_Branch_Rec *b3;
+	b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
+	b3->so.type = scheme_branch_type;
+	b3->test = clv->value;
+	b3->tbranch = scheme_true;
+	b3->fbranch = b->fbranch;
+	
+	info = scheme_resolve_info_extend(info, 0, 1, 0);
+
+	return scheme_resolve_expr((Scheme_Object *)b3, info);
+      }
+    }
+  }
+
+
+  return scheme_resolve_lets(form, info);
+}
+
 static Scheme_Object *
 gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
 		int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec,