/[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.39 by dbarlow, Fri Dec 12 03:22:36 2003 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    "Create a SWANK TCP server."    "Create a SWANK TCP server."
33    (let* ((ip (resolve-hostname address))    (let* ((ip (resolve-hostname address))
34           (fd (ext:create-inet-listener port :stream           (fd (ext:create-inet-listener port :stream
35                                         :reuse-address reuse-address                                         :reuse-address reuse-address
36                                         :host ip)))                                         :host ip)))
37      (system:add-fd-handler fd :input #'accept-connection)      (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd)))
38      (nth-value 1 (ext::get-socket-host-and-port fd))))      (accept-connection fd)))
39    
40  (defun accept-connection (socket)  (defun accept-connection (socket)
41    "Accept one Swank TCP connection on SOCKET and then close it."    "Accept one Swank TCP connection on SOCKET and then close it."
42    (setup-request-handler (ext:accept-tcp-connection socket))    (let* ((fd (ext:accept-tcp-connection socket))
43    (sys:invalidate-descriptor socket)           (stream (sys:make-fd-stream fd :input t :output t
44    (unix:unix-close socket))                                       :element-type 'base-char)))
45        (sys:invalidate-descriptor socket)
46        (unix:unix-close socket)
47        (request-loop stream)))
48    
49  (defun open-stream-to-emacs ()  (defun open-stream-to-emacs ()
50    "Return an output-stream to Emacs' output buffer."    "Return an output-stream to Emacs' output buffer."
# Line 56  Line 60 
60    
61  (defvar *use-dedicated-output-stream* t)  (defvar *use-dedicated-output-stream* t)
62    
63  (defun setup-request-handler (socket)  (defun request-loop (*emacs-io*)
64    "Setup request handling for SOCKET."    "Processes requests until the remote Emacs goes away."
65    (let* ((stream (sys:make-fd-stream socket    (unwind-protect
66                                       :input t :output t         (let* ((*slime-output* (if *use-dedicated-output-stream*
67                                       :element-type 'base-char))                                    (open-stream-to-emacs)
68           (input (make-slime-input-stream))                                    (make-slime-output-stream)))
69           (output (if *use-dedicated-output-stream*                (*slime-input* (make-slime-input-stream))
70                       (let ((*emacs-io* stream)) (open-stream-to-emacs))                (*slime-io* (make-two-way-stream *slime-input* *slime-output*)))
71                       (make-slime-output-stream)))           (loop
72           (io (make-two-way-stream input output)))            (catch 'slime-toplevel
73      (system:add-fd-handler socket              (with-simple-restart (abort "Return to Slime toplevel.")
74                             :input (lambda (fd)                (handler-case (read-from-emacs)
75                                      (declare (ignore fd))                  (slime-read-error (e)
76                                      (serve-request stream output input io)))))                    (when *swank-debug-p*
77                        (format *debug-io*
78  (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)                              "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
79    "Read and process a request from a SWANK client.                    (return)))))
80  The request is read from the socket as a sexp and then evaluated."            (sys:scrub-control-stack)))
81    (catch 'slime-toplevel      (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*)
82      (with-simple-restart (abort "Return to Slime toplevel.")      (close *emacs-io*)))
       (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))  
83    
84    
85  ;;;; Stream handling  ;;;; Stream handling
# Line 277  the error-context redundant." Line 274  the error-context redundant."
274           (make-location (list :file (namestring *compile-file-truename*))           (make-location (list :file (namestring *compile-file-truename*))
275                          (list :position 0)))                          (list :position 0)))
276          (*compile-filename*          (*compile-filename*
277             ;; XXX is this _ever_ used?  By what?  *compile-file-truename*
278             ;; should be set by the implementation inside any call to compile-file
279           (make-location (list :file *compile-filename*) (list :position 0)))           (make-location (list :file *compile-filename*) (list :position 0)))
280          (t          (t
281           (list :error "No error location available"))))           (list :error "No error location available"))))
282    
283  (defmacro with-compilation-hooks (() &body body)  (defmethod call-with-compilation-hooks (function)
284    "Execute BODY and record the set of compiler notes."    (let ((*previous-compiler-condition* nil)
285    `(let ((*previous-compiler-condition* nil)          (*previous-context* nil)
286           (*previous-context* nil)          (*print-readably* nil))
          (*print-readably* nil))  
287      (handler-bind ((c::compiler-error #'handle-notification-condition)      (handler-bind ((c::compiler-error #'handle-notification-condition)
288                     (c::style-warning  #'handle-notification-condition)                     (c::style-warning  #'handle-notification-condition)
289                     (c::warning        #'handle-notification-condition))                     (c::warning        #'handle-notification-condition))
290        ,@body)))        (funcall function))))
291    
292  (defmethod compile-file-for-emacs (filename load-p)  (defmethod compile-file-for-emacs (filename load-p)
293    (clear-xref-info filename)    (clear-xref-info filename)
# Line 553  the code omponent CODE." Line 551  the code omponent CODE."
551    
552  ;;;; Definitions  ;;;; Definitions
553    
554  (defvar *debug-definition-finding* t  (defvar *debug-definition-finding* nil
555    "When true don't handle errors while looking for definitions.    "When true don't handle errors while looking for definitions.
556  This is useful when debugging the definition-finding code.")  This is useful when debugging the definition-finding code.")
557    
# Line 670  The second return value is the condition Line 668  The second return value is the condition
668    (destructuring-bind (first) (function-source-locations function)    (destructuring-bind (first) (function-source-locations function)
669      first))      first))
670    
671  (defslimefun find-function-locations (symbol-name)  (defmethod find-function-locations (symbol-name)
672    "Return a list of source-locations for SYMBOL-NAME's functions."    "Return a list of source-locations for SYMBOL-NAME's functions."
673    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
674      (cond ((not foundp)      (cond ((not foundp)
# Line 807  The result has the format \"(...)\"." Line 805  The result has the format \"(...)\"."
805  (defmethod macroexpand-all (form)  (defmethod macroexpand-all (form)
806    (walker:macroexpand-all form))    (walker:macroexpand-all form))
807    
808    (in-package :c)
809    
810    (defun swank::expand-ir1-top-level (form)
811      "A scaled down version of the first pass of the compiler."
812      (with-compilation-unit ()
813        (let* ((*lexical-environment*
814                (make-lexenv :default (make-null-environment)
815                             :cookie *default-cookie*
816                             :interface-cookie *default-interface-cookie*))
817               (*source-info* (make-lisp-source-info form))
818               (*block-compile* nil)
819               (*block-compile-default* nil))
820          (with-ir1-namespace
821              (clear-stuff)
822            (find-source-paths form 0)
823            (ir1-top-level form '(0) t)))))
824    
825    (in-package :swank)
826    
827    (defslimefun print-ir1-converted-blocks (form)
828      (with-output-to-string (*standard-output*)
829        (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
830    
831  (defun tracedp (fname)  (defun tracedp (fname)
832    (gethash (debug::trace-fdefinition fname)    (gethash (debug::trace-fdefinition fname)
833             debug::*traced-functions*))             debug::*traced-functions*))
# Line 827  The result has the format \"(...)\"." Line 848  The result has the format \"(...)\"."
848    (setf *default-pathname-defaults* (pathname (ext:default-directory)))    (setf *default-pathname-defaults* (pathname (ext:default-directory)))
849    (namestring (ext:default-directory)))    (namestring (ext:default-directory)))
850    
851    ;;; source-path-{stream,file,string,etc}-position moved into
852  ;;;; 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))))))  
853    
854  (defun code-location-stream-position (code-location stream)  (defun code-location-stream-position (code-location stream)
855    "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 963  format suitable for Emacs."
963    (nth index *sldb-restarts*))    (nth index *sldb-restarts*))
964    
965  (defun format-frame-for-emacs (frame)  (defun format-frame-for-emacs (frame)
966    (list (di:frame-number frame)    (with-output-to-string (*standard-output*)
967          (with-output-to-string (*standard-output*)      (let ((*print-pretty* *sldb-pprint-frames*))
968            (let ((*print-pretty* *sldb-pprint-frames*))        (debug::print-frame-call frame :verbosity 1 :number t))))
             (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 frame))))
983    
984  (defmethod debugger-info-for-emacs (start end)  (defmethod debugger-info-for-emacs (start end)
985    (list (format-condition-for-emacs)    (list (format-condition-for-emacs)
# Line 1086  stack." Line 1007  stack."
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
1010            collect (list            for symbol = (di:debug-variable-symbol v)
1011                     :symbol (di:debug-variable-symbol v)            for id =  (di:debug-variable-id v)
1012                     :id (di:debug-variable-id v)            for validy = (di:debug-variable-validity v location)
1013              collect (list :symbol symbol :id id
1014                     :value-string                     :value-string
1015                     (if (eq (di:debug-variable-validity v location)                     (ecase validy
1016                             :valid)                       (:valid (to-string (di:debug-variable-value v frame)))
1017                         (to-string (di:debug-variable-value v frame))                       ((:invalid :unknown) "<not-available>"))))))
                        "<not-available>")))))  
1018    
1019  (defmethod frame-catch-tags (index)  (defmethod frame-catch-tags (index)
1020    (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 1026  stack."
1026  (defslimefun sldb-abort ()  (defslimefun sldb-abort ()
1027    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1028    
1029    (defun set-step-breakpoints (frame)
1030      (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1031                                         (di:frame-code-location frame)))
1032        (error "Cannot step, in elsewhere code~%"))
1033      (let* ((code-location (di:frame-code-location frame))
1034             (debug::*bad-code-location-types*
1035              (remove :call-site debug::*bad-code-location-types*))
1036             (next (debug::next-code-locations code-location)))
1037        (cond (next
1038               (let ((steppoints '()))
1039                 (flet ((hook (frame breakpoint)
1040                          (let ((debug:*stack-top-hint* frame))
1041                            (mapc #'di:delete-breakpoint steppoints)
1042                            (let ((cl (di::breakpoint-what breakpoint)))
1043                              (break "Breakpoint: ~S ~S"
1044                                     (di:code-location-kind cl)
1045                                     (di::compiled-code-location-pc cl))))))
1046                   (dolist (code-location next)
1047                     (let ((bp (di:make-breakpoint #'hook code-location
1048                                                   :kind :code-location)))
1049                       (di:activate-breakpoint bp)
1050                       (push bp steppoints))))))
1051             (t
1052              (flet ((hook (frame breakpoint values cookie)
1053                       (declare (ignore cookie))
1054                       (di:delete-breakpoint breakpoint)
1055                       (let ((debug:*stack-top-hint* frame))
1056                         (break "Function-end: ~A ~A" breakpoint values))))
1057                (let* ((debug-function (di:frame-debug-function frame))
1058                       (bp (di:make-breakpoint #'hook debug-function
1059                                               :kind :function-end)))
1060                  (di:activate-breakpoint bp)))))))
1061    
1062    (defslimefun sldb-step (frame)
1063      (cond ((find-restart 'continue *swank-debugger-condition*)
1064             (set-step-breakpoints (nth-frame frame))
1065             (continue *swank-debugger-condition*))
1066            (t
1067             (error "Cannot continue in from condition: ~A"
1068                    *swank-debugger-condition*))))
1069    
1070    (defslimefun sldb-disassemble (frame-number)
1071      "Return a string with the disassembly of frames code."
1072      ;; this could need some refactoring.
1073      (let* ((frame (nth-frame frame-number))
1074             (real-frame (di::frame-real-frame frame))
1075             (frame-pointer (di::frame-pointer real-frame))
1076             (debug-fun (di:frame-debug-function real-frame)))
1077        (with-output-to-string (*standard-output*)
1078          (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
1079                  frame (eq frame real-frame) real-frame frame-pointer)
1080          (etypecase debug-fun
1081            (di::compiled-debug-function
1082             (let* ((code-loc (di:frame-code-location frame))
1083                    (component (di::compiled-debug-function-component debug-fun))
1084                    (pc (di::compiled-code-location-pc code-loc))
1085                    (ip (sys:sap-int
1086                         (sys:sap+ (kernel:code-instructions component) pc)))
1087                    (kind (if (di:code-location-unknown-p code-loc)
1088                              :unkown
1089                              (di:code-location-kind code-loc)))
1090                    (fun (di:debug-function-function debug-fun)))
1091               (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
1092                       ip pc kind)
1093               (if fun
1094                   (disassemble fun)
1095                   (disassem:disassemble-code-component component))))
1096            (di::bogus-debug-function
1097             (format t "~%[Disassembling bogus frames not implemented]"))))))
1098    
1099  ;;;; Inspecting  ;;;; Inspecting
1100    

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

  ViewVC Help
Powered by ViewVC 1.1.5