branch: externals/sly
commit c41b2980773521af90f8e62a39040b4c0b3f96bb
Author: Chris Schafmeister <meis...@temple.edu>
Commit: João Távora <joaotav...@gmail.com>
clasp.lisp changes to use new clasp-debug pkg
Clasp added a clasp-debug package for debugging.
Here we upgrade clasp.lisp to use it in slynk.
* slynk/backend/clasp.lisp: rework.
Cherry-picked-from: SLIME commit 221518f0d3d224403743e6690f6bb66c42d9dec9
Co-authored-by: João Távora <joaotav...@gmail.com>
---
slynk/backend/clasp.lisp | 147 +++++++++--------------------------------------
1 file changed, 27 insertions(+), 120 deletions(-)
diff --git a/slynk/backend/clasp.lisp b/slynk/backend/clasp.lisp
index f0f8a8b..415f830 100644
--- a/slynk/backend/clasp.lisp
+++ b/slynk/backend/clasp.lisp
@@ -381,25 +381,6 @@
;;; Debugging
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (import
- '(si::*break-env*
- si::*ihs-top*
- si::*ihs-current*
- si::*ihs-base*
-#+frs si::*frs-base*
-#+frs si::*frs-top*
- si::*tpl-commands*
- si::*tpl-level*
-#+frs si::frs-top
- si::ihs-top
- si::ihs-fun
- si::ihs-env
-#+frs si::sch-frs-base
- si::set-break-env
- si::set-current-ihs
- si::tpl-commands)))
-
(defun make-invoke-debugger-hook (hook)
(when hook
#'(lambda (condition old-hook)
@@ -410,14 +391,12 @@
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
- (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))
- )
+ (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
(ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
- (funcall fun))
- )
+ (funcall fun)))
(defvar *backtrace* '())
@@ -455,122 +434,50 @@
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
- (let* ((*ihs-top* 0)
- (*ihs-current* *ihs-top*)
- #+frs (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+
(frs-top))))
- #+frs (*frs-top* (frs-top))
- (*tpl-level* (1+ *tpl-level*)))
- (core:call-with-backtrace
- (lambda (raw-backtrace)
- (let ((*backtrace*
- (let ((backtrace (core::common-lisp-backtrace-frames
- raw-backtrace
- :gather-start-trigger
- (lambda (frame)
- (let ((function-name
(core::backtrace-frame-function-name frame)))
- (and (symbolp function-name)
- (eq function-name
'core::universal-error-handler))))
- :gather-all-frames nil)))
- (unless backtrace
- (setq backtrace (core::common-lisp-backtrace-frames
- :gather-all-frames nil)))
- backtrace)))
- (declare (special *ihs-current*))
- (set-break-env)
- (set-current-ihs)
- (let ((*ihs-base* *ihs-top*))
- (funcall debugger-loop-fn)))))))
+ (clasp-debug:with-stack (stack)
+ (let ((*backtrace* (clasp-debug:list-stack stack)))
+ (funcall debugger-loop-fn))))
(defimplementation compute-backtrace (start end)
(subseq *backtrace* start
(and (numberp end)
(min end (length *backtrace*)))))
-(defun frame-name (frame)
- (let ((x (core::backtrace-frame-function-name frame)))
- (if (symbolp x)
- x
- (function-name x))))
-
-(defun frame-function (frame-number)
- (let ((x (core::backtrace-frame-function-name (elt *backtrace*
frame-number))))
- (etypecase x
- (symbol
- (and (fboundp x)
- (fdefinition x)))
- (cons
- (if (eq (car x) 'cl:setf)
- (fdefinition x)
- nil))
- (function
- x))))
+(defun frame-from-number (frame-number)
+ (elt *backtrace* frame-number))
(defimplementation print-frame (frame stream)
- (if (core::backtrace-frame-arguments frame)
- (format stream "(~a~{ ~s~})" (core::backtrace-frame-print-name frame)
- (coerce (core::backtrace-frame-arguments frame) 'list))
- (format stream "~a" (core::backtrace-frame-print-name frame))))
+ (clasp-debug:prin1-frame-call frame stream))
(defimplementation frame-source-location (frame-number)
- (let* ((address (core::backtrace-frame-return-address (elt *backtrace*
frame-number)))
- (code-source-location (ext::code-source-position address)))
- (format t "address: ~a code-source-location ~s~%" address
code-source-location)
- ;; (core::source-info-backtrace *backtrace*)
- (if (ext::code-source-line-source-pathname code-source-location)
- (make-location (list :file (namestring
(ext::code-source-line-source-pathname code-source-location)))
- (list :line (ext::code-source-line-line-number
code-source-location))
+ (let ((csl (clasp-debug:frame-source-position (frame-from-number
frame-number))))
+ (if (clasp-debug:code-source-line-pathname csl)
+ (make-location (list :file (namestring
(clasp-debug:code-source-line-pathname csl)))
+ (list :line (clasp-debug:code-source-line-line-number
csl))
'(:align t))
`(:error ,(format nil "No source for frame: ~a" frame-number)))))
-#+clasp-working
-(defimplementation frame-catch-tags (frame-number)
- (third (elt *backtrace* frame-number)))
-
-(defun ihs-frame-id (frame-number)
- (- (core:ihs-top) frame-number))
-
(defimplementation frame-locals (frame-number)
- (let* ((frame (elt *backtrace* frame-number))
- (env nil) ; no env yet
- (locals (loop for x = env then (core:get-parent-environment x)
- while x
- nconc (loop for name across
(core:environment-debug-names x)
- for value across
(core:environment-debug-values x)
- collect (list :name name :id 0 :value
value)))))
- (nconc
- (loop for arg across (core::backtrace-frame-arguments frame)
- for i from 0
- collect (list :name (intern (format nil "ARG~d" i) :cl-user)
- :id 0
- :value arg))
- locals)))
+ (loop for (var . value)
+ in (clasp-debug:frame-locals (frame-from-number frame-number))
+ for i from 0
+ collect (list :name var :id i :value value)))
(defimplementation frame-var-value (frame-number var-number)
- (let* ((frame (elt *backtrace* frame-number))
- (env nil)
- (args (core::backtrace-frame-arguments frame)))
- (if (< var-number (length args))
- (svref args var-number)
- (elt (frame-locals frame-number) var-number))))
+ (let* ((frame (frame-from-number frame-number))
+ (locals (clasp-debug:frame-locals frame)))
+ (cdr (nth var-number locals))))
(defimplementation disassemble-frame (frame-number)
- (let ((fun (frame-function frame-number)))
- (disassemble fun)))
+ (clasp-debug:disassemble-frame (frame-from-number frame-number)))
(defimplementation eval-in-frame (form frame-number)
- (let* ((frame (elt *backtrace* frame-number))
- (raw-arg-values (coerce (core::backtrace-frame-arguments frame)
'list)))
- (if (and (= (length raw-arg-values) 2) (core:vaslistp (car
raw-arg-values)))
- (let* ((arg-values (core:list-from-va-list (car raw-arg-values)))
- (bindings (append (loop for i from 0 for value in arg-values
collect `(,(intern (core:bformat nil "ARG%d" i) :cl-user) ',value))
- (list (list (intern "NEXT-METHODS" :cl-user)
(cadr raw-arg-values))))))
- (eval
- `(let (,@bindings) ,form)))
- (let* ((arg-values raw-arg-values)
- (bindings (loop for i from 0 for value in arg-values collect
`(,(intern (core:bformat nil "ARG%d" i) :cl-user) ',value))))
- (eval
- `(let (,@bindings) ,form))))))
-
+ (let* ((frame (frame-from-number frame-number)))
+ (eval
+ `(let (,@(loop for (var . value)
+ in (clasp-debug:frame-locals frame)
+ collect `(,var ',value)))
+ (progn ,form)))))
#+clasp-working
(defimplementation gdb-initial-commands ()
@@ -712,7 +619,7 @@
"STOPPED"))
(defimplementation make-lock (&key name)
- (mp:make-lock :name name))
+ (mp:make-recursive-mutex name))
(defimplementation call-with-lock-held (lock function)
(declare (type function function))
