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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.330 - (hide annotations)
Fri Nov 1 14:42:09 2013 UTC (5 months, 2 weeks ago) by heller
Branch: MAIN
Changes since 1.329: +25 -25 lines
* swank-sbcl.lisp (swank-compile-string): Fix last commit.  Honor
*trap-load-time-warnings* but without calling LOAD inside
WITH-COMPILATION-UNIT.
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 sboukarev 1.328 (defimplementation type-specifier-p (symbol)
442     (or (sb-ext:valid-type-specifier-p symbol)
443     (not (eq (type-specifier-arglist symbol) :not-available))))
444 trittweiler 1.246
445 dbarlow 1.42 (defvar *buffer-name* nil)
446 nsiivola 1.282 (defvar *buffer-tmpfile* nil)
447 dbarlow 1.1 (defvar *buffer-offset*)
448 heller 1.70 (defvar *buffer-substring* nil)
449 dbarlow 1.1
450 lgorrie 1.24 (defvar *previous-compiler-condition* nil
451     "Used to detect duplicates.")
452    
453 dbarlow 1.1 (defun handle-notification-condition (condition)
454     "Handle a condition caused by a compiler warning.
455     This traps all compiler conditions at a lower-level than using
456     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
457     craft our own error messages, which can omit a lot of redundant
458     information."
459 nsiivola 1.206 (unless (or (eq condition *previous-compiler-condition*))
460     ;; First resignal warnings, so that outer handlers -- which may choose to
461     ;; muffle this -- get a chance to run.
462     (when (typep condition 'warning)
463     (signal condition))
464     (setq *previous-compiler-condition* condition)
465 trittweiler 1.260 (signal-compiler-condition (real-condition condition)
466     (sb-c::find-error-context nil))))
467 lgorrie 1.24
468     (defun signal-compiler-condition (condition context)
469 sboukarev 1.324 (signal 'compiler-condition
470     :original-condition condition
471     :severity (etypecase condition
472     (sb-ext:compiler-note :note)
473     (sb-c:compiler-error :error)
474     (reader-error :read-error)
475     (error :error)
476     #+#.(swank-backend:with-symbol redefinition-warning
477     sb-kernel)
478     (sb-kernel:redefinition-warning
479     :redefinition)
480     (style-warning :style-warning)
481     (warning :warning))
482     :references (condition-references condition)
483     :message (brief-compiler-message-for-emacs condition)
484     :source-context (compiler-error-context context)
485     :location (compiler-note-location condition context)))
486 heller 1.107
487     (defun real-condition (condition)
488     "Return the encapsulated condition or CONDITION itself."
489     (typecase condition
490     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
491     (t condition)))
492 lgorrie 1.24
493 heller 1.184 (defun condition-references (condition)
494     (if (typep condition 'sb-int:reference-condition)
495     (externalize-reference
496     (sb-int:reference-condition-references condition))))
497    
498 trittweiler 1.235 (defun compiler-note-location (condition context)
499     (flet ((bailout ()
500 trittweiler 1.266 (return-from compiler-note-location
501     (make-error-location "No error location available"))))
502 trittweiler 1.235 (cond (context
503     (locate-compiler-note
504     (sb-c::compiler-error-context-file-name context)
505     (compiler-source-path context)
506     (sb-c::compiler-error-context-original-source context)))
507     ((typep condition 'reader-error)
508 trittweiler 1.236 (let* ((stream (stream-error-stream condition))
509     (file (pathname stream)))
510     (unless (open-stream-p stream)
511     (bailout))
512     (if (compiling-from-buffer-p file)
513 heller 1.306 ;; The stream position for e.g. "comma not inside
514     ;; backquote" is at the character following the
515     ;; comma, :offset is 0-based, hence the 1-.
516 trittweiler 1.236 (make-location (list :buffer *buffer-name*)
517     (list :offset *buffer-offset*
518 trittweiler 1.237 (1- (file-position stream))))
519 trittweiler 1.236 (progn
520     (assert (compiling-from-file-p file))
521 trittweiler 1.237 ;; No 1- because :position is 1-based.
522 trittweiler 1.236 (make-location (list :file (namestring file))
523     (list :position (file-position stream)))))))
524 trittweiler 1.235 (t (bailout)))))
525 heller 1.124
526 trittweiler 1.236 (defun compiling-from-buffer-p (filename)
527 trittweiler 1.266 (and *buffer-name*
528     ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
529 nsiivola 1.282 ;; in LOCATE-COMPILER-NOTE, and allows handling nested
530     ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
531 nsiivola 1.284 ;;
532     ;; PROBE-FILE to handle tempfile directory being a symlink.
533 nsiivola 1.282 (pathnamep filename)
534 nsiivola 1.284 (let ((true1 (probe-file filename))
535     (true2 (probe-file *buffer-tmpfile*)))
536     (and true1 (equal true1 true2)))))
537 trittweiler 1.236
538     (defun compiling-from-file-p (filename)
539 nsiivola 1.282 (and (pathnamep filename)
540     (or (null *buffer-name*)
541 nsiivola 1.284 (null *buffer-tmpfile*)
542     (let ((true1 (probe-file filename))
543     (true2 (probe-file *buffer-tmpfile*)))
544     (not (and true1 (equal true1 true2)))))))
545 trittweiler 1.236
546     (defun compiling-from-generated-code-p (filename source)
547     (and (eq filename :lisp) (stringp source)))
548    
549 heller 1.127 (defun locate-compiler-note (file source-path source)
550 trittweiler 1.236 (cond ((compiling-from-buffer-p file)
551 heller 1.219 (make-location (list :buffer *buffer-name*)
552     (list :offset *buffer-offset*
553     (source-path-string-position
554     source-path *buffer-substring*))))
555 trittweiler 1.236 ((compiling-from-file-p file)
556 heller 1.124 (make-location (list :file (namestring file))
557 heller 1.219 (list :position (1+ (source-path-file-position
558     source-path file)))))
559 trittweiler 1.236 ((compiling-from-generated-code-p file source)
560 heller 1.127 (make-location (list :source-form source)
561     (list :position 1)))
562 dbarlow 1.42 (t
563 heller 1.306 (error "unhandled case in compiler note ~S ~S ~S"
564     file source-path source))))
565 dbarlow 1.42
566 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
567 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
568     When Emacs presents the message it already has the source popped up
569     and the source form highlighted. This makes much of the information in
570     the error-context redundant."
571 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
572     (princ-to-string condition)))
573 heller 1.66
574 heller 1.248 (defun compiler-error-context (error-context)
575 heller 1.66 "Describe a compiler error for Emacs including context information."
576 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
577 heller 1.66 (multiple-value-bind (enclosing source)
578     (if error-context
579     (values (sb-c::compiler-error-context-enclosing-source error-context)
580     (sb-c::compiler-error-context-source error-context)))
581 heller 1.248 (and (or enclosing source)
582     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
583     enclosing source))))
584 dbarlow 1.1
585 heller 1.124 (defun compiler-source-path (context)
586 dbarlow 1.1 "Return the source-path for the current compiler error.
587     Returns NIL if this cannot be determined by examining internal
588     compiler state."
589     (cond ((sb-c::node-p context)
590     (reverse
591     (sb-c::source-path-original-source
592     (sb-c::node-source-path context))))
593     ((sb-c::compiler-error-context-p context)
594     (reverse
595     (sb-c::compiler-error-context-original-source-path context)))))
596    
597 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
598 heller 1.58 (declare (type function function))
599 trittweiler 1.238 (handler-bind
600     ;; N.B. Even though these handlers are called HANDLE-FOO they
601     ;; actually decline, i.e. the signalling of the original
602     ;; condition continues upward.
603 trittweiler 1.260 ((sb-c:fatal-compiler-error #'handle-notification-condition)
604     (sb-c:compiler-error #'handle-notification-condition)
605     (sb-ext:compiler-note #'handle-notification-condition)
606     (error #'handle-notification-condition)
607     (warning #'handle-notification-condition))
608 dbarlow 1.41 (funcall function)))
609 lgorrie 1.24
610 sboukarev 1.268 (defun compiler-policy (qualities)
611     "Return compiler policy qualities present in the QUALITIES alist.
612     QUALITIES is an alist with (quality . value)"
613     #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
614     (loop with policy = (sb-ext:restrict-compiler-policy)
615     for (quality) in qualities
616     collect (cons quality
617     (or (cdr (assoc quality policy))
618     0))))
619    
620     (defun (setf compiler-policy) (policy)
621     (declare (ignorable policy))
622     #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
623     (loop for (qual . value) in policy
624     do (sb-ext:restrict-compiler-policy qual value)))
625    
626     (defmacro with-compiler-policy (policy &body body)
627     (let ((current-policy (gensym)))
628     `(let ((,current-policy (compiler-policy ,policy)))
629     (setf (compiler-policy) ,policy)
630     (unwind-protect (progn ,@body)
631     (setf (compiler-policy) ,current-policy)))))
632    
633 heller 1.330 (defimplementation swank-compile-file (input-file output-file
634 sboukarev 1.268 load-p external-format
635     &key policy)
636 trittweiler 1.264 (multiple-value-bind (output-file warnings-p failure-p)
637 sboukarev 1.268 (with-compiler-policy policy
638     (with-compilation-hooks ()
639     (compile-file input-file :output-file output-file
640     :external-format external-format)))
641 trittweiler 1.264 (values output-file warnings-p
642     (or failure-p
643     (when load-p
644     ;; Cache the latest source file for definition-finding.
645 heller 1.330 (source-cache-get input-file
646 trittweiler 1.264 (file-write-date input-file))
647     (not (load output-file)))))))
648 lgorrie 1.24
649 heller 1.124 ;;;; compile-string
650    
651 heller 1.156 ;;; We copy the string to a temporary file in order to get adequate
652     ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
653     ;;; which the previous approach using
654     ;;; (compile nil `(lambda () ,(read-from-string string)))
655     ;;; did not provide.
656    
657 heller 1.245 (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
658    
659 heller 1.242 (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
660     sb-alien:c-string
661     (dir sb-alien:c-string)
662     (prefix sb-alien:c-string))
663 heller 1.156
664 heller 1.245 )
665    
666 heller 1.156 (defun temp-file-name ()
667     "Return a temporary file name to compile strings into."
668 heller 1.242 (tempnam nil nil))
669 heller 1.156
670 heller 1.330 (defvar *trap-load-time-warnings* t)
671    
672 heller 1.231 (defimplementation swank-compile-string (string &key buffer position filename
673     policy)
674 heller 1.156 (let ((*buffer-name* buffer)
675     (*buffer-offset* position)
676     (*buffer-substring* string)
677 nsiivola 1.282 (*buffer-tmpfile* (temp-file-name)))
678 heller 1.330 (labels ((load-it (filename)
679     (when filename (load filename)))
680     (cf ()
681     (with-compiler-policy policy
682     (with-compilation-unit
683     (:source-plist (list :emacs-buffer buffer
684     :emacs-filename filename
685     :emacs-string string
686     :emacs-position position)
687     :source-namestring filename
688     :allow-other-keys t)
689     (compile-file *buffer-tmpfile* :external-format :utf-8))))
690     (compile-it (cont)
691     (with-compilation-hooks ()
692     (multiple-value-bind (output-file warningsp failurep) (cf)
693     (declare (ignore warningsp))
694     (unless failurep
695     (funcall cont output-file))))))
696 heller 1.303 (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
697     :external-format :utf-8)
698 heller 1.156 (write-string string s))
699     (unwind-protect
700 heller 1.330 (if *trap-load-time-warnings*
701     (compile-it #'load-it)
702     (load-it (compile-it #'identity)))
703 heller 1.156 (ignore-errors
704 nsiivola 1.282 (delete-file *buffer-tmpfile*)
705     (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
706 dbarlow 1.1
707     ;;;; Definitions
708    
709 jsnellman 1.149 (defparameter *definition-types*
710     '(:variable defvar
711     :constant defconstant
712     :type deftype
713     :symbol-macro define-symbol-macro
714     :macro defmacro
715     :compiler-macro define-compiler-macro
716     :function defun
717     :generic-function defgeneric
718     :method defmethod
719     :setf-expander define-setf-expander
720     :structure defstruct
721 jsnellman 1.159 :condition define-condition
722 jsnellman 1.149 :class defclass
723     :method-combination define-method-combination
724     :package defpackage
725     :transform :deftransform
726     :optimizer :defoptimizer
727     :vop :define-vop
728     :source-transform :define-source-transform)
729     "Map SB-INTROSPECT definition type names to Slime-friendly forms")
730    
731 trittweiler 1.234 (defun definition-specifier (type name)
732     "Return a pretty specifier for NAME representing a definition of type TYPE."
733     (if (and (symbolp name)
734     (eq type :function)
735     (sb-int:info :function :ir1-convert name))
736     :def-ir1-translator
737     (getf *definition-types* type)))
738    
739 trittweiler 1.258 (defun make-dspec (type name source-location)
740 nsiivola 1.276 (let ((spec (definition-specifier type name))
741     (desc (sb-introspect::definition-source-description source-location)))
742     (if (eq :define-vop spec)
743     ;; The first part of the VOP description is the name of the template
744     ;; -- which is actually good information and often long. So elide the
745     ;; original name in favor of making the interesting bit more visible.
746     ;;
747 heller 1.306 ;; The second part of the VOP description is the associated
748     ;; compiler note, or NIL -- which is quite uninteresting and
749     ;; confuses the eye when reading the actual name which usually
750     ;; has a worthwhile postfix. So drop the note.
751 nsiivola 1.276 (list spec (car desc))
752     (list* spec name desc))))
753 trittweiler 1.234
754 jsnellman 1.149 (defimplementation find-definitions (name)
755     (loop for type in *definition-types* by #'cddr
756 trittweiler 1.261 for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
757     append (loop for defsrc in defsrcs collect
758     (list (make-dspec type name defsrc)
759 trittweiler 1.267 (converting-errors-to-error-location
760 heller 1.306 (definition-source-for-emacs defsrc
761     type name))))))
762 jsnellman 1.149
763 trittweiler 1.193 (defimplementation find-source-location (obj)
764     (flet ((general-type-of (obj)
765     (typecase obj
766     (method :method)
767     (generic-function :generic-function)
768     (function :function)
769     (structure-class :structure-class)
770     (class :class)
771     (method-combination :method-combination)
772 trittweiler 1.200 (package :package)
773 trittweiler 1.261 (condition :condition)
774 trittweiler 1.193 (structure-object :structure-object)
775     (standard-object :standard-object)
776     (t :thing)))
777     (to-string (obj)
778     (typecase obj
779 heller 1.306 ;; Packages are possibly named entities.
780     (package (princ-to-string obj))
781 trittweiler 1.193 ((or structure-object standard-object condition)
782     (with-output-to-string (s)
783     (print-unreadable-object (obj s :type t :identity t))))
784 trittweiler 1.200 (t (princ-to-string obj)))))
785 trittweiler 1.267 (converting-errors-to-error-location
786 trittweiler 1.261 (let ((defsrc (sb-introspect:find-definition-source obj)))
787     (definition-source-for-emacs defsrc
788     (general-type-of obj)
789     (to-string obj))))))
790 jsnellman 1.149
791 heller 1.316 (defmacro with-definition-source ((&rest names) obj &body body)
792     "Like with-slots but works only for structs."
793     (flet ((reader (slot)
794     ;; Use read-from-string instead of intern so that
795     ;; conc-name can be a string such as ext:struct- and not
796     ;; cause errors and not force interning ext::struct-
797     (read-from-string
798     (concatenate 'string "sb-introspect:definition-source-"
799     (string slot)))))
800     (let ((tmp (gensym "OO-")))
801     ` (let ((,tmp ,obj))
802     (symbol-macrolet
803     ,(loop for name in names collect
804     (typecase name
805     (symbol `(,name (,(reader name) ,tmp)))
806     (cons `(,(first name) (,(reader (second name)) ,tmp)))
807     (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
808     ,@body)))))
809 trittweiler 1.234
810 trittweiler 1.261 (defun categorize-definition-source (definition-source)
811 heller 1.316 (with-definition-source (pathname form-path character-offset plist)
812     definition-source
813 sboukarev 1.312 (let ((file-p (and pathname (probe-file pathname)
814     (or form-path character-offset))))
815     (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
816     ((getf plist :emacs-buffer) :buffer)
817     (file-p :file)
818     (pathname :file-without-position)
819     (t :invalid)))))
820 trittweiler 1.261
821 sboukarev 1.310 (defun definition-source-buffer-location (definition-source)
822 heller 1.316 (with-definition-source (form-path character-offset plist) definition-source
823 sboukarev 1.310 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
824     emacs-string &allow-other-keys)
825     plist
826     (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
827     (multiple-value-bind (start end)
828     (if form-path
829     (with-debootstrapping
830     (source-path-string-position form-path
831     emacs-string))
832     (values character-offset
833     most-positive-fixnum))
834     (make-location
835     `(:buffer ,emacs-buffer)
836     `(:offset ,emacs-position ,start)
837     `(:snippet
838     ,(subseq emacs-string
839     start
840     (min end (+ start *source-snippet-size*))))))))))
841    
842     (defun definition-source-file-location (definition-source)
843 heller 1.316 (with-definition-source (pathname form-path character-offset plist
844     file-write-date) definition-source
845 sboukarev 1.310 (let* ((namestring (namestring (translate-logical-pathname pathname)))
846     (pos (if form-path
847     (source-file-position namestring file-write-date
848     form-path)
849     character-offset))
850     (snippet (source-hint-snippet namestring file-write-date pos)))
851     (make-location `(:file ,namestring)
852     ;; /file positions/ in Common Lisp start from
853     ;; 0, buffer positions in Emacs start from 1.
854     `(:position ,(1+ pos))
855     `(:snippet ,snippet)))))
856    
857 sboukarev 1.312 (defun definition-source-buffer-and-file-location (definition-source)
858     (let ((buffer (definition-source-buffer-location definition-source))
859     (file (definition-source-file-location definition-source)))
860     (make-location (list :buffer-and-file
861     (cadr (location-buffer buffer))
862     (cadr (location-buffer file)))
863 sboukarev 1.313 (location-position buffer)
864     (location-hints buffer))))
865 sboukarev 1.312
866 trittweiler 1.261 (defun definition-source-for-emacs (definition-source type name)
867 heller 1.316 (with-definition-source (pathname form-path character-offset plist
868     file-write-date)
869     definition-source
870 sboukarev 1.314 (ecase (categorize-definition-source definition-source)
871     (:buffer-and-file
872     (definition-source-buffer-and-file-location definition-source))
873     (:buffer
874     (definition-source-buffer-location definition-source))
875     (:file
876     (definition-source-file-location definition-source))
877     (:file-without-position
878     (make-location `(:file ,(namestring
879     (translate-logical-pathname pathname)))
880     '(:position 1)
881     (when (eql type :function)
882     `(:snippet ,(format nil "(defun ~a "
883     (symbol-name name))))))
884     (:invalid
885     (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
886 trittweiler 1.261 meaningful information."
887 sboukarev 1.314 type name)))))
888 jsnellman 1.149
889 trittweiler 1.261 (defun source-file-position (filename write-date form-path)
890 jsnellman 1.172 (let ((source (get-source-code filename write-date))
891     (*readtable* (guess-readtable-for-filename filename)))
892 trittweiler 1.192 (with-debootstrapping
893 trittweiler 1.261 (source-path-string-position form-path source))))
894 jsnellman 1.172
895 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
896 trittweiler 1.241 (read-snippet-from-string (get-source-code filename write-date) position))
897 jsnellman 1.149
898 jsnellman 1.151 (defun function-source-location (function &optional name)
899     (declare (type function function))
900 trittweiler 1.261 (definition-source-for-emacs (sb-introspect:find-definition-source function)
901     :function
902     (or name (function-name function))))
903 jsnellman 1.151
904 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
905 dbarlow 1.1 "Return a plist describing SYMBOL.
906     Return NIL if the symbol is unbound."
907     (let ((result '()))
908 heller 1.133 (flet ((doc (kind)
909     (or (documentation symbol kind) :not-documented))
910     (maybe-push (property value)
911     (when value
912     (setf result (list* property value result)))))
913 dbarlow 1.1 (maybe-push
914     :variable (multiple-value-bind (kind recorded-p)
915     (sb-int:info :variable :kind symbol)
916     (declare (ignore kind))
917     (if (or (boundp symbol) recorded-p)
918     (doc 'variable))))
919 heller 1.133 (when (fboundp symbol)
920     (maybe-push
921     (cond ((macro-function symbol) :macro)
922     ((special-operator-p symbol) :special-operator)
923     ((typep (fdefinition symbol) 'generic-function)
924     :generic-function)
925     (t :function))
926     (doc 'function)))
927 dbarlow 1.1 (maybe-push
928     :setf (if (or (sb-int:info :setf :inverse symbol)
929     (sb-int:info :setf :expander symbol))
930     (doc 'setf)))
931     (maybe-push
932     :type (if (sb-int:info :type :kind symbol)
933     (doc 'type)))
934 lgorrie 1.24 result)))
935 dbarlow 1.1
936 heller 1.74 (defimplementation describe-definition (symbol type)
937 lgorrie 1.54 (case type
938     (:variable
939 heller 1.74 (describe symbol))
940     (:function
941     (describe (symbol-function symbol)))
942 lgorrie 1.54 (:setf
943 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
944     (sb-int:info :setf :expander symbol))))
945 lgorrie 1.54 (:class
946 heller 1.74 (describe (find-class symbol)))
947 lgorrie 1.54 (:type
948 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
949 jsnellman 1.172
950     #+#.(swank-backend::sbcl-with-xref-p)
951     (progn
952 trittweiler 1.255 (defmacro defxref (name &optional fn-name)
953 jsnellman 1.172 `(defimplementation ,name (what)
954     (sanitize-xrefs
955     (mapcar #'source-location-for-xref-data
956 trittweiler 1.255 (,(find-symbol (symbol-name (if fn-name
957     fn-name
958     name))
959     "SB-INTROSPECT")
960 jsnellman 1.172 what)))))
961     (defxref who-calls)
962     (defxref who-binds)
963     (defxref who-sets)
964     (defxref who-references)
965 trittweiler 1.222 (defxref who-macroexpands)
966 sboukarev 1.263 #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
967 trittweiler 1.255 (defxref who-specializes who-specializes-directly))
968 jsnellman 1.172
969     (defun source-location-for-xref-data (xref-data)
970 trittweiler 1.261 (destructuring-bind (name . defsrc) xref-data
971 trittweiler 1.267 (list name (converting-errors-to-error-location
972 trittweiler 1.261 (definition-source-for-emacs defsrc 'function name)))))
973 dbarlow 1.1
974 heller 1.97 (defimplementation list-callers (symbol)
975     (let ((fn (fdefinition symbol)))
976 heller 1.168 (sanitize-xrefs
977     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
978 heller 1.97
979     (defimplementation list-callees (symbol)
980     (let ((fn (fdefinition symbol)))
981 heller 1.168 (sanitize-xrefs
982     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
983 heller 1.97
984 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
985 heller 1.168 (remove-duplicates
986     (remove-if (lambda (f)
987     (member f (ignored-xref-function-names)))
988 jsnellman 1.172 (loop for entry in xrefs
989     for name = (car entry)
990     collect (if (and (consp name)
991     (member (car name)
992     '(sb-pcl::fast-method
993     sb-pcl::slow-method
994     sb-pcl::method)))
995     (cons (cons 'defmethod (cdr name))
996     (cdr entry))
997     entry))
998 heller 1.168 :key #'car)
999     :test (lambda (a b)
1000     (and (eq (first a) (first b))
1001     (equal (second a) (second b))))))
1002    
1003     (defun ignored-xref-function-names ()
1004     #-#.(swank-backend::sbcl-with-new-stepper-p)
1005     '(nil sb-c::step-form sb-c::step-values)
1006     #+#.(swank-backend::sbcl-with-new-stepper-p)
1007     '(nil))
1008 jsnellman 1.166
1009 lgorrie 1.122 (defun function-dspec (fn)
1010     "Describe where the function FN was defined.
1011     Return a list of the form (NAME LOCATION)."
1012 trittweiler 1.261 (let ((name (function-name fn)))
1013 trittweiler 1.267 (list name (converting-errors-to-error-location
1014 trittweiler 1.258 (function-source-location fn name)))))
1015 lgorrie 1.122
1016 dbarlow 1.4 ;;; macroexpansion
1017 dbarlow 1.1
1018 lgorrie 1.54 (defimplementation macroexpand-all (form)
1019 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
1020     (sb-walker:walk-form form)))
1021 lgorrie 1.25
1022 dbarlow 1.1
1023     ;;; Debugging
1024    
1025 trittweiler 1.257 ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
1026     ;;; than just a hook into BREAK. In particular, it'll make
1027     ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1028     ;;; than the native debugger. That should probably be considered a
1029     ;;; feature.
1030 dbarlow 1.1
1031 trittweiler 1.194 (defun make-invoke-debugger-hook (hook)
1032 trittweiler 1.259 (when hook
1033     #'(sb-int:named-lambda swank-invoke-debugger-hook
1034     (condition old-hook)
1035     (if *debugger-hook*
1036     nil ; decline, *DEBUGGER-HOOK* will be tried next.
1037     (funcall hook condition old-hook)))))
1038 trittweiler 1.194
1039 trittweiler 1.257 (defun set-break-hook (hook)
1040     (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1041    
1042     (defun call-with-break-hook (hook continuation)
1043     (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1044     (funcall continuation)))
1045    
1046 heller 1.148 (defimplementation install-debugger-globally (function)
1047 trittweiler 1.194 (setq *debugger-hook* function)
1048 trittweiler 1.257 (set-break-hook function))
1049 heller 1.148
1050 jsnellman 1.162 (defimplementation condition-extras (condition)
1051 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1052     ((typep condition 'sb-impl::step-form-condition)
1053     `((:show-frame-source 0)))
1054     ((typep condition 'sb-int:reference-condition)
1055     (let ((refs (sb-int:reference-condition-references condition)))
1056     (if refs
1057     `((:references ,(externalize-reference refs))))))))
1058    
1059     (defun externalize-reference (ref)
1060     (etypecase ref
1061     (null nil)
1062     (cons (cons (externalize-reference (car ref))
1063     (externalize-reference (cdr ref))))
1064     ((or string number) ref)
1065     (symbol
1066     (cond ((eq (symbol-package ref) (symbol-package :test))
1067     ref)
1068     (t (symbol-name ref))))))
1069 jsnellman 1.162
1070 trittweiler 1.257 (defvar *sldb-stack-top*)
1071    
1072 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1073 heller 1.58 (declare (type function debugger-loop-fn))
1074 sboukarev 1.323 (let ((*sldb-stack-top*
1075     (if (and (not *debug-swank-backend*)
1076     sb-debug:*stack-top-hint*)
1077     #+#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
1078     (sb-debug::resolve-stack-top-hint)
1079     #-#.(swank-backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
1080     sb-debug:*stack-top-hint*
1081     (sb-di:top-frame)))
1082     (sb-debug:*stack-top-hint* nil))
1083 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
1084 sboukarev 1.323 (lambda (condition)
1085     (signal 'sldb-condition
1086     :original-condition condition))))
1087 lgorrie 1.25 (funcall debugger-loop-fn))))
1088 dbarlow 1.1
1089 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
1090     (progn
1091     (defimplementation activate-stepping (frame)
1092     (declare (ignore frame))
1093     (sb-impl::enable-stepping))
1094     (defimplementation sldb-stepper-condition-p (condition)
1095     (typep condition 'sb-ext:step-form-condition))
1096     (defimplementation sldb-step-into ()
1097     (invoke-restart 'sb-ext:step-into))
1098     (defimplementation sldb-step-next ()
1099     (invoke-restart 'sb-ext:step-next))
1100     (defimplementation sldb-step-out ()
1101     (invoke-restart 'sb-ext:step-out)))
1102    
1103 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
1104 trittweiler 1.259 (let ((*debugger-hook* hook)
1105     #+#.(swank-backend::sbcl-with-new-stepper-p)
1106 jsnellman 1.162 (sb-ext:*stepper-hook*
1107     (lambda (condition)
1108 jsnellman 1.164 (typecase condition
1109     (sb-ext:step-form-condition
1110     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1111     (sb-impl::invoke-debugger condition)))))))
1112     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1113     (sb-ext:step-condition #'sb-impl::invoke-stepper))
1114 trittweiler 1.257 (call-with-break-hook hook fun))))
1115 heller 1.118
1116 dbarlow 1.1 (defun nth-frame (index)
1117     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1118     (i index (1- i)))
1119     ((zerop i) frame)))
1120    
1121 heller 1.74 (defimplementation compute-backtrace (start end)
1122 dbarlow 1.1 "Return a list of frames starting with frame number START and
1123     continuing to frame number END or, if END is nil, the last frame on the
1124     stack."
1125     (let ((end (or end most-positive-fixnum)))
1126 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1127     for i from start below end
1128 heller 1.225 while f collect f)))
1129 trittweiler 1.218
1130 heller 1.225 (defimplementation print-frame (frame stream)
1131     (sb-debug::print-frame-call frame stream))
1132 trittweiler 1.218
1133 heller 1.225 (defimplementation frame-restartable-p (frame)
1134 trittweiler 1.218 #+#.(swank-backend::sbcl-with-restart-frame)
1135 heller 1.225 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1136 dbarlow 1.1
1137 sboukarev 1.265 (defimplementation frame-call (frame-number)
1138     (multiple-value-bind (name args)
1139     (sb-debug::frame-call (nth-frame frame-number))
1140     (with-output-to-string (stream)
1141     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1142     (let ((*print-length* nil)
1143     (*print-level* nil))
1144     (prin1 (sb-debug::ensure-printable-object name) stream))
1145     (let ((args (sb-debug::ensure-printable-object args)))
1146     (if (listp args)
1147     (format stream "~{ ~_~S~}" args)
1148     (format stream " ~S" args)))))))
1149    
1150 heller 1.124 ;;;; Code-location -> source-location translation
1151    
1152 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
1153     ;;; the source-path for a code-location. If the code was compiled
1154     ;;; with C-c C-c, we have to search the position in the source string.
1155     ;;; If there's no debug-block info, we return the (less precise)
1156     ;;; source-location of the corresponding function.
1157    
1158 nsiivola 1.134 (defun code-location-source-location (code-location)
1159     (let* ((dsource (sb-di:code-location-debug-source code-location))
1160     (plist (sb-c::debug-source-plist dsource)))
1161     (if (getf plist :emacs-buffer)
1162     (emacs-buffer-source-location code-location plist)
1163 sboukarev 1.263 #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1164 nsiivola 1.134 (ecase (sb-di:debug-source-from dsource)
1165     (:file (file-source-location code-location))
1166 trittweiler 1.197 (:lisp (lisp-source-location code-location)))
1167 sboukarev 1.263 #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1168 trittweiler 1.197 (if (sb-di:debug-source-namestring dsource)
1169     (file-source-location code-location)
1170     (lisp-source-location code-location)))))
1171 nsiivola 1.134
1172     ;;; FIXME: The naming policy of source-location functions is a bit
1173     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1174     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1175     ;;; which returns the source location for a _code-location_.
1176 jsnellman 1.158 ;;;
1177 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
1178 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
1179     ;;; least the names should indicate the main entry point vs. helper
1180     ;;; status.
1181 heller 1.124
1182 nsiivola 1.134 (defun file-source-location (code-location)
1183     (if (code-location-has-debug-block-info-p code-location)
1184     (source-file-source-location code-location)
1185     (fallback-source-location code-location)))
1186    
1187     (defun fallback-source-location (code-location)
1188     (let ((fun (code-location-debug-fun-fun code-location)))
1189     (cond (fun (function-source-location fun))
1190 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
1191 nsiivola 1.134
1192 heller 1.124 (defun lisp-source-location (code-location)
1193 jsnellman 1.158 (let ((source (prin1-to-string
1194 nsiivola 1.305 (sb-debug::code-location-source-form code-location 100)))
1195 nsiivola 1.307 (condition (swank-value '*swank-debugger-condition*)))
1196 nsiivola 1.309 (if (and (typep condition 'sb-impl::step-form-condition)
1197     (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1198 nsiivola 1.307 :test #'char-equal)
1199     (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1200 heller 1.306 ;; The initial form is utterly uninteresting -- and almost
1201     ;; certainly right there in the REPL.
1202 nsiivola 1.304 (make-error-location "Stepping...")
1203     (make-location `(:source-form ,source) '(:position 1)))))
1204 heller 1.124
1205 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
1206     (if (code-location-has-debug-block-info-p code-location)
1207 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1208     &allow-other-keys)
1209     plist
1210 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
1211 trittweiler 1.241 (snipped (read-snippet-from-string emacs-string pos)))
1212 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
1213 heller 1.219 `(:offset ,emacs-position ,pos)
1214 nsiivola 1.134 `(:snippet ,snipped))))
1215     (fallback-source-location code-location)))
1216    
1217 heller 1.124 (defun source-file-source-location (code-location)
1218     (let* ((code-date (code-location-debug-source-created code-location))
1219     (filename (code-location-debug-source-name code-location))
1220 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
1221 heller 1.126 (source-code (get-source-code filename code-date)))
1222 jsnellman 1.186 (with-debootstrapping
1223     (with-input-from-string (s source-code)
1224     (let* ((pos (stream-source-position code-location s))
1225     (snippet (read-snippet s pos)))
1226     (make-location `(:file ,filename)
1227 heller 1.219 `(:position ,pos)
1228 jsnellman 1.186 `(:snippet ,snippet)))))))
1229 heller 1.124
1230     (defun code-location-debug-source-name (code-location)
1231 sboukarev 1.263 (namestring (truename (#+#.(swank-backend:with-symbol
1232 trittweiler 1.197 'debug-source-name 'sb-di)
1233     sb-c::debug-source-name
1234 sboukarev 1.263 #-#.(swank-backend:with-symbol
1235 trittweiler 1.197 'debug-source-name 'sb-di)
1236     sb-c::debug-source-namestring
1237 jsnellman 1.186 (sb-di::code-location-debug-source code-location)))))
1238 heller 1.124
1239     (defun code-location-debug-source-created (code-location)
1240 jsnellman 1.158 (sb-c::debug-source-created
1241 heller 1.124 (sb-di::code-location-debug-source code-location)))
1242    
1243     (defun code-location-debug-fun-fun (code-location)
1244     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1245    
1246     (defun code-location-has-debug-block-info-p (code-location)
1247 jsnellman 1.158 (handler-case
1248 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
1249     t)
1250     (sb-di:no-debug-blocks () nil)))
1251    
1252     (defun stream-source-position (code-location stream)
1253     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1254 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1255 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
1256     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1257     (let* ((path-table (sb-di::form-number-translations tlf 0))
1258 heller 1.128 (path (cond ((<= (length path-table) form-number)
1259 heller 1.129 (warn "inconsistent form-number-translations")
1260 heller 1.128 (list 0))
1261     (t
1262     (reverse (cdr (aref path-table form-number)))))))
1263     (source-path-source-position path tlf pos-map)))))
1264    
1265     (defun string-source-position (code-location string)
1266     (with-input-from-string (s string)
1267     (stream-source-position code-location s)))
1268 dbarlow 1.1
1269 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
1270 lgorrie 1.121
1271 heller 1.243 (defimplementation frame-source-location (index)
1272 trittweiler 1.267 (converting-errors-to-error-location
1273 trittweiler 1.258 (code-location-source-location
1274     (sb-di:frame-code-location (nth-frame index)))))
1275 dbarlow 1.1
1276 heller 1.326 (defvar *keep-non-valid-locals* nil)
1277    
1278 heller 1.92 (defun frame-debug-vars (frame)
1279     "Return a vector of debug-variables in frame."
1280 heller 1.326 (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))))
1281     (cond (*keep-non-valid-locals* all-vars)
1282     (t (let ((loc (sb-di:frame-code-location frame)))
1283     (remove-if (lambda (var)
1284     (ecase (sb-di:debug-var-validity var loc)
1285     (:valid nil)
1286     ((:invalid :unknown) t)))
1287     all-vars))))))
1288 heller 1.92
1289     (defun debug-var-value (var frame location)
1290     (ecase (sb-di:debug-var-validity var location)
1291     (:valid (sb-di:debug-var-value var frame))
1292     ((:invalid :unknown) ':<not-available>)))
1293    
1294 nsiivola 1.285 (defun debug-var-info (var)
1295     ;; Introduced by SBCL 1.0.49.76.
1296     (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1297     (when (and s (fboundp s))
1298     (funcall s var))))
1299    
1300 lgorrie 1.54 (defimplementation frame-locals (index)
1301 dbarlow 1.1 (let* ((frame (nth-frame index))
1302 heller 1.92 (loc (sb-di:frame-code-location frame))
1303 nsiivola 1.285 (vars (frame-debug-vars frame))
1304     ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1305     ;; specially.
1306     (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1307     (more-context nil)
1308     (more-count nil)
1309     (more-id 0))
1310 sboukarev 1.256 (when vars
1311 nsiivola 1.285 (let ((locals
1312     (loop for v across vars
1313     do (when (eq (sb-di:debug-var-symbol v) more-name)
1314     (incf more-id))
1315     (case (debug-var-info v)
1316     (:more-context
1317     (setf more-context (debug-var-value v frame loc)))
1318     (:more-count
1319     (setf more-count (debug-var-value v frame loc))))
1320     collect
1321     (list :name (sb-di:debug-var-symbol v)
1322     :id (sb-di:debug-var-id v)
1323     :value (debug-var-value v frame loc)))))
1324     (when (and more-context more-count)
1325     (setf locals (append locals
1326     (list
1327     (list :name more-name
1328     :id more-id
1329     :value (multiple-value-list
1330 heller 1.306 (sb-c:%more-arg-values
1331     more-context
1332     0 more-count)))))))
1333 nsiivola 1.285 locals))))
1334 heller 1.92
1335     (defimplementation frame-var-value (frame var)
1336     (let* ((frame (nth-frame frame))
1337 nsiivola 1.285 (vars (frame-debug-vars frame))
1338     (loc (sb-di:frame-code-location frame))
1339     (dvar (if (= var (length vars))
1340 heller 1.306 ;; If VAR is out of bounds, it must be the fake var
1341     ;; we made up for &MORE.
1342     (let* ((context-var (find :more-context vars
1343     :key #'debug-var-info))
1344     (more-context (debug-var-value context-var frame
1345     loc))
1346     (count-var (find :more-count vars
1347     :key #'debug-var-info))
1348 nsiivola 1.285 (more-count (debug-var-value count-var frame loc)))
1349     (return-from frame-var-value
1350 heller 1.306 (multiple-value-list (sb-c:%more-arg-values
1351     more-context
1352     0 more-count))))
1353 nsiivola 1.285 (aref vars var))))
1354     (debug-var-value dvar frame loc)))
1355 dbarlow 1.1
1356 lgorrie 1.54 (defimplementation frame-catch-tags (index)
1357 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1358 lgorrie 1.50
1359 heller 1.56 (defimplementation eval-in-frame (form index)
1360     (let ((frame (nth-frame index)))
1361 heller 1.58 (funcall (the function
1362 jsnellman 1.158 (sb-di:preprocess-for-eval form
1363 heller 1.58 (sb-di:frame-code-location frame)))
1364 heller 1.56 frame)))
1365    
1366 heller 1.327 (defimplementation frame-package (frame-number)
1367     (let* ((frame (nth-frame frame-number))
1368     (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
1369     (when fun
1370     (let ((name (function-name fun)))
1371     (typecase name
1372     (null nil)
1373     (symbol (symbol-package name))
1374     ((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))
1375    
1376 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
1377     (progn
1378     (defimplementation return-from-frame (index form)
1379     (let* ((frame (nth-frame index)))
1380     (cond ((sb-debug:frame-has-debug-tag-p frame)
1381     (let ((values (multiple-value-list (eval-in-frame form index))))
1382     (sb-debug:unwind-to-frame-and-call frame
1383     (lambda ()
1384     (values-list values)))))
1385     (t (format nil "Cannot return from frame: ~S" frame)))))
1386 nsiivola 1.293
1387 jsnellman 1.174 (defimplementation restart-frame (index)
1388 nsiivola 1.293 (let ((frame (nth-frame index)))
1389     (when (sb-debug:frame-has-debug-tag-p frame)
1390     (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1391     (multiple-value-bind (fun arglist)
1392     (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1393     (values (fdefinition fname) args)
1394     (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1395     (sb-debug::frame-args-as-list frame)))
1396     (when (functionp fun)
1397 heller 1.306 (sb-debug:unwind-to-frame-and-call
1398     frame
1399     (lambda ()
1400     ;; Ensure TCO.
1401     (declare (optimize (debug 0)))
1402     (apply fun arglist)))))))
1403 nsiivola 1.293 (format nil "Cannot restart frame: ~S" frame))))
1404 heller 1.152
1405     ;; FIXME: this implementation doesn't unwind the stack before
1406     ;; re-invoking the function, but it's better than no implementation at
1407     ;; all.
1408 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
1409     (progn
1410     (defun sb-debug-catch-tag-p (tag)
1411     (and (symbolp tag)
1412     (not (symbol-package tag))
1413     (string= tag :sb-debug-catch-tag)))
1414    
1415     (defimplementation return-from-frame (index form)
1416     (let* ((frame (nth-frame index))
1417     (probe (assoc-if #'sb-debug-catch-tag-p
1418     (sb-di::frame-catches frame))))
1419     (cond (probe (throw (car probe) (eval-in-frame form index)))
1420     (t (format nil "Cannot return from frame: ~S" frame)))))
1421    
1422     (defimplementation restart-frame (index)
1423     (let ((frame (nth-frame index)))
1424     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1425 jsnellman 1.158
1426 lgorrie 1.87 ;;;;; reference-conditions
1427    
1428     (defimplementation format-sldb-condition (condition)
1429     (let ((sb-int:*print-condition-references* nil))
1430     (princ-to-string condition)))
1431    
1432 heller 1.57
1433     ;;;; Profiling
1434    
1435     (defimplementation profile (fname)
1436     (when fname (eval `(sb-profile:profile ,fname))))
1437    
1438     (defimplementation unprofile (fname)
1439     (when fname (eval `(sb-profile:unprofile ,fname))))
1440    
1441     (defimplementation unprofile-all ()
1442     (sb-profile:unprofile)
1443     "All functions unprofiled.")
1444    
1445     (defimplementation profile-report ()
1446     (sb-profile:report))
1447    
1448     (defimplementation profile-reset ()
1449     (sb-profile:reset)
1450     "Reset profiling counters.")
1451    
1452     (defimplementation profiled-functions ()
1453     (sb-profile:profile))
1454    
1455 heller 1.116 (defimplementation profile-package (package callers methods)
1456     (declare (ignore callers methods))
1457     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1458    
1459 heller 1.57
1460 heller 1.64 ;;;; Inspector
1461 heller 1.63
1462 heller 1.190 (defmethod emacs-inspect ((o t))
1463 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1464 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1465 heller 1.64 (t
1466 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1467 sboukarev 1.271 (list* (string-right-trim '(#\Newline) text)
1468     '(:newline)
1469 heller 1.191 (if label
1470     (loop for (l . v) in parts
1471     append (label-value-line l v))
1472 sboukarev 1.271 (loop for value in parts
1473     for i from 0
1474 heller 1.191 append (label-value-line i value))))))))
1475 heller 1.64
1476 heller 1.190 (defmethod emacs-inspect ((o function))
1477 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1478     (cond ((= header sb-vm:simple-fun-header-widetag)
1479 heller 1.126 (label-value-line*
1480     (:name (sb-kernel:%simple-fun-name o))
1481     (:arglist (sb-kernel:%simple-fun-arglist o))
1482     (:self (sb-kernel:%simple-fun-self o))
1483     (:next (sb-kernel:%simple-fun-next o))
1484     (:type (sb-kernel:%simple-fun-type o))
1485 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1486 heller 1.64 ((= header sb-vm:closure-header-widetag)
1487 jsnellman 1.158 (append
1488 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1489     `("Closed over values:" (:newline))
1490     (loop for i below (1- (sb-kernel:get-closure-length o))
1491 jsnellman 1.158 append (label-value-line
1492 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1493 heller 1.64 (t (call-next-method o)))))
1494    
1495 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1496 jsnellman 1.158 (append
1497     (label-value-line*
1498 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1499     (:entry-points (sb-kernel:%code-entry-points o))
1500     (:debug-info (sb-kernel:%code-debug-info o))
1501 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1502 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1503     `("Constants:" (:newline))
1504 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1505 mbaringer 1.102 below (sb-kernel:get-header-data o)
1506 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1507     `("Code:" (:newline)
1508     , (with-output-to-string (s)
1509     (cond ((sb-kernel:%code-debug-info o)
1510     (sb-disassem:disassemble-code-component o :stream s))
1511     (t
1512 jsnellman 1.158 (sb-disassem:disassemble-memory
1513     (sb-disassem::align
1514 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1515     sb-vm:lowtag-mask)
1516 heller 1.126 (* sb-vm:code-constants-offset
1517     sb-vm:n-word-bytes))
1518 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1519     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1520 heller 1.191 :stream s)))))))
1521 mbaringer 1.102
1522 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1523 mbaringer 1.167 (label-value-line*
1524 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1525 mbaringer 1.167
1526 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1527 heller 1.126 (label-value-line*
1528     (:name (sb-kernel:fdefn-name o))
1529 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1530 mbaringer 1.102
1531 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1532 jsnellman 1.158 (append
1533 heller 1.191 (call-next-method)
1534 heller 1.126 (label-value-line*
1535     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1536     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1537 heller 1.191 )))
1538 heller 1.90
1539 heller 1.63
1540 lgorrie 1.50 ;;;; Multiprocessing
1541    
1542 crhodes 1.136 #+(and sb-thread
1543 sboukarev 1.271 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1544 crhodes 1.136 (progn
1545     (defvar *thread-id-counter* 0)
1546 jsnellman 1.158
1547 crhodes 1.136 (defvar *thread-id-counter-lock*
1548     (sb-thread:make-mutex :name "thread id counter lock"))
1549    
1550     (defun next-thread-id ()
1551     (sb-thread:with-mutex (*thread-id-counter-lock*)
1552     (incf *thread-id-counter*)))
1553 jsnellman 1.158
1554 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1555    
1556     ;; This should be a thread -> id map but as weak keys are not
1557     ;; supported it is id -> map instead.
1558     (defvar *thread-id-map-lock*
1559     (sb-thread:make-mutex :name "thread id map lock"))
1560 jsnellman 1.158
1561 crhodes 1.136 (defimplementation spawn (fn &key name)
1562     (sb-thread:make-thread fn :name name))
1563    
1564     (defimplementation thread-id (thread)
1565 heller 1.160 (block thread-id
1566     (sb-thread:with-mutex (*thread-id-map-lock*)
1567     (loop for id being the hash-key in *thread-id-map*
1568     using (hash-value thread-pointer)
1569     do
1570     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1571     (cond ((null maybe-thread)
1572     ;; the value is gc'd, remove it manually
1573     (remhash id *thread-id-map*))
1574     ((eq thread maybe-thread)
1575     (return-from thread-id id)))))
1576     ;; lazy numbering
1577     (let ((id (next-thread-id)))
1578     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1579     id))))
1580 crhodes 1.136
1581     (defimplementation find-thread (id)
1582     (sb-thread:with-mutex (*thread-id-map-lock*)
1583     (let ((thread-pointer (gethash id *thread-id-map*)))
1584     (if thread-pointer
1585     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1586     (if maybe-thread
1587     maybe-thread
1588     ;; the value is gc'd, remove it manually
1589     (progn
1590     (remhash id *thread-id-map*)
1591     nil)))
1592     nil))))
1593 jsnellman 1.158
1594 crhodes 1.136 (defimplementation thread-name (thread)
1595     ;; sometimes the name is not a string (e.g. NIL)
1596     (princ-to-string (sb-thread:thread-name thread)))
1597    
1598     (defimplementation thread-status (thread)
1599     (if (sb-thread:thread-alive-p thread)
1600 sboukarev 1.253 "Running"
1601     "Stopped"))
1602    
1603 crhodes 1.136 (defimplementation make-lock (&key name)
1604     (sb-thread:make-mutex :name name))
1605    
1606     (defimplementation call-with-lock-held (lock function)
1607     (declare (type function function))
1608 nsiivola 1.154 (sb-thread:with-recursive-lock (lock) (funcall function)))
1609    
1610 crhodes 1.136 (defimplementation current-thread ()
1611     sb-thread:*current-thread*)
1612    
1613     (defimplementation all-threads ()
1614     (sb-thread:list-all-threads))
1615 jsnellman 1.158
1616 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1617     (sb-thread:interrupt-thread thread fn))
1618    
1619     (defimplementation kill-thread (thread)
1620     (sb-thread:terminate-thread thread))
1621    
1622     (defimplementation thread-alive-p (thread)
1623     (sb-thread:thread-alive-p thread))
1624    
1625     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1626     (defvar *mailboxes* (list))
1627     (declaim (type list *mailboxes*))
1628    
1629 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1630 crhodes 1.136 thread
1631     (mutex (sb-thread:make-mutex))
1632     (waitqueue (sb-thread:make-waitqueue))
1633     (queue '() :type list))
1634    
1635     (defun mailbox (thread)
1636     "Return THREAD's mailbox."
1637     (sb-thread:with-mutex (*mailbox-lock*)
1638     (or (find thread *mailboxes* :key #'mailbox.thread)
1639     (let ((mb (make-mailbox :thread thread)))
1640     (push mb *mailboxes*)
1641     mb))))
1642    
1643     (defimplementation send (thread message)
1644     (let* ((mbox (mailbox thread))
1645     (mutex (mailbox.mutex mbox)))
1646     (sb-thread:with-mutex (mutex)
1647     (setf (mailbox.queue mbox)
1648     (nconc (mailbox.queue mbox) (list message)))
1649     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1650 heller 1.317
1651 heller 1.318
1652 trittweiler 1.270 (defun condition-timed-wait (waitqueue mutex timeout)
1653 heller 1.317 (macrolet ((foo ()
1654 heller 1.322 (cond ((member :sb-lutex *features*) ; Darwin
1655 heller 1.317 '(sb-thread:condition-wait waitqueue mutex))
1656     (t
1657     '(handler-case
1658     (let ((*break-on-signals* nil))
1659     (sb-sys:with-deadline (:seconds timeout
1660     :override t)
1661     (sb-thread:condition-wait waitqueue mutex) t))
1662     (sb-ext:timeout ()
1663     nil))))))
1664     (foo)))
1665 trittweiler 1.270
1666 heller 1.212 (defimplementation receive-if (test &optional timeout)
1667 heller 1.209 (let* ((mbox (mailbox (current-thread)))
1668 trittweiler 1.270 (mutex (mailbox.mutex mbox))
1669     (waitq (mailbox.waitqueue mbox)))
1670 heller 1.212 (assert (or (not timeout) (eq timeout t)))
1671 heller 1.207 (loop
1672     (check-slime-interrupts)
1673 heller 1.209 (sb-thread:with-mutex (mutex)
1674 heller 1.202 (let* ((q (mailbox.queue mbox))
1675     (tail (member-if test q)))
1676 heller 1.207 (when tail
1677     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1678     (return (car tail))))
1679 heller 1.212 (when (eq timeout t) (return (values nil t)))
1680 trittweiler 1.270 (condition-timed-wait waitq mutex 0.2)))))
1681 heller 1.301
1682     (let ((alist '())
1683     (mutex (sb-thread:make-mutex :name "register-thread")))
1684    
1685     (defimplementation register-thread (name thread)
1686     (declare (type symbol name))
1687     (sb-thread:with-mutex (mutex)
1688     (etypecase thread
1689     (null
1690     (setf alist (delete name alist :key #'car)))
1691     (sb-thread:thread
1692     (let ((probe (assoc name alist)))
1693     (cond (probe (setf (cdr probe) thread))
1694     (t (setf alist (acons name thread alist))))))))
1695     nil)
1696    
1697     (defimplementation find-registered (name)
1698     (sb-thread:with-mutex (mutex)
1699     (cdr (assoc name alist)))))
1700    
1701 nsiivola 1.308 ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1702     ;; buffer write lock.
1703     ;;
1704     ;; Another alternative would be to grab the world-lock here, but that's less
1705     ;; future-proof, and could introduce other lock-ordering issues in the
1706     ;; future.
1707     ;;
1708     ;; In an ideal world we would just have an :AROUND method on
1709     ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1710     ;; file is loaded -- so first we need a dummy definition that will be
1711     ;; overridden by swank-gray.lisp.
1712     (defclass slime-output-stream (fundamental-character-output-stream)
1713     ())
1714     (defmethod stream-force-output :around ((stream slime-output-stream))
1715 heller 1.322 (handler-case
1716     (sb-sys:with-deadline (:seconds 0.1)
1717     (call-next-method))
1718     (sb-sys:deadline-timeout ()
1719     nil)))
1720 heller 1.59 )
1721 heller 1.126
1722     (defimplementation quit-lisp ()
1723 sboukarev 1.311 #+#.(swank-backend:with-symbol 'exit 'sb-ext)
1724     (sb-ext:exit)
1725     #-#.(swank-backend:with-symbol 'exit 'sb-ext)
1726     (progn
1727     #+sb-thread
1728     (dolist (thread (remove (current-thread) (all-threads)))
1729     (ignore-errors (sb-thread:terminate-thread thread)))
1730     (sb-ext:quit)))
1731 heller 1.133
1732 mbaringer 1.117
1733 heller 1.118
1734 mbaringer 1.117 ;;Trace implementations
1735     ;;In SBCL, we have:
1736     ;; (trace <name>)
1737 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1738 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1739     ;; <name> can be a normal name or a (setf name)
1740    
1741 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1742 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1743     (eval `(untrace ,fspec))
1744     (format nil "~S is now untraced." fspec))
1745     (t
1746     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1747     (format nil "~S is now traced." fspec))))
1748    
1749     (defun process-fspec (fspec)
1750     (cond ((consp fspec)
1751     (ecase (first fspec)
1752     ((:defun :defgeneric) (second fspec))
1753     ((:defmethod) `(method ,@(rest fspec)))
1754     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1755     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1756     (t
1757     fspec)))
1758    
1759 heller 1.119 (defimplementation toggle-trace (spec)
1760     (ecase (car spec)
1761 jsnellman 1.158 ((setf)
1762 heller 1.119 (toggle-trace-aux spec))
1763     ((:defmethod)
1764     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1765     ((:defgeneric)
1766     (toggle-trace-aux (second spec) :methods t))
1767     ((:call)
1768     (destructuring-bind (caller callee) (cdr spec)
1769     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1770 mkoeppe 1.142
1771     ;;; Weak datastructures
1772    
1773 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1774     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1775     (apply #'make-hash-table :weakness :key args)
1776     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1777     (apply #'make-hash-table args))
1778 mkoeppe 1.142
1779 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1780 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1781     (apply #'make-hash-table :weakness :value args)
1782     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1783     (apply #'make-hash-table args))
1784 alendvai 1.173
1785     (defimplementation hash-table-weakness (hashtable)
1786     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1787     (sb-ext:hash-table-weakness hashtable))
1788 heller 1.214
1789     #-win32
1790     (defimplementation save-image (filename &optional restart-function)
1791 heller 1.274 (flet ((restart-sbcl ()
1792     (sb-debug::enable-debugger)
1793     (setf sb-impl::*descriptor-handlers* nil)
1794     (funcall restart-function)))
1795     (let ((pid (sb-posix:fork)))
1796     (cond ((= pid 0)
1797     (sb-debug::disable-debugger)
1798     (apply #'sb-ext:save-lisp-and-die filename
1799     (when restart-function
1800     (list :toplevel #'restart-sbcl))))
1801     (t
1802     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1803     (assert (= pid rpid))
1804     (assert (and (sb-posix:wifexited status)
1805     (zerop (sb-posix:wexitstatus status))))))))))
1806    
1807     #+unix
1808     (progn
1809 nsiivola 1.281 (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1810 heller 1.274 (program sb-alien:c-string)
1811     (argv (* sb-alien:c-string)))
1812 nsiivola 1.281
1813 heller 1.274 (defun execv (program args)
1814     "Replace current executable with another one."
1815     (let ((a-args (sb-alien:make-alien sb-alien:c-string
1816     (+ 1 (length args)))))
1817     (unwind-protect
1818     (progn
1819     (loop for index from 0 by 1
1820     and item in (append args '(nil))
1821     do (setf (sb-alien:deref a-args index)
1822     item))
1823     (when (minusp
1824     (sys-execv program a-args))
1825 nsiivola 1.281 (error "execv(3) returned.")))
1826 heller 1.274 (sb-alien:free-alien a-args))))
1827    
1828 sboukarev 1.275 (defun runtime-pathname ()
1829     #+#.(swank-backend:with-symbol
1830     '*runtime-pathname* 'sb-ext)
1831     sb-ext:*runtime-pathname*
1832     #-#.(swank-backend:with-symbol
1833     '*runtime-pathname* 'sb-ext)
1834     (car sb-ext:*posix-argv*))
1835    
1836 heller 1.274 (defimplementation exec-image (image-file args)
1837     (loop with fd-arg =
1838     (loop for arg in args
1839     and key = "" then arg
1840     when (string-equal key "--swank-fd")
1841 sboukarev 1.275 return (parse-integer arg))
1842 heller 1.274 for my-fd from 3 to 1024
1843     when (/= my-fd fd-arg)
1844 sboukarev 1.275 do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1845     (let* ((self-string (pathname-to-filename (runtime-pathname))))
1846 heller 1.274 (execv
1847     self-string
1848     (apply 'list self-string "--core" image-file args)))))
1849    
1850     (defimplementation make-fd-stream (fd external-format)
1851     (sb-sys:make-fd-stream fd :input t :output t
1852     :element-type 'character
1853     :buffering :full
1854     :dual-channel-p t
1855     :external-format external-format))
1856    
1857 sboukarev 1.277 #-win32
1858     (defimplementation background-save-image (filename &key restart-function
1859     completion-function)
1860 heller 1.274 (flet ((restart-sbcl ()
1861     (sb-debug::enable-debugger)
1862     (setf sb-impl::*descriptor-handlers* nil)
1863     (funcall restart-function)))
1864     (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1865     (let ((pid (sb-posix:fork)))
1866     (cond ((= pid 0)
1867     (sb-posix:close pipe-in)
1868     (sb-debug::disable-debugger)
1869     (apply #'sb-ext:save-lisp-and-die filename
1870     (when restart-function
1871     (list :toplevel #'restart-sbcl))))
1872     (t
1873     (sb-posix:close pipe-out)
1874     (sb-sys:add-fd-handler
1875     pipe-in :input
1876     (lambda (fd)
1877     (sb-sys:invalidate-descriptor fd)
1878     (sb-posix:close fd)
1879     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1880     (assert (= pid rpid))
1881     (assert (sb-posix:wifexited status))
1882     (funcall completion-function
1883     (zerop (sb-posix:wexitstatus status))))))))))))
1884 nsiivola 1.278
1885     (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5