(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.
;; 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
(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.
;; 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
(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))
;;; This holds the current segment while assembling. Use ASSEMBLE to
;;; change it.
;;;
-;;; The double parens in the name are intended to suggest that this
+;;; The double asterisks in the name are intended to suggest that this
;;; isn't just any old special variable, it's an extra-special
;;; variable, because sometimes MACROLET is used to bind it. So be
;;; careful out there..
;; Must be done so that contribs and user code doing
;; low-level stuff don't need to worry about this.
(disable-package-locks %%current-segment%% %%current-vop%%))
- (macrolet ((%%current-segment%% () '**current-segment**)
- (%%current-vop%% () '**current-vop**))
+ (macrolet ((%%current-segment%% () ',seg-var)
+ (%%current-vop%% () ',vop-var))
;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
;; can't deal with this declaration, so disable it on host.
;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration.
`(,name (gen-label)))
new-labels))
(declare (ignorable ,vop-var ,seg-var))
- (macrolet ((%%current-segment%% () '**current-segment**)
- (%%current-vop%% () '**current-vop**))
+ (macrolet ((%%current-segment%% () ',seg-var)
+ (%%current-vop%% () ',vop-var))
(symbol-macrolet (,@(when (or inherited-labels nested-labels)
`((..inherited-labels.. ,nested-labels))))
,@(mapcar (lambda (form)
(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)))))
(defmacro define-instruction-macro (name lambda-list &body body)
(with-unique-names (whole env)
(multiple-value-bind (body local-defs)
- (sb!kernel:parse-defmacro lambda-list
- whole
- body
- name
+ (sb!kernel:parse-defmacro lambda-list whole body name
'instruction-macro
:environment env)
`(eval-when (:compile-toplevel :load-toplevel :execute)
projects / sbcl.git / blobdiff