From 19fbb978ef71ce02d6ab9378ea201225ea0413e1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 25 Jun 2012 14:06:09 -0400 Subject: [PATCH] Split out some small utilities to prepare to reduce dependencies. original commit: a05acfee4c1387a829972db05643375fe3fcebbc --- collects/typed-racket/core.rkt | 2 +- collects/typed-racket/infer/signatures.rkt | 3 +- collects/typed-racket/tc-setup.rkt | 2 +- .../typed-racket/typecheck/signatures.rkt | 3 +- collects/typed-racket/typed-racket.rkt | 2 +- collects/typed-racket/types/subtype.rkt | 2 +- collects/typed-racket/utils/timing.rkt | 38 ++++++++++++ collects/typed-racket/utils/unit-utils.rkt | 12 ++++ collects/typed-racket/utils/utils.rkt | 59 ++----------------- 9 files changed, 62 insertions(+), 61 deletions(-) create mode 100644 collects/typed-racket/utils/timing.rkt create mode 100644 collects/typed-racket/utils/unit-utils.rkt diff --git a/collects/typed-racket/core.rkt b/collects/typed-racket/core.rkt index f30d3cac..7eb3b962 100644 --- a/collects/typed-racket/core.rkt +++ b/collects/typed-racket/core.rkt @@ -11,7 +11,7 @@ (rep type-rep) (for-template (only-in (base-env prims) :type :print-type :query-result-type)) (utils utils tc-utils arm) - "tc-setup.rkt") + "tc-setup.rkt" "utils/debug.rkt") (provide mb-core ti-core wt-core) diff --git a/collects/typed-racket/infer/signatures.rkt b/collects/typed-racket/infer/signatures.rkt index 342cf045..1b72a99f 100644 --- a/collects/typed-racket/infer/signatures.rkt +++ b/collects/typed-racket/infer/signatures.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/unit racket/contract racket/require - "constraint-structs.rkt" (path-up "utils/utils.rkt" "rep/type-rep.rkt")) + "constraint-structs.rkt" + (path-up "utils/utils.rkt" "utils/unit-utils.rkt" "rep/type-rep.rkt")) (provide (all-defined-out)) (define-signature dmap^ diff --git a/collects/typed-racket/tc-setup.rkt b/collects/typed-racket/tc-setup.rkt index 5606e66b..b152daa8 100644 --- a/collects/typed-racket/tc-setup.rkt +++ b/collects/typed-racket/tc-setup.rkt @@ -8,7 +8,7 @@ (typecheck typechecker provide-handling tc-toplevel) (env tvar-env type-name-env type-alias-env) (r:infer infer) - (utils tc-utils disarm mutated-vars) + (utils tc-utils disarm mutated-vars debug) (rep type-rep) (except-in (utils utils) infer) (only-in (r:infer infer-dummy) infer-param) diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index a2d5bb62..c3773191 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/unit racket/contract - "../utils/utils.rkt" (rep type-rep) (types utils)) + "../utils/utils.rkt" "../utils/unit-utils.rkt" + (rep type-rep) (types utils)) (provide (all-defined-out)) (define-signature tc-expr^ diff --git a/collects/typed-racket/typed-racket.rkt b/collects/typed-racket/typed-racket.rkt index 5ee80017..c06bb3db 100644 --- a/collects/typed-racket/typed-racket.rkt +++ b/collects/typed-racket/typed-racket.rkt @@ -1,7 +1,7 @@ #lang racket/base (require - (for-syntax racket/base "utils/utils.rkt") ;; only for timing/debugging + (for-syntax racket/base "utils/timing.rkt") ;; only for timing/debugging ;; the below requires are needed since they provide identifiers ;; that may appear in the residual program (for-syntax "typecheck/renamer.rkt" "types/type-table.rkt") diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 72417e20..becf609c 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -270,7 +270,7 @@ [((or (? Struct? s1) (NameStruct: s1)) (or (? Struct? s2) (NameStruct: s2))) (=> unmatch) (cond [(unrelated-structs s1 s2) - (dprintf "found unrelated structs: ~a ~a\n" s1 s2) + ;(dprintf "found unrelated structs: ~a ~a\n" s1 s2) (fail! s t)] [else (unmatch)])] ;; similar case for structs and base types, which are obviously unrelated diff --git a/collects/typed-racket/utils/timing.rkt b/collects/typed-racket/utils/timing.rkt new file mode 100644 index 00000000..6d171a85 --- /dev/null +++ b/collects/typed-racket/utils/timing.rkt @@ -0,0 +1,38 @@ +#lang racket/base +(require (for-syntax racket/base)) +(provide start-timing do-time) + +;; some macros to do some timing, only when `timing?' is #t +(define-for-syntax timing? #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 '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" 32 #\space) initial-time)))]) + (syntax-rules () + [(_ msg) + (begin + (unless last-time + (start-timing msg)) + (let* ([t (current-process-milliseconds)] + [old last-time] + [diff (- t old)] + [new-msg (pad msg 32 #\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))))) diff --git a/collects/typed-racket/utils/unit-utils.rkt b/collects/typed-racket/utils/unit-utils.rkt new file mode 100644 index 00000000..aeec3dcf --- /dev/null +++ b/collects/typed-racket/utils/unit-utils.rkt @@ -0,0 +1,12 @@ +#lang racket/base +(require (for-syntax racket/base) "utils.rkt" racket/unit) + +(provide cond-contracted) + +(define-signature-form (cond-contracted stx) + (syntax-case stx () + [(_ nm cnt) + (if enable-contracts? + (list #'[contracted (nm cnt)]) + (list #'nm))])) + diff --git a/collects/typed-racket/utils/utils.rkt b/collects/typed-racket/utils/utils.rkt index 2f9271de..a8881634 100644 --- a/collects/typed-racket/utils/utils.rkt +++ b/collects/typed-racket/utils/utils.rkt @@ -6,12 +6,11 @@ at least theoretically. |# (require (for-syntax racket/base syntax/parse racket/string) - racket/require-syntax racket/unit - racket/provide-syntax (prefix-in d: unstable/debug) - racket/struct-info) + racket/require-syntax racket/provide-syntax + racket/struct-info "timing.rkt") ;; to move to unstable -(provide reverse-begin list-update list-set debugf debugging? dprintf) +(provide list-update list-set) (provide ;; optimization @@ -94,9 +93,6 @@ at least theoretically. (define-requirer optimizer optimizer-out) (define-requirer base-env base-env-out) -;; run `h' last, but drop its return value -(define-syntax-rule (reverse-begin h . forms) (begin0 (begin . forms) h)) - ;; conditionalized logging ;; there's some logging code in the source ;; which was used for gathering statistics about various programs @@ -110,41 +106,6 @@ at least theoretically. #'(log-debug (format fmt . args))]) #'(void))) -;; some macros to do some timing, only when `timing?' is #t -(define-for-syntax timing? #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 '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" 32 #\space) initial-time)))]) - (syntax-rules () - [(_ msg) - (begin - (unless last-time - (start-timing msg)) - (let* ([t (current-process-milliseconds)] - [old last-time] - [diff (- t old)] - [new-msg (pad msg 32 #\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 ;; this requires lots of work for two reasons: ;; - 1 printers have to be defined at the same time as the structs @@ -180,8 +141,7 @@ at least theoretically. ;; turn contracts on and off - off by default for performance. (provide (for-syntax enable-contracts?) provide/cond-contract - with-cond-contract - cond-contracted + with-cond-contract define-struct/cond-contract define/cond-contract contract-req @@ -242,13 +202,6 @@ at least theoretically. [(_ hd ([i c] ...) . opts) (define-struct hd (i ...) . opts)]))) -(define-signature-form (cond-contracted stx) - (syntax-case stx () - [(_ nm cnt) - (if enable-contracts? - (list #'[contracted (nm cnt)]) - (list #'nm))])) - (define (list-update l i f) (cond [(null? l) (error 'list-update "list not long enough" l i f)] [(zero? i) (cons (f (car l)) (cdr l))] @@ -259,10 +212,6 @@ at least theoretically. (cons v (cdr l)) (cons (car l) (list-set (cdr l) (sub1 k) v)))) -(define debugging? (make-parameter #f)) -(define-syntax-rule (debugf f . args) (if (debugging?) (d:debugf f . args) (f . args))) -(define (dprintf . args) (when (debugging?) (apply d:dprintf args))) - (provide make-struct-info-self-ctor) ;Copied from racket/private/define-struct