source: branches/working-0711/ccl/lib/misc.lisp @ 13547

Last change on this file since 13547 was 13547, checked in by gz, 9 years ago

From trunk: heap-ivector-utilization (r13533)

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