allow optimizations around procedure-specialize

Although `procedure-specialize` should be useful in places where
inlining does not apply, allowing inlining and related optimizations
through it, anyway.

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

@@ -1922,6 +1922,28 @@
               (define (g y)
                 (+ y 1))))
 
+
+(test-comp '(let ()
+             (define (f x)
+               (procedure-specialize
+                (lambda (y) (+ x y))))
+             ((f 10) 12))
+           '22)
+
+(test-comp '(let ()
+             (define (f x)
+               (procedure-specialize
+                (lambda (y) (+ x y))))
+             (procedure? (f 10)))
+           '#t)
+
+(test-comp '(let ([f (procedure-specialize
+                      (lambda (y) (+ 1 y)))])
+             (list f (procedure-arity-includes? f 1)))
+           '(let ([f (procedure-specialize
+                      (lambda (y) (+ 1 y)))])
+             (list f #t)))
+
 (test-comp '(values 10)
            10)
 (test-comp '(let ([x (values 10)])

racket/src/racket/src/fun.c

@@ -79,6 +79,7 @@ READ_ONLY Scheme_Object scheme_void[1]; /* the void constant */
 READ_ONLY Scheme_Object *scheme_values_func; /* the function bound to `values' */
 READ_ONLY Scheme_Object *scheme_procedure_p_proc;
 READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc;
+READ_ONLY Scheme_Object *scheme_procedure_specialize_proc;
 READ_ONLY Scheme_Object *scheme_void_proc;
 READ_ONLY Scheme_Object *scheme_void_p_proc;
 READ_ONLY Scheme_Object *scheme_check_not_undefined_proc;
@@ -594,11 +595,14 @@ scheme_init_fun (Scheme_Env *env)
 						      "procedure-closure-contents-eq?",
 						      2, 2, 1),
 			     env);
-  scheme_add_global_constant("procedure-specialize",
+
-			     scheme_make_prim_w_arity(procedure_specialize,
+  REGISTER_SO(scheme_procedure_specialize_proc);
+  o = scheme_make_prim_w_arity(procedure_specialize,
                                "procedure-specialize",
-						      1, 1),
+                               1, 1);
-			     env);
+  scheme_procedure_specialize_proc = o;
+  scheme_add_global_constant("procedure-specialize", o, env);
+
   scheme_add_global_constant("chaperone-procedure",
 			     scheme_make_prim_w_arity(chaperone_procedure,
 						      "chaperone-procedure",

racket/src/racket/src/optimize.c

@@ -289,6 +289,19 @@ static void note_match(int actual, int expected, Optimize_Info *warn_info)
   }
 }
 
+static Scheme_Object *extract_specialized_proc(Scheme_Object *le, Scheme_Object *default_val)
+{
+  if (SAME_TYPE(SCHEME_TYPE(le), scheme_application2_type)) {
+    Scheme_App2_Rec *app = (Scheme_App2_Rec *)le;
+    if (SAME_OBJ(app->rator, scheme_procedure_specialize_proc)) {
+      if (SCHEME_PROCP(app->rand) || IS_COMPILED_PROC(app->rand))
+        return app->rand;
+    }
+  }
+
+  return default_val;
+}
+
 int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
                           Optimize_Info *opt_info, Optimize_Info *warn_info,
                           int min_id_depth, int id_offset, int no_id)
@@ -469,6 +482,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
                    && (SCHEME_INT_VAL(app->rand) >= 0))
                    && IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(app->rand))) {
       return 1;
+    } else if (SAME_OBJ(app->rator, scheme_procedure_specialize_proc)) {
+      if ((vals == 1 || vals == -1) && extract_specialized_proc(o, NULL))
+        return 1;
     } else if (SCHEME_PRIMP(app->rator)) {
       if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)
           || SAME_OBJ(scheme_values_func, app->rator)) {
@@ -1775,6 +1791,8 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
   if (already_opt)
     extract_tail_inside(&le, &prev, &id_offset);
 
+  le = extract_specialized_proc(le, le);
+
   if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
     /* Found a `((lambda' */
     single_use = 1;
@@ -2480,6 +2498,8 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
       return scheme_box_p_proc;
     else if (SAME_OBJ(rator, scheme_void_proc))
       return scheme_void_p_proc;
+    else if (SAME_OBJ(rator, scheme_procedure_specialize_proc))
+      return scheme_procedure_p_proc;
     
     {
       Scheme_Object *p;
@@ -6393,6 +6413,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
         }
       }
 
+      if (value)
+        value = extract_specialized_proc(value, value);
+
       if (value && (scheme_compiled_propagate_ok(value, body_info))) {
         int cnt;
 

racket/src/racket/src/schpriv.h

@@ -455,6 +455,7 @@ extern Scheme_Object *scheme_apply_proc;
 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_procedure_specialize_proc;
 extern Scheme_Object *scheme_void_proc;
 extern Scheme_Object *scheme_void_p_proc;
 extern Scheme_Object *scheme_syntax_p_proc;