From 1ce720cffd58ef38d7f8b447470660fe81a014a4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 10 Sep 2007 21:13:57 +0000
Subject: [PATCH] add simple optimization of procedure? applied to an id whose
 value is known to be a procedure

svn: r7308
---
 collects/tests/mzscheme/optimize.ss | 11 +++++++++++
 src/mzscheme/src/eval.c             | 16 ++++++++++++++++
 src/mzscheme/src/fun.c              |  4 ++++
 src/mzscheme/src/schpriv.h          |  1 +
 4 files changed, 32 insertions(+)

diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss
index f5de7a5962..5c70f55472 100644
--- a/collects/tests/mzscheme/optimize.ss
+++ b/collects/tests/mzscheme/optimize.ss
@@ -519,6 +519,17 @@
               15)
            15)
 
+(test-comp '(procedure? add1)
+           #t)
+(test-comp '(procedure? (lambda (x) x))
+           #t)
+(test-comp '(let ([f (lambda (x) x)])
+              (if (procedure? f)
+                  (list f)
+                  88))
+           '(let ([f (lambda (x) x)])
+              (list f)))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check bytecode verification of lifted functions
 
diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c
index e9b92e1beb..c4289c7e79 100644
--- a/src/mzscheme/src/eval.c
+++ b/src/mzscheme/src/eval.c
@@ -2293,6 +2293,22 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
       return le;
   }
 
+  if (SAME_OBJ(scheme_procedure_p_proc, app->rator)) {
+    if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(app->rand))) {
+      info->preserves_marks = 1;
+      info->single_result = 1;
+      return scheme_true;
+    }
+    if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)) {
+      int offset;
+      if (scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(app->rand), &offset)) {
+        info->preserves_marks = 1;
+        info->single_result = 1;
+        return scheme_true;
+      }
+    }
+  }
+
   if (SAME_OBJ(scheme_values_func, app->rator)
       && scheme_omittable_expr(app->rand, 1)) {
     info->preserves_marks = 1;
diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c
index 5db1caa289..3bf5eeff65 100644
--- a/src/mzscheme/src/fun.c
+++ b/src/mzscheme/src/fun.c
@@ -79,6 +79,7 @@ int scheme_defining_primitives; /* set to 1 during start-up */
 
 Scheme_Object scheme_void[1]; /* the void constant */
 Scheme_Object *scheme_values_func; /* the function bound to `values' */
+Scheme_Object *scheme_procedure_p_proc;
 Scheme_Object *scheme_void_proc;
 Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
 
@@ -217,11 +218,14 @@ scheme_init_fun (Scheme_Env *env)
   REGISTER_SO(cached_beg_stx);
   REGISTER_SO(cached_dv_stx);
   REGISTER_SO(cached_ds_stx);
+  REGISTER_SO(scheme_procedure_p_proc);
 
   o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1);
   SCHEME_PRIM_PROC_FLAGS(o) |= SCHEME_PRIM_IS_UNARY_INLINED;
   scheme_add_global_constant("procedure?", o, env);
 
+  scheme_procedure_p_proc = o;
+
   scheme_add_global_constant("apply",
 			     scheme_make_prim_w_arity2(apply,
 						       "apply",
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 2faf0bf4f1..a71f8661ec 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -235,6 +235,7 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
 /*========================================================================*/
 
 extern Scheme_Object *scheme_values_func;
+extern Scheme_Object *scheme_procedure_p_proc;
 extern Scheme_Object *scheme_void_proc;
 extern Scheme_Object *scheme_call_with_values_proc;
 extern Scheme_Object *scheme_make_struct_type_proc;