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

Last change on this file since 10336 was 10336, checked in by rme, 12 years ago

*heap-utilization-vector-type-names* for x8632 (same as ppc32).

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