add simple optimization of procedure? applied to an id whose value is known to be a procedure

svn: r7308

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
 

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;

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",

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;