some improvement in eliminating procedure? and procedure-arity-includes? statically

svn: r14723

collects/mzlib/port.ss

@@ -1,7 +1,7 @@
 #lang mzscheme
 
 (require mzlib/etc
-         mzlib/contract
+         scheme/contract
          mzlib/list
          "private/port.ss")
 

collects/tests/mzscheme/optimize.ss

@@ -694,6 +694,26 @@
               (define (q x)
                 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10))))))))))))))
 
+(test-comp '(module m mzscheme
+              (define (f x) x)
+              (procedure? f))
+           '(module m mzscheme
+              (define (f x) x)
+              #t))
+
+(test-comp '(module m mzscheme
+              (define (f x) x)
+              (procedure-arity-includes? f 1))
+           '(module m mzscheme
+              (define (f x) x)
+              #t))
+(test-comp '(module m mzscheme
+              (define (f x) x)
+              (procedure-arity-includes? f 2))
+           '(module m mzscheme
+              (define (f x) x)
+              #f))
+
 (let ([test-dropped
        (lambda (cons-name . args)
          (test-comp `(let ([x 5])

src/mzscheme/src/eval.c

@@ -2564,6 +2564,39 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
   return (Scheme_Object *)app;
 }
 
+static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *rand)
+{
+  Scheme_Object *c = NULL;
+
+  if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(rand)))
+    c = rand;
+  if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
+    int offset;
+    Scheme_Object *expr;
+    expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0);
+    c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL);
+  }
+  if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) {
+    if (info->top_level_consts) {
+      int pos;
+      
+      while (1) {
+        pos = SCHEME_TOPLEVEL_POS(rand);
+        c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
+        if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type))
+          rand = c;
+        else
+          break;
+      }
+    }
+  }
+
+  if (c && SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c)))
+    return c;
+
+  return NULL;
+}
+
 static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info)
 {
   Scheme_App2_Rec *app;
@@ -2598,21 +2631,11 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
   }
 
   if (SAME_OBJ(scheme_procedure_p_proc, app->rator)) {
-    if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(app->rand))) {
+    if (lookup_constant_proc(info, 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;
-      Scheme_Object *expr;
-      expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(app->rand), 0);
-      if (scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL)) {
-        info->preserves_marks = 1;
-        info->single_result = 1;
-        return scheme_true;
-      }
-    }
   }
 
   if ((SAME_OBJ(scheme_values_func, app->rator)
@@ -2702,6 +2725,24 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
     }
   }
 
+  if (SAME_OBJ(scheme_procedure_arity_includes_proc, app->rator)) {
+    if (SCHEME_INTP(app->rand2)) {
+      Scheme_Closure_Data *data;
+      data = (Scheme_Closure_Data *)lookup_constant_proc(info, app->rand1);
+      if (data) {
+        int n = SCHEME_INT_VAL(app->rand2);
+        info->preserves_marks = 1;
+        info->single_result = 1;
+        if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
+          return ((data->num_params - 1) <= n) ? scheme_true : scheme_false;
+        } else {
+          return (data->num_params == n) ? scheme_true : scheme_false;
+        }
+      }
+    }
+  }
+
+
   info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
   info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
   if (rator_flags & CLOS_RESULT_TENTATIVE) {

src/mzscheme/src/fun.c

@@ -81,6 +81,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_procedure_arity_includes_proc;
 Scheme_Object *scheme_void_proc;
 Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
 Scheme_Object *scheme_reduced_procedure_struct;
@@ -226,6 +227,7 @@ scheme_init_fun (Scheme_Env *env)
   REGISTER_SO(cached_dv_stx);
   REGISTER_SO(cached_ds_stx);
   REGISTER_SO(scheme_procedure_p_proc);
+  REGISTER_SO(scheme_procedure_arity_includes_proc);
 
   REGISTER_SO(offstack_cont);
   REGISTER_SO(offstack_overflow);
@@ -488,11 +490,14 @@ scheme_init_fun (Scheme_Env *env)
 						      "procedure-arity?",
 						      1, 1, 1),
 			     env);
-  scheme_add_global_constant("procedure-arity-includes?",
+
-			     scheme_make_folding_prim(procedure_arity_includes,
+  scheme_procedure_arity_includes_proc = scheme_make_folding_prim(procedure_arity_includes,
                                                                   "procedure-arity-includes?",
-						      2, 2, 1),
+                                                                  2, 2, 1);
+  scheme_add_global_constant("procedure-arity-includes?",
+			     scheme_procedure_arity_includes_proc,
 			     env);
+
   scheme_add_global_constant("procedure-reduce-arity",
 			     scheme_make_prim_w_arity(procedure_reduce_arity,
 						      "procedure-reduce-arity",

src/mzscheme/src/schpriv.h

@@ -267,6 +267,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_procedure_arity_includes_proc;
 extern Scheme_Object *scheme_void_proc;
 extern Scheme_Object *scheme_cons_proc;
 extern Scheme_Object *scheme_mcons_proc;