Skip to content
Snippets Groups Projects
Commit 685cdcfa authored by ram's avatar ram
Browse files

Support for new minimal debug info format to reduce space use.

parent 5fd33a46
No related branches found
No related tags found
No related merge requests found
......@@ -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)))
......@@ -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.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment