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

Diff of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.32 by heller, Wed Dec 3 22:34:50 2003 UTC revision 1.44 by lgorrie, Sat Jan 10 06:45:05 2004 UTC
# Line 4  Line 4 
4    
5  (in-package :swank)  (in-package :swank)
6    
 ;; Turn on xref. [should we?]  
 (setf c:*record-xref-info* t)  
   
7  (defun without-interrupts* (body)  (defun without-interrupts* (body)
8    (sys:without-interrupts (funcall body)))    (sys:without-interrupts (funcall body)))
9    
 (defun set-fd-non-blocking (fd)  
   (flet ((fcntl (fd cmd arg)  
            (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)  
              (or flags  
                  (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))  
     (let ((flags (fcntl fd unix:F-GETFL 0)))  
       (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))  
   
10    
11  ;;;; TCP server.  ;;;; TCP server.
12    
# Line 27  Line 16 
16      (ext:htonl address)))      (ext:htonl address)))
17    
18  (defun create-swank-server (port &key (reuse-address t)  (defun create-swank-server (port &key (reuse-address t)
19                              (address "localhost"))                              (address "localhost")
20                                (announce #'simple-announce-function)
21                                (background *start-swank-in-background*)
22                                (close *close-swank-socket-after-setup*))
23    "Create a SWANK TCP server."    "Create a SWANK TCP server."
24    (let* ((ip (resolve-hostname address))    (let* ((ip (resolve-hostname address))
25           (fd (ext:create-inet-listener port :stream           (fd (ext:create-inet-listener port :stream
26                                         :reuse-address reuse-address                                         :reuse-address reuse-address
27                                         :host ip)))                                         :host ip)))
28      (system:add-fd-handler fd :input #'accept-connection)      (funcall announce (tcp-port fd))
29      (nth-value 1 (ext::get-socket-host-and-port fd))))      (accept-clients fd background close)))
30    
31    (defun accept-clients (fd background close)
32      "Accept clients on the the server socket FD.  Use fd-handlers if
33    BACKGROUND is non-nil.  Close the server socket after the first client
34    if CLOSE is non-nil, "
35      (flet ((accept-client (&optional (fdes fd))
36               (accept-one-client fd background close)))
37        (cond (background (add-input-handler fd #'accept-client))
38              (close      (accept-client))
39              (t          (loop (accept-client))))))
40    
41    (defun accept-one-client (socket background close)
42      (let ((fd (ext:accept-tcp-connection socket)))
43        (when close
44          (sys:invalidate-descriptor socket)
45          (unix:unix-close socket))
46        (setup-request-loop fd background)))
47    
48    (defun setup-request-loop (fd background)
49      "Setup request handling for connection FD.
50    If BACKGROUND is true, setup SERVE-EVENT handler and return immediately.
51    Otherwise enter a request handling loop until the connection closes."
52      (let* ((stream (make-emacs-io-stream fd))
53             (out (if *use-dedicated-output-stream*
54                      (open-stream-to-emacs stream)
55                      (make-slime-output-stream)))
56             (in (make-slime-input-stream))
57             (io (make-two-way-stream in out)))
58        (flet ((serve-request (&optional fdes)
59                 (declare (ignore fdes))
60                 (serve-one-request stream out in io)))
61          (if background
62              (add-input-handler fd #'serve-request)
63              (loop (serve-one-request stream out in io))))))
64    
65    (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
66      "Read and process one request from a SWANK client.
67    The request is read from the socket as a sexp and then evaluated.
68    Return non-nil iff a reader-error occured."
69      (catch 'slime-toplevel
70        (with-simple-restart (abort "Return to Slime toplevel.")
71          (handler-case (read-from-emacs)
72            (slime-read-error (e)
73              (when *swank-debug-p*
74                (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
75              (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
76              (close *emacs-io*)
77              (return-from serve-one-request t)))))
78      nil)
79    
80    ;;;
81    ;;;;; Socket helpers.
82    
83    (defun tcp-port (fd)
84      "Return the TCP port of the socket represented by FD."
85      (nth-value 1 (ext::get-socket-host-and-port fd)))
86    
87    (defun resolve-hostname (hostname)
88      "Return the IP address of HOSTNAME as an integer."
89      (let* ((hostent (ext:lookup-host-entry hostname))
90             (address (car (ext:host-entry-addr-list hostent))))
91        (ext:htonl address)))
92    
93  (defun accept-connection (socket)  (defun add-input-handler (fd fn)
94    "Accept one Swank TCP connection on SOCKET and then close it."    (system:add-fd-handler fd :input fn))
   (setup-request-handler (ext:accept-tcp-connection socket))  
   (sys:invalidate-descriptor socket)  
   (unix:unix-close socket))  
95    
96  (defun open-stream-to-emacs ()  (defun make-emacs-io-stream (fd)
97      "Create a new input/output fd-stream for FD."
98      (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
99    
100    (defun open-stream-to-emacs (*emacs-io*)
101    "Return an output-stream to Emacs' output buffer."    "Return an output-stream to Emacs' output buffer."
102    (let* ((ip (resolve-hostname "localhost"))    (let* ((ip (resolve-hostname "localhost"))
103           (listener (ext:create-inet-listener 0 :stream :host ip))           (listener (ext:create-inet-listener 0 :stream :host ip))
104           (port (nth-value 1 (ext::get-socket-host-and-port listener))))           (port (tcp-port listener)))
105      (unwind-protect      (unwind-protect
106           (progn           (progn
107             (eval-in-emacs `(slime-open-stream-to-lisp ,port))             (eval-in-emacs `(slime-open-stream-to-lisp ,port))
# Line 54  Line 109 
109               (sys:make-fd-stream fd :output t)))               (sys:make-fd-stream fd :output t)))
110        (ext:close-socket listener))))        (ext:close-socket listener))))
111    
 (defvar *use-dedicated-output-stream* t)  
   
 (defun setup-request-handler (socket)  
   "Setup request handling for SOCKET."  
   (let* ((stream (sys:make-fd-stream socket  
                                      :input t :output t  
                                      :element-type 'base-char))  
          (input (make-slime-input-stream))  
          (output (if *use-dedicated-output-stream*  
                      (let ((*emacs-io* stream)) (open-stream-to-emacs))  
                      (make-slime-output-stream)))  
          (io (make-two-way-stream input output)))  
     (system:add-fd-handler socket  
                            :input (lambda (fd)  
                                     (declare (ignore fd))  
                                     (serve-request stream output input io)))))  
   
 (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)  
   "Read and process a request from a SWANK client.  
 The request is read from the socket as a sexp and then evaluated."  
   (catch 'slime-toplevel  
     (with-simple-restart (abort "Return to Slime toplevel.")  
       (handler-case (read-from-emacs)  
         (slime-read-error (e)  
           (when *swank-debug-p*  
             (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))  
           (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))  
           (close *emacs-io*)))))  
   (sys:scrub-control-stack))  
   
112    
113  ;;;; Stream handling  ;;;; Stream handling
114    
# Line 277  the error-context redundant." Line 302  the error-context redundant."
302           (make-location (list :file (namestring *compile-file-truename*))           (make-location (list :file (namestring *compile-file-truename*))
303                          (list :position 0)))                          (list :position 0)))
304          (*compile-filename*          (*compile-filename*
305             ;; XXX is this _ever_ used?  By what?  *compile-file-truename*
306             ;; should be set by the implementation inside any call to compile-file
307           (make-location (list :file *compile-filename*) (list :position 0)))           (make-location (list :file *compile-filename*) (list :position 0)))
308          (t          (t
309           (list :error "No error location available"))))           (list :error "No error location available"))))
310    
311  (defmacro with-compilation-hooks (() &body body)  (defmethod call-with-compilation-hooks (function)
312    "Execute BODY and record the set of compiler notes."    (let ((*previous-compiler-condition* nil)
313    `(let ((*previous-compiler-condition* nil)          (*previous-context* nil)
314           (*previous-context* nil)          (*print-readably* nil))
          (*print-readably* nil))  
315      (handler-bind ((c::compiler-error #'handle-notification-condition)      (handler-bind ((c::compiler-error #'handle-notification-condition)
316                     (c::style-warning  #'handle-notification-condition)                     (c::style-warning  #'handle-notification-condition)
317                     (c::warning        #'handle-notification-condition))                     (c::warning        #'handle-notification-condition))
318        ,@body)))        (funcall function))))
319    
320  (defmethod compile-file-for-emacs (filename load-p)  (defmethod compile-file-for-emacs (filename load-p)
321    (clear-xref-info filename)    (clear-xref-info filename)
322    (with-compilation-hooks ()    (with-compilation-hooks ()
323      (let ((*buffer-name* nil)      (let ((*buffer-name* nil)
324            (*compile-filename* filename))            (*compile-filename* filename))
325          (compile-file filename :load load-p))))        (multiple-value-bind (fasl-file warnings-p failure-p)
326              (compile-file filename)
327            (declare (ignore warnings-p))
328            (when (and load-p (not failure-p))
329              (load fasl-file))))))
330    
331  (defmethod compile-string-for-emacs (string &key buffer position)  (defmethod compile-string-for-emacs (string &key buffer position)
332    (with-compilation-hooks ()    (with-compilation-hooks ()
# Line 312  the error-context redundant." Line 342  the error-context redundant."
342                          :emacs-buffer-offset ,position                          :emacs-buffer-offset ,position
343                          :emacs-buffer-string ,string))))))                          :emacs-buffer-string ,string))))))
344    
345    (defmethod compile-system-for-emacs (system-name)
346      (with-compilation-hooks ()
347        (cond ((ext:featurep :asdf)
348               (let ((operate (find-symbol (string :operate) :asdf))
349                     (load-op (find-symbol (string :load-op) :asdf)))
350                 (funcall operate load-op system-name)))
351              (t (error "ASDF not loaded")))))
352    
353    
354  ;;;; XREF  ;;;; XREF
355    
# Line 380  reference   ::= (FUNCTION-SPECIFIER . SO Line 418  reference   ::= (FUNCTION-SPECIFIER . SO
418                xrefs)))                xrefs)))
419      (group-xrefs xrefs)))      (group-xrefs xrefs)))
420    
   
 (defun location-buffer= (location1 location2)  
   (equalp location1 location2))  
   
 (defun file-xrefs-for-emacs (unix-filename contexts)  
   "Return a summary of the references from a particular file.  
 The result is a list of the form (FILENAME ((REFERRER SOURCE-PATH) ...))"  
   (list unix-filename  
         (loop for context in (sort-contexts-by-source-path contexts)  
               collect (list (let ((*print-pretty* nil))  
                               (to-string (xref:xref-context-name context)))  
                             (xref:xref-context-source-path context)))))  
   
 (defun sort-contexts-by-source-path (contexts)  
   "Sort xref contexts by lexical position of source-paths.  
 It is assumed that all contexts belong to the same file."  
   (sort contexts #'source-path< :key #'xref:xref-context-source-path))  
   
 (defun source-path< (path1 path2)  
   "Return true if PATH1 is lexically before PATH2."  
   (and (every #'< path1 path2)  
        (< (length path1) (length path2))))  
   
421  (defun clear-xref-info (namestring)  (defun clear-xref-info (namestring)
422    "Clear XREF notes pertaining to FILENAME.    "Clear XREF notes pertaining to FILENAME.
423  This is a workaround for a CMUCL bug: XREF records are cumulative."  This is a workaround for a CMUCL bug: XREF records are cumulative."
# Line 551  the code omponent CODE." Line 566  the code omponent CODE."
566                                   (function-source-location fn)))                                   (function-source-location fn)))
567                           fns))))                           fns))))
568    
569    
570  ;;;; Definitions  ;;;; Definitions
571    
572  (defvar *debug-definition-finding* t  (defvar *debug-definition-finding* nil
573    "When true don't handle errors while looking for definitions.    "When true don't handle errors while looking for definitions.
574  This is useful when debugging the definition-finding code.")  This is useful when debugging the definition-finding code.")
575    
576  (defmacro safe-definition-finding (&body body)  (defmacro safe-definition-finding (&body body)
577    "Execute BODY ignoring errors.  Return a the source location    "Execute BODY ignoring errors.  Return the source location returned
578  returned by BODY or if an error occurs a description of the error.  by BODY or if an error occurs a description of the error.  The second
579  The second return value is the condition or nil."  return value is the condition or nil."
580    `(flet ((body () ,@body))    `(flet ((body () ,@body))
581      (if *debug-definition-finding*      (if *debug-definition-finding*
582          (body)          (body)
# Line 670  The second return value is the condition Line 686  The second return value is the condition
686    (destructuring-bind (first) (function-source-locations function)    (destructuring-bind (first) (function-source-locations function)
687      first))      first))
688    
689  (defslimefun find-function-locations (symbol-name)  (defmethod find-function-locations (symbol-name)
690    "Return a list of source-locations for SYMBOL-NAME's functions."    "Return a list of source-locations for SYMBOL-NAME's functions."
691    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
692      (cond ((not foundp)      (cond ((not foundp)
# Line 807  The result has the format \"(...)\"." Line 823  The result has the format \"(...)\"."
823  (defmethod macroexpand-all (form)  (defmethod macroexpand-all (form)
824    (walker:macroexpand-all form))    (walker:macroexpand-all form))
825    
826  (defun tracedp (fname)  (in-package :c)
827    (gethash (debug::trace-fdefinition fname)  
828             debug::*traced-functions*))  (defun swank::expand-ir1-top-level (form)
829      "A scaled down version of the first pass of the compiler."
830  (defslimefun toggle-trace-fdefinition (fname-string)    (with-compilation-unit ()
831    (let ((fname (from-string fname-string)))      (let* ((*lexical-environment*
832      (cond ((tracedp fname)              (make-lexenv :default (make-null-environment)
833             (debug::untrace-1 fname)                           :cookie *default-cookie*
834             (format nil "~S is now untraced." fname))                           :interface-cookie *default-interface-cookie*))
835            (t             (*source-info* (make-lisp-source-info form))
836             (debug::trace-1 fname (debug::make-trace-info))             (*block-compile* nil)
837             (format nil "~S is now traced." fname)))))             (*block-compile-default* nil))
838          (with-ir1-namespace
839              (clear-stuff)
840            (find-source-paths form 0)
841            (ir1-top-level form '(0) t)))))
842    
843    (in-package :swank)
844    
845    (defslimefun print-ir1-converted-blocks (form)
846      (with-output-to-string (*standard-output*)
847        (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
848    
849  (defslimefun set-default-directory (directory)  (defslimefun set-default-directory (directory)
850    (setf (ext:default-directory) (namestring directory))    (setf (ext:default-directory) (namestring directory))
# Line 827  The result has the format \"(...)\"." Line 853  The result has the format \"(...)\"."
853    (setf *default-pathname-defaults* (pathname (ext:default-directory)))    (setf *default-pathname-defaults* (pathname (ext:default-directory)))
854    (namestring (ext:default-directory)))    (namestring (ext:default-directory)))
855    
856    ;;; source-path-{stream,file,string,etc}-position moved into
857  ;;;; Source-paths  ;;; swank-source-path-parser
   
 ;;; CMUCL uses a data structure called "source-path" to locate  
 ;;; subforms.  The compiler assigns a source-path to each form in a  
 ;;; compilation unit.  Compiler notes usually contain the source-path  
 ;;; of the error location.  
 ;;;  
 ;;; Compiled code objects don't contain source paths, only the  
 ;;; "toplevel-form-number" and the (sub-) "form-number".  To get from  
 ;;; the form-number to the source-path we need the entire toplevel-form  
 ;;; (i.e. we have to read the source code).  CMUCL has already some  
 ;;; utilities to do this translation, but we use some extended  
 ;;; versions, because we need more exact position info.  Apparently  
 ;;; Hemlock is happy with the position of the toplevel-form; we also  
 ;;; need the position of subforms.  
 ;;;  
 ;;; We use a special readtable to get the positions of the subforms.  
 ;;; The readtable stores the start and end position for each subform in  
 ;;; hashtable for later retrieval.  
   
 (defun make-source-recorder (fn source-map)  
   "Return a macro character function that does the same as FN, but  
 additionally stores the result together with the stream positions  
 before and after of calling FN in the hashtable SOURCE-MAP."  
   (lambda (stream char)  
     (let ((start (file-position stream))  
           (values (multiple-value-list (funcall fn stream char)))  
           (end (file-position stream)))  
       #+(or) (format t "~&[~D ~{~A~^, ~} ~D]~%" start values end)  
       (unless (null values)  
         (push (cons start end) (gethash (car values) source-map)))  
       (values-list values))))  
   
 (defun make-source-recording-readtable (readtable source-map)  
   "Return a source position recording copy of READTABLE.  
 The source locations are stored in SOURCE-MAP."  
   (let* ((tab (copy-readtable readtable))  
          (*readtable* tab))  
     (dotimes (code char-code-limit)  
       (let ((char (code-char code)))  
         (multiple-value-bind (fn term) (get-macro-character char tab)  
           (when fn  
             (set-macro-character char (make-source-recorder fn source-map)  
                                  term tab)))))  
     tab))  
   
 (defun make-source-map ()  
   (make-hash-table :test #'eq))  
   
 (defvar *source-map* (make-source-map)  
   "The hashtable table used for source position recording.")  
   
 (defvar *recording-readtable-cache* '()  
   "An alist of (READTABLE . RECORDING-READTABLE) pairs.")  
   
 (defun lookup-recording-readtable (readtable)  
   "Find a cached or create a new recording readtable for READTABLE."  
   (or (cdr (assoc readtable *recording-readtable-cache*))  
       (let ((table (make-source-recording-readtable readtable *source-map*)))  
         (push (cons readtable table) *recording-readtable-cache*)  
         table)))  
   
 (defun read-and-record-source-map (stream)  
   "Read the next object from STREAM.  
 Return the object together with a hashtable that maps  
 subexpressions of the object to stream positions."  
   (let ((*readtable* (lookup-recording-readtable *readtable*)))  
     (clrhash *source-map*)  
     (values (read stream) *source-map*)))  
   
 (defun source-path-stream-position (path stream)  
   "Search the source-path PATH in STREAM and return its position."  
   (destructuring-bind (tlf-number . path) path  
     (let ((*read-suppress* t))  
       (dotimes (i tlf-number) (read stream))  
       (multiple-value-bind (form source-map)  
           (read-and-record-source-map stream)  
         (source-path-source-position (cons 0 path) form source-map)))))  
   
 (defun source-path-string-position (path string)  
   (with-input-from-string (s string)  
     (source-path-stream-position path s)))  
   
 (defun source-path-file-position (path filename)  
   (with-open-file (file filename)  
     (source-path-stream-position path file)))  
   
 (defun source-path-source-position (path form source-map)  
   "Return the start position of PATH form FORM and SOURCE-MAP.  All  
 subforms along the path are considered and the start and end position  
 of deepest (i.e. smallest) possible form is returned."  
   ;; compute all subforms along path  
   (let ((forms (loop for n in path  
                      for f = form then (nth n f)  
                      collect f)))  
     ;; select the first subform present in source-map  
     (loop for form in (reverse forms)  
           for positions = (gethash form source-map)  
           until (and positions (null (cdr positions)))  
           finally (destructuring-bind ((start . end)) positions  
                     (return (values (1- start) end))))))  
858    
859  (defun code-location-stream-position (code-location stream)  (defun code-location-stream-position (code-location stream)
860    "Return the byte offset of CODE-LOCATION in STREAM.  Extract the    "Return the byte offset of CODE-LOCATION in STREAM.  Extract the
# Line 1028  format suitable for Emacs." Line 954  format suitable for Emacs."
954          collect (list (princ-to-string (restart-name restart))          collect (list (princ-to-string (restart-name restart))
955                        (princ-to-string restart))))                        (princ-to-string restart))))
956    
 (defun format-condition-for-emacs ()  
   (format nil "~A~%   [Condition of type ~S]"  
           (debug::safe-condition-message *swank-debugger-condition*)  
           (type-of *swank-debugger-condition*)))  
   
957  (defun nth-frame (index)  (defun nth-frame (index)
958    (do ((frame *sldb-stack-top* (di:frame-down frame))    (do ((frame *sldb-stack-top* (di:frame-down frame))
959         (i index (1- i)))         (i index (1- i)))
# Line 1041  format suitable for Emacs." Line 962  format suitable for Emacs."
962  (defun nth-restart (index)  (defun nth-restart (index)
963    (nth index *sldb-restarts*))    (nth index *sldb-restarts*))
964    
965  (defun format-frame-for-emacs (frame)  (defun format-frame-for-emacs (number frame)
966    (list (di:frame-number frame)    (print-with-frame-label
967          (with-output-to-string (*standard-output*)     number (lambda (*standard-output*)
968            (let ((*print-pretty* *sldb-pprint-frames*))              (debug::print-frame-call frame :verbosity 1 :number nil))))
             (debug::print-frame-call frame :verbosity 1 :number t)))))  
969    
970  (defun compute-backtrace (start end)  (defun compute-backtrace (start end)
971    "Return a list of frames starting with frame number START and    "Return a list of frames starting with frame number START and
# Line 1055  stack." Line 975  stack."
975      (loop for f = (nth-frame start) then (di:frame-down f)      (loop for f = (nth-frame start) then (di:frame-down f)
976            for i from start below end            for i from start below end
977            while f            while f
978            collect f)))            collect (cons i f))))
979    
980  (defmethod backtrace (start end)  (defmethod backtrace (start end)
981    (mapcar #'format-frame-for-emacs (compute-backtrace start end)))    (loop for (n . frame) in (compute-backtrace start end)
982            collect (list n (format-frame-for-emacs n frame))))
983    
984  (defmethod debugger-info-for-emacs (start end)  (defmethod debugger-info-for-emacs (start end)
985    (list (format-condition-for-emacs)    (list (debugger-condition-for-emacs)
986          (format-restarts-for-emacs)          (format-restarts-for-emacs)
987          (backtrace start end)))          (backtrace start end)))
988    
# Line 1085  stack." Line 1006  stack."
1006           (location (di:frame-code-location frame))           (location (di:frame-code-location frame))
1007           (debug-function (di:frame-debug-function frame))           (debug-function (di:frame-debug-function frame))
1008           (debug-variables (di::debug-function-debug-variables debug-function)))           (debug-variables (di::debug-function-debug-variables debug-function)))
1009      (loop for v across debug-variables      (loop for v across debug-variables collect
1010            collect (list            (list :name (to-string (di:debug-variable-symbol v))
1011                     :symbol (di:debug-variable-symbol v)                  :id (di:debug-variable-id v)
1012                     :id (di:debug-variable-id v)                  :value-string (ecase (di:debug-variable-validity v location)
1013                     :value-string                                  (:valid
1014                     (if (eq (di:debug-variable-validity v location)                                   (to-string (di:debug-variable-value v frame)))
1015                             :valid)                                  ((:invalid :unknown)
1016                         (to-string (di:debug-variable-value v frame))                                   "<not-available>"))))))
                        "<not-available>")))))  
1017    
1018  (defmethod frame-catch-tags (index)  (defmethod frame-catch-tags (index)
1019    (loop for (tag . code-location) in (di:frame-catches (nth-frame index))    (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
# Line 1105  stack." Line 1025  stack."
1025  (defslimefun sldb-abort ()  (defslimefun sldb-abort ()
1026    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1027    
1028    (defun set-step-breakpoints (frame)
1029      (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1030                                         (di:frame-code-location frame)))
1031        (error "Cannot step, in elsewhere code~%"))
1032      (let* ((code-location (di:frame-code-location frame))
1033             (debug::*bad-code-location-types*
1034              (remove :call-site debug::*bad-code-location-types*))
1035             (next (debug::next-code-locations code-location)))
1036        (cond (next
1037               (let ((steppoints '()))
1038                 (flet ((hook (frame breakpoint)
1039                          (let ((debug:*stack-top-hint* frame))
1040                            (mapc #'di:delete-breakpoint steppoints)
1041                            (let ((cl (di::breakpoint-what breakpoint)))
1042                              (break "Breakpoint: ~S ~S"
1043                                     (di:code-location-kind cl)
1044                                     (di::compiled-code-location-pc cl))))))
1045                   (dolist (code-location next)
1046                     (let ((bp (di:make-breakpoint #'hook code-location
1047                                                   :kind :code-location)))
1048                       (di:activate-breakpoint bp)
1049                       (push bp steppoints))))))
1050             (t
1051              (flet ((hook (frame breakpoint values cookie)
1052                       (declare (ignore cookie))
1053                       (di:delete-breakpoint breakpoint)
1054                       (let ((debug:*stack-top-hint* frame))
1055                         (break "Function-end: ~A ~A" breakpoint values))))
1056                (let* ((debug-function (di:frame-debug-function frame))
1057                       (bp (di:make-breakpoint #'hook debug-function
1058                                               :kind :function-end)))
1059                  (di:activate-breakpoint bp)))))))
1060    
1061    (defslimefun sldb-step (frame)
1062      (cond ((find-restart 'continue *swank-debugger-condition*)
1063             (set-step-breakpoints (nth-frame frame))
1064             (continue *swank-debugger-condition*))
1065            (t
1066             (error "Cannot continue in from condition: ~A"
1067                    *swank-debugger-condition*))))
1068    
1069    (defslimefun sldb-disassemble (frame-number)
1070      "Return a string with the disassembly of frames code."
1071      ;; this could need some refactoring.
1072      (let* ((frame (nth-frame frame-number))
1073             (real-frame (di::frame-real-frame frame))
1074             (frame-pointer (di::frame-pointer real-frame))
1075             (debug-fun (di:frame-debug-function real-frame)))
1076        (with-output-to-string (*standard-output*)
1077          (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
1078                  frame (eq frame real-frame) real-frame frame-pointer)
1079          (etypecase debug-fun
1080            (di::compiled-debug-function
1081             (let* ((code-loc (di:frame-code-location frame))
1082                    (component (di::compiled-debug-function-component debug-fun))
1083                    (pc (di::compiled-code-location-pc code-loc))
1084                    (ip (sys:sap-int
1085                         (sys:sap+ (kernel:code-instructions component) pc)))
1086                    (kind (if (di:code-location-unknown-p code-loc)
1087                              :unkown
1088                              (di:code-location-kind code-loc)))
1089                    (fun (di:debug-function-function debug-fun)))
1090               (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
1091                       ip pc kind)
1092               (if fun
1093                   (disassemble fun)
1094                   (disassem:disassemble-code-component component))))
1095            (di::bogus-debug-function
1096             (format t "~%[Disassembling bogus frames not implemented]"))))))
1097    
1098  ;;;; Inspecting  ;;;; Inspecting
1099    
# Line 1304  nil if there's no second element." Line 1293  nil if there's no second element."
1293            `(("Name" . ,(kernel:fdefn-name o))            `(("Name" . ,(kernel:fdefn-name o))
1294              ("Function" . ,(kernel:fdefn-function o)))))              ("Function" . ,(kernel:fdefn-function o)))))
1295    
1296    
1297    ;;;; Multiprocessing
1298    
1299    #+MP
1300    (progn
1301      (defvar *I/O-lock*          (mp:make-lock "SWANK I/O lock"))
1302      (defvar *conversation-lock* (mp:make-lock "SWANK conversation lock"))
1303    
1304      (defvar *known-processes* '()         ; FIXME: leakage. -luke
1305        "List of processes that have been assigned IDs.
1306         The ID is the position in the list.")
1307    
1308      (defmethod startup-multiprocessing ()
1309        (mp::startup-idle-and-top-level-loops))
1310    
1311      (defmethod thread-id ()
1312        (mp:without-scheduling
1313         (or (find-thread-id)
1314             (prog1 (length *known-processes*)
1315               (setq *known-processes*
1316                     (append *known-processes* (list (mp:current-process))))))))
1317    
1318      (defun find-thread-id (&optional (process (mp:current-process)))
1319        (position process *known-processes*))
1320    
1321      (defun lookup-thread (thread-id)
1322        (or (nth thread-id *known-processes*)
1323            (error "Unknown Thread-ID: ~S" thread-id)))
1324    
1325      (defmethod thread-name (thread-id)
1326        (mp:process-name (lookup-thread thread-id)))
1327    
1328      (defmethod call-with-I/O-lock (function)
1329        (mp:with-lock-held (*I/O-lock*)
1330          (funcall function)))
1331    
1332      (defmethod call-with-conversation-lock (function)
1333        (mp:with-lock-held (*conversation-lock*)
1334          (funcall function)))
1335    
1336      (defmethod wait-goahead ()
1337        (mp:disable-process (mp:current-process))
1338        (mp:process-yield))
1339    
1340      (defmethod give-goahead (thread-id)
1341        (mp:enable-process (lookup-thread thread-id))))
1342    
1343    
1344    ;;;; Epilogue
1345  ;;; Local Variables:  ;;; Local Variables:
1346  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1347  ;;; End:  ;;; End:

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.44

  ViewVC Help
Powered by ViewVC 1.1.5