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.

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)))))

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

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

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))

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"