1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
;; Copyright (c) 2013-2024 by Greg Hendershott.
;; SPDX-License-Identifier: GPL-3.0-or-later
#lang racket/base
(require (for-syntax racket/base)
syntax/parse/define
racket/format
"define-fallbacks.rkt"
"safe-dynamic-require.rkt")
(provide string->namespace-syntax
syntax-or-sexpr->syntax
syntax-or-sexpr->sexpr
nat/c
pos/c
memq?
log-racket-mode-debug
log-racket-mode-info
log-racket-mode-warning
log-racket-mode-error
log-racket-mode-fatal
time-apply/log
with-time/log
with-memory-use/log
(all-from-out "define-fallbacks.rkt")
(all-from-out "safe-dynamic-require.rkt"))
(define (string->namespace-syntax str)
(namespace-syntax-introduce
(read-syntax #f (open-input-string str))))
(define (syntax-or-sexpr->syntax v)
(if (syntax? v)
v
(namespace-syntax-introduce (datum->syntax #f v))))
(define (syntax-or-sexpr->sexpr v)
(if (syntax? v)
(syntax-e v)
v))
(define nat/c exact-nonnegative-integer?)
(define pos/c exact-positive-integer?)
(define (memq? x xs)
(and (memq x xs) #t))
;;; logger / timing
(define-logger racket-mode)
(define (time-apply/log what proc args)
(define-values (vs cpu real gc) (time-apply proc args))
(define (fmt n) (~s #:align 'right #:min-width 4 n))
(log-racket-mode-debug "~a cpu | ~a real | ~a gc :: ~a"
(fmt cpu) (fmt real) (fmt gc) what)
(apply values vs))
(define-simple-macro (with-time/log what e ...+)
(time-apply/log what (λ () e ...) '()))
(define (memory-use/log what thunk)
(define before (current-memory-use))
(begin0 (thunk)
(let ([after (current-memory-use)])
(define (mb n)
(~a (~r #:min-width 4
#:precision 0
(/ n 1024.0 1024.0))
" MB"))
(log-racket-mode-debug "~a [~a => ~a] :: ~a"
(mb (- after before))
(mb before)
(mb after)
what))))
(define-simple-macro (with-memory-use/log what e ...+)
(memory-use/log what (λ () e ...)))
|
