From 069d79066cd5c18482833c11b1e36d71090c05e7 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Wed, 17 Aug 2016 09:54:46 -0400 Subject: [PATCH] Distinguish base/non-base-string in fop-symbol etc Also add symbol name buffers to the fasl input structure --- src/code/early-fasl.lisp | 2 + src/code/fop.lisp | 94 +++++++++++++++++++-------------------- src/compiler/dump.lisp | 32 +++++-------- src/compiler/generic/genesis.lisp | 20 ++++----- 4 files changed, 69 insertions(+), 79 deletions(-) diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index c54545839..c441682b7 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -173,6 +173,8 @@ (stream nil :type ansi-stream :read-only t) (table (make-fop-vector 1000) :type simple-vector) (stack (make-fop-vector 100) :type simple-vector) + (name-buffer (cons (make-array 31 :element-type 'base-char) + (make-array 1 :element-type 'character))) (deprecated-stuff nil :type list) ;; Sometimes we want to skip over any FOPs with side-effects (like ;; function calls) while executing other FOPs. SKIP-UNTIL will diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 31f82e10f..e7d37a509 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -227,54 +227,52 @@ (error nil :read-only t)) (declaim (freeze-type undefined-package)) -;; cold loader has its own implementation of this and all symbol fops. -#-sb-xc-host -(defun aux-fop-intern (size package fasl-input) - (declare (optimize speed)) - (let ((input-stream (%fasl-input-stream fasl-input)) - (buffer (make-string size))) - #!+sb-unicode (read-string-as-unsigned-byte-32 input-stream buffer size) - #!-sb-unicode (read-string-as-bytes input-stream buffer size) - (if (undefined-package-p package) - (error 'simple-package-error - :format-control "Error finding package for symbol ~s:~% ~a" - :format-arguments - (list (subseq buffer 0 size) - (undefined-package-error package))) - (push-fop-table (without-package-locks - (%intern buffer size package nil)) - fasl-input)))) - -(!define-fop 80 :not-host (fop-lisp-symbol-save ((:operands namelen))) - (aux-fop-intern namelen *cl-package* (fasl-input))) -(!define-fop 84 :not-host (fop-keyword-symbol-save ((:operands namelen))) - (aux-fop-intern namelen *keyword-package* (fasl-input))) - -;; But srsly? Most of the space is wasted by UCS4 encoding of ASCII. -;; An extra word per symbol for the package is nothing by comparison. - ;; FIXME: Because we don't have FOP-SYMBOL-SAVE any more, an - ;; enormous number of symbols will fall through to this case, - ;; probably resulting in bloated fasl files. A new - ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE - ;; cloned fop pair could undo some of this bloat. -(!define-fop #xF0 :not-host (fop-symbol-in-package-save ((:operands pkg-index namelen))) - (aux-fop-intern namelen (ref-fop-table (fasl-input) pkg-index) (fasl-input))) - -;;; Symbol-hash is usually computed lazily and memoized into a symbol. -;;; Laziness slightly improves the speed of allocation. -;;; But when loading fasls, the time spent in the loader totally swamps -;;; any time savings of not precomputing symbol-hash. -;;; INTERN hashes everything anyway, so let's be consistent -;;; and precompute the hashes of uninterned symbols too. -(macrolet ((ensure-hashed (symbol-form) - `(let ((symbol ,symbol-form)) - (ensure-symbol-hash symbol) - symbol))) - (!define-fop 96 :not-host (fop-uninterned-symbol-save ((:operands namelen))) - (let ((res (make-string namelen))) - #!-sb-unicode (read-string-as-bytes (fasl-input-stream) res) - #!+sb-unicode (read-string-as-unsigned-byte-32 (fasl-input-stream) res) - (push-fop-table (ensure-hashed (make-symbol res)) +;; Cold load has its own implementation of all symbol fops, +;; but we have to execute define-fop now to assign their numbers. +(labels ((read-symbol-name (length+flag fasl-input) + (let* ((namelen (ash (the fixnum length+flag) -1)) + (base-p (oddp length+flag)) + (buffer (%fasl-input-name-buffer fasl-input)) + (string (the string (if base-p (car buffer) (cdr buffer))))) + (when (< (length string) namelen) ; grow + (setf string + (if base-p + (setf (car buffer) (make-array namelen :element-type 'base-char)) + (setf (cdr buffer) (make-array namelen :element-type 'character))))) + (funcall (if base-p 'read-base-string-as-bytes 'read-string-as-unsigned-byte-32) + (%fasl-input-stream fasl-input) string namelen) + (values string namelen))) + (aux-fop-intern (length+flag package fasl-input) + (multiple-value-bind (name length) (read-symbol-name length+flag fasl-input) + (if (undefined-package-p package) + (error 'simple-package-error + :format-control "Error finding package for symbol ~s:~% ~a" + :format-arguments + (list (subseq name 0 length) + (undefined-package-error package))) + (push-fop-table (without-package-locks (%intern name length package t)) + fasl-input)))) + ;; Symbol-hash is usually computed lazily and memoized into a symbol. + ;; Laziness slightly improves the speed of allocation. + ;; But when loading fasls, the time spent in the loader totally swamps + ;; any time savings of not precomputing symbol-hash. + ;; INTERN hashes everything anyway, so let's be consistent + ;; and precompute the hashes of uninterned symbols too. + (ensure-hashed (symbol) + (ensure-symbol-hash symbol) + symbol)) + + (declare (inline ensure-hashed)) + (!define-fop 80 :not-host (fop-lisp-symbol-save ((:operands length+flag))) + (aux-fop-intern length+flag *cl-package* (fasl-input))) + (!define-fop 84 :not-host (fop-keyword-symbol-save ((:operands length+flag))) + (aux-fop-intern length+flag *keyword-package* (fasl-input))) + (!define-fop #xF0 :not-host (fop-symbol-in-package-save ((:operands pkg-index length+flag))) + (aux-fop-intern length+flag (ref-fop-table (fasl-input) pkg-index) (fasl-input))) + + (!define-fop 96 :not-host (fop-uninterned-symbol-save ((:operands length+flag))) + (multiple-value-bind (name len) (read-symbol-name length+flag (fasl-input)) + (push-fop-table (ensure-hashed (make-symbol (subseq name 0 len))) (fasl-input)))) (!define-fop 104 :not-host (fop-copy-symbol-save ((:operands table-index))) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index e3cd99f26..7354708e0 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -944,6 +944,8 @@ (declare (type fasl-output file)) (let* ((pname (symbol-name s)) (pname-length (length pname)) + (base-string-p (typep pname (or #-sb-xc-host 'base-string t))) + (length+flag (logior (ash pname-length 1) (if base-string-p 1 0))) (dumped-as-copy nil) (pkg (symbol-package s))) ;; see comment in genesis: we need this here for repeatable fasls @@ -957,15 +959,11 @@ (setq pkg sb!int:*cl-package*))) (cond ((null pkg) - (let ((this-base-p #+sb-xc-host t - #-sb-xc-host (typep pname 'base-string))) + (let ((this-base-p base-string-p)) (dolist (lookalike (gethash pname (fasl-output-string=-table file)) (dump-fop 'fop-uninterned-symbol-save - file pname-length)) + file length+flag)) ;; Find the right kind of lookalike symbol. - ;; actually this seems pretty bogus - afaict, we don't correctly - ;; preserve the type of the string (base or character) anyway, - ;; but if we did, then this would be right also. ;; [what about a symbol whose name is a (simple-array nil (0))?] (let ((that-base-p #+sb-xc-host t @@ -975,27 +973,19 @@ (dump-fop 'fop-copy-symbol-save file (gethash lookalike (fasl-output-eq-table file))) (return (setq dumped-as-copy t))))))) - ;; CMU CL had FOP-SYMBOL-SAVE/FOP-SMALL-SYMBOL-SAVE fops which - ;; used the current value of *PACKAGE*. Unfortunately that's - ;; broken w.r.t. ANSI Common Lisp semantics, so those are gone - ;; from SBCL. - ;;((eq pkg *package*) - ;; (dump-fop* pname-length - ;; fop-small-symbol-save - ;; fop-symbol-save file)) ((eq pkg sb!int:*cl-package*) - (dump-fop 'fop-lisp-symbol-save file pname-length)) + (dump-fop 'fop-lisp-symbol-save file length+flag)) ((eq pkg sb!int:*keyword-package*) - (dump-fop 'fop-keyword-symbol-save file pname-length)) + (dump-fop 'fop-keyword-symbol-save file length+flag)) (t (dump-fop 'fop-symbol-in-package-save file - (dump-package pkg file) pname-length))) + (dump-package pkg file) length+flag))) (unless dumped-as-copy - #+sb-xc-host (dump-base-chars-of-string pname file) - #-sb-xc-host (#!+sb-unicode dump-characters-of-string - #!-sb-unicode dump-base-chars-of-string - pname file) + (funcall (if base-string-p + 'dump-base-chars-of-string + 'dump-characters-of-string) + pname file) (push s (gethash (symbol-name s) (fasl-output-string=-table file)))) (setf (gethash s (fasl-output-eq-table file)) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index bbd36c16a..1846d56c9 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2492,28 +2492,28 @@ core and return a descriptor to it." ;;; Load a symbol SIZE characters long from FASL-INPUT, and ;;; intern that symbol in PACKAGE. -(defun cold-load-symbol (size package fasl-input) - (let ((string (make-string size))) +(defun cold-load-symbol (length+flag package fasl-input) + (let ((string (make-string (ash length+flag -1)))) (read-string-as-bytes (%fasl-input-stream fasl-input) string) (push-fop-table (intern string package) fasl-input))) ;; I don't feel like hacking up DEFINE-COLD-FOP any more than necessary, ;; so this code is handcrafted to accept two operands. -(flet ((fop-cold-symbol-in-package-save (fasl-input index pname-len) - (cold-load-symbol pname-len (ref-fop-table fasl-input index) +(flet ((fop-cold-symbol-in-package-save (fasl-input index length+flag) + (cold-load-symbol length+flag (ref-fop-table fasl-input index) fasl-input))) (dotimes (i 16) ; occupies 16 cells in the dispatch table (setf (svref **fop-funs** (+ (get 'fop-symbol-in-package-save 'opcode) i)) #'fop-cold-symbol-in-package-save))) -(define-cold-fop (fop-lisp-symbol-save (namelen)) - (cold-load-symbol namelen *cl-package* (fasl-input))) +(define-cold-fop (fop-lisp-symbol-save (length+flag)) + (cold-load-symbol length+flag *cl-package* (fasl-input))) -(define-cold-fop (fop-keyword-symbol-save (namelen)) - (cold-load-symbol namelen *keyword-package* (fasl-input))) +(define-cold-fop (fop-keyword-symbol-save (length+flag)) + (cold-load-symbol length+flag *keyword-package* (fasl-input))) -(define-cold-fop (fop-uninterned-symbol-save (namelen)) - (let ((name (make-string namelen))) +(define-cold-fop (fop-uninterned-symbol-save (length+flag)) + (let ((name (make-string (ash length+flag -1)))) (read-string-as-bytes (fasl-input-stream) name) (push-fop-table (get-uninterned-symbol name) (fasl-input)))) -- 2.11.4.GIT