From 8ee61a7761181511d15690246eb52d100e233935 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 9 Dec 2011 20:39:49 +0200 Subject: [PATCH] refactor FOP table and stack handling Just two special variables *FOP-TABLE* and *FOP-STACK*. Both hold a simple-vector, whose first index holds the index of the last element. These are always freshly allocated -- no more *FREE-FOP-TABLES* dirtying up the old generations. Define a semi-opaque interface for manipulating the stack and the table. (Mainly replacing explicit SVREF's with REF-FOP-TABLE.) ...and lo! Our fasl-loading speed sucks 5-10% less. --- src/code/fop.lisp | 24 ++--- src/code/load.lisp | 186 +++++++++++++++++++++---------------- src/compiler/generic/genesis.lisp | 10 +- 3 files changed, 125 insertions(+), 95 deletions(-) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 9b69677..ddf5ba7 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -134,8 +134,8 @@ (define-fop (fop-nop 0 :stackp nil)) (define-fop (fop-pop 1 :pushp nil) (push-fop-table (pop-stack))) -(define-fop (fop-push 2) (svref *current-fop-table* (read-word-arg))) -(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-byte-arg))) +(define-fop (fop-push 2) (ref-fop-table (read-word-arg))) +(define-fop (fop-byte-push 3) (ref-fop-table (read-byte-arg))) (define-fop (fop-empty-list 4) ()) (define-fop (fop-truth 5) t) @@ -184,10 +184,10 @@ (define-fop (fop-verify-table-size 62 :stackp nil) (let ((expected-index (read-word-arg))) - (unless (= *current-fop-table-index* expected-index) + (unless (= (get-fop-table-index) expected-index) (bug "fasl table of improper size")))) (define-fop (fop-verify-empty-stack 63 :stackp nil) - (unless (zerop (length *fop-stack*)) + (unless (fop-stack-empty-p) (bug "fasl stack not empty when it should be"))) ;;;; fops for loading symbols @@ -227,13 +227,13 @@ ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE ;; cloned fop pair could undo some of this bloat. (def fop-symbol-in-package-save 8 nil - (svref *current-fop-table* (read-word-arg))) + (ref-fop-table (read-word-arg))) (def fop-small-symbol-in-package-save 9 t - (svref *current-fop-table* (read-word-arg))) + (ref-fop-table (read-word-arg))) (def fop-symbol-in-byte-package-save 10 nil - (svref *current-fop-table* (read-byte-arg))) + (ref-fop-table (read-byte-arg))) (def fop-small-symbol-in-byte-package-save 11 t - (svref *current-fop-table* (read-byte-arg)))) + (ref-fop-table (read-byte-arg)))) (define-cloned-fops (fop-uninterned-symbol-save 12) (fop-uninterned-small-symbol-save 13) @@ -546,20 +546,20 @@ ;;;; fops for fixing up circularities (define-fop (fop-rplaca 200 :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg)) (val (pop-stack))) (setf (car (nthcdr idx obj)) val))) (define-fop (fop-rplacd 201 :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg)) (val (pop-stack))) (setf (cdr (nthcdr idx obj)) val))) (define-fop (fop-svset 202 :pushp nil) (let* ((obi (read-word-arg)) - (obj (svref *current-fop-table* obi)) + (obj (ref-fop-table obi)) (idx (read-word-arg)) (val (pop-stack))) (if (%instancep obj) @@ -567,7 +567,7 @@ (setf (svref obj idx) val)))) (define-fop (fop-structset 204 :pushp nil) - (setf (%instance-ref (svref *current-fop-table* (read-word-arg)) + (setf (%instance-ref (ref-fop-table (read-word-arg)) (read-word-arg)) (pop-stack))) diff --git a/src/code/load.lisp b/src/code/load.lisp index 8c82bf1..ed29a41 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -118,84 +118,117 @@ ;;;; the fop table ;;; The table is implemented as a simple-vector indexed by the table -;;; offset. We may need to have several, since LOAD can be called -;;; recursively. - -;;; a list of free fop tables for the fasloader +;;; offset. The offset is kept in at index 0 of the vector. ;;; -;;; FIXME: Is it really a win to have this permanently bound? -;;; Couldn't we just bind it on entry to LOAD-AS-FASL? -(defvar *free-fop-tables* (list (make-array 1000))) - -;;; the current fop table -(defvar *current-fop-table*) -(declaim (simple-vector *current-fop-table*)) - -;;; the length of the current fop table -(defvar *current-fop-table-size*) -(declaim (type index *current-fop-table-size*)) - -;;; the index in the fop-table of the next entry to be used -(defvar *current-fop-table-index*) -(declaim (type index *current-fop-table-index*)) - -(defun grow-fop-table () - (let* ((new-size (* *current-fop-table-size* 2)) - (new-table (make-array new-size))) - (declare (fixnum new-size) (simple-vector new-table)) - (replace new-table (the simple-vector *current-fop-table*)) - (setq *current-fop-table* new-table) - (setq *current-fop-table-size* new-size))) - -(defmacro push-fop-table (thing) - (let ((n-index (gensym))) - `(let ((,n-index *current-fop-table-index*)) - (declare (fixnum ,n-index)) - (when (= ,n-index (the fixnum *current-fop-table-size*)) - (grow-fop-table)) - (setq *current-fop-table-index* (1+ ,n-index)) - (setf (svref *current-fop-table* ,n-index) ,thing)))) +;;; FOPs use the table to save stuff, other FOPs refer to the table by +;;; direct indexes via REF-FOP-TABLE. + +(defvar *fop-table*) +(declaim (simple-vector *fop-table*)) + +(declaim (inline ref-fop-table)) +(defun ref-fop-table (index) + (declare (index index)) + (svref *fop-table* (the index (+ index 1)))) + +(defun get-fop-table-index () + (svref *fop-table* 0)) + +(defun reset-fop-table () + (setf (svref *fop-table* 0) 0)) + +(defun push-fop-table (thing) + (let* ((table *fop-table*) + (index (+ (the index (aref table 0)) 1))) + (declare (fixnum index) + (simple-vector table)) + (when (eql index (length table)) + (setf table (grow-fop-vector table index) + *fop-table* table)) + (setf (aref table 0) index + (aref table index) thing))) + +;;; These three routines are used for both the stack and the table. +(defun make-fop-vector (size) + (declare (index size)) + (let ((vector (make-array size))) + (setf (aref vector 0) 0) + vector)) + +(defun grow-fop-vector (old-vector old-size) + (declare (simple-vector old-vector) + (index old-size)) + (let* ((new-size (* old-size 2)) + (new-vector (make-array new-size))) + (declare (fixnum new-size) + (simple-vector new-vector old-vector)) + (replace new-vector old-vector) + (nuke-fop-vector old-vector) + new-vector)) + +(defun nuke-fop-vector (vector) + (declare (simple-vector vector) + (optimize speed)) + ;; Make sure we don't keep any garbage. + #!+gencgc + (fill vector 0)) + ;;;; the fop stack -;;; (This is to be bound by LOAD to an adjustable (VECTOR T) with -;;; FILL-POINTER, for use as a stack with VECTOR-PUSH-EXTEND.) +;;; Much like the table, this is bound to a simple vector whose first +;;; element is the current index. (defvar *fop-stack*) -(declaim (type (vector t) *fop-stack*)) - -;;; Cache information about the fop stack in local variables. Define a -;;; local macro to pop from the stack. Push the result of evaluation +(declaim (simple-vector *fop-stack*)) + +(defun fop-stack-empty-p () + (eql 0 (svref *fop-stack* 0))) + +(defun pop-fop-stack () + (let* ((stack *fop-stack*) + (top (svref stack 0))) + (declare (index top)) + (when (eql 0 top) + (error "FOP stack empty")) + (setf (svref stack 0) (1- top)) + (svref stack top))) + +(defun push-fop-stack (value) + (let* ((stack *fop-stack*) + (next (1+ (the index (svref stack 0))))) + (declare (index next)) + (when (eql (length stack) next) + (setf stack (grow-fop-vector stack next) + *fop-stack* stack)) + (setf (svref stack 0) next + (svref stack next) value))) + +;;; Define a local macro to pop from the stack. Push the result of evaluation ;;; if PUSHP. (defmacro with-fop-stack (pushp &body forms) (aver (member pushp '(nil t :nope))) - (with-unique-names (fop-stack) - `(let ((,fop-stack *fop-stack*)) - (declare (type (vector t) ,fop-stack) - (ignorable ,fop-stack)) - (macrolet ((pop-stack () - `(vector-pop ,',fop-stack)) - (push-stack (value) - `(vector-push-extend ,value ,',fop-stack)) - (call-with-popped-args (fun n) - `(%call-with-popped-args ,fun ,n ,',fop-stack))) - ,(if pushp - `(vector-push-extend (progn ,@forms) ,fop-stack) - `(progn ,@forms)))))) + `(macrolet ((pop-stack () + `(pop-fop-stack)) + (push-stack (value) + `(push-fop-stack ,value))) + ,(if pushp + `(push-fop-stack (progn ,@forms)) + `(progn ,@forms)))) ;;; Call FUN with N arguments popped from STACK. -(defmacro %call-with-popped-args (fun n stack) +(defmacro call-with-popped-args (fun n) ;; N's integer value must be known at macroexpansion time. (declare (type index n)) - (with-unique-names (n-stack old-length new-length) + (with-unique-names (n-stack old-top new-top) (let ((argtmps (make-gensym-list n))) - `(let* ((,n-stack ,stack) - (,old-length (fill-pointer ,n-stack)) - (,new-length (- ,old-length ,n)) - ,@(loop for i from 0 below n collecting - `(,(nth i argtmps) - (aref ,n-stack (+ ,new-length ,i))))) - (declare (type (vector t) ,n-stack)) - (setf (fill-pointer ,n-stack) ,new-length) + `(let* ((,n-stack *fop-stack*) + (,old-top (svref ,n-stack 0)) + (,new-top (- ,old-top ,n)) + ,@(loop for i from 1 upto n collecting + `(,(nth (1- i) argtmps) + (aref ,n-stack (+ ,new-top ,i))))) + (declare (simple-vector ,n-stack)) + (setf (svref ,n-stack 0) ,new-top) ;; (For some applications it might be appropriate to FILL the ;; popped area with NIL here, to avoid holding onto garbage. For ;; sbcl-0.8.7.something, though, it shouldn't matter, because @@ -397,8 +430,8 @@ (defun load-fasl-group (stream) (when (check-fasl-header stream) (catch 'fasl-group-end - (let ((*current-fop-table-index* 0) - (*skip-until* nil)) + (reset-fop-table) + (let ((*skip-until* nil)) (declare (special *skip-until*)) (loop (let ((byte (read-byte stream))) @@ -406,12 +439,12 @@ #!+sb-show (when *show-fops-p* (let* ((stack *fop-stack*) - (ptr (1- (fill-pointer *fop-stack*)))) + (ptr (svref stack 0))) (fresh-line *trace-output*) ;; The FOP operations are stack based, so it's sorta ;; logical to display the operand before the operator. ;; ("reverse Polish notation") - (unless (= ptr -1) + (unless (= ptr 0) (write-char #\space *trace-output*) (prin1 (aref stack ptr) *trace-output*) (terpri *trace-output*)) @@ -437,17 +470,14 @@ (maybe-announce-load stream verbose) (with-world-lock () (let* ((*fasl-input-stream* stream) - (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) - (*current-fop-table-size* (length *current-fop-table*)) - (*fop-stack* (make-array 100 :fill-pointer 0 :adjustable t))) + (*fop-table* (make-fop-vector 1000)) + (*fop-stack* (make-fop-vector 100))) (unwind-protect (loop while (load-fasl-group stream)) - (push *current-fop-table* *free-fop-tables*) - ;; NIL out the table, so that we don't hold onto garbage. - ;; - ;; FIXME: Could we just get rid of the free fop table pool so - ;; that this would go away? - (fill *current-fop-table* nil)))) + ;; Nuke the table and stack to avoid keeping garbage on + ;; conservatively collected platforms. + (nuke-fop-vector *fop-table*) + (nuke-fop-vector *fop-stack*)))) t) (declaim (notinline read-byte)) ; Why is it even *declaimed* inline above? diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 91422bb..ed55374 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -2123,7 +2123,7 @@ core and return a descriptor to it." (let ((index (read-arg ,package-len))) (push-fop-table (cold-load-symbol (read-arg ,pname-len) - (svref *current-fop-table* index))))))) + (ref-fop-table index))))))) (frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes) (frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes) (frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1) @@ -2390,17 +2390,17 @@ core and return a descriptor to it." ;;;; cold fops for fixing up circularities (define-cold-fop (fop-rplaca :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-memory (cold-nthcdr idx obj) (pop-stack)))) (define-cold-fop (fop-rplacd :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack)))) (define-cold-fop (fop-svset :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed obj (+ idx @@ -2410,7 +2410,7 @@ core and return a descriptor to it." (pop-stack)))) (define-cold-fop (fop-structset :pushp nil) - (let ((obj (svref *current-fop-table* (read-word-arg))) + (let ((obj (ref-fop-table (read-word-arg))) (idx (read-word-arg))) (write-wordindexed obj (1+ idx) (pop-stack)))) -- 1.7.10.4