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

Last change on this file since 8229 was 8229, checked in by andreas, 12 years ago

Lock-free STATIC-CONS for x86.

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