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

Much more infrastructure for timing typed racket passes.

Browse Source 
original commit: 403bb6414e5ba29e653e2c2dd18de076177f440d
This commit is contained in:
Sam Tobin-Hochstadt 2011-08-26 12:17:54 -04:00
parent 91c229be09
commit 4068b47296
4 changed files with 39 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/typed-scheme/core.rkt
View File

@ -31,11 +31,11 @@
(;; pmb = #%plain-module-begin
[(pmb . body2) new-mod]
;; perform the provide transformation from [Culpepper 07]
[transformed-body (remove-provides #'body2)]
[transformed-body (begin0 (remove-provides #'body2) (do-time "Removed provides"))]
;; add the real definitions of contracts on requires
[transformed-body (change-contract-fixups #'transformed-body)]
[transformed-body (begin0 (change-contract-fixups #'transformed-body) (do-time "Fixed contract ids"))]
;; potentially optimize the code based on the type information
[(optimized-body ...) (maybe-optimize #'transformed-body)]
[(optimized-body ...) (maybe-optimize #'transformed-body)] ;; has own call to do-time
;; add in syntax property on useless expression to draw check-syntax arrows
[check-syntax-help (syntax-property
(syntax-property

4
collects/typed-scheme/tc-setup.rkt
View File

@ -4,7 +4,6 @@
(except-in syntax/parse id)
unstable/mutated-vars
racket/pretty
scheme/base
(optimizer optimizer)
(private type-contract)
(types utils convenience)
@ -35,7 +34,7 @@
(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body)
(let ()
(set-box! typed-context? #t)
(start-timing (syntax-property stx 'enclosing-module-name))
;(start-timing (syntax-property stx 'enclosing-module-name))
(with-handlers
([(lambda (e) (and #f (exn:fail? e) (not (exn:fail:syntax? e))))
(lambda (e) (tc-error "Internal Typed Racket Error : ~a" e))])
@ -68,6 +67,7 @@
[orig-module-stx (or (orig-module-stx) orig-stx)]
[expanded-module-stx fully-expanded-stx]
[debugging? #f])
(do-time "Starting `checker'")
(let ([result (checker fully-expanded-stx)])
(do-time "Typechecking Done")
(let () . body))))))))

19
collects/typed-scheme/typed-scheme.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require (for-syntax racket/base
"utils/utils.rkt" ;; only for timing/debugging
;; these requires are needed since their code
;; appears in the residual program
"typecheck/renamer.rkt" "types/type-table.rkt"))
@ -16,18 +17,28 @@
(define-for-syntax initialized #f)
(define-for-syntax (do-standard-inits)
(unless initialized
(do-time "Starting initialization")
((dynamic-require 'typed-scheme/base-env/base-structs 'initialize-structs))
((dynamic-require 'typed-scheme/base-env/base-env-indexing 'initialize-indexing))
((dynamic-require 'typed-scheme/base-env/base-env 'init))
((dynamic-require 'typed-scheme/base-env/base-env-numeric 'init))
(do-time "Finshed base-structs")
((dynamic-require 'typed-scheme/base-env/base-env-indexing 'initialize-indexing))
(do-time "Finshed base-env-indexing")
((dynamic-require 'typed-scheme/base-env/base-env 'init))
(do-time "Finshed base-env")
((dynamic-require 'typed-scheme/base-env/base-env-numeric 'init))
(do-time "Finshed base-env-numeric")
((dynamic-require 'typed-scheme/base-env/base-special-env 'initialize-special))
(do-time "Finished base-special-env")
(set! initialized #t)))
(define-syntax-rule (drivers [name sym] ...)
(begin
(define-syntax (name stx)
(do-time (format "Calling ~a driver" 'name))
(do-standard-inits)
((dynamic-require 'typed-scheme/core 'sym) stx))
(define f (dynamic-require 'typed-scheme/core 'sym))
(do-time (format "Loaded core ~a" 'sym))
(begin0 (f stx)
(do-time "Finished, returning to Racket")))
...))
(drivers [module-begin mb-core] [top-interaction ti-core] [with-type wt-core])

29
collects/typed-scheme/utils/utils.rkt
View File

@ -106,27 +106,36 @@ at least theoretically.
;; some macros to do some timing, only when `timing?' is #t
(define-for-syntax timing? #f)
(define last-time (make-parameter #f))
(define last-time #f) (define initial-time #f)
(define (set!-initial-time t) (set! initial-time t))
(define (set!-last-time t) (set! last-time t))
(define (pad str len pad-char)
(define l (string-length str))
(if (>= l len)
str
(string-append str (make-string (- len l) pad-char))))
(define-syntaxes (start-timing do-time)
(if timing?
(values
(syntax-rules ()
[(_ msg)
(begin
(when (last-time)
(error #f "Timing already started"))
(last-time (current-process-milliseconds))
(printf "Starting ~a at ~a\n" msg (last-time)))])
(when last-time
(error 'start-timing "Timing already started"))
(set!-last-time (current-process-milliseconds))
(set!-initial-time last-time)
(log-debug (format "TR Timing: ~a at ~a" (pad "Starting" 40 #\space) initial-time)))])
(syntax-rules ()
[(_ msg)
(begin
(unless (last-time)
(unless last-time
(start-timing msg))
(let* ([t (current-process-milliseconds)]
[old (last-time)]
[diff (- t old)])
(last-time t)
(printf "Timing ~a at ~a@~a\n" msg diff t)))]))
[old last-time]
[diff (- t old)]
[new-msg (pad msg 40 #\space)])
(set!-last-time t)
(log-debug (format "TR Timing: ~a at ~a\tlast step: ~a\ttotal: ~a" new-msg t diff (- t initial-time)))))]))
(values (lambda _ #'(void)) (lambda _ #'(void)))))
;; custom printing