diff --git a/collects/typed-scheme/optimizer/tool/tool.rkt b/collects/typed-scheme/optimizer/tool/tool.rkt
index 28fcad0b1b..4867b25d7f 100644
--- a/collects/typed-scheme/optimizer/tool/tool.rkt
+++ b/collects/typed-scheme/optimizer/tool/tool.rkt
@@ -21,6 +21,28 @@
 (define (performance-report-callback drr-frame)
   (send (send drr-frame get-definitions-text) add-highlights))
 
+(define lowest-badness-color  (make-object color% "pink"))
+(define highest-badness-color (make-object color% "red"))
+;; the higher the badness, the closer to red the highlight should be
+(define (make-color-table max-badness)
+  (define min-g (send highest-badness-color green))
+  (define max-g (send lowest-badness-color  green))
+  (define min-b (send highest-badness-color blue))
+  (define max-b (send lowest-badness-color  blue))
+  (define delta-g (- max-g min-g))
+  (define delta-b (- max-b min-b))
+  (define bucket-size-g (quotient delta-g max-badness))
+  (define bucket-size-b (quotient delta-b max-badness))
+  (build-vector (add1 max-badness) ; to index directly using badness
+                (lambda (x)
+                  (make-object
+                   color%
+                   255
+                   ;; clipping, since the first (unused, for
+                   ;; badness of 0) would have invalid components
+                   (min 255 (- max-g (* (sub1 x) bucket-size-g)))
+                   (min 255 (- max-b (* (sub1 x) bucket-size-b)))))))
+
 (define remove-highlights-mixin
   (mixin ((class->interface text%)) ()
     (inherit begin-edit-sequence
@@ -28,13 +50,53 @@
              insert
              get-text)
 
-    (define highlights '())
+    (define highlights  '())
+    (define color-table #f)
+
+    (define (highlight-irritant i)
+      (define pos (syntax-position i))
+      (and pos
+           (let ([start (sub1 pos)]
+                 [end   (sub1 (+ pos (syntax-span i)))]
+                 [color "red"]
+                 [caret-space #f]
+                 [style 'hollow-ellipse])
+             ;; high priority, to display above the coloring
+             (send this highlight-range
+                   start end color caret-space 'high style)
+             ;; info needed to remove the highlight
+             (list start end color caret-space style))))
+
+    (define (highlight-entry l)
+      (match l
+        [(log-entry kind msg stx (? number? pos))
+         (let* ([start (sub1 pos)]
+                [end   (+ start (syntax-span stx))]
+                [opt?  (opt-log-entry? l)] ;; opt or missed opt?
+                [color (if opt?
+                           "lightgreen"
+                           (vector-ref color-table
+                                       (missed-opt-log-entry-badness l)))])
+           (send this highlight-range start end color)
+           (send this set-clickback start end
+                 (lambda (ed start end)
+                   (message-box "Performance Report" msg)))
+           ;; record highlights to undo them later
+           (cons (list start end color)
+                 ;; missed optimizations have irritants, circle them
+                 (if opt?
+                     '()
+                     (filter values ; remove irritants w/o location
+                             (map highlight-irritant
+                                  (missed-opt-log-entry-irritants l))))))]
+        [_ '()])) ; no source location, don't highlight anything
 
     (define/public (add-highlights)
       (define portname (send this get-port-name))
       (define input    (open-input-text-editor this))
       (port-count-lines! input)
       (define log '())
+      ;; generate the log
       (with-intercepted-tr-logging
        (lambda (l)
          (set! log (cons (cdr (vector-ref l 2)) ; log-entry struct
@@ -43,42 +105,14 @@
          (parameterize ([current-namespace  (make-base-namespace)]
                         [read-accept-reader #t])
            (expand (tr:read-syntax portname input)))))
-      (set! log (reverse log))
-      (define (highlight-irritant i)
-        (define pos (syntax-position i))
-        (and pos
-             (let ([start (sub1 pos)]
-                   [end   (sub1 (+ pos (syntax-span i)))]
-                   [color "red"]
-                   [caret-space #f]
-                   [style 'hollow-ellipse])
-               ;; high priority, to display above the coloring
-               (send this highlight-range
-                     start end color caret-space 'high style)
-               ;; info needed to remove the highlight
-               (list start end color caret-space style))))
-      ;; highlight
-      (define new-highlights
-        (for/list ([l (in-list log)])
-          (match l
-            [(log-entry kind msg stx (? number? pos))
-             (let* ([start (sub1 pos)]
-                    [end   (+ start (syntax-span stx))]
-                    [opt?  (opt-log-entry? l)] ;; opt or missed opt?
-                    [color (if opt? "lightgreen" "pink")])
-               (send this highlight-range start end color)
-               (send this set-clickback start end
-                     (lambda (ed start end)
-                       (message-box "Performance Report" msg)))
-               ;; record highlights to undo them later
-               (cons (list start end color)
-                     ;; missed optimizations have irritants, circle them
-                     (if opt?
-                         '()
-                         (filter values ; remove irritants w/o location
-                                 (map highlight-irritant
-                                      (missed-opt-log-entry-irritants l))))))]
-            [_ '()]))) ; no source location, don't highlight anything
+      (define max-badness
+        (for/fold ([max-badness 0])
+            ([l (in-list log)]
+             #:when (missed-opt-log-entry? l))
+          (max max-badness (missed-opt-log-entry-badness l))))
+      (unless (= max-badness 0) ; no missed opts, color table code would error
+        (set! color-table (make-color-table max-badness)))
+      (define new-highlights (map highlight-entry log))
       (set! highlights (append (apply append new-highlights) highlights)))
 
     (define (clear-highlights)