source: branches/watchpoints/lib/misc.lisp @ 12906

Last change on this file since 12906 was 12906, checked in by rme, 10 years ago

New function X86-EMULATE-WRITE-INSTRUCTION and a couple of helpers.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 41.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (eval compile)
20  (require 'defstruct-macros))
21
22(defun short-site-name  ()
23  "Return a string with the abbreviated site name, or NIL if not known."
24  (or *short-site-name* "unspecified"))
25
26(defun long-site-name   ()
27  "Return a string with the long form of the site name, or NIL if not known."
28  (or *long-site-name* "unspecified"))
29
30(defun machine-instance ()
31  "Return a string giving the name of the local machine."
32  #-windows-target (%uname 1)
33  #+windows-target
34  (rlet ((nsize #>DWORD 0))
35    (if (eql 0 (#_GetComputerNameExW #$ComputerNameDnsFullyQualified
36                                     (%null-ptr)
37                                     nsize))
38      (%stack-block ((buf (* 2 (pref nsize #>DWORD))))
39        (#_GetComputerNameExW #$ComputerNameDnsFullyQualified
40                              buf
41                              nsize)
42        (%get-native-utf-16-cstring buf))
43      "localhost"))
44  )
45
46
47(defun machine-type ()
48  "Returns a string describing the type of the local machine."
49  #-windows-target (%uname 4)
50  #+windows-target
51  (rlet ((info #>SYSTEM_INFO))
52    (#_GetSystemInfo info)
53    (case (pref info #>SYSTEM_INFO.nil.nil.wProcessorArchitecture)
54      (#.#$PROCESSOR_ARCHITECTURE_AMD64 "x64")
55      (#.#$PROCESSOR_ARCHITECTURE_INTEL "x86")
56      (t "unknown")))
57  )
58
59
60
61(defloadvar *machine-version* nil)
62
63(defun machine-version ()
64  "Return a string describing the version of the computer hardware we
65are running on, or NIL if we can't find any useful information."
66  (or *machine-version*
67      (setq *machine-version*
68            #+darwin-target
69            (block darwin-machine-version
70              (%stack-block ((mib 8))
71                (setf (%get-long mib 0) #$CTL_HW
72                      (%get-long mib 4) #$HW_MODEL)
73                (%stack-block ((res 256)
74                               (reslen target::node-size))
75                  (setf (%get-byte res 0) 0
76                        (%get-natural reslen 0) 256)
77                  (if (zerop (#_sysctl mib 2 res reslen (%null-ptr) 0))
78                    (return-from darwin-machine-version (%get-cstring res))))))
79            #+linux-target
80            (with-open-file (f "/proc/cpuinfo" :if-does-not-exist nil)
81              (when f
82                (flet ((cpu-info-match (target line)
83                         (let* ((targetlen (length target))
84                                (linelen (length line)))
85                           (if (and (> linelen targetlen)
86                                    (string= target line
87                                             :end2 targetlen))
88                           (let* ((colonpos (position #\: line)))
89                             (when colonpos
90                               (string-trim " "
91                                            (subseq line (1+ colonpos)))))))))
92                  (do* ((line (read-line f nil nil)
93                              (read-line f nil nil))
94                        (target #+ppc-target "machine"
95                                #+x86-target "model name"))
96                       ((null line))
97                    (let* ((matched (cpu-info-match target line)))
98                      (when matched (return matched)))))))
99            #+freebsd-target
100            (%stack-block ((ret 512)
101                           (mib (* (record-length :uint))))
102              (setf (%get-unsigned-long mib 0)
103                    #$CTL_HW
104                    (%get-unsigned-long mib (record-length :uint))
105                    #$HW_MODEL)
106              (rlet ((oldsize :uint 512))
107                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
108                  (%get-cstring ret)
109                  1)))
110            #+solaris-target
111            (rlet ((info :processor_info_t))
112              (do* ((i 0 (1+ i)))
113                   ((and (= 0 (#_processor_info i info))
114                         (= (pref info :processor_info_t.pi_state)
115                            #$P_ONLINE))
116                    (%get-cstring (pref info :processor_info_t.pi_processor_type)))))
117            #+windows-target
118            (getenv "PROCESSOR_IDENTIFIER")
119            )))
120
121
122(defun software-type ()
123  "Return a string describing the supporting software."
124  #-windows-target (%uname 0)
125  #+windows-target "Microsoft Windows")
126
127
128(defun software-version ()
129  "Return a string describing version of the supporting software, or NIL
130   if not available."
131  #-windows-target (%uname 2)
132  #+windows-target
133  (rletZ ((info #>OSVERSIONINFOEX))
134    (setf (pref info #>OSVERSIONINFOEX.dwOSVersionInfoSize)
135          (record-length #>OSVERSIONINFOEX))
136    (#_GetVersionExA info)
137    (format nil "~d.~d Build ~d (~a)"
138            (pref info #>OSVERSIONINFOEX.dwMajorVersion)
139            (pref info #>OSVERSIONINFOEX.dwMinorVersion)
140            (pref info #>OSVERSIONINFOEX.dwBuildNumber)
141            (if (eql (pref info #>OSVERSIONINFOEX.wProductType)
142                     #$VER_NT_WORKSTATION)
143              "Workstation"
144              "Server")))
145  )
146
147
148
149
150
151
152
153;;; Yawn.
154
155
156
157(defmethod documentation (thing doc-id)
158  (%get-documentation thing doc-id))
159
160(defmethod (setf documentation) (new thing doc-id)
161  (%put-documentation thing doc-id new))
162
163
164(defmethod documentation ((symbol symbol) (doc-type (eql 'function)))
165  (let* ((def (fboundp symbol)))        ; FBOUNDP returns info about definition
166    (when def
167      (%get-documentation def t))))
168
169(defmethod (setf documentation) ((new t)
170                                 (symbol symbol)
171                                 (doc-type (eql 'function)))
172  (let* ((def (fboundp symbol)))        ; FBOUNDP returns info about definition
173    (when def
174      (%put-documentation def
175                          t
176                          new))
177    new))
178
179(defmethod documentation ((symbol symbol) (doc-type (eql 'setf)))
180  (call-next-method))
181
182(defmethod (setf documentation) ((new t)
183                                 (symbol symbol)
184                                 (doc-type (eql 'setf)))
185  (call-next-method))
186
187
188(defmethod documentation ((symbol symbol) (doc-type (eql 'variable)))
189  (call-next-method))
190
191(defmethod (setf documentation) ((new t)
192                                 (symbol symbol)
193                                 (doc-type (eql 'variable)))
194  (call-next-method))
195
196(defmethod documentation ((symbol symbol) (doc-type (eql 'compiler-macro)))
197  (call-next-method))
198
199(defmethod (setf documentation) ((new t)
200                                 (symbol symbol)
201                                 (doc-type (eql 'compiler-macro)))
202  (call-next-method))
203
204(defmethod documentation ((symbol symbol) (doc-type (eql 'type)))
205  (let* ((class (find-class symbol nil)))
206    (if class
207      (documentation class doc-type)
208      (call-next-method))))
209
210(defmethod (setf documentation) (new (symbol symbol) (doc-type (eql 'type)))
211  (let* ((class (find-class symbol nil)))
212    (if class
213      (setf (documentation class doc-type) new)
214      (call-next-method))))
215
216(defmethod documentation ((symbol symbol) (doc-type (eql 'method-combination)))
217  (let* ((mci (method-combination-info symbol)))
218    (if mci
219      (documentation mci doc-type))))
220
221(defmethod (setf documentation) ((new t)
222                                 (symbol symbol)
223                                 (doc-type (eql 'method-combination)))
224  (let* ((mci (method-combination-info symbol)))
225    (if mci
226      (setf (documentation mci doc-type) new))))
227
228
229(defmethod documentation ((symbol symbol) (doc-type (eql 'structure)))
230  (let* ((class (find-class symbol nil)))
231    (if (typep class 'structure-class)
232      (documentation class 'type)
233      (call-next-method))))
234
235(defmethod (setf documentation) ((new t)
236                                 (symbol symbol)
237                                 (doc-type (eql 'structure)))
238  (let* ((class (find-class symbol nil)))
239    (if (typep class 'structure-class)
240      (setf (documentation class 'type) new)
241      (call-next-method))))
242
243(defmethod documentation ((p package) (doc-type (eql 't)))
244  (call-next-method))
245
246(defmethod (setf documentation) ((new t) (p package) (doc-type (eql 't)))
247  (call-next-method))
248
249(defmethod documentation ((f function) (doc-type (eql 't)))
250  (call-next-method))
251
252(defmethod (setf documentation) ((new t) (f function) (doc-type (eql 't)))
253  (call-next-method))
254
255(defmethod documentation ((f function) (doc-type (eql 'function)))
256  (documentation f t))
257
258(defmethod (setf documentation) ((new t)
259                                 (f function)
260                                 (doc-type (eql 'function)))
261  (setf (documentation f t) new))
262
263(defmethod documentation ((l cons) (doc-type (eql 'function)))
264  (let* ((name (setf-function-spec-name l)))
265    (if name
266      (documentation name doc-type)
267      (%get-documentation l doc-type))))
268
269(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'function)))
270  (let* ((name  (setf-function-spec-name l)))
271    (if name
272      (setf (documentation name doc-type) new)
273      (%put-documentation l doc-type new))))
274
275
276(defmethod documentation ((l cons) (doc-type (eql 'compiler-macro)))
277  (let* ((name (setf-function-spec-name l)))
278    (if name
279      (documentation name doc-type)
280      (%get-documentation l doc-type))))
281
282(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'compiler-macr0)))
283  (let* ((name (setf-function-spec-name l)))
284    (if name
285      (setf (documentation name doc-type) new)
286      (%put-documentation l doc-type new))))
287
288
289(defmethod documentation ((m method-combination)
290                          (doc-type (eql 'method-combination)))
291  (call-next-method))
292
293(defmethod (setf documentation) ((new t)
294                                 (m method-combination)
295                                 (doc-type (eql 'method-combination)))
296  (call-next-method))
297
298(defmethod documentation ((m method-combination)
299                          (doc-type (eql t)))
300  (documentation m 'method-combination))
301
302(defmethod (setf documentation) ((new t)
303                                 (m method-combination)
304                                 (doc-type (eql t)))
305  (setf (documentation m 'method-combination) new))
306
307(defmethod documentation ((m standard-method)
308                          (doc-type (eql t)))
309  (call-next-method))
310
311(defmethod (setf documentation) ((new t)
312                                 (m standard-method)
313                                 (doc-type (eql t)))
314  (call-next-method))
315
316(defmethod documentation ((c standard-class) (doc-type (eql 'type)))
317  (call-next-method))
318
319(defmethod (setf documentation) ((new t)
320                                 (c standard-class)
321                                 (doc-type (eql 'type)))
322  (call-next-method))
323
324(defmethod documentation ((c standard-class) (doc-type (eql 't)))
325  (documentation c 'type))
326
327(defmethod (setf documentation) ((new t)
328                                 (c standard-class)
329                                 (doc-type (eql 't)))
330  (setf (documentation c 'type) new))
331
332(defmethod documentation ((c structure-class) (doc-type (eql 'type)))
333  (call-next-method))
334
335(defmethod (setf documentation) ((new t)
336                                 (c structure-class)
337                                 (doc-type (eql 'type)))
338  (call-next-method))
339
340(defmethod documentation ((c structure-class) (doc-type (eql 't)))
341  (documentation c 'type))
342
343(defmethod (setf documentation) ((new t)
344                                 (c structure-class)
345                                 (doc-type (eql 't)))
346  (setf (documentation c 'type) new))
347
348;;; This is now deprecated; things which call it should stop doing so.
349(defun set-documentation (symbol doc-type string)
350  (setf (documentation symbol doc-type) string))
351
352(defun set-function-info (symbol info)
353  (let* ((doc-string (if (consp info) (car info) info)))
354    (if (and *save-doc-strings* (stringp doc-string))
355      (set-documentation  symbol 'function doc-string)))
356  (let* ((cons (assq symbol *nx-globally-inline*))
357         (lambda-expression (if (consp info) (cdr info))))
358    (if (and (proclaimed-inline-p symbol)
359             (not (compiler-special-form-p symbol))
360             (lambda-expression-p lambda-expression)
361             (let* ((lambda-list (cadr lambda-expression)))
362               (and (not (memq '&lap lambda-list))
363                    (not (memq '&method lambda-list))
364                    (not (memq '&lexpr lambda-list)))))
365      (if cons 
366        (%rplacd cons lambda-expression)
367        (push (cons symbol lambda-expression) *nx-globally-inline*))
368      (if cons (setq *nx-globally-inline* (delete cons *nx-globally-inline*)))))
369  symbol)
370
371
372(setf (documentation 'if 'function)
373      "If Predicate Then [Else]
374  If Predicate evaluates to non-null, evaluate Then and returns its values,
375  otherwise evaluate Else and return its values. Else defaults to NIL.")
376
377(setf (documentation 'progn 'function)
378      "progn form*
379  Evaluates each FORM and returns the value(s) of the last FORM.")
380
381(defmethod documentation ((thing character-encoding) (doc-type (eql t)))
382  (character-encoding-documentation thing))
383
384(defmethod (setf documentation) (new (thing character-encoding) (doc-type (eql t)))
385  (check-type new (or null string))
386  (setf (character-encoding-documentation thing) new))
387
388(defmethod documentation ((thing symbol) (doc-type (eql 'character-encoding)))
389  (let* ((encoding (lookup-character-encoding (intern (string thing) :keyword))))
390    (when encoding
391      (documentation encoding t))))
392
393                                 
394
395
396#|
397(setf (documentation 'car 'variable) "Preferred brand of automobile")
398(documentation 'car 'variable)
399(setf (documentation 'foo 'structure) "the structure is grand.")
400(documentation 'foo 'structure)
401(setf (documentation 'foo 'variable) "the metasyntactic remarker")
402(documentation 'foo 'variable)
403(setf (documentation 'foo 'obscure) "no one really knows what it means")
404(documentation 'foo 'obscure)
405(setf (documentation 'foo 'structure) "the structure is solid")
406(documentation 'foo 'function)
407||#
408
409;;
410
411
412(defun %page-fault-info ()
413  #-(or darwin-target windows-target)
414  (rlet ((usage :rusage))
415    (%%rusage usage)
416    (values (pref usage :rusage.ru_minflt)
417            (pref usage :rusage.ru_majflt)
418            (pref usage :rusage.ru_nswap)))
419  #+darwin-target
420  (rlet ((count #>mach_msg_type_number_t #$TASK_EVENTS_INFO_COUNT)
421         (info #>task_events_info))
422    (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count)
423    (values (pref info #>task_events_info.cow_faults)
424            (pref info #>task_events_info.faults)
425            (pref info #>task_events_info.pageins)))
426  #+windows-target
427  ;; Um, don't know how to determine this, or anything like it.
428  (values 0 0 0))
429
430
431         
432(defparameter *report-time-function* nil
433  "If non-NULL, should be a function which accepts the following
434   keyword arguments:
435   :FORM              the form that was executed
436   :RESULTS           a list of all values returned by the execution of FORM
437   :ELAPSED-TIME      total elapsed (real) time, in internal-time-units-per-second
438   :USER-TIME         elapsed user time, in internal-time-units-per-second
439   :SYSTEM-TIME       elapsed system time, in internal-time-units-per-second
440   :GC-TIME           total real time spent in the GC, in internal-time-units-per-second
441   :BYTES-ALLOCATED   total bytes allocated
442   :MINOR-PAGE-FAULTS minor page faults
443   :MAJOR-PAGE-FAULTS major page faults
444   :SWAPS             swaps")
445
446
447(defun standard-report-time (&key form results elapsed-time user-time
448                                  system-time gc-time bytes-allocated
449                                  minor-page-faults major-page-faults
450                                  swaps)
451  (let* ((s *trace-output*)
452         (units
453          (ecase internal-time-units-per-second
454            (1000000 "microseconds")
455            (1000  "milliseconds")))
456         (width
457          (ecase internal-time-units-per-second
458            (1000000 6)
459            (1000  3)))
460         (cpu-count (cpu-count)))
461    (format s "~&~S took ~:D ~a (~,vF seconds) to run ~%~20twith ~D available CPU core~P."
462            form elapsed-time units width (/ elapsed-time internal-time-units-per-second) cpu-count cpu-count)
463    (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))
464    (format s "~&                    ~:D ~a (~,vF seconds) were spent in system mode" system-time units width(/ system-time internal-time-units-per-second))
465    (unless (eql gc-time 0)
466      (format s
467              "~%~:D ~a (~,vF seconds) was spent in GC."
468              gc-time units width (/ gc-time internal-time-units-per-second)))
469    (unless (eql 0 bytes-allocated)
470      (format s "~% ~:D bytes of memory allocated." bytes-allocated))
471    (when (or (> minor-page-faults 0)
472              (> major-page-faults 0)
473              (> swaps 0))
474      (format s
475              "~% ~:D minor page faults, ~:D major page faults, ~:D swaps."
476              minor-page-faults major-page-faults swaps))
477    (format s "~&")
478    (values-list results)))
479
480(defun report-time (form thunk)
481  (flet ((integer-size-in-bytes (i)
482           (if (typep i 'fixnum)
483             0
484             (* (logand (+ 2 (uvsize i)) (lognot 1)) 4))))
485    (multiple-value-bind (user-start system-start)
486        (%internal-run-time)
487      (multiple-value-bind (minor-start major-start swaps-start)
488          (%page-fault-info)
489        (let* ((initial-real-time (get-internal-real-time))
490               (initial-gc-time (gctime))
491               (initial-consed (total-bytes-allocated))           
492               (initial-overhead (integer-size-in-bytes initial-consed)))
493          (let* ((results (multiple-value-list (funcall thunk))))
494            (declare (dynamic-extent results))
495            (multiple-value-bind (user-end system-end)
496                (%internal-run-time)
497              (multiple-value-bind (minor-end major-end swaps-end)
498                  (%page-fault-info)
499                (let* ((new-consed (total-bytes-allocated))                 
500                       (bytes-consed
501                        (- new-consed (+ initial-overhead initial-consed)))
502                       (elapsed-real-time
503                        (- (get-internal-real-time) initial-real-time))
504                       (elapsed-gc-time (- (gctime) initial-gc-time))
505                       (elapsed-user-time
506                        (- user-end user-start))
507                       (elapsed-system-time
508                        (- system-end system-start))
509                       (elapsed-minor (- minor-end minor-start))
510                       (elapsed-major (- major-end major-start))
511                       (elapsed-swaps (- swaps-end swaps-start)))
512                  (funcall (or *report-time-function*
513                               #'standard-report-time)
514                           :form form
515                           :results results
516                           :elapsed-time elapsed-real-time
517                           :user-time elapsed-user-time
518                           :system-time elapsed-system-time
519                           :gc-time elapsed-gc-time
520                           :bytes-allocated bytes-consed
521                           :minor-page-faults elapsed-minor
522                           :major-page-faults elapsed-major
523                           :swaps elapsed-swaps))))))))))
524
525
526
527
528;;; site names and machine-instance is in the init file.
529
530(defun add-feature (symbol)
531  "Not CL but should be."
532  (if (symbolp symbol)
533      (if (not (memq symbol *features*))
534          (setq *features* (cons symbol *features*)))))
535
536;;; (dotimes (i 5000) (declare (fixnum i)) (add-feature 'junk))
537
538
539
540
541;;; Misc string functions
542
543
544(defun string-left-trim (char-bag string &aux end)
545  "Given a set of characters (a list or string) and a string, returns
546  a copy of the string with the characters in the set removed from the
547  left end."
548  (setq string (string string))
549  (setq end (length string))
550  (do ((index 0 (%i+ index 1)))
551      ((or (eq index end) (not (find (aref string index) char-bag)))
552       (subseq string index end))))
553
554(defun string-right-trim (char-bag string &aux end)
555  "Given a set of characters (a list or string) and a string, returns
556  a copy of the string with the characters in the set removed from the
557  right end."
558  (setq string (string string))
559  (setq end (length string))
560  (do ((index (%i- end 1) (%i- index 1)))
561      ((or (%i< index 0) (not (find (aref string index) char-bag)))
562       (subseq string 0 (%i+ index 1)))))
563
564(defun string-trim (char-bag string &aux end)
565  "Given a set of characters (a list or string) and a string, returns a
566  copy of the string with the characters in the set removed from both
567  ends."
568  (setq string (string string))
569  (setq end (length string))
570  (let ((left-end) (right-end))
571     (do ((index 0 (%i+ index 1)))
572         ((or (eq index end) (not (find (aref string index) char-bag)))
573          (setq left-end index)))
574     (do ((index (%i- end 1) (%i- index 1)))
575         ((or (%i< index left-end) (not (find (aref string index) char-bag)))
576          (setq right-end index)))
577      (subseq string left-end (%i+ right-end 1))))
578
579
580
581(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol def)
582  "Make and return a new uninterned symbol with the same print name
583  as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound
584  nor fbound and has no properties, else it has a copy of SYMBOL's
585  function, value and property list."
586  (setq new-symbol (make-symbol (symbol-name symbol)))
587  (when copy-props
588      (when (boundp symbol)
589            (set new-symbol (symbol-value symbol)))
590      (when (setq def (fboundp symbol))
591            ;;;Shouldn't err out on macros/special forms.
592            (%fhave new-symbol def))
593      (set-symbol-plist new-symbol (copy-list (symbol-plist symbol))))
594  new-symbol)
595
596
597(defvar %gentemp-counter 0
598  "Counter for generating unique GENTEMP symbols.")
599
600(defun gentemp (&optional (prefix "T") (package *package*))
601  "Creates a new symbol interned in package PACKAGE with the given PREFIX."
602  (loop
603    (let* ((new-pname (%str-cat (ensure-simple-string prefix) 
604                                (%integer-to-string %gentemp-counter)))
605           (sym (find-symbol new-pname package)))
606      (if sym
607        (setq %gentemp-counter (%i+ %gentemp-counter 1))
608        (return (values (intern new-pname package))))))) ; 1 value.
609
610
611
612
613(defun add-gc-hook (hook-function &optional (which-hook :pre-gc))
614  (ecase which-hook
615    (:pre-gc
616     (pushnew hook-function *pre-gc-hook-list*)
617     (setq *pre-gc-hook* #'(lambda ()
618                             (dolist (hook *pre-gc-hook-list*)
619                               (funcall hook)))))
620    (:post-gc
621     (pushnew hook-function *post-gc-hook-list*)
622     (setq *post-gc-hook* #'(lambda ()
623                             (dolist (hook *post-gc-hook-list*)
624                               (funcall hook))))))
625  hook-function)
626
627(defun remove-gc-hook (hook-function &optional (which-hook :pre-gc))
628  (ecase which-hook
629    (:pre-gc
630     (unless (setq *pre-gc-hook-list* (delq hook-function *pre-gc-hook-list*))
631       (setq *pre-gc-hook* nil)))
632    (:post-gc
633     (unless (setq *post-gc-hook-list* (delq hook-function *post-gc-hook-list*))
634       (setq *post-gc-hook* nil)))))
635
636
637
638
639
640
641(defun find-method-by-names (name qualifiers specializers)
642  (let ((gf (fboundp name)))
643    (when gf
644      (if (not (standard-generic-function-p gf))
645        (error "~S is not a generic-function." gf)
646        (let ((methods (%gf-methods gf)))
647          (when methods
648            (let* ((spec-len (length (%method-specializers (car methods))))
649                   (new-specs (make-list spec-len :initial-element (find-class t))))
650              (declare (dynamic-extent new-specs))
651              (do ((specs specializers (cdr specs))
652                   (nspecs new-specs (cdr nspecs)))
653                  ((or (null specs) (null nspecs)))
654                (let ((s (car specs)))
655                  (rplaca nspecs (if (consp s) s (find-class s nil)))))
656              (find-method gf qualifiers new-specs nil))))))))
657
658
659
660
661(defun make-population (&key (type :list) initial-contents)
662  (let* ((ntype (ecase type
663                  (:list $population_weak-list)
664                  (:alist $population_weak-alist)))
665         (list (if (eq type :alist)
666                 (map 'list (lambda (c) (cons (car c) (%cdr c))) initial-contents)
667                 (if (listp initial-contents)
668                   (copy-list initial-contents)
669                   (coerce initial-contents 'list)))))
670    (%cons-population list ntype)))
671
672(defun population-type (population)
673  (let ((ntype (population.type (require-type population 'population))))
674    (cond ((eq ntype $population_weak-alist) :alist)
675          ((eq ntype $population_weak-list) :list)
676          (t nil))))
677
678(declaim (inline population-contents (setf population-contents)))
679
680(defun population-contents (population)
681  (population.data (require-type population 'population)))
682
683(defun (setf population-contents) (list population)
684  (setf (population.data (require-type population 'population)) (require-type list 'list)))
685
686
687
688
689(defun get-string-from-user (prompt)
690  (with-terminal-input
691      (format *query-io* "~&~a " prompt)
692    (force-output *query-io*)
693    (clear-input *query-io*)
694    (values (read-line *query-io*))))
695
696
697(defun select-item-from-list (list &key (window-title "Select one of the following")
698                                   (table-print-function #'prin1)
699                                   &allow-other-keys)
700  (block get-answer
701    (with-terminal-input
702      (format *query-io* "~a:~%" window-title)
703      (loop
704         (catch :redisplay
705           (do* ((l list (cdr l))
706                 (i 0 (1+ i))
707                 (item (car l) (car l)))
708                ((null l))
709             (declare (fixnum i))
710             (format *query-io* "~&  ~d: " i)
711             (funcall table-print-function item *query-io*))
712           (loop
713              (fresh-line *query-io*)
714              (let* ((string (get-string-from-user "Selection [number,q,r,?]:"))
715                     (value (ignore-errors
716                              (let* ((*package* *keyword-package*))
717                                (read-from-string string nil)))))
718                (cond ((eq value :q) (throw :cancel t))
719                      ((eq value :r) (throw :redisplay t))
720                      ((eq value :?) 
721                       (format *query-io* "~%Enter the number of the selection, ~%  r to redisplay, ~%  q to cancel or ~%  ? to show this message again."))
722                      ((and (typep value 'unsigned-byte)
723                            (< value (length list)))
724                       (return-from get-answer (list (nth value list))))))))))))
725
726(defvar *choose-file-dialog-hook* nil "for GUIs")
727
728;;; There should ideally be some way to override the UI (such as
729;;; it is ...) here.
730;;; More generally, this either
731;;;   a) shouldn't exist, or
732;;;   b) should do more sanity-checking
733(defun choose-file-dialog (&key file-types (prompt "File name:"))
734  (let* ((hook *choose-file-dialog-hook*))
735    (if hook
736      (funcall hook t prompt file-types)
737      (%choose-file-dialog t prompt file-types))))
738
739(defun choose-new-file-dialog (&key prompt)
740  (let* ((hook *choose-file-dialog-hook*))
741    (if hook
742      (funcall hook nil prompt nil)
743      (%choose-file-dialog nil prompt nil))))
744
745(defun %choose-file-dialog (must-exist prompt file-types)
746  (loop
747      (let* ((namestring (get-string-from-user prompt))
748             (pathname (ignore-errors (pathname namestring)))
749             (exists (and pathname (probe-file pathname))))
750        (when (and (if must-exist exists)
751                   (or (null file-types)
752                       (member (pathname-type pathname)
753                               file-types :test #'equal)))
754          (return pathname))
755        (if (not exists)
756          (format *query-io* "~&~s does not exist." namestring)
757          (format *query-io* "~&Type of ~s is not one of ~{~a~}"
758                  namestring file-types)))))
759
760(defparameter *overwrite-dialog-hook* nil)
761(defun overwrite-dialog (filename prompt)
762  (if *overwrite-dialog-hook*
763    (funcall *overwrite-dialog-hook* filename prompt)
764    t))
765
766;;; Might want to have some other entry for, e.g., the inspector
767;;; and to let it get its hands on the list header returned by
768;;; disassemble-ppc-function.  Maybe disassemble-ppc-function
769;;; should take care of "normalizing" the code-vector ?
770(defun disassemble (thing)
771  "Disassemble the compiled code associated with OBJECT, which can be a
772  function, a lambda expression, or a symbol with a function definition. If
773  it is not already compiled, the compiler is called to produce something to
774  disassemble."
775  (#+ppc-target ppc-xdisassemble
776   #+x86-target x86-xdisassemble
777   (require-type (function-for-disassembly thing) 'compiled-function)))
778
779(defun function-for-disassembly (thing)
780  (let* ((fun thing))
781    ;; CLHS says that DISASSEMBLE should signal a type error if its
782    ;; argument isn't a function designator.  Hard to imagine any
783    ;; code depending on that ...
784    ;;(when (typep fun 'standard-method) (setq fun (%method-function fun)))
785    (when (or (symbolp fun)
786              (and (consp fun) (neq (%car fun) 'lambda)))
787      (setq fun (fboundp thing))
788      (when (and (symbolp thing) (not (functionp fun)))
789        (setq fun (macro-function thing))))
790    (if (typep fun 'compiled-lexical-closure)
791        (setq fun (closure-function fun)))
792    (when (lambda-expression-p fun)
793      (setq fun (compile-named-function fun)))
794    fun))
795
796(%fhave 'df #'disassemble)
797
798(defun string-sans-most-whitespace (string &optional (max-length (length string)))
799  (with-output-to-string (sans-whitespace)
800    (loop
801      for count below max-length
802      for char across string
803      with just-saw-space = nil
804      if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed))
805        do (if just-saw-space
806               (decf count)
807               (write-char #\Space sans-whitespace))
808        and do (setf just-saw-space t)
809      else
810        do (setf just-saw-space nil)
811        and do (write-char char sans-whitespace))))
812
813
814(defparameter *svn-program* "svn")
815
816(defloadvar *use-cygwin-svn*
817    #+windows-target (not (null (getenv "CYGWIN")))
818    #-windows-target nil)
819
820(defun svn-info-component (component)
821  (let* ((component-length (length component)))
822    (let* ((s (make-string-output-stream)))
823      (multiple-value-bind (status exit-code)
824          (external-process-status
825           (run-program *svn-program*  (list "info" (native-translated-namestring "ccl:")) :output s :error :output))
826        (when (and (eq :exited status) (zerop exit-code))
827          (with-input-from-string (output (get-output-stream-string s))
828            (do* ((line (read-line output nil nil) (read-line output nil nil)))
829                 ((null line))
830              (when (and (>= (length line) component-length)
831                         (string= component line :end2 component-length))
832                (return-from svn-info-component
833                  (string-trim " " (subseq line component-length)))))))))
834    nil))
835
836(defun svn-url () (svn-info-component "URL:"))
837(defun svn-repository () (svn-info-component "Repository Root:"))
838
839;;; Try to say something about what tree (trunk, a branch, a release)
840;;; we were built from. If the URL (relative to the repository)
841;;; starts with "branches", return the second component of the
842;;; relative URL, otherwise return the first component.
843(defun svn-tree ()
844  (let* ((repo (svn-repository))
845         (url (svn-url)))
846    (or 
847     (if (and repo url)
848       (let* ((repo-len (length repo)))
849         (when (and (> (length url) repo-len)
850                    (string= repo url :end2 repo-len))
851           ;; Cheat: do pathname parsing here.
852           (let* ((path (pathname (ensure-directory-namestring (subseq url repo-len))))
853                  (dir (cdr (pathname-directory path))))
854             (when (string= "ccl" (car (last dir)))
855               (let* ((base (car dir)))
856                 (unless (or (string= base "release")
857                             (string= base "releases"))
858                   (if (string= base "branches")
859                     (cadr dir)
860                     (car dir))))))))))))
861
862
863(defun svnversion-program ()
864  (or (ignore-errors
865        (native-translated-namestring
866         (merge-pathnames "svnversion" *svn-program*)))
867      "svnversion"))
868       
869                     
870       
871                         
872(defun local-svn-revision ()
873  (let* ((s (make-string-output-stream))
874         (root (native-translated-namestring "ccl:")))
875    (when *use-cygwin-svn*
876      (setq root (cygpath root)))
877    (multiple-value-bind (status exit-code)
878        (external-process-status
879         (run-program (svnversion-program)  (list  (native-translated-namestring "ccl:") (or (svn-url) "")) :output s :error :output))
880      (when (and (eq :exited status) (zerop exit-code))
881        (with-input-from-string (output (get-output-stream-string s))
882          (let* ((line (read-line output nil nil)))
883            (when (and line (parse-integer line :junk-allowed t) )
884              (return-from local-svn-revision line))))))
885    nil))
886
887
888;;; Scan the heap, collecting infomation on the primitive object types
889;;; found.  Report that information.
890
891(defun heap-utilization (&key (stream *debug-io*)
892                              (gc-first t))
893  (let* ((nconses 0)
894         (nvectors (make-array 256))
895         (vector-sizes (make-array 256))
896         (vector-physical-sizes (make-array 256))
897         (array-size-function (arch::target-array-data-size-function
898                               (backend-target-arch *host-backend*))))
899    (declare (type (simple-vector 256) nvectors vector-sizes)
900             (dynamic-extent nvectors vector-sizes vector-physical-sizes))
901    (when gc-first (gc))
902    (%map-areas (lambda (thing)
903                  (if (listp thing)
904                    (incf nconses)
905                    (let* ((typecode (typecode thing))
906                           (logsize (funcall array-size-function typecode (uvsize thing))))
907                      (incf (aref nvectors typecode))
908                      (incf (aref vector-sizes typecode) logsize)
909                      (incf (aref vector-physical-sizes typecode)
910                            (logandc2 (+ logsize
911                                         #+64-bit-target (+ 8 15)
912                                         #+32-bit-target (+ 4 7))
913                                      #+64-bit-target 15
914                                      #+32-bit-target 7))))))
915                                         
916    (report-heap-utilization stream nconses nvectors vector-sizes vector-physical-sizes)
917    (values)))
918
919(defvar *heap-utilization-vector-type-names*
920  (let* ((a (make-array 256)))
921    #+x8664-target
922    (dotimes (i 256)
923      (let* ((fulltag (logand i x8664::fulltagmask))
924             (names-vector
925              (cond ((= fulltag x8664::fulltag-nodeheader-0)
926                     *nodeheader-0-types*)
927                    ((= fulltag x8664::fulltag-nodeheader-1)
928                     *nodeheader-1-types*)
929                    ((= fulltag x8664::fulltag-immheader-0)
930                     *immheader-0-types*)
931                    ((= fulltag x8664::fulltag-immheader-1)
932                     *immheader-1-types*)
933                    ((= fulltag x8664::fulltag-immheader-2)
934                     *immheader-2-types*)))
935             (name (if names-vector
936                     (aref names-vector (ash i -4)))))
937        ;; Special-case a few things ...
938        (if (eq name 'symbol-vector)
939          (setq name 'symbol)
940          (if (eq name 'function-vector)
941            (setq name 'function)))
942        (setf (aref a i) name)))
943    #+ppc64-target
944    (dotimes (i 256)
945      (let* ((lowtag (logand i ppc64::lowtagmask)))
946        (setf (%svref a i)
947              (cond ((= lowtag ppc64::lowtag-immheader)
948                     (%svref *immheader-types* (ash i -2)))
949                    ((= lowtag ppc64::lowtag-nodeheader)
950                     (%svref *nodeheader-types* (ash i -2)))))))
951    #+(or ppc32-target x8632-target)
952    (dotimes (i 256)
953      (let* ((fulltag (logand i target::fulltagmask)))
954        (setf (%svref a i)
955              (cond ((= fulltag target::fulltag-immheader)
956                     (%svref *immheader-types* (ash i -3)))
957                    ((= fulltag target::fulltag-nodeheader)
958                     (%svref *nodeheader-types* (ash i -3)))))))
959    a))
960
961 
962   
963(defun report-heap-utilization (out nconses nvectors vector-sizes vector-physical-sizes)
964  (let* ((total-cons-size  (* nconses target::cons.size))
965         (total-vector-size 0)
966         (total-physical-vector-size 0))
967    (format out "~&Object type~40tCount~48tTotal Size in Bytes~70tTotal Size")
968    (format out "~&CONS~34t~12d~46t~16d~16d" nconses total-cons-size total-cons-size)
969    (dotimes (i (length nvectors))
970      (let* ((count (aref nvectors i))
971             (sizes (aref vector-sizes i))
972             (psizes (aref vector-physical-sizes i)))
973        (unless (zerop count)
974          (incf total-vector-size sizes)
975          (incf total-physical-vector-size psizes)
976          (format out "~&~a~34t~12d~46t~16d~16d" (aref *heap-utilization-vector-type-names* i)  count sizes psizes))))
977    (format out "~&   Total sizes: ~47t~16d~16d" (+ total-cons-size total-vector-size) (+ total-cons-size total-physical-vector-size))))
978                           
979;; The number of words to allocate for static conses when the user requests
980;; one and we don't have any left over
981(defparameter *static-cons-chunk* 1048576)
982
983(defun initialize-static-cons ()
984  "Activates collection of garbage conses in the static-conses
985   list and allocates initial static conses."
986  ; There might be a race here when multiple threads call this
987  ; function.  However, the discarded static conses will become
988  ; garbage and be added right back to the list.  No harm here
989  ; except for additional garbage collections.
990  (%set-kernel-global 'static-conses nil)
991  (allocate-static-conses))
992
993(defun allocate-static-conses ()
994  "Allocates some memory, freezes it and lets it become garbage.
995   This will add the memory to the list of free static conses."
996  (let* ((nfullgc (full-gccount)))
997    (multiple-value-bind (head tail)
998        (%allocate-list 0 *static-cons-chunk*)
999      (if (eql (full-gccount) nfullgc)
1000        (freeze)
1001        (flash-freeze))
1002      (%augment-static-conses head tail))))
1003
1004(defun static-cons (car-value cdr-value)
1005  "Allocates a cons cell that doesn't move on garbage collection,
1006   and thus doesn't trigger re-hashing when used as a key in a hash
1007   table.  Usage is equivalent to regular CONS."
1008  (when (eq (%get-kernel-global 'static-conses) 0)
1009    (initialize-static-cons))
1010  (let ((cell (%atomic-pop-static-cons)))
1011    (if cell
1012      (progn
1013        (setf (car cell) car-value)
1014        (setf (cdr cell) cdr-value)
1015        cell)
1016      (progn
1017        (allocate-static-conses)
1018        (static-cons car-value cdr-value)))))
1019       
1020
1021(defparameter *weak-gc-method-names*
1022  '((:traditional . 0)
1023    (:non-circular . 1)))
1024
1025
1026(defun weak-gc-method ()
1027  (or (car (rassoc (%get-kernel-global 'weak-gc-method)
1028                   *weak-gc-method-names*))
1029      :traditional))
1030
1031
1032(defun (setf weak-gc-method) (name)
1033  (setf (%get-kernel-global 'weak-gc-method)
1034        (or (cdr (assoc name *weak-gc-method-names*))
1035            0))
1036  name)
1037
1038(defun %lock-whostate-string (string lock)
1039  (with-standard-io-syntax
1040      (format nil "~a for ~a ~@[~a ~]@ #x~x"
1041              string
1042              (%svref lock target::lock.kind-cell)
1043              (lock-name lock)
1044              (%ptr-to-int (%svref lock target::lock._value-cell)))))
1045
1046(defun watch (&optional thing)
1047  (if thing
1048    (progn
1049      (require-type thing '(or cons (satisfies uvectorp)))
1050      (%watch thing))
1051    (let (result)
1052      (%map-areas #'(lambda (x) (push x result)) area-watched area-watched)
1053      result)))
1054
1055(defun unwatch (thing)
1056  (%map-areas #'(lambda (x)
1057                  (when (eq x thing)
1058                    ;; This is a rather questionable thing to do,
1059                    ;; since we'll be unlinking an area from the area
1060                    ;; list while %map-areas iterates over it, but I
1061                    ;; think we'll get away with it.
1062                    (let ((new (if (uvectorp thing)
1063                                 (%alloc-misc (uvsize thing) (typecode thing))
1064                                 (cons nil nil))))
1065                      (return-from unwatch (%unwatch thing new)))))
1066              area-watched area-watched))
1067
1068;;; These functions would seem to belong somewhere else.
1069     
1070;; This will work only if the uvector is in a static gc area.
1071(defun %uvector-index-for-address (uvector address)
1072  (let* ((size (uvsize uvector))
1073         (nbytes (if (ivectorp uvector)
1074                   (subtag-bytes (typecode uvector) size)
1075                   (* size target::node-size)))
1076         (bytes-per-element (/ nbytes size))
1077         (noderef (logandc2 (%address-of uvector)
1078                            target::fulltagmask))
1079         (offset (- address (+ noderef target::node-size)))
1080         (index (/ offset bytes-per-element)))
1081    index))
1082
1083(defun x86-imm-reg-p (reg-num)
1084  (member reg-num (list x8664::imm0 x8664::imm1 x8664::imm2
1085                        x8664::imm0.l x8664::imm0.l x8664::imm2.l
1086                        x8664::imm0.w x8664::imm0.w x8664::imm2.w
1087                        x8664::imm0.b x8664::imm0.b x8664::imm2.b)))
1088
1089;;; Try to emulate the instruction.  Returns true on success,
1090;;; NIL on failure.  If dest isn't in a static area, we will lose...
1091(defun x86-emulate-write-instruction (xp insn addr dest)
1092  (let ((op0 (x86-di-op0 insn)))
1093    (unless (and (typep op0 'x86::x86-register-operand)
1094                 (string= (subseq (x86-di-mnemonic insn) 0 3) "mov"))
1095      (return-from x86-emulate-write-instruction nil))
1096    (let* ((reg-entry (x86::x86-register-operand-entry op0))
1097           (reg-num (x86::reg-entry-reg-num reg-entry)))
1098      (if (uvectorp dest)
1099        (cond ((gvectorp dest)
1100               (let* ((src (encoded-gpr-lisp xp reg-num))
1101                      (index (%uvector-index-for-address dest addr)))
1102                 (if (fixnump index)
1103                   (setf (uvref dest index) src))))
1104              ((ivectorp dest)
1105               (let* ((src (if (x86-imm-reg-p reg-num)
1106                             (encoded-gpr-integer xp reg-num)
1107                             (encoded-gpr-lisp xp reg-num)))
1108                      (index (%uvector-index-for-address dest addr)))
1109                 (if (fixnump index)
1110                   (setf (uvref dest index) src))
1111               (setq src (encoded-gpr-lisp xp reg-num)))))
1112        (if (consp dest)
1113          (let* ((src (encoded-gpr-lisp xp reg-num)))
1114            (if (= addr (+ (%address-of dest) target::cons.cdr))
1115              (rplacd dest src)
1116              (if (= addr (+ (%address-of dest) target::cons.car))
1117                (rplaca dest src)))))))))
Note: See TracBrowser for help on using the repository browser.