From 8b8c6dfd0992b4c9fce066ab1307b11afac2d992 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 23 Apr 1990 16:19:08 +0000 Subject: [PATCH] CONT -> FP Also, merged in some new stuff from Bill. Variable access now understands indirect value cells, and d-f-arguments won't choke on the OPTIONAL-ARGS marker when it appears (tho it still won't mark optionals.) --- code/debug-int.lisp | 74 ++++++++++++++++++++++++++++++--------------- 1 file changed, 50 insertions(+), 24 deletions(-) diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 1cd088d14..963bce790 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -587,7 +587,7 @@ (defun top-frame () "Returns the top frame of the control stack as it was before calling this function." - (compute-calling-frame (system:%primitive current-cont) nil)) + (compute-calling-frame (system:%primitive current-fp) nil)) (defun frame-down (frame) "Returns the frame immediately below frame on the stack. When frame is @@ -611,7 +611,7 @@ ;;; executing upon returning to that previous frame. ;;; (defun compute-calling-frame (current-fp up-frame) - (let ((caller (stack-ref current-fp c::old-cont-save-offset))) + (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) @@ -737,7 +737,7 @@ (values env ;; This is valid since the escape frame must be ;; preceded by some frame. - (stack-ref fp c::old-cont-save-offset) + (stack-ref fp c::old-fp-save-offset) fp)) (t (error "Escaping frame ENV invalid?")))) @@ -764,7 +764,7 @@ (values env ;; This is valid since the escape frame must be ;; preceded by some frame. - (stack-ref fp c::old-cont-save-offset) + (stack-ref fp c::old-fp-save-offset) fp)) (t (error "Escaping frame ENV invalid?")))) @@ -858,7 +858,7 @@ (fp (frame-pointer frame))) (loop (when (eql catch 0) (return (nreverse res))) - (when (eq fp (stack-ref catch system:%unwind-block-current-cont)) + (when (eq fp (stack-ref catch system:%unwind-block-current-fp)) (push (cons (stack-ref catch system:%catch-block-tag) (make-code-location (- (stack-ref catch system:%unwind-block-entry-pc) @@ -1161,6 +1161,10 @@ (c::deleted ;; Deleted required arg at beginning of args array. (push :deleted res)) + (c::optional-args + ;; When I fill this in, I can remove the (typep last 'cons) + ;; below. + ) (c::supplied-p ;; supplied-p var immediately following keyword or optional. ;; Stick the extra var in the result element representing @@ -1683,16 +1687,25 @@ (defun debug-variable-value (debug-var frame) "Returns the value stored for debug-variable in frame. The value may be invalid." + (let ((res (access-debug-var-slot debug-var frame))) + (if (indirect-value-cell-p res) + (system:%primitive header-ref res + system:%function-value-cell-value-slot) + res))) + +(defun access-debug-var-slot (debug-var frame) (let ((escaped (frame-escaped frame))) (if escaped - (sub-debug-var-value (frame-pointer frame) - (debug-variable-sc-offset debug-var) - escaped) - (sub-debug-var-value (frame-pointer frame) - (or (debug-variable-save-sc-offset debug-var) - (debug-variable-sc-offset debug-var)))))) - -(defun sub-debug-var-value (fp sc-offset &optional escaped) + (sub-access-debug-var-slot + (frame-pointer frame) + (debug-variable-sc-offset debug-var) + escaped) + (sub-access-debug-var-slot + (frame-pointer frame) + (or (debug-variable-save-sc-offset debug-var) + (debug-variable-sc-offset debug-var)))))) + +(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (ecase (c::sc-offset-scn sc-offset) ((0 1) ;; Any register or descriptor register. (if escaped @@ -1712,18 +1725,27 @@ (code-char (stack-ref fp (c::sc-offset-offset sc-offset)))))) (defun %set-debug-variable-value (debug-var frame value) + (let ((current-value (access-debug-var-slot debug-var frame))) + (if (indirect-value-cell-p current-value) + (system:%primitive header-set current-value + system:%function-value-cell-value-slot + value) + (set-debug-variable-slot debug-var frame value)))) + +(defun set-debug-variable-slot (debug-var frame value) (let ((escaped (frame-escaped frame))) (if escaped - (sub-%set-debug-var-value (frame-pointer frame) - (debug-variable-sc-offset debug-var) - value - escaped) - (sub-%set-debug-var-value (frame-pointer frame) - (or (debug-variable-save-sc-offset debug-var) - (debug-variable-sc-offset debug-var)) - value)))) -;;; -(defun sub-%set-debug-var-value (fp sc-offset value &optional escaped) + (sub-set-debug-var-slot (frame-pointer frame) + (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)) + value)))) + +(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (ecase (c::sc-offset-scn sc-offset) ((0 1) ;; Any register or descriptor register. (if escaped @@ -1745,9 +1767,13 @@ (5 ;; String-chars on the stack (w/o tag bits). (setf (stack-ref fp (c::sc-offset-offset sc-offset)) (char-code value))))) -;;; (defsetf debug-variable-value %set-debug-variable-value) +(defun indirect-value-cell-p (x) + (and (functionp x) + (eql (system:%primitive get-vector-subtype x) + system:%function-value-cell-subtype))) + ;;; DEBUG-VARIABLE-VALIDITY -- Public. ;;; -- GitLab