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

Last change on this file since 10641 was 10641, checked in by gb, 12 years ago

Enviromental inquiry changes for Windows.
Handle TIME reporting differently, to account for Windows differences.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 35.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (eval compile)
20  (require 'defstruct-macros))
21
22(defun short-site-name  ()
23  "Return a string with the abbreviated site name, or NIL if not known."
24  (or *short-site-name* "unspecified"))
25
26(defun long-site-name   ()
27  "Return a string with the long form of the site name, or NIL if not known."
28  (or *long-site-name* "unspecified"))
29
30(defun machine-instance ()
31  "Return a string giving the name of the local machine."
32  #-windows-target (%uname 1)
33  #+windows-target
34  (rlet ((nsize #>DWORD 0))
35    (if (eql 0 (#_GetComputerNameExW #$ComputerNameDnsFullyQualified
36                                     +null-ptr+
37                                     nsize))
38      (%stack-block ((buf (* 2 (pref nsize #>DWORD))))
39        (#_GetComputerNameExW #$ComputerNameDnsFullyQualified
40                              buf
41                              nsize)
42        (%get-native-utf-16-cstring buf))
43      "localhost"))
44  )
45
46
47(defun machine-type ()
48  "Returns a string describing the type of the local machine."
49  #-windows-target (%uname 4)
50  #+windows-target
51  (rlet ((info #>SYSTEM_INFO))
52    (#_GetSystemInfo info)
53    (case (pref info #>SYSTEM_INFO.nil.nil.wProcessorArchitecture)
54      (#.#$PROCESSOR_ARCHITECTURE_AMD64 "x64")
55      (#.#$PROCESSOR_ARCHITECTURE_INTEL "x86")
56      (t "unknown")))
57  )
58
59
60
61(defloadvar *machine-version* nil)
62
63(defun machine-version ()
64  "Return a string describing the version of the computer hardware we
65are running on, or NIL if we can't find any useful information."
66  (or *machine-version*
67      (setq *machine-version*
68            #+darwin-target
69            (block darwin-machine-version
70              (%stack-block ((mib 8))
71                (setf (%get-long mib 0) #$CTL_HW
72                      (%get-long mib 4) #$HW_MODEL)
73                (%stack-block ((res 256)
74                               (reslen target::node-size))
75                  (setf (%get-byte res 0) 0
76                        (%get-natural reslen 0) 256)
77                  (if (zerop (#_sysctl mib 2 res reslen (%null-ptr) 0))
78                    (return-from darwin-machine-version (%get-cstring res))))))
79            #+linux-target
80            (with-open-file (f "/proc/cpuinfo" :if-does-not-exist nil)
81              (when f
82                (flet ((cpu-info-match (target line)
83                         (let* ((targetlen (length target))
84                                (linelen (length line)))
85                           (if (and (> linelen targetlen)
86                                    (string= target line
87                                             :end2 targetlen))
88                           (let* ((colonpos (position #\: line)))
89                             (when colonpos
90                               (string-trim " "
91                                            (subseq line (1+ colonpos)))))))))
92                  (do* ((line (read-line f nil nil)
93                              (read-line f nil nil))
94                        (target #+ppc-target "machine"
95                                #+x86-target "model name"))
96                       ((null line))
97                    (let* ((matched (cpu-info-match target line)))
98                      (when matched (return matched)))))))
99            #+freebsd-target
100            (%stack-block ((ret 512)
101                           (mib (* (record-length :uint))))
102              (setf (%get-unsigned-long mib 0)
103                    #$CTL_HW
104                    (%get-unsigned-long mib (record-length :uint))
105                    #$HW_MODEL)
106              (rlet ((oldsize :uint 512))
107                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
108                  (%get-cstring ret)
109                  1)))
110            #+solaris-target
111            (rlet ((info :processor_info_t))
112              (do* ((i 0 (1+ i)))
113                   ((and (= 0 (#_processor_info i info))
114                         (= (pref info :processor_info_t.pi_state)
115                            #$P_ONLINE))
116                    (%get-cstring (pref info :processor_info_t.pi_processor_type)))))
117            #+windows-target
118            (getenv "PROCESSOR_IDENTIFIER")
119            )))
120
121
122(defun software-type ()
123  "Return a string describing the supporting software."
124  #-windows-target (%uname 0)
125  #+windows-target "Microsoft Windows")
126
127
128(defun software-version ()
129  "Return a string describing version of the supporting software, or NIL
130   if not available."
131  #-windows-target (%uname 2)
132  #+windows-target
133  (rletZ ((info #>OSVERSIONINFOEX))
134    (setf (pref info #>OSVERSIONINFOEX.dwOSVersionInfoSize)
135          (record-length #>OSVERSIONINFOEX))
136    (#_GetVersionExA info)
137    (format nil "~d.~d Build ~d (~a)"
138            (pref info #>OSVERSIONINFOEX.dwMajorVersion)
139            (pref info #>OSVERSIONINFOEX.dwMinorVersion)
140            (pref info #>OSVERSIONINFOEX.dwBuildNumber)
141            (if (eql (pref info #>OSVERSIONINFOEX.wProductType)
142                     #$VER_NT_WORKSTATION)
143              "Workstation"
144              "Server")))
145  )
146
147
148
149
150
151
152
153;;; Yawn.
154
155
156
157(defmethod documentation (thing doc-id)
158  (%get-documentation thing doc-id))
159
160(defun set-documentation (thing doc-id new)
161  (setf (documentation thing doc-id) new))
162
163(defmethod (setf documentation) (new thing doc-id)
164  (%put-documentation thing doc-id new))
165
166
167(defmethod documentation ((symbol symbol) (doc-type (eql 'function)))
168  (let* ((def (fboundp symbol)))        ; FBOUNDP returns info about definition
169    (when def
170      (%get-documentation def t))))
171
172(defmethod (setf documentation) ((new t)
173                                 (symbol symbol)
174                                 (doc-type (eql 'function)))
175  (let* ((def (fboundp symbol)))        ; FBOUNDP returns info about definition
176    (when def
177      (%put-documentation def
178                          t
179                          new))
180    new))
181
182(defmethod documentation ((symbol symbol) (doc-type (eql 'setf)))
183  (call-next-method))
184
185(defmethod (setf documentation) ((new t)
186                                 (symbol symbol)
187                                 (doc-type (eql 'setf)))
188  (call-next-method))
189
190
191(defmethod documentation ((symbol symbol) (doc-type (eql 'variable)))
192  (call-next-method))
193
194(defmethod (setf documentation) ((new t)
195                                 (symbol symbol)
196                                 (doc-type (eql 'variable)))
197  (call-next-method))
198
199(defmethod documentation ((symbol symbol) (doc-type (eql 'compiler-macro)))
200  (call-next-method))
201
202(defmethod (setf documentation) ((new t)
203                                 (symbol symbol)
204                                 (doc-type (eql 'compiler-macro)))
205  (call-next-method))
206
207(defmethod documentation ((symbol symbol) (doc-type (eql 'type)))
208  (let* ((class (find-class symbol nil)))
209    (if class
210      (documentation class doc-type)
211      (call-next-method))))
212
213(defmethod (setf documentation) (new (symbol symbol) (doc-type (eql 'type)))
214  (let* ((class (find-class symbol nil)))
215    (if class
216      (setf (documentation class doc-type) new)
217      (call-next-method))))
218
219(defmethod documentation ((symbol symbol) (doc-type (eql 'method-combination)))
220  (let* ((mci (method-combination-info symbol)))
221    (if mci
222      (documentation mci doc-type))))
223
224(defmethod (setf documentation) ((new t)
225                                 (symbol symbol)
226                                 (doc-type (eql 'method-combination)))
227  (let* ((mci (method-combination-info symbol)))
228    (if mci
229      (setf (documentation mci doc-type) new))))
230
231
232(defmethod documentation ((symbol symbol) (doc-type (eql 'structure)))
233  (let* ((class (find-class symbol nil)))
234    (if (typep class 'structure-class)
235      (documentation class 'type)
236      (call-next-method))))
237
238(defmethod (setf documentation) ((new t)
239                                 (symbol symbol)
240                                 (doc-type (eql 'structure)))
241  (let* ((class (find-class symbol nil)))
242    (if (typep class 'structure-class)
243      (setf (documentation class 'type) new)
244      (call-next-method))))
245
246(defmethod documentation ((p package) (doc-type (eql 't)))
247  (call-next-method))
248
249(defmethod (setf documentation) ((new t) (p package) (doc-type (eql 't)))
250  (call-next-method))
251
252(defmethod documentation ((f function) (doc-type (eql 't)))
253  (call-next-method))
254
255(defmethod (setf documentation) ((new t) (f function) (doc-type (eql 't)))
256  (call-next-method))
257
258(defmethod documentation ((f function) (doc-type (eql 'function)))
259  (documentation f t))
260
261(defmethod (setf documentation) ((new t)
262                                 (f function)
263                                 (doc-type (eql 'function)))
264  (setf (documentation f t) new))
265
266(defmethod documentation ((l cons) (doc-type (eql 'function)))
267  (let* ((name (setf-function-spec-name l)))
268    (if name
269      (documentation name doc-type)
270      (%get-documentation l doc-type))))
271
272(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'function)))
273  (let* ((name  (setf-function-spec-name l)))
274    (if name
275      (setf (documentation name doc-type) new)
276      (%put-documentation l doc-type new))))
277
278
279(defmethod documentation ((l cons) (doc-type (eql 'compiler-macro)))
280  (let* ((name (setf-function-spec-name l)))
281    (if name
282      (documentation name doc-type)
283      (%get-documentation l doc-type))))
284
285(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'compiler-macr0)))
286  (let* ((name (setf-function-spec-name l)))
287    (if name
288      (setf (documentation name doc-type) new)
289      (%put-documentation l doc-type new))))
290
291
292(defmethod documentation ((m method-combination)
293                          (doc-type (eql 'method-combination)))
294  (call-next-method))
295
296(defmethod (setf documentation) ((new t)
297                                 (m method-combination)
298                                 (doc-type (eql 'method-combination)))
299  (call-next-method))
300
301(defmethod documentation ((m method-combination)
302                          (doc-type (eql t)))
303  (documentation m 'method-combination))
304
305(defmethod (setf documentation) ((new t)
306                                 (m method-combination)
307                                 (doc-type (eql t)))
308  (setf (documentation m 'method-combination) new))
309
310(defmethod documentation ((m standard-method)
311                          (doc-type (eql t)))
312  (call-next-method))
313
314(defmethod (setf documentation) ((new t)
315                                 (m standard-method)
316                                 (doc-type (eql t)))
317  (call-next-method))
318
319(defmethod documentation ((c standard-class) (doc-type (eql 'type)))
320  (call-next-method))
321
322(defmethod (setf documentation) ((new t)
323                                 (c standard-class)
324                                 (doc-type (eql 'type)))
325  (call-next-method))
326
327(defmethod documentation ((c standard-class) (doc-type (eql 't)))
328  (documentation c 'type))
329
330(defmethod (setf documentation) ((new t)
331                                 (c standard-class)
332                                 (doc-type (eql 't)))
333  (setf (documentation c 'type) new))
334
335(defmethod documentation ((c structure-class) (doc-type (eql 'type)))
336  (call-next-method))
337
338(defmethod (setf documentation) ((new t)
339                                 (c structure-class)
340                                 (doc-type (eql 'type)))
341  (call-next-method))
342
343(defmethod documentation ((c structure-class) (doc-type (eql 't)))
344  (documentation c 'type))
345
346(defmethod (setf documentation) ((new t)
347                                 (c structure-class)
348                                 (doc-type (eql 't)))
349  (setf (documentation c 'type) new))
350
351;;; This is now deprecated; things which call it should stop doing so.
352(defun set-documentation (symbol doc-type string)
353  (setf (documentation symbol doc-type) string))
354
355(defun set-function-info (symbol info)
356  (let* ((doc-string (if (consp info) (car info) info)))
357    (if (and *save-doc-strings* (stringp doc-string))
358      (set-documentation  symbol 'function doc-string)))
359  (let* ((cons (assq symbol *nx-globally-inline*))
360         (lambda-expression (if (consp info) (cdr info))))
361    (if (and (proclaimed-inline-p symbol)
362             (not (compiler-special-form-p symbol))
363             (lambda-expression-p lambda-expression)
364             (let* ((lambda-list (cadr lambda-expression)))
365               (and (not (memq '&lap lambda-list))
366                    (not (memq '&method lambda-list))
367                    (not (memq '&lexpr lambda-list)))))
368      (if cons 
369        (%rplacd cons lambda-expression)
370        (push (cons symbol lambda-expression) *nx-globally-inline*))
371      (if cons (setq *nx-globally-inline* (delete cons *nx-globally-inline*)))))
372  symbol)
373
374
375(setf (documentation 'if 'function)
376      "If Predicate Then [Else]
377  If Predicate evaluates to non-null, evaluate Then and returns its values,
378  otherwise evaluate Else and return its values. Else defaults to NIL.")
379
380(setf (documentation 'progn 'function)
381      "progn form*
382  Evaluates each FORM and returns the value(s) of the last FORM.")
383
384(defmethod documentation ((thing character-encoding) (doc-type (eql t)))
385  (character-encoding-documentation thing))
386
387(defmethod (setf documentation) (new (thing character-encoding) (doc-type (eql t)))
388  (check-type new (or null string))
389  (setf (character-encoding-documentation thing) new))
390
391(defmethod documentation ((thing symbol) (doc-type (eql 'character-encoding)))
392  (let* ((encoding (lookup-character-encoding (intern (string thing) :keyword))))
393    (when encoding
394      (documentation encoding t))))
395
396                                 
397
398
399#|
400(setf (documentation 'car 'variable) "Preferred brand of automobile")
401(documentation 'car 'variable)
402(setf (documentation 'foo 'structure) "the structure is grand.")
403(documentation 'foo 'structure)
404(setf (documentation 'foo 'variable) "the metasyntactic remarker")
405(documentation 'foo 'variable)
406(setf (documentation 'foo 'obscure) "no one really knows what it means")
407(documentation 'foo 'obscure)
408(setf (documentation 'foo 'structure) "the structure is solid")
409(documentation 'foo 'function)
410||#
411
412;;
413
414
415(defun %page-fault-info ()
416  #-(or darwin-target windows-target)
417  (rlet ((usage :rusage))
418    (%%rusage usage)
419    (values (pref usage :rusage.ru_minflt)
420            (pref usage :rusage.ru_majflt)
421            (pref usage :rusage.ru_nswap)))
422  #+darwin-target
423  (rlet ((count #>mach_msg_type_number_t #$TASK_EVENTS_INFO_COUNT)
424         (info #>task_events_info))
425    (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count)
426    (values (pref info #>task_events_info.cow_faults)
427            (pref info #>task_events_info.faults)
428            (pref info #>task_events_info.pageins)))
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(defun get-string-from-user (prompt)
664  (with-terminal-input
665      (format *query-io* "~&~a " prompt)
666    (force-output *query-io*)
667    (clear-input *query-io*)
668    (values (read-line *query-io*))))
669
670
671(defun select-item-from-list (list &key (window-title "Select one of the following")
672                                   (table-print-function #'prin1)
673                                   &allow-other-keys)
674  (block get-answer
675    (with-terminal-input
676      (format *query-io* "~a:~%" window-title)
677      (loop
678         (catch :redisplay
679           (do* ((l list (cdr l))
680                 (i 0 (1+ i))
681                 (item (car l) (car l)))
682                ((null l))
683             (declare (fixnum i))
684             (format *query-io* "~&  ~d: " i)
685             (funcall table-print-function item *query-io*))
686           (loop
687              (fresh-line *query-io*)
688              (let* ((string (get-string-from-user "Selection [number,q,r,?]:"))
689                     (value (ignore-errors
690                              (let* ((*package* *keyword-package*))
691                                (read-from-string string nil)))))
692                (cond ((eq value :q) (throw :cancel t))
693                      ((eq value :r) (throw :redisplay t))
694                      ((eq value :?) 
695                       (format *query-io* "~%Enter the number of the selection, ~%  r to redisplay, ~%  q to cancel or ~%  ? to show this message again."))
696                      ((and (typep value 'unsigned-byte)
697                            (< value (length list)))
698                       (return-from get-answer (list (nth value list))))))))))))
699
700;;; There should ideally be some way to override the UI (such as
701;;; it is ...) here.
702;;; More generally, this either
703;;;   a) shouldn't exist, or
704;;;   b) should do more sanity-checking
705(defun choose-file-dialog (&key file-types (prompt "File name:"))
706  (%choose-file-dialog t prompt file-types))
707
708(defun choose-new-file-dialog (&key prompt)
709  (%choose-file-dialog nil prompt nil))
710
711(defun %choose-file-dialog (must-exist prompt file-types)
712  (loop
713      (let* ((namestring (get-string-from-user prompt))
714             (pathname (ignore-errors (pathname namestring)))
715             (exists (and pathname (probe-file pathname))))
716        (when (and (if must-exist exists)
717                   (or (null file-types)
718                       (member (pathname-type pathname)
719                               file-types :test #'equal)))
720          (return pathname))
721        (if (not exists)
722          (format *query-io* "~&~s does not exist." namestring)
723          (format *query-io* "~&Type of ~s is not one of ~{~a~}"
724                  namestring file-types)))))
725
726(defparameter *overwrite-dialog-hook* nil)
727(defun overwrite-dialog (filename prompt)
728  (if *overwrite-dialog-hook*
729    (funcall *overwrite-dialog-hook* filename prompt)
730    t))
731
732;;; Might want to have some other entry for, e.g., the inspector
733;;; and to let it get its hands on the list header returned by
734;;; disassemble-ppc-function.  Maybe disassemble-ppc-function
735;;; should take care of "normalizing" the code-vector ?
736(defun disassemble (thing)
737  "Disassemble the compiled code associated with OBJECT, which can be a
738  function, a lambda expression, or a symbol with a function definition. If
739  it is not already compiled, the compiler is called to produce something to
740  disassemble."
741  (#+ppc-target ppc-xdisassemble
742   #+x8632-target x8632-xdisassemble
743   #+x8664-target x8664-xdisassemble
744   (require-type (function-for-disassembly thing) 'compiled-function)))
745
746(defun function-for-disassembly (thing)
747  (let* ((fun thing))
748    ;; CLHS says that DISASSEMBLE should signal a type error if its
749    ;; argument isn't a function designator.  Hard to imagine any
750    ;; code depending on that ...
751    ;;(when (typep fun 'standard-method) (setq fun (%method-function fun)))
752    (when (or (symbolp fun)
753              (and (consp fun) (neq (%car fun) 'lambda)))
754      (setq fun (fboundp thing))
755      (when (and (symbolp thing) (not (functionp fun)))
756        (setq fun (macro-function thing))))
757    (if (typep fun 'compiled-lexical-closure)
758        (setq fun (closure-function fun)))
759    (when (lambda-expression-p fun)
760      (setq fun (compile-named-function fun)))
761    fun))
762
763(%fhave 'df #'disassemble)
764
765(defloadvar *use-cygwin-svn*
766    #+windows-target (not (null (getenv "CYGWIN")))
767    #-windows-target nil)
768
769(defun svn-info-component (component)
770  (let* ((component-length (length component)))
771  (with-output-to-string (s)
772    (multiple-value-bind (status exit-code)
773        (external-process-status
774         (run-program "svn"  (list "info" (native-translated-namestring "ccl:")):output s))
775      (when (and (eq :exited status) (zerop exit-code))
776        (with-input-from-string (output (get-output-stream-string s))
777            (do* ((line (read-line output nil nil) (read-line output nil nil)))
778                 ((null line))
779              (when (and (>= (length line) component-length)
780                         (string= component line :end2 component-length))
781                (return-from svn-info-component
782                  (string-trim " " (subseq line component-length)))))))))))
783
784(defun svn-url () (svn-info-component "URL:"))
785(defun svn-repository () (svn-info-component "Repository Root:"))
786
787;;; Try to say something about what tree (trunk, a branch, a release)
788;;; we were built from. If the URL (relative to the repository)
789;;; starts with "branches", return the second component of the
790;;; relative URL, otherwise return the first component.
791(defun svn-tree ()
792  (let* ((repo (svn-repository))
793         (url (svn-url)))
794    (or 
795     (if (and repo url)
796       (let* ((repo-len (length repo)))
797         (when (and (> (length url) repo-len)
798                    (string= repo url :end2 repo-len))
799           ;; Cheat: do pathname parsing here.
800           (let* ((path (pathname (ensure-directory-namestring (subseq url repo-len))))
801                  (dir (cdr (pathname-directory path))))
802             (when (string= "ccl" (car (last dir)))
803               (let* ((base (car dir)))
804                 (unless (or (string= base "release")
805                             (string= base "releases"))
806                   (if (string= base "branches")
807                     (cadr dir)
808                     (car dir))))))))))))
809
810
811
812       
813                         
814(defun local-svn-revision ()
815  (or
816   ;; svn2cvs uses a .svnrev file to sync CVS and SVN; if present,
817   ;; it contains the svn revision in decimal.
818   (with-open-file (f "ccl:\\.svnrev" :direction :input :if-does-not-exist nil)
819     (when f (read f)))
820   (with-output-to-string (s)
821     (let* ((root (native-translated-namestring "ccl:")))
822       (when *use-cygwin-svn*
823         (setq root (cygpath root)))
824       (multiple-value-bind (status exit-code)
825           (external-process-status
826            (run-program "svnversion"  (list  (native-translated-namestring "ccl:") (or (svn-url) "")):output s))
827         (when (and (eq :exited status) (zerop exit-code))
828           (with-input-from-string (output (get-output-stream-string s))
829             (let* ((line (read-line output nil nil)))
830               (when (and line (parse-integer line :junk-allowed t) )
831                 (return-from local-svn-revision line))))))))))
832
833
834;;; Scan the heap, collecting infomation on the primitive object types
835;;; found.  Report that information.
836
837(defun heap-utilization (&key (stream *debug-io*)
838                              (gc-first t))
839  (let* ((nconses 0)
840         (nvectors (make-array 256))
841         (vector-sizes (make-array 256))
842         (array-size-function (arch::target-array-data-size-function
843                               (backend-target-arch *host-backend*))))
844    (declare (type (simple-vector 256) nvectors vector-sizes)
845             (dynamic-extent nvectors vector-sizes))
846    (when gc-first (gc))
847    (%map-areas (lambda (thing)
848                  (if (consp thing)
849                    (incf nconses)
850                    (let* ((typecode (typecode thing)))
851                      (incf (aref nvectors typecode))
852                      (incf (aref vector-sizes typecode)
853                            (funcall array-size-function typecode (uvsize thing)))))))
854    (report-heap-utilization stream nconses nvectors vector-sizes)
855    (values)))
856
857(defvar *heap-utilization-vector-type-names*
858  (let* ((a (make-array 256)))
859    #+x8664-target
860    (dotimes (i 256)
861      (let* ((fulltag (logand i x8664::fulltagmask))
862             (names-vector
863              (cond ((= fulltag x8664::fulltag-nodeheader-0)
864                     *nodeheader-0-types*)
865                    ((= fulltag x8664::fulltag-nodeheader-1)
866                     *nodeheader-1-types*)
867                    ((= fulltag x8664::fulltag-immheader-0)
868                     *immheader-0-types*)
869                    ((= fulltag x8664::fulltag-immheader-1)
870                     *immheader-1-types*)
871                    ((= fulltag x8664::fulltag-immheader-2)
872                     *immheader-2-types*)))
873             (name (if names-vector
874                     (aref names-vector (ash i -4)))))
875        ;; Special-case a few things ...
876        (if (eq name 'symbol-vector)
877          (setq name 'symbol)
878          (if (eq name 'function-vector)
879            (setq name 'function)))
880        (setf (aref a i) name)))
881    #+ppc64-target
882    (dotimes (i 256)
883      (let* ((lowtag (logand i ppc64::lowtagmask)))
884        (setf (%svref a i)
885              (cond ((= lowtag ppc64::lowtag-immheader)
886                     (%svref *immheader-types* (ash i -2)))
887                    ((= lowtag ppc64::lowtag-nodeheader)
888                     (%svref *nodeheader-types* (ash i -2)))))))
889    #+(or ppc32-target x8632-target)
890    (dotimes (i 256)
891      (let* ((fulltag (logand i target::fulltagmask)))
892        (setf (%svref a i)
893              (cond ((= fulltag target::fulltag-immheader)
894                     (%svref *immheader-types* (ash i -3)))
895                    ((= fulltag target::fulltag-nodeheader)
896                     (%svref *nodeheader-types* (ash i -3)))))))
897    a))
898
899 
900   
901(defun report-heap-utilization (out nconses nvectors vector-sizes)
902  (format out "~&Object type~42tCount~50tTotal Size in Bytes")
903  (format out "~&CONS~36t~12d~48t~16d" nconses (* nconses target::cons.size))
904  (dotimes (i (length nvectors))
905    (let* ((count (aref nvectors i))
906           (sizes (aref vector-sizes i)))
907      (unless (zerop count)
908        (format out "~&~a~36t~12d~48t~16d" (aref *heap-utilization-vector-type-names* i)  count sizes)))))
909                           
910;; The number of words to allocate for static conses when the user requests
911;; one and we don't have any left over
912(defparameter *static-cons-chunk* 1048576)
913
914(defun initialize-static-cons ()
915  "Activates collection of garbage conses in the static-conses
916   list and allocates initial static conses."
917  ; There might be a race here when multiple threads call this
918  ; function.  However, the discarded static conses will become
919  ; garbage and be added right back to the list.  No harm here
920  ; except for additional garbage collections.
921  (%set-kernel-global 'static-conses nil)
922  (allocate-static-conses))
923
924(defun allocate-static-conses ()
925  "Allocates some memory, freezes it and lets it become garbage.
926   This will add the memory to the list of free static conses."
927  (let ((l (make-array *static-cons-chunk*)))
928    (declare (ignore l))
929    (freeze))
930  (gc))
931
932(defun static-cons (car-value cdr-value)
933  "Allocates a cons cell that doesn't move on garbage collection,
934   and thus doesn't trigger re-hashing when used as a key in a hash
935   table.  Usage is equivalent to regular CONS."
936  (when (eq (%get-kernel-global 'static-conses) 0)
937    (initialize-static-cons))
938  (let ((cell (%atomic-pop-static-cons)))
939    (if cell
940      (progn
941        (setf (car cell) car-value)
942        (setf (cdr cell) cdr-value)
943        cell)
944      (progn
945        (allocate-static-conses)
946        (static-cons car-value cdr-value)))))
947       
948
949(defparameter *weak-gc-method-names*
950  '((:traditional . 0)
951    (:non-circular . 1)))
952
953
954(defun weak-gc-method ()
955  (or (car (rassoc (%get-kernel-global 'weak-gc-method)
956                   *weak-gc-method-names*))
957      :traditional))
958
959
960(defun (setf weak-gc-method) (name)
961  (setf (%get-kernel-global 'weak-gc-method)
962        (or (cdr (assoc name *weak-gc-method-names*))
963            0))
964  name)
Note: See TracBrowser for help on using the repository browser.