Split out some small utilities to prepare to reduce dependencies.
original commit: a05acfee4c1387a829972db05643375fe3fcebbc
This commit is contained in:
parent
a80b2e0941
commit
19fbb978ef
|
@ -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)
|
||||
|
||||
|
|
|
@ -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^
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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^
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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
|
||||
|
|
38
collects/typed-racket/utils/timing.rkt
Normal file
38
collects/typed-racket/utils/timing.rkt
Normal file
|
@ -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)))))
|
12
collects/typed-racket/utils/unit-utils.rkt
Normal file
12
collects/typed-racket/utils/unit-utils.rkt
Normal file
|
@ -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))]))
|
||||
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user