From 7dbb3dbbf7b2834238d698a777bf02e3f454d800 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Wed, 17 Dec 2025 21:42:38 -0500 Subject: [PATCH] sb-cover: Optionally store source-form-source-position at compile-time See the commenet at SB-COVER:ENABLE-COVERAGE-LOGGING for a brief sketch. This mode of use is not ready for general consumption. --- contrib/sb-cover/cover.lisp | 164 +++++++++++++++++++++++++++--- src/code/cold-init.lisp | 2 +- src/code/load.lisp | 4 +- src/cold/exports.lisp | 3 +- src/compiler/coverage.lisp | 10 +- src/compiler/dump.lisp | 7 +- src/compiler/generic/genesis.lisp | 1 + src/compiler/main.lisp | 5 +- tests/sb-cover.impure.lisp | 6 ++ 9 files changed, 180 insertions(+), 22 deletions(-) diff --git a/contrib/sb-cover/cover.lisp b/contrib/sb-cover/cover.lisp index aa258dcab..9c6023114 100644 --- a/contrib/sb-cover/cover.lisp +++ b/contrib/sb-cover/cover.lisp @@ -8,6 +8,7 @@ (defpackage #:sb-cover (:use #:cl #:sb-c #:sb-int) (:export #:report + #:enable-coverage-logging #:get-coverage #:reset-coverage #:clear-coverage #:merge-coverage #:merge-coverage-from-file @@ -199,7 +200,7 @@ in RESTORE-COVERAGE." (loop for (filename paths . bits) in coverage-state do (let ((image-states (gethash filename (code-coverage-hashtable)))) (cond ((not image-states) ; use all the new data - (let ((info (sb-c::make-coverage-instrumented-file paths))) + (let ((info (sb-c::make-coverage-instrumented-file paths nil nil))) (replace (covered-file-executed info) bits) (setf (gethash filename (code-coverage-hashtable)) info))) ((equal (covered-file-paths image-states) paths) @@ -375,6 +376,11 @@ report, otherwise ignored. The default value is CL:IDENTITY. (format html-stream "") (multiple-value-bind (counts states source) (compute-file-info file external-format) + #+nil ; maybe cross-check both techniques for producing states + (multiple-value-bind (counts2 states2) (compute-file-states file) + (when states2 + (assert (equalp counts counts2)) + (assert (equalp states states2)))) (print-report html-stream file counts states source) (format html-stream "") (list (getf counts :expression) (getf counts :branch)))) @@ -404,24 +410,86 @@ report, otherwise ignored. The default value is CL:IDENTITY. (fill-states-from-locations source states locations) (values counts states source))) +;;; Two varint-encoded integers can usually be stuffed into one fixnum. +;;; For 30-bit fixnums it's slightly more likely to be a bignum, but if +;;; the START is under 1MiB, it's very possibly a fixnum. +(defun pack-pair (start end &optional octets) + (aver (>= end start)) + (unless octets ; a convenience for manual use and testing + (setf octets (make-array 4 :element-type '(unsigned-byte 8) :fill-pointer 0))) + ;; Delta-encoded as with code fixups, biased up by 1 because 0 signifies no data + (write-var-integer (1+ start) octets) + (write-var-integer (- end start) octets) + (prog1 (sb-c::integer-from-octets octets) (setf (fill-pointer octets) 0))) + +(defun unpack-pair (packed-pair) + (let ((list (sb-c::unpack-code-fixup-locs packed-pair))) + (values (1- (car list)) ; 1 as encoded means 0, etc + ;; If START and END were =, then the delta is 0, which can't be encoded, + ;; so the pair reads back as only one integer, which we just repeat. + (1- (if (singleton-p list) (car list) (cadr list)))))) + +(defconstant +suppressed+ 15) +;;; Produce the STATES array without re-reading FILENAME. +(defun compute-file-states (filename) + (binding* ((file (gethash filename (code-coverage-hashtable)) :exit-if-null) + (loc-vec (covered-file-locations file) :exit-if-null) + (linelengths (covered-file-lines file)) + (mock-source ; there is 1 fewer #\newline than there are lines + (make-string (+ (reduce #'+ linelengths) (1- (length linelengths))) + :initial-element #\z)) + (states (make-array (length mock-source) :element-type '(unsigned-byte 4) + :initial-element 0)) + (counts (list :branch (make-sample-count :branch) + :expression (make-sample-count :expression))) + (records (get-records filename counts))) + ;; Insert #\newline chars. These are the only characters that FILL-WITH-STATE + ;; cares about. Revision b40ce7df50 did away with looking for #\Space, possibly + ;; a relic of an abandoned attempt to avoid coloring leading whitespace. + (let ((pos 0)) + (dotimes (i (1- (length linelengths))) + (let ((len (aref linelengths i))) + (setf (char mock-source (incf pos len)) #\newline) + (incf pos)))) + ;; Elements of LOC-VEC at indices exceeding the length of COVERED-FILE-PATHS + ;; are infeasible to execute. + (loop for i from (length (covered-file-paths file)) below (length loc-vec) + do (multiple-value-bind (start end) (unpack-pair (aref loc-vec i)) + (fill-with-state mock-source states +suppressed+ (1- start) end))) + (fill-states-from-locations + mock-source states + (mapcan (lambda (record) + (destructuring-bind (state . loc) (cdr record) + (if (/= loc 0) + (multiple-value-bind (start end) (unpack-pair loc) + (list (list start end state)))))) + records)) + (values counts states))) + (defun get-records (filename counts) (let* ((file (gethash filename (code-coverage-hashtable))) (paths (covered-file-paths file)) (bits (covered-file-executed file)) + (locs (covered-file-locations file)) + (branch-locs (make-hash-table :test 'equal)) (branch-recs (make-hash-table :test 'equal)) (branch-count (getf counts :branch)) (expression-count (getf counts :expression))) (collect ((records)) (dotimes (i (length paths)) - (let ((state (if (zerop (sbit bits i)) 2 1)) (path (aref paths i))) + (let ((state (if (zerop (sbit bits i)) 2 1)) + (path (aref paths i)) + (location (if (< i (length locs)) (aref locs i)))) (cond ((member (car path) '(:then :else)) + (when location + (pushnew location (gethash (cdr path) branch-locs))) (setf (gethash (cdr path) branch-recs) (logior (gethash (cdr path) branch-recs 0) (ash state (if (eql (car path) :then) 0 2))))) (t (when (eql state 1) (incf (ok-of expression-count))) (incf (all-of expression-count)) - (records (list path state)))))) + (records (list* path state location)))))) (maphash (lambda (path state) ;; Each branch record accounts for two paths (incf (ok-of branch-count) @@ -430,7 +498,11 @@ report, otherwise ignored. The default value is CL:IDENTITY. ((6 9) 1) ; #b0110 = taken/not-taken, #b1001 = not-taken/taken (10 0))) ; #b1010 = neither way taken (incf (all-of branch-count) 2) - (records (list path state))) + (let ((location (gethash path branch-locs))) + ;; :THEN and :ELSE must have the identical locations + ;; (it's the location of the value that picks the branch direction) + (aver (or (not location) (singleton-p location))) + (records (list* path state (car location))))) branch-recs) (records)))) @@ -464,7 +536,7 @@ report, otherwise ignored. The default value is CL:IDENTITY. ;; STATES array is 0-origin but locations are 1-origin, so the array ;; range to fill is (1- START) to (1- END) inclusive (when suppress - (fill-with-state source states 15 (1- start) end))))))) + (fill-with-state source states +suppressed+ (1- start) end))))))) ;;; Change most elements of STATES between START (inclusive) and END (exclusive) ;;; to STATE. Some elements will remain unaffected: @@ -503,11 +575,13 @@ report, otherwise ignored. The default value is CL:IDENTITY. (defun get-locations (records maps filename) (let (locations) (dolist (record records locations) - (destructuring-bind (path state) record - (let* ((path (reverse path)) - (tlf (car path)) - (source-form (car (nth tlf maps))) - (source-map (cdr (nth tlf maps))) + (destructuring-bind (rpath state . dummy) record + (declare (ignore dummy)) + (let* ((path (reverse rpath)) + (tlf-num (car path)) + (tlf (nth tlf-num maps)) + (source-form (car tlf)) + (source-map (cdr tlf)) (source-path (cdr path))) (if source-map (handler-case @@ -519,7 +593,7 @@ report, otherwise ignored. The default value is CL:IDENTITY. (warn "~@" source-path filename e))) (warn "Unable to find a source map for toplevel form ~A in file ~A~%" - tlf filename))))))) + tlf-num filename))))))) (defun fill-states-from-locations (source states locations) (setf locations (sort (copy-list locations) #'> :key #'third)) @@ -638,6 +712,70 @@ table.summary tr.subheading td { text-align: left; font-weight: bold; padding-le (sb-kernel:%shrink-vector string nchars)) string))) +;;; Return a cons of (LOCATIONS . LINE-LENGTHS) where each element of LOCATIONS +;;; describes the bounding box of a corresponding element in PATHS, and +;;; elements of LINE-LENGTHS indicate where all the #\newline chars go. +(defun coverage-augmentation (stream paths) + (file-position stream 0) + (let* ((string (make-string (file-length stream))) + (nchars (read-sequence string stream))) + (when (< nchars (length string)) + (sb-kernel:%shrink-vector string nchars)) + (setq string (detabify string)) + (let* ((source-maps (let ((*package* (find-package "CL-USER"))) + (read-and-record-source-maps string))) + (lines + (collect ((lines)) + (let ((start 0)) + (loop + (let ((end (position #\newline string :start start))) + (lines (- (or end (length string)) start)) + (if end (setq start (1+ end)) (return (lines)))))))) + (locations (make-array (length paths) :initial-element 0)) + (suppressions) + (octets (make-array 4 :element-type '(unsigned-byte 8) :fill-pointer 0))) + ;; just like NOTE-SUPPRESSIONS but different + (dolist (tlf source-maps) ; = (form . hash-table) + (dohash ((k locations) (cdr tlf)) + (declare (ignore k)) + (dolist (location locations) + (when (third location) + (push (pack-pair (first location) (second location) octets) suppressions))))) + ;; just like GET-LOCATIONS but different + (dotimes (i (length paths)) + (binding* ((rpath (aref paths i)) + (path (reverse (if (fixnump (car rpath)) rpath (cdr rpath)))) + (tlf-num (car path)) + (tlf (nth tlf-num source-maps)) + (source-form (car tlf)) + (source-map (cdr tlf)) + (source-path (cdr path)) + ((start end) + (source-path-source-position (cons 0 source-path) source-form source-map))) + (when (and start end) + (setf (aref locations i) (pack-pair start end))))) + (cons (sb-c::coerce-to-smallest-eltype (concatenate 'vector locations suppressions)) + (sb-c::coerce-to-smallest-eltype lines))))) + +;;; In the usual way of invoking SB-COVER:REPORT, it first re-reads all source files, +;;; without which, we lack a way for code under test to produce side-channel artifacts +;;; describing source forms hit in a way that most coverage aggregation tooling expects. +;;; (e.g. "lines 1 through 9 are comments; lines 10 through 20 were executed") +;;; At best we could output source paths reached. Those tend to be not user-friendly. +;;; To improve things so that tests can emit descriptive files usable for later +;;; consumption by non-Lisp tooling (think LCOV,GCOV), we have a few options: +;;; (1) in the code being run, feed it all ita sources (from in-memory streams perhaps?) +;;; to re-parse and derive so-called "source maps" just-in-time, OR +;;; (2) invent a compact way to represent source-maps in the code under test, OR +;;; (3) translate source paths to physical bounding boxes at compile-time. +;;; This enhacement takess the third approach, storing more data in *CODE-COVERAGE-INFO* +;;; if SB-COVER:ENABLE-COVERAGE-LOGGING is called prior to compiling anything. +;;; Coverage-instrumented functions gain enough metadata to describe the forms reached +;;; by line and column. Thus we separate analysim from presentation, and only the UI needs +;;; access to the source code for purposes of rendering it in different colors. +(defun enable-coverage-logging () + (setq sb-c::*coverage-augmentation-hook* #'coverage-augmentation)) + (defun make-source-recorder (fn source-map) "Return a macro character function that does the same as FN, but additionally stores the result together with the stream positions @@ -973,12 +1111,12 @@ As a quick way to view source maps, do: (loop for i from start repeat char-count do (format t " ~X" (aref states i))) (format t "~%")))) -(defun show-file-source-maps (pathname) +(defun show-file-source-maps (pathname &optional tlf-num) (let* ((source (read-source pathname :default)) (maps (read-and-record-source-maps source)) (*print-pprint-dispatch* *ppd*) (i -1)) - (dolist (cell maps) + (dolist (cell (if tlf-num (list (nth tlf-num maps)) maps)) (let ((form (car cell))) (format t "TLF ~d:~%" (incf i)) (write form) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 3cd0edddd..f53648678 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -260,7 +260,7 @@ (unless (!c-runtime-noinform-p) (print (cdr toplevel-thing)))) ((cons (eql :record-code-coverage)) (setf (gethash (second toplevel-thing) (car *code-coverage-info*)) - (sb-c::make-coverage-instrumented-file (third toplevel-thing)))) + (sb-c::make-coverage-instrumented-file (third toplevel-thing) nil nil))) (t (!cold-lose "bogus operation in *!COLD-TOPLEVELS*"))))) (/show0 "done with loop over cold toplevel forms and fixups") diff --git a/src/code/load.lisp b/src/code/load.lisp index db2456031..f3a2fabfe 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -1221,11 +1221,11 @@ ;;;; fops for code coverage -(define-fop 120 :not-host (fop-record-code-coverage (paths) nil) +(define-fop 120 :not-host (fop-record-code-coverage (paths extra) nil) (setf (gethash (sb-c::debug-source-namestring (%fasl-input-partial-source-info (fasl-input))) (car *code-coverage-info*)) - (sb-c::make-coverage-instrumented-file paths))) + (sb-c::make-coverage-instrumented-file paths (car extra) (cdr extra)))) ;;; Primordial layouts. (macrolet ((frob (&rest specs) diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index e10187ebc..4731a2bd9 100644 --- a/src/cold/exports.lisp +++ b/src/cold/exports.lisp @@ -2647,7 +2647,8 @@ be submitted as a CDR") "COMPUTE-FUN" "COMPUTE-OLD-NFP" "COPY-MORE-ARG" "COMPUTE-UDIV32-MAGIC" "COMPUTE-FASTREM-COEFFICIENT" - "COVERED-FILE-EXECUTED" "COVERED-FILE-PATHS" + "COVERED-FILE-EXECUTED" "COVERED-FILE-LINES" "COVERED-FILE-LOCATIONS" + "COVERED-FILE-PATHS" "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN" "CURRENT-STACK-POINTER" "*ALIEN-STACK-POINTER*" diff --git a/src/compiler/coverage.lisp b/src/compiler/coverage.lisp index 0584c24f3..d5520c355 100644 --- a/src/compiler/coverage.lisp +++ b/src/compiler/coverage.lisp @@ -20,11 +20,15 @@ ;;; (1 . #8#) (2 . #8#) (:THEN . #8#) #10=(1 . #9#) #11=(1 . #10#) ...) (defstruct (covered-file (:constructor make-coverage-instrumented-file - (paths &aux (executed (make-array (length paths) - :element-type 'bit)))) + (paths locations lines + &aux (executed (make-array (length paths) :element-type 'bit)))) (:copier nil) (:predicate nil)) (executed #* :type simple-bit-vector :read-only t) - (paths #() :type simple-vector :read-only t)) + (paths #() :type simple-vector :read-only t) + ;; The following slots are only for displayless (non-HTML) output. + ;; They allow computing coverage "states" without re-reading source files. + (locations nil :type (or null vector) :read-only t) + (lines nil :type (or null vector) :read-only t)) (defknown %mark-covered (cons) t (always-translatable)) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 3ecca4bdd..879c0745e 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1479,7 +1479,12 @@ ;;;; code coverage -(defun dump-code-coverage-records (cc file) +;;; SB-COVER can override this dumping function, outputting more metadata. +;;; If it does, the resulting functions in FILE can produce descriptions of forms +;;; hit by line & column without needing to re-read their source files. +;;; Presentation still needs to read files - only as strings - for display. +(defun dump-code-coverage-records (cc augmentation file) (declare (type simple-vector cc)) (dump-object cc file) + (dump-object augmentation file) (dump-fop 'fop-record-code-coverage file)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 2b2bff863..bea32ebd7 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2945,6 +2945,7 @@ Legal values for OFFSET are -4, -8, -12, ..." (values)) (define-cold-fop (fop-record-code-coverage) + (pop-stack) ; don't need the augmentation during cross-compile (let ((paths (pop-stack))) (push (cold-list :record-code-coverage (host-constant-to-core diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 5848614e3..060e0ab60 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1598,6 +1598,7 @@ necessary, since type inference may take arbitrarily long to converge.") (lexenv-handled-conditions *lexenv*)))) (and ctype (handle-p condition (car ctype)))))) +(defglobal *coverage-augmentation-hook* nil) ;;; Read all forms from INFO and compile them, with output to ;;; *COMPILE-OBJECT*. Return (VALUES ABORT-P WARNINGS-P FAILURE-P). (defun sub-compile-file (info cfasl) @@ -1669,7 +1670,9 @@ necessary, since type inference may take arbitrarily long to converge.") (dohash ((k v) hash-table) (declare (ignore v)) (setf (aref records (incf i)) k)) - (dump-code-coverage-records records *compile-object*)))) + (let ((extra (awhen *coverage-augmentation-hook* + (funcall it (source-info-stream info) records)))) + (dump-code-coverage-records records extra *compile-object*))))) nil)))) ;; Some errors are sufficiently bewildering that we just fail ;; immediately, without trying to recover and compile more of diff --git a/tests/sb-cover.impure.lisp b/tests/sb-cover.impure.lisp index 237cb3828..da76fd6c3 100644 --- a/tests/sb-cover.impure.lisp +++ b/tests/sb-cover.impure.lisp @@ -52,6 +52,12 @@ ;; Weak pointers to toplevel forms need to survive the entire test run (sb-int:encapsulate 'sb-fasl::possibly-log-new-code 'override #'preserve-code) +(with-test (:name :location-codec) + (dotimes (i 100) (dotimes (j 100) + (let* ((start i) (end (+ i j)) (packed (sb-cover::pack-pair start end))) + (multiple-value-bind (first second) (sb-cover::unpack-pair packed) + (assert (= start first)) (assert (= end second))))))) + (with-test (:name :sb-cover) (test-util:with-test-directory (sb-cover-test:*output-directory*) (load (merge-pathnames "tests.lisp" sb-cover-test:*source-directory*))