X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=453edf1a54446bc569793b045e2a13951d72c622;hb=fb91e1987cc40f3f698f2972d0de50426ec3086f;hp=8e042eec8e6aea46222938cf7a1606df3b9957b6;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 8e042ee..453edf1 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -44,8 +44,9 @@ (sort insts #'> :key #'specializer-rank)) (defun specialization-error (insts) - (error "~@" - insts)) + (bug + "~@" + insts)) ;;; Given a list of instructions INSTS, Sees if one of these instructions is a ;;; more general form of all the others, in which case they are put into its @@ -252,7 +253,7 @@ (defstruct (offs-hook (:copier nil)) (offset 0 :type offset) - (function (missing-arg) :type function) + (fun (missing-arg) :type function) (before-address nil :type (member t nil))) (defstruct (segment (:conc-name seg-) @@ -275,71 +276,6 @@ (seg-virtual-location seg) (seg-code seg))))) -;;; All state during disassembly. We store some seemingly redundant -;;; information so that we can allow garbage collect during disassembly and -;;; not get tripped up by a code block being moved... -(defstruct (disassem-state (:conc-name dstate-) - (:constructor %make-dstate) - (:copier nil)) - ;; offset of current pos in segment - (cur-offs 0 :type offset) - ;; offset of next position - (next-offs 0 :type offset) - ;; a sap pointing to our segment - (segment-sap (missing-arg) :type sb!sys:system-area-pointer) - ;; the current segment - (segment nil :type (or null segment)) - ;; what to align to in most cases - (alignment sb!vm:n-word-bytes :type alignment) - (byte-order :little-endian - :type (member :big-endian :little-endian)) - ;; for user code to hang stuff off of - (properties nil :type list) - (filtered-values (make-array max-filtered-value-index) - :type filtered-value-vector) - ;; used for prettifying printing - (addr-print-len nil :type (or null (integer 0 20))) - (argument-column 0 :type column) - ;; to make output look nicer - (output-state :beginning - :type (member :beginning - :block-boundary - nil)) - - ;; alist of (address . label-number) - (labels nil :type list) - ;; same as LABELS slot data, but in a different form - (label-hash (make-hash-table) :type hash-table) - ;; list of function - (fun-hooks nil :type list) - - ;; alist of (address . label-number), popped as it's used - (cur-labels nil :type list) ; - ;; list of offs-hook, popped as it's used - (cur-offs-hooks nil :type list) - - ;; for the current location - (notes nil :type list) - - ;; currently active source variables - (current-valid-locations nil :type (or null (vector bit)))) -(def!method print-object ((dstate disassem-state) stream) - (print-unreadable-object (dstate stream :type t) - (format stream - "+~W~@[ in ~S~]" - (dstate-cur-offs dstate) - (dstate-segment dstate)))) - -;;; Return the absolute address of the current instruction in DSTATE. -(defun dstate-cur-addr (dstate) - (the address (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate)))) - -;;; Return the absolute address of the next instruction in DSTATE. -(defun dstate-next-addr (dstate) - (the address (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-next-offs dstate)))) - ;;;; function ops (defun fun-self (fun) @@ -506,7 +442,7 @@ (setf (dstate-cur-offs dstate) 0) (setf (dstate-cur-labels dstate) (dstate-labels dstate))) -(defun do-offs-hooks (before-address stream dstate) +(defun call-offs-hooks (before-address stream dstate) (declare (type (or null stream) stream) (type disassem-state dstate)) (let ((cur-offs (dstate-cur-offs dstate))) @@ -527,7 +463,7 @@ (unless (= (dstate-next-offs dstate) cur-offs) (return))))))) -(defun do-fun-hooks (chunk stream dstate) +(defun call-fun-hooks (chunk stream dstate) (let ((hooks (dstate-fun-hooks dstate)) (cur-offs (dstate-cur-offs dstate))) (setf (dstate-next-offs dstate) cur-offs) @@ -568,10 +504,10 @@ (setf (dstate-next-offs dstate) (dstate-cur-offs dstate)) - (do-offs-hooks t stream dstate) + (call-offs-hooks t stream dstate) (unless (or prefix-p (null stream)) (print-current-address stream dstate)) - (do-offs-hooks nil stream dstate) + (call-offs-hooks nil stream dstate) (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) (sb!sys:without-gcing @@ -581,7 +517,7 @@ (sap-ref-dchunk (dstate-segment-sap dstate) (dstate-cur-offs dstate) (dstate-byte-order dstate)))) - (let ((fun-prefix-p (do-fun-hooks chunk stream dstate))) + (let ((fun-prefix-p (call-fun-hooks chunk stream dstate))) (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) (setf prefix-p fun-prefix-p) (let ((inst (find-inst chunk ispace))) @@ -858,7 +794,7 @@ ((null fun)) (let ((offset (code-offs-to-segment-offs (fun-offset fun) segment))) (when (<= 0 offset length) - (push (make-offs-hook :offset offset :function #'fun-header-hook) + (push (make-offs-hook :offset offset :fun #'fun-header-hook) (seg-hooks segment)))))) ;;; A SAP-MAKER is a no-argument function that returns a SAP. @@ -1236,8 +1172,8 @@ (let ((last-block-pc -1)) (flet ((add-hook (pc fun &optional before-address) (push (make-offs-hook - :offset pc ;; ##### FIX to account for non-zero offs in code - :function fun + :offset pc ;; ### FIX to account for non-zero offs in code + :fun fun :before-address before-address) (seg-hooks segment)))) (handler-case @@ -1303,20 +1239,20 @@ (storage-info-for-debug-fun debug-fun)) (add-source-tracking-hooks segment debug-fun sfcache) (let ((kind (sb!di:debug-fun-kind debug-fun))) - (flet ((anh (n) + (flet ((add-new-hook (n) (push (make-offs-hook :offset 0 - :function (lambda (stream dstate) - (declare (ignore stream)) - (note n dstate))) + :fun (lambda (stream dstate) + (declare (ignore stream)) + (note n dstate))) (seg-hooks segment)))) (case kind (:external) ((nil) - (anh "no-arg-parsing entry point")) + (add-new-hook "no-arg-parsing entry point")) (t - (anh (lambda (stream) - (format stream "~S entry point" kind))))))))) + (add-new-hook (lambda (stream) + (format stream "~S entry point" kind))))))))) ;;; Return a list of the segments of memory containing machine code ;;; instructions for FUNCTION.