/[slime]/slime/swank-sbcl.lisp
ViewVC logotype

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.319 - (hide annotations)
Fri May 11 06:52:05 2012 UTC (23 months, 1 week ago) by heller
Branch: MAIN
Changes since 1.318: +0 -7 lines
* swank-backend.lisp (call-with-io-timeout): Not used. Deleted.
* swank-sbcl.lisp (call-with-io-timeout): Deleted.
1 heller 1.316 ;;;;; -*- indent-tabs-mode: nil -*-
2 dbarlow 1.1 ;;;
3     ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4     ;;;
5     ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6     ;;;
7 jsnellman 1.158 ;;; This code has been placed in the Public Domain. All warranties are
8 dbarlow 1.1 ;;; disclaimed.
9    
10 heller 1.106 ;;; Requires the SB-INTROSPECT contrib.
11 dbarlow 1.1
12     ;;; Administrivia
13    
14 heller 1.146 (in-package :swank-backend)
15    
16 dbarlow 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
17     (require 'sb-bsd-sockets)
18 heller 1.59 (require 'sb-introspect)
19 trittweiler 1.179 (require 'sb-posix)
20 nsiivola 1.308 (require 'sb-cltl2)
21     (import-from :sb-gray *gray-stream-symbols* :swank-backend))
22 heller 1.107
23 heller 1.196 (declaim (optimize (debug 2)
24     (sb-c::insert-step-conditions 0)
25 nsiivola 1.315 (sb-c::insert-debug-catch 0)))
26 dbarlow 1.1
27 jsnellman 1.166 ;;; backwards compability tests
28    
29     (eval-when (:compile-toplevel :load-toplevel :execute)
30     ;; Generate a form suitable for testing for stepper support (0.9.17)
31     ;; with #+.
32     (defun sbcl-with-new-stepper-p ()
33 trittweiler 1.233 (with-symbol 'enable-stepping 'sb-impl))
34 nsiivola 1.170 ;; Ditto for weak hash-tables
35     (defun sbcl-with-weak-hash-tables ()
36 trittweiler 1.233 (with-symbol 'hash-table-weakness 'sb-ext))
37 jsnellman 1.172 ;; And for xref support (1.0.1)
38     (defun sbcl-with-xref-p ()
39 trittweiler 1.233 (with-symbol 'who-calls 'sb-introspect))
40 jsnellman 1.174 ;; ... for restart-frame support (1.0.2)
41     (defun sbcl-with-restart-frame ()
42 trittweiler 1.233 (with-symbol 'frame-has-debug-tag-p 'sb-debug)))
43 jsnellman 1.166
44 mbaringer 1.100 ;;; swank-mop
45    
46 heller 1.106 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
47 mbaringer 1.100
48 mbaringer 1.101 (defun swank-mop:slot-definition-documentation (slot)
49 jsnellman 1.158 (sb-pcl::documentation slot t))
50 mbaringer 1.100
51 trittweiler 1.194 ;;; Connection info
52    
53     (defimplementation lisp-implementation-type-name ()
54     "sbcl")
55    
56     ;; Declare return type explicitly to shut up STYLE-WARNINGS about
57     ;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
58     (declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
59     (defimplementation getpid ()
60     (sb-posix:getpid))
61    
62 heller 1.290 ;;; UTF8
63    
64     (defimplementation string-to-utf8 (string)
65     (sb-ext:string-to-octets string :external-format :utf8))
66    
67     (defimplementation utf8-to-string (octets)
68     (sb-ext:octets-to-string octets :external-format :utf8))
69    
70 dbarlow 1.1 ;;; TCP Server
71    
72 lgorrie 1.132 (defimplementation preferred-communication-style ()
73 crhodes 1.155 (cond
74     ;; fixme: when SBCL/win32 gains better select() support, remove
75     ;; this.
76 sboukarev 1.289 ((member :sb-thread *features*) :spawn)
77 crhodes 1.155 ((member :win32 *features*) nil)
78     (t :fd-handler)))
79 jsnellman 1.158
80 heller 1.65 (defun resolve-hostname (name)
81     (car (sb-bsd-sockets:host-ent-addresses
82     (sb-bsd-sockets:get-host-by-name name))))
83    
84 heller 1.294 (defimplementation create-socket (host port &key backlog)
85 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
86     :type :stream
87     :protocol :tcp)))
88 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
89 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
90 heller 1.294 (sb-bsd-sockets:socket-listen socket (or backlog 5))
91 heller 1.29 socket))
92    
93 lgorrie 1.54 (defimplementation local-port (socket)
94 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
95    
96 lgorrie 1.54 (defimplementation close-socket (socket)
97 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
98 heller 1.48 (sb-bsd-sockets:socket-close socket))
99    
100 jsnellman 1.158 (defimplementation accept-connection (socket &key
101 heller 1.160 external-format
102     buffering timeout)
103 dcrosher 1.153 (declare (ignore timeout))
104 heller 1.291 (make-socket-io-stream (accept socket) external-format
105     (ecase buffering
106     ((t :full) :full)
107     ((nil :none) :none)
108     ((:line) :line))))
109 heller 1.48
110 heller 1.214 #-win32
111 heller 1.213 (defimplementation install-sigint-handler (function)
112     (sb-sys:enable-interrupt sb-unix:sigint
113     (lambda (&rest args)
114     (declare (ignore args))
115 heller 1.221 (sb-sys:invoke-interruption
116     (lambda ()
117     (sb-sys:with-interrupts
118     (funcall function)))))))
119 heller 1.213
120 heller 1.59 (defvar *sigio-handlers* '()
121     "List of (key . fn) pairs to be called on SIGIO.")
122    
123     (defun sigio-handler (signal code scp)
124 heller 1.60 (declare (ignore signal code scp))
125     (mapc (lambda (handler)
126     (funcall (the function (cdr handler))))
127     *sigio-handlers*))
128 heller 1.59
129     (defun set-sigio-handler ()
130 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
131 heller 1.59 (sigio-handler signal code scp))))
132    
133 heller 1.62 (defun enable-sigio-on-fd (fd)
134 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
135 trittweiler 1.194 (sb-posix::fcntl fd sb-posix::f-setown (getpid))
136     (values))
137 heller 1.62
138 heller 1.67 (defimplementation add-sigio-handler (socket fn)
139 heller 1.62 (set-sigio-handler)
140     (let ((fd (socket-fd socket)))
141     (enable-sigio-on-fd fd)
142     (push (cons fd fn) *sigio-handlers*)))
143    
144 heller 1.67 (defimplementation remove-sigio-handlers (socket)
145 heller 1.59 (let ((fd (socket-fd socket)))
146     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
147 jsnellman 1.158 (sb-sys:invalidate-descriptor fd))
148 heller 1.51 (close socket))
149 heller 1.67
150 heller 1.244 (defimplementation add-fd-handler (socket fun)
151     (let ((fd (socket-fd socket))
152     (handler nil))
153     (labels ((add ()
154     (setq handler (sb-sys:add-fd-handler fd :input #'run)))
155     (run (fd)
156     (sb-sys:remove-fd-handler handler) ; prevent recursion
157     (unwind-protect
158     (funcall fun)
159     (when (sb-unix:unix-fstat fd) ; still open?
160     (add)))))
161     (add))))
162 heller 1.67
163     (defimplementation remove-fd-handlers (socket)
164     (sb-sys:invalidate-descriptor (socket-fd socket)))
165 heller 1.51
166 heller 1.274 (defimplementation socket-fd (socket)
167 heller 1.48 (etypecase socket
168     (fixnum socket)
169     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
170     (file-stream (sb-sys:fd-stream-fd socket))))
171    
172 heller 1.274 (defimplementation command-line-args ()
173     sb-ext:*posix-argv*)
174    
175     (defimplementation dup (fd)
176     (sb-posix:dup fd))
177    
178 heller 1.221 (defvar *wait-for-input-called*)
179    
180     (defimplementation wait-for-input (streams &optional timeout)
181     (assert (member timeout '(nil t)))
182     (when (boundp '*wait-for-input-called*)
183     (setq *wait-for-input-called* t))
184     (let ((*wait-for-input-called* nil))
185     (loop
186 nsiivola 1.298 (let ((ready (remove-if-not #'input-ready-p streams)))
187     (when ready (return ready)))
188     (when (check-slime-interrupts)
189     (return :interrupt))
190     (when *wait-for-input-called*
191     (return :interrupt))
192     (when timeout
193     (return nil))
194     (sleep 0.1))))
195 heller 1.242
196 heller 1.302 (defun fd-stream-input-buffer-empty-p (stream)
197     (let ((buffer (sb-impl::fd-stream-ibuf stream)))
198     (or (not buffer)
199     (= (sb-impl::buffer-head buffer)
200     (sb-impl::buffer-tail buffer)))))
201    
202 nsiivola 1.298 #-win32
203     (defun input-ready-p (stream)
204 heller 1.302 (or (not (fd-stream-input-buffer-empty-p stream))
205 sboukarev 1.300 #+#.(swank-backend:with-symbol 'fd-stream-fd-type 'sb-impl)
206 nsiivola 1.298 (eq :regular (sb-impl::fd-stream-fd-type stream))
207     (not (sb-impl::sysread-may-block-p stream))))
208 heller 1.295
209 sboukarev 1.297 #+win32
210 heller 1.242 (progn
211     (defun input-ready-p (stream)
212 heller 1.295 (or (not (fd-stream-input-buffer-empty-p stream))
213     (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
214 heller 1.242
215     (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
216     sb-win32:handle)
217    
218     (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
219     sb-alien:int
220     (event sb-win32:handle))
221    
222     (defconstant +fd-read+ #.(ash 1 0))
223     (defconstant +fd-close+ #.(ash 1 5))
224    
225     (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
226     sb-alien:int
227     (fd sb-alien:int)
228     (handle sb-win32:handle)
229     (mask sb-alien:long))
230    
231     (sb-alien:load-shared-object "kernel32.dll")
232     (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
233     wait-for-single-object-ex)
234     sb-alien:int
235     (event sb-win32:handle)
236     (milliseconds sb-alien:long)
237     (alertable sb-alien:int))
238    
239     ;; see SB-WIN32:HANDLE-LISTEN
240     (defun handle-listen (handle)
241     (sb-alien:with-alien ((avail sb-win32:dword)
242     (buf (array char #.sb-win32::input-record-size)))
243     (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
244     (sb-alien:alien-sap
245     (sb-alien:addr avail))
246     nil))
247     (return-from handle-listen (plusp avail)))
248    
249     (unless (zerop (sb-win32:peek-console-input handle
250     (sb-alien:alien-sap buf)
251     sb-win32::input-record-size
252     (sb-alien:alien-sap
253     (sb-alien:addr avail))))
254     (return-from handle-listen (plusp avail))))
255    
256     (let ((event (wsa-create-event)))
257     (wsa-event-select handle event (logior +fd-read+ +fd-close+))
258     (let ((val (wait-for-single-object-ex event 0 0)))
259     (wsa-close-event event)
260     (unless (= val -1)
261     (return-from handle-listen (zerop val)))))
262    
263     nil)
264    
265     )
266 heller 1.221
267 heller 1.171 (defvar *external-format-to-coding-system*
268     '((:iso-8859-1
269     "latin-1" "latin-1-unix" "iso-latin-1-unix"
270     "iso-8859-1" "iso-8859-1-unix")
271     (:utf-8 "utf-8" "utf-8-unix")
272     (:euc-jp "euc-jp" "euc-jp-unix")
273     (:us-ascii "us-ascii" "us-ascii-unix")))
274    
275 heller 1.306 ;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general,
276     ;; 2008-08-22.
277 trittweiler 1.216 (defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
278    
279 heller 1.223 (defimplementation filename-to-pathname (filename)
280 trittweiler 1.216 (sb-ext:parse-native-namestring filename *physical-pathname-host*))
281    
282 heller 1.171 (defimplementation find-external-format (coding-system)
283     (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
284     *external-format-to-coding-system*)))
285 heller 1.137
286 heller 1.150 (defun make-socket-io-stream (socket external-format buffering)
287 heller 1.291 (let ((args `(,@()
288     :output t
289     :input t
290     :element-type ,(if external-format
291     'character
292     '(unsigned-byte 8))
293     :buffering ,buffering
294     ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
295     `(:external-format ,external-format))
296     (t '()))
297     :serve-events ,(eq :fd-handler
298 nsiivola 1.307 (swank-value '*communication-style* t))
299 heller 1.291 ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS
300     ;; argument.
301     :allow-other-keys t)))
302     (apply #'sb-bsd-sockets:socket-make-stream socket args)))
303 lgorrie 1.46
304 heller 1.29 (defun accept (socket)
305     "Like socket-accept, but retry on EAGAIN."
306 jsnellman 1.158 (loop (handler-case
307 heller 1.29 (return (sb-bsd-sockets:socket-accept socket))
308     (sb-bsd-sockets:interrupted-error ()))))
309 dbarlow 1.6
310 heller 1.124
311     ;;;; Support for SBCL syntax
312    
313 heller 1.129 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
314     ;;; containing `!' have special meaning. We have to work long and
315     ;;; hard to be able to read the source. To deal with #! reader
316     ;;; macros, we use a special readtable. The special symbols are
317     ;;; converted by a condition handler.
318    
319 heller 1.124 (defun feature-in-list-p (feature list)
320     (etypecase feature
321     (symbol (member feature list :test #'eq))
322     (cons (flet ((subfeature-in-list-p (subfeature)
323     (feature-in-list-p subfeature list)))
324     (ecase (first feature)
325     (:or (some #'subfeature-in-list-p (rest feature)))
326     (:and (every #'subfeature-in-list-p (rest feature)))
327     (:not (destructuring-bind (e) (cdr feature)
328     (not (subfeature-in-list-p e)))))))))
329    
330     (defun shebang-reader (stream sub-character infix-parameter)
331     (declare (ignore sub-character))
332     (when infix-parameter
333     (error "illegal read syntax: #~D!" infix-parameter))
334     (let ((next-char (read-char stream)))
335     (unless (find next-char "+-")
336     (error "illegal read syntax: #!~C" next-char))
337     ;; When test is not satisfied
338     ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
339     ;; would become "unless test is satisfied"..
340     (when (let* ((*package* (find-package "KEYWORD"))
341     (*read-suppress* nil)
342     (not-p (char= next-char #\-))
343     (feature (read stream)))
344     (if (feature-in-list-p feature *features*)
345     not-p
346     (not not-p)))
347     ;; Read (and discard) a form from input.
348     (let ((*read-suppress* t))
349     (read stream t nil t))))
350     (values))
351    
352 jsnellman 1.158 (defvar *shebang-readtable*
353 heller 1.124 (let ((*readtable* (copy-readtable nil)))
354 jsnellman 1.158 (set-dispatch-macro-character #\# #\!
355 heller 1.124 (lambda (s c n) (shebang-reader s c n))
356     *readtable*)
357     *readtable*))
358    
359     (defun shebang-readtable ()
360     *shebang-readtable*)
361    
362     (defun sbcl-package-p (package)
363     (let ((name (package-name package)))
364     (eql (mismatch "SB-" name) 3)))
365    
366 heller 1.126 (defun sbcl-source-file-p (filename)
367 nsiivola 1.187 (when filename
368 trittweiler 1.218 (loop for (nil pattern) in (logical-pathname-translations "SYS")
369 nsiivola 1.187 thereis (pathname-match-p filename pattern))))
370 heller 1.126
371     (defun guess-readtable-for-filename (filename)
372     (if (sbcl-source-file-p filename)
373     (shebang-readtable)
374     *readtable*))
375    
376 heller 1.124 (defvar *debootstrap-packages* t)
377    
378 heller 1.126 (defun call-with-debootstrapping (fun)
379 jsnellman 1.158 (handler-bind ((sb-int:bootstrap-package-not-found
380 heller 1.126 #'sb-int:debootstrap-package))
381     (funcall fun)))
382    
383 heller 1.124 (defmacro with-debootstrapping (&body body)
384 heller 1.126 `(call-with-debootstrapping (lambda () ,@body)))
385 heller 1.124
386     (defimplementation call-with-syntax-hooks (fn)
387 jsnellman 1.158 (cond ((and *debootstrap-packages*
388 heller 1.124 (sbcl-package-p *package*))
389     (with-debootstrapping (funcall fn)))
390     (t
391     (funcall fn))))
392    
393     (defimplementation default-readtable-alist ()
394     (let ((readtable (shebang-readtable)))
395     (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
396     collect (cons (package-name p) readtable))))
397    
398 dbarlow 1.1 ;;; Utilities
399    
400 nsiivola 1.307 (defun swank-value (name &optional errorp)
401     ;; Easy way to refer to symbol values in SWANK, which doesn't yet exist when
402     ;; this is file is loaded.
403     (let ((symbol (find-symbol (string name) :swank)))
404     (if (and symbol (or errorp (boundp symbol)))
405     (symbol-value symbol)
406     (when errorp
407     (error "~S does not exist in SWANK." name)))))
408    
409 sboukarev 1.263 #+#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
410 trittweiler 1.230 (defimplementation arglist (fname)
411     (sb-introspect:function-lambda-list fname))
412    
413 sboukarev 1.263 #-#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
414 heller 1.160 (defimplementation arglist (fname)
415 heller 1.74 (sb-introspect:function-arglist fname))
416 mbaringer 1.100
417 heller 1.160 (defimplementation function-name (f)
418     (check-type f function)
419 mbaringer 1.100 (sb-impl::%fun-name f))
420 dbarlow 1.1
421 trittweiler 1.179 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
422     (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
423     (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
424     (if flags
425 heller 1.306 ;; Symbols aren't printed with package qualifiers, but the
426     ;; FLAGS would have to be fully qualified when used inside a
427     ;; declaration. So we strip those as long as there's no
428     ;; better way. (FIXME)
429     `(&any ,@(remove-if-not
430     #'(lambda (qualifier)
431     (find-symbol (symbol-name (first qualifier)) :cl))
432     flags :key #'ensure-list))
433 trittweiler 1.179 (call-next-method)))))
434    
435 sboukarev 1.263 #+#.(swank-backend:with-symbol 'deftype-lambda-list 'sb-introspect)
436 trittweiler 1.229 (defmethod type-specifier-arglist :around (typespec-operator)
437     (multiple-value-bind (arglist foundp)
438     (sb-introspect:deftype-lambda-list typespec-operator)
439     (if foundp arglist (call-next-method))))
440    
441 trittweiler 1.246
442 dbarlow 1.42 (defvar *buffer-name* nil)
443 nsiivola 1.282 (defvar *buffer-tmpfile* nil)
444 dbarlow 1.1 (defvar *buffer-offset*)
445 heller 1.70 (defvar *buffer-substring* nil)
446 dbarlow 1.1
447 lgorrie 1.24 (defvar *previous-compiler-condition* nil
448     "Used to detect duplicates.")
449    
450 dbarlow 1.1 (defun handle-notification-condition (condition)
451     "Handle a condition caused by a compiler warning.
452     This traps all compiler conditions at a lower-level than using
453     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
454     craft our own error messages, which can omit a lot of redundant
455     information."
456 nsiivola 1.206 (unless (or (eq condition *previous-compiler-condition*))
457     ;; First resignal warnings, so that outer handlers -- which may choose to
458     ;; muffle this -- get a chance to run.
459     (when (typep condition 'warning)
460     (signal condition))
461     (setq *previous-compiler-condition* condition)
462 trittweiler 1.260 (signal-compiler-condition (real-condition condition)
463     (sb-c::find-error-context nil))))
464 lgorrie 1.24
465     (defun signal-compiler-condition (condition context)
466     (signal (make-condition
467     'compiler-condition
468     :original-condition condition
469     :severity (etypecase condition
470 trittweiler 1.264 (sb-ext:compiler-note :note)
471 lgorrie 1.24 (sb-c:compiler-error :error)
472 trittweiler 1.264 (reader-error :read-error)
473 trittweiler 1.260 (error :error)
474 heller 1.306 #+#.(swank-backend:with-symbol redefinition-warning
475     sb-kernel)
476 trittweiler 1.246 (sb-kernel:redefinition-warning
477     :redefinition)
478 lgorrie 1.24 (style-warning :style-warning)
479 trittweiler 1.260 (warning :warning))
480     :references (condition-references condition)
481 heller 1.248 :message (brief-compiler-message-for-emacs condition)
482     :source-context (compiler-error-context context)
483 trittweiler 1.235 :location (compiler-note-location condition context))))
484 heller 1.107
485     (defun real-condition (condition)
486     "Return the encapsulated condition or CONDITION itself."
487     (typecase condition
488     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
489     (t condition)))
490 lgorrie 1.24
491 heller 1.184 (defun condition-references (condition)
492     (if (typep condition 'sb-int:reference-condition)
493     (externalize-reference
494     (sb-int:reference-condition-references condition))))
495    
496 trittweiler 1.235 (defun compiler-note-location (condition context)
497     (flet ((bailout ()
498 trittweiler 1.266 (return-from compiler-note-location
499     (make-error-location "No error location available"))))
500 trittweiler 1.235 (cond (context
501     (locate-compiler-note
502     (sb-c::compiler-error-context-file-name context)
503     (compiler-source-path context)
504     (sb-c::compiler-error-context-original-source context)))
505     ((typep condition 'reader-error)
506 trittweiler 1.236 (let* ((stream (stream-error-stream condition))
507     (file (pathname stream)))
508     (unless (open-stream-p stream)
509     (bailout))
510     (if (compiling-from-buffer-p file)
511 heller 1.306 ;; The stream position for e.g. "comma not inside
512     ;; backquote" is at the character following the
513     ;; comma, :offset is 0-based, hence the 1-.
514 trittweiler 1.236 (make-location (list :buffer *buffer-name*)
515     (list :offset *buffer-offset*
516 trittweiler 1.237 (1- (file-position stream))))
517 trittweiler 1.236 (progn
518     (assert (compiling-from-file-p file))
519 trittweiler 1.237 ;; No 1- because :position is 1-based.
520 trittweiler 1.236 (make-location (list :file (namestring file))
521     (list :position (file-position stream)))))))
522 trittweiler 1.235 (t (bailout)))))
523 heller 1.124
524 trittweiler 1.236 (defun compiling-from-buffer-p (filename)
525 trittweiler 1.266 (and *buffer-name*
526     ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
527 nsiivola 1.282 ;; in LOCATE-COMPILER-NOTE, and allows handling nested
528     ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
529 nsiivola 1.284 ;;
530     ;; PROBE-FILE to handle tempfile directory being a symlink.
531 nsiivola 1.282 (pathnamep filename)
532 nsiivola 1.284 (let ((true1 (probe-file filename))
533     (true2 (probe-file *buffer-tmpfile*)))
534     (and true1 (equal true1 true2)))))
535 trittweiler 1.236
536     (defun compiling-from-file-p (filename)
537 nsiivola 1.282 (and (pathnamep filename)
538     (or (null *buffer-name*)
539 nsiivola 1.284 (null *buffer-tmpfile*)
540     (let ((true1 (probe-file filename))
541     (true2 (probe-file *buffer-tmpfile*)))
542     (not (and true1 (equal true1 true2)))))))
543 trittweiler 1.236
544     (defun compiling-from-generated-code-p (filename source)
545     (and (eq filename :lisp) (stringp source)))
546    
547 heller 1.127 (defun locate-compiler-note (file source-path source)
548 trittweiler 1.236 (cond ((compiling-from-buffer-p file)
549 heller 1.219 (make-location (list :buffer *buffer-name*)
550     (list :offset *buffer-offset*
551     (source-path-string-position
552     source-path *buffer-substring*))))
553 trittweiler 1.236 ((compiling-from-file-p file)
554 heller 1.124 (make-location (list :file (namestring file))
555 heller 1.219 (list :position (1+ (source-path-file-position
556     source-path file)))))
557 trittweiler 1.236 ((compiling-from-generated-code-p file source)
558 heller 1.127 (make-location (list :source-form source)
559     (list :position 1)))
560 dbarlow 1.42 (t
561 heller 1.306 (error "unhandled case in compiler note ~S ~S ~S"
562     file source-path source))))
563 dbarlow 1.42
564 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
565 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
566     When Emacs presents the message it already has the source popped up
567     and the source form highlighted. This makes much of the information in
568     the error-context redundant."
569 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
570     (princ-to-string condition)))
571 heller 1.66
572 heller 1.248 (defun compiler-error-context (error-context)
573 heller 1.66 "Describe a compiler error for Emacs including context information."
574 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
575 heller 1.66 (multiple-value-bind (enclosing source)
576     (if error-context
577     (values (sb-c::compiler-error-context-enclosing-source error-context)
578     (sb-c::compiler-error-context-source error-context)))
579 heller 1.248 (and (or enclosing source)
580     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
581     enclosing source))))
582 dbarlow 1.1
583 heller 1.124 (defun compiler-source-path (context)
584 dbarlow 1.1 "Return the source-path for the current compiler error.
585     Returns NIL if this cannot be determined by examining internal
586     compiler state."
587     (cond ((sb-c::node-p context)
588     (reverse
589     (sb-c::source-path-original-source
590     (sb-c::node-source-path context))))
591     ((sb-c::compiler-error-context-p context)
592     (reverse
593     (sb-c::compiler-error-context-original-source-path context)))))
594    
595 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
596 heller 1.58 (declare (type function function))
597 trittweiler 1.238 (handler-bind
598     ;; N.B. Even though these handlers are called HANDLE-FOO they
599     ;; actually decline, i.e. the signalling of the original
600     ;; condition continues upward.
601 trittweiler 1.260 ((sb-c:fatal-compiler-error #'handle-notification-condition)
602     (sb-c:compiler-error #'handle-notification-condition)
603     (sb-ext:compiler-note #'handle-notification-condition)
604     (error #'handle-notification-condition)
605     (warning #'handle-notification-condition))
606 dbarlow 1.41 (funcall function)))
607 lgorrie 1.24
608 lgorrie 1.96
609 nsiivola 1.280 (defvar *trap-load-time-warnings* t)
610 heller 1.91
611 sboukarev 1.268 (defun compiler-policy (qualities)
612     "Return compiler policy qualities present in the QUALITIES alist.
613     QUALITIES is an alist with (quality . value)"
614     #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
615     (loop with policy = (sb-ext:restrict-compiler-policy)
616     for (quality) in qualities
617     collect (cons quality
618     (or (cdr (assoc quality policy))
619     0))))
620    
621     (defun (setf compiler-policy) (policy)
622     (declare (ignorable policy))
623     #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
624     (loop for (qual . value) in policy
625     do (sb-ext:restrict-compiler-policy qual value)))
626    
627     (defmacro with-compiler-policy (policy &body body)
628     (let ((current-policy (gensym)))
629     `(let ((,current-policy (compiler-policy ,policy)))
630     (setf (compiler-policy) ,policy)
631     (unwind-protect (progn ,@body)
632     (setf (compiler-policy) ,current-policy)))))
633    
634 heller 1.232 (defimplementation swank-compile-file (input-file output-file
635 sboukarev 1.268 load-p external-format
636     &key policy)
637 trittweiler 1.264 (multiple-value-bind (output-file warnings-p failure-p)
638 sboukarev 1.268 (with-compiler-policy policy
639     (with-compilation-hooks ()
640     (compile-file input-file :output-file output-file
641     :external-format external-format)))
642 trittweiler 1.264 (values output-file warnings-p
643     (or failure-p
644     (when load-p
645     ;; Cache the latest source file for definition-finding.
646     (source-cache-get input-file
647     (file-write-date input-file))
648     (not (load output-file)))))))
649 lgorrie 1.24
650 heller 1.124 ;;;; compile-string
651    
652 heller 1.156 ;;; We copy the string to a temporary file in order to get adequate
653     ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
654     ;;; which the previous approach using
655     ;;; (compile nil `(lambda () ,(read-from-string string)))
656     ;;; did not provide.
657    
658 heller 1.245 (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
659    
660 heller 1.242 (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
661     sb-alien:c-string
662     (dir sb-alien:c-string)
663     (prefix sb-alien:c-string))
664 heller 1.156
665 heller 1.245 )
666    
667 heller 1.156 (defun temp-file-name ()
668     "Return a temporary file name to compile strings into."
669 heller 1.242 (tempnam nil nil))
670 heller 1.156
671 heller 1.231 (defimplementation swank-compile-string (string &key buffer position filename
672     policy)
673 heller 1.156 (let ((*buffer-name* buffer)
674     (*buffer-offset* position)
675     (*buffer-substring* string)
676 nsiivola 1.282 (*buffer-tmpfile* (temp-file-name)))
677 trittweiler 1.200 (flet ((load-it (filename)
678     (when filename (load filename)))
679     (compile-it (cont)
680 heller 1.139 (with-compilation-hooks ()
681 heller 1.156 (with-compilation-unit
682     (:source-plist (list :emacs-buffer buffer
683 heller 1.231 :emacs-filename filename
684 heller 1.156 :emacs-string string
685 nsiivola 1.280 :emacs-position position)
686     :source-namestring filename
687     :allow-other-keys t)
688 trittweiler 1.249 (multiple-value-bind (output-file warningsp failurep)
689 heller 1.303 (compile-file *buffer-tmpfile* :external-format :utf-8)
690 sboukarev 1.251 (declare (ignore warningsp))
691 trittweiler 1.249 (unless failurep
692     (funcall cont output-file)))))))
693 heller 1.303 (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
694     :external-format :utf-8)
695 heller 1.156 (write-string string s))
696     (unwind-protect
697 sboukarev 1.268 (with-compiler-policy policy
698     (if *trap-load-time-warnings*
699     (compile-it #'load-it)
700     (load-it (compile-it #'identity))))
701 heller 1.156 (ignore-errors
702 nsiivola 1.282 (delete-file *buffer-tmpfile*)
703     (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
704 dbarlow 1.1
705     ;;;; Definitions
706    
707 jsnellman 1.149 (defparameter *definition-types*
708     '(:variable defvar
709     :constant defconstant
710     :type deftype
711     :symbol-macro define-symbol-macro
712     :macro defmacro
713     :compiler-macro define-compiler-macro
714     :function defun
715     :generic-function defgeneric
716     :method defmethod
717     :setf-expander define-setf-expander
718     :structure defstruct
719 jsnellman 1.159 :condition define-condition
720 jsnellman 1.149 :class defclass
721     :method-combination define-method-combination
722     :package defpackage
723     :transform :deftransform
724     :optimizer :defoptimizer
725     :vop :define-vop
726     :source-transform :define-source-transform)
727     "Map SB-INTROSPECT definition type names to Slime-friendly forms")
728    
729 trittweiler 1.234 (defun definition-specifier (type name)
730     "Return a pretty specifier for NAME representing a definition of type TYPE."
731     (if (and (symbolp name)
732     (eq type :function)
733     (sb-int:info :function :ir1-convert name))
734     :def-ir1-translator
735     (getf *definition-types* type)))
736    
737 trittweiler 1.258 (defun make-dspec (type name source-location)
738 nsiivola 1.276 (let ((spec (definition-specifier type name))
739     (desc (sb-introspect::definition-source-description source-location)))
740     (if (eq :define-vop spec)
741     ;; The first part of the VOP description is the name of the template
742     ;; -- which is actually good information and often long. So elide the
743     ;; original name in favor of making the interesting bit more visible.
744     ;;
745 heller 1.306 ;; The second part of the VOP description is the associated
746     ;; compiler note, or NIL -- which is quite uninteresting and
747     ;; confuses the eye when reading the actual name which usually
748     ;; has a worthwhile postfix. So drop the note.
749 nsiivola 1.276 (list spec (car desc))
750     (list* spec name desc))))
751 trittweiler 1.234
752 jsnellman 1.149 (defimplementation find-definitions (name)
753     (loop for type in *definition-types* by #'cddr
754 trittweiler 1.261 for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
755     append (loop for defsrc in defsrcs collect
756     (list (make-dspec type name defsrc)
757 trittweiler 1.267 (converting-errors-to-error-location
758 heller 1.306 (definition-source-for-emacs defsrc
759     type name))))))
760 jsnellman 1.149
761 trittweiler 1.193 (defimplementation find-source-location (obj)
762     (flet ((general-type-of (obj)
763     (typecase obj
764     (method :method)
765     (generic-function :generic-function)
766     (function :function)
767     (structure-class :structure-class)
768     (class :class)
769     (method-combination :method-combination)
770 trittweiler 1.200 (package :package)
771 trittweiler 1.261 (condition :condition)
772 trittweiler 1.193 (structure-object :structure-object)
773     (standard-object :standard-object)
774     (t :thing)))
775     (to-string (obj)
776     (typecase obj
777 heller 1.306 ;; Packages are possibly named entities.
778     (package (princ-to-string obj))
779 trittweiler 1.193 ((or structure-object standard-object condition)
780     (with-output-to-string (s)
781     (print-unreadable-object (obj s :type t :identity t))))
782 trittweiler 1.200 (t (princ-to-string obj)))))
783 trittweiler 1.267 (converting-errors-to-error-location
784 trittweiler 1.261 (let ((defsrc (sb-introspect:find-definition-source obj)))
785     (definition-source-for-emacs defsrc
786     (general-type-of obj)
787     (to-string obj))))))
788 jsnellman 1.149
789 heller 1.316 (defmacro with-definition-source ((&rest names) obj &body body)
790     "Like with-slots but works only for structs."
791     (flet ((reader (slot)
792     ;; Use read-from-string instead of intern so that
793     ;; conc-name can be a string such as ext:struct- and not
794     ;; cause errors and not force interning ext::struct-
795     (read-from-string
796     (concatenate 'string "sb-introspect:definition-source-"
797     (string slot)))))
798     (let ((tmp (gensym "OO-")))
799     ` (let ((,tmp ,obj))
800     (symbol-macrolet
801     ,(loop for name in names collect
802     (typecase name
803     (symbol `(,name (,(reader name) ,tmp)))
804     (cons `(,(first name) (,(reader (second name)) ,tmp)))
805     (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
806     ,@body)))))
807 trittweiler 1.234
808 trittweiler 1.261 (defun categorize-definition-source (definition-source)
809 heller 1.316 (with-definition-source (pathname form-path character-offset plist)
810     definition-source
811 sboukarev 1.312 (let ((file-p (and pathname (probe-file pathname)
812     (or form-path character-offset))))
813     (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
814     ((getf plist :emacs-buffer) :buffer)
815     (file-p :file)
816     (pathname :file-without-position)
817     (t :invalid)))))
818 trittweiler 1.261
819 sboukarev 1.310 (defun definition-source-buffer-location (definition-source)
820 heller 1.316 (with-definition-source (form-path character-offset plist) definition-source
821 sboukarev 1.310 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
822     emacs-string &allow-other-keys)
823     plist
824     (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
825     (multiple-value-bind (start end)
826     (if form-path
827     (with-debootstrapping
828     (source-path-string-position form-path
829     emacs-string))
830     (values character-offset
831     most-positive-fixnum))
832     (make-location
833     `(:buffer ,emacs-buffer)
834     `(:offset ,emacs-position ,start)
835     `(:snippet
836     ,(subseq emacs-string
837     start
838     (min end (+ start *source-snippet-size*))))))))))
839    
840     (defun definition-source-file-location (definition-source)
841 heller 1.316 (with-definition-source (pathname form-path character-offset plist
842     file-write-date) definition-source
843 sboukarev 1.310 (let* ((namestring (namestring (translate-logical-pathname pathname)))
844     (pos (if form-path
845     (source-file-position namestring file-write-date
846     form-path)
847     character-offset))
848     (snippet (source-hint-snippet namestring file-write-date pos)))
849     (make-location `(:file ,namestring)
850     ;; /file positions/ in Common Lisp start from
851     ;; 0, buffer positions in Emacs start from 1.
852     `(:position ,(1+ pos))
853     `(:snippet ,snippet)))))
854    
855 sboukarev 1.312 (defun definition-source-buffer-and-file-location (definition-source)
856     (let ((buffer (definition-source-buffer-location definition-source))
857     (file (definition-source-file-location definition-source)))
858     (make-location (list :buffer-and-file
859     (cadr (location-buffer buffer))
860     (cadr (location-buffer file)))
861 sboukarev 1.313 (location-position buffer)
862     (location-hints buffer))))
863 sboukarev 1.312
864 trittweiler 1.261 (defun definition-source-for-emacs (definition-source type name)
865 heller 1.316 (with-definition-source (pathname form-path character-offset plist
866     file-write-date)
867     definition-source
868 sboukarev 1.314 (ecase (categorize-definition-source definition-source)
869     (:buffer-and-file
870     (definition-source-buffer-and-file-location definition-source))
871     (:buffer
872     (definition-source-buffer-location definition-source))
873     (:file
874     (definition-source-file-location definition-source))
875     (:file-without-position
876     (make-location `(:file ,(namestring
877     (translate-logical-pathname pathname)))
878     '(:position 1)
879     (when (eql type :function)
880     `(:snippet ,(format nil "(defun ~a "
881     (symbol-name name))))))
882     (:invalid
883     (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
884 trittweiler 1.261 meaningful information."
885 sboukarev 1.314 type name)))))
886 jsnellman 1.149
887 trittweiler 1.261 (defun source-file-position (filename write-date form-path)
888 jsnellman 1.172 (let ((source (get-source-code filename write-date))
889     (*readtable* (guess-readtable-for-filename filename)))
890 trittweiler 1.192 (with-debootstrapping
891 trittweiler 1.261 (source-path-string-position form-path source))))
892 jsnellman 1.172
893 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
894 trittweiler 1.241 (read-snippet-from-string (get-source-code filename write-date) position))
895 jsnellman 1.149
896 jsnellman 1.151 (defun function-source-location (function &optional name)
897     (declare (type function function))
898 trittweiler 1.261 (definition-source-for-emacs (sb-introspect:find-definition-source function)
899     :function
900     (or name (function-name function))))
901 jsnellman 1.151
902 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
903 dbarlow 1.1 "Return a plist describing SYMBOL.
904     Return NIL if the symbol is unbound."
905     (let ((result '()))
906 heller 1.133 (flet ((doc (kind)
907     (or (documentation symbol kind) :not-documented))
908     (maybe-push (property value)
909     (when value
910     (setf result (list* property value result)))))
911 dbarlow 1.1 (maybe-push
912     :variable (multiple-value-bind (kind recorded-p)
913     (sb-int:info :variable :kind symbol)
914     (declare (ignore kind))
915     (if (or (boundp symbol) recorded-p)
916     (doc 'variable))))
917 heller 1.133 (when (fboundp symbol)
918     (maybe-push
919     (cond ((macro-function symbol) :macro)
920     ((special-operator-p symbol) :special-operator)
921     ((typep (fdefinition symbol) 'generic-function)
922     :generic-function)
923     (t :function))
924     (doc 'function)))
925 dbarlow 1.1 (maybe-push
926     :setf (if (or (sb-int:info :setf :inverse symbol)
927     (sb-int:info :setf :expander symbol))
928     (doc 'setf)))
929     (maybe-push
930     :type (if (sb-int:info :type :kind symbol)
931     (doc 'type)))
932 lgorrie 1.24 result)))
933 dbarlow 1.1
934 heller 1.74 (defimplementation describe-definition (symbol type)
935 lgorrie 1.54 (case type
936     (:variable
937 heller 1.74 (describe symbol))
938     (:function
939     (describe (symbol-function symbol)))
940 lgorrie 1.54 (:setf
941 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
942     (sb-int:info :setf :expander symbol))))
943 lgorrie 1.54 (:class
944 heller 1.74 (describe (find-class symbol)))
945 lgorrie 1.54 (:type
946 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
947 jsnellman 1.172
948     #+#.(swank-backend::sbcl-with-xref-p)
949     (progn
950 trittweiler 1.255 (defmacro defxref (name &optional fn-name)
951 jsnellman 1.172 `(defimplementation ,name (what)
952     (sanitize-xrefs
953     (mapcar #'source-location-for-xref-data
954 trittweiler 1.255 (,(find-symbol (symbol-name (if fn-name
955     fn-name
956     name))
957     "SB-INTROSPECT")
958 jsnellman 1.172 what)))))
959     (defxref who-calls)
960     (defxref who-binds)
961     (defxref who-sets)
962     (defxref who-references)
963 trittweiler 1.222 (defxref who-macroexpands)
964 sboukarev 1.263 #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
965 trittweiler 1.255 (defxref who-specializes who-specializes-directly))
966 jsnellman 1.172
967     (defun source-location-for-xref-data (xref-data)
968 trittweiler 1.261 (destructuring-bind (name . defsrc) xref-data
969 trittweiler 1.267 (list name (converting-errors-to-error-location
970 trittweiler 1.261 (definition-source-for-emacs defsrc 'function name)))))
971 dbarlow 1.1
972 heller 1.97 (defimplementation list-callers (symbol)
973     (let ((fn (fdefinition symbol)))
974 heller 1.168 (sanitize-xrefs
975     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
976 heller 1.97
977     (defimplementation list-callees (symbol)
978     (let ((fn (fdefinition symbol)))
979 heller 1.168 (sanitize-xrefs
980     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
981 heller 1.97
982 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
983 heller 1.168 (remove-duplicates
984     (remove-if (lambda (f)
985     (member f (ignored-xref-function-names)))
986 jsnellman 1.172 (loop for entry in xrefs
987     for name = (car entry)
988     collect (if (and (consp name)
989     (member (car name)
990     '(sb-pcl::fast-method
991     sb-pcl::slow-method
992     sb-pcl::method)))
993     (cons (cons 'defmethod (cdr name))
994     (cdr entry))
995     entry))
996 heller 1.168 :key #'car)
997     :test (lambda (a b)
998     (and (eq (first a) (first b))
999     (equal (second a) (second b))))))
1000    
1001     (defun ignored-xref-function-names ()
1002     #-#.(swank-backend::sbcl-with-new-stepper-p)
1003     '(nil sb-c::step-form sb-c::step-values)
1004     #+#.(swank-backend::sbcl-with-new-stepper-p)
1005     '(nil))
1006 jsnellman 1.166
1007 lgorrie 1.122 (defun function-dspec (fn)
1008     "Describe where the function FN was defined.
1009     Return a list of the form (NAME LOCATION)."
1010 trittweiler 1.261 (let ((name (function-name fn)))
1011 trittweiler 1.267 (list name (converting-errors-to-error-location
1012 trittweiler 1.258 (function-source-location fn name)))))
1013 lgorrie 1.122
1014 dbarlow 1.4 ;;; macroexpansion
1015 dbarlow 1.1
1016 lgorrie 1.54 (defimplementation macroexpand-all (form)
1017 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
1018     (sb-walker:walk-form form)))
1019 lgorrie 1.25
1020 dbarlow 1.1
1021     ;;; Debugging
1022    
1023 trittweiler 1.257 ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
1024     ;;; than just a hook into BREAK. In particular, it'll make
1025     ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1026     ;;; than the native debugger. That should probably be considered a
1027     ;;; feature.
1028 dbarlow 1.1
1029 trittweiler 1.194 (defun make-invoke-debugger-hook (hook)
1030 trittweiler 1.259 (when hook
1031     #'(sb-int:named-lambda swank-invoke-debugger-hook
1032     (condition old-hook)
1033     (if *debugger-hook*
1034     nil ; decline, *DEBUGGER-HOOK* will be tried next.
1035     (funcall hook condition old-hook)))))
1036 trittweiler 1.194
1037 trittweiler 1.257 (defun set-break-hook (hook)
1038     (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1039    
1040     (defun call-with-break-hook (hook continuation)
1041     (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1042     (funcall continuation)))
1043    
1044 heller 1.148 (defimplementation install-debugger-globally (function)
1045 trittweiler 1.194 (setq *debugger-hook* function)
1046 trittweiler 1.257 (set-break-hook function))
1047 heller 1.148
1048 jsnellman 1.162 (defimplementation condition-extras (condition)
1049 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1050     ((typep condition 'sb-impl::step-form-condition)
1051     `((:show-frame-source 0)))
1052     ((typep condition 'sb-int:reference-condition)
1053     (let ((refs (sb-int:reference-condition-references condition)))
1054     (if refs
1055     `((:references ,(externalize-reference refs))))))))
1056    
1057     (defun externalize-reference (ref)
1058     (etypecase ref
1059     (null nil)
1060     (cons (cons (externalize-reference (car ref))
1061     (externalize-reference (cdr ref))))
1062     ((or string number) ref)
1063     (symbol
1064     (cond ((eq (symbol-package ref) (symbol-package :test))
1065     ref)
1066     (t (symbol-name ref))))))
1067 jsnellman 1.162
1068 trittweiler 1.257 (defvar *sldb-stack-top*)
1069    
1070 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1071 heller 1.58 (declare (type function debugger-loop-fn))
1072 trittweiler 1.258 (let* ((*sldb-stack-top* (if *debug-swank-backend*
1073     (sb-di:top-frame)
1074 heller 1.306 (or sb-debug:*stack-top-hint*
1075     (sb-di:top-frame))))
1076 trittweiler 1.199 (sb-debug:*stack-top-hint* nil))
1077 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
1078 dbarlow 1.1 (lambda (condition)
1079 lgorrie 1.25 (signal (make-condition
1080     'sldb-condition
1081     :original-condition condition)))))
1082     (funcall debugger-loop-fn))))
1083 dbarlow 1.1
1084 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
1085     (progn
1086     (defimplementation activate-stepping (frame)
1087     (declare (ignore frame))
1088     (sb-impl::enable-stepping))
1089     (defimplementation sldb-stepper-condition-p (condition)
1090     (typep condition 'sb-ext:step-form-condition))
1091     (defimplementation sldb-step-into ()
1092     (invoke-restart 'sb-ext:step-into))
1093     (defimplementation sldb-step-next ()
1094     (invoke-restart 'sb-ext:step-next))
1095     (defimplementation sldb-step-out ()
1096     (invoke-restart 'sb-ext:step-out)))
1097    
1098 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
1099 trittweiler 1.259 (let ((*debugger-hook* hook)
1100     #+#.(swank-backend::sbcl-with-new-stepper-p)
1101 jsnellman 1.162 (sb-ext:*stepper-hook*
1102     (lambda (condition)
1103 jsnellman 1.164 (typecase condition
1104     (sb-ext:step-form-condition
1105     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1106     (sb-impl::invoke-debugger condition)))))))
1107     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1108     (sb-ext:step-condition #'sb-impl::invoke-stepper))
1109 trittweiler 1.257 (call-with-break-hook hook fun))))
1110 heller 1.118
1111 dbarlow 1.1 (defun nth-frame (index)
1112     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1113     (i index (1- i)))
1114     ((zerop i) frame)))
1115    
1116 heller 1.74 (defimplementation compute-backtrace (start end)
1117 dbarlow 1.1 "Return a list of frames starting with frame number START and
1118     continuing to frame number END or, if END is nil, the last frame on the
1119     stack."
1120     (let ((end (or end most-positive-fixnum)))
1121 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1122     for i from start below end
1123 heller 1.225 while f collect f)))
1124 trittweiler 1.218
1125 heller 1.225 (defimplementation print-frame (frame stream)
1126     (sb-debug::print-frame-call frame stream))
1127 trittweiler 1.218
1128 heller 1.225 (defimplementation frame-restartable-p (frame)
1129 trittweiler 1.218 #+#.(swank-backend::sbcl-with-restart-frame)
1130 heller 1.225 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1131 dbarlow 1.1
1132 sboukarev 1.265 (defimplementation frame-call (frame-number)
1133     (multiple-value-bind (name args)
1134     (sb-debug::frame-call (nth-frame frame-number))
1135     (with-output-to-string (stream)
1136     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1137     (let ((*print-length* nil)
1138     (*print-level* nil))
1139     (prin1 (sb-debug::ensure-printable-object name) stream))
1140     (let ((args (sb-debug::ensure-printable-object args)))
1141     (if (listp args)
1142     (format stream "~{ ~_~S~}" args)
1143     (format stream " ~S" args)))))))
1144    
1145 heller 1.124 ;;;; Code-location -> source-location translation
1146    
1147 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
1148     ;;; the source-path for a code-location. If the code was compiled
1149     ;;; with C-c C-c, we have to search the position in the source string.
1150     ;;; If there's no debug-block info, we return the (less precise)
1151     ;;; source-location of the corresponding function.
1152    
1153 nsiivola 1.134 (defun code-location-source-location (code-location)
1154     (let* ((dsource (sb-di:code-location-debug-source code-location))
1155     (plist (sb-c::debug-source-plist dsource)))
1156     (if (getf plist :emacs-buffer)
1157     (emacs-buffer-source-location code-location plist)
1158 sboukarev 1.263 #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1159 nsiivola 1.134 (ecase (sb-di:debug-source-from dsource)
1160     (:file (file-source-location code-location))
1161 trittweiler 1.197 (:lisp (lisp-source-location code-location)))
1162 sboukarev 1.263 #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1163 trittweiler 1.197 (if (sb-di:debug-source-namestring dsource)
1164     (file-source-location code-location)
1165     (lisp-source-location code-location)))))
1166 nsiivola 1.134
1167     ;;; FIXME: The naming policy of source-location functions is a bit
1168     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1169     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1170     ;;; which returns the source location for a _code-location_.
1171 jsnellman 1.158 ;;;
1172 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
1173 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
1174     ;;; least the names should indicate the main entry point vs. helper
1175     ;;; status.
1176 heller 1.124
1177 nsiivola 1.134 (defun file-source-location (code-location)
1178     (if (code-location-has-debug-block-info-p code-location)
1179     (source-file-source-location code-location)
1180     (fallback-source-location code-location)))
1181    
1182     (defun fallback-source-location (code-location)
1183     (let ((fun (code-location-debug-fun-fun code-location)))
1184     (cond (fun (function-source-location fun))
1185 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
1186 nsiivola 1.134
1187 heller 1.124 (defun lisp-source-location (code-location)
1188 jsnellman 1.158 (let ((source (prin1-to-string
1189 nsiivola 1.305 (sb-debug::code-location-source-form code-location 100)))
1190 nsiivola 1.307 (condition (swank-value '*swank-debugger-condition*)))
1191 nsiivola 1.309 (if (and (typep condition 'sb-impl::step-form-condition)
1192     (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1193 nsiivola 1.307 :test #'char-equal)
1194     (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1195 heller 1.306 ;; The initial form is utterly uninteresting -- and almost
1196     ;; certainly right there in the REPL.
1197 nsiivola 1.304 (make-error-location "Stepping...")
1198     (make-location `(:source-form ,source) '(:position 1)))))
1199 heller 1.124
1200 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
1201     (if (code-location-has-debug-block-info-p code-location)
1202 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1203     &allow-other-keys)
1204     plist
1205 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
1206 trittweiler 1.241 (snipped (read-snippet-from-string emacs-string pos)))
1207 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
1208 heller 1.219 `(:offset ,emacs-position ,pos)
1209 nsiivola 1.134 `(:snippet ,snipped))))
1210     (fallback-source-location code-location)))
1211    
1212 heller 1.124 (defun source-file-source-location (code-location)
1213     (let* ((code-date (code-location-debug-source-created code-location))
1214     (filename (code-location-debug-source-name code-location))
1215 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
1216 heller 1.126 (source-code (get-source-code filename code-date)))
1217 jsnellman 1.186 (with-debootstrapping
1218     (with-input-from-string (s source-code)
1219     (let* ((pos (stream-source-position code-location s))
1220     (snippet (read-snippet s pos)))
1221     (make-location `(:file ,filename)
1222 heller 1.219 `(:position ,pos)
1223 jsnellman 1.186 `(:snippet ,snippet)))))))
1224 heller 1.124
1225     (defun code-location-debug-source-name (code-location)
1226 sboukarev 1.263 (namestring (truename (#+#.(swank-backend:with-symbol
1227 trittweiler 1.197 'debug-source-name 'sb-di)
1228     sb-c::debug-source-name
1229 sboukarev 1.263 #-#.(swank-backend:with-symbol
1230 trittweiler 1.197 'debug-source-name 'sb-di)
1231     sb-c::debug-source-namestring
1232 jsnellman 1.186 (sb-di::code-location-debug-source code-location)))))
1233 heller 1.124
1234     (defun code-location-debug-source-created (code-location)
1235 jsnellman 1.158 (sb-c::debug-source-created
1236 heller 1.124 (sb-di::code-location-debug-source code-location)))
1237    
1238     (defun code-location-debug-fun-fun (code-location)
1239     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1240    
1241     (defun code-location-has-debug-block-info-p (code-location)
1242 jsnellman 1.158 (handler-case
1243 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
1244     t)
1245     (sb-di:no-debug-blocks () nil)))
1246    
1247     (defun stream-source-position (code-location stream)
1248     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1249 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1250 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
1251     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1252     (let* ((path-table (sb-di::form-number-translations tlf 0))
1253 heller 1.128 (path (cond ((<= (length path-table) form-number)
1254 heller 1.129 (warn "inconsistent form-number-translations")
1255 heller 1.128 (list 0))
1256     (t
1257     (reverse (cdr (aref path-table form-number)))))))
1258     (source-path-source-position path tlf pos-map)))))
1259    
1260     (defun string-source-position (code-location string)
1261     (with-input-from-string (s string)
1262     (stream-source-position code-location s)))
1263 dbarlow 1.1
1264 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
1265 lgorrie 1.121
1266 heller 1.243 (defimplementation frame-source-location (index)
1267 trittweiler 1.267 (converting-errors-to-error-location
1268 trittweiler 1.258 (code-location-source-location
1269     (sb-di:frame-code-location (nth-frame index)))))
1270 dbarlow 1.1
1271 heller 1.92 (defun frame-debug-vars (frame)
1272     "Return a vector of debug-variables in frame."
1273     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1274    
1275     (defun debug-var-value (var frame location)
1276     (ecase (sb-di:debug-var-validity var location)
1277     (:valid (sb-di:debug-var-value var frame))
1278     ((:invalid :unknown) ':<not-available>)))
1279    
1280 nsiivola 1.285 (defun debug-var-info (var)
1281     ;; Introduced by SBCL 1.0.49.76.
1282     (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1283     (when (and s (fboundp s))
1284     (funcall s var))))
1285    
1286 lgorrie 1.54 (defimplementation frame-locals (index)
1287 dbarlow 1.1 (let* ((frame (nth-frame index))
1288 heller 1.92 (loc (sb-di:frame-code-location frame))
1289 nsiivola 1.285 (vars (frame-debug-vars frame))
1290     ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1291     ;; specially.
1292     (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1293     (more-context nil)
1294     (more-count nil)
1295     (more-id 0))
1296 sboukarev 1.256 (when vars
1297 nsiivola 1.285 (let ((locals
1298     (loop for v across vars
1299     do (when (eq (sb-di:debug-var-symbol v) more-name)
1300     (incf more-id))
1301     (case (debug-var-info v)
1302     (:more-context
1303     (setf more-context (debug-var-value v frame loc)))
1304     (:more-count
1305     (setf more-count (debug-var-value v frame loc))))
1306     collect
1307     (list :name (sb-di:debug-var-symbol v)
1308     :id (sb-di:debug-var-id v)
1309     :value (debug-var-value v frame loc)))))
1310     (when (and more-context more-count)
1311     (setf locals (append locals
1312     (list
1313     (list :name more-name
1314     :id more-id
1315     :value (multiple-value-list
1316 heller 1.306 (sb-c:%more-arg-values
1317     more-context
1318     0 more-count)))))))
1319 nsiivola 1.285 locals))))
1320 heller 1.92
1321     (defimplementation frame-var-value (frame var)
1322     (let* ((frame (nth-frame frame))
1323 nsiivola 1.285 (vars (frame-debug-vars frame))
1324     (loc (sb-di:frame-code-location frame))
1325     (dvar (if (= var (length vars))
1326 heller 1.306 ;; If VAR is out of bounds, it must be the fake var
1327     ;; we made up for &MORE.
1328     (let* ((context-var (find :more-context vars
1329     :key #'debug-var-info))
1330     (more-context (debug-var-value context-var frame
1331     loc))
1332     (count-var (find :more-count vars
1333     :key #'debug-var-info))
1334 nsiivola 1.285 (more-count (debug-var-value count-var frame loc)))
1335     (return-from frame-var-value
1336 heller 1.306 (multiple-value-list (sb-c:%more-arg-values
1337     more-context
1338     0 more-count))))
1339 nsiivola 1.285 (aref vars var))))
1340     (debug-var-value dvar frame loc)))
1341 dbarlow 1.1
1342 lgorrie 1.54 (defimplementation frame-catch-tags (index)
1343 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1344 lgorrie 1.50
1345 heller 1.56 (defimplementation eval-in-frame (form index)
1346     (let ((frame (nth-frame index)))
1347 heller 1.58 (funcall (the function
1348 jsnellman 1.158 (sb-di:preprocess-for-eval form
1349 heller 1.58 (sb-di:frame-code-location frame)))
1350 heller 1.56 frame)))
1351    
1352 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
1353     (progn
1354     (defimplementation return-from-frame (index form)
1355     (let* ((frame (nth-frame index)))
1356     (cond ((sb-debug:frame-has-debug-tag-p frame)
1357     (let ((values (multiple-value-list (eval-in-frame form index))))
1358     (sb-debug:unwind-to-frame-and-call frame
1359     (lambda ()
1360     (values-list values)))))
1361     (t (format nil "Cannot return from frame: ~S" frame)))))
1362 nsiivola 1.293
1363 jsnellman 1.174 (defimplementation restart-frame (index)
1364 nsiivola 1.293 (let ((frame (nth-frame index)))
1365     (when (sb-debug:frame-has-debug-tag-p frame)
1366     (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1367     (multiple-value-bind (fun arglist)
1368     (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1369     (values (fdefinition fname) args)
1370     (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1371     (sb-debug::frame-args-as-list frame)))
1372     (when (functionp fun)
1373 heller 1.306 (sb-debug:unwind-to-frame-and-call
1374     frame
1375     (lambda ()
1376     ;; Ensure TCO.
1377     (declare (optimize (debug 0)))
1378     (apply fun arglist)))))))
1379 nsiivola 1.293 (format nil "Cannot restart frame: ~S" frame))))
1380 heller 1.152
1381     ;; FIXME: this implementation doesn't unwind the stack before
1382     ;; re-invoking the function, but it's better than no implementation at
1383     ;; all.
1384 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
1385     (progn
1386     (defun sb-debug-catch-tag-p (tag)
1387     (and (symbolp tag)
1388     (not (symbol-package tag))
1389     (string= tag :sb-debug-catch-tag)))
1390    
1391     (defimplementation return-from-frame (index form)
1392     (let* ((frame (nth-frame index))
1393     (probe (assoc-if #'sb-debug-catch-tag-p
1394     (sb-di::frame-catches frame))))
1395     (cond (probe (throw (car probe) (eval-in-frame form index)))
1396     (t (format nil "Cannot return from frame: ~S" frame)))))
1397    
1398     (defimplementation restart-frame (index)
1399     (let ((frame (nth-frame index)))
1400     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1401 jsnellman 1.158
1402 lgorrie 1.87 ;;;;; reference-conditions
1403    
1404     (defimplementation format-sldb-condition (condition)
1405     (let ((sb-int:*print-condition-references* nil))
1406     (princ-to-string condition)))
1407    
1408 heller 1.57
1409     ;;;; Profiling
1410    
1411     (defimplementation profile (fname)
1412     (when fname (eval `(sb-profile:profile ,fname))))
1413    
1414     (defimplementation unprofile (fname)
1415     (when fname (eval `(sb-profile:unprofile ,fname))))
1416    
1417     (defimplementation unprofile-all ()
1418     (sb-profile:unprofile)
1419     "All functions unprofiled.")
1420    
1421     (defimplementation profile-report ()
1422     (sb-profile:report))
1423    
1424     (defimplementation profile-reset ()
1425     (sb-profile:reset)
1426     "Reset profiling counters.")
1427    
1428     (defimplementation profiled-functions ()
1429     (sb-profile:profile))
1430    
1431 heller 1.116 (defimplementation profile-package (package callers methods)
1432     (declare (ignore callers methods))
1433     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1434    
1435 heller 1.57
1436 heller 1.64 ;;;; Inspector
1437 heller 1.63
1438 heller 1.190 (defmethod emacs-inspect ((o t))
1439 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1440 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1441 heller 1.64 (t
1442 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1443 sboukarev 1.271 (list* (string-right-trim '(#\Newline) text)
1444     '(:newline)
1445 heller 1.191 (if label
1446     (loop for (l . v) in parts
1447     append (label-value-line l v))
1448 sboukarev 1.271 (loop for value in parts
1449     for i from 0
1450 heller 1.191 append (label-value-line i value))))))))
1451 heller 1.64
1452 heller 1.190 (defmethod emacs-inspect ((o function))
1453 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1454     (cond ((= header sb-vm:simple-fun-header-widetag)
1455 heller 1.126 (label-value-line*
1456     (:name (sb-kernel:%simple-fun-name o))
1457     (:arglist (sb-kernel:%simple-fun-arglist o))
1458     (:self (sb-kernel:%simple-fun-self o))
1459     (:next (sb-kernel:%simple-fun-next o))
1460     (:type (sb-kernel:%simple-fun-type o))
1461 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1462 heller 1.64 ((= header sb-vm:closure-header-widetag)
1463 jsnellman 1.158 (append
1464 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1465     `("Closed over values:" (:newline))
1466     (loop for i below (1- (sb-kernel:get-closure-length o))
1467 jsnellman 1.158 append (label-value-line
1468 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1469 heller 1.64 (t (call-next-method o)))))
1470    
1471 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1472 jsnellman 1.158 (append
1473     (label-value-line*
1474 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1475     (:entry-points (sb-kernel:%code-entry-points o))
1476     (:debug-info (sb-kernel:%code-debug-info o))
1477 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1478 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1479     `("Constants:" (:newline))
1480 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1481 mbaringer 1.102 below (sb-kernel:get-header-data o)
1482 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1483     `("Code:" (:newline)
1484     , (with-output-to-string (s)
1485     (cond ((sb-kernel:%code-debug-info o)
1486     (sb-disassem:disassemble-code-component o :stream s))
1487     (t
1488 jsnellman 1.158 (sb-disassem:disassemble-memory
1489     (sb-disassem::align
1490 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1491     sb-vm:lowtag-mask)
1492 heller 1.126 (* sb-vm:code-constants-offset
1493     sb-vm:n-word-bytes))
1494 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1495     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1496 heller 1.191 :stream s)))))))
1497 mbaringer 1.102
1498 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1499 mbaringer 1.167 (label-value-line*
1500 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1501 mbaringer 1.167
1502 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1503 heller 1.126 (label-value-line*
1504     (:name (sb-kernel:fdefn-name o))
1505 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1506 mbaringer 1.102
1507 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1508 jsnellman 1.158 (append
1509 heller 1.191 (call-next-method)
1510 heller 1.126 (label-value-line*
1511     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1512     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1513 heller 1.191 )))
1514 heller 1.90
1515 heller 1.63
1516 lgorrie 1.50 ;;;; Multiprocessing
1517    
1518 crhodes 1.136 #+(and sb-thread
1519 sboukarev 1.271 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1520 crhodes 1.136 (progn
1521     (defvar *thread-id-counter* 0)
1522 jsnellman 1.158
1523 crhodes 1.136 (defvar *thread-id-counter-lock*
1524     (sb-thread:make-mutex :name "thread id counter lock"))
1525    
1526     (defun next-thread-id ()
1527     (sb-thread:with-mutex (*thread-id-counter-lock*)
1528     (incf *thread-id-counter*)))
1529 jsnellman 1.158
1530 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1531    
1532     ;; This should be a thread -> id map but as weak keys are not
1533     ;; supported it is id -> map instead.
1534     (defvar *thread-id-map-lock*
1535     (sb-thread:make-mutex :name "thread id map lock"))
1536 jsnellman 1.158
1537 crhodes 1.136 (defimplementation spawn (fn &key name)
1538     (sb-thread:make-thread fn :name name))
1539    
1540     (defimplementation thread-id (thread)
1541 heller 1.160 (block thread-id
1542     (sb-thread:with-mutex (*thread-id-map-lock*)
1543     (loop for id being the hash-key in *thread-id-map*
1544     using (hash-value thread-pointer)
1545     do
1546     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1547     (cond ((null maybe-thread)
1548     ;; the value is gc'd, remove it manually
1549     (remhash id *thread-id-map*))
1550     ((eq thread maybe-thread)
1551     (return-from thread-id id)))))
1552     ;; lazy numbering
1553     (let ((id (next-thread-id)))
1554     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1555     id))))
1556 crhodes 1.136
1557     (defimplementation find-thread (id)
1558     (sb-thread:with-mutex (*thread-id-map-lock*)
1559     (let ((thread-pointer (gethash id *thread-id-map*)))
1560     (if thread-pointer
1561     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1562     (if maybe-thread
1563     maybe-thread
1564     ;; the value is gc'd, remove it manually
1565     (progn
1566     (remhash id *thread-id-map*)
1567     nil)))
1568     nil))))
1569 jsnellman 1.158
1570 crhodes 1.136 (defimplementation thread-name (thread)
1571     ;; sometimes the name is not a string (e.g. NIL)
1572     (princ-to-string (sb-thread:thread-name thread)))
1573    
1574     (defimplementation thread-status (thread)
1575     (if (sb-thread:thread-alive-p thread)
1576 sboukarev 1.253 "Running"
1577     "Stopped"))
1578    
1579 crhodes 1.136 (defimplementation make-lock (&key name)
1580     (sb-thread:make-mutex :name name))
1581    
1582     (defimplementation call-with-lock-held (lock function)
1583     (declare (type function function))
1584 nsiivola 1.154 (sb-thread:with-recursive-lock (lock) (funcall function)))
1585    
1586 crhodes 1.136 (defimplementation current-thread ()
1587     sb-thread:*current-thread*)
1588    
1589     (defimplementation all-threads ()
1590     (sb-thread:list-all-threads))
1591 jsnellman 1.158
1592 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1593     (sb-thread:interrupt-thread thread fn))
1594    
1595     (defimplementation kill-thread (thread)
1596     (sb-thread:terminate-thread thread))
1597    
1598     (defimplementation thread-alive-p (thread)
1599     (sb-thread:thread-alive-p thread))
1600    
1601     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1602     (defvar *mailboxes* (list))
1603     (declaim (type list *mailboxes*))
1604    
1605 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1606 crhodes 1.136 thread
1607     (mutex (sb-thread:make-mutex))
1608     (waitqueue (sb-thread:make-waitqueue))
1609     (queue '() :type list))
1610    
1611     (defun mailbox (thread)
1612     "Return THREAD's mailbox."
1613     (sb-thread:with-mutex (*mailbox-lock*)
1614     (or (find thread *mailboxes* :key #'mailbox.thread)
1615     (let ((mb (make-mailbox :thread thread)))
1616     (push mb *mailboxes*)
1617     mb))))
1618    
1619     (defimplementation send (thread message)
1620     (let* ((mbox (mailbox thread))
1621     (mutex (mailbox.mutex mbox)))
1622     (sb-thread:with-mutex (mutex)
1623     (setf (mailbox.queue mbox)
1624     (nconc (mailbox.queue mbox) (list message)))
1625     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1626 heller 1.317
1627 heller 1.318
1628 trittweiler 1.270 (defun condition-timed-wait (waitqueue mutex timeout)
1629 heller 1.317 (macrolet ((foo ()
1630 heller 1.318 (cond ((and (> (length (sb-introspect:function-lambda-list
1631     #'sb-thread:condition-wait))
1632     2)
1633     nil ; FIXME: :timeout doesn't work. Why?
1634     )
1635 heller 1.317 '(sb-thread:condition-wait waitqueue mutex
1636     :timeout timeout))
1637     ((member :sb-lutex *features*) ; Darwin
1638     '(sb-thread:condition-wait waitqueue mutex))
1639     (t
1640     '(handler-case
1641     (let ((*break-on-signals* nil))
1642     (sb-sys:with-deadline (:seconds timeout
1643     :override t)
1644     (sb-thread:condition-wait waitqueue mutex) t))
1645     (sb-ext:timeout ()
1646     nil))))))
1647     (foo)))
1648 trittweiler 1.270
1649 heller 1.212 (defimplementation receive-if (test &optional timeout)
1650 heller 1.209 (let* ((mbox (mailbox (current-thread)))
1651 trittweiler 1.270 (mutex (mailbox.mutex mbox))
1652     (waitq (mailbox.waitqueue mbox)))
1653 heller 1.212 (assert (or (not timeout) (eq timeout t)))
1654 heller 1.207 (loop
1655     (check-slime-interrupts)
1656 heller 1.209 (sb-thread:with-mutex (mutex)
1657 heller 1.202 (let* ((q (mailbox.queue mbox))
1658     (tail (member-if test q)))
1659 heller 1.207 (when tail
1660     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1661     (return (car tail))))
1662 heller 1.212 (when (eq timeout t) (return (values nil t)))
1663 trittweiler 1.270 (condition-timed-wait waitq mutex 0.2)))))
1664 heller 1.301
1665     (let ((alist '())
1666     (mutex (sb-thread:make-mutex :name "register-thread")))
1667    
1668     (defimplementation register-thread (name thread)
1669     (declare (type symbol name))
1670     (sb-thread:with-mutex (mutex)
1671     (etypecase thread
1672     (null
1673     (setf alist (delete name alist :key #'car)))
1674     (sb-thread:thread
1675     (let ((probe (assoc name alist)))
1676     (cond (probe (setf (cdr probe) thread))
1677     (t (setf alist (acons name thread alist))))))))
1678     nil)
1679    
1680     (defimplementation find-registered (name)
1681     (sb-thread:with-mutex (mutex)
1682     (cdr (assoc name alist)))))
1683    
1684 nsiivola 1.308 ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1685     ;; buffer write lock.
1686     ;;
1687     ;; Another alternative would be to grab the world-lock here, but that's less
1688     ;; future-proof, and could introduce other lock-ordering issues in the
1689     ;; future.
1690     ;;
1691     ;; In an ideal world we would just have an :AROUND method on
1692     ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1693     ;; file is loaded -- so first we need a dummy definition that will be
1694     ;; overridden by swank-gray.lisp.
1695     (defclass slime-output-stream (fundamental-character-output-stream)
1696     ())
1697     (defmethod stream-force-output :around ((stream slime-output-stream))
1698     (handler-case
1699     (sb-sys:with-deadline (:seconds 0.1)
1700     (call-next-method))
1701     (sb-sys:deadline-timeout ()
1702     nil)))
1703    
1704 heller 1.59 )
1705 heller 1.126
1706     (defimplementation quit-lisp ()
1707 sboukarev 1.311 #+#.(swank-backend:with-symbol 'exit 'sb-ext)
1708     (sb-ext:exit)
1709     #-#.(swank-backend:with-symbol 'exit 'sb-ext)
1710     (progn
1711     #+sb-thread
1712     (dolist (thread (remove (current-thread) (all-threads)))
1713     (ignore-errors (sb-thread:terminate-thread thread)))
1714     (sb-ext:quit)))
1715 heller 1.133
1716 mbaringer 1.117
1717 heller 1.118
1718 mbaringer 1.117 ;;Trace implementations
1719     ;;In SBCL, we have:
1720     ;; (trace <name>)
1721 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1722 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1723     ;; <name> can be a normal name or a (setf name)
1724    
1725 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1726 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1727     (eval `(untrace ,fspec))
1728     (format nil "~S is now untraced." fspec))
1729     (t
1730     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1731     (format nil "~S is now traced." fspec))))
1732    
1733     (defun process-fspec (fspec)
1734     (cond ((consp fspec)
1735     (ecase (first fspec)
1736     ((:defun :defgeneric) (second fspec))
1737     ((:defmethod) `(method ,@(rest fspec)))
1738     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1739     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1740     (t
1741     fspec)))
1742    
1743 heller 1.119 (defimplementation toggle-trace (spec)
1744     (ecase (car spec)
1745 jsnellman 1.158 ((setf)
1746 heller 1.119 (toggle-trace-aux spec))
1747     ((:defmethod)
1748     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1749     ((:defgeneric)
1750     (toggle-trace-aux (second spec) :methods t))
1751     ((:call)
1752     (destructuring-bind (caller callee) (cdr spec)
1753     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1754 mkoeppe 1.142
1755     ;;; Weak datastructures
1756    
1757 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1758     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1759     (apply #'make-hash-table :weakness :key args)
1760     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1761     (apply #'make-hash-table args))
1762 mkoeppe 1.142
1763 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1764 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1765     (apply #'make-hash-table :weakness :value args)
1766     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1767     (apply #'make-hash-table args))
1768 alendvai 1.173
1769     (defimplementation hash-table-weakness (hashtable)
1770     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1771     (sb-ext:hash-table-weakness hashtable))
1772 heller 1.214
1773     #-win32
1774     (defimplementation save-image (filename &optional restart-function)
1775 heller 1.274 (flet ((restart-sbcl ()
1776     (sb-debug::enable-debugger)
1777     (setf sb-impl::*descriptor-handlers* nil)
1778     (funcall restart-function)))
1779     (let ((pid (sb-posix:fork)))
1780     (cond ((= pid 0)
1781     (sb-debug::disable-debugger)
1782     (apply #'sb-ext:save-lisp-and-die filename
1783     (when restart-function
1784     (list :toplevel #'restart-sbcl))))
1785     (t
1786     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1787     (assert (= pid rpid))
1788     (assert (and (sb-posix:wifexited status)
1789     (zerop (sb-posix:wexitstatus status))))))))))
1790    
1791     #+unix
1792     (progn
1793 nsiivola 1.281 (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1794 heller 1.274 (program sb-alien:c-string)
1795     (argv (* sb-alien:c-string)))
1796 nsiivola 1.281
1797 heller 1.274 (defun execv (program args)
1798     "Replace current executable with another one."
1799     (let ((a-args (sb-alien:make-alien sb-alien:c-string
1800     (+ 1 (length args)))))
1801     (unwind-protect
1802     (progn
1803     (loop for index from 0 by 1
1804     and item in (append args '(nil))
1805     do (setf (sb-alien:deref a-args index)
1806     item))
1807     (when (minusp
1808     (sys-execv program a-args))
1809 nsiivola 1.281 (error "execv(3) returned.")))
1810 heller 1.274 (sb-alien:free-alien a-args))))
1811    
1812 sboukarev 1.275 (defun runtime-pathname ()
1813     #+#.(swank-backend:with-symbol
1814     '*runtime-pathname* 'sb-ext)
1815     sb-ext:*runtime-pathname*
1816     #-#.(swank-backend:with-symbol
1817     '*runtime-pathname* 'sb-ext)
1818     (car sb-ext:*posix-argv*))
1819    
1820 heller 1.274 (defimplementation exec-image (image-file args)
1821     (loop with fd-arg =
1822     (loop for arg in args
1823     and key = "" then arg
1824     when (string-equal key "--swank-fd")
1825 sboukarev 1.275 return (parse-integer arg))
1826 heller 1.274 for my-fd from 3 to 1024
1827     when (/= my-fd fd-arg)
1828 sboukarev 1.275 do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1829     (let* ((self-string (pathname-to-filename (runtime-pathname))))
1830 heller 1.274 (execv
1831     self-string
1832     (apply 'list self-string "--core" image-file args)))))
1833    
1834     (defimplementation make-fd-stream (fd external-format)
1835     (sb-sys:make-fd-stream fd :input t :output t
1836     :element-type 'character
1837     :buffering :full
1838     :dual-channel-p t
1839     :external-format external-format))
1840    
1841 sboukarev 1.277 #-win32
1842     (defimplementation background-save-image (filename &key restart-function
1843     completion-function)
1844 heller 1.274 (flet ((restart-sbcl ()
1845     (sb-debug::enable-debugger)
1846     (setf sb-impl::*descriptor-handlers* nil)
1847     (funcall restart-function)))
1848     (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1849     (let ((pid (sb-posix:fork)))
1850     (cond ((= pid 0)
1851     (sb-posix:close pipe-in)
1852     (sb-debug::disable-debugger)
1853     (apply #'sb-ext:save-lisp-and-die filename
1854     (when restart-function
1855     (list :toplevel #'restart-sbcl))))
1856     (t
1857     (sb-posix:close pipe-out)
1858     (sb-sys:add-fd-handler
1859     pipe-in :input
1860     (lambda (fd)
1861     (sb-sys:invalidate-descriptor fd)
1862     (sb-posix:close fd)
1863     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1864     (assert (= pid rpid))
1865     (assert (sb-posix:wifexited status))
1866     (funcall completion-function
1867     (zerop (sb-posix:wexitstatus status))))))))))))
1868 nsiivola 1.278
1869     (defun deinit-log-output ()
1870     ;; Can't hang on to an fd-stream from a previous session.
1871 sboukarev 1.279 (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1872     nil))
1873 nsiivola 1.278
1874     (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5