From a026e03b8b4676c2bad66748a3b76ff9906d7aca Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Wed, 22 Aug 1990 18:03:56 +0000 Subject: [PATCH] Support for stack parsing now that the old-cont/return-pc aren't always on the stack. We must use the debug-info to find them if the frame is escaped. For the current function (in TOP-FRAME), we use the new %CALLER-FRAME-AND-PC primitive. --- code/debug-int.lisp | 134 +++++++++++++++++++++++++++----------------- 1 file changed, 84 insertions(+), 50 deletions(-) diff --git a/code/debug-int.lisp b/code/debug-int.lisp index c58b1f848..0e02c090d 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -731,32 +731,69 @@ (defsetf stack-ref %set-stack-ref) +;;; FRAME-REAL-FRAME -- Internal +;;; +;;; If an interpreted frame, return the real frame, otherwise frame. +;;; +(defun frame-real-frame (frame) + (etypecase frame + (compiled-frame frame) + (interpreted-frame (interpreted-frame-real-frame frame)))) + ;;; TOP-FRAME -- Public. ;;; (defun top-frame () "Returns the top frame of the control stack as it was before calling this function." - (possibly-an-interpreted-frame - (compute-calling-frame (system:%primitive current-fp) nil) - nil)) + (multiple-value-bind (fp pc) + (kernel:%caller-frame-and-pc) + (possibly-an-interpreted-frame + (compute-calling-frame fp pc nil) + nil))) + + +;;; GET-CONTEXT-VALUE -- Internal +;;; +;;; Get the old FP or return PC out of Frame. Stack-Slot is offset the +;;; standard save location on the stack. Loc the the saved SC-Offset +;;; describing the main location. +;;; +(defun get-context-value (frame stack-slot loc) + (declare (type compiled-frame frame) (type unsigned-byte stack-slot) + (type c::sc-offset loc)) + (let ((pointer (frame-pointer frame)) + (escaped (compiled-frame-escaped frame))) + (if escaped + (sub-access-debug-var-slot pointer loc escaped) + (stack-ref pointer stack-slot)))) + ;;; FRAME-DOWN -- Public. ;;; +;;; We have to access the old-fp and return-pc out of Frame and pass them to +;;; COMPUTE-CALLING-FRAME. +;;; (defun frame-down (frame) "Returns the frame immediately below frame on the stack. When frame is the bottom of the stack, this returns nil." (let ((down (frame-%down frame))) (if (eq down :unparsed) - (setf (frame-%down frame) - (possibly-an-interpreted-frame - (etypecase frame - (compiled-frame - (compute-calling-frame (frame-pointer frame) frame)) - (interpreted-frame - (compute-calling-frame - (frame-pointer (interpreted-frame-real-frame frame)) - frame))) - frame)) + (let* ((real (frame-real-frame frame)) + (c-d-f (compiled-debug-function-compiler-debug-fun + (frame-debug-function real)))) + (setf (frame-%down frame) + (possibly-an-interpreted-frame + (compute-calling-frame + (get-context-value + frame + c::old-fp-save-offset + (c::compiled-debug-function-old-fp c-d-f)) + (get-context-value + frame + c::return-pc-save-offset + (c::compiled-debug-function-return-pc c-d-f)) + frame) + frame))) down))) (defvar *debugging-interpreter* nil @@ -818,34 +855,32 @@ ;;; want, and the current frame contains the pc at which we will continue ;;; executing upon returning to that previous frame. ;;; -(defun compute-calling-frame (current-fp up-frame) - (let ((caller (stack-ref current-fp c::old-fp-save-offset))) - (unless (cstack-pointer-valid-p caller) - (return-from compute-calling-frame nil)) - (multiple-value-bind (env env-fp escaped) - (fp-env caller current-fp) - (if escaped - ;; If env-fp is escaped, then caller is the escape frame. - (multiple-value-bind - (env pc) - (pc-offset (escape-register caller c::return-pc-offset) - env up-frame) - (let ((d-fun (debug-function-from-pc env pc))) - (make-compiled-frame env-fp up-frame d-fun - (code-location-from-pc d-fun pc escaped) - (if up-frame (1+ (frame-number up-frame)) 0) - escaped))) - (multiple-value-bind - (env pc) - (pc-offset (stack-ref current-fp c::return-pc-save-offset) - env up-frame) - (let ((d-fun (debug-function-from-pc env pc))) - ;; env-fp = caller. - (make-compiled-frame env-fp up-frame d-fun - (code-location-from-pc d-fun pc escaped) - (if up-frame - (1+ (frame-number up-frame)) - 0)))))))) +(defun compute-calling-frame (caller caller-pc up-frame) + (unless (cstack-pointer-valid-p caller) + (return-from compute-calling-frame nil)) + (multiple-value-bind (env env-fp escaped) + (fp-env caller caller-pc) + (if escaped + ;; If env-fp is escaped, then caller is the escape frame. + (multiple-value-bind + (env pc) + (pc-offset (escape-register caller c::return-pc-offset) + env up-frame) + (let ((d-fun (debug-function-from-pc env pc))) + (make-compiled-frame env-fp up-frame d-fun + (code-location-from-pc d-fun pc escaped) + (if up-frame (1+ (frame-number up-frame)) 0) + escaped))) + (multiple-value-bind + (env pc) + (pc-offset caller-pc env up-frame) + (let ((d-fun (debug-function-from-pc env pc))) + ;; env-fp = caller. + (make-compiled-frame env-fp up-frame d-fun + (code-location-from-pc d-fun pc escaped) + (if up-frame + (1+ (frame-number up-frame)) + 0))))))) ;;; PC-OFFSET -- Internal. ;;; @@ -922,14 +957,13 @@ ;;; fp referenced an escape. If fp is an escape frame, then we return fp as ;;; the last value for convenience in accessing data saved in the escape frame. ;;; -(defun fp-env (fp current-fp) +(defun fp-env (fp caller-pc) (let ((env (stack-ref fp c::env-save-offset))) (if (and (eql env 0) - ;; If env is zero indicating an escape frame, then its return-pc - ;; must point into an assembler routine for interrupts. - (= (system:%primitive get-type - (stack-ref current-fp - c::return-pc-save-offset)) + ;; If env is zero, then see if it is really an escape frame by + ;; checking whether its pc points into an assembler routine for + ;; interrupts. + (= (system:%primitive get-type caller-pc) system:%assembler-code-type)) ;; Get the env of the interrupted frame. (let ((env (escape-register fp c::env-offset))) @@ -2142,12 +2176,12 @@ (let ((escaped (compiled-frame-escaped frame))) (if escaped (sub-set-debug-var-slot (frame-pointer frame) - (debug-variable-sc-offset debug-var) + (compiled-debug-variable-sc-offset debug-var) value escaped) (sub-set-debug-var-slot (frame-pointer frame) - (or (debug-variable-save-sc-offset debug-var) - (debug-variable-sc-offset debug-var)) + (or (compiled-debug-variable-save-sc-offset debug-var) + (compiled-debug-variable-sc-offset debug-var)) value)))) ;;; SUB-SET-DEBUG-VAR-SLOT -- Internal. -- GitLab