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

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

In the #+darwin-target version of %page-fault-info, try to do what
the 10.6 version of #_getrusage (which actually bothers to do something)
does.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 54.6 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                       ((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    (let* ((faults (pref info #>task_events_info.faults))
425           (pageins (pref info #>task_events_info.pageins)))
426      (values (- faults pageins)
427              pageins
428              0)))
429  #+windows-target
430  ;; Um, don't know how to determine this, or anything like it.
431  (values 0 0 0))
432
433
434         
435(defparameter *report-time-function* nil
436  "If non-NULL, should be a function which accepts the following
437   keyword arguments:
438   :FORM              the form that was executed
439   :RESULTS           a list of all values returned by the execution of FORM
440   :ELAPSED-TIME      total elapsed (real) time, in internal-time-units-per-second
441   :USER-TIME         elapsed user time, in internal-time-units-per-second
442   :SYSTEM-TIME       elapsed system time, in internal-time-units-per-second
443   :GC-TIME           total real time spent in the GC, in internal-time-units-per-second
444   :BYTES-ALLOCATED   total bytes allocated
445   :MINOR-PAGE-FAULTS minor page faults
446   :MAJOR-PAGE-FAULTS major page faults
447   :SWAPS             swaps")
448
449
450(defun standard-report-time (&key form results elapsed-time user-time
451                                  system-time gc-time bytes-allocated
452                                  minor-page-faults major-page-faults
453                                  swaps)
454  (let* ((s *trace-output*)
455         (units
456          (ecase internal-time-units-per-second
457            (1000000 "microseconds")
458            (1000  "milliseconds")))
459         (width
460          (ecase internal-time-units-per-second
461            (1000000 6)
462            (1000  3)))
463         (cpu-count (cpu-count)))
464    (format s "~&~S took ~:D ~a (~,vF seconds) to run ~%~20twith ~D available CPU core~P."
465            form elapsed-time units width (/ elapsed-time internal-time-units-per-second) cpu-count cpu-count)
466    (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))
467    (format s "~&                    ~:D ~a (~,vF seconds) were spent in system mode" system-time units width(/ system-time internal-time-units-per-second))
468    (unless (eql gc-time 0)
469      (format s
470              "~%~:D ~a (~,vF seconds) was spent in GC."
471              gc-time units width (/ gc-time internal-time-units-per-second)))
472    (unless (eql 0 bytes-allocated)
473      (format s "~% ~:D bytes of memory allocated." bytes-allocated))
474    (when (or (> minor-page-faults 0)
475              (> major-page-faults 0)
476              (> swaps 0))
477      (format s
478              "~% ~:D minor page faults, ~:D major page faults, ~:D swaps."
479              minor-page-faults major-page-faults swaps))
480    (format s "~&")
481    (values-list results)))
482
483(defun report-time (form thunk)
484  (flet ((integer-size-in-bytes (i)
485           (if (typep i 'fixnum)
486             0
487             (* (logand (+ 2 (uvsize i)) (lognot 1)) 4))))
488    (multiple-value-bind (user-start system-start)
489        (%internal-run-time)
490      (multiple-value-bind (minor-start major-start swaps-start)
491          (%page-fault-info)
492        (let* ((initial-real-time (get-internal-real-time))
493               (initial-gc-time (gctime))
494               (initial-consed (total-bytes-allocated))           
495               (initial-overhead (integer-size-in-bytes initial-consed)))
496          (let* ((results (multiple-value-list (funcall thunk))))
497            (declare (dynamic-extent results))
498            (multiple-value-bind (user-end system-end)
499                (%internal-run-time)
500              (multiple-value-bind (minor-end major-end swaps-end)
501                  (%page-fault-info)
502                (let* ((new-consed (total-bytes-allocated))                 
503                       (bytes-consed
504                        (- new-consed (+ initial-overhead initial-consed)))
505                       (elapsed-real-time
506                        (- (get-internal-real-time) initial-real-time))
507                       (elapsed-gc-time (- (gctime) initial-gc-time))
508                       (elapsed-user-time
509                        (- user-end user-start))
510                       (elapsed-system-time
511                        (- system-end system-start))
512                       (elapsed-minor (- minor-end minor-start))
513                       (elapsed-major (- major-end major-start))
514                       (elapsed-swaps (- swaps-end swaps-start)))
515                  (funcall (or *report-time-function*
516                               #'standard-report-time)
517                           :form form
518                           :results results
519                           :elapsed-time elapsed-real-time
520                           :user-time elapsed-user-time
521                           :system-time elapsed-system-time
522                           :gc-time elapsed-gc-time
523                           :bytes-allocated bytes-consed
524                           :minor-page-faults elapsed-minor
525                           :major-page-faults elapsed-major
526                           :swaps elapsed-swaps))))))))))
527
528
529
530
531;;; site names and machine-instance is in the init file.
532
533(defun add-feature (symbol)
534  "Not CL but should be."
535  (if (symbolp symbol)
536      (if (not (memq symbol *features*))
537          (setq *features* (cons symbol *features*)))))
538
539;;; (dotimes (i 5000) (declare (fixnum i)) (add-feature 'junk))
540
541
542
543
544;;; Misc string functions
545
546
547(defun string-left-trim (char-bag string &aux end)
548  "Given a set of characters (a list or string) and a string, returns
549  a copy of the string with the characters in the set removed from the
550  left end."
551  (setq string (string string))
552  (setq end (length string))
553  (do ((index 0 (%i+ index 1)))
554      ((or (eq index end) (not (find (aref string index) char-bag)))
555       (subseq string index end))))
556
557(defun string-right-trim (char-bag string &aux end)
558  "Given a set of characters (a list or string) and a string, returns
559  a copy of the string with the characters in the set removed from the
560  right end."
561  (setq string (string string))
562  (setq end (length string))
563  (do ((index (%i- end 1) (%i- index 1)))
564      ((or (%i< index 0) (not (find (aref string index) char-bag)))
565       (subseq string 0 (%i+ index 1)))))
566
567(defun string-trim (char-bag string &aux end)
568  "Given a set of characters (a list or string) and a string, returns a
569  copy of the string with the characters in the set removed from both
570  ends."
571  (setq string (string string))
572  (setq end (length string))
573  (let ((left-end) (right-end))
574     (do ((index 0 (%i+ index 1)))
575         ((or (eq index end) (not (find (aref string index) char-bag)))
576          (setq left-end index)))
577     (do ((index (%i- end 1) (%i- index 1)))
578         ((or (%i< index left-end) (not (find (aref string index) char-bag)))
579          (setq right-end index)))
580      (subseq string left-end (%i+ right-end 1))))
581
582
583
584(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol def)
585  "Make and return a new uninterned symbol with the same print name
586  as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound
587  nor fbound and has no properties, else it has a copy of SYMBOL's
588  function, value and property list."
589  (setq new-symbol (make-symbol (symbol-name symbol)))
590  (when copy-props
591      (when (boundp symbol)
592            (set new-symbol (symbol-value symbol)))
593      (when (setq def (fboundp symbol))
594            ;;;Shouldn't err out on macros/special forms.
595            (%fhave new-symbol def))
596      (set-symbol-plist new-symbol (copy-list (symbol-plist symbol))))
597  new-symbol)
598
599
600(defvar %gentemp-counter 0
601  "Counter for generating unique GENTEMP symbols.")
602
603(defun gentemp (&optional (prefix "T") (package *package*))
604  "Creates a new symbol interned in package PACKAGE with the given PREFIX."
605  (loop
606    (let* ((new-pname (%str-cat (ensure-simple-string prefix) 
607                                (%integer-to-string %gentemp-counter)))
608           (sym (find-symbol new-pname package)))
609      (if sym
610        (setq %gentemp-counter (%i+ %gentemp-counter 1))
611        (return (values (intern new-pname package))))))) ; 1 value.
612
613
614
615
616(defun add-gc-hook (hook-function &optional (which-hook :pre-gc))
617  (ecase which-hook
618    (:pre-gc
619     (pushnew hook-function *pre-gc-hook-list*)
620     (setq *pre-gc-hook* #'(lambda ()
621                             (dolist (hook *pre-gc-hook-list*)
622                               (funcall hook)))))
623    (:post-gc
624     (pushnew hook-function *post-gc-hook-list*)
625     (setq *post-gc-hook* #'(lambda ()
626                             (dolist (hook *post-gc-hook-list*)
627                               (funcall hook))))))
628  hook-function)
629
630(defun remove-gc-hook (hook-function &optional (which-hook :pre-gc))
631  (ecase which-hook
632    (:pre-gc
633     (unless (setq *pre-gc-hook-list* (delq hook-function *pre-gc-hook-list*))
634       (setq *pre-gc-hook* nil)))
635    (:post-gc
636     (unless (setq *post-gc-hook-list* (delq hook-function *post-gc-hook-list*))
637       (setq *post-gc-hook* nil)))))
638
639
640
641
642
643
644(defun find-method-by-names (name qualifiers specializers)
645  (let ((gf (fboundp name)))
646    (when gf
647      (if (not (standard-generic-function-p gf))
648        (error "~S is not a generic-function." gf)
649        (let ((methods (%gf-methods gf)))
650          (when methods
651            (let* ((spec-len (length (%method-specializers (car methods))))
652                   (new-specs (make-list spec-len :initial-element (find-class t))))
653              (declare (dynamic-extent new-specs))
654              (do ((specs specializers (cdr specs))
655                   (nspecs new-specs (cdr nspecs)))
656                  ((or (null specs) (null nspecs)))
657                (let ((s (car specs)))
658                  (rplaca nspecs (if (consp s) s (find-class s nil)))))
659              (find-method gf qualifiers new-specs nil))))))))
660
661
662
663
664(defun make-population (&key (type :list) initial-contents)
665  (let* ((ntype (ecase type
666                  (:list $population_weak-list)
667                  (:alist $population_weak-alist)))
668         (list (if (eq type :alist)
669                 (map 'list (lambda (c) (cons (car c) (%cdr c))) initial-contents)
670                 (if (listp initial-contents)
671                   (copy-list initial-contents)
672                   (coerce initial-contents 'list)))))
673    (%cons-population list ntype)))
674
675(defun population-type (population)
676  (let ((ntype (population.type (require-type population 'population))))
677    (cond ((eq ntype $population_weak-alist) :alist)
678          ((eq ntype $population_weak-list) :list)
679          (t nil))))
680
681(declaim (inline population-contents (setf population-contents)))
682
683(defun population-contents (population)
684  (population.data (require-type population 'population)))
685
686(defun (setf population-contents) (list population)
687  (setf (population.data (require-type population 'population)) (require-type list 'list)))
688
689
690
691
692(defun get-string-from-user (prompt)
693  (with-terminal-input
694      (format *query-io* "~&~a " prompt)
695    (force-output *query-io*)
696    (clear-input *query-io*)
697    (values (read-line *query-io*))))
698
699
700(defun select-item-from-list (list &key (window-title "Select one of the following")
701                                   (table-print-function #'prin1)
702                                   &allow-other-keys)
703  (block get-answer
704    (with-terminal-input
705      (format *query-io* "~a:~%" window-title)
706      (loop
707         (catch :redisplay
708           (do* ((l list (cdr l))
709                 (i 0 (1+ i))
710                 (item (car l) (car l)))
711                ((null l))
712             (declare (fixnum i))
713             (format *query-io* "~&  ~d: " i)
714             (funcall table-print-function item *query-io*))
715           (loop
716              (fresh-line *query-io*)
717              (let* ((string (get-string-from-user "Selection [number,q,r,?]:"))
718                     (value (ignore-errors
719                              (let* ((*package* *keyword-package*))
720                                (read-from-string string nil)))))
721                (cond ((eq value :q) (throw :cancel t))
722                      ((eq value :r) (throw :redisplay t))
723                      ((eq value :?) 
724                       (format *query-io* "~%Enter the number of the selection, ~%  r to redisplay, ~%  q to cancel or ~%  ? to show this message again."))
725                      ((and (typep value 'unsigned-byte)
726                            (< value (length list)))
727                       (return-from get-answer (list (nth value list))))))))))))
728
729(defvar *choose-file-dialog-hook* nil "for GUIs")
730
731;;; There should ideally be some way to override the UI (such as
732;;; it is ...) here.
733;;; More generally, this either
734;;;   a) shouldn't exist, or
735;;;   b) should do more sanity-checking
736(defun choose-file-dialog (&key file-types (prompt "File name:"))
737  (let* ((hook *choose-file-dialog-hook*))
738    (if hook
739      (funcall hook t prompt file-types)
740      (%choose-file-dialog t prompt file-types))))
741
742(defun choose-new-file-dialog (&key prompt)
743  (let* ((hook *choose-file-dialog-hook*))
744    (if hook
745      (funcall hook nil prompt nil)
746      (%choose-file-dialog nil prompt nil))))
747
748(defun %choose-file-dialog (must-exist prompt file-types)
749  (loop
750      (let* ((namestring (get-string-from-user prompt))
751             (pathname (ignore-errors (pathname namestring)))
752             (exists (and pathname (probe-file pathname))))
753        (when (and (if must-exist exists)
754                   (or (null file-types)
755                       (member (pathname-type pathname)
756                               file-types :test #'equal)))
757          (return pathname))
758        (if (not exists)
759          (format *query-io* "~&~s does not exist." namestring)
760          (format *query-io* "~&Type of ~s is not one of ~{~a~}"
761                  namestring file-types)))))
762
763(defparameter *overwrite-dialog-hook* nil)
764(defun overwrite-dialog (filename prompt)
765  (if *overwrite-dialog-hook*
766    (funcall *overwrite-dialog-hook* filename prompt)
767    t))
768
769;;; Might want to have some other entry for, e.g., the inspector
770;;; and to let it get its hands on the list header returned by
771;;; disassemble-ppc-function.  Maybe disassemble-ppc-function
772;;; should take care of "normalizing" the code-vector ?
773(defun disassemble (thing)
774  "Disassemble the compiled code associated with OBJECT, which can be a
775  function, a lambda expression, or a symbol with a function definition. If
776  it is not already compiled, the compiler is called to produce something to
777  disassemble."
778  (#+ppc-target ppc-xdisassemble
779   #+x86-target x86-xdisassemble
780   (require-type (function-for-disassembly thing) 'compiled-function)))
781
782(defun function-for-disassembly (thing)
783  (let* ((fun thing))
784    ;; CLHS says that DISASSEMBLE should signal a type error if its
785    ;; argument isn't a function designator.  Hard to imagine any
786    ;; code depending on that ...
787    ;;(when (typep fun 'standard-method) (setq fun (%method-function fun)))
788    (when (or (symbolp fun)
789              (and (consp fun) (neq (%car fun) 'lambda)))
790      (setq fun (fboundp thing))
791      (when (and (symbolp thing) (not (functionp fun)))
792        (setq fun (macro-function thing))))
793    (if (typep fun 'compiled-lexical-closure)
794        (setq fun (closure-function fun)))
795    (when (lambda-expression-p fun)
796      (setq fun (compile-named-function fun)))
797    fun))
798
799(%fhave 'df #'disassemble)
800
801(defun string-sans-most-whitespace (string &optional (max-length (length string)))
802  (with-output-to-string (sans-whitespace)
803    (loop
804      for count below max-length
805      for char across string
806      with just-saw-space = nil
807      if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed))
808        do (if just-saw-space
809               (decf count)
810               (write-char #\Space sans-whitespace))
811        and do (setf just-saw-space t)
812      else
813        do (setf just-saw-space nil)
814        and do (write-char char sans-whitespace))))
815
816
817(defparameter *svn-program* "svn")
818
819(defloadvar *use-cygwin-svn*
820    #+windows-target (not (null (getenv "CYGWIN")))
821    #-windows-target nil)
822
823(defun svn-info-component (component)
824  (let* ((component-length (length component)))
825    (let* ((s (make-string-output-stream)))
826      (multiple-value-bind (status exit-code)
827          (external-process-status
828           (run-program *svn-program*  (list "info" (native-translated-namestring "ccl:")) :output s :error :output))
829        (when (and (eq :exited status) (zerop exit-code))
830          (with-input-from-string (output (get-output-stream-string s))
831            (do* ((line (read-line output nil nil) (read-line output nil nil)))
832                 ((null line))
833              (when (and (>= (length line) component-length)
834                         (string= component line :end2 component-length))
835                (return-from svn-info-component
836                  (string-trim " " (subseq line component-length)))))))))
837    nil))
838
839(defun svn-url () (svn-info-component "URL:"))
840(defun svn-repository () (svn-info-component "Repository Root:"))
841
842;;; Try to say something about what tree (trunk, a branch, a release)
843;;; we were built from. If the URL (relative to the repository)
844;;; starts with "branches", return the second component of the
845;;; relative URL, otherwise return the first component.
846(defun svn-tree ()
847  (let* ((repo (svn-repository))
848         (url (svn-url)))
849    (or 
850     (if (and repo url)
851       (let* ((repo-len (length repo)))
852         (when (and (> (length url) repo-len)
853                    (string= repo url :end2 repo-len))
854           ;; Cheat: do pathname parsing here.
855           (let* ((path (pathname (ensure-directory-namestring (subseq url repo-len))))
856                  (dir (cdr (pathname-directory path))))
857             (when (string= "ccl" (car (last dir)))
858               (let* ((base (car dir)))
859                 (unless (or (string= base "release")
860                             (string= base "releases"))
861                   (if (string= base "branches")
862                     (cadr dir)
863                     (car dir))))))))))))
864
865
866(defun svnversion-program ()
867  (or (ignore-errors
868        (native-translated-namestring
869         (merge-pathnames "svnversion" *svn-program*)))
870      "svnversion"))
871       
872                     
873       
874                         
875(defun local-svn-revision ()
876  (let* ((s (make-string-output-stream))
877         (root (native-translated-namestring "ccl:")))
878    (when *use-cygwin-svn*
879      (setq root (cygpath root)))
880    (multiple-value-bind (status exit-code)
881        (external-process-status
882         (run-program (svnversion-program)  (list  (native-translated-namestring "ccl:") (or (svn-url) "")) :output s :error :output))
883      (when (and (eq :exited status) (zerop exit-code))
884        (with-input-from-string (output (get-output-stream-string s))
885          (let* ((line (read-line output nil nil)))
886            (when (and line (parse-integer line :junk-allowed t) )
887              (return-from local-svn-revision line))))))
888    nil))
889
890
891;;; Scan the heap, collecting infomation on the primitive object types
892;;; found.  Report that information.
893
894(defun heap-utilization (&key (stream *debug-io*)
895                              (gc-first t)
896                              (area nil)
897                              (unit nil)
898                              (sort :size)
899                              (classes nil)
900                              (start nil)
901                              (threshold (and classes 0.00005)))
902  "Show statistics about types of objects in the heap.
903   If :GC-FIRST is true (the default), do a full gc before scanning the heap.
904   If :START is non-nil, it should be an object returned by GET-ALLOCATION-SENTINEL, only
905     objects at higher address are scanned (i.e. roughly, only objects allocated after it).
906   :SORT can be one of :COUNT, :LOGICAL-SIZE, or :PHYSICAL-SIZE to sort by count or size.
907   :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes.
908   :AREA can be used to restrict the walk to one area or a list of areas.  Some possible
909   values are :DYNAMIC, :STATIC, :MANAGED-STATIC, :READONLY.  By default, all areas
910   (including stacks) are examined.
911   If :CLASSES is true, classifies by class rather than just typecode"
912  (let ((data (collect-heap-utilization :gc-first gc-first :start start :area area :classes classes)))
913    (report-heap-utilization data :stream stream :unit unit :sort sort :threshold threshold)))
914
915(defun collect-heap-utilization (&key (gc-first t) start area classes)
916  ;; returns list of (type-name count logical-sizes-total physical-sizes-total)
917  (when start
918    (unless (or (null area)
919                (eq (heap-area-code area) area-dynamic)
920                (and (consp area) (every (lambda (a) (eq (heap-area-code a) area-dynamic)) area)))
921      (error "~s ~s and ~s ~s are incompatible" :start start :area area))
922    (setq area area-dynamic))
923  (if classes
924    (collect-heap-utilization-by-class gc-first area start)
925    (collect-heap-utilization-by-typecode gc-first area start)))
926
927(defun collect-heap-utilization-by-typecode (gc-first area start)
928  (let* ((nconses 0)
929         (counts (make-array 257))
930         (sizes (make-array 257))
931         (physical-sizes (make-array 257))
932         (array-size-function (arch::target-array-data-size-function
933                               (backend-target-arch *host-backend*))))
934    (declare (type (simple-vector 257) counts sizes physical-sizes)
935             (fixnum nconses)
936             (dynamic-extent counts sizes physical-sizes))
937    (flet ((collect (thing)
938             (when (or (null start)
939                       (locally (declare (optimize (speed 3) (safety 0))) ;; lie
940                         (%i< start thing)))
941               (if (listp thing)
942                 (incf nconses)
943                 (let* ((typecode (typecode thing))
944                        (logsize (funcall array-size-function typecode (uvsize thing)))
945                        (physize (logandc2 (+ logsize
946                                              #+64-bit-target (+ 8 15)
947                                              #+32-bit-target (+ 4 7))
948                                           #+64-bit-target 15
949                                           #+32-bit-target 7)))
950                   (incf (aref counts typecode))
951                   (incf (aref sizes typecode) logsize)
952                   (incf (aref physical-sizes typecode) physize))))))
953      (declare (dynamic-extent #'collect))
954      (when gc-first (gc))
955      (%map-areas #'collect area))
956    (setf (aref counts 256) nconses)
957    (setf (aref sizes 256) (* nconses target::cons.size))
958    (setf (aref physical-sizes 256) (aref sizes 256))
959    (loop for i from 0 upto 256
960      when (plusp (aref counts i))
961      collect (list (if (eql i 256) 'cons (aref *heap-utilization-vector-type-names* i))
962                    (aref counts i)
963                    (aref sizes i)
964                    (aref physical-sizes i)))))
965
966(defun collect-heap-utilization-by-class (gc-first area start)
967  (let* ((nconses 0)
968         (max-classes (+ 100 (hash-table-count %find-classes%)))
969         (map (make-hash-table :shared nil
970                               :test 'eq
971                               :size max-classes))
972         (inst-counts (make-array max-classes :initial-element 0))
973         (slotv-counts (make-array max-classes :initial-element 0))
974         (inst-sizes (make-array max-classes :initial-element 0))
975         (slotv-sizes (make-array max-classes :initial-element 0))
976         (inst-psizes (make-array max-classes :initial-element 0))
977         (slotv-psizes (make-array max-classes :initial-element 0))
978         (overflow nil)
979         (array-size-function (arch::target-array-data-size-function
980                               (backend-target-arch *host-backend*))))
981    (declare (type simple-vector inst-counts slotv-counts inst-sizes slotv-sizes inst-psizes slotv-psizes))
982    (flet ((collect (thing)
983             (when (or (null start)
984                       (locally (declare (optimize (speed 3) (safety 0))) ;; lie
985                         (%i< start thing)))
986               (if (listp thing)
987                 (incf nconses)
988                 (unless (or (eq thing map)
989                             (eq thing (nhash.vector map))
990                             (eq thing inst-counts)
991                             (eq thing slotv-counts)
992                             (eq thing inst-sizes)
993                             (eq thing slotv-sizes)
994                             (eq thing inst-psizes)
995                             (eq thing slotv-psizes))
996                   (let* ((typecode (typecode thing))
997                          (logsize (funcall array-size-function typecode (uvsize thing)))
998                          (physize (logandc2 (+ logsize
999                                                #+64-bit-target (+ 8 15)
1000                                                #+32-bit-target (+ 4 7))
1001                                             #+64-bit-target 15
1002                                             #+32-bit-target 7))
1003                          (class (class-of (if (eql typecode target::subtag-slot-vector)
1004                                             (uvref thing slot-vector.instance)
1005                                             (if (eql typecode target::subtag-function)
1006                                               (function-vector-to-function thing)
1007                                               thing))))
1008                          (index (or (gethash class map)
1009                                     (let ((count (hash-table-count map)))
1010                                       (if (eql count max-classes)
1011                                         (setq overflow t count (1- max-classes))
1012                                         (setf (gethash class map) count))))))
1013                   
1014                     (if (eql typecode target::subtag-slot-vector)
1015                       (progn
1016                         (incf (aref slotv-counts index))
1017                         (incf (aref slotv-sizes index) logsize)
1018                         (incf (aref slotv-psizes index) physize))
1019                       (progn
1020                         (incf (aref inst-counts index))
1021                         (incf (aref inst-sizes index) logsize)
1022                         (incf (aref inst-psizes index) physize)))))))))
1023      (declare (dynamic-extent #'collect))
1024      (when gc-first (gc))
1025      (%map-areas #'collect area))
1026    (let ((data ()))
1027      (when (plusp nconses)
1028        (push (list 'cons nconses (* nconses target::cons.size) (* nconses target::cons.size)) data))
1029      (maphash (lambda (class index)
1030                 (let* ((icount (aref inst-counts index))
1031                        (scount (aref slotv-counts index))
1032                        (name (if (and overflow (eql index (1- max-classes)))
1033                                "All others"
1034                                (or (%class-proper-name class) class))))
1035                   (declare (fixnum icount) (fixnum scount))
1036                   ;; When printing class names, the package matters.  report-heap-utilization
1037                   ;; uses ~a, so print here.
1038                   (when (plusp icount)
1039                     (push (list (prin1-to-string name)
1040                                 icount (aref inst-sizes index) (aref inst-psizes index)) data))
1041                   (when (plusp scount)
1042                     (push (list (format nil "~s slot vector" name)
1043                                 scount (aref slotv-sizes index) (aref slotv-psizes index)) data))))
1044               map)
1045      data)))
1046
1047(defun collect-heap-ivector-utilization-by-typecode ()
1048  (let* ((counts (make-array 256 :initial-element 0))
1049         (sizes (make-array 256 :initial-element 0))
1050         (physical-sizes (make-array 256 :initial-element 0))
1051         (array-size-function (arch::target-array-data-size-function
1052                               (backend-target-arch *host-backend*)))
1053         (result ()))
1054    (declare (dynamic-extent counts sizes))
1055    (with-lock-grabbed (*heap-ivector-lock*)
1056      (dolist (vector *heap-ivectors*)
1057        (let* ((typecode (typecode vector))
1058               (logsize (funcall array-size-function typecode (uvsize vector)))
1059               (physsize (+ logsize
1060                            ;; header, delta, round up
1061                            #+32-bit-target (+ 4 2 7)
1062                            #+64-bit-target (+ 8 2 15))))
1063          (incf (aref counts typecode))
1064          (incf (aref sizes typecode) logsize)
1065          (incf (aref physical-sizes typecode) physsize))))
1066    (dotimes (i 256 result)
1067      (when (plusp (aref counts i))
1068        (push (list (aref *heap-utilization-vector-type-names* i)
1069                    (aref counts i)
1070                    (aref sizes i)
1071                    (aref physical-sizes i))
1072              result)))))
1073
1074(defun heap-ivector-utilization (&key (stream *debug-io*)
1075                                      (unit nil)
1076                                      (sort :size))
1077  (let* ((data (collect-heap-ivector-utilization-by-typecode)))
1078    (report-heap-utilization data :stream stream :unit unit :sort sort)))
1079 
1080(defvar *heap-utilization-vector-type-names*
1081  (let* ((a (make-array 256)))
1082    #+x8664-target
1083    (dotimes (i 256)
1084      (let* ((fulltag (logand i x8664::fulltagmask))
1085             (names-vector
1086              (cond ((= fulltag x8664::fulltag-nodeheader-0)
1087                     *nodeheader-0-types*)
1088                    ((= fulltag x8664::fulltag-nodeheader-1)
1089                     *nodeheader-1-types*)
1090                    ((= fulltag x8664::fulltag-immheader-0)
1091                     *immheader-0-types*)
1092                    ((= fulltag x8664::fulltag-immheader-1)
1093                     *immheader-1-types*)
1094                    ((= fulltag x8664::fulltag-immheader-2)
1095                     *immheader-2-types*)))
1096             (name (if names-vector
1097                     (aref names-vector (ash i -4)))))
1098        ;; Special-case a few things ...
1099        (if (eq name 'symbol-vector)
1100          (setq name 'symbol)
1101          (if (eq name 'function-vector)
1102            (setq name 'function)))
1103        (setf (aref a i) name)))
1104    #+ppc64-target
1105    (dotimes (i 256)
1106      (let* ((lowtag (logand i ppc64::lowtagmask)))
1107        (setf (%svref a i)
1108              (cond ((= lowtag ppc64::lowtag-immheader)
1109                     (%svref *immheader-types* (ash i -2)))
1110                    ((= lowtag ppc64::lowtag-nodeheader)
1111                     (%svref *nodeheader-types* (ash i -2)))))))
1112    #+(or ppc32-target x8632-target)
1113    (dotimes (i 256)
1114      (let* ((fulltag (logand i target::fulltagmask)))
1115        (setf (%svref a i)
1116              (cond ((= fulltag target::fulltag-immheader)
1117                     (%svref *immheader-types* (ash i -3)))
1118                    ((= fulltag target::fulltag-nodeheader)
1119                     (%svref *nodeheader-types* (ash i -3)))))))
1120    a))
1121
1122 
1123(defun report-heap-utilization (data &key stream unit sort threshold)
1124  (check-type threshold (or null (real 0 1)))
1125  (let* ((div (ecase unit
1126                ((nil) 1)
1127                (:kb 1024.0d0)
1128                (:mb (* 1024.0d0 1024.0d0))
1129                (:gb (* 1024.0d0 1024.0d0 1024.0d0))))
1130         (sort-key (ecase sort
1131                     (:count #'cadr)
1132                     (:logical-size #'caddr)
1133                     ((:physical-size :size) #'cadddr)
1134                     ((:name nil) nil)))
1135         (total-count 0)
1136         (total-lsize 0)
1137         (total-psize 0)
1138         (max-name 0)
1139         (others (list "All others" 0 0 0)))
1140
1141    (when (hash-table-p data)
1142      (setq data
1143            (let ((alist nil))
1144              (maphash (lambda (type measures) (push (cons type measures) alist)) data)
1145              alist)))
1146
1147    (flet ((type-string (name)
1148             (if (stringp name)
1149               name
1150               (if (symbolp name)
1151                 (symbol-name name)
1152                 (princ-to-string name)))))
1153      (loop for (nil count lsize psize) in data
1154            do (incf total-count count)
1155            do (incf total-lsize lsize)
1156            do (incf total-psize psize))
1157
1158      (when (and data threshold)
1159        (setq data (sort data #'< :key #'cadddr))
1160        (loop while (< (/ (cadddr (car data)) total-psize) threshold)
1161              do (destructuring-bind (type count lsize psize) (pop data)
1162                   (declare (ignore type))
1163                   (incf (cadr others) count)
1164                   (incf (caddr others) lsize)
1165                   (incf (cadddr others) psize))))
1166
1167      (setq data
1168            (if sort-key
1169              (sort data #'> :key sort-key)
1170              (sort data #'string-lessp :key #'(lambda (s) (type-string (car s))))))
1171
1172      (when (> (cadr others) 0)
1173        (setq data (nconc data (list others))))
1174
1175      (setq max-name (loop for (name) in data maximize (length (type-string name))))
1176
1177      (format stream "~&Object type~vtCount     Logical size   Physical size   % of Heap~%~vt ~a~vt ~2:*~a"
1178              (+ max-name 7)
1179              (+ max-name 15)
1180              (ecase unit
1181                ((nil) "  (in bytes)")
1182                (:kb   "(in kilobytes)")
1183                (:mb   "(in megabytes)")
1184                (:gb   "(in gigabytes)"))
1185              (+ max-name 31))
1186      (loop for (type count logsize physsize) in data
1187            do (if unit
1188                 (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%"
1189                         (type-string type)
1190                         (1+ max-name)
1191                         count
1192                         (/ logsize div)
1193                         (/ physsize div)
1194                         (* 100.0 (/ physsize total-psize)))
1195                 (format stream "~&~a~vt~11d~16d~16d~11,2f%"
1196                         (type-string type)
1197                         (1+ max-name)
1198                         count
1199                         logsize
1200                         physsize
1201                         (* 100.0 (/ physsize total-psize)))))
1202      (if unit
1203        (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%"
1204                "Total"
1205                (1+ max-name)
1206                total-count
1207                (/ total-lsize div)
1208                (/ total-psize div)
1209                100.0d0)
1210        (format stream "~&~a~vt~11d~16d~16d~11,2f%"
1211                "Total"
1212                (1+ max-name)
1213                total-count
1214                total-lsize
1215                total-psize
1216                100.0d0))))
1217  (values))
1218
1219
1220
1221(defun static-cons (car-value cdr-value)
1222  "Allocates a cons cell that doesn't move on garbage collection,
1223   and thus doesn't trigger re-hashing when used as a key in a hash
1224   table.  Usage is equivalent to regular CONS."
1225  (loop
1226    (let ((cell (without-interrupts (%atomic-pop-static-cons))))
1227      (if cell
1228        (progn
1229          (setf (car cell) car-value)
1230          (setf (cdr cell) cdr-value)
1231          (return cell))
1232        (progn
1233          (%ensure-static-conses))))))
1234
1235(defun free-static-conses ()
1236  (%get-kernel-global free-static-conses))
1237
1238(defun reserved-static-conses ()
1239  (%fixnum-ref-natural (%get-kernel-global static-cons-area) target::area.ndnodes))
1240       
1241
1242(defparameter *weak-gc-method-names*
1243  '((:traditional . 0)
1244    (:non-circular . 1)))
1245
1246
1247(defun weak-gc-method ()
1248  (or (car (rassoc (%get-kernel-global 'weak-gc-method)
1249                   *weak-gc-method-names*))
1250      :traditional))
1251
1252
1253(defun (setf weak-gc-method) (name)
1254  (setf (%get-kernel-global 'weak-gc-method)
1255        (or (cdr (assoc name *weak-gc-method-names*))
1256            0))
1257  name)
1258
1259(defun %lock-whostate-string (string lock)
1260  (with-standard-io-syntax
1261      (format nil "~a for ~a ~@[~a ~]@ #x~x"
1262              string
1263              (%svref lock target::lock.kind-cell)
1264              (lock-name lock)
1265              (%ptr-to-int (%svref lock target::lock._value-cell)))))
1266
1267(defun all-watched-objects ()
1268  (let (result)
1269    (with-other-threads-suspended
1270      (%map-areas #'(lambda (x) (push x result)) area-watched))
1271    result))
1272
1273(defun primitive-watch (thing)
1274  (require-type thing '(or cons (satisfies uvectorp)))
1275  (%watch thing))
1276
1277(defun watch (&optional thing)
1278  (cond ((null thing)
1279         (all-watched-objects))
1280        ((arrayp thing)
1281         (primitive-watch (array-data-and-offset thing)))
1282        ((hash-table-p thing)
1283         (primitive-watch (nhash.vector thing)))
1284        ((standard-instance-p thing)
1285         (primitive-watch (instance-slots thing)))
1286        (t
1287         (primitive-watch thing))))
1288
1289(defun unwatch (thing)
1290  (with-other-threads-suspended
1291    (%map-areas #'(lambda (x)
1292                    (when (eq x thing)
1293                      (let ((new (if (uvectorp thing)
1294                                   (%alloc-misc (uvsize thing)
1295                                                (typecode thing))
1296                                   (cons nil nil))))
1297                        (return-from unwatch (%unwatch thing new)))))
1298                area-watched)))
1299
1300(defun %parse-unsigned-integer (vector start end)
1301  (declare ((simple-array (unsigned-byte 8) (*)) vector)
1302           (fixnum start end)
1303           (optimize (speed 3) (safety 0)))
1304  (let* ((count (- end start))
1305         (msb 0))
1306    (declare (fixnum count) ((unsigned-byte 8) msb))
1307    (or
1308     (do* ((i start (1+ i)))
1309          ((>= i end) 0)
1310       (declare (fixnum i))
1311       (let* ((b (aref vector i)))
1312         (declare ((unsigned-byte 8) b))
1313         (cond ((zerop b) (incf start) (decf count))
1314               (t (setq msb b) (return)))))
1315     (cond
1316       ((or (< count #+64-bit-target 8 #+32-bit-target 4)
1317            (and (= count #+64-bit-target 8 #+32-bit-target 4)
1318                 (< msb #+64-bit-target 16 #+32-bit-target 32)))
1319        ;; Result will be a fixnum.
1320        (do* ((result 0)
1321              (shift 0 (+ shift 8))
1322              (i (1- end) (1- i)))
1323             ((< i start) result)
1324          (declare (fixnum result shift i))
1325          (setq result (logior result (the fixnum (%ilsl shift (aref vector i)))))))
1326       (t
1327        ;; Result will be a bignum.  If COUNT is a multiple of 4
1328        ;; and the most significant bit is set, need to add an
1329        ;; extra word of zero-extension.
1330        (let* ((result (allocate-typed-vector :bignum
1331                                              (if (and (logbitp 7 msb)
1332                                                       (zerop (the fixnum (logand count 3))))
1333                                                (the fixnum (1+ (the fixnum (ash count -2))))
1334                                                (the fixnum (ash (the fixnum (+ count 3)) -2))))))
1335          (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie
1336          (dotimes (i count result)
1337            (decf end)
1338            (setf (aref result
1339                        #+little-endian-target i
1340                        #+big-endian-target (the fixnum (logxor i 3)))
1341                  (aref vector end)))))))))
1342
1343 
1344;;; Octets between START and END encode an unsigned integer in big-endian
1345;;; byte order.
1346(defun parse-unsigned-integer (vector &optional (start 0) end)
1347  (setq end (check-sequence-bounds vector start end))
1348  (locally (declare (fixnum start end))
1349      (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
1350        (multiple-value-bind (data offset) (array-data-and-offset vector)
1351          (declare (fixnum offset))
1352          (unless (typep data '(simple-array (unsigned-byte 8) (*)))
1353            (report-bad-arg vector '(vector (unsigned-byte 8))))
1354          (incf start offset)
1355          (incf end offset)
1356          (setq vector data)))
1357      (%parse-unsigned-integer vector start end)))
1358
1359(defun %parse-signed-integer (vector start end)
1360  (declare ((simple-array (unsigned-byte 8) (*)) vector)
1361           (fixnum start end)
1362           (optimize (speed 3) (safety 0)))
1363  (let* ((count (- end start)))
1364    (declare (fixnum count))
1365    (if (zerop count)
1366      0
1367      (let* ((sign-byte (aref vector start)))
1368        (declare (fixnum sign-byte))
1369        (if (< sign-byte 128)
1370          (%parse-unsigned-integer vector start end)
1371          (progn
1372            (decf sign-byte 256)
1373            (or
1374             (do* ()
1375                  ((= count 1) sign-byte)
1376               (unless (= sign-byte -1)
1377                 (return))
1378               (let* ((next (1+ start))
1379                      (nextb (aref vector next)))
1380                 (declare (fixnum next nextb))
1381                 (if (not (logbitp 7 nextb))
1382                   (return))
1383                 (setq sign-byte (- nextb 256)
1384                       start next
1385                       count (1- count))))
1386             (cond ((or (< count #+64-bit-target 8 #+32-bit-target 4)
1387                        (and (= count #+64-bit-target 8 #+32-bit-target 4)
1388                             (>= sign-byte
1389                                 #+64-bit-target -16
1390                                 #+32-bit-target -32)))
1391                    ;; Result will be a fixnum
1392                    (do* ((result 0)
1393                          (shift 0 (+ shift 8))
1394                          (i (1- end) (1- i)))
1395                         ((= i start) (logior result (the fixnum (%ilsl shift sign-byte))))
1396                      (declare (fixnum result shift i))
1397                      (setq result (logior result (the fixnum (%ilsl shift (aref vector i)))))))
1398                   (t
1399                    (let* ((result (allocate-typed-vector :bignum (the fixnum (ash (the fixnum (+ count 3)) -2)))))
1400          (declare ((simple-array (unsigned-byte 8) (*)) result)) ; lie
1401          (dotimes (i count (do* ((i count (1+ i)))
1402                                 ((= 0 (the fixnum (logand i 3)))
1403                                  result)
1404                              (declare (fixnum i))
1405                              (setf (aref result
1406                                          #+little-endian-target i
1407                                          #+big-endian-target (the fixnum (logxor i 3))) #xff)))
1408            (decf end)
1409            (setf (aref result
1410                        #+little-endian-target i
1411                        #+big-endian-target (the fixnum (logxor i 3)))
1412                  (aref vector end)))))))))))))
1413
1414(defun parse-signed-integer (vector &optional (start 0) end)
1415  (setq end (check-sequence-bounds vector start end))
1416  (locally (declare (fixnum start end))
1417    (unless (typep vector '(simple-array (unsigned-byte 8) (*)))
1418      (multiple-value-bind (data offset) (array-data-and-offset vector)
1419        (declare (fixnum offset))
1420        (unless (typep data '(simple-array (unsigned-byte 8) (*)))
1421          (report-bad-arg vector '(vector (unsigned-byte 8))))
1422        (incf start offset)
1423        (incf end offset)
1424        (setq vector data)))
1425    (%parse-signed-integer vector start end)))
Note: See TracBrowser for help on using the repository browser.