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

Improve TR timing, add more timing events.

Browse Source 
original commit: 36ab55c1e5147e3c2e58c3cf2a92be86e5799414
This commit is contained in:
Sam Tobin-Hochstadt 2014-05-01 15:26:48 -04:00
parent f7cdf5f1ae
commit 8bba85dd57
2 changed files with 38 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -13,11 +13,12 @@
(utils tc-utils)
(typecheck provide-handling def-binding tc-structs
typechecker internal-forms)
(for-template
(only-in syntax/location quote-module-name)
racket/base))
syntax/location
racket/format
(for-template
(only-in syntax/location quote-module-name)
racket/base
(env env-req)))
(provide/cond-contract
[tc-module (syntax? . c:-> . (values syntax? syntax?))]
@ -44,6 +45,13 @@
;; syntax? -> (listof def-binding?)
(define (tc-toplevel/pass1 form)
#; ;; pass1 is fast
(do-time (format "pass1 ~a line ~a"
(if #t
(substring (~a (syntax-source form))
(max 0 (- (string-length (~a (syntax-source form))) 20)))
(syntax-source form))
(syntax-line form)))
(parameterize ([current-orig-stx form])
(syntax-parse form
#:literals (values define-values #%plain-app begin define-syntaxes)
@ -180,6 +188,13 @@
;; no side-effects
;; syntax? -> (or/c 'no-type tc-results/c)
(define (tc-toplevel/pass2 form)
(do-time (format "pass2 ~a line ~a"
(if #t
(substring (~a (syntax-source form))
(max 0 (- (string-length (~a (syntax-source form))) 20)))
(syntax-source form))
(syntax-line form)))
(parameterize ([current-orig-stx form])
(syntax-parse form
#:literal-sets (kernel-literals)
@ -248,6 +263,7 @@
;; syntax-list -> (values syntax syntax)
(define (type-check forms0)
(define forms (syntax->list forms0))
(do-time "before form splitting")
(define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs)
(filter-multiple
forms
@ -258,13 +274,11 @@
provide?
define/fixup-contract?))
(do-time "Form splitting done")
;(printf "before parsing type aliases~n")
(define-values (type-alias-names type-alias-map)
(get-type-alias-info type-aliases))
;; Add the struct names to the type table, but not with a type
;(printf "before adding type names~n")
(let ((names (map name-of-struct struct-defs))
(type-vars (map type-vars-of-struct struct-defs)))
(for ([name names])
@ -272,10 +286,11 @@
name (make-Name name null #f #t)))
(for-each register-type-name names)
(for-each add-constant-variance! names type-vars))
;(printf "after adding type names~n")
(do-time "after adding type names")
(register-all-type-aliases type-alias-names type-alias-map)
(do-time "starting struct handling")
;; Parse and register the structure types
(define parsed-structs
(for/list ((def (in-list struct-defs)))
@ -287,8 +302,7 @@
;; register the bindings of the structs
(define struct-bindings (map register-parsed-struct-bindings! parsed-structs))
;(printf "after resolving type aliases~n")
;(displayln "Starting pass1")
(do-time "before pass1")
;; do pass 1, and collect the defintions
(define *defs (apply append
(append
@ -296,7 +310,7 @@
(map tc-toplevel/pass1 forms))))
;; do pass 1.5 to finish up the definitions
(define defs (append *defs (apply append (map tc-toplevel/pass1.5 forms))))
;(displayln "Finished pass1")
(do-time "Finished pass1")
;; separate the definitions into structures we'll handle for provides
(define def-tbl
(for/fold ([h (make-immutable-free-id-table)])
@ -312,10 +326,11 @@
[else
(int-err "Two conflicting definitions: ~a ~a" def other-def)]))
(dict-update h (binding-name def) merge-def-bindings #f)))
(do-time "computed def-tbl")
;; typecheck the expressions and the rhss of defintions
;(displayln "Starting pass2")
(for-each tc-toplevel/pass2 forms)
;(displayln "Finished pass2")
(do-time "Finished pass2")
;; check that declarations correspond to definitions
(check-all-registered-types)
;; report delayed errors
@ -384,7 +399,7 @@
;; syntax -> (values syntax syntax)
(define (tc-module stx)
(syntax-parse stx
[(pmb . forms) (type-check #'forms)]))
[(pmb . forms) (begin0 (type-check #'forms) (do-time "finished type checking"))]))
;; typecheck a top-level form
;; used only from #%top-interaction

15
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/timing.rkt
View File

@ -7,9 +7,10 @@
(define-logger tr-timing)
(define last-time #f) (define initial-time #f)
(define last-time #f) (define initial-time #f) (define gc-time #f)
(define (set!-initial-time t) (set! initial-time t))
(define (set!-last-time t) (set! last-time t))
(define (set!-gc-time t) (set! gc-time t))
(define (pad str len pad-char)
(define l (string-length str))
(if (>= l len)
@ -21,11 +22,12 @@
(syntax-rules ()
[(_ msg)
(log-tr-timing-debug
(let ()
(begin
(when last-time
(error 'start-timing "Timing already started"))
(set!-last-time (current-process-milliseconds))
(set!-initial-time last-time)
(set!-gc-time (current-gc-milliseconds))
(format "~a at ~a"
(pad "Starting" 32 #\space) initial-time)))])
(syntax-rules ()
@ -35,10 +37,13 @@
(unless last-time
(start-timing msg))
(let* ([t (current-process-milliseconds)]
[gc (current-gc-milliseconds)]
[old last-time]
[diff (- t old)]
[new-msg (pad msg 32 #\space)])
[gc-diff (- gc gc-time)]
[new-msg (pad msg 40 #\space)])
(set!-last-time t)
(format "~a at ~a\tlast step: ~a\ttotal: ~a"
new-msg t diff (- t initial-time)))))]))
(set!-gc-time gc)
(format "~a at ~a\tlast step: ~a\tgc: ~a\ttotal: ~a"
new-msg t diff gc-diff (- t initial-time)))))]))
(values (lambda _ #'(void)) (lambda _ #'(void)))))