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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.315 - (hide annotations)
Fri May 4 11:16:40 2012 UTC (23 months, 2 weeks ago) by nsiivola
Branch: MAIN
Changes since 1.314: +1 -2 lines
sbcl: remove MERGE-TAIL-CALLS proclamation
1 trittweiler 1.246 ;;;;; -*- Mode: lisp; 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 trittweiler 1.234
790 trittweiler 1.261 (defun categorize-definition-source (definition-source)
791 sboukarev 1.310 (with-struct ("sb-introspect:definition-source-"
792     pathname form-path character-offset plist)
793     definition-source
794 sboukarev 1.312 (let ((file-p (and pathname (probe-file pathname)
795     (or form-path character-offset))))
796     (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
797     ((getf plist :emacs-buffer) :buffer)
798     (file-p :file)
799     (pathname :file-without-position)
800     (t :invalid)))))
801 trittweiler 1.261
802 sboukarev 1.310 (defun definition-source-buffer-location (definition-source)
803     (with-struct ("sb-introspect:definition-source-"
804     form-path character-offset plist)
805     definition-source
806     (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
807     emacs-string &allow-other-keys)
808     plist
809     (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
810     (multiple-value-bind (start end)
811     (if form-path
812     (with-debootstrapping
813     (source-path-string-position form-path
814     emacs-string))
815     (values character-offset
816     most-positive-fixnum))
817     (make-location
818     `(:buffer ,emacs-buffer)
819     `(:offset ,emacs-position ,start)
820     `(:snippet
821     ,(subseq emacs-string
822     start
823     (min end (+ start *source-snippet-size*))))))))))
824    
825     (defun definition-source-file-location (definition-source)
826     (with-struct ("sb-introspect:definition-source-"
827     pathname form-path character-offset plist
828     file-write-date) definition-source
829     (let* ((namestring (namestring (translate-logical-pathname pathname)))
830     (pos (if form-path
831     (source-file-position namestring file-write-date
832     form-path)
833     character-offset))
834     (snippet (source-hint-snippet namestring file-write-date pos)))
835     (make-location `(:file ,namestring)
836     ;; /file positions/ in Common Lisp start from
837     ;; 0, buffer positions in Emacs start from 1.
838     `(:position ,(1+ pos))
839     `(:snippet ,snippet)))))
840    
841 sboukarev 1.312 (defun definition-source-buffer-and-file-location (definition-source)
842     (let ((buffer (definition-source-buffer-location definition-source))
843     (file (definition-source-file-location definition-source)))
844     (make-location (list :buffer-and-file
845     (cadr (location-buffer buffer))
846     (cadr (location-buffer file)))
847 sboukarev 1.313 (location-position buffer)
848     (location-hints buffer))))
849 sboukarev 1.312
850 trittweiler 1.261 (defun definition-source-for-emacs (definition-source type name)
851 sboukarev 1.310 (with-struct ("sb-introspect:definition-source-"
852     pathname form-path character-offset plist
853     file-write-date)
854     definition-source
855 sboukarev 1.314 (ecase (categorize-definition-source definition-source)
856     (:buffer-and-file
857     (definition-source-buffer-and-file-location definition-source))
858     (:buffer
859     (definition-source-buffer-location definition-source))
860     (:file
861     (definition-source-file-location definition-source))
862     (:file-without-position
863     (make-location `(:file ,(namestring
864     (translate-logical-pathname pathname)))
865     '(:position 1)
866     (when (eql type :function)
867     `(:snippet ,(format nil "(defun ~a "
868     (symbol-name name))))))
869     (:invalid
870     (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
871 trittweiler 1.261 meaningful information."
872 sboukarev 1.314 type name)))))
873 jsnellman 1.149
874 trittweiler 1.261 (defun source-file-position (filename write-date form-path)
875 jsnellman 1.172 (let ((source (get-source-code filename write-date))
876     (*readtable* (guess-readtable-for-filename filename)))
877 trittweiler 1.192 (with-debootstrapping
878 trittweiler 1.261 (source-path-string-position form-path source))))
879 jsnellman 1.172
880 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
881 trittweiler 1.241 (read-snippet-from-string (get-source-code filename write-date) position))
882 jsnellman 1.149
883 jsnellman 1.151 (defun function-source-location (function &optional name)
884     (declare (type function function))
885 trittweiler 1.261 (definition-source-for-emacs (sb-introspect:find-definition-source function)
886     :function
887     (or name (function-name function))))
888 jsnellman 1.151
889 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
890 dbarlow 1.1 "Return a plist describing SYMBOL.
891     Return NIL if the symbol is unbound."
892     (let ((result '()))
893 heller 1.133 (flet ((doc (kind)
894     (or (documentation symbol kind) :not-documented))
895     (maybe-push (property value)
896     (when value
897     (setf result (list* property value result)))))
898 dbarlow 1.1 (maybe-push
899     :variable (multiple-value-bind (kind recorded-p)
900     (sb-int:info :variable :kind symbol)
901     (declare (ignore kind))
902     (if (or (boundp symbol) recorded-p)
903     (doc 'variable))))
904 heller 1.133 (when (fboundp symbol)
905     (maybe-push
906     (cond ((macro-function symbol) :macro)
907     ((special-operator-p symbol) :special-operator)
908     ((typep (fdefinition symbol) 'generic-function)
909     :generic-function)
910     (t :function))
911     (doc 'function)))
912 dbarlow 1.1 (maybe-push
913     :setf (if (or (sb-int:info :setf :inverse symbol)
914     (sb-int:info :setf :expander symbol))
915     (doc 'setf)))
916     (maybe-push
917     :type (if (sb-int:info :type :kind symbol)
918     (doc 'type)))
919 lgorrie 1.24 result)))
920 dbarlow 1.1
921 heller 1.74 (defimplementation describe-definition (symbol type)
922 lgorrie 1.54 (case type
923     (:variable
924 heller 1.74 (describe symbol))
925     (:function
926     (describe (symbol-function symbol)))
927 lgorrie 1.54 (:setf
928 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
929     (sb-int:info :setf :expander symbol))))
930 lgorrie 1.54 (:class
931 heller 1.74 (describe (find-class symbol)))
932 lgorrie 1.54 (:type
933 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
934 jsnellman 1.172
935     #+#.(swank-backend::sbcl-with-xref-p)
936     (progn
937 trittweiler 1.255 (defmacro defxref (name &optional fn-name)
938 jsnellman 1.172 `(defimplementation ,name (what)
939     (sanitize-xrefs
940     (mapcar #'source-location-for-xref-data
941 trittweiler 1.255 (,(find-symbol (symbol-name (if fn-name
942     fn-name
943     name))
944     "SB-INTROSPECT")
945 jsnellman 1.172 what)))))
946     (defxref who-calls)
947     (defxref who-binds)
948     (defxref who-sets)
949     (defxref who-references)
950 trittweiler 1.222 (defxref who-macroexpands)
951 sboukarev 1.263 #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
952 trittweiler 1.255 (defxref who-specializes who-specializes-directly))
953 jsnellman 1.172
954     (defun source-location-for-xref-data (xref-data)
955 trittweiler 1.261 (destructuring-bind (name . defsrc) xref-data
956 trittweiler 1.267 (list name (converting-errors-to-error-location
957 trittweiler 1.261 (definition-source-for-emacs defsrc 'function name)))))
958 dbarlow 1.1
959 heller 1.97 (defimplementation list-callers (symbol)
960     (let ((fn (fdefinition symbol)))
961 heller 1.168 (sanitize-xrefs
962     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
963 heller 1.97
964     (defimplementation list-callees (symbol)
965     (let ((fn (fdefinition symbol)))
966 heller 1.168 (sanitize-xrefs
967     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
968 heller 1.97
969 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
970 heller 1.168 (remove-duplicates
971     (remove-if (lambda (f)
972     (member f (ignored-xref-function-names)))
973 jsnellman 1.172 (loop for entry in xrefs
974     for name = (car entry)
975     collect (if (and (consp name)
976     (member (car name)
977     '(sb-pcl::fast-method
978     sb-pcl::slow-method
979     sb-pcl::method)))
980     (cons (cons 'defmethod (cdr name))
981     (cdr entry))
982     entry))
983 heller 1.168 :key #'car)
984     :test (lambda (a b)
985     (and (eq (first a) (first b))
986     (equal (second a) (second b))))))
987    
988     (defun ignored-xref-function-names ()
989     #-#.(swank-backend::sbcl-with-new-stepper-p)
990     '(nil sb-c::step-form sb-c::step-values)
991     #+#.(swank-backend::sbcl-with-new-stepper-p)
992     '(nil))
993 jsnellman 1.166
994 lgorrie 1.122 (defun function-dspec (fn)
995     "Describe where the function FN was defined.
996     Return a list of the form (NAME LOCATION)."
997 trittweiler 1.261 (let ((name (function-name fn)))
998 trittweiler 1.267 (list name (converting-errors-to-error-location
999 trittweiler 1.258 (function-source-location fn name)))))
1000 lgorrie 1.122
1001 dbarlow 1.4 ;;; macroexpansion
1002 dbarlow 1.1
1003 lgorrie 1.54 (defimplementation macroexpand-all (form)
1004 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
1005     (sb-walker:walk-form form)))
1006 lgorrie 1.25
1007 dbarlow 1.1
1008     ;;; Debugging
1009    
1010 trittweiler 1.257 ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
1011     ;;; than just a hook into BREAK. In particular, it'll make
1012     ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1013     ;;; than the native debugger. That should probably be considered a
1014     ;;; feature.
1015 dbarlow 1.1
1016 trittweiler 1.194 (defun make-invoke-debugger-hook (hook)
1017 trittweiler 1.259 (when hook
1018     #'(sb-int:named-lambda swank-invoke-debugger-hook
1019     (condition old-hook)
1020     (if *debugger-hook*
1021     nil ; decline, *DEBUGGER-HOOK* will be tried next.
1022     (funcall hook condition old-hook)))))
1023 trittweiler 1.194
1024 trittweiler 1.257 (defun set-break-hook (hook)
1025     (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1026    
1027     (defun call-with-break-hook (hook continuation)
1028     (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1029     (funcall continuation)))
1030    
1031 heller 1.148 (defimplementation install-debugger-globally (function)
1032 trittweiler 1.194 (setq *debugger-hook* function)
1033 trittweiler 1.257 (set-break-hook function))
1034 heller 1.148
1035 jsnellman 1.162 (defimplementation condition-extras (condition)
1036 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1037     ((typep condition 'sb-impl::step-form-condition)
1038     `((:show-frame-source 0)))
1039     ((typep condition 'sb-int:reference-condition)
1040     (let ((refs (sb-int:reference-condition-references condition)))
1041     (if refs
1042     `((:references ,(externalize-reference refs))))))))
1043    
1044     (defun externalize-reference (ref)
1045     (etypecase ref
1046     (null nil)
1047     (cons (cons (externalize-reference (car ref))
1048     (externalize-reference (cdr ref))))
1049     ((or string number) ref)
1050     (symbol
1051     (cond ((eq (symbol-package ref) (symbol-package :test))
1052     ref)
1053     (t (symbol-name ref))))))
1054 jsnellman 1.162
1055 trittweiler 1.257 (defvar *sldb-stack-top*)
1056    
1057 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1058 heller 1.58 (declare (type function debugger-loop-fn))
1059 trittweiler 1.258 (let* ((*sldb-stack-top* (if *debug-swank-backend*
1060     (sb-di:top-frame)
1061 heller 1.306 (or sb-debug:*stack-top-hint*
1062     (sb-di:top-frame))))
1063 trittweiler 1.199 (sb-debug:*stack-top-hint* nil))
1064 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
1065 dbarlow 1.1 (lambda (condition)
1066 lgorrie 1.25 (signal (make-condition
1067     'sldb-condition
1068     :original-condition condition)))))
1069     (funcall debugger-loop-fn))))
1070 dbarlow 1.1
1071 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
1072     (progn
1073     (defimplementation activate-stepping (frame)
1074     (declare (ignore frame))
1075     (sb-impl::enable-stepping))
1076     (defimplementation sldb-stepper-condition-p (condition)
1077     (typep condition 'sb-ext:step-form-condition))
1078     (defimplementation sldb-step-into ()
1079     (invoke-restart 'sb-ext:step-into))
1080     (defimplementation sldb-step-next ()
1081     (invoke-restart 'sb-ext:step-next))
1082     (defimplementation sldb-step-out ()
1083     (invoke-restart 'sb-ext:step-out)))
1084    
1085 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
1086 trittweiler 1.259 (let ((*debugger-hook* hook)
1087     #+#.(swank-backend::sbcl-with-new-stepper-p)
1088 jsnellman 1.162 (sb-ext:*stepper-hook*
1089     (lambda (condition)
1090 jsnellman 1.164 (typecase condition
1091     (sb-ext:step-form-condition
1092     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1093     (sb-impl::invoke-debugger condition)))))))
1094     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1095     (sb-ext:step-condition #'sb-impl::invoke-stepper))
1096 trittweiler 1.257 (call-with-break-hook hook fun))))
1097 heller 1.118
1098 dbarlow 1.1 (defun nth-frame (index)
1099     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1100     (i index (1- i)))
1101     ((zerop i) frame)))
1102    
1103 heller 1.74 (defimplementation compute-backtrace (start end)
1104 dbarlow 1.1 "Return a list of frames starting with frame number START and
1105     continuing to frame number END or, if END is nil, the last frame on the
1106     stack."
1107     (let ((end (or end most-positive-fixnum)))
1108 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1109     for i from start below end
1110 heller 1.225 while f collect f)))
1111 trittweiler 1.218
1112 heller 1.225 (defimplementation print-frame (frame stream)
1113     (sb-debug::print-frame-call frame stream))
1114 trittweiler 1.218
1115 heller 1.225 (defimplementation frame-restartable-p (frame)
1116 trittweiler 1.218 #+#.(swank-backend::sbcl-with-restart-frame)
1117 heller 1.225 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1118 dbarlow 1.1
1119 sboukarev 1.265 (defimplementation frame-call (frame-number)
1120     (multiple-value-bind (name args)
1121     (sb-debug::frame-call (nth-frame frame-number))
1122     (with-output-to-string (stream)
1123     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1124     (let ((*print-length* nil)
1125     (*print-level* nil))
1126     (prin1 (sb-debug::ensure-printable-object name) stream))
1127     (let ((args (sb-debug::ensure-printable-object args)))
1128     (if (listp args)
1129     (format stream "~{ ~_~S~}" args)
1130     (format stream " ~S" args)))))))
1131    
1132 heller 1.124 ;;;; Code-location -> source-location translation
1133    
1134 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
1135     ;;; the source-path for a code-location. If the code was compiled
1136     ;;; with C-c C-c, we have to search the position in the source string.
1137     ;;; If there's no debug-block info, we return the (less precise)
1138     ;;; source-location of the corresponding function.
1139    
1140 nsiivola 1.134 (defun code-location-source-location (code-location)
1141     (let* ((dsource (sb-di:code-location-debug-source code-location))
1142     (plist (sb-c::debug-source-plist dsource)))
1143     (if (getf plist :emacs-buffer)
1144     (emacs-buffer-source-location code-location plist)
1145 sboukarev 1.263 #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1146 nsiivola 1.134 (ecase (sb-di:debug-source-from dsource)
1147     (:file (file-source-location code-location))
1148 trittweiler 1.197 (:lisp (lisp-source-location code-location)))
1149 sboukarev 1.263 #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1150 trittweiler 1.197 (if (sb-di:debug-source-namestring dsource)
1151     (file-source-location code-location)
1152     (lisp-source-location code-location)))))
1153 nsiivola 1.134
1154     ;;; FIXME: The naming policy of source-location functions is a bit
1155     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1156     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1157     ;;; which returns the source location for a _code-location_.
1158 jsnellman 1.158 ;;;
1159 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
1160 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
1161     ;;; least the names should indicate the main entry point vs. helper
1162     ;;; status.
1163 heller 1.124
1164 nsiivola 1.134 (defun file-source-location (code-location)
1165     (if (code-location-has-debug-block-info-p code-location)
1166     (source-file-source-location code-location)
1167     (fallback-source-location code-location)))
1168    
1169     (defun fallback-source-location (code-location)
1170     (let ((fun (code-location-debug-fun-fun code-location)))
1171     (cond (fun (function-source-location fun))
1172 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
1173 nsiivola 1.134
1174 heller 1.124 (defun lisp-source-location (code-location)
1175 jsnellman 1.158 (let ((source (prin1-to-string
1176 nsiivola 1.305 (sb-debug::code-location-source-form code-location 100)))
1177 nsiivola 1.307 (condition (swank-value '*swank-debugger-condition*)))
1178 nsiivola 1.309 (if (and (typep condition 'sb-impl::step-form-condition)
1179     (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1180 nsiivola 1.307 :test #'char-equal)
1181     (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1182 heller 1.306 ;; The initial form is utterly uninteresting -- and almost
1183     ;; certainly right there in the REPL.
1184 nsiivola 1.304 (make-error-location "Stepping...")
1185     (make-location `(:source-form ,source) '(:position 1)))))
1186 heller 1.124
1187 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
1188     (if (code-location-has-debug-block-info-p code-location)
1189 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1190     &allow-other-keys)
1191     plist
1192 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
1193 trittweiler 1.241 (snipped (read-snippet-from-string emacs-string pos)))
1194 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
1195 heller 1.219 `(:offset ,emacs-position ,pos)
1196 nsiivola 1.134 `(:snippet ,snipped))))
1197     (fallback-source-location code-location)))
1198    
1199 heller 1.124 (defun source-file-source-location (code-location)
1200     (let* ((code-date (code-location-debug-source-created code-location))
1201     (filename (code-location-debug-source-name code-location))
1202 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
1203 heller 1.126 (source-code (get-source-code filename code-date)))
1204 jsnellman 1.186 (with-debootstrapping
1205     (with-input-from-string (s source-code)
1206     (let* ((pos (stream-source-position code-location s))
1207     (snippet (read-snippet s pos)))
1208     (make-location `(:file ,filename)
1209 heller 1.219 `(:position ,pos)
1210 jsnellman 1.186 `(:snippet ,snippet)))))))
1211 heller 1.124
1212     (defun code-location-debug-source-name (code-location)
1213 sboukarev 1.263 (namestring (truename (#+#.(swank-backend:with-symbol
1214 trittweiler 1.197 'debug-source-name 'sb-di)
1215     sb-c::debug-source-name
1216 sboukarev 1.263 #-#.(swank-backend:with-symbol
1217 trittweiler 1.197 'debug-source-name 'sb-di)
1218     sb-c::debug-source-namestring
1219 jsnellman 1.186 (sb-di::code-location-debug-source code-location)))))
1220 heller 1.124
1221     (defun code-location-debug-source-created (code-location)
1222 jsnellman 1.158 (sb-c::debug-source-created
1223 heller 1.124 (sb-di::code-location-debug-source code-location)))
1224    
1225     (defun code-location-debug-fun-fun (code-location)
1226     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1227    
1228     (defun code-location-has-debug-block-info-p (code-location)
1229 jsnellman 1.158 (handler-case
1230 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
1231     t)
1232     (sb-di:no-debug-blocks () nil)))
1233    
1234     (defun stream-source-position (code-location stream)
1235     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1236 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1237 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
1238     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1239     (let* ((path-table (sb-di::form-number-translations tlf 0))
1240 heller 1.128 (path (cond ((<= (length path-table) form-number)
1241 heller 1.129 (warn "inconsistent form-number-translations")
1242 heller 1.128 (list 0))
1243     (t
1244     (reverse (cdr (aref path-table form-number)))))))
1245     (source-path-source-position path tlf pos-map)))))
1246    
1247     (defun string-source-position (code-location string)
1248     (with-input-from-string (s string)
1249     (stream-source-position code-location s)))
1250 dbarlow 1.1
1251 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
1252 lgorrie 1.121
1253 heller 1.243 (defimplementation frame-source-location (index)
1254 trittweiler 1.267 (converting-errors-to-error-location
1255 trittweiler 1.258 (code-location-source-location
1256     (sb-di:frame-code-location (nth-frame index)))))
1257 dbarlow 1.1
1258 heller 1.92 (defun frame-debug-vars (frame)
1259     "Return a vector of debug-variables in frame."
1260     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1261    
1262     (defun debug-var-value (var frame location)
1263     (ecase (sb-di:debug-var-validity var location)
1264     (:valid (sb-di:debug-var-value var frame))
1265     ((:invalid :unknown) ':<not-available>)))
1266    
1267 nsiivola 1.285 (defun debug-var-info (var)
1268     ;; Introduced by SBCL 1.0.49.76.
1269     (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1270     (when (and s (fboundp s))
1271     (funcall s var))))
1272    
1273 lgorrie 1.54 (defimplementation frame-locals (index)
1274 dbarlow 1.1 (let* ((frame (nth-frame index))
1275 heller 1.92 (loc (sb-di:frame-code-location frame))
1276 nsiivola 1.285 (vars (frame-debug-vars frame))
1277     ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1278     ;; specially.
1279     (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1280     (more-context nil)
1281     (more-count nil)
1282     (more-id 0))
1283 sboukarev 1.256 (when vars
1284 nsiivola 1.285 (let ((locals
1285     (loop for v across vars
1286     do (when (eq (sb-di:debug-var-symbol v) more-name)
1287     (incf more-id))
1288     (case (debug-var-info v)
1289     (:more-context
1290     (setf more-context (debug-var-value v frame loc)))
1291     (:more-count
1292     (setf more-count (debug-var-value v frame loc))))
1293     collect
1294     (list :name (sb-di:debug-var-symbol v)
1295     :id (sb-di:debug-var-id v)
1296     :value (debug-var-value v frame loc)))))
1297     (when (and more-context more-count)
1298     (setf locals (append locals
1299     (list
1300     (list :name more-name
1301     :id more-id
1302     :value (multiple-value-list
1303 heller 1.306 (sb-c:%more-arg-values
1304     more-context
1305     0 more-count)))))))
1306 nsiivola 1.285 locals))))
1307 heller 1.92
1308     (defimplementation frame-var-value (frame var)
1309     (let* ((frame (nth-frame frame))
1310 nsiivola 1.285 (vars (frame-debug-vars frame))
1311     (loc (sb-di:frame-code-location frame))
1312     (dvar (if (= var (length vars))
1313 heller 1.306 ;; If VAR is out of bounds, it must be the fake var
1314     ;; we made up for &MORE.
1315     (let* ((context-var (find :more-context vars
1316     :key #'debug-var-info))
1317     (more-context (debug-var-value context-var frame
1318     loc))
1319     (count-var (find :more-count vars
1320     :key #'debug-var-info))
1321 nsiivola 1.285 (more-count (debug-var-value count-var frame loc)))
1322     (return-from frame-var-value
1323 heller 1.306 (multiple-value-list (sb-c:%more-arg-values
1324     more-context
1325     0 more-count))))
1326 nsiivola 1.285 (aref vars var))))
1327     (debug-var-value dvar frame loc)))
1328 dbarlow 1.1
1329 lgorrie 1.54 (defimplementation frame-catch-tags (index)
1330 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1331 lgorrie 1.50
1332 heller 1.56 (defimplementation eval-in-frame (form index)
1333     (let ((frame (nth-frame index)))
1334 heller 1.58 (funcall (the function
1335 jsnellman 1.158 (sb-di:preprocess-for-eval form
1336 heller 1.58 (sb-di:frame-code-location frame)))
1337 heller 1.56 frame)))
1338    
1339 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
1340     (progn
1341     (defimplementation return-from-frame (index form)
1342     (let* ((frame (nth-frame index)))
1343     (cond ((sb-debug:frame-has-debug-tag-p frame)
1344     (let ((values (multiple-value-list (eval-in-frame form index))))
1345     (sb-debug:unwind-to-frame-and-call frame
1346     (lambda ()
1347     (values-list values)))))
1348     (t (format nil "Cannot return from frame: ~S" frame)))))
1349 nsiivola 1.293
1350 jsnellman 1.174 (defimplementation restart-frame (index)
1351 nsiivola 1.293 (let ((frame (nth-frame index)))
1352     (when (sb-debug:frame-has-debug-tag-p frame)
1353     (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1354     (multiple-value-bind (fun arglist)
1355     (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1356     (values (fdefinition fname) args)
1357     (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1358     (sb-debug::frame-args-as-list frame)))
1359     (when (functionp fun)
1360 heller 1.306 (sb-debug:unwind-to-frame-and-call
1361     frame
1362     (lambda ()
1363     ;; Ensure TCO.
1364     (declare (optimize (debug 0)))
1365     (apply fun arglist)))))))
1366 nsiivola 1.293 (format nil "Cannot restart frame: ~S" frame))))
1367 heller 1.152
1368     ;; FIXME: this implementation doesn't unwind the stack before
1369     ;; re-invoking the function, but it's better than no implementation at
1370     ;; all.
1371 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
1372     (progn
1373     (defun sb-debug-catch-tag-p (tag)
1374     (and (symbolp tag)
1375     (not (symbol-package tag))
1376     (string= tag :sb-debug-catch-tag)))
1377    
1378     (defimplementation return-from-frame (index form)
1379     (let* ((frame (nth-frame index))
1380     (probe (assoc-if #'sb-debug-catch-tag-p
1381     (sb-di::frame-catches frame))))
1382     (cond (probe (throw (car probe) (eval-in-frame form index)))
1383     (t (format nil "Cannot return from frame: ~S" frame)))))
1384    
1385     (defimplementation restart-frame (index)
1386     (let ((frame (nth-frame index)))
1387     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1388 jsnellman 1.158
1389 lgorrie 1.87 ;;;;; reference-conditions
1390    
1391     (defimplementation format-sldb-condition (condition)
1392     (let ((sb-int:*print-condition-references* nil))
1393     (princ-to-string condition)))
1394    
1395 heller 1.57
1396     ;;;; Profiling
1397    
1398     (defimplementation profile (fname)
1399     (when fname (eval `(sb-profile:profile ,fname))))
1400    
1401     (defimplementation unprofile (fname)
1402     (when fname (eval `(sb-profile:unprofile ,fname))))
1403    
1404     (defimplementation unprofile-all ()
1405     (sb-profile:unprofile)
1406     "All functions unprofiled.")
1407    
1408     (defimplementation profile-report ()
1409     (sb-profile:report))
1410    
1411     (defimplementation profile-reset ()
1412     (sb-profile:reset)
1413     "Reset profiling counters.")
1414    
1415     (defimplementation profiled-functions ()
1416     (sb-profile:profile))
1417    
1418 heller 1.116 (defimplementation profile-package (package callers methods)
1419     (declare (ignore callers methods))
1420     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1421    
1422 heller 1.57
1423 heller 1.64 ;;;; Inspector
1424 heller 1.63
1425 heller 1.190 (defmethod emacs-inspect ((o t))
1426 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1427 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1428 heller 1.64 (t
1429 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1430 sboukarev 1.271 (list* (string-right-trim '(#\Newline) text)
1431     '(:newline)
1432 heller 1.191 (if label
1433     (loop for (l . v) in parts
1434     append (label-value-line l v))
1435 sboukarev 1.271 (loop for value in parts
1436     for i from 0
1437 heller 1.191 append (label-value-line i value))))))))
1438 heller 1.64
1439 heller 1.190 (defmethod emacs-inspect ((o function))
1440 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1441     (cond ((= header sb-vm:simple-fun-header-widetag)
1442 heller 1.126 (label-value-line*
1443     (:name (sb-kernel:%simple-fun-name o))
1444     (:arglist (sb-kernel:%simple-fun-arglist o))
1445     (:self (sb-kernel:%simple-fun-self o))
1446     (:next (sb-kernel:%simple-fun-next o))
1447     (:type (sb-kernel:%simple-fun-type o))
1448 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1449 heller 1.64 ((= header sb-vm:closure-header-widetag)
1450 jsnellman 1.158 (append
1451 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1452     `("Closed over values:" (:newline))
1453     (loop for i below (1- (sb-kernel:get-closure-length o))
1454 jsnellman 1.158 append (label-value-line
1455 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1456 heller 1.64 (t (call-next-method o)))))
1457    
1458 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1459 jsnellman 1.158 (append
1460     (label-value-line*
1461 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1462     (:entry-points (sb-kernel:%code-entry-points o))
1463     (:debug-info (sb-kernel:%code-debug-info o))
1464 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1465 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1466     `("Constants:" (:newline))
1467 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1468 mbaringer 1.102 below (sb-kernel:get-header-data o)
1469 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1470     `("Code:" (:newline)
1471     , (with-output-to-string (s)
1472     (cond ((sb-kernel:%code-debug-info o)
1473     (sb-disassem:disassemble-code-component o :stream s))
1474     (t
1475 jsnellman 1.158 (sb-disassem:disassemble-memory
1476     (sb-disassem::align
1477 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1478     sb-vm:lowtag-mask)
1479 heller 1.126 (* sb-vm:code-constants-offset
1480     sb-vm:n-word-bytes))
1481 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1482     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1483 heller 1.191 :stream s)))))))
1484 mbaringer 1.102
1485 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1486 mbaringer 1.167 (label-value-line*
1487 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1488 mbaringer 1.167
1489 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1490 heller 1.126 (label-value-line*
1491     (:name (sb-kernel:fdefn-name o))
1492 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1493 mbaringer 1.102
1494 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1495 jsnellman 1.158 (append
1496 heller 1.191 (call-next-method)
1497 heller 1.126 (label-value-line*
1498     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1499     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1500 heller 1.191 )))
1501 heller 1.90
1502 heller 1.63
1503 lgorrie 1.50 ;;;; Multiprocessing
1504    
1505 crhodes 1.136 #+(and sb-thread
1506 sboukarev 1.271 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1507 crhodes 1.136 (progn
1508     (defvar *thread-id-counter* 0)
1509 jsnellman 1.158
1510 crhodes 1.136 (defvar *thread-id-counter-lock*
1511     (sb-thread:make-mutex :name "thread id counter lock"))
1512    
1513     (defun next-thread-id ()
1514     (sb-thread:with-mutex (*thread-id-counter-lock*)
1515     (incf *thread-id-counter*)))
1516 jsnellman 1.158
1517 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1518    
1519     ;; This should be a thread -> id map but as weak keys are not
1520     ;; supported it is id -> map instead.
1521     (defvar *thread-id-map-lock*
1522     (sb-thread:make-mutex :name "thread id map lock"))
1523 jsnellman 1.158
1524 crhodes 1.136 (defimplementation spawn (fn &key name)
1525     (sb-thread:make-thread fn :name name))
1526    
1527     (defimplementation thread-id (thread)
1528 heller 1.160 (block thread-id
1529     (sb-thread:with-mutex (*thread-id-map-lock*)
1530     (loop for id being the hash-key in *thread-id-map*
1531     using (hash-value thread-pointer)
1532     do
1533     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1534     (cond ((null maybe-thread)
1535     ;; the value is gc'd, remove it manually
1536     (remhash id *thread-id-map*))
1537     ((eq thread maybe-thread)
1538     (return-from thread-id id)))))
1539     ;; lazy numbering
1540     (let ((id (next-thread-id)))
1541     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1542     id))))
1543 crhodes 1.136
1544     (defimplementation find-thread (id)
1545     (sb-thread:with-mutex (*thread-id-map-lock*)
1546     (let ((thread-pointer (gethash id *thread-id-map*)))
1547     (if thread-pointer
1548     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1549     (if maybe-thread
1550     maybe-thread
1551     ;; the value is gc'd, remove it manually
1552     (progn
1553     (remhash id *thread-id-map*)
1554     nil)))
1555     nil))))
1556 jsnellman 1.158
1557 crhodes 1.136 (defimplementation thread-name (thread)
1558     ;; sometimes the name is not a string (e.g. NIL)
1559     (princ-to-string (sb-thread:thread-name thread)))
1560    
1561     (defimplementation thread-status (thread)
1562     (if (sb-thread:thread-alive-p thread)
1563 sboukarev 1.253 "Running"
1564     "Stopped"))
1565    
1566 crhodes 1.136 (defimplementation make-lock (&key name)
1567     (sb-thread:make-mutex :name name))
1568    
1569     (defimplementation call-with-lock-held (lock function)
1570     (declare (type function function))
1571 nsiivola 1.154 (sb-thread:with-recursive-lock (lock) (funcall function)))
1572    
1573 crhodes 1.136 (defimplementation current-thread ()
1574     sb-thread:*current-thread*)
1575    
1576     (defimplementation all-threads ()
1577     (sb-thread:list-all-threads))
1578 jsnellman 1.158
1579 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1580     (sb-thread:interrupt-thread thread fn))
1581    
1582     (defimplementation kill-thread (thread)
1583     (sb-thread:terminate-thread thread))
1584    
1585     (defimplementation thread-alive-p (thread)
1586     (sb-thread:thread-alive-p thread))
1587    
1588     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1589     (defvar *mailboxes* (list))
1590     (declaim (type list *mailboxes*))
1591    
1592 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1593 crhodes 1.136 thread
1594     (mutex (sb-thread:make-mutex))
1595     (waitqueue (sb-thread:make-waitqueue))
1596     (queue '() :type list))
1597    
1598     (defun mailbox (thread)
1599     "Return THREAD's mailbox."
1600     (sb-thread:with-mutex (*mailbox-lock*)
1601     (or (find thread *mailboxes* :key #'mailbox.thread)
1602     (let ((mb (make-mailbox :thread thread)))
1603     (push mb *mailboxes*)
1604     mb))))
1605    
1606     (defimplementation send (thread message)
1607     (let* ((mbox (mailbox thread))
1608     (mutex (mailbox.mutex mbox)))
1609     (sb-thread:with-mutex (mutex)
1610     (setf (mailbox.queue mbox)
1611     (nconc (mailbox.queue mbox) (list message)))
1612     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1613 trittweiler 1.270 #-sb-lutex
1614     (defun condition-timed-wait (waitqueue mutex timeout)
1615     (handler-case
1616     (let ((*break-on-signals* nil))
1617     (sb-sys:with-deadline (:seconds timeout :override t)
1618     (sb-thread:condition-wait waitqueue mutex) t))
1619     (sb-ext:timeout ()
1620     nil)))
1621    
1622     ;; FIXME: with-timeout doesn't work properly on Darwin
1623     #+sb-lutex
1624     (defun condition-timed-wait (waitqueue mutex timeout)
1625     (declare (ignore timeout))
1626     (sb-thread:condition-wait waitqueue mutex))
1627    
1628 heller 1.212 (defimplementation receive-if (test &optional timeout)
1629 heller 1.209 (let* ((mbox (mailbox (current-thread)))
1630 trittweiler 1.270 (mutex (mailbox.mutex mbox))
1631     (waitq (mailbox.waitqueue mbox)))
1632 heller 1.212 (assert (or (not timeout) (eq timeout t)))
1633 heller 1.207 (loop
1634     (check-slime-interrupts)
1635 heller 1.209 (sb-thread:with-mutex (mutex)
1636 heller 1.202 (let* ((q (mailbox.queue mbox))
1637     (tail (member-if test q)))
1638 heller 1.207 (when tail
1639     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1640     (return (car tail))))
1641 heller 1.212 (when (eq timeout t) (return (values nil t)))
1642 trittweiler 1.270 (condition-timed-wait waitq mutex 0.2)))))
1643 heller 1.301
1644     (let ((alist '())
1645     (mutex (sb-thread:make-mutex :name "register-thread")))
1646    
1647     (defimplementation register-thread (name thread)
1648     (declare (type symbol name))
1649     (sb-thread:with-mutex (mutex)
1650     (etypecase thread
1651     (null
1652     (setf alist (delete name alist :key #'car)))
1653     (sb-thread:thread
1654     (let ((probe (assoc name alist)))
1655     (cond (probe (setf (cdr probe) thread))
1656     (t (setf alist (acons name thread alist))))))))
1657     nil)
1658    
1659     (defimplementation find-registered (name)
1660     (sb-thread:with-mutex (mutex)
1661     (cdr (assoc name alist)))))
1662    
1663 nsiivola 1.308 ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1664     ;; buffer write lock.
1665     ;;
1666     ;; Another alternative would be to grab the world-lock here, but that's less
1667     ;; future-proof, and could introduce other lock-ordering issues in the
1668     ;; future.
1669     ;;
1670     ;; In an ideal world we would just have an :AROUND method on
1671     ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1672     ;; file is loaded -- so first we need a dummy definition that will be
1673     ;; overridden by swank-gray.lisp.
1674     (defclass slime-output-stream (fundamental-character-output-stream)
1675     ())
1676     (defmethod stream-force-output :around ((stream slime-output-stream))
1677     (handler-case
1678     (sb-sys:with-deadline (:seconds 0.1)
1679     (call-next-method))
1680     (sb-sys:deadline-timeout ()
1681     nil)))
1682    
1683 heller 1.59 )
1684 heller 1.126
1685     (defimplementation quit-lisp ()
1686 sboukarev 1.311 #+#.(swank-backend:with-symbol 'exit 'sb-ext)
1687     (sb-ext:exit)
1688     #-#.(swank-backend:with-symbol 'exit 'sb-ext)
1689     (progn
1690     #+sb-thread
1691     (dolist (thread (remove (current-thread) (all-threads)))
1692     (ignore-errors (sb-thread:terminate-thread thread)))
1693     (sb-ext:quit)))
1694 heller 1.133
1695 mbaringer 1.117
1696 heller 1.118
1697 mbaringer 1.117 ;;Trace implementations
1698     ;;In SBCL, we have:
1699     ;; (trace <name>)
1700 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1701 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1702     ;; <name> can be a normal name or a (setf name)
1703    
1704 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1705 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1706     (eval `(untrace ,fspec))
1707     (format nil "~S is now untraced." fspec))
1708     (t
1709     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1710     (format nil "~S is now traced." fspec))))
1711    
1712     (defun process-fspec (fspec)
1713     (cond ((consp fspec)
1714     (ecase (first fspec)
1715     ((:defun :defgeneric) (second fspec))
1716     ((:defmethod) `(method ,@(rest fspec)))
1717     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1718     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1719     (t
1720     fspec)))
1721    
1722 heller 1.119 (defimplementation toggle-trace (spec)
1723     (ecase (car spec)
1724 jsnellman 1.158 ((setf)
1725 heller 1.119 (toggle-trace-aux spec))
1726     ((:defmethod)
1727     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1728     ((:defgeneric)
1729     (toggle-trace-aux (second spec) :methods t))
1730     ((:call)
1731     (destructuring-bind (caller callee) (cdr spec)
1732     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1733 mkoeppe 1.142
1734     ;;; Weak datastructures
1735    
1736 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1737     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1738     (apply #'make-hash-table :weakness :key args)
1739     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1740     (apply #'make-hash-table args))
1741 mkoeppe 1.142
1742 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1743 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1744     (apply #'make-hash-table :weakness :value args)
1745     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1746     (apply #'make-hash-table args))
1747 alendvai 1.173
1748     (defimplementation hash-table-weakness (hashtable)
1749     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1750     (sb-ext:hash-table-weakness hashtable))
1751 heller 1.214
1752     #-win32
1753     (defimplementation save-image (filename &optional restart-function)
1754 heller 1.274 (flet ((restart-sbcl ()
1755     (sb-debug::enable-debugger)
1756     (setf sb-impl::*descriptor-handlers* nil)
1757     (funcall restart-function)))
1758     (let ((pid (sb-posix:fork)))
1759     (cond ((= pid 0)
1760     (sb-debug::disable-debugger)
1761     (apply #'sb-ext:save-lisp-and-die filename
1762     (when restart-function
1763     (list :toplevel #'restart-sbcl))))
1764     (t
1765     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1766     (assert (= pid rpid))
1767     (assert (and (sb-posix:wifexited status)
1768     (zerop (sb-posix:wexitstatus status))))))))))
1769    
1770     #+unix
1771     (progn
1772 nsiivola 1.281 (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1773 heller 1.274 (program sb-alien:c-string)
1774     (argv (* sb-alien:c-string)))
1775 nsiivola 1.281
1776 heller 1.274 (defun execv (program args)
1777     "Replace current executable with another one."
1778     (let ((a-args (sb-alien:make-alien sb-alien:c-string
1779     (+ 1 (length args)))))
1780     (unwind-protect
1781     (progn
1782     (loop for index from 0 by 1
1783     and item in (append args '(nil))
1784     do (setf (sb-alien:deref a-args index)
1785     item))
1786     (when (minusp
1787     (sys-execv program a-args))
1788 nsiivola 1.281 (error "execv(3) returned.")))
1789 heller 1.274 (sb-alien:free-alien a-args))))
1790    
1791 sboukarev 1.275 (defun runtime-pathname ()
1792     #+#.(swank-backend:with-symbol
1793     '*runtime-pathname* 'sb-ext)
1794     sb-ext:*runtime-pathname*
1795     #-#.(swank-backend:with-symbol
1796     '*runtime-pathname* 'sb-ext)
1797     (car sb-ext:*posix-argv*))
1798    
1799 heller 1.274 (defimplementation exec-image (image-file args)
1800     (loop with fd-arg =
1801     (loop for arg in args
1802     and key = "" then arg
1803     when (string-equal key "--swank-fd")
1804 sboukarev 1.275 return (parse-integer arg))
1805 heller 1.274 for my-fd from 3 to 1024
1806     when (/= my-fd fd-arg)
1807 sboukarev 1.275 do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1808     (let* ((self-string (pathname-to-filename (runtime-pathname))))
1809 heller 1.274 (execv
1810     self-string
1811     (apply 'list self-string "--core" image-file args)))))
1812    
1813     (defimplementation make-fd-stream (fd external-format)
1814     (sb-sys:make-fd-stream fd :input t :output t
1815     :element-type 'character
1816     :buffering :full
1817     :dual-channel-p t
1818     :external-format external-format))
1819    
1820 nsiivola 1.283 (defimplementation call-with-io-timeout (function &key seconds)
1821     (handler-case
1822     (sb-sys:with-deadline (:seconds seconds)
1823     (funcall function))
1824     (sb-sys:deadline-timeout ()
1825     nil)))
1826    
1827 sboukarev 1.277 #-win32
1828     (defimplementation background-save-image (filename &key restart-function
1829     completion-function)
1830 heller 1.274 (flet ((restart-sbcl ()
1831     (sb-debug::enable-debugger)
1832     (setf sb-impl::*descriptor-handlers* nil)
1833     (funcall restart-function)))
1834     (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1835     (let ((pid (sb-posix:fork)))
1836     (cond ((= pid 0)
1837     (sb-posix:close pipe-in)
1838     (sb-debug::disable-debugger)
1839     (apply #'sb-ext:save-lisp-and-die filename
1840     (when restart-function
1841     (list :toplevel #'restart-sbcl))))
1842     (t
1843     (sb-posix:close pipe-out)
1844     (sb-sys:add-fd-handler
1845     pipe-in :input
1846     (lambda (fd)
1847     (sb-sys:invalidate-descriptor fd)
1848     (sb-posix:close fd)
1849     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1850     (assert (= pid rpid))
1851     (assert (sb-posix:wifexited status))
1852     (funcall completion-function
1853     (zerop (sb-posix:wexitstatus status))))))))))))
1854 nsiivola 1.278
1855     (defun deinit-log-output ()
1856     ;; Can't hang on to an fd-stream from a previous session.
1857 sboukarev 1.279 (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1858     nil))
1859 nsiivola 1.278
1860     (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5