/[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.43 by heller, Fri Jan 2 18:23:14 2004 UTC
# Line 27  Line 27 
27      (ext:htonl address)))      (ext:htonl address)))
28    
29  (defun create-swank-server (port &key (reuse-address t)  (defun create-swank-server (port &key (reuse-address t)
30                              (address "localhost"))                              (address "localhost")
31                                (announce #'simple-announce-function)
32                                (background *start-swank-in-background*)
33                                (close *close-swank-socket-after-setup*))
34    "Create a SWANK TCP server."    "Create a SWANK TCP server."
35    (let* ((ip (resolve-hostname address))    (let* ((ip (resolve-hostname address))
36           (fd (ext:create-inet-listener port :stream           (fd (ext:create-inet-listener port :stream
37                                         :reuse-address reuse-address                                         :reuse-address reuse-address
38                                         :host ip)))                                         :host ip)))
39      (system:add-fd-handler fd :input #'accept-connection)      (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd)))
40      (nth-value 1 (ext::get-socket-host-and-port fd))))      (accept-loop fd background close)))
41    
42  (defun accept-connection (socket)  (defun emacs-io (fd)
43    "Accept one Swank TCP connection on SOCKET and then close it."    "Create a new fd-stream for fd."
44    (setup-request-handler (ext:accept-tcp-connection socket))    (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
45    (sys:invalidate-descriptor socket)  
46    (unix:unix-close socket))  (defun add-input-handler (fd fn)
47      (system:add-fd-handler fd :input fn))
48    
49    (defun accept-loop (fd background close)
50      "Accept clients on the the server socket FD.  Use fd-handlers if
51    BACKGROUND is non-nil.  Close the server socket after the first client
52    if CLOSE is non-nil, "
53      (cond (background
54             (add-input-handler
55              fd (lambda (fd) (accept-one-client fd background close))))
56            (close
57             (accept-one-client fd background close))
58            (t
59             (loop (accept-one-client fd background close)))))
60    
61    (defun accept-one-client (socket background close)
62      (let ((fd (ext:accept-tcp-connection socket)))
63        (when close
64          (sys:invalidate-descriptor socket)
65          (unix:unix-close socket))
66        (request-loop fd background)))
67    
68    (defun request-loop (fd background)
69      "Process all request from the socket FD."
70      (let* ((stream (emacs-io fd))
71             (out (if *use-dedicated-output-stream*
72                      (open-stream-to-emacs stream)
73                      (make-slime-output-stream)))
74             (in (make-slime-input-stream))
75             (io (make-two-way-stream in out)))
76        (cond (background
77               (add-input-handler
78                fd (lambda (fd)
79                     (declare (ignore fd))
80                     (serve-one-request stream out in io))))
81              (t (do () ((serve-one-request stream out in io)))))))
82    
83    (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
84      "Read and process one request from a SWANK client.
85    The request is read from the socket as a sexp and then evaluated.
86    Return non-nil iff a reader-error occured."
87      (catch 'slime-toplevel
88        (with-simple-restart (abort "Return to Slime toplevel.")
89          (handler-case (read-from-emacs)
90            (slime-read-error (e)
91              (when *swank-debug-p*
92                (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
93              (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
94              (close *emacs-io*)
95              (return-from serve-one-request t)))))
96      nil)
97    
98  (defun open-stream-to-emacs ()  (defun open-stream-to-emacs (*emacs-io*)
99    "Return an output-stream to Emacs' output buffer."    "Return an output-stream to Emacs' output buffer."
100    (let* ((ip (resolve-hostname "localhost"))    (let* ((ip (resolve-hostname "localhost"))
101           (listener (ext:create-inet-listener 0 :stream :host ip))           (listener (ext:create-inet-listener 0 :stream :host ip))
# Line 54  Line 107 
107               (sys:make-fd-stream fd :output t)))               (sys:make-fd-stream fd :output t)))
108        (ext:close-socket listener))))        (ext:close-socket listener))))
109    
 (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))  
   
110    
111  ;;;; Stream handling  ;;;; Stream handling
112    
# Line 277  the error-context redundant." Line 300  the error-context redundant."
300           (make-location (list :file (namestring *compile-file-truename*))           (make-location (list :file (namestring *compile-file-truename*))
301                          (list :position 0)))                          (list :position 0)))
302          (*compile-filename*          (*compile-filename*
303             ;; XXX is this _ever_ used?  By what?  *compile-file-truename*
304             ;; should be set by the implementation inside any call to compile-file
305           (make-location (list :file *compile-filename*) (list :position 0)))           (make-location (list :file *compile-filename*) (list :position 0)))
306          (t          (t
307           (list :error "No error location available"))))           (list :error "No error location available"))))
308    
309  (defmacro with-compilation-hooks (() &body body)  (defmethod call-with-compilation-hooks (function)
310    "Execute BODY and record the set of compiler notes."    (let ((*previous-compiler-condition* nil)
311    `(let ((*previous-compiler-condition* nil)          (*previous-context* nil)
312           (*previous-context* nil)          (*print-readably* nil))
          (*print-readably* nil))  
313      (handler-bind ((c::compiler-error #'handle-notification-condition)      (handler-bind ((c::compiler-error #'handle-notification-condition)
314                     (c::style-warning  #'handle-notification-condition)                     (c::style-warning  #'handle-notification-condition)
315                     (c::warning        #'handle-notification-condition))                     (c::warning        #'handle-notification-condition))
316        ,@body)))        (funcall function))))
317    
318  (defmethod compile-file-for-emacs (filename load-p)  (defmethod compile-file-for-emacs (filename load-p)
319    (clear-xref-info filename)    (clear-xref-info filename)
320    (with-compilation-hooks ()    (with-compilation-hooks ()
321      (let ((*buffer-name* nil)      (let ((*buffer-name* nil)
322            (*compile-filename* filename))            (*compile-filename* filename))
323          (compile-file filename :load load-p))))        (multiple-value-bind (fasl-file warnings-p failure-p)
324              (compile-file filename)
325            (declare (ignore warnings-p))
326            (when (and load-p (not failure-p))
327              (load fasl-file))))))
328    
329  (defmethod compile-string-for-emacs (string &key buffer position)  (defmethod compile-string-for-emacs (string &key buffer position)
330    (with-compilation-hooks ()    (with-compilation-hooks ()
# Line 312  the error-context redundant." Line 340  the error-context redundant."
340                          :emacs-buffer-offset ,position                          :emacs-buffer-offset ,position
341                          :emacs-buffer-string ,string))))))                          :emacs-buffer-string ,string))))))
342    
343    (defmethod compile-system-for-emacs (system-name)
344      (with-compilation-hooks ()
345        (cond ((ext:featurep :asdf)
346               (let ((operate (find-symbol (string :operate) :asdf))
347                     (load-op (find-symbol (string :load-op) :asdf)))
348                 (funcall operate load-op system-name)))
349              (t (error "ASDF not loaded")))))
350    
351    
352  ;;;; XREF  ;;;; XREF
353    
# Line 380  reference   ::= (FUNCTION-SPECIFIER . SO Line 416  reference   ::= (FUNCTION-SPECIFIER . SO
416                xrefs)))                xrefs)))
417      (group-xrefs xrefs)))      (group-xrefs xrefs)))
418    
   
 (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))))  
   
419  (defun clear-xref-info (namestring)  (defun clear-xref-info (namestring)
420    "Clear XREF notes pertaining to FILENAME.    "Clear XREF notes pertaining to FILENAME.
421  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 564  the code omponent CODE."
564                                   (function-source-location fn)))                                   (function-source-location fn)))
565                           fns))))                           fns))))
566    
567    
568  ;;;; Definitions  ;;;; Definitions
569    
570  (defvar *debug-definition-finding* t  (defvar *debug-definition-finding* nil
571    "When true don't handle errors while looking for definitions.    "When true don't handle errors while looking for definitions.
572  This is useful when debugging the definition-finding code.")  This is useful when debugging the definition-finding code.")
573    
574  (defmacro safe-definition-finding (&body body)  (defmacro safe-definition-finding (&body body)
575    "Execute BODY ignoring errors.  Return a the source location    "Execute BODY ignoring errors.  Return the source location returned
576  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
577  The second return value is the condition or nil."  return value is the condition or nil."
578    `(flet ((body () ,@body))    `(flet ((body () ,@body))
579      (if *debug-definition-finding*      (if *debug-definition-finding*
580          (body)          (body)
# Line 670  The second return value is the condition Line 684  The second return value is the condition
684    (destructuring-bind (first) (function-source-locations function)    (destructuring-bind (first) (function-source-locations function)
685      first))      first))
686    
687  (defslimefun find-function-locations (symbol-name)  (defmethod find-function-locations (symbol-name)
688    "Return a list of source-locations for SYMBOL-NAME's functions."    "Return a list of source-locations for SYMBOL-NAME's functions."
689    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
690      (cond ((not foundp)      (cond ((not foundp)
# Line 807  The result has the format \"(...)\"." Line 821  The result has the format \"(...)\"."
821  (defmethod macroexpand-all (form)  (defmethod macroexpand-all (form)
822    (walker:macroexpand-all form))    (walker:macroexpand-all form))
823    
824  (defun tracedp (fname)  (in-package :c)
825    (gethash (debug::trace-fdefinition fname)  
826             debug::*traced-functions*))  (defun swank::expand-ir1-top-level (form)
827      "A scaled down version of the first pass of the compiler."
828  (defslimefun toggle-trace-fdefinition (fname-string)    (with-compilation-unit ()
829    (let ((fname (from-string fname-string)))      (let* ((*lexical-environment*
830      (cond ((tracedp fname)              (make-lexenv :default (make-null-environment)
831             (debug::untrace-1 fname)                           :cookie *default-cookie*
832             (format nil "~S is now untraced." fname))                           :interface-cookie *default-interface-cookie*))
833            (t             (*source-info* (make-lisp-source-info form))
834             (debug::trace-1 fname (debug::make-trace-info))             (*block-compile* nil)
835             (format nil "~S is now traced." fname)))))             (*block-compile-default* nil))
836          (with-ir1-namespace
837              (clear-stuff)
838            (find-source-paths form 0)
839            (ir1-top-level form '(0) t)))))
840    
841    (in-package :swank)
842    
843    (defslimefun print-ir1-converted-blocks (form)
844      (with-output-to-string (*standard-output*)
845        (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
846    
847  (defslimefun set-default-directory (directory)  (defslimefun set-default-directory (directory)
848    (setf (ext:default-directory) (namestring directory))    (setf (ext:default-directory) (namestring directory))
# Line 827  The result has the format \"(...)\"." Line 851  The result has the format \"(...)\"."
851    (setf *default-pathname-defaults* (pathname (ext:default-directory)))    (setf *default-pathname-defaults* (pathname (ext:default-directory)))
852    (namestring (ext:default-directory)))    (namestring (ext:default-directory)))
853    
854    ;;; source-path-{stream,file,string,etc}-position moved into
855  ;;;; 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))))))  
856    
857  (defun code-location-stream-position (code-location stream)  (defun code-location-stream-position (code-location stream)
858    "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 952  format suitable for Emacs."
952          collect (list (princ-to-string (restart-name restart))          collect (list (princ-to-string (restart-name restart))
953                        (princ-to-string restart))))                        (princ-to-string restart))))
954    
 (defun format-condition-for-emacs ()  
   (format nil "~A~%   [Condition of type ~S]"  
           (debug::safe-condition-message *swank-debugger-condition*)  
           (type-of *swank-debugger-condition*)))  
   
955  (defun nth-frame (index)  (defun nth-frame (index)
956    (do ((frame *sldb-stack-top* (di:frame-down frame))    (do ((frame *sldb-stack-top* (di:frame-down frame))
957         (i index (1- i)))         (i index (1- i)))
# Line 1041  format suitable for Emacs." Line 960  format suitable for Emacs."
960  (defun nth-restart (index)  (defun nth-restart (index)
961    (nth index *sldb-restarts*))    (nth index *sldb-restarts*))
962    
963  (defun format-frame-for-emacs (frame)  (defun format-frame-for-emacs (number frame)
964    (list (di:frame-number frame)    (print-with-frame-label
965          (with-output-to-string (*standard-output*)     number (lambda (*standard-output*)
966            (let ((*print-pretty* *sldb-pprint-frames*))              (debug::print-frame-call frame :verbosity 1 :number nil))))
             (debug::print-frame-call frame :verbosity 1 :number t)))))  
967    
968  (defun compute-backtrace (start end)  (defun compute-backtrace (start end)
969    "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 973  stack."
973      (loop for f = (nth-frame start) then (di:frame-down f)      (loop for f = (nth-frame start) then (di:frame-down f)
974            for i from start below end            for i from start below end
975            while f            while f
976            collect f)))            collect (cons i f))))
977    
978  (defmethod backtrace (start end)  (defmethod backtrace (start end)
979    (mapcar #'format-frame-for-emacs (compute-backtrace start end)))    (loop for (n . frame) in (compute-backtrace start end)
980            collect (list n (format-frame-for-emacs n frame))))
981    
982  (defmethod debugger-info-for-emacs (start end)  (defmethod debugger-info-for-emacs (start end)
983    (list (format-condition-for-emacs)    (list (debugger-condition-for-emacs)
984          (format-restarts-for-emacs)          (format-restarts-for-emacs)
985          (backtrace start end)))          (backtrace start end)))
986    
# Line 1085  stack." Line 1004  stack."
1004           (location (di:frame-code-location frame))           (location (di:frame-code-location frame))
1005           (debug-function (di:frame-debug-function frame))           (debug-function (di:frame-debug-function frame))
1006           (debug-variables (di::debug-function-debug-variables debug-function)))           (debug-variables (di::debug-function-debug-variables debug-function)))
1007      (loop for v across debug-variables      (loop for v across debug-variables collect
1008            collect (list            (list :name (to-string (di:debug-variable-symbol v))
1009                     :symbol (di:debug-variable-symbol v)                  :id (di:debug-variable-id v)
1010                     :id (di:debug-variable-id v)                  :value-string (ecase (di:debug-variable-validity v location)
1011                     :value-string                                  (:valid
1012                     (if (eq (di:debug-variable-validity v location)                                   (to-string (di:debug-variable-value v frame)))
1013                             :valid)                                  ((:invalid :unknown)
1014                         (to-string (di:debug-variable-value v frame))                                   "<not-available>"))))))
                        "<not-available>")))))  
1015    
1016  (defmethod frame-catch-tags (index)  (defmethod frame-catch-tags (index)
1017    (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 1023  stack."
1023  (defslimefun sldb-abort ()  (defslimefun sldb-abort ()
1024    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1025    
1026    (defun set-step-breakpoints (frame)
1027      (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1028                                         (di:frame-code-location frame)))
1029        (error "Cannot step, in elsewhere code~%"))
1030      (let* ((code-location (di:frame-code-location frame))
1031             (debug::*bad-code-location-types*
1032              (remove :call-site debug::*bad-code-location-types*))
1033             (next (debug::next-code-locations code-location)))
1034        (cond (next
1035               (let ((steppoints '()))
1036                 (flet ((hook (frame breakpoint)
1037                          (let ((debug:*stack-top-hint* frame))
1038                            (mapc #'di:delete-breakpoint steppoints)
1039                            (let ((cl (di::breakpoint-what breakpoint)))
1040                              (break "Breakpoint: ~S ~S"
1041                                     (di:code-location-kind cl)
1042                                     (di::compiled-code-location-pc cl))))))
1043                   (dolist (code-location next)
1044                     (let ((bp (di:make-breakpoint #'hook code-location
1045                                                   :kind :code-location)))
1046                       (di:activate-breakpoint bp)
1047                       (push bp steppoints))))))
1048             (t
1049              (flet ((hook (frame breakpoint values cookie)
1050                       (declare (ignore cookie))
1051                       (di:delete-breakpoint breakpoint)
1052                       (let ((debug:*stack-top-hint* frame))
1053                         (break "Function-end: ~A ~A" breakpoint values))))
1054                (let* ((debug-function (di:frame-debug-function frame))
1055                       (bp (di:make-breakpoint #'hook debug-function
1056                                               :kind :function-end)))
1057                  (di:activate-breakpoint bp)))))))
1058    
1059    (defslimefun sldb-step (frame)
1060      (cond ((find-restart 'continue *swank-debugger-condition*)
1061             (set-step-breakpoints (nth-frame frame))
1062             (continue *swank-debugger-condition*))
1063            (t
1064             (error "Cannot continue in from condition: ~A"
1065                    *swank-debugger-condition*))))
1066    
1067    (defslimefun sldb-disassemble (frame-number)
1068      "Return a string with the disassembly of frames code."
1069      ;; this could need some refactoring.
1070      (let* ((frame (nth-frame frame-number))
1071             (real-frame (di::frame-real-frame frame))
1072             (frame-pointer (di::frame-pointer real-frame))
1073             (debug-fun (di:frame-debug-function real-frame)))
1074        (with-output-to-string (*standard-output*)
1075          (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
1076                  frame (eq frame real-frame) real-frame frame-pointer)
1077          (etypecase debug-fun
1078            (di::compiled-debug-function
1079             (let* ((code-loc (di:frame-code-location frame))
1080                    (component (di::compiled-debug-function-component debug-fun))
1081                    (pc (di::compiled-code-location-pc code-loc))
1082                    (ip (sys:sap-int
1083                         (sys:sap+ (kernel:code-instructions component) pc)))
1084                    (kind (if (di:code-location-unknown-p code-loc)
1085                              :unkown
1086                              (di:code-location-kind code-loc)))
1087                    (fun (di:debug-function-function debug-fun)))
1088               (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
1089                       ip pc kind)
1090               (if fun
1091                   (disassemble fun)
1092                   (disassem:disassemble-code-component component))))
1093            (di::bogus-debug-function
1094             (format t "~%[Disassembling bogus frames not implemented]"))))))
1095    
1096  ;;;; Inspecting  ;;;; Inspecting
1097    
# Line 1304  nil if there's no second element." Line 1291  nil if there's no second element."
1291            `(("Name" . ,(kernel:fdefn-name o))            `(("Name" . ,(kernel:fdefn-name o))
1292              ("Function" . ,(kernel:fdefn-function o)))))              ("Function" . ,(kernel:fdefn-function o)))))
1293    
1294    
1295    ;;;; Multiprocessing
1296    
1297    #+MP
1298    (progn
1299      (defvar *I/O-lock*          (mp:make-lock "SWANK I/O lock"))
1300      (defvar *conversation-lock* (mp:make-lock "SWANK conversation lock"))
1301    
1302      (defvar *known-processes* '()         ; FIXME: leakage. -luke
1303        "List of processes that have been assigned IDs.
1304         The ID is the position in the list.")
1305    
1306      (defmethod startup-multiprocessing ()
1307        (mp::startup-idle-and-top-level-loops))
1308    
1309      (defmethod thread-id ()
1310        (mp:without-scheduling
1311         (or (find-thread-id)
1312             (prog1 (length *known-processes*)
1313               (setq *known-processes*
1314                     (append *known-processes* (list (mp:current-process))))))))
1315    
1316      (defun find-thread-id (&optional (process (mp:current-process)))
1317        (position process *known-processes*))
1318    
1319      (defun lookup-thread (thread-id)
1320        (or (nth thread-id *known-processes*)
1321            (error "Unknown Thread-ID: ~S" thread-id)))
1322    
1323      (defmethod thread-name (thread-id)
1324        (mp:process-name (lookup-thread thread-id)))
1325    
1326      (defmethod call-with-I/O-lock (function)
1327        (mp:with-lock-held (*I/O-lock*)
1328          (funcall function)))
1329    
1330      (defmethod call-with-conversation-lock (function)
1331        (mp:with-lock-held (*conversation-lock*)
1332          (funcall function)))
1333    
1334      (defmethod wait-goahead ()
1335        (mp:disable-process (mp:current-process))
1336        (mp:process-yield))
1337    
1338      (defmethod give-goahead (thread-id)
1339        (mp:enable-process (lookup-thread thread-id))))
1340    
1341    
1342    ;;;; Epilogue
1343  ;;; Local Variables:  ;;; Local Variables:
1344  ;;; 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))))
1345  ;;; End:  ;;; End:

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

  ViewVC Help
Powered by ViewVC 1.1.5