From 54c1961adb016aa9f56ab124e85b4bdf85768683 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Tue, 4 Nov 1997 15:02:02 +0000
Subject: [PATCH] Add a check that objects obtained from the stack in
 sub-access-debug-var-slot (x86) are valid.  Debug variable locations are not
 always valid, and on the x86 there can be non-descriptor objects on the
 stack.

Cleanup the sap-ref code in sub-access-debug-var-slot and
sub-set-debug-var-slot which had been using convoluted code to work
around sap-ref bugs that have since been fixed.
---
 code/debug-int.lisp | 123 ++++++++++++++++++++++----------------------
 1 file changed, 61 insertions(+), 62 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index fe5d50f3c..f1ca8fdb0 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.72 1997/11/04 09:10:41 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.73 1997/11/04 15:02:02 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -14,6 +14,7 @@
 ;;;
 ;;; Written by Bill Chiles and Rob Maclachlan.
 ;;;
+;;; Enhancements/debugging for the x86 port by Douglas Crosher 1996, 1997.
 
 (in-package "DEBUG-INTERNALS")
 
@@ -1107,12 +1108,13 @@
 			#-x86
 		       (compute-calling-frame
 			#-alpha
-			(system:sap-ref-sap
-			 fp (* vm::ocfp-save-offset vm:word-bytes))
+			(system:sap-ref-sap fp (* vm::ocfp-save-offset
+						  vm:word-bytes))
 			#+alpha
 			(kernel::int-sap
-			 (system:sap-ref-32
-			  fp (* vm::ocfp-save-offset vm:word-bytes)))
+			 (system:sap-ref-32 fp (* vm::ocfp-save-offset
+						  vm:word-bytes)))
+
 			#-gengc
 			(kernel:stack-ref fp vm::lra-save-offset)
 			#+gengc
@@ -2947,7 +2949,7 @@
 	 (frame-pointer frame)
 	 (or (compiled-debug-variable-save-sc-offset debug-var)
 	     (compiled-debug-variable-sc-offset debug-var))))))
-
+
 ;;; SUB-ACCESS-DEBUG-VAR-SLOT -- Internal.
 ;;;
 #-x86
@@ -3034,6 +3036,7 @@
        (with-nfp (nfp)
 	 (system:sap-ref-sap nfp (* (c::sc-offset-offset sc-offset)
 				    vm:word-bytes)))))))
+
 #+x86
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
   (declare (type system:system-area-pointer fp))
@@ -3050,13 +3053,31 @@
 		  escaped
 		  (c::sc-offset-offset sc-offset)
 		  ',format)
-		 :invalid-value-for-unescaped-register-storage)))
+		 :invalid-value-for-unescaped-register-storage))
+	     ;; The debug variable locations are not always valid, and
+	     ;; on the x86 locations can contain raw values.  To
+	     ;; prevent later problems from invalid objects, they are
+	     ;; filtered here.
+	     (make-valid-lisp-obj (val)
+	       `(if (or 
+		     ;; Fixnum
+		     (zerop (logand ,val 3))
+		     ;; Character
+		     (and (zerop (logand ,val #xffff0000)) ; Top bits zero
+		      (= (logand ,val #xff) vm:base-char-type)) ; Char tag
+		     ;; Pointer
+		     (and (logand ,val 1)
+		      ;; Check that the pointer is valid. XX Should do
+		      ;; a better job.
+		      (< vm:target-read-only-space-start ,val #x11000000)))
+		 (kernel:make-lisp-obj ,val)
+		 :invalid-object)))
     (case (c::sc-offset-scn sc-offset)
       ((#.vm:any-reg-sc-number
 	#.vm:descriptor-reg-sc-number)
        (system:without-gcing
 	(with-escaped-value (val)
-	  (kernel:make-lisp-obj val))))
+	  (make-valid-lisp-obj val))))
       (#.vm:base-char-reg-sc-number
        (with-escaped-value (val)
 	 (code-char val)))
@@ -3080,43 +3101,29 @@
       (#.vm:double-reg-sc-number
        (escaped-float-value double-float))
       (#.vm:single-stack-sc-number
-       (system:sap-ref-single
-	(system:int-sap (- (system:sap-int fp)
-			   (* (1+ (c::sc-offset-offset sc-offset))
-			      vm:word-bytes))) 0))
+       (system:sap-ref-single fp (- (* (1+ (c::sc-offset-offset sc-offset))
+				       vm:word-bytes))))
       (#.vm:double-stack-sc-number
-	(system:sap-ref-double
-	  (system:int-sap (- (system:sap-int fp)
-			  (* (+ (c::sc-offset-offset sc-offset) 2)
-				vm:word-bytes))) 0))
+       (system:sap-ref-double fp (- (* (+ (c::sc-offset-offset sc-offset) 2)
+				       vm:word-bytes))))
       (#.vm:control-stack-sc-number
-       (kernel:stack-ref fp (c::sc-offset-offset sc-offset)))
+       (make-valid-lisp-obj
+	(system:sap-ref-32 fp (- (* (1+ (c::sc-offset-offset sc-offset))
+				    vm:word-bytes)))))
       (#.vm:base-char-stack-sc-number
        (code-char
-	(system:sap-ref-32
-	 (system:int-sap (- (system:sap-int fp)
-			    (* (1+ (c::sc-offset-offset sc-offset))
-			       vm:word-bytes))) 0)))
+	(system:sap-ref-32 fp (- (* (1+ (c::sc-offset-offset sc-offset))
+				    vm:word-bytes)))))
       (#.vm:unsigned-stack-sc-number
-       (system:sap-ref-32
-	(system:int-sap (- (system:sap-int fp)
-			   (* (1+ (c::sc-offset-offset sc-offset))
-			      vm:word-bytes))) 0))
+       (system:sap-ref-32 fp (- (* (1+ (c::sc-offset-offset sc-offset))
+				   vm:word-bytes))))
       (#.vm:signed-stack-sc-number
-       (system:signed-sap-ref-32
-	(system:int-sap (- (system:sap-int fp)
-			   (* (1+ (c::sc-offset-offset sc-offset))
-			      vm:word-bytes))) 0))
+       (system:signed-sap-ref-32 fp (- (* (1+ (c::sc-offset-offset sc-offset))
+					  vm:word-bytes))))
       (#.vm:sap-stack-sc-number
-       (system:sap-ref-sap 
-	(system:int-sap (- (system:sap-int fp)
-			   (* (1+ (c::sc-offset-offset sc-offset))
-			      vm:word-bytes))) 0))
-      ;; Not using ecase to avoid recursive processing.
-      ;; I would rather see some hint as to what is wrong
-      (t (format t "Sc-offset-scn ~a fell through CASE ~%"
-		 (c::sc-offset-scn sc-offset)) nil))
-    ))
+       (system:sap-ref-sap fp (- (* (1+ (c::sc-offset-offset sc-offset))
+				    vm:word-bytes)))))))
+
 
 ;;; %SET-DEBUG-VARIABLE-VALUE -- Internal.
 ;;;
@@ -3167,7 +3174,7 @@
 
 ;;; SUB-SET-DEBUG-VAR-SLOT -- Internal.
 ;;;
-#-x86 ;; preserve original
+#-x86
 (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
   (macrolet ((set-escaped-value (val)
 	       `(if escaped
@@ -3296,40 +3303,35 @@
 	#+nil ;;  don't have escaped floats -- still in npx?
        (set-escaped-float-value double-float value))
       (#.vm:single-stack-sc-number
-       (setf (system:sap-ref-single
-	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
-				 (- vm:word-bytes))) 0)
+       (setf (system:sap-ref-single fp
+				    (- (* (1+ (c::sc-offset-offset sc-offset))
+					  vm:word-bytes)))
 	     (the single-float value)))
       (#.vm:double-stack-sc-number
-       (setf (system:sap-ref-double
-	      (system:sap+ fp (* (+ (c::sc-offset-offset sc-offset) 2)
-				 (- vm:word-bytes))) 0)
+       (setf (system:sap-ref-double fp
+				    (- (* (+ (c::sc-offset-offset sc-offset) 2)
+					  vm:word-bytes)))
 	     (the double-float value)))
       (#.vm:control-stack-sc-number
        (setf (kernel:stack-ref fp (c::sc-offset-offset sc-offset)) value))
       (#.vm:base-char-stack-sc-number
-       (setf (system:sap-ref-32
-	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
-				 (- vm:word-bytes))) 0)
-  	     (char-code (the character value))))
+       (setf (system:sap-ref-32 fp (- (* (1+ (c::sc-offset-offset sc-offset))
+					 vm:word-bytes)))
+	     (char-code (the character value))))
       (#.vm:unsigned-stack-sc-number
-       (setf (system:sap-ref-32
-	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
-				 (- vm:word-bytes))) 0)
+       (setf (system:sap-ref-32 fp (- (* (1+ (c::sc-offset-offset sc-offset))
+					 vm:word-bytes)))
 	     (the (unsigned-byte 32) value)))
       (#.vm:signed-stack-sc-number
        (setf (system:signed-sap-ref-32
-	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
-				 (- vm:word-bytes))) 0)
- 	     (the (signed-byte 32) value)))
+	      fp (- (* (1+ (c::sc-offset-offset sc-offset)) vm:word-bytes)))
+	     (the (signed-byte 32) value)))
       (#.vm:sap-stack-sc-number
-       (setf (system:sap-ref-sap
-	      (system:sap+ fp (* (1+ (c::sc-offset-offset sc-offset))
-				 (- vm:word-bytes))) 0)
+       (setf (system:sap-ref-sap fp (- (* (1+ (c::sc-offset-offset sc-offset))
+					  vm:word-bytes)))
 	     (the system:system-area-pointer value))))))
 
 
-
 (defsetf debug-variable-value %set-debug-variable-value)
 
 
@@ -3374,8 +3376,6 @@
 ;;; This is the method for DEBUG-VARIABLE-VALIDITY for compiled-debug-variables.
 ;;; For safety, make sure basic-code-loc is what we think.
 ;;;
-;;#+x86-compile-botch ;; tn conflict S1
-
 (defun compiled-debug-variable-validity (debug-var basic-code-loc)
   (check-type basic-code-loc compiled-code-location)
   (cond ((debug-variable-alive-p debug-var)
@@ -3428,7 +3428,6 @@
 ;;; Temporary buffer used to build form-number => source-path translation in
 ;;; FORM-NUMBER-TRANSLATIONS.
 ;;;
-
 (defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
 
 ;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
-- 
GitLab