source: trunk/source/lib/misc.lisp @ 14423

Last change on this file since 14423 was 14327, checked in by gb, 9 years ago

Make ADD-FEATURE try to do so in a thread-safe way; define REMOVE-FEATURE.
Export ADD-FEATURE and REMOVE-FEATURE.

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