Skip to content
Snippets Groups Projects
Commit 8b8c6dfd authored by ram's avatar ram
Browse files

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.)
parent 803c69f3
No related branches found
No related tags found
No related merge requests found
...@@ -587,7 +587,7 @@ ...@@ -587,7 +587,7 @@
(defun top-frame () (defun top-frame ()
"Returns the top frame of the control stack as it was before calling this "Returns the top frame of the control stack as it was before calling this
function." function."
(compute-calling-frame (system:%primitive current-cont) nil)) (compute-calling-frame (system:%primitive current-fp) nil))
(defun frame-down (frame) (defun frame-down (frame)
"Returns the frame immediately below frame on the stack. When frame is "Returns the frame immediately below frame on the stack. When frame is
...@@ -611,7 +611,7 @@ ...@@ -611,7 +611,7 @@
;;; executing upon returning to that previous frame. ;;; executing upon returning to that previous frame.
;;; ;;;
(defun compute-calling-frame (current-fp up-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) (unless (cstack-pointer-valid-p caller)
(return-from compute-calling-frame nil)) (return-from compute-calling-frame nil))
(multiple-value-bind (env env-fp escaped) (multiple-value-bind (env env-fp escaped)
...@@ -737,7 +737,7 @@ ...@@ -737,7 +737,7 @@
(values env (values env
;; This is valid since the escape frame must be ;; This is valid since the escape frame must be
;; preceded by some frame. ;; preceded by some frame.
(stack-ref fp c::old-cont-save-offset) (stack-ref fp c::old-fp-save-offset)
fp)) fp))
(t (t
(error "Escaping frame ENV invalid?")))) (error "Escaping frame ENV invalid?"))))
...@@ -764,7 +764,7 @@ ...@@ -764,7 +764,7 @@
(values env (values env
;; This is valid since the escape frame must be ;; This is valid since the escape frame must be
;; preceded by some frame. ;; preceded by some frame.
(stack-ref fp c::old-cont-save-offset) (stack-ref fp c::old-fp-save-offset)
fp)) fp))
(t (t
(error "Escaping frame ENV invalid?")))) (error "Escaping frame ENV invalid?"))))
...@@ -858,7 +858,7 @@ ...@@ -858,7 +858,7 @@
(fp (frame-pointer frame))) (fp (frame-pointer frame)))
(loop (loop
(when (eql catch 0) (return (nreverse res))) (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) (push (cons (stack-ref catch system:%catch-block-tag)
(make-code-location (make-code-location
(- (stack-ref catch system:%unwind-block-entry-pc) (- (stack-ref catch system:%unwind-block-entry-pc)
...@@ -1161,6 +1161,10 @@ ...@@ -1161,6 +1161,10 @@
(c::deleted (c::deleted
;; Deleted required arg at beginning of args array. ;; Deleted required arg at beginning of args array.
(push :deleted res)) (push :deleted res))
(c::optional-args
;; When I fill this in, I can remove the (typep last 'cons)
;; below.
)
(c::supplied-p (c::supplied-p
;; supplied-p var immediately following keyword or optional. ;; supplied-p var immediately following keyword or optional.
;; Stick the extra var in the result element representing ;; Stick the extra var in the result element representing
...@@ -1683,16 +1687,25 @@ ...@@ -1683,16 +1687,25 @@
(defun debug-variable-value (debug-var frame) (defun debug-variable-value (debug-var frame)
"Returns the value stored for debug-variable in frame. The value may be "Returns the value stored for debug-variable in frame. The value may be
invalid." 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))) (let ((escaped (frame-escaped frame)))
(if escaped (if escaped
(sub-debug-var-value (frame-pointer frame) (sub-access-debug-var-slot
(debug-variable-sc-offset debug-var) (frame-pointer frame)
escaped) (debug-variable-sc-offset debug-var)
(sub-debug-var-value (frame-pointer frame) escaped)
(or (debug-variable-save-sc-offset debug-var) (sub-access-debug-var-slot
(debug-variable-sc-offset debug-var)))))) (frame-pointer frame)
(or (debug-variable-save-sc-offset debug-var)
(defun sub-debug-var-value (fp sc-offset &optional escaped) (debug-variable-sc-offset debug-var))))))
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(ecase (c::sc-offset-scn sc-offset) (ecase (c::sc-offset-scn sc-offset)
((0 1) ;; Any register or descriptor register. ((0 1) ;; Any register or descriptor register.
(if escaped (if escaped
...@@ -1712,18 +1725,27 @@ ...@@ -1712,18 +1725,27 @@
(code-char (stack-ref fp (c::sc-offset-offset sc-offset)))))) (code-char (stack-ref fp (c::sc-offset-offset sc-offset))))))
(defun %set-debug-variable-value (debug-var frame value) (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))) (let ((escaped (frame-escaped frame)))
(if escaped (if escaped
(sub-%set-debug-var-value (frame-pointer frame) (sub-set-debug-var-slot (frame-pointer frame)
(debug-variable-sc-offset debug-var) (debug-variable-sc-offset debug-var)
value value
escaped) escaped)
(sub-%set-debug-var-value (frame-pointer frame) (sub-set-debug-var-slot
(or (debug-variable-save-sc-offset debug-var) (frame-pointer frame)
(debug-variable-sc-offset debug-var)) (or (debug-variable-save-sc-offset debug-var)
value)))) (debug-variable-sc-offset debug-var))
;;; value))))
(defun sub-%set-debug-var-value (fp sc-offset value &optional escaped)
(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
(ecase (c::sc-offset-scn sc-offset) (ecase (c::sc-offset-scn sc-offset)
((0 1) ;; Any register or descriptor register. ((0 1) ;; Any register or descriptor register.
(if escaped (if escaped
...@@ -1745,9 +1767,13 @@ ...@@ -1745,9 +1767,13 @@
(5 ;; String-chars on the stack (w/o tag bits). (5 ;; String-chars on the stack (w/o tag bits).
(setf (stack-ref fp (c::sc-offset-offset sc-offset)) (setf (stack-ref fp (c::sc-offset-offset sc-offset))
(char-code value))))) (char-code value)))))
;;;
(defsetf debug-variable-value %set-debug-variable-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. ;;; DEBUG-VARIABLE-VALIDITY -- Public.
;;; ;;;
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment