optimizer: don't drop application when argument count is wrong
Guard some ad hoc optimizations with an arity check in the cases of 1 or 2 arguments. Closes #2222
This commit is contained in:
parent
305d02f46a
commit
4a7c4d184c
|
@ -3823,32 +3823,44 @@
|
|||
;; Types related to arithmetic
|
||||
|
||||
(let ()
|
||||
(define (check-real-op op [can-omit? #t] [can-multi? #t])
|
||||
(define (check-real-op op [can-omit? #t] [can-multi? #t]
|
||||
#:implies-real? [implies-real? #t]
|
||||
#:needs-two-args? [needs-two-args? #f])
|
||||
(test-comp `(lambda (x y)
|
||||
(list (,op x y)
|
||||
(real? x)
|
||||
(real? y)
|
||||
(number? x)
|
||||
(number? y)))
|
||||
`(lambda (x y)
|
||||
(list (,op x y)
|
||||
#t
|
||||
#t
|
||||
#t
|
||||
#t)))
|
||||
(when implies-real?
|
||||
(test-comp `(lambda (x y)
|
||||
(list (,op x y)
|
||||
(real? x)
|
||||
(real? y)
|
||||
(number? x)
|
||||
(number? y)))
|
||||
`(lambda (x y)
|
||||
(list (,op x y)
|
||||
#t
|
||||
#t
|
||||
#t
|
||||
#t))))
|
||||
(when can-multi?
|
||||
(test-comp `(lambda (x y z w)
|
||||
(list (,op x y z w)
|
||||
(real? x)
|
||||
(real? y)
|
||||
(real? z)
|
||||
(real? w)))
|
||||
`(lambda (x y z w)
|
||||
(list (,op x y z w)
|
||||
#t
|
||||
#t
|
||||
#t
|
||||
#t))))
|
||||
(let ([? (if implies-real? 'real? 'number?)])
|
||||
(test-comp `(lambda (x y z w)
|
||||
(list (,op x y z w)
|
||||
(,? x)
|
||||
(,? y)
|
||||
(,? z)
|
||||
(,? w)))
|
||||
`(lambda (x y z w)
|
||||
(list (,op x y z w)
|
||||
#t
|
||||
#t
|
||||
#t
|
||||
#t)))))
|
||||
(when can-omit?
|
||||
(test-comp `(lambda (x y)
|
||||
(if (and (real? x) (real? y))
|
||||
|
@ -3859,16 +3871,30 @@
|
|||
`(lambda (x y)
|
||||
(if (and (real? x) (real? y))
|
||||
(,op x y)
|
||||
(error "bad"))))))
|
||||
(error "bad"))))
|
||||
;; Make sure error is not discarded when the number
|
||||
;; of arguments is wrong
|
||||
(when needs-two-args?
|
||||
(test-comp `(lambda (x)
|
||||
(if (real? x)
|
||||
(let ([tmp (= x)])
|
||||
'whatever)
|
||||
(error "bad")))
|
||||
`(lambda (x)
|
||||
(if (real? x)
|
||||
(= x)
|
||||
(error "bad")))))))
|
||||
|
||||
(check-real-op 'quotient #f #f)
|
||||
(check-real-op 'remainder #f #f)
|
||||
(check-real-op 'modulo #f #f)
|
||||
(check-real-op 'max)
|
||||
(check-real-op 'min)
|
||||
(check-real-op '<)
|
||||
(check-real-op '>)
|
||||
(check-real-op '<=)
|
||||
(check-real-op '>=)
|
||||
(check-real-op '= #:needs-two-args? #t #:implies-real? #f)
|
||||
(check-real-op '< #:needs-two-args? #t)
|
||||
(check-real-op '> #:needs-two-args? #t)
|
||||
(check-real-op '<= #:needs-two-args? #t)
|
||||
(check-real-op '>= #:needs-two-args? #t)
|
||||
|
||||
(define (check-number-op op [closed-under-reals? #t])
|
||||
(test-comp `(lambda (x y)
|
||||
|
|
|
@ -4417,7 +4417,9 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
|
|||
rator = scheme_values_proc;
|
||||
}
|
||||
|
||||
if (SCHEME_PRIMP(rator)) {
|
||||
if (SCHEME_PRIMP(rator)
|
||||
&& (1 >= ((Scheme_Primitive_Proc *)rator)->mina)
|
||||
&& (1 <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)) {
|
||||
/* Check for things like (cXr (cons X Y)): */
|
||||
switch (SCHEME_TYPE(rand)) {
|
||||
case scheme_application2_type:
|
||||
|
@ -5080,7 +5082,9 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
|
|||
}
|
||||
}
|
||||
|
||||
if (SCHEME_PRIMP(app->rator)) {
|
||||
if (SCHEME_PRIMP(app->rator)
|
||||
&& (2 >= ((Scheme_Primitive_Proc *)app->rator)->mina)
|
||||
&& (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) {
|
||||
Scheme_Object *app_o = (Scheme_Object *)app, *rator = app->rator, *rand1 = app->rand1, *rand2 = app->rand2;
|
||||
|
||||
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_AD_HOC_OPT) {
|
||||
|
|
Loading…
Reference in New Issue
Block a user