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

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

Conditionalize some TIME/GET-INTERNAL-RUN-TIME stuff for win64.

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