diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp index a467ed92a6c7d228003d440f090d8e2b81275b19..d18986fe5192cdfefcbf0f412ff87751d23e43e0 100644 --- a/compiler/disassem.lisp +++ b/compiler/disassem.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.9 1992/07/23 16:32:20 hallgren Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.10 1992/07/30 13:18:56 hallgren Exp $") ;;; ;;; ********************************************************************** ;;; @@ -16,7 +16,7 @@ ;;; Written by Miles Bader <miles@cogsci.ed.ac.uk> ;;; -(in-package :disassem :nicknames '(:disassem)) +(in-package :disassem) (use-package :extensions) @@ -36,6 +36,7 @@ disassemble-memory disassemble-function disassemble-code-component + disassemble-blocks ;; some variables to set *opcode-column-width* @@ -2298,10 +2299,10 @@ (leading-zeros (truncate (- printed-bits (integer-length printed-value)) 4))) (dotimes (i leading-zeros) - (write-char #\0)) + (write-char #\0 stream)) (unless (zerop printed-value) (write printed-value :stream stream :base 16 :radix nil)) - (write-char #\:)) + (write-char #\: stream)) ;; print any labels (loop @@ -3190,6 +3191,103 @@ (label-segments segments dstate)) (disassemble-segments segments stream dstate))) +;;; Code for disassembling segments. + +(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 (system:sap+ sap start))) + (dotimes (i length) + (setf (aref result i) (system: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:disassem-state dstate)) + (flet ((addit (seg overflow) + (let ((length (+ (disassem:seg-length seg) overflow))) + (when (> length 0) + (setf (disassem: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 (> (length connecting-vec) 0) + (let ((seg + (disassem:make-vector-segment connecting-vec + 0 + (- (length connecting-vec) + beginning-of-block-amount) + :virtual-location location))) + (setf connecting-overflow (disassem:segment-overflow seg dstate)) + (addit seg connecting-overflow))))) + (if sap + (let* ((initial-length + (max (- amount + connecting-overflow + max-instruction-size) + 0)) + (seg + (disassem:make-segment + #'(lambda () + (system:sap+ sap connecting-overflow)) + initial-length + :virtual-location location)) + (overflow + (disassem:segment-overflow seg dstate))) + (addit seg overflow) + (values seglist location + (sap-to-vector sap + (+ connecting-overflow + (disassem:seg-length seg) + overflow) + amount))) + (values seglist location nil))))) + +(defun blocks-to-segments (segment dstate) + (declare (type new-assem:segment segment) + (type disassem:disassem-state dstate)) + (let ((location 0) + (segments nil) + (connecting-vec nil)) + (new-assem:segment-map-output + segment + #'(lambda (sap amount) + (multiple-value-setq (segments location connecting-vec) + (add-block-segments sap amount segments location connecting-vec + dstate)))) + (when connecting-vec + (setf segments + (add-block-segments nil nil segments location connecting-vec + dstate))) + (sort segments #'< :key #'disassem:seg-virtual-location))) + +(defun disassemble-blocks (segment stream backend) + "Disassemble the machine code instructions associated with + SEGMENT (of type new-assem::segment)." + (declare (type new-assem:segment segment) + (type stream stream) + (type c::backend backend)) + (let* ((dstate (disassem:make-dstate (c:backend-disassem-params backend))) + (segments (blocks-to-segments segment dstate))) + (disassem:label-segments segments dstate) + (disassem:disassemble-segments segments stream dstate))) + + ;;; ---------------------------------------------------------------- ;;; Routines to find things in the lisp environment. Obviously highly ;;; implementation specific!