/[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.40 by heller, Fri Dec 12 22:52:02 2003 UTC
# Line 26  Line 26 
26           (address (car (ext:host-entry-addr-list hostent))))           (address (car (ext:host-entry-addr-list hostent))))
27      (ext:htonl address)))      (ext:htonl address)))
28    
29    (defvar *start-swank-in-background* t)
30    (defvar *close-swank-socket-after-setup* t)
31    (defvar *use-dedicated-output-stream* t)
32    
33  (defun create-swank-server (port &key (reuse-address t)  (defun create-swank-server (port &key (reuse-address t)
34                              (address "localhost"))                              (address "localhost")
35                                (announce #'simple-announce-function)
36                                (background *start-swank-in-background*)
37                                (close *close-swank-socket-after-setup*))
38    "Create a SWANK TCP server."    "Create a SWANK TCP server."
39    (let* ((ip (resolve-hostname address))    (let* ((ip (resolve-hostname address))
40           (fd (ext:create-inet-listener port :stream           (fd (ext:create-inet-listener port :stream
41                                         :reuse-address reuse-address                                         :reuse-address reuse-address
42                                         :host ip)))                                         :host ip)))
43      (system:add-fd-handler fd :input #'accept-connection)      (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd)))
44      (nth-value 1 (ext::get-socket-host-and-port fd))))      (accept-loop fd background close)))
45    
46    (defun emacs-io (fd)
47      "Create a new fd-stream for fd."
48      (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
49    
50    (defun add-input-handler (fd fn)
51      (system:add-fd-handler fd :input fn))
52    
53    (defun accept-loop (fd background close)
54      "Accept clients on the the server socket FD.
55    Use fd-handlers if BACKGROUND is non-nil.  Close the server socket after the first client if CLOSE is non-nil, "
56      (cond (background
57             (add-input-handler
58              fd (lambda (fd) (accept-one-client fd background close))))
59            (close
60             (accept-one-client fd background close))
61            (t
62             (loop (accept-one-client fd background close)))))
63    
64  (defun accept-connection (socket)  (defun accept-one-client (socket background close)
65    "Accept one Swank TCP connection on SOCKET and then close it."    (let ((fd (ext:accept-tcp-connection socket)))
66    (setup-request-handler (ext:accept-tcp-connection socket))      (when close
67    (sys:invalidate-descriptor socket)        (sys:invalidate-descriptor socket)
68    (unix:unix-close socket))        (unix:unix-close socket))
69        (request-loop fd background)))
70    
71    (defun request-loop (fd background)
72      "Process all request from the socket FD."
73      (let* ((stream (emacs-io fd))
74             (out (if *use-dedicated-output-stream*
75                      (open-stream-to-emacs stream)
76                      (make-slime-output-stream)))
77             (in (make-slime-input-stream))
78             (io (make-two-way-stream in out)))
79        (cond (background
80               (add-input-handler
81                fd (lambda (fd)
82                     (declare (ignore fd))
83                     (serve-one-request stream out in io))))
84              (t (do () ((serve-one-request stream out in io)))))))
85    
86    (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
87      "Read and process one request from a SWANK client.
88    The request is read from the socket as a sexp and then evaluated.
89    Return non-nil iff a reader-error occured."
90      (catch 'slime-toplevel
91        (with-simple-restart (abort "Return to Slime toplevel.")
92          (handler-case (read-from-emacs)
93            (slime-read-error (e)
94              (when *swank-debug-p*
95                (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
96              (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
97              (close *emacs-io*)
98              (return-from serve-one-request t)))))
99      nil)
100    
101  (defun open-stream-to-emacs ()  (defun open-stream-to-emacs (*emacs-io*)
102    "Return an output-stream to Emacs' output buffer."    "Return an output-stream to Emacs' output buffer."
103    (let* ((ip (resolve-hostname "localhost"))    (let* ((ip (resolve-hostname "localhost"))
104           (listener (ext:create-inet-listener 0 :stream :host ip))           (listener (ext:create-inet-listener 0 :stream :host ip))
# Line 54  Line 110 
110               (sys:make-fd-stream fd :output t)))               (sys:make-fd-stream fd :output t)))
111        (ext:close-socket listener))))        (ext:close-socket listener))))
112    
 (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))  
   
113    
114  ;;;; Stream handling  ;;;; Stream handling
115    
# Line 277  the error-context redundant." Line 303  the error-context redundant."
303           (make-location (list :file (namestring *compile-file-truename*))           (make-location (list :file (namestring *compile-file-truename*))
304                          (list :position 0)))                          (list :position 0)))
305          (*compile-filename*          (*compile-filename*
306             ;; XXX is this _ever_ used?  By what?  *compile-file-truename*
307             ;; should be set by the implementation inside any call to compile-file
308           (make-location (list :file *compile-filename*) (list :position 0)))           (make-location (list :file *compile-filename*) (list :position 0)))
309          (t          (t
310           (list :error "No error location available"))))           (list :error "No error location available"))))
311    
312  (defmacro with-compilation-hooks (() &body body)  (defmethod call-with-compilation-hooks (function)
313    "Execute BODY and record the set of compiler notes."    (let ((*previous-compiler-condition* nil)
314    `(let ((*previous-compiler-condition* nil)          (*previous-context* nil)
315           (*previous-context* nil)          (*print-readably* nil))
          (*print-readably* nil))  
316      (handler-bind ((c::compiler-error #'handle-notification-condition)      (handler-bind ((c::compiler-error #'handle-notification-condition)
317                     (c::style-warning  #'handle-notification-condition)                     (c::style-warning  #'handle-notification-condition)
318                     (c::warning        #'handle-notification-condition))                     (c::warning        #'handle-notification-condition))
319        ,@body)))        (funcall function))))
320    
321  (defmethod compile-file-for-emacs (filename load-p)  (defmethod compile-file-for-emacs (filename load-p)
322    (clear-xref-info filename)    (clear-xref-info filename)
323    (with-compilation-hooks ()    (with-compilation-hooks ()
324      (let ((*buffer-name* nil)      (let ((*buffer-name* nil)
325            (*compile-filename* filename))            (*compile-filename* filename))
326          (compile-file filename :load load-p))))        (multiple-value-bind (fasl-file warnings-p failure-p)
327              (compile-file filename)
328            (declare (ignore warnings-p))
329            (when (and load-p (not failure-p))
330              (load fasl-file))))))
331    
332  (defmethod compile-string-for-emacs (string &key buffer position)  (defmethod compile-string-for-emacs (string &key buffer position)
333    (with-compilation-hooks ()    (with-compilation-hooks ()
# Line 553  the code omponent CODE." Line 584  the code omponent CODE."
584    
585  ;;;; Definitions  ;;;; Definitions
586    
587  (defvar *debug-definition-finding* t  (defvar *debug-definition-finding* nil
588    "When true don't handle errors while looking for definitions.    "When true don't handle errors while looking for definitions.
589  This is useful when debugging the definition-finding code.")  This is useful when debugging the definition-finding code.")
590    
# Line 670  The second return value is the condition Line 701  The second return value is the condition
701    (destructuring-bind (first) (function-source-locations function)    (destructuring-bind (first) (function-source-locations function)
702      first))      first))
703    
704  (defslimefun find-function-locations (symbol-name)  (defmethod find-function-locations (symbol-name)
705    "Return a list of source-locations for SYMBOL-NAME's functions."    "Return a list of source-locations for SYMBOL-NAME's functions."
706    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
707      (cond ((not foundp)      (cond ((not foundp)
# Line 807  The result has the format \"(...)\"." Line 838  The result has the format \"(...)\"."
838  (defmethod macroexpand-all (form)  (defmethod macroexpand-all (form)
839    (walker:macroexpand-all form))    (walker:macroexpand-all form))
840    
841    (in-package :c)
842    
843    (defun swank::expand-ir1-top-level (form)
844      "A scaled down version of the first pass of the compiler."
845      (with-compilation-unit ()
846        (let* ((*lexical-environment*
847                (make-lexenv :default (make-null-environment)
848                             :cookie *default-cookie*
849                             :interface-cookie *default-interface-cookie*))
850               (*source-info* (make-lisp-source-info form))
851               (*block-compile* nil)
852               (*block-compile-default* nil))
853          (with-ir1-namespace
854              (clear-stuff)
855            (find-source-paths form 0)
856            (ir1-top-level form '(0) t)))))
857    
858    (in-package :swank)
859    
860    (defslimefun print-ir1-converted-blocks (form)
861      (with-output-to-string (*standard-output*)
862        (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
863    
864  (defun tracedp (fname)  (defun tracedp (fname)
865    (gethash (debug::trace-fdefinition fname)    (gethash (debug::trace-fdefinition fname)
866             debug::*traced-functions*))             debug::*traced-functions*))
# Line 827  The result has the format \"(...)\"." Line 881  The result has the format \"(...)\"."
881    (setf *default-pathname-defaults* (pathname (ext:default-directory)))    (setf *default-pathname-defaults* (pathname (ext:default-directory)))
882    (namestring (ext:default-directory)))    (namestring (ext:default-directory)))
883    
884    ;;; source-path-{stream,file,string,etc}-position moved into
885  ;;;; 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))))))  
886    
887  (defun code-location-stream-position (code-location stream)  (defun code-location-stream-position (code-location stream)
888    "Return the byte offset of CODE-LOCATION in STREAM.  Extract the    "Return the byte offset of CODE-LOCATION in STREAM.  Extract the
# Line 1042  format suitable for Emacs." Line 996  format suitable for Emacs."
996    (nth index *sldb-restarts*))    (nth index *sldb-restarts*))
997    
998  (defun format-frame-for-emacs (frame)  (defun format-frame-for-emacs (frame)
999    (list (di:frame-number frame)    (with-output-to-string (*standard-output*)
1000          (with-output-to-string (*standard-output*)      (let ((*print-pretty* *sldb-pprint-frames*))
1001            (let ((*print-pretty* *sldb-pprint-frames*))        (debug::print-frame-call frame :verbosity 1 :number t))))
             (debug::print-frame-call frame :verbosity 1 :number t)))))  
1002    
1003  (defun compute-backtrace (start end)  (defun compute-backtrace (start end)
1004    "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 1008  stack."
1008      (loop for f = (nth-frame start) then (di:frame-down f)      (loop for f = (nth-frame start) then (di:frame-down f)
1009            for i from start below end            for i from start below end
1010            while f            while f
1011            collect f)))            collect (cons i f))))
1012    
1013  (defmethod backtrace (start end)  (defmethod backtrace (start end)
1014    (mapcar #'format-frame-for-emacs (compute-backtrace start end)))    (loop for (n . frame) in (compute-backtrace start end)
1015            collect (list n (format-frame-for-emacs frame))))
1016    
1017  (defmethod debugger-info-for-emacs (start end)  (defmethod debugger-info-for-emacs (start end)
1018    (list (format-condition-for-emacs)    (list (format-condition-for-emacs)
# Line 1086  stack." Line 1040  stack."
1040           (debug-function (di:frame-debug-function frame))           (debug-function (di:frame-debug-function frame))
1041           (debug-variables (di::debug-function-debug-variables debug-function)))           (debug-variables (di::debug-function-debug-variables debug-function)))
1042      (loop for v across debug-variables      (loop for v across debug-variables
1043            collect (list            for symbol = (di:debug-variable-symbol v)
1044                     :symbol (di:debug-variable-symbol v)            for id =  (di:debug-variable-id v)
1045                     :id (di:debug-variable-id v)            for validy = (di:debug-variable-validity v location)
1046              collect (list :symbol symbol :id id
1047                     :value-string                     :value-string
1048                     (if (eq (di:debug-variable-validity v location)                     (ecase validy
1049                             :valid)                       (:valid (to-string (di:debug-variable-value v frame)))
1050                         (to-string (di:debug-variable-value v frame))                       ((:invalid :unknown) "<not-available>"))))))
                        "<not-available>")))))  
1051    
1052  (defmethod frame-catch-tags (index)  (defmethod frame-catch-tags (index)
1053    (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 1059  stack."
1059  (defslimefun sldb-abort ()  (defslimefun sldb-abort ()
1060    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1061    
1062    (defun set-step-breakpoints (frame)
1063      (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1064                                         (di:frame-code-location frame)))
1065        (error "Cannot step, in elsewhere code~%"))
1066      (let* ((code-location (di:frame-code-location frame))
1067             (debug::*bad-code-location-types*
1068              (remove :call-site debug::*bad-code-location-types*))
1069             (next (debug::next-code-locations code-location)))
1070        (cond (next
1071               (let ((steppoints '()))
1072                 (flet ((hook (frame breakpoint)
1073                          (let ((debug:*stack-top-hint* frame))
1074                            (mapc #'di:delete-breakpoint steppoints)
1075                            (let ((cl (di::breakpoint-what breakpoint)))
1076                              (break "Breakpoint: ~S ~S"
1077                                     (di:code-location-kind cl)
1078                                     (di::compiled-code-location-pc cl))))))
1079                   (dolist (code-location next)
1080                     (let ((bp (di:make-breakpoint #'hook code-location
1081                                                   :kind :code-location)))
1082                       (di:activate-breakpoint bp)
1083                       (push bp steppoints))))))
1084             (t
1085              (flet ((hook (frame breakpoint values cookie)
1086                       (declare (ignore cookie))
1087                       (di:delete-breakpoint breakpoint)
1088                       (let ((debug:*stack-top-hint* frame))
1089                         (break "Function-end: ~A ~A" breakpoint values))))
1090                (let* ((debug-function (di:frame-debug-function frame))
1091                       (bp (di:make-breakpoint #'hook debug-function
1092                                               :kind :function-end)))
1093                  (di:activate-breakpoint bp)))))))
1094    
1095    (defslimefun sldb-step (frame)
1096      (cond ((find-restart 'continue *swank-debugger-condition*)
1097             (set-step-breakpoints (nth-frame frame))
1098             (continue *swank-debugger-condition*))
1099            (t
1100             (error "Cannot continue in from condition: ~A"
1101                    *swank-debugger-condition*))))
1102    
1103    (defslimefun sldb-disassemble (frame-number)
1104      "Return a string with the disassembly of frames code."
1105      ;; this could need some refactoring.
1106      (let* ((frame (nth-frame frame-number))
1107             (real-frame (di::frame-real-frame frame))
1108             (frame-pointer (di::frame-pointer real-frame))
1109             (debug-fun (di:frame-debug-function real-frame)))
1110        (with-output-to-string (*standard-output*)
1111          (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
1112                  frame (eq frame real-frame) real-frame frame-pointer)
1113          (etypecase debug-fun
1114            (di::compiled-debug-function
1115             (let* ((code-loc (di:frame-code-location frame))
1116                    (component (di::compiled-debug-function-component debug-fun))
1117                    (pc (di::compiled-code-location-pc code-loc))
1118                    (ip (sys:sap-int
1119                         (sys:sap+ (kernel:code-instructions component) pc)))
1120                    (kind (if (di:code-location-unknown-p code-loc)
1121                              :unkown
1122                              (di:code-location-kind code-loc)))
1123                    (fun (di:debug-function-function debug-fun)))
1124               (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
1125                       ip pc kind)
1126               (if fun
1127                   (disassemble fun)
1128                   (disassem:disassemble-code-component component))))
1129            (di::bogus-debug-function
1130             (format t "~%[Disassembling bogus frames not implemented]"))))))
1131    
1132  ;;;; Inspecting  ;;;; Inspecting
1133    

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

  ViewVC Help
Powered by ViewVC 1.1.5