From 1145d95b6697171070344cc77bf368ee516f9b56 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Fri, 27 Apr 1990 12:03:41 +0000
Subject: [PATCH] Picked up some tweaks to debug-variable functionality from
 Chiles.

---
 code/debug-int.lisp | 218 +++++++++++++++-----------------------------
 1 file changed, 72 insertions(+), 146 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 963bce790..f0b99301a 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -1,4 +1,4 @@
-;;; -*- Mode: completion; Log: debug.log; Package: debug-internals -*-
+;;; -*- Mode: completion; Log: code.log; Package: debug-internals -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the Spice Lisp project at
@@ -32,11 +32,11 @@
 	  frame-code-location eval-in-frame return-from-frame frame-catches
 	  frame-number frame frame-p
 
-	  do-blocks debug-function-lambda-list do-debug-function-variables
-	  debug-function-symbol-variables ambiguous-debug-variables
-	  preprocess-for-eval function-debug-function debug-function-function
-	  debug-function-kind debug-function-name debug-function
-	  debug-function-p
+	  do-blocks debug-function-lambda-list debug-variable-info-available
+	  do-debug-function-variables debug-function-symbol-variables
+	  ambiguous-debug-variables preprocess-for-eval function-debug-function
+	  debug-function-function debug-function-kind debug-function-name
+	  debug-function debug-function-p
 
 	  do-debug-block-locations debug-block-successors debug-block
 	  debug-block-p debug-block-elsewhere-p
@@ -326,7 +326,7 @@
   ;;
   ;; Cached Debug-variable information.  (unexported).
   ;; These are sorted by their name.
-  (debug-vars :unparsed :type (or simple-vector (member :unparsed)))
+  (debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
   ;;
   ;; Cached Debug-block information.  This is nil when we have tried to parse
   ;; the packed binary info, but none is available.
@@ -550,20 +550,16 @@
 (proclaim '(inline pointer+offset pointer- stack-ref env-valid-p
 		   cstack-pointer-valid-p %set-stack-ref))
 
+;;;
+;;; These are only used by stack parsing and making frame objects.
+;;;
+
 (defun pointer- (next previous)
   (system:%primitive pointer- next previous))
 
 (defun pointer+offset (x y)
   (system:%primitive sap+ x (ash y 2)))
 
-(defun stack-ref (s n)
-  (system:%primitive read-control-stack (pointer+offset s n)))
-
-(defun %set-stack-ref (s n value)
-  (system:%primitive write-control-stack (pointer+offset s n) value))
-;;;
-(defsetf stack-ref %set-stack-ref)
-
 (defun env-valid-p (env)
   (and (functionp env)
        (eql (system:%primitive get-vector-subtype env)
@@ -576,6 +572,19 @@
 						  system:%control-stack-type)))))
 
 
+;;;
+;;; STACK-REF needs to exist on MIPS and future implementations.
+;;;
+
+(defun stack-ref (s n)
+  (system:%primitive read-control-stack (pointer+offset s n)))
+
+(defun %set-stack-ref (s n value)
+  (system:%primitive write-control-stack (pointer+offset s n) value))
+;;;
+(defsetf stack-ref %set-stack-ref)
+
+
 ;;; These are the names of all the functions that the system could have called
 ;;; while interpreting.  We need to detect these when parsing the stack and
 ;;; make frames representing the code the intepreter is evaluating.
@@ -743,35 +752,6 @@
 		 (error "Escaping frame ENV invalid?"))))
 	(values env fp nil))))
 
-#|
-;;; FP-ENV -- Internal.
-;;;
-;;; This takes a frame pointer and returns its saved environment, taking care
-;;; if fp points to an escape frame.  As multiple values, this returns the
-;;; environment, the appropriate frame pointer for the environment, and whether
-;;; 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)
-  (let ((env (stack-ref fp c::env-save-offset)))
-    (if (eql env 0)
-	;; Get the env of the interrupted frame.
-	(let ((env (escape-register fp c::env-offset)))
-	  (cond ((eql (system:%primitive get-type env) system:%trap-type)
-		 ;; Just ignore these for frame handling.
-		 )
-		((env-valid-p env)
-		 (values env
-			 ;; This is valid since the escape frame must be
-			 ;; preceded by some frame.
-			 (stack-ref fp c::old-fp-save-offset)
-			 fp))
-		(t
-		 (error "Escaping frame ENV invalid?"))))
-	(values env fp nil))))
-
-|#
-
 ;;;
 ;;; Frame utilities.
 ;;;
@@ -899,10 +879,12 @@
   (let ((vars (gensym))
 	(i (gensym)))
     `(let ((,vars (debug-function-debug-variables ,debug-function)))
-       (declare (simple-vector ,vars))
-       (dotimes (,i (length ,vars) ,result)
-	 (let ((,var (svref ,vars ,i)))
-	   ,@body)))))
+       (declare (type (or null simple-vector) ,vars))
+       (if ,vars
+	   (dotimes (,i (length ,vars) ,result)
+	     (let ((,var (svref ,vars ,i)))
+	       ,@body))
+	   ,result))))
 
 ;;; DEBUG-FUNCTION-FUNCTION -- Public.
 ;;;
@@ -951,6 +933,12 @@
     (interpreted-debug-function
      (error "We don't debug interpreted functions now."))))
 
+;;; DEBUG-VARIABLE-INFO-AVAILABLE -- Public.
+;;;
+(defun debug-variable-info-available (debug-function)
+  "Returns whether there is any variable information for debug-function."
+  (not (not (debug-function-debug-variables debug-function))))
+
 ;;; DEBUG-FUNCTION-SYMBOL-VARIABLES -- Public.
 ;;;
 (defun debug-function-symbol-variables (debug-function symbol)
@@ -980,28 +968,29 @@
     limited to the availability of variable information in debug-function; for
     example, possibly debug-function only knows about its arguments."
   (declare (simple-string name-prefix-string))
-  (let* ((variables (debug-function-debug-variables debug-function))
-	 (len (length variables))
-	 (prefix-len (length name-prefix-string))
-	 (pos (find-variable name-prefix-string variables len))
-	 (res nil))
-    (declare (simple-vector variables))
-    (when pos
-      ;; Find names from pos to variable's len that contain prefix.
-      (do ((i pos (1+ i)))
-	  ((= i len))
-	(let* ((var (svref variables i))
-	       (name (debug-variable-name var))
-	       (name-len (length name)))
-	  (declare (simple-string name))
-	  (when (/= (or (string/= name-prefix-string name
-				  :end1 prefix-len :end2 name-len)
-			prefix-len)
-		    prefix-len)
-	    (return))
-	  (push var res)))
-      (setq res (nreverse res)))
-    res))
+  (let ((variables (debug-function-debug-variables debug-function)))
+    (declare (type (or null simple-vector) variables))
+    (if variables
+	(let* ((len (length variables))
+	       (prefix-len (length name-prefix-string))
+	       (pos (find-variable name-prefix-string variables len))
+	       (res nil))
+	  (when pos
+	    ;; Find names from pos to variable's len that contain prefix.
+	    (do ((i pos (1+ i)))
+		((= i len))
+	      (let* ((var (svref variables i))
+		     (name (debug-variable-name var))
+		     (name-len (length name)))
+		(declare (simple-string name))
+		(when (/= (or (string/= name-prefix-string name
+					:end1 prefix-len :end2 name-len)
+			      prefix-len)
+			  prefix-len)
+		  (return))
+		(push var res)))
+	    (setq res (nreverse res)))
+	  res))))
 
 ;;; FIND-VARIABLE -- Internal.
 ;;;
@@ -1021,75 +1010,6 @@
 			       (string= x y :end1 name-len :end2 name-len))))
 	      :end (or end (length variables)))))
 
-#|
-    (multiple-value-bind (pos found)
-			 (find-variable name-prefix-string variables len)
-      (declare (ignore found))
-      ;;
-      ;; Find names from pos to variable's len that contain prefix.
-      (do ((i pos (1+ i)))
-	  ((= i len))
-	(let* ((var (svref variables i))
-	       (name (debug-variable-name var))
-	       (name-len (length name)))
-	  (declare (simple-string name))
-	  (when (/= (or (string/= name-prefix-string name
-				  :end1 prefix-len :end2 name-len)
-			prefix-len)
-		    prefix-len)
-	    (return))
-	  (push var res)))
-      (setq res (nreverse res))
-      ;;
-      ;; Find names from pos to initial variable containing prefix.
-      (do ((i (1- pos) (1- i)))
-	  ((minusp i))
-	(let* ((var (svref variables i))
-	       (name (debug-variable-name var))
-	       (name-len (length name)))
-	  (declare (simple-string name))
-	  (when (/= (or (string/= name-prefix-string name
-				  :end1 prefix-len :end2 name-len)
-			prefix-len)
-		    prefix-len)
-	    (return))
-	  (push var res))))
-
-;;; FIND-VARIABLE -- Internal.
-;;;
-;;; This does a binary search on variables for the one containing name as an
-;;; initial substring.  End is the length of variables if supplied.  This
-;;; returns two values: the position of the entry, and whether it was found.
-;;; When it wasn't found, the position is where to insert a new entry.
-;;;
-(defun find-variable (name variables &optional end)
-  (declare (simple-vector variables)
-	   (simple-string name))
-  (let ((low 0)
-	(high (or end (length variables)))
-	(mid 0)
-	(name-len (length name)))
-    (declare (fixnum low high mid name-len))
-    (loop
-      (when (< high low) (return (values low nil)))
-      (setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low))
-      (let* ((test-name (debug-variable-name (svref variables mid)))
-	     (test-name-len (length test-name)))
-	(declare (simple-string test-name) (fixnum test-name-len))
-	(let ((res (string/= name test-name
-			     :end1 name-len :end2 test-name-len)))
-	  (declare (type (or null fixnum) res))
-	  (cond ((null res)
-		 (return (values mid t)))
-		((= res name-len)
-		 (setf high (1- mid)))
-		((= res test-name-len)
-		 (setf low (1+ mid)))
-		((char< (schar name res) (schar test-name res))
-		 (setf high (1- mid)))
-		(t (setf low (1+ mid)))))))))
-|#
-
 ;;; DEBUG-FUNCTION-LAMBDA-LIST -- Public.
 ;;;
 (defun debug-function-lambda-list (debug-function)
@@ -1140,6 +1060,8 @@
 ;;; DEBUG-FUNCTION-LAMBDA-LIST calls this when a compiled-debug-function has no
 ;;; lambda-list information cached.  It returns the lambda-list as the first
 ;;; value and whether there was any argument information as the second value.
+;;; Therefore, nil and t means there were no arguments, but nil and nil means
+;;; there was no argument information.
 ;;;
 (defun compiled-debug-function-lambda-list (debug-function)
   (let ((args (c::compiled-debug-function-arguments
@@ -1152,7 +1074,7 @@
 	      (i 0)
 	      (len (length args))
 	      (res nil))
-	  (declare (simple-vector vars))
+	  (declare (type (or null simple-vector) vars))
 	  (loop
 	    (when (>= i len) (return))
 	    (let ((ele (aref args i)))
@@ -1299,11 +1221,10 @@
 ;;;
 (defun parse-debug-blocks (debug-function)
   (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
-	 (var-count (length (the simple-vector (debug-function-debug-variables
-						debug-function))))
+	 (var-count (length (debug-function-debug-variables debug-function)))
 	 (blocks (c::compiled-debug-function-blocks debug-fun))
 	 ;; 8 is a hard-wired constant in the compiler for the element size of
-	 ;; of the packed binary form of the blocks data.
+	 ;; the packed binary representation of the blocks data.
 	 (live-set-len (ceiling var-count 8))
 	 (tlf-number (c::compiled-debug-function-tlf-number debug-fun)))
     (unless blocks (return-from parse-debug-blocks nil))
@@ -1358,8 +1279,10 @@
 
 ;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal Interface.
 ;;;
-;;; The argument is a debug internals structure.  The resulting vector may be
-;;; empty.
+;;; The argument is a debug internals structure.  This returns nil if there is
+;;; no variable information.  It returns an empty simple-vector if there were
+;;; no locals in the function.  Otherwise it returns a simple-vector of
+;;; debug-variables.
 ;;;
 (defun debug-function-debug-variables (debug-function)
   (etypecase debug-function
@@ -1382,7 +1305,10 @@
 	 (packed-vars (c::compiled-debug-function-variables debug-fun))
 	 (default-package (c::compiled-debug-info-package
 			   (debug-function-debug-info debug-function))))
-    (when (or (not packed-vars) (zerop (length packed-vars)))
+    (unless packed-vars
+      (return-from parse-debug-variables nil))
+    (when (zerop (length packed-vars))
+      ;; Return a simple-vector not whatever packed-vars may be.
       (return-from parse-debug-variables '#()))
     (let ((i 0)
 	  (len (length packed-vars)))
-- 
GitLab