From 8bba85dd5732c831aa3a502c7ef6bb18081a8a18 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 May 2014 15:26:48 -0400 Subject: [PATCH] Improve TR timing, add more timing events. original commit: 36ab55c1e5147e3c2e58c3cf2a92be86e5799414 --- .../typed-racket/typecheck/tc-toplevel.rkt | 41 +++++++++++++------ .../typed-racket/utils/timing.rkt | 15 ++++--- 2 files changed, 38 insertions(+), 18 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index e91e264c..fcbf3eb0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -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 diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/timing.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/timing.rkt index 90a4933f..122583fa 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/timing.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/timing.rkt @@ -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)))))