From b0ab617943caf96f498cd921cfef9de116470c21 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Sat, 21 Jan 2017 14:11:43 +0300 Subject: [PATCH] More compact debug info. Use flags to avoid writing empty data. --- src/code/debug-info.lisp | 19 ++++++++++--- src/code/debug-int.lisp | 29 +++++++++++++------- src/compiler/debug-dump.lisp | 63 ++++++++++++++++++++++++++------------------ 3 files changed, 71 insertions(+), 40 deletions(-) diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp index ef0c46cdc..84e181fa3 100644 --- a/src/code/debug-info.lisp +++ b/src/code/debug-info.lisp @@ -54,10 +54,21 @@ ;;;; ...more ;;;; tuples... -(defparameter *compiled-code-location-kinds* - #(:unknown-return :known-return :internal-error :non-local-exit - :block-start :call-site :single-value-return :non-local-entry - :step-before-vop)) +(defconstant-eqx +compiled-code-location-kinds+ + #(:unknown-return :known-return :internal-error :non-local-exit + :block-start :call-site :single-value-return :non-local-entry + :step-before-vop) + #'equalp) + +(eval-when (:compile-toplevel) + (assert (<= (integer-length (1- (length +compiled-code-location-kinds+))) 4))) + +;;; Location flags, encoded in the low 4 bits of loction kind byte +(defconstant compiled-code-location-stepping (ash #b0001 4)) +(defconstant compiled-code-location-context (ash #b0010 4)) +(defconstant compiled-code-location-live (ash #b0100 4)) +(defconstant compiled-code-location-zero-form-number (ash #b1000 4)) + ;;;; DEBUG-FUN objects diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index baf62775d..7b894bd89 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1647,20 +1647,29 @@ register." (when (>= i len) (return)) (let ((block (make-compiled-debug-block))) (dotimes (k (sb!c:read-var-integerf blocks i)) - (let* ((kind (svref sb!c::*compiled-code-location-kinds* - (aref+ blocks i))) + (let* ((flags (aref+ blocks i)) + (kind (svref sb!c::+compiled-code-location-kinds+ + (ldb (byte 4 0) flags))) (pc (+ last-pc (sb!c:read-var-integerf blocks i))) (tlf-offset (or tlf-number (sb!c:read-var-integerf blocks i))) - (form-number (sb!c:read-var-integerf blocks i)) - (live-set (sb!c:read-packed-bit-vector - live-set-len blocks i)) - (step-info (sb!c:read-var-string blocks i)) - (context-index (sb!c:read-var-integerf blocks i)) - (context (and (plusp context-index) - (svref (sb!c::compiled-debug-fun-contexts compiler-debug-fun) - (1- context-index))))) + (form-number + (if (logtest sb!c::compiled-code-location-zero-form-number flags) + 0 + (sb!c:read-var-integerf blocks i))) + (live-set + (if (logtest sb!c::compiled-code-location-live flags) + (sb!c:read-packed-bit-vector live-set-len blocks i) + (make-array (* live-set-len 8) :element-type 'bit))) + (step-info + (if (logtest sb!c::compiled-code-location-stepping flags) + (sb!c:read-var-string blocks i) + "")) + (context + (and (logtest sb!c::compiled-code-location-context flags) + (svref (sb!c::compiled-debug-fun-contexts compiler-debug-fun) + (sb!c:read-var-integerf blocks i))))) (vector-push-extend (make-known-code-location pc debug-fun block tlf-offset form-number live-set kind diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 9935355c3..7adb1013e 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -122,36 +122,45 @@ (type location-kind kind) (type (or index null) tlf-num) (type hash-table var-locs) (type (or vop null) vop)) - (let ((byte-buffer *byte-buffer*)) + (let ((byte-buffer *byte-buffer*) + (stepping (and (combination-p node) + (combination-step-info node))) + (anything-alive (and live + (find 1 live))) + (path (node-source-path node))) (vector-push-extend - (position-or-lose kind *compiled-code-location-kinds*) + (logior + (if context + compiled-code-location-context + 0) + (if stepping + compiled-code-location-stepping + 0) + (if anything-alive + compiled-code-location-live + 0) + (if (zerop (source-path-form-number path)) + compiled-code-location-zero-form-number + 0) + (position-or-lose kind +compiled-code-location-kinds+)) byte-buffer) (let ((loc (if (fixnump label) label (label-position label)))) (write-var-integer (- loc *previous-location*) byte-buffer) (setq *previous-location* loc)) - (let ((path (node-source-path node))) - (unless tlf-num - (write-var-integer (source-path-tlf-number path) byte-buffer)) + (unless tlf-num + (write-var-integer (source-path-tlf-number path) byte-buffer)) + (unless (zerop (source-path-form-number path)) (write-var-integer (source-path-form-number path) byte-buffer)) - (if live - (write-packed-bit-vector (compute-live-vars live node block var-locs vop) - byte-buffer) - (write-packed-bit-vector - (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7) - :initial-element 0 - :element-type 'bit) - byte-buffer)) - (write-var-string (or (and (typep node 'combination) - (combination-step-info node)) - "") - byte-buffer) - (write-var-integer (if context - (1+ (vector-push-extend context *contexts*)) - 0) - byte-buffer)) + (when anything-alive + (write-packed-bit-vector (compute-live-vars live node block var-locs vop) + byte-buffer)) + (when stepping + (write-var-string stepping byte-buffer)) + (when context + (write-var-integer (vector-push-extend context *contexts*) byte-buffer))) (values)) ;;; Extract context info from a Location-Info structure and use it to @@ -565,10 +574,10 @@ (declare (type clambda fun) (type hash-table var-locs)) (let* ((dfun (dfun-from-fun fun)) (actual-level (policy (lambda-bind fun) compute-debug-fun)) - (level (if #!+sb-dyncount *collect-dynamic-statistics* - #!-sb-dyncount nil - (max actual-level 2) - actual-level)) + (level (cond #!+sb-dyncount + (*collect-dynamic-statistics* + (max actual-level 2)) + (actual-level))) (toplevel-p (eq :toplevel (compiled-debug-fun-kind dfun)))) (cond ((or (zerop level) toplevel-p)) ((and (<= level 1) @@ -590,7 +599,9 @@ (setf (compiled-debug-fun-blocks dfun) blocks (compiled-debug-fun-tlf-number dfun) tlf-num (compiled-debug-fun-form-number dfun) form-number - (compiled-debug-fun-contexts dfun) (coerce contexts 'simple-vector))) + (compiled-debug-fun-contexts dfun) + (and (plusp (length contexts)) + (coerce contexts 'simple-vector)))) (multiple-value-bind (tlf-num form-number) (find-tlf-number fun) (setf (compiled-debug-fun-tlf-number dfun) tlf-num (compiled-debug-fun-form-number dfun) form-number))) -- 2.11.4.GIT