From: Juho Snellman Date: Sat, 13 May 2006 18:33:40 +0000 (+0000) Subject: 0.9.12.14: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=30479182014bc1e02f54d330643ca45605e3530d;p=sbcl.git 0.9.12.14: Get rid of some low-level hotspots in the compiler: * Use simple-arrays for assembler segment buffers. * Move the checking of policy variable name validity from run-time to compile-time where possible. * In POLICY, don't fetch the values of optimization qualities that aren't used in the body. * When creating debug-names, don't call FORMAT when encountering values of unhandled types. Instead mark them with a suitable s-exp. --- diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 4b90328..2e6fd3e 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -30,12 +30,12 @@ (name "unnamed" :type simple-string) ;; Ordinarily this is a vector where instructions are written. If ;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the - ;; vector can be replaced by NIL. - (buffer (make-array 0 - :fill-pointer 0 - :adjustable t - :element-type 'assembly-unit) - :type (or null (vector assembly-unit))) + ;; vector can be replaced by NIL. This used to be an adjustable + ;; array, but we now do the array size management manually for + ;; performance reasons (as of 2006-05-13 hairy array operations + ;; are rather slow compared to simple ones). + (buffer (make-array 0 :element-type 'assembly-unit) + :type (or null (simple-array assembly-unit))) ;; whether or not to run the scheduler. Note: if the instruction ;; definitions were not compiled with the scheduler turned on, this ;; has no effect. @@ -48,6 +48,7 @@ ;; indexes are the same, but after we start collapsing choosers, ;; positions can change while indexes stay the same. (current-posn 0 :type index) + (%current-index 0 :type index) ;; a list of all the annotations that have been output to this segment (annotations nil :type list) ;; a pointer to the last cons cell in the annotations list. This is @@ -108,11 +109,13 @@ (sb!c::defprinter (segment) name) -;;; where the next byte of output goes -#!-sb-fluid (declaim (inline segment-current-index)) +(declaim (inline segment-current-index)) (defun segment-current-index (segment) - (fill-pointer (segment-buffer segment))) + (segment-%current-index segment)) + (defun (setf segment-current-index) (new-value segment) + (declare (type index new-value) + (type segment segment)) ;; FIXME: It would be lovely to enforce this, but first FILL-IN will ;; need to be convinced to stop rolling SEGMENT-CURRENT-INDEX ;; backwards. @@ -121,19 +124,26 @@ ;; about what's going on in the (legacy) code: The segment never ;; shrinks. -- WHN the reverse engineer #+nil (aver (>= new-value (segment-current-index segment))) - (let ((buffer (segment-buffer segment))) - ;; Make sure that the array is big enough. - (do () - ((>= (array-dimension buffer 0) new-value)) - ;; When we have to increase the size of the array, we want to - ;; roughly double the vector length: that way growing the array - ;; to size N conses only O(N) bytes in total. But just doubling - ;; the length would leave a zero-length vector unchanged. Hence, - ;; take the MAX with 1.. - (adjust-array buffer (max 1 (* 2 (array-dimension buffer 0))))) + (let* ((buffer (segment-buffer segment)) + (new-buffer-size (length buffer))) + (declare (type (simple-array (unsigned-byte 8)) buffer) + (type index new-buffer-size)) + ;; Make sure the array is big enough. + (when (<= new-buffer-size new-value) + (do () + ((> new-buffer-size new-value)) + ;; When we have to increase the size of the array, we want to + ;; roughly double the vector length: that way growing the array + ;; to size N conses only O(N) bytes in total. But just doubling + ;; the length would leave a zero-length vector unchanged. Hence, + ;; take the MAX with 1.. + (setf new-buffer-size (max 1 (* 2 new-buffer-size)))) + (let ((new-buffer (make-array new-buffer-size + :element-type '(unsigned-byte 8)))) + (replace new-buffer buffer) + (setf (segment-buffer segment) new-buffer))) ;; Now that the array has the intended next free byte, we can point to it. - (setf (fill-pointer buffer) new-value))) - + (setf (segment-%current-index segment) new-value))) ;;; Various functions (like BACK-PATCH-FUN or CHOOSER-WORST-CASE-FUN) ;;; aren't cleanly parameterized, but instead use @@ -748,8 +758,10 @@ (defun emit-byte (segment byte) (declare (type segment segment)) (declare (type possibly-signed-assembly-unit byte)) - (vector-push-extend (logand byte assembly-unit-mask) - (segment-buffer segment)) + (let ((old-index (segment-current-index segment))) + (incf (segment-current-index segment)) + (setf (aref (segment-buffer segment) old-index) + (logand byte assembly-unit-mask))) (incf (segment-current-posn segment)) (values)) @@ -1340,6 +1352,7 @@ (declare (type function function)) (let ((buffer (segment-buffer segment)) (i0 0)) + (declare (type (simple-array (unsigned-byte 8)) buffer)) (flet ((frob (i0 i1) (when (< i0 i1) (funcall function (subseq buffer i0 i1))))) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 515701a..3ec3798 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -190,7 +190,7 @@ convention (names like *FOO*) for special variables" symbol)) ((or symbol number string) x) (t - (format nil "#<~S>" (type-of x)))) + (list 'of-type (type-of x)))) "#<...>"))) ;; FIXME: It might be nice to put markers in the tree instead of ;; this #<...> business, so that they would evantually be printed diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index fae8e19..0e7a4eb 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -102,16 +102,15 @@ *policy-qualities*)) (dependent-binds (loop for (name . info) in *policy-dependent-qualities* - collect `(,name (policy-quality ,n-policy ',name)) - collect `(,name (if (= ,name 1) - ,(policy-dependent-quality-expression info) - ,name))))) - `(let* ((,n-policy (%coerce-to-policy ,thing)) - ,@binds - ,@dependent-binds) - (declare (ignorable ,@*policy-qualities* - ,@(mapcar #'car *policy-dependent-qualities*))) - ,expr))) + collect `(,name (let ((,name (policy-quality ,n-policy ',name))) + (if (= ,name 1) + ,(policy-dependent-quality-expression info) + ,name)))))) + `(let* ((,n-policy (%coerce-to-policy ,thing))) + (declare (ignorable ,n-policy)) + (symbol-macrolet (,@binds + ,@dependent-binds) + ,expr)))) ;;; Dependent qualities (defmacro define-optimization-quality diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index fa72708..d2d096e 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -4039,3 +4039,17 @@ (give-up-ir1-transform "not a real transform")) (defun /report-lvar (x message) (declare (ignore x message)))) + + +;;;; Transforms for internal compiler utilities + +;;; If QUALITY-NAME is constant and a valid name, don't bother +;;; checking that it's still valid at run-time. +(deftransform policy-quality ((policy quality-name) + (t symbol)) + (unless (and (constant-lvar-p quality-name) + (policy-quality-name-p (lvar-value quality-name))) + (give-up-ir1-transform)) + `(let* ((acons (assoc quality-name policy)) + (result (or (cdr acons) 1))) + result)) diff --git a/version.lisp-expr b/version.lisp-expr index ce0e226..6bca97b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.12.13" +"0.9.12.14"