1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | (in-package "CCL") |
---|
19 | |
---|
20 | (eval-when (eval compile) |
---|
21 | (require 'defstruct-macros)) |
---|
22 | |
---|
23 | (defun short-site-name () |
---|
24 | "Return a string with the abbreviated site name, or NIL if not known." |
---|
25 | (or *short-site-name* "unspecified")) |
---|
26 | |
---|
27 | (defun long-site-name () |
---|
28 | "Return a string with the long form of the site name, or NIL if not known." |
---|
29 | (or *long-site-name* "unspecified")) |
---|
30 | |
---|
31 | (defun machine-instance () |
---|
32 | "Return a string giving the name of the local machine." |
---|
33 | #-windows-target (%uname 1) |
---|
34 | #+windows-target |
---|
35 | (rlet ((nsize #>DWORD 0)) |
---|
36 | (if (eql 0 (#_GetComputerNameExW #$ComputerNameDnsFullyQualified |
---|
37 | (%null-ptr) |
---|
38 | nsize)) |
---|
39 | (%stack-block ((buf (* 2 (pref nsize #>DWORD)))) |
---|
40 | (#_GetComputerNameExW #$ComputerNameDnsFullyQualified |
---|
41 | buf |
---|
42 | nsize) |
---|
43 | (%get-native-utf-16-cstring buf)) |
---|
44 | "localhost")) |
---|
45 | ) |
---|
46 | |
---|
47 | |
---|
48 | (defun machine-type () |
---|
49 | "Returns a string describing the type of the local machine." |
---|
50 | #-windows-target (%uname 4) |
---|
51 | #+windows-target |
---|
52 | (rlet ((info #>SYSTEM_INFO)) |
---|
53 | (#_GetSystemInfo info) |
---|
54 | (case (pref info #>SYSTEM_INFO.nil.nil.wProcessorArchitecture) |
---|
55 | (#.#$PROCESSOR_ARCHITECTURE_AMD64 "x64") |
---|
56 | (#.#$PROCESSOR_ARCHITECTURE_INTEL "x86") |
---|
57 | (t "unknown"))) |
---|
58 | ) |
---|
59 | |
---|
60 | |
---|
61 | |
---|
62 | (defloadvar *machine-version* nil) |
---|
63 | |
---|
64 | (defun machine-version () |
---|
65 | "Return a string describing the version of the computer hardware we |
---|
66 | are running on, or NIL if we can't find any useful information." |
---|
67 | (or *machine-version* |
---|
68 | (setq *machine-version* |
---|
69 | #+darwin-target |
---|
70 | (block darwin-machine-version |
---|
71 | (%stack-block ((mib 8)) |
---|
72 | (setf (%get-long mib 0) #$CTL_HW |
---|
73 | (%get-long mib 4) #$HW_MODEL) |
---|
74 | (%stack-block ((res 256) |
---|
75 | (reslen target::node-size)) |
---|
76 | (setf (%get-byte res 0) 0 |
---|
77 | (%get-natural reslen 0) 256) |
---|
78 | (if (zerop (#_sysctl mib 2 res reslen (%null-ptr) 0)) |
---|
79 | (return-from darwin-machine-version (%get-cstring res)))))) |
---|
80 | #+linux-target |
---|
81 | (with-open-file (f "/proc/cpuinfo" :if-does-not-exist nil) |
---|
82 | (when f |
---|
83 | (flet ((cpu-info-match (target line) |
---|
84 | (let* ((targetlen (length target)) |
---|
85 | (linelen (length line))) |
---|
86 | (if (and (> linelen targetlen) |
---|
87 | (string= target line |
---|
88 | :end2 targetlen)) |
---|
89 | (let* ((colonpos (position #\: line))) |
---|
90 | (when colonpos |
---|
91 | (string-trim " " |
---|
92 | (subseq line (1+ colonpos))))))))) |
---|
93 | (do* ((line (read-line f nil nil) |
---|
94 | (read-line f nil nil)) |
---|
95 | (target #+ppc-target "machine" |
---|
96 | #+x86-target "model name")) |
---|
97 | ((null line)) |
---|
98 | (let* ((matched (cpu-info-match target line))) |
---|
99 | (when matched (return matched))))))) |
---|
100 | #+freebsd-target |
---|
101 | (%stack-block ((ret 512) |
---|
102 | (mib (* (record-length :uint)))) |
---|
103 | (setf (%get-unsigned-long mib 0) |
---|
104 | #$CTL_HW |
---|
105 | (%get-unsigned-long mib (record-length :uint)) |
---|
106 | #$HW_MODEL) |
---|
107 | (rlet ((oldsize :uint 512)) |
---|
108 | (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0)) |
---|
109 | (%get-cstring ret) |
---|
110 | 1))) |
---|
111 | #+solaris-target |
---|
112 | (rlet ((info :processor_info_t)) |
---|
113 | (do* ((i 0 (1+ i))) |
---|
114 | ((and (= 0 (#_processor_info i info)) |
---|
115 | (= (pref info :processor_info_t.pi_state) |
---|
116 | #$P_ONLINE)) |
---|
117 | (%get-cstring (pref info :processor_info_t.pi_processor_type))))) |
---|
118 | #+windows-target |
---|
119 | (getenv "PROCESSOR_IDENTIFIER") |
---|
120 | ))) |
---|
121 | |
---|
122 | |
---|
123 | (defun software-type () |
---|
124 | "Return a string describing the supporting software." |
---|
125 | #-windows-target (%uname 0) |
---|
126 | #+windows-target "Microsoft Windows") |
---|
127 | |
---|
128 | |
---|
129 | (defun software-version () |
---|
130 | "Return a string describing version of the supporting software, or NIL |
---|
131 | if not available." |
---|
132 | #-windows-target (%uname 2) |
---|
133 | #+windows-target |
---|
134 | (rletZ ((info #>OSVERSIONINFOEX)) |
---|
135 | (setf (pref info #>OSVERSIONINFOEX.dwOSVersionInfoSize) |
---|
136 | (record-length #>OSVERSIONINFOEX)) |
---|
137 | (#_GetVersionExA info) |
---|
138 | (format nil "~d.~d Build ~d (~a)" |
---|
139 | (pref info #>OSVERSIONINFOEX.dwMajorVersion) |
---|
140 | (pref info #>OSVERSIONINFOEX.dwMinorVersion) |
---|
141 | (pref info #>OSVERSIONINFOEX.dwBuildNumber) |
---|
142 | (if (eql (pref info #>OSVERSIONINFOEX.wProductType) |
---|
143 | #$VER_NT_WORKSTATION) |
---|
144 | "Workstation" |
---|
145 | "Server"))) |
---|
146 | ) |
---|
147 | |
---|
148 | |
---|
149 | |
---|
150 | |
---|
151 | |
---|
152 | |
---|
153 | |
---|
154 | ;;; Yawn. |
---|
155 | |
---|
156 | |
---|
157 | |
---|
158 | (defmethod documentation (thing doc-id) |
---|
159 | (%get-documentation thing doc-id)) |
---|
160 | |
---|
161 | (defmethod (setf documentation) (new thing doc-id) |
---|
162 | (%put-documentation thing doc-id new)) |
---|
163 | |
---|
164 | |
---|
165 | (defmethod documentation ((symbol symbol) (doc-type (eql 'function))) |
---|
166 | (let* ((def (fboundp symbol))) ; FBOUNDP returns info about definition |
---|
167 | (when def |
---|
168 | (%get-documentation def t)))) |
---|
169 | |
---|
170 | (defmethod (setf documentation) ((new t) |
---|
171 | (symbol symbol) |
---|
172 | (doc-type (eql 'function))) |
---|
173 | (let* ((def (fboundp symbol))) ; FBOUNDP returns info about definition |
---|
174 | (when def |
---|
175 | (%put-documentation def |
---|
176 | t |
---|
177 | new)) |
---|
178 | new)) |
---|
179 | |
---|
180 | (defmethod documentation ((symbol symbol) (doc-type (eql 'setf))) |
---|
181 | (call-next-method)) |
---|
182 | |
---|
183 | (defmethod (setf documentation) ((new t) |
---|
184 | (symbol symbol) |
---|
185 | (doc-type (eql 'setf))) |
---|
186 | (call-next-method)) |
---|
187 | |
---|
188 | |
---|
189 | (defmethod documentation ((symbol symbol) (doc-type (eql 'variable))) |
---|
190 | (call-next-method)) |
---|
191 | |
---|
192 | (defmethod (setf documentation) ((new t) |
---|
193 | (symbol symbol) |
---|
194 | (doc-type (eql 'variable))) |
---|
195 | (call-next-method)) |
---|
196 | |
---|
197 | (defmethod documentation ((symbol symbol) (doc-type (eql 'compiler-macro))) |
---|
198 | (call-next-method)) |
---|
199 | |
---|
200 | (defmethod (setf documentation) ((new t) |
---|
201 | (symbol symbol) |
---|
202 | (doc-type (eql 'compiler-macro))) |
---|
203 | (call-next-method)) |
---|
204 | |
---|
205 | (defmethod documentation ((symbol symbol) (doc-type (eql 'type))) |
---|
206 | (let* ((class (find-class symbol nil))) |
---|
207 | (if class |
---|
208 | (documentation class doc-type) |
---|
209 | (call-next-method)))) |
---|
210 | |
---|
211 | (defmethod (setf documentation) (new (symbol symbol) (doc-type (eql 'type))) |
---|
212 | (let* ((class (find-class symbol nil))) |
---|
213 | (if class |
---|
214 | (setf (documentation class doc-type) new) |
---|
215 | (call-next-method)))) |
---|
216 | |
---|
217 | (defmethod documentation ((symbol symbol) (doc-type (eql 'method-combination))) |
---|
218 | (let* ((mci (method-combination-info symbol))) |
---|
219 | (if mci |
---|
220 | (documentation mci doc-type)))) |
---|
221 | |
---|
222 | (defmethod (setf documentation) ((new t) |
---|
223 | (symbol symbol) |
---|
224 | (doc-type (eql 'method-combination))) |
---|
225 | (let* ((mci (method-combination-info symbol))) |
---|
226 | (if mci |
---|
227 | (setf (documentation mci doc-type) new)))) |
---|
228 | |
---|
229 | |
---|
230 | (defmethod documentation ((symbol symbol) (doc-type (eql 'structure))) |
---|
231 | (let* ((class (find-class symbol nil))) |
---|
232 | (if (typep class 'structure-class) |
---|
233 | (documentation class 'type) |
---|
234 | (call-next-method)))) |
---|
235 | |
---|
236 | (defmethod (setf documentation) ((new t) |
---|
237 | (symbol symbol) |
---|
238 | (doc-type (eql 'structure))) |
---|
239 | (let* ((class (find-class symbol nil))) |
---|
240 | (if (typep class 'structure-class) |
---|
241 | (setf (documentation class 'type) new) |
---|
242 | (call-next-method)))) |
---|
243 | |
---|
244 | (defmethod documentation ((p package) (doc-type (eql 't))) |
---|
245 | (call-next-method)) |
---|
246 | |
---|
247 | (defmethod (setf documentation) ((new t) (p package) (doc-type (eql 't))) |
---|
248 | (call-next-method)) |
---|
249 | |
---|
250 | (defmethod documentation ((f function) (doc-type (eql 't))) |
---|
251 | (call-next-method)) |
---|
252 | |
---|
253 | (defmethod (setf documentation) ((new t) (f function) (doc-type (eql 't))) |
---|
254 | (call-next-method)) |
---|
255 | |
---|
256 | (defmethod documentation ((f function) (doc-type (eql 'function))) |
---|
257 | (documentation f t)) |
---|
258 | |
---|
259 | (defmethod (setf documentation) ((new t) |
---|
260 | (f function) |
---|
261 | (doc-type (eql 'function))) |
---|
262 | (setf (documentation f t) new)) |
---|
263 | |
---|
264 | (defmethod documentation ((l cons) (doc-type (eql 'function))) |
---|
265 | (let* ((name (setf-function-spec-name l))) |
---|
266 | (if name |
---|
267 | (documentation name doc-type) |
---|
268 | (%get-documentation l doc-type)))) |
---|
269 | |
---|
270 | (defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'function))) |
---|
271 | (let* ((name (setf-function-spec-name l))) |
---|
272 | (if name |
---|
273 | (setf (documentation name doc-type) new) |
---|
274 | (%put-documentation l doc-type new)))) |
---|
275 | |
---|
276 | |
---|
277 | (defmethod documentation ((l cons) (doc-type (eql 'compiler-macro))) |
---|
278 | (let* ((name (setf-function-spec-name l))) |
---|
279 | (if name |
---|
280 | (documentation name doc-type) |
---|
281 | (%get-documentation l doc-type)))) |
---|
282 | |
---|
283 | (defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'compiler-macr0))) |
---|
284 | (let* ((name (setf-function-spec-name l))) |
---|
285 | (if name |
---|
286 | (setf (documentation name doc-type) new) |
---|
287 | (%put-documentation l doc-type new)))) |
---|
288 | |
---|
289 | |
---|
290 | (defmethod documentation ((m method-combination) |
---|
291 | (doc-type (eql 'method-combination))) |
---|
292 | (call-next-method)) |
---|
293 | |
---|
294 | (defmethod (setf documentation) ((new t) |
---|
295 | (m method-combination) |
---|
296 | (doc-type (eql 'method-combination))) |
---|
297 | (call-next-method)) |
---|
298 | |
---|
299 | (defmethod documentation ((m method-combination) |
---|
300 | (doc-type (eql t))) |
---|
301 | (documentation m 'method-combination)) |
---|
302 | |
---|
303 | (defmethod (setf documentation) ((new t) |
---|
304 | (m method-combination) |
---|
305 | (doc-type (eql t))) |
---|
306 | (setf (documentation m 'method-combination) new)) |
---|
307 | |
---|
308 | (defmethod documentation ((m standard-method) |
---|
309 | (doc-type (eql t))) |
---|
310 | (call-next-method)) |
---|
311 | |
---|
312 | (defmethod (setf documentation) ((new t) |
---|
313 | (m standard-method) |
---|
314 | (doc-type (eql t))) |
---|
315 | (call-next-method)) |
---|
316 | |
---|
317 | (defmethod documentation ((c standard-class) (doc-type (eql 'type))) |
---|
318 | (call-next-method)) |
---|
319 | |
---|
320 | (defmethod (setf documentation) ((new t) |
---|
321 | (c standard-class) |
---|
322 | (doc-type (eql 'type))) |
---|
323 | (call-next-method)) |
---|
324 | |
---|
325 | (defmethod documentation ((c standard-class) (doc-type (eql 't))) |
---|
326 | (documentation c 'type)) |
---|
327 | |
---|
328 | (defmethod (setf documentation) ((new t) |
---|
329 | (c standard-class) |
---|
330 | (doc-type (eql 't))) |
---|
331 | (setf (documentation c 'type) new)) |
---|
332 | |
---|
333 | (defmethod documentation ((c structure-class) (doc-type (eql 'type))) |
---|
334 | (call-next-method)) |
---|
335 | |
---|
336 | (defmethod (setf documentation) ((new t) |
---|
337 | (c structure-class) |
---|
338 | (doc-type (eql 'type))) |
---|
339 | (call-next-method)) |
---|
340 | |
---|
341 | (defmethod documentation ((c structure-class) (doc-type (eql 't))) |
---|
342 | (documentation c 'type)) |
---|
343 | |
---|
344 | (defmethod (setf documentation) ((new t) |
---|
345 | (c structure-class) |
---|
346 | (doc-type (eql 't))) |
---|
347 | (setf (documentation c 'type) new)) |
---|
348 | |
---|
349 | ;;; This is now deprecated; things which call it should stop doing so. |
---|
350 | (defun set-documentation (symbol doc-type string) |
---|
351 | (setf (documentation symbol doc-type) string)) |
---|
352 | |
---|
353 | (defun set-function-info (symbol info) |
---|
354 | (let* ((doc-string (if (consp info) (car info) info))) |
---|
355 | (if (and *save-doc-strings* (stringp doc-string)) |
---|
356 | (set-documentation symbol 'function doc-string))) |
---|
357 | (let* ((cons (assq symbol *nx-globally-inline*)) |
---|
358 | (lambda-expression (if (consp info) (cdr info)))) |
---|
359 | (if (and (proclaimed-inline-p symbol) |
---|
360 | (not (compiler-special-form-p symbol)) |
---|
361 | (lambda-expression-p lambda-expression) |
---|
362 | (let* ((lambda-list (cadr lambda-expression))) |
---|
363 | (and (not (memq '&lap lambda-list)) |
---|
364 | (not (memq '&method lambda-list)) |
---|
365 | (not (memq '&lexpr lambda-list))))) |
---|
366 | (if cons |
---|
367 | (%rplacd cons lambda-expression) |
---|
368 | (push (cons symbol lambda-expression) *nx-globally-inline*)) |
---|
369 | (if cons (setq *nx-globally-inline* (delete cons *nx-globally-inline*))))) |
---|
370 | symbol) |
---|
371 | |
---|
372 | |
---|
373 | (setf (documentation 'if 'function) |
---|
374 | "If Predicate Then [Else] |
---|
375 | If Predicate evaluates to non-null, evaluate Then and returns its values, |
---|
376 | otherwise evaluate Else and return its values. Else defaults to NIL.") |
---|
377 | |
---|
378 | (setf (documentation 'progn 'function) |
---|
379 | "progn form* |
---|
380 | Evaluates each FORM and returns the value(s) of the last FORM.") |
---|
381 | |
---|
382 | (defmethod documentation ((thing character-encoding) (doc-type (eql t))) |
---|
383 | (character-encoding-documentation thing)) |
---|
384 | |
---|
385 | (defmethod (setf documentation) (new (thing character-encoding) (doc-type (eql t))) |
---|
386 | (check-type new (or null string)) |
---|
387 | (setf (character-encoding-documentation thing) new)) |
---|
388 | |
---|
389 | (defmethod documentation ((thing symbol) (doc-type (eql 'character-encoding))) |
---|
390 | (let* ((encoding (lookup-character-encoding (intern (string thing) :keyword)))) |
---|
391 | (when encoding |
---|
392 | (documentation encoding t)))) |
---|
393 | |
---|
394 | |
---|
395 | |
---|
396 | |
---|
397 | #| |
---|
398 | (setf (documentation 'car 'variable) "Preferred brand of automobile") |
---|
399 | (documentation 'car 'variable) |
---|
400 | (setf (documentation 'foo 'structure) "the structure is grand.") |
---|
401 | (documentation 'foo 'structure) |
---|
402 | (setf (documentation 'foo 'variable) "the metasyntactic remarker") |
---|
403 | (documentation 'foo 'variable) |
---|
404 | (setf (documentation 'foo 'obscure) "no one really knows what it means") |
---|
405 | (documentation 'foo 'obscure) |
---|
406 | (setf (documentation 'foo 'structure) "the structure is solid") |
---|
407 | (documentation 'foo 'function) |
---|
408 | ||# |
---|
409 | |
---|
410 | ;; |
---|
411 | |
---|
412 | |
---|
413 | (defun %page-fault-info () |
---|
414 | #-(or darwin-target windows-target) |
---|
415 | (rlet ((usage :rusage)) |
---|
416 | (%%rusage usage) |
---|
417 | (values (pref usage :rusage.ru_minflt) |
---|
418 | (pref usage :rusage.ru_majflt) |
---|
419 | (pref usage :rusage.ru_nswap))) |
---|
420 | #+darwin-target |
---|
421 | (rlet ((count #>mach_msg_type_number_t #$TASK_EVENTS_INFO_COUNT) |
---|
422 | (info #>task_events_info)) |
---|
423 | (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count) |
---|
424 | (values (pref info #>task_events_info.cow_faults) |
---|
425 | (pref info #>task_events_info.faults) |
---|
426 | (pref info #>task_events_info.pageins))) |
---|
427 | #+windows-target |
---|
428 | ;; Um, don't know how to determine this, or anything like it. |
---|
429 | (values 0 0 0)) |
---|
430 | |
---|
431 | |
---|
432 | |
---|
433 | (defparameter *report-time-function* nil |
---|
434 | "If non-NULL, should be a function which accepts the following |
---|
435 | keyword arguments: |
---|
436 | :FORM the form that was executed |
---|
437 | :RESULTS a list of all values returned by the execution of FORM |
---|
438 | :ELAPSED-TIME total elapsed (real) time, in internal-time-units-per-second |
---|
439 | :USER-TIME elapsed user time, in internal-time-units-per-second |
---|
440 | :SYSTEM-TIME elapsed system time, in internal-time-units-per-second |
---|
441 | :GC-TIME total real time spent in the GC, in internal-time-units-per-second |
---|
442 | :BYTES-ALLOCATED total bytes allocated |
---|
443 | :MINOR-PAGE-FAULTS minor page faults |
---|
444 | :MAJOR-PAGE-FAULTS major page faults |
---|
445 | :SWAPS swaps") |
---|
446 | |
---|
447 | |
---|
448 | (defun standard-report-time (&key form results elapsed-time user-time |
---|
449 | system-time gc-time bytes-allocated |
---|
450 | minor-page-faults major-page-faults |
---|
451 | swaps) |
---|
452 | (let* ((s *trace-output*) |
---|
453 | (units |
---|
454 | (ecase internal-time-units-per-second |
---|
455 | (1000000 "microseconds") |
---|
456 | (1000 "milliseconds"))) |
---|
457 | (width |
---|
458 | (ecase internal-time-units-per-second |
---|
459 | (1000000 6) |
---|
460 | (1000 3))) |
---|
461 | (cpu-count (cpu-count))) |
---|
462 | (format s "~&~S took ~:D ~a (~,vF seconds) to run ~%~20twith ~D available CPU core~P." |
---|
463 | form elapsed-time units width (/ elapsed-time internal-time-units-per-second) cpu-count cpu-count) |
---|
464 | (format s "~&During that period, ~:D ~a (~,vF seconds) were spent in user mode" user-time units width (/ user-time internal-time-units-per-second)) |
---|
465 | (format s "~& ~:D ~a (~,vF seconds) were spent in system mode" system-time units width(/ system-time internal-time-units-per-second)) |
---|
466 | (unless (eql gc-time 0) |
---|
467 | (format s |
---|
468 | "~%~:D ~a (~,vF seconds) was spent in GC." |
---|
469 | gc-time units width (/ gc-time internal-time-units-per-second))) |
---|
470 | (unless (eql 0 bytes-allocated) |
---|
471 | (format s "~% ~:D bytes of memory allocated." bytes-allocated)) |
---|
472 | (when (or (> minor-page-faults 0) |
---|
473 | (> major-page-faults 0) |
---|
474 | (> swaps 0)) |
---|
475 | (format s |
---|
476 | "~% ~:D minor page faults, ~:D major page faults, ~:D swaps." |
---|
477 | minor-page-faults major-page-faults swaps)) |
---|
478 | (format s "~&") |
---|
479 | (values-list results))) |
---|
480 | |
---|
481 | (defun report-time (form thunk) |
---|
482 | (flet ((integer-size-in-bytes (i) |
---|
483 | (if (typep i 'fixnum) |
---|
484 | 0 |
---|
485 | (* (logand (+ 2 (uvsize i)) (lognot 1)) 4)))) |
---|
486 | (multiple-value-bind (user-start system-start) |
---|
487 | (%internal-run-time) |
---|
488 | (multiple-value-bind (minor-start major-start swaps-start) |
---|
489 | (%page-fault-info) |
---|
490 | (let* ((initial-real-time (get-internal-real-time)) |
---|
491 | (initial-gc-time (gctime)) |
---|
492 | (initial-consed (total-bytes-allocated)) |
---|
493 | (initial-overhead (integer-size-in-bytes initial-consed))) |
---|
494 | (let* ((results (multiple-value-list (funcall thunk)))) |
---|
495 | (declare (dynamic-extent results)) |
---|
496 | (multiple-value-bind (user-end system-end) |
---|
497 | (%internal-run-time) |
---|
498 | (multiple-value-bind (minor-end major-end swaps-end) |
---|
499 | (%page-fault-info) |
---|
500 | (let* ((new-consed (total-bytes-allocated)) |
---|
501 | (bytes-consed |
---|
502 | (- new-consed (+ initial-overhead initial-consed))) |
---|
503 | (elapsed-real-time |
---|
504 | (- (get-internal-real-time) initial-real-time)) |
---|
505 | (elapsed-gc-time (- (gctime) initial-gc-time)) |
---|
506 | (elapsed-user-time |
---|
507 | (- user-end user-start)) |
---|
508 | (elapsed-system-time |
---|
509 | (- system-end system-start)) |
---|
510 | (elapsed-minor (- minor-end minor-start)) |
---|
511 | (elapsed-major (- major-end major-start)) |
---|
512 | (elapsed-swaps (- swaps-end swaps-start))) |
---|
513 | (funcall (or *report-time-function* |
---|
514 | #'standard-report-time) |
---|
515 | :form form |
---|
516 | :results results |
---|
517 | :elapsed-time elapsed-real-time |
---|
518 | :user-time elapsed-user-time |
---|
519 | :system-time elapsed-system-time |
---|
520 | :gc-time elapsed-gc-time |
---|
521 | :bytes-allocated bytes-consed |
---|
522 | :minor-page-faults elapsed-minor |
---|
523 | :major-page-faults elapsed-major |
---|
524 | :swaps elapsed-swaps)))))))))) |
---|
525 | |
---|
526 | |
---|
527 | |
---|
528 | |
---|
529 | ;;; site names and machine-instance is in the init file. |
---|
530 | |
---|
531 | (defun add-feature (symbol) |
---|
532 | "Not CL but should be." |
---|
533 | (if (symbolp symbol) |
---|
534 | (if (not (memq symbol *features*)) |
---|
535 | (setq *features* (cons symbol *features*))))) |
---|
536 | |
---|
537 | ;;; (dotimes (i 5000) (declare (fixnum i)) (add-feature 'junk)) |
---|
538 | |
---|
539 | |
---|
540 | |
---|
541 | |
---|
542 | ;;; Misc string functions |
---|
543 | |
---|
544 | |
---|
545 | (defun string-left-trim (char-bag string &aux end) |
---|
546 | "Given a set of characters (a list or string) and a string, returns |
---|
547 | a copy of the string with the characters in the set removed from the |
---|
548 | left end." |
---|
549 | (setq string (string string)) |
---|
550 | (setq end (length string)) |
---|
551 | (do ((index 0 (%i+ index 1))) |
---|
552 | ((or (eq index end) (not (find (aref string index) char-bag))) |
---|
553 | (subseq string index end)))) |
---|
554 | |
---|
555 | (defun string-right-trim (char-bag string &aux end) |
---|
556 | "Given a set of characters (a list or string) and a string, returns |
---|
557 | a copy of the string with the characters in the set removed from the |
---|
558 | right end." |
---|
559 | (setq string (string string)) |
---|
560 | (setq end (length string)) |
---|
561 | (do ((index (%i- end 1) (%i- index 1))) |
---|
562 | ((or (%i< index 0) (not (find (aref string index) char-bag))) |
---|
563 | (subseq string 0 (%i+ index 1))))) |
---|
564 | |
---|
565 | (defun string-trim (char-bag string &aux end) |
---|
566 | "Given a set of characters (a list or string) and a string, returns a |
---|
567 | copy of the string with the characters in the set removed from both |
---|
568 | ends." |
---|
569 | (setq string (string string)) |
---|
570 | (setq end (length string)) |
---|
571 | (let ((left-end) (right-end)) |
---|
572 | (do ((index 0 (%i+ index 1))) |
---|
573 | ((or (eq index end) (not (find (aref string index) char-bag))) |
---|
574 | (setq left-end index))) |
---|
575 | (do ((index (%i- end 1) (%i- index 1))) |
---|
576 | ((or (%i< index left-end) (not (find (aref string index) char-bag))) |
---|
577 | (setq right-end index))) |
---|
578 | (subseq string left-end (%i+ right-end 1)))) |
---|
579 | |
---|
580 | |
---|
581 | |
---|
582 | (defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol def) |
---|
583 | "Make and return a new uninterned symbol with the same print name |
---|
584 | as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound |
---|
585 | nor fbound and has no properties, else it has a copy of SYMBOL's |
---|
586 | function, value and property list." |
---|
587 | (setq new-symbol (make-symbol (symbol-name symbol))) |
---|
588 | (when copy-props |
---|
589 | (when (boundp symbol) |
---|
590 | (set new-symbol (symbol-value symbol))) |
---|
591 | (when (setq def (fboundp symbol)) |
---|
592 | ;;;Shouldn't err out on macros/special forms. |
---|
593 | (%fhave new-symbol def)) |
---|
594 | (set-symbol-plist new-symbol (copy-list (symbol-plist symbol)))) |
---|
595 | new-symbol) |
---|
596 | |
---|
597 | |
---|
598 | (defvar %gentemp-counter 0 |
---|
599 | "Counter for generating unique GENTEMP symbols.") |
---|
600 | |
---|
601 | (defun gentemp (&optional (prefix "T") (package *package*)) |
---|
602 | "Creates a new symbol interned in package PACKAGE with the given PREFIX." |
---|
603 | (loop |
---|
604 | (let* ((new-pname (%str-cat (ensure-simple-string prefix) |
---|
605 | (%integer-to-string %gentemp-counter))) |
---|
606 | (sym (find-symbol new-pname package))) |
---|
607 | (if sym |
---|
608 | (setq %gentemp-counter (%i+ %gentemp-counter 1)) |
---|
609 | (return (values (intern new-pname package))))))) ; 1 value. |
---|
610 | |
---|
611 | |
---|
612 | |
---|
613 | |
---|
614 | (defun add-gc-hook (hook-function &optional (which-hook :pre-gc)) |
---|
615 | (ecase which-hook |
---|
616 | (:pre-gc |
---|
617 | (pushnew hook-function *pre-gc-hook-list*) |
---|
618 | (setq *pre-gc-hook* #'(lambda () |
---|
619 | (dolist (hook *pre-gc-hook-list*) |
---|
620 | (funcall hook))))) |
---|
621 | (:post-gc |
---|
622 | (pushnew hook-function *post-gc-hook-list*) |
---|
623 | (setq *post-gc-hook* #'(lambda () |
---|
624 | (dolist (hook *post-gc-hook-list*) |
---|
625 | (funcall hook)))))) |
---|
626 | hook-function) |
---|
627 | |
---|
628 | (defun remove-gc-hook (hook-function &optional (which-hook :pre-gc)) |
---|
629 | (ecase which-hook |
---|
630 | (:pre-gc |
---|
631 | (unless (setq *pre-gc-hook-list* (delq hook-function *pre-gc-hook-list*)) |
---|
632 | (setq *pre-gc-hook* nil))) |
---|
633 | (:post-gc |
---|
634 | (unless (setq *post-gc-hook-list* (delq hook-function *post-gc-hook-list*)) |
---|
635 | (setq *post-gc-hook* nil))))) |
---|
636 | |
---|
637 | |
---|
638 | |
---|
639 | |
---|
640 | |
---|
641 | |
---|
642 | (defun find-method-by-names (name qualifiers specializers) |
---|
643 | (let ((gf (fboundp name))) |
---|
644 | (when gf |
---|
645 | (if (not (standard-generic-function-p gf)) |
---|
646 | (error "~S is not a generic-function." gf) |
---|
647 | (let ((methods (%gf-methods gf))) |
---|
648 | (when methods |
---|
649 | (let* ((spec-len (length (%method-specializers (car methods)))) |
---|
650 | (new-specs (make-list spec-len :initial-element (find-class t)))) |
---|
651 | (declare (dynamic-extent new-specs)) |
---|
652 | (do ((specs specializers (cdr specs)) |
---|
653 | (nspecs new-specs (cdr nspecs))) |
---|
654 | ((or (null specs) (null nspecs))) |
---|
655 | (let ((s (car specs))) |
---|
656 | (rplaca nspecs (if (consp s) s (find-class s nil))))) |
---|
657 | (find-method gf qualifiers new-specs nil)))))))) |
---|
658 | |
---|
659 | |
---|
660 | |
---|
661 | |
---|
662 | (defun make-population (&key (type :list) initial-contents) |
---|
663 | (let* ((ntype (ecase type |
---|
664 | (:list $population_weak-list) |
---|
665 | (:alist $population_weak-alist))) |
---|
666 | (list (if (eq type :alist) |
---|
667 | (map 'list (lambda (c) (cons (car c) (%cdr c))) initial-contents) |
---|
668 | (if (listp initial-contents) |
---|
669 | (copy-list initial-contents) |
---|
670 | (coerce initial-contents 'list))))) |
---|
671 | (%cons-population list ntype))) |
---|
672 | |
---|
673 | (defun population-type (population) |
---|
674 | (let ((ntype (population.type (require-type population 'population)))) |
---|
675 | (cond ((eq ntype $population_weak-alist) :alist) |
---|
676 | ((eq ntype $population_weak-list) :list) |
---|
677 | (t nil)))) |
---|
678 | |
---|
679 | (declaim (inline population-contents (setf population-contents))) |
---|
680 | |
---|
681 | (defun population-contents (population) |
---|
682 | (population.data (require-type population 'population))) |
---|
683 | |
---|
684 | (defun (setf population-contents) (list population) |
---|
685 | (setf (population.data (require-type population 'population)) (require-type list 'list))) |
---|
686 | |
---|
687 | |
---|
688 | |
---|
689 | |
---|
690 | (defun get-string-from-user (prompt) |
---|
691 | (with-terminal-input |
---|
692 | (format *query-io* "~&~a " prompt) |
---|
693 | (force-output *query-io*) |
---|
694 | (clear-input *query-io*) |
---|
695 | (values (read-line *query-io*)))) |
---|
696 | |
---|
697 | |
---|
698 | (defun select-item-from-list (list &key (window-title "Select one of the following") |
---|
699 | (table-print-function #'prin1) |
---|
700 | &allow-other-keys) |
---|
701 | (block get-answer |
---|
702 | (with-terminal-input |
---|
703 | (format *query-io* "~a:~%" window-title) |
---|
704 | (loop |
---|
705 | (catch :redisplay |
---|
706 | (do* ((l list (cdr l)) |
---|
707 | (i 0 (1+ i)) |
---|
708 | (item (car l) (car l))) |
---|
709 | ((null l)) |
---|
710 | (declare (fixnum i)) |
---|
711 | (format *query-io* "~& ~d: " i) |
---|
712 | (funcall table-print-function item *query-io*)) |
---|
713 | (loop |
---|
714 | (fresh-line *query-io*) |
---|
715 | (let* ((string (get-string-from-user "Selection [number,q,r,?]:")) |
---|
716 | (value (ignore-errors |
---|
717 | (let* ((*package* *keyword-package*)) |
---|
718 | (read-from-string string nil))))) |
---|
719 | (cond ((eq value :q) (throw :cancel t)) |
---|
720 | ((eq value :r) (throw :redisplay t)) |
---|
721 | ((eq value :?) |
---|
722 | (format *query-io* "~%Enter the number of the selection, ~% r to redisplay, ~% q to cancel or ~% ? to show this message again.")) |
---|
723 | ((and (typep value 'unsigned-byte) |
---|
724 | (< value (length list))) |
---|
725 | (return-from get-answer (list (nth value list)))))))))))) |
---|
726 | |
---|
727 | (defvar *choose-file-dialog-hook* nil "for GUIs") |
---|
728 | |
---|
729 | ;;; There should ideally be some way to override the UI (such as |
---|
730 | ;;; it is ...) here. |
---|
731 | ;;; More generally, this either |
---|
732 | ;;; a) shouldn't exist, or |
---|
733 | ;;; b) should do more sanity-checking |
---|
734 | (defun choose-file-dialog (&key file-types (prompt "File name:")) |
---|
735 | (let* ((hook *choose-file-dialog-hook*)) |
---|
736 | (if hook |
---|
737 | (funcall hook t prompt file-types) |
---|
738 | (%choose-file-dialog t prompt file-types)))) |
---|
739 | |
---|
740 | (defun choose-new-file-dialog (&key prompt) |
---|
741 | (let* ((hook *choose-file-dialog-hook*)) |
---|
742 | (if hook |
---|
743 | (funcall hook nil prompt nil) |
---|
744 | (%choose-file-dialog nil prompt nil)))) |
---|
745 | |
---|
746 | (defun %choose-file-dialog (must-exist prompt file-types) |
---|
747 | (loop |
---|
748 | (let* ((namestring (get-string-from-user prompt)) |
---|
749 | (pathname (ignore-errors (pathname namestring))) |
---|
750 | (exists (and pathname (probe-file pathname)))) |
---|
751 | (when (and (if must-exist exists) |
---|
752 | (or (null file-types) |
---|
753 | (member (pathname-type pathname) |
---|
754 | file-types :test #'equal))) |
---|
755 | (return pathname)) |
---|
756 | (if (not exists) |
---|
757 | (format *query-io* "~&~s does not exist." namestring) |
---|
758 | (format *query-io* "~&Type of ~s is not one of ~{~a~}" |
---|
759 | namestring file-types))))) |
---|
760 | |
---|
761 | (defparameter *overwrite-dialog-hook* nil) |
---|
762 | (defun overwrite-dialog (filename prompt) |
---|
763 | (if *overwrite-dialog-hook* |
---|
764 | (funcall *overwrite-dialog-hook* filename prompt) |
---|
765 | t)) |
---|
766 | |
---|
767 | ;;; Might want to have some other entry for, e.g., the inspector |
---|
768 | ;;; and to let it get its hands on the list header returned by |
---|
769 | ;;; disassemble-ppc-function. Maybe disassemble-ppc-function |
---|
770 | ;;; should take care of "normalizing" the code-vector ? |
---|
771 | (defun disassemble (thing) |
---|
772 | "Disassemble the compiled code associated with OBJECT, which can be a |
---|
773 | function, a lambda expression, or a symbol with a function definition. If |
---|
774 | it is not already compiled, the compiler is called to produce something to |
---|
775 | disassemble." |
---|
776 | (#+ppc-target ppc-xdisassemble |
---|
777 | #+x86-target x86-xdisassemble |
---|
778 | (require-type (function-for-disassembly thing) 'compiled-function))) |
---|
779 | |
---|
780 | (defun function-for-disassembly (thing) |
---|
781 | (let* ((fun thing)) |
---|
782 | ;; CLHS says that DISASSEMBLE should signal a type error if its |
---|
783 | ;; argument isn't a function designator. Hard to imagine any |
---|
784 | ;; code depending on that ... |
---|
785 | ;;(when (typep fun 'standard-method) (setq fun (%method-function fun))) |
---|
786 | (when (or (symbolp fun) |
---|
787 | (and (consp fun) (neq (%car fun) 'lambda))) |
---|
788 | (setq fun (fboundp thing)) |
---|
789 | (when (and (symbolp thing) (not (functionp fun))) |
---|
790 | (setq fun (macro-function thing)))) |
---|
791 | (if (typep fun 'compiled-lexical-closure) |
---|
792 | (setq fun (closure-function fun))) |
---|
793 | (when (lambda-expression-p fun) |
---|
794 | (setq fun (compile-named-function fun))) |
---|
795 | fun)) |
---|
796 | |
---|
797 | (%fhave 'df #'disassemble) |
---|
798 | |
---|
799 | (defun string-sans-most-whitespace (string &optional (max-length (length string))) |
---|
800 | (with-output-to-string (sans-whitespace) |
---|
801 | (loop |
---|
802 | for count below max-length |
---|
803 | for char across string |
---|
804 | with just-saw-space = nil |
---|
805 | if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed)) |
---|
806 | do (if just-saw-space |
---|
807 | (decf count) |
---|
808 | (write-char #\Space sans-whitespace)) |
---|
809 | and do (setf just-saw-space t) |
---|
810 | else |
---|
811 | do (setf just-saw-space nil) |
---|
812 | and do (write-char char sans-whitespace)))) |
---|
813 | |
---|
814 | |
---|
815 | (defparameter *svn-program* "svn") |
---|
816 | |
---|
817 | (defloadvar *use-cygwin-svn* |
---|
818 | #+windows-target (not (null (getenv "CYGWIN"))) |
---|
819 | #-windows-target nil) |
---|
820 | |
---|
821 | (defun svn-info-component (component) |
---|
822 | (let* ((component-length (length component))) |
---|
823 | (let* ((s (make-string-output-stream))) |
---|
824 | (multiple-value-bind (status exit-code) |
---|
825 | (external-process-status |
---|
826 | (run-program *svn-program* (list "info" (native-translated-namestring "ccl:")) :output s :error :output)) |
---|
827 | (when (and (eq :exited status) (zerop exit-code)) |
---|
828 | (with-input-from-string (output (get-output-stream-string s)) |
---|
829 | (do* ((line (read-line output nil nil) (read-line output nil nil))) |
---|
830 | ((null line)) |
---|
831 | (when (and (>= (length line) component-length) |
---|
832 | (string= component line :end2 component-length)) |
---|
833 | (return-from svn-info-component |
---|
834 | (string-trim " " (subseq line component-length))))))))) |
---|
835 | nil)) |
---|
836 | |
---|
837 | (defun svn-url () (svn-info-component "URL:")) |
---|
838 | (defun svn-repository () (svn-info-component "Repository Root:")) |
---|
839 | |
---|
840 | ;;; Try to say something about what tree (trunk, a branch, a release) |
---|
841 | ;;; we were built from. If the URL (relative to the repository) |
---|
842 | ;;; starts with "branches", return the second component of the |
---|
843 | ;;; relative URL, otherwise return the first component. |
---|
844 | (defun svn-tree () |
---|
845 | (let* ((repo (svn-repository)) |
---|
846 | (url (svn-url))) |
---|
847 | (or |
---|
848 | (if (and repo url) |
---|
849 | (let* ((repo-len (length repo))) |
---|
850 | (when (and (> (length url) repo-len) |
---|
851 | (string= repo url :end2 repo-len)) |
---|
852 | ;; Cheat: do pathname parsing here. |
---|
853 | (let* ((path (pathname (ensure-directory-namestring (subseq url repo-len)))) |
---|
854 | (dir (cdr (pathname-directory path)))) |
---|
855 | (when (string= "ccl" (car (last dir))) |
---|
856 | (let* ((base (car dir))) |
---|
857 | (unless (or (string= base "release") |
---|
858 | (string= base "releases")) |
---|
859 | (if (string= base "branches") |
---|
860 | (cadr dir) |
---|
861 | (car dir)))))))))))) |
---|
862 | |
---|
863 | |
---|
864 | (defun svnversion-program () |
---|
865 | (or (ignore-errors |
---|
866 | (native-translated-namestring |
---|
867 | (merge-pathnames "svnversion" *svn-program*))) |
---|
868 | "svnversion")) |
---|
869 | |
---|
870 | |
---|
871 | |
---|
872 | |
---|
873 | (defun local-svn-revision () |
---|
874 | (let* ((s (make-string-output-stream)) |
---|
875 | (root (native-translated-namestring "ccl:"))) |
---|
876 | (when *use-cygwin-svn* |
---|
877 | (setq root (cygpath root))) |
---|
878 | (multiple-value-bind (status exit-code) |
---|
879 | (external-process-status |
---|
880 | (run-program (svnversion-program) (list (native-translated-namestring "ccl:") (or (svn-url) "")) :output s :error :output)) |
---|
881 | (when (and (eq :exited status) (zerop exit-code)) |
---|
882 | (with-input-from-string (output (get-output-stream-string s)) |
---|
883 | (let* ((line (read-line output nil nil))) |
---|
884 | (when (and line (parse-integer line :junk-allowed t) ) |
---|
885 | (return-from local-svn-revision line)))))) |
---|
886 | nil)) |
---|
887 | |
---|
888 | |
---|
889 | ;;; Scan the heap, collecting infomation on the primitive object types |
---|
890 | ;;; found. Report that information. |
---|
891 | |
---|
892 | (defun heap-utilization (&key (stream *debug-io*) |
---|
893 | (gc-first t) |
---|
894 | (area nil) |
---|
895 | (unit nil) |
---|
896 | (sort :size) |
---|
897 | (classes nil) |
---|
898 | (start nil) |
---|
899 | (threshold (and classes 0.00005))) |
---|
900 | "Show statistics about types of objects in the heap. |
---|
901 | If :GC-FIRST is true (the default), do a full gc before scanning the heap. |
---|
902 | If :START is non-nil, it should be an object returned by GET-ALLOCATION-SENTINEL, only |
---|
903 | objects at higher address are scanned (i.e. roughly, only objects allocated after it). |
---|
904 | :SORT can be one of :COUNT, :LOGICAL-SIZE, or :PHYSICAL-SIZE to sort by count or size. |
---|
905 | :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes. |
---|
906 | :AREA can be used to restrict the walk to one area or a list of areas. Some possible |
---|
907 | values are :DYNAMIC, :STATIC, :MANAGED-STATIC, :READONLY. By default, all areas |
---|
908 | (including stacks) are examined. |
---|
909 | If :CLASSES is true, classifies by class rather than just typecode" |
---|
910 | (let ((data (collect-heap-utilization :gc-first gc-first :start start :area area :classes classes))) |
---|
911 | (report-heap-utilization data :stream stream :unit unit :sort sort :threshold threshold))) |
---|
912 | |
---|
913 | (defun collect-heap-utilization (&key (gc-first t) start area classes) |
---|
914 | ;; returns list of (type-name count logical-sizes-total physical-sizes-total) |
---|
915 | (when start |
---|
916 | (unless (or (null area) |
---|
917 | (eq (heap-area-code area) area-dynamic) |
---|
918 | (and (consp area) (every (lambda (a) (eq (heap-area-code a) area-dynamic)) area))) |
---|
919 | (error "~s ~s and ~s ~s are incompatible" :start start :area area)) |
---|
920 | (setq area area-dynamic)) |
---|
921 | (if classes |
---|
922 | (collect-heap-utilization-by-class gc-first area start) |
---|
923 | (collect-heap-utilization-by-typecode gc-first area start))) |
---|
924 | |
---|
925 | (defun collect-heap-utilization-by-typecode (gc-first area start) |
---|
926 | (let* ((nconses 0) |
---|
927 | (counts (make-array 257)) |
---|
928 | (sizes (make-array 257)) |
---|
929 | (physical-sizes (make-array 257)) |
---|
930 | (array-size-function (arch::target-array-data-size-function |
---|
931 | (backend-target-arch *host-backend*)))) |
---|
932 | (declare (type (simple-vector 257) counts sizes physical-sizes) |
---|
933 | (fixnum nconses) |
---|
934 | (dynamic-extent counts sizes physical-sizes)) |
---|
935 | (flet ((collect (thing) |
---|
936 | (when (or (null start) |
---|
937 | (locally (declare (optimize (speed 3) (safety 0))) ;; lie |
---|
938 | (%i< start thing))) |
---|
939 | (if (listp thing) |
---|
940 | (incf nconses) |
---|
941 | (let* ((typecode (typecode thing)) |
---|
942 | (logsize (funcall array-size-function typecode (uvsize thing))) |
---|
943 | (physize (logandc2 (+ logsize |
---|
944 | #+64-bit-target (+ 8 15) |
---|
945 | #+32-bit-target (+ 4 7)) |
---|
946 | #+64-bit-target 15 |
---|
947 | #+32-bit-target 7))) |
---|
948 | (incf (aref counts typecode)) |
---|
949 | (incf (aref sizes typecode) logsize) |
---|
950 | (incf (aref physical-sizes typecode) physize)))))) |
---|
951 | (declare (dynamic-extent #'collect)) |
---|
952 | (when gc-first (gc)) |
---|
953 | (%map-areas #'collect area)) |
---|
954 | (setf (aref counts 256) nconses) |
---|
955 | (setf (aref sizes 256) (* nconses target::cons.size)) |
---|
956 | (setf (aref physical-sizes 256) (aref sizes 256)) |
---|
957 | (loop for i from 0 upto 256 |
---|
958 | when (plusp (aref counts i)) |
---|
959 | collect (list (if (eql i 256) 'cons (aref *heap-utilization-vector-type-names* i)) |
---|
960 | (aref counts i) |
---|
961 | (aref sizes i) |
---|
962 | (aref physical-sizes i))))) |
---|
963 | |
---|
964 | (defun collect-heap-utilization-by-class (gc-first area start) |
---|
965 | (let* ((nconses 0) |
---|
966 | (max-classes (+ 100 (hash-table-count %find-classes%))) |
---|
967 | (map (make-hash-table :shared nil |
---|
968 | :test 'eq |
---|
969 | :size max-classes)) |
---|
970 | (inst-counts (make-array max-classes :initial-element 0)) |
---|
971 | (slotv-counts (make-array max-classes :initial-element 0)) |
---|
972 | (inst-sizes (make-array max-classes :initial-element 0)) |
---|
973 | (slotv-sizes (make-array max-classes :initial-element 0)) |
---|
974 | (inst-psizes (make-array max-classes :initial-element 0)) |
---|
975 | (slotv-psizes (make-array max-classes :initial-element 0)) |
---|
976 | (overflow nil) |
---|
977 | (array-size-function (arch::target-array-data-size-function |
---|
978 | (backend-target-arch *host-backend*)))) |
---|
979 | (declare (type simple-vector inst-counts slotv-counts inst-sizes slotv-sizes inst-psizes slotv-psizes)) |
---|
980 | (flet ((collect (thing) |
---|
981 | (when (or (null start) |
---|
982 | (locally (declare (optimize (speed 3) (safety 0))) ;; lie |
---|
983 | (%i< start thing))) |
---|
984 | (if (listp thing) |
---|
985 | (incf nconses) |
---|
986 | (unless (or (eq thing map) |
---|
987 | (eq thing (nhash.vector map)) |
---|
988 | (eq thing inst-counts) |
---|
989 | (eq thing slotv-counts) |
---|
990 | (eq thing inst-sizes) |
---|
991 | (eq thing slotv-sizes) |
---|
992 | (eq thing inst-psizes) |
---|
993 | (eq thing slotv-psizes)) |
---|
994 | (let* ((typecode (typecode thing)) |
---|
995 | (logsize (funcall array-size-function typecode (uvsize thing))) |
---|
996 | (physize (logandc2 (+ logsize |
---|
997 | #+64-bit-target (+ 8 15) |
---|
998 | #+32-bit-target (+ 4 7)) |
---|
999 | #+64-bit-target 15 |
---|
1000 | #+32-bit-target 7)) |
---|
1001 | (class (class-of (if (eql typecode target::subtag-slot-vector) |
---|
1002 | (uvref thing slot-vector.instance) |
---|
1003 | (if (eql typecode target::subtag-function) |
---|
1004 | (function-vector-to-function thing) |
---|
1005 | thing)))) |
---|
1006 | (index (or (gethash class map) |
---|
1007 | (let ((count (hash-table-count map))) |
---|
1008 | (if (eql count max-classes) |
---|
1009 | (setq overflow t count (1- max-classes)) |
---|
1010 | (setf (gethash class map) count)))))) |
---|
1011 | |
---|
1012 | (if (eql typecode target::subtag-slot-vector) |
---|
1013 | (progn |
---|
1014 | (incf (aref slotv-counts index)) |
---|
1015 | (incf (aref slotv-sizes index) logsize) |
---|
1016 | (incf (aref slotv-psizes index) physize)) |
---|
1017 | (progn |
---|
1018 | (incf (aref inst-counts index)) |
---|
1019 | (incf (aref inst-sizes index) logsize) |
---|
1020 | (incf (aref inst-psizes index) physize))))))))) |
---|
1021 | (declare (dynamic-extent #'collect)) |
---|
1022 | (when gc-first (gc)) |
---|
1023 | (%map-areas #'collect area)) |
---|
1024 | (let ((data ())) |
---|
1025 | (when (plusp nconses) |
---|
1026 | (push (list 'cons nconses (* nconses target::cons.size) (* nconses target::cons.size)) data)) |
---|
1027 | (maphash (lambda (class index) |
---|
1028 | (let* ((icount (aref inst-counts index)) |
---|
1029 | (scount (aref slotv-counts index)) |
---|
1030 | (name (if (and overflow (eql index (1- max-classes))) |
---|
1031 | "All others" |
---|
1032 | (or (%class-proper-name class) class)))) |
---|
1033 | (declare (fixnum icount) (fixnum scount)) |
---|
1034 | ;; When printing class names, the package matters. report-heap-utilization |
---|
1035 | ;; uses ~a, so print here. |
---|
1036 | (when (plusp icount) |
---|
1037 | (push (list (prin1-to-string name) |
---|
1038 | icount (aref inst-sizes index) (aref inst-psizes index)) data)) |
---|
1039 | (when (plusp scount) |
---|
1040 | (push (list (format nil "~s slot vector" name) |
---|
1041 | scount (aref slotv-sizes index) (aref slotv-psizes index)) data)))) |
---|
1042 | map) |
---|
1043 | data))) |
---|
1044 | |
---|
1045 | (defun collect-heap-ivector-utilization-by-typecode () |
---|
1046 | (let* ((counts (make-array 256 :initial-element 0)) |
---|
1047 | (sizes (make-array 256 :initial-element 0)) |
---|
1048 | (physical-sizes (make-array 256 :initial-element 0)) |
---|
1049 | (array-size-function (arch::target-array-data-size-function |
---|
1050 | (backend-target-arch *host-backend*))) |
---|
1051 | (result ())) |
---|
1052 | (declare (dynamic-extent counts sizes)) |
---|
1053 | (with-lock-grabbed (*heap-ivector-lock*) |
---|
1054 | (dolist (vector *heap-ivectors*) |
---|
1055 | (let* ((typecode (typecode vector)) |
---|
1056 | (logsize (funcall array-size-function typecode (uvsize vector))) |
---|
1057 | (physsize (+ logsize |
---|
1058 | ;; header, delta, round up |
---|
1059 | #+32-bit-target (+ 4 2 7) |
---|
1060 | #+64-bit-target (+ 8 2 15)))) |
---|
1061 | (incf (aref counts typecode)) |
---|
1062 | (incf (aref sizes typecode) logsize) |
---|
1063 | (incf (aref physical-sizes typecode) physsize)))) |
---|
1064 | (dotimes (i 256 result) |
---|
1065 | (when (plusp (aref counts i)) |
---|
1066 | (push (list (aref *heap-utilization-vector-type-names* i) |
---|
1067 | (aref counts i) |
---|
1068 | (aref sizes i) |
---|
1069 | (aref physical-sizes i)) |
---|
1070 | result))))) |
---|
1071 | |
---|
1072 | (defun heap-ivector-utilization (&key (stream *debug-io*) |
---|
1073 | (unit nil) |
---|
1074 | (sort :size)) |
---|
1075 | (let* ((data (collect-heap-ivector-utilization-by-typecode))) |
---|
1076 | (report-heap-utilization data :stream stream :unit unit :sort sort))) |
---|
1077 | |
---|
1078 | (defvar *heap-utilization-vector-type-names* |
---|
1079 | (let* ((a (make-array 256))) |
---|
1080 | #+x8664-target |
---|
1081 | (dotimes (i 256) |
---|
1082 | (let* ((fulltag (logand i x8664::fulltagmask)) |
---|
1083 | (names-vector |
---|
1084 | (cond ((= fulltag x8664::fulltag-nodeheader-0) |
---|
1085 | *nodeheader-0-types*) |
---|
1086 | ((= fulltag x8664::fulltag-nodeheader-1) |
---|
1087 | *nodeheader-1-types*) |
---|
1088 | ((= fulltag x8664::fulltag-immheader-0) |
---|
1089 | *immheader-0-types*) |
---|
1090 | ((= fulltag x8664::fulltag-immheader-1) |
---|
1091 | *immheader-1-types*) |
---|
1092 | ((= fulltag x8664::fulltag-immheader-2) |
---|
1093 | *immheader-2-types*))) |
---|
1094 | (name (if names-vector |
---|
1095 | (aref names-vector (ash i -4))))) |
---|
1096 | ;; Special-case a few things ... |
---|
1097 | (if (eq name 'symbol-vector) |
---|
1098 | (setq name 'symbol) |
---|
1099 | (if (eq name 'function-vector) |
---|
1100 | (setq name 'function))) |
---|
1101 | (setf (aref a i) name))) |
---|
1102 | #+ppc64-target |
---|
1103 | (dotimes (i 256) |
---|
1104 | (let* ((lowtag (logand i ppc64::lowtagmask))) |
---|
1105 | (setf (%svref a i) |
---|
1106 | (cond ((= lowtag ppc64::lowtag-immheader) |
---|
1107 | (%svref *immheader-types* (ash i -2))) |
---|
1108 | ((= lowtag ppc64::lowtag-nodeheader) |
---|
1109 | (%svref *nodeheader-types* (ash i -2))))))) |
---|
1110 | #+(or ppc32-target x8632-target) |
---|
1111 | (dotimes (i 256) |
---|
1112 | (let* ((fulltag (logand i target::fulltagmask))) |
---|
1113 | (setf (%svref a i) |
---|
1114 | (cond ((= fulltag target::fulltag-immheader) |
---|
1115 | (%svref *immheader-types* (ash i -3))) |
---|
1116 | ((= fulltag target::fulltag-nodeheader) |
---|
1117 | (%svref *nodeheader-types* (ash i -3))))))) |
---|
1118 | a)) |
---|
1119 | |
---|
1120 | |
---|
1121 | (defun report-heap-utilization (data &key stream unit sort threshold) |
---|
1122 | (check-type threshold (or null (real 0 1))) |
---|
1123 | (let* ((div (ecase unit |
---|
1124 | ((nil) 1) |
---|
1125 | (:kb 1024.0d0) |
---|
1126 | (:mb (* 1024.0d0 1024.0d0)) |
---|
1127 | (:gb (* 1024.0d0 1024.0d0 1024.0d0)))) |
---|
1128 | (sort-key (ecase sort |
---|
1129 | (:count #'cadr) |
---|
1130 | (:logical-size #'caddr) |
---|
1131 | ((:physical-size :size) #'cadddr) |
---|
1132 | ((:name nil) nil))) |
---|
1133 | (total-count 0) |
---|
1134 | (total-lsize 0) |
---|
1135 | (total-psize 0) |
---|
1136 | (max-name 0) |
---|
1137 | (others (list "All others" 0 0 0))) |
---|
1138 | |
---|
1139 | (when (hash-table-p data) |
---|
1140 | (setq data |
---|
1141 | (let ((alist nil)) |
---|
1142 | (maphash (lambda (type measures) (push (cons type measures) alist)) data) |
---|
1143 | alist))) |
---|
1144 | |
---|
1145 | (flet ((type-string (name) |
---|
1146 | (if (stringp name) |
---|
1147 | name |
---|
1148 | (if (symbolp name) |
---|
1149 | (symbol-name name) |
---|
1150 | (princ-to-string name))))) |
---|
1151 | (loop for (nil count lsize psize) in data |
---|
1152 | do (incf total-count count) |
---|
1153 | do (incf total-lsize lsize) |
---|
1154 | do (incf total-psize psize)) |
---|
1155 | |
---|
1156 | (when (and data threshold) |
---|
1157 | (setq data (sort data #'< :key #'cadddr)) |
---|
1158 | (loop while (< (/ (cadddr (car data)) total-psize) threshold) |
---|
1159 | do (destructuring-bind (type count lsize psize) (pop data) |
---|
1160 | (declare (ignore type)) |
---|
1161 | (incf (cadr others) count) |
---|
1162 | (incf (caddr others) lsize) |
---|
1163 | (incf (cadddr others) psize)))) |
---|
1164 | |
---|
1165 | (setq data |
---|
1166 | (if sort-key |
---|
1167 | (sort data #'> :key sort-key) |
---|
1168 | (sort data #'string-lessp :key #'(lambda (s) (type-string (car s)))))) |
---|
1169 | |
---|
1170 | (when (> (cadr others) 0) |
---|
1171 | (setq data (nconc data (list others)))) |
---|
1172 | |
---|
1173 | (setq max-name (loop for (name) in data maximize (length (type-string name)))) |
---|
1174 | |
---|
1175 | (format stream "~&Object type~vtCount Logical size Physical size % of Heap~%~vt ~a~vt ~2:*~a" |
---|
1176 | (+ max-name 7) |
---|
1177 | (+ max-name 15) |
---|
1178 | (ecase unit |
---|
1179 | ((nil) " (in bytes)") |
---|
1180 | (:kb "(in kilobytes)") |
---|
1181 | (:mb "(in megabytes)") |
---|
1182 | (:gb "(in gigabytes)")) |
---|
1183 | (+ max-name 31)) |
---|
1184 | (loop for (type count logsize physsize) in data |
---|
1185 | do (if unit |
---|
1186 | (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%" |
---|
1187 | (type-string type) |
---|
1188 | (1+ max-name) |
---|
1189 | count |
---|
1190 | (/ logsize div) |
---|
1191 | (/ physsize div) |
---|
1192 | (* 100.0 (/ physsize total-psize))) |
---|
1193 | (format stream "~&~a~vt~11d~16d~16d~11,2f%" |
---|
1194 | (type-string type) |
---|
1195 | (1+ max-name) |
---|
1196 | count |
---|
1197 | logsize |
---|
1198 | physsize |
---|
1199 | (* 100.0 (/ physsize total-psize))))) |
---|
1200 | (if unit |
---|
1201 | (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%" |
---|
1202 | "Total" |
---|
1203 | (1+ max-name) |
---|
1204 | total-count |
---|
1205 | (/ total-lsize div) |
---|
1206 | (/ total-psize div) |
---|
1207 | 100.0d0) |
---|
1208 | (format stream "~&~a~vt~11d~16d~16d~11,2f%" |
---|
1209 | "Total" |
---|
1210 | (1+ max-name) |
---|
1211 | total-count |
---|
1212 | total-lsize |
---|
1213 | total-psize |
---|
1214 | 100.0d0)))) |
---|
1215 | (values)) |
---|
1216 | |
---|
1217 | |
---|
1218 | |
---|
1219 | (defun static-cons (car-value cdr-value) |
---|
1220 | "Allocates a cons cell that doesn't move on garbage collection, |
---|
1221 | and thus doesn't trigger re-hashing when used as a key in a hash |
---|
1222 | table. Usage is equivalent to regular CONS." |
---|
1223 | (loop |
---|
1224 | (let ((cell (without-interrupts (%atomic-pop-static-cons)))) |
---|
1225 | (if cell |
---|
1226 | (progn |
---|
1227 | (setf (car cell) car-value) |
---|
1228 | (setf (cdr cell) cdr-value) |
---|
1229 | (return cell)) |
---|
1230 | (progn |
---|
1231 | (%ensure-static-conses)))))) |
---|
1232 | |
---|
1233 | (defun free-static-conses () |
---|
1234 | (%get-kernel-global free-static-conses)) |
---|
1235 | |
---|
1236 | (defun reserved-static-conses () |
---|
1237 | (%fixnum-ref-natural (%get-kernel-global static-cons-area) target::area.ndnodes)) |
---|
1238 | |
---|
1239 | |
---|
1240 | (defparameter *weak-gc-method-names* |
---|
1241 | '((:traditional . 0) |
---|
1242 | (:non-circular . 1))) |
---|
1243 | |
---|
1244 | |
---|
1245 | (defun weak-gc-method () |
---|
1246 | (or (car (rassoc (%get-kernel-global 'weak-gc-method) |
---|
1247 | *weak-gc-method-names*)) |
---|
1248 | :traditional)) |
---|
1249 | |
---|
1250 | |
---|
1251 | (defun (setf weak-gc-method) (name) |
---|
1252 | (setf (%get-kernel-global 'weak-gc-method) |
---|
1253 | (or (cdr (assoc name *weak-gc-method-names*)) |
---|
1254 | 0)) |
---|
1255 | name) |
---|
1256 | |
---|
1257 | (defun %lock-whostate-string (string lock) |
---|
1258 | (with-standard-io-syntax |
---|
1259 | (format nil "~a for ~a ~@[~a ~]@ #x~x" |
---|
1260 | string |
---|
1261 | (%svref lock target::lock.kind-cell) |
---|
1262 | (lock-name lock) |
---|
1263 | (%ptr-to-int (%svref lock target::lock._value-cell))))) |
---|
1264 | |
---|
1265 | (defun all-watched-objects () |
---|
1266 | (let (result) |
---|
1267 | (with-other-threads-suspended |
---|
1268 | (%map-areas #'(lambda (x) (push x result)) area-watched)) |
---|
1269 | result)) |
---|
1270 | |
---|
1271 | (defun primitive-watch (thing) |
---|
1272 | (require-type thing '(or cons (satisfies uvectorp))) |
---|
1273 | (%watch thing)) |
---|
1274 | |
---|
1275 | (defun watch (&optional thing) |
---|
1276 | (cond ((null thing) |
---|
1277 | (all-watched-objects)) |
---|
1278 | ((arrayp thing) |
---|
1279 | (primitive-watch (array-data-and-offset thing))) |
---|
1280 | ((hash-table-p thing) |
---|
1281 | (primitive-watch (nhash.vector thing))) |
---|
1282 | ((standard-instance-p thing) |
---|
1283 | (primitive-watch (instance-slots thing))) |
---|
1284 | (t |
---|
1285 | (primitive-watch thing)))) |
---|
1286 | |
---|
1287 | (defun unwatch (thing) |
---|
1288 | (with-other-threads-suspended |
---|
1289 | (%map-areas #'(lambda (x) |
---|
1290 | (when (eq x thing) |
---|
1291 | (let ((new (if (uvectorp thing) |
---|
1292 | (%alloc-misc (uvsize thing) |
---|
1293 | (typecode thing)) |
---|
1294 | (cons nil nil)))) |
---|
1295 | (return-from unwatch (%unwatch thing new))))) |
---|
1296 | area-watched))) |
---|
1297 | |
---|
1298 | (defun %parse-unsigned-integer (vector start end) |
---|
1299 | (declare ((simple-array (unsigned-byte 8) (*)) vector) |
---|
1300 | (fixnum start end) |
---|
1301 | (optimize (speed 3) (safety 0))) |
---|
1302 | (let* ((count (- end start)) |
---|
1303 | (msb 0)) |
---|
1304 | (declare (fixnum count) ((unsigned-byte 8) msb)) |
---|
1305 | (or |
---|
1306 | (do* ((i start (1+ i))) |
---|
1307 | ((>= i end) 0) |
---|
1308 | (declare (fixnum i)) |
---|
1309 | (let* ((b (aref vector i))) |
---|
1310 | (declare ((unsigned-byte 8) b)) |
---|
1311 | (cond ((zerop b) (incf start) (decf count)) |
---|
1312 | (t (setq msb b) (return))))) |
---|
1313 | (cond |
---|
1314 | ((or (< count #+64-bit-target 8 #+32-bit-target 4) |
---|
1315 | (and (= count #+64-bit-target 8 #+32-bit-target 4) |
---|
1316 | (< msb #+64-bit-target 16 #+32-bit-target 32))) |
---|
1317 | ;; Result will be a fixnum. |
---|
1318 | (do* ((result 0) |
---|
1319 | (shift 0 (+ shift 8)) |
---|
1320 | (i (1- end) (1- i))) |
---|
1321 | ((< i start) result) |
---|
1322 | (declare (fixnum result shift i)) |
---|
1323 | (setq result (logior result (the fixnum (%ilsl shift (aref vector i))))))) |
---|
1324 | (t |
---|
1325 | ;; Result will be a bignum. If COUNT is a multiple of 4 |
---|
1326 | ;; and the most significant bit is set, need to add an |
---|
1327 | ;; extra word of zero-extension. |
---|
1328 | (let* ((result (allocate-typed-vector :bignum |
---|
1329 | (if (and (logbitp 7 msb) |
---|
1330 | (zerop (the fixnum (logand count 3)))) |
---|
1331 | (the fixnum (1+ (the fixnum (ash count -2)))) |
---|
1332 | (the fixnum (ash (the fixnum (+ count 3)) -2)))))) |
---|
1333 | (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie |
---|
1334 | (dotimes (i count result) |
---|
1335 | (decf end) |
---|
1336 | (setf (aref result |
---|
1337 | #+little-endian-target i |
---|
1338 | #+big-endian-target (the fixnum (logxor i 3))) |
---|
1339 | (aref vector end))))))))) |
---|
1340 | |
---|
1341 | |
---|
1342 | ;;; Octets between START and END encode an unsigned integer in big-endian |
---|
1343 | ;;; byte order. |
---|
1344 | (defun parse-unsigned-integer (vector &optional (start 0) end) |
---|
1345 | (setq end (check-sequence-bounds vector start end)) |
---|
1346 | (locally (declare (fixnum start end)) |
---|
1347 | (unless (typep vector '(simple-array (unsigned-byte 8) (*))) |
---|
1348 | (multiple-value-bind (data offset) (array-data-and-offset vector) |
---|
1349 | (declare (fixnum offset)) |
---|
1350 | (unless (typep data '(simple-array (unsigned-byte 8) (*))) |
---|
1351 | (report-bad-arg vector '(vector (unsigned-byte 8)))) |
---|
1352 | (incf start offset) |
---|
1353 | (incf end offset) |
---|
1354 | (setq vector data))) |
---|
1355 | (%parse-unsigned-integer vector start end))) |
---|
1356 | |
---|
1357 | (defun %parse-signed-integer (vector start end) |
---|
1358 | (declare ((simple-array (unsigned-byte 8) (*)) vector) |
---|
1359 | (fixnum start end) |
---|
1360 | (optimize (speed 3) (safety 0))) |
---|
1361 | (let* ((count (- end start))) |
---|
1362 | (declare (fixnum count)) |
---|
1363 | (if (zerop count) |
---|
1364 | 0 |
---|
1365 | (let* ((sign-byte (aref vector start))) |
---|
1366 | (declare (fixnum sign-byte)) |
---|
1367 | (if (< sign-byte 128) |
---|
1368 | (%parse-unsigned-integer vector start end) |
---|
1369 | (progn |
---|
1370 | (decf sign-byte 256) |
---|
1371 | (or |
---|
1372 | (do* () |
---|
1373 | ((= count 1) sign-byte) |
---|
1374 | (unless (= sign-byte -1) |
---|
1375 | (return)) |
---|
1376 | (let* ((next (1+ start)) |
---|
1377 | (nextb (aref vector next))) |
---|
1378 | (declare (fixnum next nextb)) |
---|
1379 | (if (not (logbitp 7 nextb)) |
---|
1380 | (return)) |
---|
1381 | (setq sign-byte (- nextb 256) |
---|
1382 | start next |
---|
1383 | count (1- count)))) |
---|
1384 | (cond ((or (< count #+64-bit-target 8 #+32-bit-target 4) |
---|
1385 | (and (= count #+64-bit-target 8 #+32-bit-target 4) |
---|
1386 | (>= sign-byte |
---|
1387 | #+64-bit-target -16 |
---|
1388 | #+32-bit-target -32))) |
---|
1389 | ;; Result will be a fixnum |
---|
1390 | (do* ((result 0) |
---|
1391 | (shift 0 (+ shift 8)) |
---|
1392 | (i (1- end) (1- i))) |
---|
1393 | ((= i start) (logior result (the fixnum (%ilsl shift sign-byte)))) |
---|
1394 | (declare (fixnum result shift i)) |
---|
1395 | (setq result (logior result (the fixnum (%ilsl shift (aref vector i))))))) |
---|
1396 | (t |
---|
1397 | (let* ((result (allocate-typed-vector :bignum (the fixnum (ash (the fixnum (+ count 3)) -2))))) |
---|
1398 | (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie |
---|
1399 | (dotimes (i count (do* ((i count (1+ i))) |
---|
1400 | ((= 0 (the fixnum (logand i 3))) |
---|
1401 | result) |
---|
1402 | (declare (fixnum i)) |
---|
1403 | (setf (aref result |
---|
1404 | #+little-endian-target i |
---|
1405 | #+big-endian-target (the fixnum (logxor i 3))) #xff))) |
---|
1406 | (decf end) |
---|
1407 | (setf (aref result |
---|
1408 | #+little-endian-target i |
---|
1409 | #+big-endian-target (the fixnum (logxor i 3))) |
---|
1410 | (aref vector end))))))))))))) |
---|
1411 | |
---|
1412 | (defun parse-signed-integer (vector &optional (start 0) end) |
---|
1413 | (setq end (check-sequence-bounds vector start end)) |
---|
1414 | (locally (declare (fixnum start end)) |
---|
1415 | (unless (typep vector '(simple-array (unsigned-byte 8) (*))) |
---|
1416 | (multiple-value-bind (data offset) (array-data-and-offset vector) |
---|
1417 | (declare (fixnum offset)) |
---|
1418 | (unless (typep data '(simple-array (unsigned-byte 8) (*))) |
---|
1419 | (report-bad-arg vector '(vector (unsigned-byte 8)))) |
---|
1420 | (incf start offset) |
---|
1421 | (incf end offset) |
---|
1422 | (setq vector data))) |
---|
1423 | (%parse-signed-integer vector start end))) |
---|