From 2151a7edc0b64b52941baedad9f6daaf657f093b Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 3 Jun 2011 16:04:26 -0400
Subject: [PATCH] Put logging code in its own file.

original commit: 4c31b085546f5e4c6f20982b805fcebd6c6bb5ba
---
 collects/tests/typed-scheme/optimizer/run.rkt |   2 +-
 collects/typed-scheme/optimizer/apply.rkt     |   2 +-
 collects/typed-scheme/optimizer/box.rkt       |   2 +-
 collects/typed-scheme/optimizer/dead-code.rkt |   2 +-
 collects/typed-scheme/optimizer/fixnum.rkt    |   2 +-
 .../typed-scheme/optimizer/float-complex.rkt  |   2 +-
 collects/typed-scheme/optimizer/float.rkt     |   2 +-
 collects/typed-scheme/optimizer/logging.rkt   | 112 ++++++++++++++++++
 collects/typed-scheme/optimizer/number.rkt    |   2 +-
 collects/typed-scheme/optimizer/optimizer.rkt |   5 +-
 collects/typed-scheme/optimizer/pair.rkt      |   2 +-
 collects/typed-scheme/optimizer/sequence.rkt  |   2 +-
 collects/typed-scheme/optimizer/string.rkt    |   2 +-
 collects/typed-scheme/optimizer/struct.rkt    |   2 +-
 .../typed-scheme/optimizer/unboxed-let.rkt    |   2 +-
 collects/typed-scheme/optimizer/utils.rkt     | 111 +----------------
 collects/typed-scheme/optimizer/vector.rkt    |   2 +-
 17 files changed, 131 insertions(+), 125 deletions(-)
 create mode 100644 collects/typed-scheme/optimizer/logging.rkt

diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt
index 7b1f5f32..fdea4c71 100644
--- a/collects/tests/typed-scheme/optimizer/run.rkt
+++ b/collects/tests/typed-scheme/optimizer/run.rkt
@@ -1,7 +1,7 @@
 #lang racket
 (require racket/runtime-path
          rackunit rackunit/text-ui
-         typed-scheme/optimizer/utils
+         typed-scheme/optimizer/logging
          unstable/logging)
 
 (provide optimization-tests missed-optimization-tests
diff --git a/collects/typed-scheme/optimizer/apply.rkt b/collects/typed-scheme/optimizer/apply.rkt
index e85c2dee..cd4eb0f2 100644
--- a/collects/typed-scheme/optimizer/apply.rkt
+++ b/collects/typed-scheme/optimizer/apply.rkt
@@ -2,7 +2,7 @@
 (require syntax/parse
          (for-template scheme/unsafe/ops racket/base (prefix-in k: '#%kernel))
          "../utils/utils.rkt"
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide apply-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/box.rkt b/collects/typed-scheme/optimizer/box.rkt
index 66f3d097..e2d6bd64 100644
--- a/collects/typed-scheme/optimizer/box.rkt
+++ b/collects/typed-scheme/optimizer/box.rkt
@@ -6,7 +6,7 @@
          (for-template scheme/base scheme/unsafe/ops)
          (rep type-rep)
          (types type-table utils)
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide box-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/dead-code.rkt b/collects/typed-scheme/optimizer/dead-code.rkt
index d73e16da..3be84192 100644
--- a/collects/typed-scheme/optimizer/dead-code.rkt
+++ b/collects/typed-scheme/optimizer/dead-code.rkt
@@ -4,7 +4,7 @@
          (for-template scheme/base)
          "../utils/utils.rkt"
          (types type-table)
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide dead-code-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt
index 8bfe3eee..2e431e25 100644
--- a/collects/typed-scheme/optimizer/fixnum.rkt
+++ b/collects/typed-scheme/optimizer/fixnum.rkt
@@ -4,7 +4,7 @@
          "../utils/utils.rkt"
          (for-template scheme/base scheme/fixnum scheme/unsafe/ops)
          (types numeric-tower)
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide fixnum-expr fixnum-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/float-complex.rkt b/collects/typed-scheme/optimizer/float-complex.rkt
index 4ce6797a..e33ba28c 100644
--- a/collects/typed-scheme/optimizer/float-complex.rkt
+++ b/collects/typed-scheme/optimizer/float-complex.rkt
@@ -4,7 +4,7 @@
          "../utils/utils.rkt" racket/unsafe/ops
          (for-template scheme/base scheme/math racket/flonum scheme/unsafe/ops)
          (types numeric-tower)
-         (optimizer utils numeric-utils float))
+         (optimizer utils numeric-utils logging float))
 
 (provide float-complex-opt-expr
          float-complex-arith-opt-expr
diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt
index d27b3c16..a50270f9 100644
--- a/collects/typed-scheme/optimizer/float.rkt
+++ b/collects/typed-scheme/optimizer/float.rkt
@@ -5,7 +5,7 @@
          (for-template racket/base racket/flonum racket/unsafe/ops racket/math)
          "../utils/utils.rkt"
          (types numeric-tower)
-         (optimizer utils numeric-utils fixnum))
+         (optimizer utils numeric-utils logging fixnum))
 
 (provide float-opt-expr float-arg-expr)
 
diff --git a/collects/typed-scheme/optimizer/logging.rkt b/collects/typed-scheme/optimizer/logging.rkt
new file mode 100644
index 00000000..affb9d48
--- /dev/null
+++ b/collects/typed-scheme/optimizer/logging.rkt
@@ -0,0 +1,112 @@
+#lang racket/base
+
+(require racket/set racket/string racket/match
+         unstable/syntax)
+
+(provide log-optimization log-missed-optimization
+         optimization-log-key
+         print-log clear-log)
+
+(define (line+col->string stx)
+  (let ([line (syntax-line stx)]
+        [col  (syntax-column stx)])
+    (if (and line col)
+        (format "~a:~a" line col)
+        "(no location)")))
+
+(struct log-entry (msg line col) #:transparent)
+
+;; to identify log messages that come from the optimizer
+;; to be stored in the data section of log messages
+;; external tools/scripts (like the test harness) can look for it
+;; since this is used across phases, can't be a gensym
+(define optimization-log-key 'log-message-coming-from-the-TR-optimizer)
+
+;; we keep track of log entries, to avoid repetitions that would be
+;; caused by traversing the same syntax multiple times (which is not
+;; a problem per se)
+(define log-so-far (set))
+
+(define (gen-log-message msg stx)
+  (format "~a ~a ~a -- ~a"
+          (syntax-source-file-name stx)
+          (line+col->string stx)
+          (syntax->datum stx)
+          msg))
+
+(define (do-logging msg stx)
+  (let* ([new-message (gen-log-message msg stx)]
+         [new-entry (log-entry new-message
+                               (syntax-line stx)
+                               (syntax-column stx))])
+    (unless (set-member? log-so-far new-entry)
+      (set! log-so-far (set-add log-so-far new-entry)))))
+
+;; once the optimizer is done, we sort the log according to source
+;; location, then print it
+(define (print-log)
+  (define logger (current-logger))
+  ;; add missed optimizations messages to the log, now that we know all of them
+  (for-each (lambda (x) (do-logging (missed-optimization-msg x)
+                                    (missed-optimization-stx x)))
+            missed-optimizations-log)
+  (for-each (lambda (x) (log-message logger 'warning (log-entry-msg x)
+                                     optimization-log-key))
+            (sort (set->list log-so-far)
+                  (lambda (x y)
+                    (match* (x y)
+                      [((log-entry msg-x line-x col-x)
+                        (log-entry msg-y line-y col-y))
+                       (cond [(not (or line-x line-y))
+                              ;; neither have location, sort by message
+                              (string<? msg-x msg-y)]
+                             [(not line-y) #f]
+                             [(not line-x) #t]
+                             [else
+                              ;; both have location
+                              (let* ([loc-x (+ (* 1000 line-x) col-x)]
+                                     ;; 1000 is a conservative bound
+                                     [loc-y (+ (* 1000 line-y) col-y)])
+                                (cond [(= loc-x loc-y)
+                                       ;; same location, sort by message
+                                       (string<? msg-x msg-y)]
+                                      ;; sort by source location
+                                      [else (< loc-x loc-y)]))])])))))
+(define (clear-log)
+  (set! log-so-far (set))
+  (set! missed-optimizations-log '()))
+
+(define (log-optimization kind stx) (do-logging kind stx))
+
+
+;; Keep track of optimizations that "almost" happened, with the intention
+;; of reporting them to the user.
+;; This is meant to help users understand what hurts the performance of
+;; their programs.
+
+;; badness : Integer. crude measure of how severe the missed optimizations are
+;;  currently, it's simply a count of how many missed optimizations occur
+;;  within a given syntax object
+(struct missed-optimization (msg stx irritants [badness #:mutable])
+        #:transparent)
+
+(define missed-optimizations-log '())
+
+(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))]
+         [msg (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)])
+    (set! missed-optimizations-log
+          (cons (missed-optimization msg stx irritants 1)
+                missed-optimizations-log))))
diff --git a/collects/typed-scheme/optimizer/number.rkt b/collects/typed-scheme/optimizer/number.rkt
index 310eec3b..8673f9a5 100644
--- a/collects/typed-scheme/optimizer/number.rkt
+++ b/collects/typed-scheme/optimizer/number.rkt
@@ -3,7 +3,7 @@
 (require syntax/parse
          (for-template scheme/base)
          "../utils/utils.rkt"
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide number-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index 69e20234..9f412703 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -4,8 +4,9 @@
          racket/pretty
          (for-template scheme/base)
          "../utils/utils.rkt"
-         (optimizer utils number fixnum float float-complex vector string
-                    pair sequence box struct dead-code apply unboxed-let))
+         (optimizer utils logging
+                    number fixnum float float-complex vector string pair
+                    sequence box struct dead-code apply unboxed-let))
 
 (provide optimize-top)
 
diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt
index 70971866..255f1ddf 100644
--- a/collects/typed-scheme/optimizer/pair.rkt
+++ b/collects/typed-scheme/optimizer/pair.rkt
@@ -7,7 +7,7 @@
          (rep type-rep)
          (types type-table utils)
          (typecheck typechecker)
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide pair-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/sequence.rkt b/collects/typed-scheme/optimizer/sequence.rkt
index 2ca95990..35e5413c 100644
--- a/collects/typed-scheme/optimizer/sequence.rkt
+++ b/collects/typed-scheme/optimizer/sequence.rkt
@@ -6,7 +6,7 @@
          "../utils/utils.rkt" "../utils/tc-utils.rkt"
          (rep type-rep)
          (types abbrev type-table utils)
-         (optimizer utils string))
+         (optimizer utils logging string))
 
 (provide sequence-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/string.rkt b/collects/typed-scheme/optimizer/string.rkt
index 66ac4b6f..58177435 100644
--- a/collects/typed-scheme/optimizer/string.rkt
+++ b/collects/typed-scheme/optimizer/string.rkt
@@ -4,7 +4,7 @@
          (for-template scheme/base scheme/unsafe/ops)
          "../utils/utils.rkt"
          (types abbrev)
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide string-opt-expr string-expr bytes-expr)
 
diff --git a/collects/typed-scheme/optimizer/struct.rkt b/collects/typed-scheme/optimizer/struct.rkt
index 3271b18b..1d8bc63f 100644
--- a/collects/typed-scheme/optimizer/struct.rkt
+++ b/collects/typed-scheme/optimizer/struct.rkt
@@ -4,7 +4,7 @@
          (for-template scheme/base scheme/unsafe/ops)
          "../utils/utils.rkt"
          (types type-table)
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide struct-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt
index e5660f5f..e751fa0c 100644
--- a/collects/typed-scheme/optimizer/unboxed-let.rkt
+++ b/collects/typed-scheme/optimizer/unboxed-let.rkt
@@ -7,7 +7,7 @@
          (for-template scheme/base)
          (types numeric-tower utils type-table)
          (rep type-rep)
-         (optimizer utils float-complex))
+         (optimizer utils logging float-complex))
 
 (provide unboxed-let-opt-expr)
 
diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-scheme/optimizer/utils.rkt
index a189bb5f..3c0cd9b0 100644
--- a/collects/typed-scheme/optimizer/utils.rkt
+++ b/collects/typed-scheme/optimizer/utils.rkt
@@ -1,126 +1,19 @@
 #lang racket/base
 
-(require unstable/match racket/match racket/set racket/string
+(require unstable/match racket/match
          racket/dict syntax/id-table racket/syntax unstable/syntax
          "../utils/utils.rkt"
          (for-template racket/base)
          (types type-table utils subtype)
          (rep type-rep))
 
-(provide log-optimization log-missed-optimization
-         optimization-log-key
-         print-log clear-log
-         *show-optimized-code*
+(provide *show-optimized-code*
          subtypeof? isoftype?
          mk-unsafe-tbl
          n-ary->binary
          unboxed-gensym reset-unboxed-gensym
          optimize)
 
-(define (line+col->string stx)
-  (let ([line (syntax-line stx)]
-        [col  (syntax-column stx)])
-    (if (and line col)
-        (format "~a:~a" line col)
-        "(no location)")))
-
-(struct log-entry (msg line col) #:transparent)
-
-;; to identify log messages that come from the optimizer
-;; to be stored in the data section of log messages
-;; external tools/scripts (like the test harness) can look for it
-;; since this is used across phases, can't be a gensym
-(define optimization-log-key 'log-message-coming-from-the-TR-optimizer)
-
-;; we keep track of log entries, to avoid repetitions that would be
-;; caused by traversing the same syntax multiple times (which is not
-;; a problem per se)
-(define log-so-far (set))
-
-(define (gen-log-message msg stx)
-  (format "~a ~a ~a -- ~a"
-          (syntax-source-file-name stx)
-          (line+col->string stx)
-          (syntax->datum stx)
-          msg))
-
-(define (do-logging msg stx)
-  (let* ([new-message (gen-log-message msg stx)]
-         [new-entry (log-entry new-message
-                               (syntax-line stx)
-                               (syntax-column stx))])
-    (unless (set-member? log-so-far new-entry)
-      (set! log-so-far (set-add log-so-far new-entry)))))
-
-;; once the optimizer is done, we sort the log according to source
-;; location, then print it
-(define (print-log)
-  (define logger (current-logger))
-  ;; add missed optimizations messages to the log, now that we know all of them
-  (for-each (lambda (x) (do-logging (missed-optimization-msg x)
-                                    (missed-optimization-stx x)))
-            missed-optimizations-log)
-  (for-each (lambda (x) (log-message logger 'warning (log-entry-msg x)
-                                     optimization-log-key))
-            (sort (set->list log-so-far)
-                  (lambda (x y)
-                    (match* (x y)
-                      [((log-entry msg-x line-x col-x)
-                        (log-entry msg-y line-y col-y))
-                       (cond [(not (or line-x line-y))
-                              ;; neither have location, sort by message
-                              (string<? msg-x msg-y)]
-                             [(not line-y) #f]
-                             [(not line-x) #t]
-                             [else
-                              ;; both have location
-                              (let* ([loc-x (+ (* 1000 line-x) col-x)]
-                                     ;; 1000 is a conservative bound
-                                     [loc-y (+ (* 1000 line-y) col-y)])
-                                (cond [(= loc-x loc-y)
-                                       ;; same location, sort by message
-                                       (string<? msg-x msg-y)]
-                                      ;; sort by source location
-                                      [else (< loc-x loc-y)]))])])))))
-(define (clear-log)
-  (set! log-so-far (set))
-  (set! missed-optimizations-log '()))
-
-(define (log-optimization kind stx) (do-logging kind stx))
-
-;; Keep track of optimizations that "almost" happened, with the intention
-;; of reporting them to the user.
-;; This is meant to help users understand what hurts the performance of
-;; their programs.
-
-;; badness : Integer. crude measure of how severe the missed optimizations are
-;;  currently, it's simply a count of how many missed optimizations occur
-;;  within a given syntax object
-(struct missed-optimization (msg stx irritants [badness #:mutable])
-        #:transparent)
-
-(define missed-optimizations-log '())
-
-(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))]
-         [msg (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)])
-    (set! missed-optimizations-log
-          (cons (missed-optimization msg stx irritants 1)
-                missed-optimizations-log))))
-
-
 ;; if set to #t, the optimizer will dump its result to stdout before compilation
 (define *show-optimized-code* #f)
 
diff --git a/collects/typed-scheme/optimizer/vector.rkt b/collects/typed-scheme/optimizer/vector.rkt
index 69c1841b..c18da3cb 100644
--- a/collects/typed-scheme/optimizer/vector.rkt
+++ b/collects/typed-scheme/optimizer/vector.rkt
@@ -6,7 +6,7 @@
          "../utils/utils.rkt"
          (rep type-rep)
          (types type-table utils)
-         (optimizer utils))
+         (optimizer utils logging))
 
 (provide vector-opt-expr)