common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Faster canonicalize-whitespace

Browse source 
Don't write any files if they have not changed.
This commit is contained in:
Stas Boukarev 2023-08-04 21:46:06 +03:00
parent a5f36524ab
commit 70a4741793
4 changed files with 86 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -16,7 +16,6 @@ obj
local-target-features.lisp-expr
customize-target-features.*
customize-backend-subfeatures.*
whitespace-stamp
src/assembly/target
src/compiler/assembly
src/compiler/target

1
clean.sh
View file

@ -114,7 +114,6 @@ find . \( \
-name 'test-status.lisp-expr' -o \
-name 'last-random-state.lisp-expr' -o \
-name 'test.log' -o \
-name 'whitespace-stamp' -o \
-name 'a.out' -o \
-name 'sbcl' -o \
-name 'sbcl.h' -o \

2
make-config.sh
View file

@ -540,7 +540,7 @@ echo //initializing $ltf
echo ';;;; This is a machine-generated file.' > $ltf
echo ';;;; Please do not edit it by hand.' >> $ltf
echo ';;;; See make-config.sh.' >> $ltf
echo "(lambda (features) (set-difference (union features (list :${sbcl_arch}$WITH_FEATURES " >> $ltf
echo "(lambda (features) (set-difference (union features (list :${sbcl_arch}$WITH_FEATURES" >> $ltf
# Automatically block sb-simd on non-x86 platforms, at least for now.
case "$sbcl_arch" in

188
tools-for-build/canonicalize-whitespace.lisp
View file

@ -15,120 +15,102 @@
;;; Stream and single-file functions
#+ecl (ext:quit) ; avoids 'Unexpected end of file on #<input file "stdin">.'
#+sbcl
(progn
(defun whitespace-p (character)
(member character '(#\Space #\Tab) :test #'char=))
(defun canonicalize-whitespace (input output)
(let (change-p)
(flet ((remove-trailing-whitespace (line)
(let ((non-ws-position (position-if-not #'whitespace-p line
:from-end t)))
(cond
((not non-ws-position)
(unless (zerop (length line))
(setq change-p t))
"")
((< non-ws-position (1- (length line)))
(setq change-p t)
(subseq line 0 (1+ non-ws-position)))
(t
line))))
(remove-tabs (line)
(unless (find #\Tab line :test #'char=)
(return-from remove-tabs line))
(setq change-p t)
(with-output-to-string (stream)
(loop :for char :across line :do
(if (char= char #\Tab)
(write-string " " stream)
(write-char char stream))))))
(loop :for line = (read-line input nil :eof)
:until (eq line :eof)
:do (let ((clean (remove-tabs (remove-trailing-whitespace line))))
(write-line clean output))))
change-p))
(defvar *buffer* (make-string (* 2 1024 1024)))
(defun canonicalize-whitespace (string length)
(declare ((simple-array character (*)) string))
(let ((i 0)
whitespace)
(loop while (< i length)
for char = (schar string i)
do
(case char
(#\Newline
(when whitespace
(return)))
(#\Tab
(unless whitespace
(setf whitespace i))
(return))
(#\Space
(unless whitespace
(setf whitespace i)))
(t
(setf whitespace nil)))
(incf i))
(unless (= i length)
(with-output-to-string (out)
(write-string string out :end whitespace)
(loop for i from whitespace below length
for char = (schar string i)
do
(case char
(#\Newline
(setf whitespace nil)
(write-char char out))
((#\Space #\Tab)
(unless whitespace
(setf whitespace i)))
(t
(when whitespace
(loop for i from whitespace below i
for char = (char string i)
do (if (char= char #\Tab)
(write-string " " out)
(write-char char out)))
(setf whitespace nil))
(write-char char out))))))))
(defun canonicalize-whitespace/file (file)
(macrolet ((with-open-source-file ((stream pathname direction) &body body)
`(with-open-file (,stream ,pathname
:direction ,direction
:if-exists :supersede
:external-format #-clisp :utf-8 #+clisp charset:utf-8)
,@body)))
(let* ((temporary (make-pathname :type "temp" :defaults file))
(change-p
(handler-case
(with-open-source-file (input file :input)
(with-open-source-file (output temporary :output)
(canonicalize-whitespace input output)))
(#+sbcl sb-int:stream-decoding-error #-sbcl error ()
(format t "// Ignoring non-UTF-8 source file ~S~%" file)
nil))))
(cond
(change-p
(delete-file file)
(rename-file temporary file)
t)
((probe-file temporary)
(delete-file temporary)
nil)))))
(let ((new
(with-open-file (stream file :external-format :utf-8 :if-does-not-exist nil)
(when stream
(canonicalize-whitespace
*buffer*
(read-sequence *buffer* stream))))))
(when new
(with-open-file (stream file :direction :output
:external-format :utf-8
:if-exists :supersede)
(print file)
(write-sequence new stream)))))
;;; Timestamp functions
(defvar *stamp-file* "whitespace-stamp")
(defun read-stamp-file ()
(if (probe-file *stamp-file*)
(file-write-date *stamp-file*)
0))
(defun write-stamp-file ()
;; We want the stamp file to have the current time for its write
;; date. Conforming variation in OPEN's IF-EXISTS semantics across
;; existing XC hosts means it's simplest to unconditionally ensure a
;; new file.
(when (probe-file *stamp-file*)
(delete-file *stamp-file*))
(close (open *stamp-file* :direction :output :if-exists :error
:if-does-not-exist :create)))
;;; Repository-level functions
(defvar *source-types* '("lisp" "lisp-expr" "c" "h" "asd" "texinfo"))
(defvar *exceptions* '("compile-file-pos-utf16be"))
#+sbcl ; don't warn about illegal DIRECTORY keywords in other lisps
(defun canonicalize-whitespace/directory
(&optional (directory *default-pathname-defaults*) (report t))
(let ((stamp-date (read-stamp-file)) (n-files 0) (n-newer 0) (n-changed 0))
(labels ((older-than-stamp (file)
(< (file-write-date file) stamp-date))
(exception-p (file)
(member (pathname-name file) *exceptions*
:test #'string=))
(skip-p (file)
(incf n-files)
(or (older-than-stamp file) (exception-p file)))
(directory* (pattern)
;; We might be in a build tree made out of symlinks, so
;; we should list our files without resolving symlinks.
(directory pattern :resolve-symlinks nil)))
(dolist (type *source-types*)
(let* ((pattern (merge-pathnames
(make-pathname :type type
:name :wild
:directory '(:relative :wild-inferiors))
directory))
(files (remove-if #'skip-p (directory* pattern))))
(incf n-newer (length files))
(incf n-changed (count-if #'canonicalize-whitespace/file files)))))
(defun find-files ()
(let (files)
(labels ((rec (directory)
(sb-ext:map-directory
(lambda (file)
(if (not (or (pathname-name file)
(pathname-type file)))
(unless (member (car (last (pathname-directory file))) '(".git" "ansi-test" "obj" "output") :test #'equal)
(rec file))
(when (and (member (pathname-type file) *source-types* :test #'equal)
(not (member (pathname-name file) *exceptions* :test #'string=)))
(push file files))))
directory
:classify-symlinks nil)))
(rec *default-pathname-defaults*))
files))
(defun canonicalize-whitespace/directory (&key (report t))
(let* ((files (find-files))
(n-files (length files))
(n-changed 0))
(incf n-changed (count-if #'canonicalize-whitespace/file files))
(when report
(format t "~&// Rewrote ~D of ~D new files out of ~D total."
n-changed n-newer n-files))
(write-stamp-file)))
(format t "~&// Rewrote ~D files out of ~D."
n-changed n-files))))
(map nil #'compile '(find-files canonicalize-whitespace/file canonicalize-whitespace))
(values)
) ; end PROGN