[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Mon Mar 8 12:21:43 UTC 2010
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv25881
Modified Files:
ChangeLog swank-allegro.lisp
Log Message:
Try to use source-level debugging features in Allegro 8.2
* swank-allegro.lisp (disassemble-frame): Use undocumented
debugger::dyn-fd-analyze to figure out the PC and display it.
(pc-source-location, ldb-code-to-src-loc, longest-common-prefix)
(source-paths-of): New functions.
(frame-source-location): Use pc-source-location. Still far from
optimal since Allegro rarely records source regions and anonymous
functions don't seem to carry source level debug-info at all.
(*temp-file-map*, buffer-or-file-location, find-fspec-location):
Use a table to map temp-file names back to Emacs buffers instead
of putting an eval-when-compile form in the source. The
eval-when-compile form messed up source positions.
(*temp-file-header-end-position*, find-definition-in-buffer):
Deleted.
(compile-from-temp-file): Bind excl:*load-source-debug-info* and
compiler:save-source-level-debug-info-switch so that Allegro
doesn't try to load debug-info from deleted files. Also put
the filename in *temp-file-map*.
--- /project/slime/cvsroot/slime/ChangeLog 2010/03/08 11:57:04 1.2024
+++ /project/slime/cvsroot/slime/ChangeLog 2010/03/08 12:21:43 1.2025
@@ -1,3 +1,25 @@
+2010-03-08 Helmut Eller <heller at common-lisp.net>
+
+ Try to use source-level debugging features in Allegro 8.2
+
+ * swank-allegro.lisp (disassemble-frame): Use undocumented
+ debugger::dyn-fd-analyze to figure out the PC and display it.
+ (pc-source-location, ldb-code-to-src-loc, longest-common-prefix)
+ (source-paths-of): New functions.
+ (frame-source-location): Use pc-source-location. Still far from
+ optimal since Allegro rarely records source regions and anonymous
+ functions don't seem to carry source level debug-info at all.
+ (*temp-file-map*, buffer-or-file-location, find-fspec-location):
+ Use a table to map temp-file names back to Emacs buffers instead
+ of putting an eval-when-compile form in the source. The
+ eval-when-compile form messed up source positions.
+ (*temp-file-header-end-position*, find-definition-in-buffer):
+ Deleted.
+ (compile-from-temp-file): Bind excl:*load-source-debug-info* and
+ compiler:save-source-level-debug-info-switch so that Allegro
+ doesn't try to load debug-info from deleted files. Also put
+ the filename in *temp-file-map*.
+
2010-03-08 Tobias C. Rittweiler <tcr at freebits.de>
* swank.lisp (dispatch-interrupt-event): Take a connection because
--- /project/slime/cvsroot/slime/swank-allegro.lisp 2010/03/07 16:22:17 1.134
+++ /project/slime/cvsroot/slime/swank-allegro.lisp 2010/03/08 12:21:43 1.135
@@ -12,7 +12,12 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sock)
- (require :process))
+ (require :process)
+ #+(version>= 8 2)
+ (require 'lldb)
+ )
+
+;;(declaim (optimize debug))
(import-from :excl *gray-stream-symbols* :swank-backend)
@@ -131,9 +136,10 @@
(funcall debugger-loop-fn)))
(defimplementation sldb-break-at-start (fname)
- ;; :print-before is kind of mis-used but we just want to stuff our break form
- ;; somewhere. This does not work for setf, :before and :after methods, which
- ;; need special syntax in the trace call, see ACL's doc/debugging.htm chapter 10.
+ ;; :print-before is kind of mis-used but we just want to stuff our
+ ;; break form somewhere. This does not work for setf, :before and
+ ;; :after methods, which need special syntax in the trace call, see
+ ;; ACL's doc/debugging.htm chapter 10.
(eval `(trace (,fname
:print-before
((break "Function start breakpoint of ~A" ',fname)))))
@@ -182,13 +188,73 @@
(debugger:frame-var-value frame var)))
(defimplementation disassemble-frame (index)
- (disassemble (debugger:frame-function (nth-frame index))))
+ (let ((frame (nth-frame index)))
+ (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
+ (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
+ (disassemble (debugger:frame-function frame)))))
(defimplementation frame-source-location (index)
- (let* ((frame (nth-frame index))
- (expr (debugger:frame-expression frame))
- (fspec (first expr)))
- (second (first (fspec-definition-locations fspec)))))
+ (let* ((frame (nth-frame index)))
+ (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
+ (declare (ignore x xx xxx))
+ #+(version>= 8 2)
+ (pc-source-location fun pc)
+ #-(version>= 8 2)
+ (function-source-location fun)
+ )))
+
+(defun function-source-location (fun)
+ (cadr (car (fspec-definition-locations fun))))
+
+#+(version>= 8 2)
+(defun pc-source-location (fun pc)
+ (let* ((debug-info (excl::function-source-debug-info fun)))
+ (cond ((not debug-info)
+ (function-source-location fun))
+ (t
+ (let* ((return-loc (find pc debug-info :key #'excl::ldb-code-pc))
+ (prev (and return-loc (excl::ldb-code-prev-rec return-loc)))
+ (call-loc (if (integerp prev)
+ (aref debug-info prev)
+ return-loc)))
+ (cond ((not call-loc)
+ (ldb-code-to-src-loc (aref debug-info 0)))
+ (t
+ (ldb-code-to-src-loc call-loc))))))))
+
+#+(version>= 8 2)
+(defun ldb-code-to-src-loc (code)
+ (let* ((start (excl::ldb-code-start-char code))
+ (func (excl::ldb-code-func code))
+ (loc (buffer-or-file-location (excl:source-file func) (or start 0))))
+ (cond (start loc)
+ (t
+ (let* ((debug-info (excl::function-source-debug-info func))
+ (whole (aref debug-info 0))
+ (paths (source-paths-of (excl::ldb-code-source whole)
+ (excl::ldb-code-source code)))
+ (path (longest-common-prefix paths))
+ (start (excl::ldb-code-start-char whole)))
+ (make-location (location-buffer loc)
+ `(:source-path (0 . ,path) ,start)))))))
+
+(defun longest-common-prefix (sequences)
+ (assert sequences)
+ (flet ((common-prefix (s1 s2)
+ (let ((diff-pos (mismatch s1 s2)))
+ (if diff-pos (subseq s1 0 diff-pos) s1))))
+ (reduce #'common-prefix sequences)))
+
+(defun source-paths-of (whole part)
+ (let ((result '()))
+ (labels ((walk (form path)
+ (cond ((eq form part)
+ (push (reverse path) result))
+ ((consp form)
+ (loop for i from 0 while (consp form) do
+ (walk (pop form) (cons i path)))))))
+ (walk whole '())
+ (reverse result))))
(defimplementation eval-in-frame (form frame-number)
(let ((frame (nth-frame frame-number)))
@@ -228,7 +294,6 @@
(defvar *buffer-start-position*)
(defvar *buffer-string*)
(defvar *compile-filename* nil)
-(defvar *temp-file-header-end-position* nil)
(defun compiler-note-p (object)
(member (type-of object) '(excl::compiler-note compiler::compiler-note)))
@@ -292,8 +357,7 @@
(if (integerp pos)
(if *buffer-name*
(make-location `(:buffer ,*buffer-name*)
- `(:offset ,*buffer-start-position*
- ,(- pos *temp-file-header-end-position* 1)))
+ `(:offset ,*buffer-start-position* ,pos))
(make-location `(:file ,(namestring (truename file)))
`(:position ,pos)))
(make-error-location "No error location available."))))
@@ -345,11 +409,19 @@
(funcall fn file tmpname))
(delete-file tmpname))))
-(defun compile-from-temp-file (header string)
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+ "A mapping from tempfile names to Emacs buffer names.")
+
+(defun compile-from-temp-file (string buffer offset file)
(call-with-temp-file
(lambda (stream filename)
- (write-string header stream)
- (let ((*temp-file-header-end-position* (file-position stream)))
+ (let ((excl:*load-source-file-info* t)
+ (sys:*source-file-types* '(nil)) ; suppress .lisp extension
+ #+(version>= 8 2)
+ (compiler:save-source-level-debug-info-switch t)
+ #+(version>= 8 2)
+ (excl:*load-source-debug-info* t) ; NOTE: requires lldb
+ )
(write-string string stream)
(finish-output stream)
(multiple-value-bind (binary-filename warnings? failure?)
@@ -360,6 +432,8 @@
(compile-file filename :load-after-compile t))
(declare (ignore warnings?))
(when binary-filename
+ (setf (gethash (pathname stream) *temp-file-map*)
+ (list buffer offset file))
(delete-file binary-filename))
(not failure?))))))
@@ -375,26 +449,27 @@
(if filename
(merge-pathnames (pathname filename))
*default-pathname-defaults*)))
- ;; We store the source buffer in excl::*source-pathname* as a
- ;; string of the form <buffername>;<start-offset>. Quite ugly
- ;; encoding, but the fasl file is corrupted if we use some
- ;; other datatype.
- (compile-from-temp-file
- (format nil "~S~%~S~%"
- `(in-package ,(package-name *package*))
- `(eval-when (:compile-toplevel :load-toplevel)
- (setq excl::*source-pathname*
- ',(format nil "~A;~D" buffer position))))
- string)))
+ (compile-from-temp-file string buffer position filename)))
(reader-error () (values nil nil t))))
;;;; Definition Finding
+(defun buffer-or-file-location (file offset)
+ (let* ((probe (gethash file *temp-file-map*)))
+ (cond ((not probe)
+ (make-location `(:file ,(namestring (truename file)))
+ `(:position ,(1+ offset))))
+ (t
+ (destructuring-bind (buffer start file) probe
+ (declare (ignore file))
+ (make-location `(:buffer ,buffer)
+ `(:offset ,start ,offset)))))))
+
(defun fspec-primary-name (fspec)
(etypecase fspec
(symbol fspec)
(list (fspec-primary-name (second fspec)))))
-
+
(defun find-definition-in-file (fspec type file top-level)
(let* ((part
(or (scm::find-definition-in-definition-group
@@ -411,33 +486,33 @@
(list :function-name (string (fspec-primary-name fspec))))))
(make-location (list :file (namestring (truename file)))
pos)))
-
-(defun find-definition-in-buffer (filename)
- (let ((pos (position #\; filename :from-end t)))
- (make-location
- (list :buffer (subseq filename 0 pos))
- (list :offset (parse-integer (subseq filename (1+ pos))) 0))))
(defun find-fspec-location (fspec type file top-level)
(handler-case
(etypecase file
(pathname
- (find-definition-in-file fspec type file top-level))
+ (let ((probe (gethash file *temp-file-map*)))
+ (cond (probe
+ (destructuring-bind (buffer offset file) probe
+ (declare (ignore file))
+ (make-location `(:buffer ,buffer)
+ `(:offset ,offset 0))))
+ (t
+ (find-definition-in-file fspec type file top-level)))))
((member :top-level)
- (make-error-location "Defined at toplevel: ~A" (fspec->string fspec)))
- (string
- (find-definition-in-buffer file)))
+ (make-error-location "Defined at toplevel: ~A" (fspec->string fspec))))
(error (e)
(make-error-location "Error: ~A" e))))
(defun fspec->string (fspec)
- (etypecase fspec
+ (typecase fspec
(symbol (let ((*package* (find-package :keyword)))
(prin1-to-string fspec)))
(list (format nil "(~A ~A)"
(prin1-to-string (first fspec))
(let ((*package* (find-package :keyword)))
- (prin1-to-string (second fspec)))))))
+ (prin1-to-string (second fspec)))))
+ (t (princ-to-string fspec))))
(defun fspec-definition-locations (fspec)
(cond
More information about the slime-cvs
mailing list