From 685cdcfada0aea7256de31cb2857c642124b56c9 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Tue, 12 Mar 1991 17:18:29 +0000
Subject: [PATCH] Support for new minimal debug info format to reduce space
 use.

---
 code/debug-info.lisp | 132 +++++++++++++++---
 code/debug-int.lisp  | 311 ++++++++++++++++++++++++++++++-------------
 2 files changed, 335 insertions(+), 108 deletions(-)

diff --git a/code/debug-info.lisp b/code/debug-info.lisp
index 932ad9032..4a349f4b5 100644
--- a/code/debug-info.lisp
+++ b/code/debug-info.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-info.lisp,v 1.21 1991/02/11 13:36:54 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-info.lisp,v 1.22 1991/03/12 17:18:10 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -190,8 +190,10 @@
 ;;;        environment-live
 ;;;        has distinct save location
 ;;;        has ID (name not unique in this fun)
-;;;    name length in bytes (as var-length integer)
-;;;    ...name bytes...
+;;;        minimal debug-info argument (name generated as ARG-0, ...)
+;;;        deleted: placeholder for unused minimal argument
+;;;    [name length in bytes (as var-length integer), if not minimal]
+;;;    [...name bytes..., if not minimal]
 ;;;    [if packaged, var-length integer that is package name length]
 ;;;     ...package name bytes...]
 ;;;    [If has ID, ID as var-length integer]
@@ -203,6 +205,8 @@
 (defconstant compiled-debug-variable-environment-live	#b00000100)
 (defconstant compiled-debug-variable-save-loc-p		#b00001000)
 (defconstant compiled-debug-variable-id-p		#b00010000)
+(defconstant compiled-debug-variable-minimal-p		#b00100000)
+(defconstant compiled-debug-variable-deleted-p		#b01000000)
 
 
 ;;;; Compiled debug blocks:
@@ -249,9 +253,8 @@
   ;; function.  These are in alphabetical order by name.  This ordering is used
   ;; in lifetime info to refer to variables: the first entry is 0, the second
   ;; entry is 1, etc.  Variable numbers are *not* the byte index at which the
-  ;; representation of the location starts.  The entire vector must be parsed
-  ;; before function, alphabetically sorted by the NAME.  This slot may be NIL
-  ;; to save space.
+  ;; representation of the location starts.  This slot may be NIL to save
+  ;; space.
   (variables nil :type (or (simple-array (unsigned-byte 8) (*)) null))
   ;;
   ;; A vector of the packed binary representation of the COMPILED-DEBUG-BLOCKS
@@ -292,8 +295,12 @@
   ;;    specified name.
   ;;
   ;; This may be NIL to save space.  If no symbols are present, then this will
-  ;; be represented with an I-vector with sufficiently large element type.
-  (arguments nil :type (or (simple-array * (*)) null))
+  ;; be represented with an I-vector with sufficiently large element type.  If
+  ;; this is :MINIMAL, then this means that the VARIABLES are all required
+  ;; arguments, and are in the order they appear in the VARIABLES vector.  In
+  ;; other words, :MINIMAL stands in for a vector where every element holds its
+  ;; index.
+  (arguments nil :type (or (simple-array * (*)) (member :minimal nil)))
   ;;
   ;; There are three alternatives for this slot:
   ;; 
@@ -324,6 +331,92 @@
   ;; The start of elsewhere code for this function (if any.)
   (elsewhere-pc (required-argument) :type index))
 
+
+;;;; Minimal debug function:
+
+;;; The minimal debug info format compactly represents debug-info for some
+;;; cases where the other debug info (variables, blocks) is small enough so
+;;; that the per-function overhead becomes relatively large.  The minimal
+;;; debug-info format can represent any function at level 0, and any fixed-arg
+;;; function at level 1.
+;;;
+;;; In the minimal format, the debug functions and function map are packed into
+;;; a single byte-vector which is placed in the
+;;; COMPILED-DEBUG-INFO-FUNCTION-MAP.  Because of this, all functions in a
+;;; component must be representable in minimal format for any function to
+;;; actually be dumped in minimal format.  The vector is a sequence of records
+;;; in this format:
+;;;    name representation + kind + return convention (single byte)
+;;;    bit flags (single byte)
+;;;        setf, nfp, variables
+;;;    [package name length (as var-length int), if name is packaged]
+;;;    [...package name bytes, if name is packaged]
+;;;    [name length (as var-length int), if there is a name]
+;;;    [...name bytes, if there is a name]
+;;;    [variables length (as var-length int), if variables flag]
+;;;    [...bytes holding variable descriptions]
+;;;        If variables are dumped (level 1), then the variables are all
+;;;        arguments (in order) with the minimal-arg bit set.
+;;;    [If returns is specified, then the number of return values]
+;;;    [...sequence of var-length ints holding sc-offsets of the return
+;;;        value locations, if fixed return values are specified.]
+;;;    return-pc location sc-offset (as var-length int)
+;;;    old-fp location sc-offset (as var-length int)
+;;;    [nfp location sc-offset (as var-length int), if nfp flag]
+;;;    code-start-pc (as a var-length int)
+;;;        This field implicitly encodes start of this function's code in the
+;;;        function map, as a delta from the previous function's code start.
+;;;        If the first function in the component, then this is the delta from
+;;;        0 (i.e. the absolute offset.)
+;;;    start-pc (as a var-length int)
+;;;        This encodes the environment start PC as an offset from the
+;;;        code-start PC.
+;;;    elsewhere-pc
+;;;        This encodes the elsewhere code start for this function, as a delta
+;;;        from the previous function's elsewhere code start. (i.e. the
+;;;        encoding is the same as for code-start-pc.)
+;;;    
+;;;    
+
+#|
+### For functions with XEPs, name could be represented more simply and
+compactly as some sort of info about with how to find the function-entry that
+this is a function for.  Actually, you really hardly need any info.  You can
+just chain through the functions in the component until you find the right one.
+Well, I guess you need to at least know which function is an XEP for the real
+function (which would be useful info anyway).
+|#
+
+;;; Following are definitions of bit-fields in the first byte of the minimal
+;;; debug function:
+;;;
+(defconstant minimal-debug-function-name-symbol 0)
+(defconstant minimal-debug-function-name-packaged 1)
+(defconstant minimal-debug-function-name-uninterned 2)
+(defconstant minimal-debug-function-name-component 3)
+(defconstant minimal-debug-function-name-style-byte (byte 2 0))
+(defconstant minimal-debug-function-kind-byte (byte 3 2))
+(defconstant minimal-debug-function-kinds
+  '#(nil :optional :external :top-level :cleanup))
+(defconstant minimal-debug-function-returns-standard 0)
+(defconstant minimal-debug-function-returns-specified 1)
+(defconstant minimal-debug-function-returns-fixed 2)
+(defconstant minimal-debug-function-returns-byte (byte 2 5))
+
+;;; The following are bit-flags in the second byte of the minimal debug
+;;; function:
+
+;;; If true, wrap (SETF ...) around the name.
+(defconstant minimal-debug-function-setf-bit (ash 1 0))
+
+;;; If true, there is a NFP.
+(defconstant minimal-debug-function-nfp-bit (ash 1 1))
+
+;;; If true, variables (hence arguments) have been dumped.
+(defconstant minimal-debug-function-variables-bit (ash 1 2))
+
+
+;;;; Debug source:
 
 (defstruct debug-source
   ;;
@@ -360,6 +453,8 @@
   ;; COMPILE-FROM-STREAM.
   (info nil))
 
+
+;;;; The DEBUG-INFO structure:
 
 (defstruct debug-info)
 
@@ -379,11 +474,16 @@
   ;; to.  Locations that aren't packaged are in this package.
   (package (required-argument) :type simple-string)
   ;;
-  ;; A simple-vector of alternating Debug-Function structures and fixnum
-  ;; PCs.  This is used to map PCs to functions, so that we can figure out
-  ;; what function we were running in.  The function is valid between the PC
-  ;; before it (inclusive) and the PC after it (exclusive).  The PCs are in
-  ;; sorted order, so we can binary-search.  We omit the first and last PC,
-  ;; since their values are 0 and the length of the code vector.  Null only
-  ;; temporarily.
-  (function-map nil :type (or simple-vector null)))
+  ;; Either a simple-vector or a byte-vector holding the debug functions for
+  ;; this component.  This is used to map PCs to functions, so that we can
+  ;; figure out what function we were running in.  If a byte-vector, then it is
+  ;; a sequence of minimal debug functions in a packed binary representation.
+  ;;
+  ;; If a simple-vector, then it alternates Debug-Function structures and
+  ;; fixnum PCs.  The function is valid between the PC before it (inclusive)
+  ;; and the PC after it (exclusive).  The PCs are in sorted order, so we can
+  ;; binary-search.  We omit the first and last PC, since their values are 0
+  ;; and the length of the code vector.  Null only temporarily.
+  (function-map nil :type (or simple-vector
+			      (simple-array (unsigned-byte 8) (*))
+			      null)))
diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 21811188e..63566a0e9 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.20 1991/02/08 13:31:38 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.21 1991/03/12 17:18:29 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1041,7 +1041,6 @@
 ;;;
 (defsetf escape-float-register %set-escape-float-register)
 
-
 ;;; DEBUG-FUNCTION-FROM-PC -- Internal.
 ;;;
 ;;; This returns a compiled-debug-function for code and pc.  We fetch the
@@ -1053,7 +1052,7 @@
   (let ((info (code-debug-info component)))
     (unless info
       (debug-signal 'no-debug-info))
-    (let* ((function-map (c::compiled-debug-info-function-map info))
+    (let* ((function-map (get-debug-info-function-map info))
 	   (len (length function-map)))
       (declare (simple-vector function-map))
       (if (= len 1)
@@ -1437,55 +1436,59 @@
   (let ((args (c::compiled-debug-function-arguments
 	       (compiled-debug-function-compiler-debug-fun
 		debug-function))))
-    (declare (type (or (simple-array * (*)) null) args))
-    (if (not args)
-	(values nil nil)
-	(let ((vars (debug-function-debug-variables debug-function))
-	      (i 0)
-	      (len (length args))
-	      (res nil))
-	  (declare (type (or null simple-vector) vars))
-	  (loop
-	    (when (>= i len) (return))
-	    (let ((ele (aref args i)))
-	      (if (symbolp ele)
-		  (case ele
-		    (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
-		     ;; the keyword or optional.
-		     ;; ACTUALLY, WE DON'T HANDLE OPTIONALS CORRECTLY YET. ???
-		     (let ((last (car res))
-			   (v (compiled-debug-function-lambda-list-var
-			       args (incf i) vars)))
-		       (if (typep last 'cons)
-			   (nconc last (list v))
-			   (setf (car res) (list :optional last v)))))
-		    (c::rest-arg
-		     (push (list :rest
-				 (compiled-debug-function-lambda-list-var
-				  args (incf i) vars))
-			   res))
-		    (c::more-arg
-		     (error "I thought I'd never see a more-arg?"))
-		    (t
-		     ;; Keyword arg.
-		     (push (list :keyword
-				 ele
-				 (compiled-debug-function-lambda-list-var
-				  args (incf i) vars))
-			   res)))
-		  ;; Required arg at beginning of args array.
-		  (push (svref vars ele) res)))
-	    (incf i))
-	  (values (nreverse res) t)))))
+    (cond
+     ((not args)
+      (values nil nil))
+     ((eq args :minimal)
+      (values (coerce (debug-function-debug-variables debug-function) 'list)
+	      t))
+     (t
+      (let ((vars (debug-function-debug-variables debug-function))
+	    (i 0)
+	    (len (length args))
+	    (res nil))
+	(declare (type (or null simple-vector) vars))
+	(loop
+	  (when (>= i len) (return))
+	  (let ((ele (aref args i)))
+	    (if (symbolp ele)
+		(case ele
+		  (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
+		   ;; the keyword or optional.
+		   ;; ACTUALLY, WE DON'T HANDLE OPTIONALS CORRECTLY YET. ???
+		   (let ((last (car res))
+			 (v (compiled-debug-function-lambda-list-var
+			     args (incf i) vars)))
+		     (if (typep last 'cons)
+			 (nconc last (list v))
+			 (setf (car res) (list :optional last v)))))
+		  (c::rest-arg
+		   (push (list :rest
+			       (compiled-debug-function-lambda-list-var
+				args (incf i) vars))
+			 res))
+		  (c::more-arg
+		   (error "I thought I'd never see a more-arg?"))
+		  (t
+		   ;; Keyword arg.
+		   (push (list :keyword
+			       ele
+			       (compiled-debug-function-lambda-list-var
+				args (incf i) vars))
+			 res)))
+		;; Required arg at beginning of args array.
+		(push (svref vars ele) res)))
+	  (incf i))
+	(values (nreverse res) t))))))
 
 ;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST-VAR -- Internal
 ;;;
@@ -1514,9 +1517,9 @@
 ;;;
 ;;; WITH-PARSING-BUFFER -- Internal.
 ;;;
-;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARIABLES use this to unpack binary
-;;; encoded information.  It returns the values returned by the last form
-;;; in body.
+;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARIABLES and UNCOMPACT-FUNCTION-MAP use
+;;; this to unpack binary encoded information.  It returns the values returned
+;;; by the last form in body.
 ;;;
 ;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at element
 ;;; zero, and makes sure if we unwind, we nil out any set elements for GC
@@ -1734,16 +1737,36 @@
 		(when (= j len) (return))))))))
     vars))
 
+
+;;; ASSIGN-MINIMAL-VAR-NAMES  --  Internal
+;;;
+;;;    Vars is the parsed variables for a minimal debug function.  We need to
+;;; assign names of the form ARG-NNN.  We must pad with leading zeros, since
+;;; the arguments must be in alphabetical order.
+;;;
+(defun assign-minimal-var-names (vars)
+  (declare (simple-vector vars))
+  (let* ((len (length vars))
+	 (width (length (format nil "~D" (1- len)))))
+    (dotimes (i len)
+      (setf (compiled-debug-variable-name (svref vars i))
+	    (format nil "ARG-~V,'0D" width i)))))
+
+  
 ;;; PARSE-COMPILED-DEBUG-VARIABLES -- Internal.
 ;;;
 ;;; This parses the packed binary representation of debug-variables from
 ;;; debug-function's c::compiled-debug-function.
 ;;;
 (defun parse-compiled-debug-variables (debug-function)
-  (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
+  (let* ((debug-fun
+	  (compiled-debug-function-compiler-debug-fun debug-function))
 	 (packed-vars (c::compiled-debug-function-variables debug-fun))
-	 (default-package (c::compiled-debug-info-package
-			   (compiled-debug-function-debug-info debug-function))))
+	 (default-package
+	  (c::compiled-debug-info-package
+	   (compiled-debug-function-debug-info debug-function)))
+	 (args-minimal (eq (c::compiled-debug-function-arguments debug-fun)
+			   :minimal)))
     (unless packed-vars
       (return-from parse-compiled-debug-variables nil))
     (when (zerop (length packed-vars))
@@ -1753,42 +1776,146 @@
 	  (len (length packed-vars)))
       (with-parsing-buffer (buffer)
 	(loop
-	  (let ((flags (aref packed-vars i)))
-	    (declare (type (unsigned-byte 8) flags))
-	    (incf i)
-	    ;; The routines in the "C" package are macros that advance the index.
-	    (let ((name (c::read-var-string packed-vars i))
-		  (package (cond ((not
-				   (zerop
-				    (logand c::compiled-debug-variable-packaged
-					    flags)))
-				  (c::read-var-string packed-vars i))
-				 ((zerop
-				   (logand c::compiled-debug-variable-uninterned
-					   flags))
-				  default-package)
-				 (t nil)))
-		  (id (if (zerop (logand c::compiled-debug-variable-id-p
-					 flags))
-			  0
-			  (c::read-var-integer packed-vars i)))
-		  (sc-offset (c::read-var-integer packed-vars i))
-		  (save-sc-offset (if (zerop
-				       (logand
-					c::compiled-debug-variable-save-loc-p
-					flags))
-				      nil
-				      (c::read-var-integer packed-vars i))))
-	      (vector-push-extend
-	       (make-compiled-debug-variable
-		name package id
-		(not (zerop (logand c::compiled-debug-variable-environment-live
-				    flags)))
-		sc-offset save-sc-offset)
-	       buffer)))
+	  ;; The routines in the "C" package are macros that advance the
+	  ;; index.
+	  (let* ((flags (prog1 (aref packed-vars i) (incf i)))
+		 (minimal (logtest c::compiled-debug-variable-minimal-p flags))
+		 (deleted (logtest c::compiled-debug-variable-deleted-p flags))
+		 (name (if minimal "" (c::read-var-string packed-vars i)))
+		 (package (cond
+			   (minimal default-package)
+			   ((logtest c::compiled-debug-variable-packaged
+				     flags)
+			    (c::read-var-string packed-vars i))
+			   ((logtest c::compiled-debug-variable-uninterned
+				     flags)
+			    nil)
+			   (t
+			    default-package)))
+		  (id (if (logtest c::compiled-debug-variable-id-p flags)
+			  (c::read-var-integer packed-vars i)
+			  0))
+		  (sc-offset
+		   (if deleted 0 (c::read-var-integer packed-vars i)))
+		  (save-sc-offset
+		   (if (logtest c::compiled-debug-variable-save-loc-p flags)
+		       (c::read-var-integer packed-vars i)
+		       nil)))
+	    (assert (not (and args-minimal (not minimal))))
+	    (vector-push-extend
+	     (make-compiled-debug-variable
+	      name package id
+	      (logtest c::compiled-debug-variable-environment-live flags)
+	      sc-offset save-sc-offset)
+	     buffer))
 	  (when (>= i len) (return)))
-	(result buffer)))))
+	(let ((res (result buffer)))
+	  (when args-minimal
+	    (assign-minimal-var-names res))
+	  res)))))
 
+
+;;;; Unpacking minimal debug functions:
+
+(eval-when (compile eval)
+;;;
+;;; Sleazoid "macro" to keep our indentation sane...
+(defmacro make-uncompacted-debug-fun ()
+  '(c::make-compiled-debug-function
+    :name
+    (let ((base (ecase (ldb c::minimal-debug-function-name-style-byte
+			    options)
+		  (#.c::minimal-debug-function-name-symbol
+		   (intern (c::read-var-string map i)
+			   (c::compiled-debug-info-package info)))
+		  (#.c::minimal-debug-function-name-packaged
+		   (let ((pkg (c::read-var-string map i)))
+		     (intern (c::read-var-string map i) pkg)))
+		  (#.c::minimal-debug-function-name-uninterned
+		   (make-symbol (c::read-var-string map i)))
+		  (#.c::minimal-debug-function-name-component
+		   (c::compiled-debug-info-name info)))))
+      (if (logtest flags c::minimal-debug-function-setf-bit)
+	  `(setf ,base)
+	  base))
+    :kind (svref c::minimal-debug-function-kinds
+		 (ldb c::minimal-debug-function-kind-byte options))
+    :variables
+    (when vars-p
+      (let ((len (c::read-var-integer map i)))
+	(prog1 (subseq map i (+ i len))
+	  (incf i len))))
+    :arguments (when vars-p :minimal)
+    :returns
+    (ecase (ldb c::minimal-debug-function-returns-byte options)
+      (#.c::minimal-debug-function-returns-standard
+       :standard)
+      (#.c::minimal-debug-function-returns-fixed
+       :fixed)
+      (#.c::minimal-debug-function-returns-specified
+       (with-parsing-buffer (buf)
+	 (dotimes (idx (c::read-var-integer map i))
+	   (vector-push-extend (c::read-var-integer map i) buf))
+	 (result buf))))
+    :return-pc (c::read-var-integer map i)
+    :old-fp (c::read-var-integer map i)
+    :nfp (when (logtest flags c::minimal-debug-function-nfp-bit)
+	   (c::read-var-integer map i))
+    :start-pc
+    (progn
+      (setq code-start-pc (+ code-start-pc (c::read-var-integer map i)))
+      (+ code-start-pc (c::read-var-integer map i)))
+    :elsewhere-pc
+    (setq elsewhere-pc (+ elsewhere-pc (c::read-var-integer map i)))))
+
+); eval-when (compile eval)
+
+;;; UNCOMPACT-FUNCTION-MAP  --  Internal
+;;;
+;;;    Return a normal function map derived from a minimal debug info function
+;;; map.  This involves looping parsing minimal-debug-functions and then
+;;; building a vector out of them.
+;;;
+(defun uncompact-function-map (info)
+  (declare (type c::compiled-debug-info info))
+  (let* ((map (c::compiled-debug-info-function-map info))
+	 (i 0)
+	 (len (length map))
+	 (code-start-pc 0)
+	 (elsewhere-pc 0))
+    (declare (type (simple-array (unsigned-byte 8) (*)) map))
+    (collect ((res))
+      (loop
+	(when (= i len) (return))
+	(let* ((options (prog1 (aref map i) (incf i)))
+	       (flags (prog1 (aref map i) (incf i)))
+	       (vars-p (logtest flags c::minimal-debug-function-variables-bit))
+	       (dfun (make-uncompacted-debug-fun)))
+	  (print dfun)
+	  (res code-start-pc)
+	  (res dfun)))
+      
+      (coerce (cdr (res)) 'simple-vector))))
+
+    
+;;; This variable maps minimal debug-info function maps to an unpacked version
+;;; thereof.
+;;;
+(defvar *uncompacted-function-maps* (make-hash-table :test #'eq))
+
+;;; GET-DEBUG-INFO-FUNCTION-MAP  --  Internal
+;;;
+;;;    Return a function-map for a given compiled-debug-info object.  If the
+;;; info is minimal, and has not been parsed, then parse it.
+;;;
+(defun get-debug-info-function-map (info)
+  (declare (type c::compiled-debug-info info))
+  (let ((map (c::compiled-debug-info-function-map info)))
+    (if (simple-vector-p map)
+	map
+	(or (gethash map *uncompacted-function-maps*)
+	    (setf (gethash map *uncompacted-function-maps*)
+		  (uncompact-function-map info))))))
 
 
 ;;;; Code-locations.
-- 
GitLab