-;;; Code for making useful segments from arbitrary lists of code-blocks
-
-;;; The maximum size of an instruction -- this includes pseudo-instructions
-;;; like error traps with their associated operands, so it should be big enough
-;;; to include them (i.e. it's not just 4 on a risc machine!).
-(defconstant max-instruction-size 16)
-
-(defun sap-to-vector (sap start end)
- (let* ((length (- end start))
- (result (make-array length :element-type '(unsigned-byte 8)))
- (sap (sb!sys:sap+ sap start)))
- (dotimes (i length)
- (setf (aref result i) (sb!sys:sap-ref-8 sap i)))
- result))
-
-(defun add-block-segments (sap amount seglist location connecting-vec dstate)
- (declare (type list seglist)
- (type integer location)
- (type (or null (vector (unsigned-byte 8))) connecting-vec)
- (type disassem-state dstate))
- (flet ((addit (seg overflow)
- (let ((length (+ (seg-length seg) overflow)))
- (when (> length 0)
- (setf (seg-length seg) length)
- (incf location length)
- (push seg seglist)))))
- (let ((connecting-overflow 0))
- (when connecting-vec
- ;; tack on some of the new block to the old overflow vector
- (let* ((beginning-of-block-amount
- (if sap (min max-instruction-size amount) 0))
- (connecting-vec
- (if sap
- (concatenate
- '(vector (unsigned-byte 8))
- connecting-vec
- (sap-to-vector sap 0 beginning-of-block-amount))
- connecting-vec)))
- (when (and (< (length connecting-vec) max-instruction-size)
- (not (null sap)))
- (return-from add-block-segments
- ;; We want connecting vectors to be large enough to hold
- ;; any instruction, and since the current sap wasn't large
- ;; enough to do this (and is now entirely on the end of the
- ;; overflow-vector), just save it for next time.
- (values seglist location connecting-vec)))
- (when (> (length connecting-vec) 0)
- (let ((seg
- (make-vector-segment connecting-vec
- 0
- (- (length connecting-vec)
- beginning-of-block-amount)
- :virtual-location location)))
- (setf connecting-overflow (segment-overflow seg dstate))
- (addit seg connecting-overflow)))))
- (cond ((null sap)
- ;; Nothing more to add.
- (values seglist location nil))
- ((< (- amount connecting-overflow) max-instruction-size)
- ;; We can't create a segment with the minimum size
- ;; required for an instruction, so just keep on accumulating
- ;; in the overflow vector for the time-being.
- (values seglist
- location
- (sap-to-vector sap connecting-overflow amount)))
- (t
- ;; Put as much as we can into a new segment, and the rest
- ;; into the overflow-vector.
- (let* ((initial-length
- (- amount connecting-overflow max-instruction-size))
- (seg
- (make-segment #'(lambda ()
- (sb!sys:sap+ sap connecting-overflow))
- initial-length
- :virtual-location location))
- (overflow
- (segment-overflow seg dstate)))
- (addit seg overflow)
- (values seglist
- location
- (sap-to-vector sap
- (+ connecting-overflow (seg-length seg))
- amount))))))))
-\f