master: Reduce core size impact of docstring normalization
melisgl via Sbcl-commits <[email protected]> Wed, 01 Jul 2026 13:30:17 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 2c524ff00b476cae3b2b004c2fc67d791793b4c9 (commit)
from b76c7fe95868bc720426fe88591fde5f94d8c453 (commit)
- Log -----------------------------------------------------------------
commit 2c524ff00b476cae3b2b004c2fc67d791793b4c9
Author: Gabor Melis <[email protected]>
Date: Wed Jul 1 09:48:09 2026 +0200
Reduce core size impact of docstring normalization
- Conditionalize it on #+sb-doc.
- Drop Markdown blockquote support (it's not needed by any docstring
currently).
- Make the code more compact.
Without :SB-DOC, the core size impact is thus zero. With :SB-DOC, the
core size is increased by ~0.05% (~10kB).
---
contrib/sb-manual/doc/sbcl.lisp | 9 ++
contrib/sb-manual/markdown.lisp | 12 +-
contrib/sb-manual/package.lisp | 1 +
contrib/sb-manual/pax.lisp | 8 +
contrib/sb-manual/sb-manual.asd | 4 +-
contrib/sb-manual/texinfo.lisp | 8 -
doc/manual/beyond-ansi.texinfo | 2 +-
doc/manual/compiler.texinfo | 2 +-
src/pcl/documentation.lisp | 335 +++++++++++++++++++---------------------
9 files changed, 189 insertions(+), 192 deletions(-)
diff --git a/contrib/sb-manual/doc/sbcl.lisp b/contrib/sb-manual/doc/sbcl.lisp
index b650df104..40ad88c97 100644
--- a/contrib/sb-manual/doc/sbcl.lisp
+++ b/contrib/sb-manual/doc/sbcl.lisp
@@ -1,5 +1,14 @@
(in-package :sb-manual)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun documentation-generation-date-string (&key long)
+ (multiple-value-bind (second minute hour day month year)
+ (decode-universal-time (get-universal-time))
+ (if long
+ (format nil "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
+ year month day hour minute second)
+ (format nil "~D-~2,'0D" year month)))))
+
(defsection @sbcl-manual (:title "SBCL Manual")
;; This docstring is not used in the Texinfo version (see
;; EMIT-TEXINFO-FOR-SECTION).
diff --git a/contrib/sb-manual/markdown.lisp b/contrib/sb-manual/markdown.lisp
index 0ca17991e..3bed23f63 100644
--- a/contrib/sb-manual/markdown.lisp
+++ b/contrib/sb-manual/markdown.lisp
@@ -144,6 +144,10 @@
;;; TODO:
;;;
;;; - Maybe implement glossary-terms (for books, "safe type", etc).
+;;;
+;;; Also, see SB-PCL::NORMALIZE-SBCL-DOCSTRING, an expedient docstring
+;;; to plain text converter that supports the subset of this
+;;; functionality necessary for the docstrings in SBCL core.
(defun markdown-to-texinfo (string &optional lambda-list)
(let ((*texinfo-local-variables* (flatten lambda-list))
(lines (string-lines string))
@@ -485,14 +489,6 @@
() "Section name ~S contains special texinfo characters." name)
(substitute #\Space #\- (string-downcase name)))))
-(defun doc-name-p (symbol kind)
- (if *using-pax*
- (and (boundp symbol)
- (typep (symbol-value symbol) (dummy (ecase kind
- (:section 'section)
- (:concept 'concept)))))
- (lazy-doc-name-p symbol kind)))
-
(when (and (not *using-pax*)
*downcase-uppercase-code*)
(defsection @test-section (:title "Test Section"))
diff --git a/contrib/sb-manual/package.lisp b/contrib/sb-manual/package.lisp
index 25558e083..e1a840a6f 100644
--- a/contrib/sb-manual/package.lisp
+++ b/contrib/sb-manual/package.lisp
@@ -3,6 +3,7 @@
(defpackage :sb-manual
(:use :cl :sb-alien)
(:export #:use-pax)
+ #+sb-doc
(:import-from #:sb-pcl
#:string-lines #:whitespacep #:indentation #:blankp
#:reindent-docstring))))
diff --git a/contrib/sb-manual/pax.lisp b/contrib/sb-manual/pax.lisp
index 6c527240d..a4826f833 100644
--- a/contrib/sb-manual/pax.lisp
+++ b/contrib/sb-manual/pax.lisp
@@ -319,3 +319,11 @@
(if (doc-name-p name :concept)
(symbol-value name)
(error "Undefined ~S ~S." 'concept name)))
+
+(defun doc-name-p (symbol kind)
+ (if *using-pax*
+ (and (boundp symbol)
+ (typep (symbol-value symbol) (dummy (ecase kind
+ (:section 'section)
+ (:concept 'concept)))))
+ (lazy-doc-name-p symbol kind)))
diff --git a/contrib/sb-manual/sb-manual.asd b/contrib/sb-manual/sb-manual.asd
index f472cd373..60fd161a1 100644
--- a/contrib/sb-manual/sb-manual.asd
+++ b/contrib/sb-manual/sb-manual.asd
@@ -5,8 +5,8 @@
:components ((:file "package")
(:file "pax")
(:file "docstring")
- (:file "markdown")
- (:file "texinfo")
+ (:file "markdown" :if-feature :sb-doc)
+ (:file "texinfo" :if-feature :sb-doc)
(:file "manual")
(:module "doc/"
:serial t
diff --git a/contrib/sb-manual/texinfo.lisp b/contrib/sb-manual/texinfo.lisp
index 7babc46f0..1458dde80 100644
--- a/contrib/sb-manual/texinfo.lisp
+++ b/contrib/sb-manual/texinfo.lisp
@@ -257,14 +257,6 @@
"../../contrib/sb-simple-streams/sb-simple-streams.texinfo")
(@deprecation "deprecation.texinfo")))
-(defun documentation-generation-date-string (&key long)
- (multiple-value-bind (second minute hour day month year)
- (decode-universal-time (get-universal-time))
- (if long
- (format nil "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
- year month day hour minute second)
- (format nil "~D-~2,'0D" year month))))
-
(defun generate-texinfo ()
(let ((*default-pathname-defaults*
(truename (merge-pathnames
diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo
index 4f21d2fa2..8f2d8466f 100644
--- a/doc/manual/beyond-ansi.texinfo
+++ b/doc/manual/beyond-ansi.texinfo
@@ -664,7 +664,7 @@ For structures:
@item @code{slot-value} and @code{slot-boundp} function as expected, including (for
@code{slot-value}) calling and respecting the return value of
- @code{slot-unbound} if the slot is unbound;
+ @code{slot-unbound} if the slot is unbound;
@item @code{(setf slot-value)} functions as expected, including performing
type checks to verify that the new value is of an appropriate type
diff --git a/doc/manual/compiler.texinfo b/doc/manual/compiler.texinfo
index 0ab8479b0..e3afe66ef 100644
--- a/doc/manual/compiler.texinfo
+++ b/doc/manual/compiler.texinfo
@@ -393,7 +393,7 @@ Note that @code{do} appears in the processing path. This is because
@cindex macroexpansion
@cindex source transform
The rest of the processing path results from the macroexpansion of
-@code{do}:
+@code{do}:
@example
(block nil
diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp
index 15d9c9357..82256ad3a 100644
--- a/src/pcl/documentation.lisp
+++ b/src/pcl/documentation.lisp
@@ -217,44 +217,11 @@
x)))
(documentation (call-next-method)))
(maybe-add-deprecation-note namespace name
+ #+sb-doc
(normalize-sbcl-docstring x name doc-type
- documentation))))
-
-(defvar *normalize-sbcl-docstrings* t)
-
-(defun normalize-sbcl-docstring (object name doc-type docstring)
- (if (and *normalize-sbcl-docstrings*
- docstring
- (sbcl-definition-name-p object name doc-type))
- (string-right-trim '(#\Newline) (markdown-to-plain-text
- (reindent-docstring docstring)))
- docstring))
-
-(defun non-setf-name (name)
- (if (and (consp name)
- (eq (first name) 'setf)
- (consp (cdr name)))
- (second name)
- name))
-
-(defun sbcl-package-name-p (name)
- (when (stringp name)
- (or (string= name "COMMON-LISP")
- (and (>= (length name) 3)
- (string= name "SB-" :end1 3)))))
-
-(defun sbcl-definition-name-p (object name doc-type)
- (and (member doc-type '(t compiler-macro function method-combination setf
- structure type variable declaration))
- (if (and (packagep object) (eq doc-type t))
- (sbcl-package-name-p (package-name name))
- (let ((name (non-setf-name name)))
- (if (null name)
- (null object)
- (when (symbolp name)
- (let ((package (symbol-package name)))
- (when package
- (sbcl-package-name-p (package-name package))))))))))
+ documentation)
+ #-sb-doc
+ documentation)))
;;; functions, macros, and special forms
@@ -506,36 +473,114 @@ comparison.")
(dolist (args (prog1 *!docstrings* (makunbound '*!docstrings*)))
(apply #'(setf documentation) args))
-;;;; Markdown to plain text along the lines of SB-MANUAL::MARKDOWN-TO-TEXINFO
-(defun markdown-to-plain-text (string)
- (markdown-lines-to-plain-text (string-lines string) 0))
+;;;; We NORMALIZE-SBCL-DOCSTRINGs at run-time to support interactive
+;;;; docstring authoring (see SB-MANUAL).
-(defun markdown-lines-to-plain-text (lines base-indent)
+#+sb-doc
+(locally (declare (optimize space))
+
+(defvar *normalize-sbcl-docstrings* t)
+
+;;; To reduce the core size, we aggressively inline functions with one
+;;; or two uses.
+(declaim (inline non-setf-name))
+(defun non-setf-name (name)
+ (if (and (consp name)
+ (eq (first name) 'setf)
+ (consp (cdr name)))
+ (second name)
+ name))
+
+(defun sbcl-package-name-p (name)
+ (when (stringp name)
+ (or (string= name "COMMON-LISP")
+ (and (>= (length name) 3)
+ (string= name "SB-" :end1 3)))))
+
+(declaim (inline sbcl-definition-name-p))
+(defun sbcl-definition-name-p (object name doc-type)
+ (and (member doc-type '(t compiler-macro function method-combination setf
+ structure type variable declaration))
+ (if (and (packagep object) (eq doc-type t))
+ (sbcl-package-name-p (package-name name))
+ (let ((name (non-setf-name name)))
+ (if (null name)
+ (null object)
+ (when (symbolp name)
+ (let ((package (symbol-package name)))
+ (when package
+ (sbcl-package-name-p (package-name package))))))))))
+
+;;; Strip markup intended for documentation generation from the
+;;; docstrings of SBCL definitions, and remove indentation from the
+;;; docstrings.
+(defun normalize-sbcl-docstring (object name doc-type docstring)
+ (if (and *normalize-sbcl-docstrings*
+ docstring
+ (sbcl-definition-name-p object name doc-type))
+ (string-right-trim '(#\Newline) (markdown-to-plain-text
+ (reindent-docstring docstring)))
+ docstring))
+
+
+;;; Return the number of leading WHITESPACEP characters in LINE or NIL
+;;; if LINE is NIL or blank.
+(defun indentation (line)
+ (position-if-not #'whitespacep line))
+
+;;; Return the minimum number of leading whitespace characters in
+;;; non-blank lines. Ignore the first line.
+(declaim (inline docstring-indentation))
+(defun docstring-indentation (docstring)
+ (with-input-from-string (s docstring)
+ (read-line s nil nil)
+ (loop for line = (read-line s nil nil)
+ while line
+ ;; This relies on MINIMIZE returning 0 if it is not
+ ;; evaluated at all.
+ when (indentation line)
+ minimize it)))
+
+(declaim (inline strip-docstring-indent))
+(defun strip-docstring-indent (docstring indentation)
+ (declare (type fixnum indentation))
(with-output-to-string (out)
- (let ((buf nil))
- (labels ((flush ()
- (write-md-paragraph buf out)
- (setq buf nil)))
- (loop for l below (length lines)
- for line = (svref lines l)
- do (let ((n (write-md-block lines l base-indent out #'flush)))
- (if n
- (incf l (1- n))
- (push line buf))))
- (flush)))))
+ (with-input-from-string (s docstring)
+ (loop for first = t then nil
+ do (multiple-value-bind (line missing-newline-p)
+ (read-line s nil nil)
+ (unless line
+ (return))
+ (write-string line out
+ :start (if first
+ 0
+ (min (length line) indentation)))
+ (unless missing-newline-p
+ (terpri out)))))))
+
+;;; Normalize docstring indentation by stripping the longest run of
+;;; leading spaces common to all non-blank lines except the first.
+;;;
+;;; If all our docstrings were indented the same way, this could be
+;;; moved to SB-MANUAL, reducing the core size.
+(defun reindent-docstring (docstring)
+ (let ((indent (docstring-indentation docstring)))
+ (strip-docstring-indent docstring indent)))
+
+;;;; A Markdown to plain text converter along the lines of
+;;;; SB-MANUAL::MARKDOWN-TO-TEXINFO but supports only what's
+;;;; absolutely needed for SBCL docstrings.
(defun string-lines (string)
(coerce (with-input-from-string (s string)
(loop for line = (read-line s nil nil)
- while line collect line))
+ while line
+ collect line))
'vector))
(defun whitespacep (char)
- (find char #(#\Tab #\Space #\Page #\Newline #\Return)))
-
-(defun indentation (line)
- (position-if-not #'whitespacep line))
+ (find char (coerce '(#\Tab #\Space #\Page #\Newline #\Return) 'string)))
(defun blankp (line)
(null (indentation line)))
@@ -569,146 +614,92 @@ comparison.")
(setq bound (whitespacep c)))))
(terpri out))))
-(defun write-md-block (lines index base-indent out flush-fn)
- (or (write-md-fenced-code lines index base-indent out flush-fn)
- (write-md-indented-code lines index base-indent out flush-fn)
- (write-md-blockquote lines index base-indent out flush-fn)
- (write-md-markdown-itemize lines index base-indent out flush-fn)))
-
+(declaim (inline write-md-fenced-code))
(defun write-md-fenced-code (lines start base-indent out flush-fn)
(declare (ignore base-indent))
(let* ((line (svref lines start))
- (i (indentation line)))
- (when (and i (>= (length line) (+ i 3))
- (string= line "```" :start1 i :end1 (+ i 3)))
+ (indent (indentation line)))
+ (when (and indent (>= (length line) (+ indent 3))
+ (string= line "```" :start1 indent :end1 (+ indent 3)))
(funcall flush-fn)
(loop for l from (1+ start) below (length lines)
for line = (svref lines l)
- for ind = (indentation line)
- if (and ind (>= (length line) (+ ind 3))
- (string= line "```" :start1 ind :end1 (+ ind 3)))
+ for indent = (indentation line)
+ if (and indent (>= (length line) (+ indent 3))
+ (string= line "```" :start1 indent :end1 (+ indent 3)))
do (return (- (1+ l) start))
else do (write-line line out)
finally (return (- l start))))))
+(declaim (inline write-md-indented-code))
(defun write-md-indented-code (lines start base-indent out flush-fn)
(when (or (zerop start)
(blankp (svref lines (1- start))))
- (let ((i (indentation (svref lines start))))
- (when (and i (>= i (+ base-indent 4)))
+ (let ((indent (indentation (svref lines start))))
+ (when (and indent (>= indent (+ base-indent 4)))
(funcall flush-fn)
(loop for l from start below (length lines)
for line = (svref lines l)
- for ind = (indentation line)
- while (or (null ind)
- (>= ind (+ base-indent 4)))
+ for indent = (indentation line)
+ while (or (null indent)
+ (>= indent (+ base-indent 4)))
do (write-line line out)
finally (return (- l start)))))))
-(defun write-md-blockquote (lines start base-indent out flush-fn)
- (when (or (zerop start)
- (blankp (svref lines (1- start))))
- (let ((i (indentation (svref lines start))))
- (when (and i (<= i (+ base-indent 3))
- (char= (char (svref lines start) i) #\>))
- (funcall flush-fn)
- (let (stripped prefixes)
+(declaim (inline write-md-itemize))
+(defun write-md-itemize (lines start base-indent out flush-fn)
+ (flet ((maybe-itemize-offset (line)
+ (let ((indent (indentation line)))
+ (when (and indent (< (1+ indent) (length line))
+ (find (char line indent) "-*")
+ (char= (char line (1+ indent)) #\Space))
+ indent))))
+ (when (eql (maybe-itemize-offset (svref lines start)) base-indent)
+ (funcall flush-fn)
+ (let ((child (+ base-indent 4))
+ (buf nil))
+ (labels ((flush ()
+ (write-md-paragraph buf out)
+ (setq buf nil)))
(loop for l from start below (length lines)
for line = (svref lines l)
- for ind = (indentation line)
- while (and ind (<= ind (+ base-indent 3))
- (char= (char line ind) #\>))
- do (let ((c-start (if (and (< (1+ ind) (length line))
- (char= (char line (1+ ind)) #\Space))
- (+ ind 2) (1+ ind))))
- (push (subseq line c-start) stripped)
- (push (subseq line 0 c-start) prefixes)))
- (let ((inner (markdown-lines-to-plain-text
- (coerce (nreverse stripped) 'vector) 0)))
- (loop for prefix in (nreverse prefixes)
- for line across (string-lines inner)
- do (write-string prefix out)
- (write-line line out)))
- (length prefixes))))))
+ for indent = (indentation line)
+ do (cond ((null indent)
+ (flush)
+ (write-line line out))
+ ((eql (maybe-itemize-offset line) base-indent)
+ (flush)
+ (push line buf))
+ ((>= indent child)
+ (let ((n (write-md-block lines l child out #'flush)))
+ (if n
+ (incf l (1- n))
+ (push line buf))))
+ ((> indent base-indent)
+ (push line buf))
+ (t
+ (loop-finish)))
+ finally (flush)
+ (return (- l start))))))))
-(defun maybe-itemize-offset (line)
- (let ((i (indentation line)))
- (when (and i (< (1+ i) (length line))
- (find (char line i) "-*")
- (char= (char line (1+ i)) #\Space))
- i)))
+(defun write-md-block (lines index base-indent out flush-fn)
+ (or (write-md-fenced-code lines index base-indent out flush-fn)
+ (write-md-indented-code lines index base-indent out flush-fn)
+ (write-md-itemize lines index base-indent out flush-fn)))
-(defun write-md-markdown-itemize (lines start base-indent out flush-fn)
- (when (eql (maybe-itemize-offset (svref lines start)) base-indent)
- (funcall flush-fn)
- (let ((child (+ base-indent 4))
- (buf nil))
+(defun markdown-to-plain-text (string)
+ (with-output-to-string (out)
+ (let ((buf nil)
+ (lines (string-lines string)))
(labels ((flush ()
(write-md-paragraph buf out)
(setq buf nil)))
- (loop for l from start below (length lines)
+ (loop for l below (length lines)
for line = (svref lines l)
- for ind = (indentation line)
- do (cond ((blankp line)
- (flush)
- (write-line line out))
- ((eql (maybe-itemize-offset line) base-indent)
- (flush)
- (push line buf))
- ((>= ind child)
- (let ((n (write-md-block lines l child out #'flush)))
- (if n
- (incf l (1- n))
- (push line buf))))
- ((> ind base-indent)
- (push line buf))
- (t
- (loop-finish)))
- finally (flush)
- (return (- l start)))))))
-
+ do (let ((n (write-md-block lines l 0 out #'flush)))
+ (if n
+ (incf l (1- n))
+ (push line buf))))
+ (flush)))))
-;;; Normalize docstring indentation by stripping the longest run of
-;;; leading spaces common to all non-blank lines except the first.
-(defun reindent-docstring (docstring)
- (let ((indentation (docstring-indentation docstring)))
- (strip-docstring-indent docstring indentation t)))
-
-;;; Return the minimum number of leading spaces in non-blank lines
-;;; after the first.
-(defun docstring-indentation (docstring &key (first-line-special-p t))
- (let ((n-min-indentation nil))
- (with-input-from-string (s docstring)
- (loop for i upfrom 0
- for line = (read-line s nil nil)
- while line
- do (when (and (or (not first-line-special-p) (plusp i))
- (not (blankp line)))
- (when (or (null n-min-indentation)
- (< (n-leading-spaces line) n-min-indentation))
- (setq n-min-indentation (n-leading-spaces line))))))
- (or n-min-indentation 0)))
-
-(defun n-leading-spaces (line)
- (let ((n 0))
- (loop for i below (length line)
- while (char= (aref line i) #\Space)
- do (incf n))
- n))
-
-(defun strip-docstring-indent (docstring indentation first-line-special-p)
- (with-output-to-string (out)
- (with-input-from-string (s docstring)
- (loop for i upfrom 0
- do (multiple-value-bind (line missing-newline-p)
- (read-line s nil nil)
- (unless line
- (return))
- (write-string (if (and first-line-special-p
- (zerop i))
- line
- (subseq line (min (length line)
- indentation)))
- out)
- (unless missing-newline-p
- (terpri out)))))))
+) ; end #+sb-doc
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL