|
1
|
## -*- tcl -*- |
|
2
|
# # ## ### ##### ######## ############# ##################### |
|
3
|
## Copyright (c) 2008 Andreas Kupries. |
|
4
|
# |
|
5
|
# This software is licensed as described in the file LICENSE, which |
|
6
|
# you should have received as part of this distribution. |
|
7
|
# |
|
8
|
# This software consists of voluntary contributions made by many |
|
9
|
# individuals. For exact contribution history, see the revision |
|
10
|
# history and logs, available at http://fossil-scm.hwaci.com/fossil |
|
11
|
# # ## ### ##### ######## ############# ##################### |
|
12
|
|
|
13
|
## Utilities for memory tracking |
|
14
|
|
|
15
|
# # ## ### ##### ######## ############# ##################### |
|
16
|
## Requirements |
|
17
|
|
|
18
|
package require Tcl 8.4 ; # Required runtime |
|
19
|
package require struct::list ; # List assignment |
|
20
|
|
|
21
|
# # ## ### ##### ######## ############# ##################### |
|
22
|
## |
|
23
|
|
|
24
|
namespace eval ::vc::tools::mem { |
|
25
|
# # ## ### ##### ######## ############# |
|
26
|
## Public API, Methods |
|
27
|
|
|
28
|
if {[llength [info commands memory]]} { |
|
29
|
proc minfo {} { |
|
30
|
# memory info reduced to the set of relevant numbers in the output |
|
31
|
struct::list assign [split [memory info] \n] tm tf cpa cba mpa mba |
|
32
|
struct::list assign $tm _ _ tm |
|
33
|
struct::list assign $tf _ _ tf |
|
34
|
struct::list assign $cpa _ _ _ cpa |
|
35
|
struct::list assign $cba _ _ _ cba |
|
36
|
struct::list assign $mpa _ _ _ mpa |
|
37
|
struct::list assign $mba _ _ _ mba |
|
38
|
return [list $tm $tf $cpa $cba $mpa $mba] |
|
39
|
} |
|
40
|
} else { |
|
41
|
proc minfo {} {return {0 0 0 0 0 0}} |
|
42
|
} |
|
43
|
|
|
44
|
proc mlog {} { |
|
45
|
variable track ; if {!$track} { return {} } |
|
46
|
|
|
47
|
variable lcba |
|
48
|
variable lmba |
|
49
|
variable mid |
|
50
|
|
|
51
|
struct::list assign [minfo] _ _ _ cba _ mba |
|
52
|
|
|
53
|
set dc [expr $cba - $lcba] ; set lcba $cba |
|
54
|
set dm [expr $mba - $lmba] ; set lmba $mba |
|
55
|
|
|
56
|
# projection: 1 2 3 4 5 6 7 6 8 10 |
|
57
|
return "[F [incr mid]] | [F $cba] | [F $dc] | [F $mba] | [F $dm] |=| " |
|
58
|
} |
|
59
|
|
|
60
|
proc mark {} { |
|
61
|
variable track ; if {!$track} return |
|
62
|
variable mid |
|
63
|
variable lcba |
|
64
|
variable lmark |
|
65
|
set dm [expr {$lcba - $lmark}] |
|
66
|
puts "[F $mid] | [F $lcba] | [F $dm] | [X %] | [X %] |@| [X %]" |
|
67
|
set lmark $lcba |
|
68
|
return |
|
69
|
} |
|
70
|
|
|
71
|
proc F {n} { format %10d $n } |
|
72
|
proc X {c} { string repeat $c 10 } |
|
73
|
|
|
74
|
proc mlimit {} { |
|
75
|
variable track ; if {!$track} return ; # No checks if there is no memory tracking |
|
76
|
variable limit ; if {!$limit} return ; # No checks if there is no memory limit set |
|
77
|
|
|
78
|
struct::list assign [minfo] _ _ _ cba _ _ |
|
79
|
|
|
80
|
# Nothing to do if we are still under the limit |
|
81
|
if {$cba <= $limit} return |
|
82
|
|
|
83
|
# Notify user and kill the importer |
|
84
|
puts "" |
|
85
|
puts "\tMemory limit breached: $cba > $limit" |
|
86
|
puts "" |
|
87
|
exit 1 |
|
88
|
} |
|
89
|
|
|
90
|
proc setlimit {thelimit} { |
|
91
|
# Activate memory tracking, and set the limit. The specified |
|
92
|
# limit is taken relative to the amount of memory allocated at |
|
93
|
# the time of the call. |
|
94
|
|
|
95
|
variable limit |
|
96
|
struct::list assign [minfo] _ _ _ cba _ _ |
|
97
|
set limit [expr $cba + $thelimit] |
|
98
|
|
|
99
|
track |
|
100
|
return |
|
101
|
} |
|
102
|
|
|
103
|
proc notrack {} { |
|
104
|
variable track 0 |
|
105
|
return |
|
106
|
} |
|
107
|
|
|
108
|
proc track {} { |
|
109
|
variable track 1 |
|
110
|
return |
|
111
|
} |
|
112
|
|
|
113
|
# # ## ### ##### ######## ############# |
|
114
|
|
|
115
|
variable track 0 ; # Boolean flag. If set this module will track |
|
116
|
# memory, inserting the relevant information |
|
117
|
# whenever the application logs something. |
|
118
|
variable limit 0 ; # The maximum amount of memory allowed to the |
|
119
|
# application. This module will abort when |
|
120
|
# 'current bytes allocated' goes over this |
|
121
|
# value. |
|
122
|
|
|
123
|
variable lcba 0 ; # Last 'current bytes allocated' (cba) |
|
124
|
variable lmba 0 ; # Last 'maximum bytes allocated' (mba) |
|
125
|
variable mid 0 ; # Memory id, abstract time |
|
126
|
variable lmark 0 ; # |
|
127
|
|
|
128
|
# # ## ### ##### ######## ############# |
|
129
|
} |
|
130
|
|
|
131
|
namespace eval ::vc::tools::mem { |
|
132
|
namespace export minfo mlog track notrack mlimit setlimit mark |
|
133
|
} |
|
134
|
|
|
135
|
# ----------------------------------------------------------------------------- |
|
136
|
# Ready |
|
137
|
|
|
138
|
package provide vc::tools::mem 1.0 |
|
139
|
return |
|
140
|
|