diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/all-real.rkt b/collects/tests/typed-scheme/optimizer/missed-optimizations/all-real.rkt index ec36a78ddb..34943a5e3b 100644 --- a/collects/tests/typed-scheme/optimizer/missed-optimizations/all-real.rkt +++ b/collects/tests/typed-scheme/optimizer/missed-optimizations/all-real.rkt @@ -1,7 +1,7 @@ #; ( - all-real.rkt 24:0 (#%app + (quote 3) (quote 4)) -- binary, args all float-arg-expr, return type not Float -- caused by: 24:8 (quote 3) - all-real.rkt 25:0 (#%app * (quote 3) (quote 4)) -- binary, args all float-arg-expr, return type not Float -- caused by: 25:8 (quote 3) + all-real.rkt 24:0 (#%app + (quote 3) (quote 4)) -- binary, args all float-arg-expr, return type not Float -- caused by: 24:8 (quote 3), 24:21 (quote 4) + all-real.rkt 25:0 (#%app * (quote 3) (quote 4)) -- binary, args all float-arg-expr, return type not Float -- caused by: 25:8 (quote 3), 25:21 (quote 4) 7 12 ) diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/multiple-irritants.rkt b/collects/tests/typed-scheme/optimizer/missed-optimizations/multiple-irritants.rkt new file mode 100644 index 0000000000..f1fa3c4cb9 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/missed-optimizations/multiple-irritants.rkt @@ -0,0 +1,9 @@ +#; +( + multiple-irritants.rkt 9:0 (#%app * (quote 4) (quote 5) (quote 6.0)) -- binary, args all float-arg-expr, return type not Float -- caused by: 9:8 (quote 4), 9:24 (quote 5) +120.0 +) + +#lang typed/racket + +(* (ann 4 Integer) (ann 5 Integer) 6.0) diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/precision-loss.rkt b/collects/tests/typed-scheme/optimizer/missed-optimizations/precision-loss.rkt index 15ea7f6cfb..90c4c10806 100644 --- a/collects/tests/typed-scheme/optimizer/missed-optimizations/precision-loss.rkt +++ b/collects/tests/typed-scheme/optimizer/missed-optimizations/precision-loss.rkt @@ -8,7 +8,7 @@ precision-loss.rkt 28:1 + -- binary float precision-loss.rkt 30:1 + -- binary float precision-loss.rkt 36:0 (#%app * (#%app * (quote 3/4) (quote 2/3)) (quote 2.0)) -- binary, args all float-arg-expr, return type not Float -- caused by: 36:8 (#%app * (quote 3/4) (quote 2/3)) precision-loss.rkt 36:0 (#%app * (#%app * (quote 3/4) (quote 2/3)) (quote 2.0)) -- exact arithmetic subexpression inside a float expression, extra precision discarded -- caused by: 36:8 (#%app * (quote 3/4) (quote 2/3)) -precision-loss.rkt 36:8 (#%app * (quote 3/4) (quote 2/3)) -- binary, args all float-arg-expr, return type not Float -- caused by: 36:11 (quote 3/4) +precision-loss.rkt 36:8 (#%app * (quote 3/4) (quote 2/3)) -- binary, args all float-arg-expr, return type not Float -- caused by: 36:11 (quote 3/4), 36:15 (quote 2/3) 2.5 2.75 1.25 diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt index 43e5996ebf..d27b3c16ce 100644 --- a/collects/typed-scheme/optimizer/float.rkt +++ b/collects/typed-scheme/optimizer/float.rkt @@ -102,8 +102,8 @@ (when missed-optimization? (log-missed-optimization "binary, args all float-arg-expr, return type not Float" this-syntax - (for/first ([x (in-list (syntax->list #'(f1 f2 fs ...)))] - #:when (not (subtypeof? x -Flonum))) + (for/list ([x (in-list (syntax->list #'(f1 f2 fs ...)))] + #:when (not (subtypeof? x -Flonum))) x))) ;; If an optimization was expected (whether it was safe or not doesn't matter), ;; report subexpressions doing expensive exact arithmetic (Exact-Rational and diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-scheme/optimizer/utils.rkt index a99d184fc2..144f8f02a9 100644 --- a/collects/typed-scheme/optimizer/utils.rkt +++ b/collects/typed-scheme/optimizer/utils.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require unstable/match racket/match racket/set +(require unstable/match racket/match racket/set racket/string racket/dict syntax/id-table racket/syntax unstable/syntax "../utils/utils.rkt" (for-template racket/base) @@ -82,14 +82,22 @@ ;; of reporting them to the user. ;; This is meant to help users understand what hurts the performance of ;; their programs. -(define (log-missed-optimization kind stx [irritant #f]) - (do-logging (if irritant - (format "~a -- caused by: ~a ~a" - kind - (line+col->string irritant) - (syntax->datum irritant)) - kind) - stx)) +(define (log-missed-optimization kind stx [irritants '()]) + ;; for convenience, if a single irritant is given, wrap it in a list + ;; implicitly + (let ([irritants (if (list? irritants) irritants (list irritants))]) + (do-logging + (if (not (null? irritants)) + (format "~a -- caused by: ~a" + kind + (string-join (map (lambda (irritant) + (format "~a ~a" + (line+col->string irritant) + (syntax->datum irritant))) + irritants) + ", ")) + kind) + stx))) ;; if set to #t, the optimizer will dump its result to stdout before compilation (define *show-optimized-code* #f)