diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index f1eb1b85a4..4a67138c57 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/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)]) diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index b1aff09b65..f28ba52c48 100644 --- a/racket/src/racket/src/fun.c +++ b/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, - "procedure-specialize", - 1, 1), - env); + + REGISTER_SO(scheme_procedure_specialize_proc); + o = scheme_make_prim_w_arity(procedure_specialize, + "procedure-specialize", + 1, 1); + 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", diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 8040c496e5..6457f0f9e6 100644 --- a/racket/src/racket/src/optimize.c +++ b/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; diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index f1ea327d3a..a4ed95e79e 100644 --- a/racket/src/racket/src/schpriv.h +++ b/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;