suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Keep located syntax around so we can use it in the tool.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-08 11:55:48 -04:00
parent d2a8a620b1
commit c1fe25200b
2 changed files with 16 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/typed-scheme/optimizer/logging.rkt
View File

@ -25,13 +25,15 @@
(define log-so-far '()) (define log-so-far '())
;; msg is for consumption by the DrRacket tool ;; msg is for consumption by the DrRacket tool
(struct log-entry (kind msg stx pos) #:prefab) (struct log-entry (kind msg stx located-stx pos) #:prefab)
;; for optimizations only (not missed optimizations, those are below) ;; for optimizations only (not missed optimizations, those are below)
(struct opt-log-entry log-entry () #:prefab) (struct opt-log-entry log-entry () #:prefab)
(define (log-optimization kind msg stx) (define (log-optimization kind msg stx)
(let ([new-entry (opt-log-entry kind msg stx (syntax-position stx))]) (let ([new-entry
(opt-log-entry kind msg
stx (locate-stx stx) (syntax-position stx))])
(set! log-so-far (cons new-entry log-so-far)))) (set! log-so-far (cons new-entry log-so-far))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
@ -74,6 +76,7 @@
(log-entry-kind parent) ; same as child's (log-entry-kind parent) ; same as child's
(log-entry-msg parent) (log-entry-msg parent)
(log-entry-stx parent) ; we report the outermost one (log-entry-stx parent) ; we report the outermost one
(log-entry-located-stx parent)
(log-entry-pos parent) (log-entry-pos parent)
(remove-duplicates (remove-duplicates
@ -95,7 +98,8 @@
;; implicitly ;; implicitly
[irritants (if (list? irritants) irritants (list irritants))] [irritants (if (list? irritants) irritants (list irritants))]
[new [new
(missed-opt-log-entry kind msg stx (syntax-position stx) (missed-opt-log-entry kind msg
stx (locate-stx stx) (syntax-position stx)
irritants '() 1)] irritants '() 1)]
;; check if the new one is the child of an old one ;; check if the new one is the child of an old one
;; for/first is ok, since we can only have one parent in the list ;; for/first is ok, since we can only have one parent in the list
@ -144,8 +148,8 @@
(define (sort-log) (define (sort-log)
(sort (remove-duplicates log-so-far) (sort (remove-duplicates log-so-far)
(match-lambda* (match-lambda*
[(list (log-entry kind-x msg-x stx-x pos-x) [(list (log-entry kind-x msg-x stx-x loc-stx-x pos-x)
(log-entry kind-y msg-y stx-y pos-y)) (log-entry kind-y msg-y stx-y loc-stx-y pos-y))
(cond [(not (or pos-x pos-y)) (cond [(not (or pos-x pos-y))
;; neither have location, sort by message ;; neither have location, sort by message
(string<? msg-x msg-y)] (string<? msg-x msg-y)]
@ -184,7 +188,7 @@
;; For command-line printing purposes. ;; For command-line printing purposes.
;; Not as user friendly as what's produced by the DrRacket tool. ;; Not as user friendly as what's produced by the DrRacket tool.
(define (format-log-entry entry) (define (format-log-entry entry)
(define stx (locate-stx (log-entry-stx entry))) (define stx (log-entry-located-stx entry))
(define msg (define msg
(format "~a ~a ~s -- ~a" (format "~a ~a ~s -- ~a"
(syntax-source-file-name stx) (syntax-source-file-name stx)

4
collects/typed-scheme/optimizer/tool/report.rkt
View File

@ -42,8 +42,8 @@
(define (log->report log) (define (log->report log)
(define (log-entry->report-entry l) (define (log-entry->report-entry l)
(match l (match l
[(log-entry kind msg stx (? number? pos)) [(log-entry kind msg stx located-stx (? number? pos))
(define stxs+msgs `((,stx . ,msg))) (define stxs+msgs `((,located-stx . ,msg)))
(define start (sub1 pos)) (define start (sub1 pos))
(define end (+ start (syntax-span stx))) (define end (+ start (syntax-span stx)))
(if (opt-log-entry? l) (if (opt-log-entry? l)