source: branches/win64/lib/misc.lisp @ 9819

Last change on this file since 9819 was 9819, checked in by gb, 13 years ago

Handle Cygwin paths on Windows (for LOCAL-SVN-REVISION).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 32.7 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            #+windows-target
111            (getenv "PROCESSOR_IDENTIFIER")
112            )))
113
114
115(defun software-type ()
116  "Return a string describing the supporting software."
117  #-windows-target (%uname 0)
118  #+windows-target "Microsoft Windows")
119
120
121(defun software-version ()
122  "Return a string describing version of the supporting software, or NIL
123   if not available."
124  #-windows-target (%uname 2)
125  #+windows-target
126  (rletZ ((info #>OSVERSIONINFOEX))
127    (setf (pref info #>OSVERSIONINFOEX.dwOSVersionInfoSize)
128          (record-length #>OSVERSIONINFOEX))
129    (#_GetVersionExA info)
130    (format nil "~d.~d Build ~d (~a)"
131            (pref info #>OSVERSIONINFOEX.dwMajorVersion)
132            (pref info #>OSVERSIONINFOEX.dwMinorVersion)
133            (pref info #>OSVERSIONINFOEX.dwBuildNumber)
134            (if (eql (pref info #>OSVERSIONINFOEX.wProductType)
135                     #$VER_NT_WORKSTATION)
136              "Workstation"
137              "Server")))
138  )
139
140
141
142
143
144
145
146;;; Yawn.
147
148
149
150(defmethod documentation (thing doc-id)
151  (%get-documentation thing doc-id))
152
153(defun set-documentation (thing doc-id new)
154  (setf (documentation thing doc-id) new))
155
156(defmethod (setf documentation) (new thing doc-id)
157  (%put-documentation thing doc-id new))
158
159
160(defmethod documentation ((symbol symbol) (doc-type (eql 'function)))
161  (let* ((def (fboundp symbol)))        ; FBOUNDP returns info about definition
162    (when def
163      (%get-documentation def t))))
164
165(defmethod (setf documentation) ((new t)
166                                 (symbol symbol)
167                                 (doc-type (eql 'function)))
168  (let* ((def (fboundp symbol)))        ; FBOUNDP returns info about definition
169    (when def
170      (%put-documentation def
171                          t
172                          new))
173    new))
174
175(defmethod documentation ((symbol symbol) (doc-type (eql 'setf)))
176  (call-next-method))
177
178(defmethod (setf documentation) ((new t)
179                                 (symbol symbol)
180                                 (doc-type (eql 'setf)))
181  (call-next-method))
182
183
184(defmethod documentation ((symbol symbol) (doc-type (eql 'variable)))
185  (call-next-method))
186
187(defmethod (setf documentation) ((new t)
188                                 (symbol symbol)
189                                 (doc-type (eql 'variable)))
190  (call-next-method))
191
192(defmethod documentation ((symbol symbol) (doc-type (eql 'compiler-macro)))
193  (call-next-method))
194
195(defmethod (setf documentation) ((new t)
196                                 (symbol symbol)
197                                 (doc-type (eql 'compiler-macro)))
198  (call-next-method))
199
200(defmethod documentation ((symbol symbol) (doc-type (eql 'type)))
201  (let* ((class (find-class symbol nil)))
202    (if class
203      (documentation class doc-type)
204      (call-next-method))))
205
206(defmethod (setf documentation) (new (symbol symbol) (doc-type (eql 'type)))
207  (let* ((class (find-class symbol nil)))
208    (if class
209      (setf (documentation class doc-type) new)
210      (call-next-method))))
211
212(defmethod documentation ((symbol symbol) (doc-type (eql 'method-combination)))
213  (let* ((mci (method-combination-info symbol)))
214    (if mci
215      (documentation mci doc-type))))
216
217(defmethod (setf documentation) ((new t)
218                                 (symbol symbol)
219                                 (doc-type (eql 'method-combination)))
220  (let* ((mci (method-combination-info symbol)))
221    (if mci
222      (setf (documentation mci doc-type) new))))
223
224
225(defmethod documentation ((symbol symbol) (doc-type (eql 'structure)))
226  (let* ((class (find-class symbol nil)))
227    (if (typep class 'structure-class)
228      (documentation class 'type)
229      (call-next-method))))
230
231(defmethod (setf documentation) ((new t)
232                                 (symbol symbol)
233                                 (doc-type (eql 'structure)))
234  (let* ((class (find-class symbol nil)))
235    (if (typep class 'structure-class)
236      (setf (documentation class 'type) new)
237      (call-next-method))))
238
239(defmethod documentation ((p package) (doc-type (eql 't)))
240  (call-next-method))
241
242(defmethod (setf documentation) ((new t) (p package) (doc-type (eql 't)))
243  (call-next-method))
244
245(defmethod documentation ((f function) (doc-type (eql 't)))
246  (call-next-method))
247
248(defmethod (setf documentation) ((new t) (f function) (doc-type (eql 't)))
249  (call-next-method))
250
251(defmethod documentation ((f function) (doc-type (eql 'function)))
252  (documentation f t))
253
254(defmethod (setf documentation) ((new t)
255                                 (f function)
256                                 (doc-type (eql 'function)))
257  (setf (documentation f t) new))
258
259(defmethod documentation ((l cons) (doc-type (eql 'function)))
260  (let* ((name (setf-function-spec-name l)))
261    (if name
262      (documentation name doc-type)
263      (%get-documentation l doc-type))))
264
265(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'function)))
266  (let* ((name  (setf-function-spec-name l)))
267    (if name
268      (setf (documentation name doc-type) new)
269      (%put-documentation l doc-type new))))
270
271
272(defmethod documentation ((l cons) (doc-type (eql 'compiler-macro)))
273  (let* ((name (setf-function-spec-name l)))
274    (if name
275      (documentation name doc-type)
276      (%get-documentation l doc-type))))
277
278(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'compiler-macr0)))
279  (let* ((name (setf-function-spec-name l)))
280    (if name
281      (setf (documentation name doc-type) new)
282      (%put-documentation l doc-type new))))
283
284
285(defmethod documentation ((m method-combination)
286                          (doc-type (eql 'method-combination)))
287  (call-next-method))
288
289(defmethod (setf documentation) ((new t)
290                                 (m method-combination)
291                                 (doc-type (eql 'method-combination)))
292  (call-next-method))
293
294(defmethod documentation ((m method-combination)
295                          (doc-type (eql t)))
296  (documentation m 'method-combination))
297
298(defmethod (setf documentation) ((new t)
299                                 (m method-combination)
300                                 (doc-type (eql t)))
301  (setf (documentation m 'method-combination) new))
302
303(defmethod documentation ((m standard-method)
304                          (doc-type (eql t)))
305  (call-next-method))
306
307(defmethod (setf documentation) ((new t)
308                                 (m standard-method)
309                                 (doc-type (eql t)))
310  (call-next-method))
311
312(defmethod documentation ((c standard-class) (doc-type (eql 'type)))
313  (call-next-method))
314
315(defmethod (setf documentation) ((new t)
316                                 (c standard-class)
317                                 (doc-type (eql 'type)))
318  (call-next-method))
319
320(defmethod documentation ((c standard-class) (doc-type (eql 't)))
321  (documentation c 'type))
322
323(defmethod (setf documentation) ((new t)
324                                 (c standard-class)
325                                 (doc-type (eql 't)))
326  (setf (documentation c 'type) new))
327
328(defmethod documentation ((c structure-class) (doc-type (eql 'type)))
329  (call-next-method))
330
331(defmethod (setf documentation) ((new t)
332                                 (c structure-class)
333                                 (doc-type (eql 'type)))
334  (call-next-method))
335
336(defmethod documentation ((c structure-class) (doc-type (eql 't)))
337  (documentation c 'type))
338
339(defmethod (setf documentation) ((new t)
340                                 (c structure-class)
341                                 (doc-type (eql 't)))
342  (setf (documentation c 'type) new))
343
344;;; This is now deprecated; things which call it should stop doing so.
345(defun set-documentation (symbol doc-type string)
346  (setf (documentation symbol doc-type) string))
347
348(defun set-function-info (symbol info)
349  (let* ((doc-string (if (consp info) (car info) info)))
350    (if (and *save-doc-strings* (stringp doc-string))
351      (set-documentation  symbol 'function doc-string)))
352  (let* ((cons (assq symbol *nx-globally-inline*))
353         (lambda-expression (if (consp info) (cdr info))))
354    (if (and (proclaimed-inline-p symbol)
355             (not (compiler-special-form-p symbol))
356             (lambda-expression-p lambda-expression)
357             (let* ((lambda-list (cadr lambda-expression)))
358               (and (not (memq '&lap lambda-list))
359                    (not (memq '&method lambda-list))
360                    (not (memq '&lexpr lambda-list)))))
361      (if cons 
362        (%rplacd cons lambda-expression)
363        (push (cons symbol lambda-expression) *nx-globally-inline*))
364      (if cons (setq *nx-globally-inline* (delete cons *nx-globally-inline*)))))
365  symbol)
366
367
368(setf (documentation 'if 'function)
369      "If Predicate Then [Else]
370  If Predicate evaluates to non-null, evaluate Then and returns its values,
371  otherwise evaluate Else and return its values. Else defaults to NIL.")
372
373(setf (documentation 'progn 'function)
374      "progn form*
375  Evaluates each FORM and returns the value(s) of the last FORM.")
376
377(defmethod documentation ((thing character-encoding) (doc-type (eql t)))
378  (character-encoding-documentation thing))
379
380(defmethod (setf documentation) (new (thing character-encoding) (doc-type (eql t)))
381  (check-type new (or null string))
382  (setf (character-encoding-documentation thing) new))
383
384(defmethod documentation ((thing symbol) (doc-type (eql 'character-encoding)))
385  (let* ((encoding (lookup-character-encoding (intern (string thing) :keyword))))
386    (when encoding
387      (documentation encoding t))))
388
389                                 
390
391
392#|
393(setf (documentation 'car 'variable) "Preferred brand of automobile")
394(documentation 'car 'variable)
395(setf (documentation 'foo 'structure) "the structure is grand.")
396(documentation 'foo 'structure)
397(setf (documentation 'foo 'variable) "the metasyntactic remarker")
398(documentation 'foo 'variable)
399(setf (documentation 'foo 'obscure) "no one really knows what it means")
400(documentation 'foo 'obscure)
401(setf (documentation 'foo 'structure) "the structure is solid")
402(documentation 'foo 'function)
403||#
404
405;;
406
407
408(defun %page-fault-info ()
409  #-(or darwin-target windows-target)
410  (rlet ((usage :rusage))
411    (%%rusage usage)
412    (values (pref usage :rusage.ru_minflt)
413            (pref usage :rusage.ru_majflt)
414            (pref usage :rusage.ru_nswap)))
415  #+darwin-target
416  (rlet ((count #>mach_msg_type_number_t #$TASK_EVENTS_INFO_COUNT)
417         (info #>task_events_info))
418    (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count)
419    (values (pref info #>task_events_info.cow_faults)
420            (pref info #>task_events_info.faults)
421            (pref info #>task_events_info.pageins)))
422  #+windows-target
423  ;; Um, don't know how to determine this, or anything like it.
424  (values 0 0 0))
425
426
427         
428(defparameter *report-time-function* nil
429  "If non-NULL, should be a function which accepts the following
430   keyword arguments:
431   :FORM              the form that was executed
432   :RESULTS           a list of all values returned by the execution of FORM
433   :ELAPSED-TIME      total elapsed (real) time, in internal-time-units-per-second
434   :USER-TIME         elapsed user time, in internal-time-units-per-second
435   :SYSTEM-TIME       elapsed system time, in internal-time-units-per-second
436   :GC-TIME           total real time spent in the GC, in internal-time-units-per-second
437   :BYTES-ALLOCATED   total bytes allocated
438   :MINOR-PAGE-FAULTS minor page faults
439   :MAJOR-PAGE-FAULTS major page faults
440   :SWAPS             swaps")
441
442
443(defun standard-report-time (&key form results elapsed-time user-time
444                                  system-time gc-time bytes-allocated
445                                  minor-page-faults major-page-faults
446                                  swaps)
447  (let* ((s *trace-output*)
448         (units
449          (ecase internal-time-units-per-second
450            (1000000 "microseconds")
451            (1000  "milliseconds")))
452         (width
453          (ecase internal-time-units-per-second
454            (1000000 6)
455            (1000  3)))
456         (cpu-count (cpu-count)))
457    (format s "~&~S took ~:D ~a (~,vF seconds) to run ~%~20twith ~D available CPU core~P."
458            form elapsed-time units width (/ elapsed-time internal-time-units-per-second) cpu-count cpu-count)
459    (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))
460    (format s "~&                    ~:D ~a (~,vF seconds) were spent in system mode" system-time units width(/ system-time internal-time-units-per-second))
461    (unless (eql gc-time 0)
462      (format s
463              "~%~:D ~a (~,vF seconds) was spent in GC."
464              gc-time units width (/ gc-time internal-time-units-per-second)))
465    (unless (eql 0 bytes-allocated)
466      (format s "~% ~:D bytes of memory allocated." bytes-allocated))
467    (when (or (> minor-page-faults 0)
468              (> major-page-faults 0)
469              (> swaps 0))
470      (format s
471              "~% ~:D minor page faults, ~:D major page faults, ~:D swaps."
472              minor-page-faults major-page-faults swaps))
473    (format s "~&")
474    (values-list results)))
475
476(defun report-time (form thunk)
477  (flet ((integer-size-in-bytes (i)
478           (if (typep i 'fixnum)
479             0
480             (* (logand (+ 2 (uvsize i)) (lognot 1)) 4))))
481    (multiple-value-bind (user-start system-start)
482        (%internal-run-time)
483      (multiple-value-bind (minor-start major-start swaps-start)
484          (%page-fault-info)
485        (let* ((initial-real-time (get-internal-real-time))
486               (initial-gc-time (gctime))
487               (initial-consed (total-bytes-allocated))           
488               (initial-overhead (integer-size-in-bytes initial-consed)))
489          (let* ((results (multiple-value-list (funcall thunk))))
490            (declare (dynamic-extent results))
491            (multiple-value-bind (user-end system-end)
492                (%internal-run-time)
493              (multiple-value-bind (minor-end major-end swaps-end)
494                  (%page-fault-info)
495                (let* ((new-consed (total-bytes-allocated))                 
496                       (bytes-consed
497                        (- new-consed (+ initial-overhead initial-consed)))
498                       (elapsed-real-time
499                        (- (get-internal-real-time) initial-real-time))
500                       (elapsed-gc-time (- (gctime) initial-gc-time))
501                       (elapsed-user-time
502                        (- user-end user-start))
503                       (elapsed-system-time
504                        (- system-end system-start))
505                       (elapsed-minor (- minor-end minor-start))
506                       (elapsed-major (- major-end major-start))
507                       (elapsed-swaps (- swaps-end swaps-start)))
508                  (funcall (or *report-time-function*
509                               #'standard-report-time)
510                           :form form
511                           :results results
512                           :elapsed-time elapsed-real-time
513                           :user-time elapsed-user-time
514                           :system-time elapsed-system-time
515                           :gc-time elapsed-gc-time
516                           :bytes-allocated bytes-consed
517                           :minor-page-faults elapsed-minor
518                           :major-page-faults elapsed-major
519                           :swaps elapsed-swaps))))))))))
520
521
522
523
524;;; site names and machine-instance is in the init file.
525
526(defun add-feature (symbol)
527  "Not CL but should be."
528  (if (symbolp symbol)
529      (if (not (memq symbol *features*))
530          (setq *features* (cons symbol *features*)))))
531
532;;; (dotimes (i 5000) (declare (fixnum i)) (add-feature 'junk))
533
534
535
536
537;;; Misc string functions
538
539
540(defun string-left-trim (char-bag string &aux end)
541  "Given a set of characters (a list or string) and a string, returns
542  a copy of the string with the characters in the set removed from the
543  left end."
544  (setq string (string string))
545  (setq end (length string))
546  (do ((index 0 (%i+ index 1)))
547      ((or (eq index end) (not (find (aref string index) char-bag)))
548       (subseq string index end))))
549
550(defun string-right-trim (char-bag string &aux end)
551  "Given a set of characters (a list or string) and a string, returns
552  a copy of the string with the characters in the set removed from the
553  right end."
554  (setq string (string string))
555  (setq end (length string))
556  (do ((index (%i- end 1) (%i- index 1)))
557      ((or (%i< index 0) (not (find (aref string index) char-bag)))
558       (subseq string 0 (%i+ index 1)))))
559
560(defun string-trim (char-bag string &aux end)
561  "Given a set of characters (a list or string) and a string, returns a
562  copy of the string with the characters in the set removed from both
563  ends."
564  (setq string (string string))
565  (setq end (length string))
566  (let ((left-end) (right-end))
567     (do ((index 0 (%i+ index 1)))
568         ((or (eq index end) (not (find (aref string index) char-bag)))
569          (setq left-end index)))
570     (do ((index (%i- end 1) (%i- index 1)))
571         ((or (%i< index left-end) (not (find (aref string index) char-bag)))
572          (setq right-end index)))
573      (subseq string left-end (%i+ right-end 1))))
574
575
576
577(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol def)
578  "Make and return a new uninterned symbol with the same print name
579  as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound
580  nor fbound and has no properties, else it has a copy of SYMBOL's
581  function, value and property list."
582  (setq new-symbol (make-symbol (symbol-name symbol)))
583  (when copy-props
584      (when (boundp symbol)
585            (set new-symbol (symbol-value symbol)))
586      (when (setq def (fboundp symbol))
587            ;;;Shouldn't err out on macros/special forms.
588            (%fhave new-symbol def))
589      (set-symbol-plist new-symbol (copy-list (symbol-plist symbol))))
590  new-symbol)
591
592
593(defvar %gentemp-counter 0
594  "Counter for generating unique GENTEMP symbols.")
595
596(defun gentemp (&optional (prefix "T") (package *package*))
597  "Creates a new symbol interned in package PACKAGE with the given PREFIX."
598  (loop
599    (let* ((new-pname (%str-cat (ensure-simple-string prefix) 
600                                (%integer-to-string %gentemp-counter)))
601           (sym (find-symbol new-pname package)))
602      (if sym
603        (setq %gentemp-counter (%i+ %gentemp-counter 1))
604        (return (values (intern new-pname package))))))) ; 1 value.
605
606
607
608
609(defun add-gc-hook (hook-function &optional (which-hook :pre-gc))
610  (ecase which-hook
611    (:pre-gc
612     (pushnew hook-function *pre-gc-hook-list*)
613     (setq *pre-gc-hook* #'(lambda ()
614                             (dolist (hook *pre-gc-hook-list*)
615                               (funcall hook)))))
616    (:post-gc
617     (pushnew hook-function *post-gc-hook-list*)
618     (setq *post-gc-hook* #'(lambda ()
619                             (dolist (hook *post-gc-hook-list*)
620                               (funcall hook))))))
621  hook-function)
622
623(defun remove-gc-hook (hook-function &optional (which-hook :pre-gc))
624  (ecase which-hook
625    (:pre-gc
626     (unless (setq *pre-gc-hook-list* (delq hook-function *pre-gc-hook-list*))
627       (setq *pre-gc-hook* nil)))
628    (:post-gc
629     (unless (setq *post-gc-hook-list* (delq hook-function *post-gc-hook-list*))
630       (setq *post-gc-hook* nil)))))
631
632
633
634
635
636
637(defun find-method-by-names (name qualifiers specializers)
638  (let ((gf (fboundp name)))
639    (when gf
640      (if (not (standard-generic-function-p gf))
641        (error "~S is not a generic-function." gf)
642        (let ((methods (%gf-methods gf)))
643          (when methods
644            (let* ((spec-len (length (%method-specializers (car methods))))
645                   (new-specs (make-list spec-len :initial-element (find-class t))))
646              (declare (dynamic-extent new-specs))
647              (do ((specs specializers (cdr specs))
648                   (nspecs new-specs (cdr nspecs)))
649                  ((or (null specs) (null nspecs)))
650                (let ((s (car specs)))
651                  (rplaca nspecs (if (consp s) s (find-class s nil)))))
652              (find-method gf qualifiers new-specs nil))))))))
653
654
655
656(defun get-string-from-user (prompt)
657  (with-terminal-input
658      (format *query-io* "~&~a " prompt)
659    (force-output *query-io*)
660    (clear-input *query-io*)
661    (values (read-line *query-io*))))
662
663
664(defun select-item-from-list (list &key (window-title "Select one of the following")
665                                   (table-print-function #'prin1)
666                                   &allow-other-keys)
667  (block get-answer
668    (with-terminal-input
669      (format *query-io* "~a:~%" window-title)
670      (loop
671         (catch :redisplay
672           (do* ((l list (cdr l))
673                 (i 0 (1+ i))
674                 (item (car l) (car l)))
675                ((null l))
676             (declare (fixnum i))
677             (format *query-io* "~&  ~d: " i)
678             (funcall table-print-function item *query-io*))
679           (loop
680              (fresh-line *query-io*)
681              (let* ((string (get-string-from-user "Selection [number,q,r,?]:"))
682                     (value (ignore-errors
683                              (let* ((*package* *keyword-package*))
684                                (read-from-string string nil)))))
685                (cond ((eq value :q) (throw :cancel t))
686                      ((eq value :r) (throw :redisplay t))
687                      ((eq value :?) 
688                       (format *query-io* "~%Enter the number of the selection, ~%  r to redisplay, ~%  q to cancel or ~%  ? to show this message again."))
689                      ((and (typep value 'unsigned-byte)
690                            (< value (length list)))
691                       (return-from get-answer (list (nth value list))))))))))))
692
693;;; There should ideally be some way to override the UI (such as
694;;; it is ...) here.
695;;; More generally, this either
696;;;   a) shouldn't exist, or
697;;;   b) should do more sanity-checking
698(defun choose-file-dialog (&key file-types (prompt "File name:"))
699  (%choose-file-dialog t prompt file-types))
700
701(defun choose-new-file-dialog (&key prompt)
702  (%choose-file-dialog nil prompt nil))
703
704(defun %choose-file-dialog (must-exist prompt file-types)
705  (loop
706      (let* ((namestring (get-string-from-user prompt))
707             (pathname (ignore-errors (pathname namestring)))
708             (exists (and pathname (probe-file pathname))))
709        (when (and (if must-exist exists)
710                   (or (null file-types)
711                       (member (pathname-type pathname)
712                               file-types :test #'equal)))
713          (return pathname))
714        (if (not exists)
715          (format *query-io* "~&~s does not exist." namestring)
716          (format *query-io* "~&Type of ~s is not one of ~{~a~}"
717                  namestring file-types)))))
718
719(defparameter *overwrite-dialog-hook* nil)
720(defun overwrite-dialog (filename prompt)
721  (if *overwrite-dialog-hook*
722    (funcall *overwrite-dialog-hook* filename prompt)
723    t))
724
725;;; Might want to have some other entry for, e.g., the inspector
726;;; and to let it get its hands on the list header returned by
727;;; disassemble-ppc-function.  Maybe disassemble-ppc-function
728;;; should take care of "normalizing" the code-vector ?
729(defun disassemble (thing)
730  "Disassemble the compiled code associated with OBJECT, which can be a
731  function, a lambda expression, or a symbol with a function definition. If
732  it is not already compiled, the compiler is called to produce something to
733  disassemble."
734  (#+ppc-target ppc-xdisassemble
735   #+x8664-target x8664-xdisassemble
736   (require-type (function-for-disassembly thing) 'compiled-function)))
737
738(defun function-for-disassembly (thing)
739  (let* ((fun thing))
740    ;; CLHS says that DISASSEMBLE should signal a type error if its
741    ;; argument isn't a function designator.  Hard to imagine any
742    ;; code depending on that ...
743    ;;(when (typep fun 'standard-method) (setq fun (%method-function fun)))
744    (when (or (symbolp fun)
745              (and (consp fun) (neq (%car fun) 'lambda)))
746      (setq fun (fboundp thing))
747      (when (and (symbolp thing) (not (functionp fun)))
748        (setq fun (macro-function thing))))
749    (if (typep fun 'compiled-lexical-closure)
750        (setq fun (closure-function fun)))
751    (when (lambda-expression-p fun)
752      (setq fun (compile-named-function fun nil)))
753    fun))
754
755(%fhave 'df #'disassemble)
756
757(defloadvar *use-cygwin-svn*
758    #+windows-target (not (null (getenv "CYGWIN")))
759    #-windows-target nil)
760
761(defun local-svn-revision ()
762  (or
763   ;; svn2cvs uses a .svnrev file to sync CVS and SVN; if present,
764   ;; it contains the svn revision in decimal.
765   (with-open-file (f "ccl:\\.svnrev" :direction :input :if-does-not-exist nil)
766     (when f (read f)))
767   (with-output-to-string (s)
768     (let* ((root (native-translated-namestring "ccl:")))
769       (when *use-cygwin-svn*
770         (setq root (cygpath root)))
771       (multiple-value-bind (status exit-code)
772           (external-process-status
773            (run-program "svnversion"  (list  root "/trunk/ccl"):output s))
774         (when (and (eq :exited status) (zerop exit-code))
775           (with-input-from-string (output (get-output-stream-string s))
776             (let* ((line (read-line output nil nil)))
777               (when (and line (parse-integer line :junk-allowed t) )
778                 (return-from local-svn-revision line)))))
779         (return-from local-svn-revision nil))))))
780
781
782;;; Scan the heap, collecting infomation on the primitive object types
783;;; found.  Report that information.
784
785(defun heap-utilization (&key (stream *debug-io*)
786                              (gc-first t))
787  (let* ((nconses 0)
788         (nvectors (make-array 256))
789         (vector-sizes (make-array 256))
790         (array-size-function (arch::target-array-data-size-function
791                               (backend-target-arch *host-backend*))))
792    (declare (type (simple-vector 256) nvectors vector-sizes)
793             (dynamic-extent nvectors vector-sizes))
794    (when gc-first (gc))
795    (%map-areas (lambda (thing)
796                  (if (consp thing)
797                    (incf nconses)
798                    (let* ((typecode (typecode thing)))
799                      (incf (aref nvectors typecode))
800                      (incf (aref vector-sizes typecode)
801                            (funcall array-size-function typecode (uvsize thing)))))))
802    (report-heap-utilization stream nconses nvectors vector-sizes)
803    (values)))
804
805(defvar *heap-utilization-vector-type-names*
806  (let* ((a (make-array 256)))
807    #+x8664-target
808    (dotimes (i 256)
809      (let* ((fulltag (logand i x8664::fulltagmask))
810             (names-vector
811              (cond ((= fulltag x8664::fulltag-nodeheader-0)
812                     *nodeheader-0-types*)
813                    ((= fulltag x8664::fulltag-nodeheader-1)
814                     *nodeheader-1-types*)
815                    ((= fulltag x8664::fulltag-immheader-0)
816                     *immheader-0-types*)
817                    ((= fulltag x8664::fulltag-immheader-1)
818                     *immheader-1-types*)
819                    ((= fulltag x8664::fulltag-immheader-2)
820                     *immheader-2-types*)))
821             (name (if names-vector
822                     (aref names-vector (ash i -4)))))
823        ;; Special-case a few things ...
824        (if (eq name 'symbol-vector)
825          (setq name 'symbol)
826          (if (eq name 'function-vector)
827            (setq name 'function)))
828        (setf (aref a i) name)))
829    #+ppc64-target
830    (dotimes (i 256)
831      (let* ((lowtag (logand i ppc64::lowtagmask)))
832        (setf (%svref a i)
833              (cond ((= lowtag ppc64::lowtag-immheader)
834                     (%svref *immheader-types* (ash i -2)))
835                    ((= lowtag ppc64::lowtag-nodeheader)
836                     (%svref *nodeheader-types* (ash i -2)))))))
837    #+ppc32-target
838    (dotimes (i 256)
839      (let* ((fulltag (logand i ppc32::fulltagmask)))
840        (setf (%svref a i)
841              (cond ((= fulltag ppc32::fulltag-immheader)
842                     (%svref *immheader-types* (ash i -3)))
843                    ((= fulltag ppc32::fulltag-nodeheader)
844                     (%svref *nodeheader-types* (ash i -3)))))))
845    a))
846
847 
848   
849(defun report-heap-utilization (out nconses nvectors vector-sizes)
850  (format out "~&Object type~42tCount~50tTotal Size in Bytes")
851  (format out "~&CONS~36t~12d~48t~16d" nconses (* nconses target::cons.size))
852  (dotimes (i (length nvectors))
853    (let* ((count (aref nvectors i))
854           (sizes (aref vector-sizes i)))
855      (unless (zerop count)
856        (format out "~&~a~36t~12d~48t~16d" (aref *heap-utilization-vector-type-names* i)  count sizes)))))
857                           
858;; The number of words to allocate for static conses when the user requests
859;; one and we don't have any left over
860(defparameter *static-cons-chunk* 1048576)
861
862(defun initialize-static-cons ()
863  "Activates collection of garbage conses in the static-conses
864   list and allocates initial static conses."
865  ; There might be a race here when multiple threads call this
866  ; function.  However, the discarded static conses will become
867  ; garbage and be added right back to the list.  No harm here
868  ; except for additional garbage collections.
869  (%set-kernel-global 'static-conses nil)
870  (allocate-static-conses))
871
872(defun allocate-static-conses ()
873  "Allocates some memory, freezes it and lets it become garbage.
874   This will add the memory to the list of free static conses."
875  (let ((l (make-array *static-cons-chunk*)))
876    (declare (ignore l))
877    (freeze))
878  (gc))
879
880(defun static-cons (car-value cdr-value)
881  "Allocates a cons cell that doesn't move on garbage collection,
882   and thus doesn't trigger re-hashing when used as a key in a hash
883   table.  Usage is equivalent to regular CONS."
884  (when (eq (%get-kernel-global 'static-conses) 0)
885    (initialize-static-cons))
886  (let ((cell (%atomic-pop-static-cons)))
887    (if cell
888      (progn
889        (setf (car cell) car-value)
890        (setf (cdr cell) cdr-value)
891        cell)
892      (progn
893        (allocate-static-conses)
894        (static-cons car-value cdr-value)))))
895       
896
897(defparameter *weak-gc-method-names*
898  '((:traditional . 0)
899    (:non-circular . 1)))
900
901
902(defun weak-gc-method ()
903  (or (car (rassoc (%get-kernel-global 'weak-gc-method)
904                   *weak-gc-method-names*))
905      :traditional))
906
907
908(defun (setf weak-gc-method) (name)
909  (setf (%get-kernel-global 'weak-gc-method)
910        (or (cdr (assoc name *weak-gc-method-names*))
911            0))
912  name)
Note: See TracBrowser for help on using the repository browser.