X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=4b73b0b42777786d9adfe73b5e7d4b0f2536eb9a;hb=1e9966d5f24709d227e20911b4e1ddd27c87a00e;hp=0a6fa384789d7c98ed9a5045c189995db236db8c;hpb=f6a2be77637d025bfded9430f02863c28f74f77a;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 0a6fa38..4b73b0b 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 @@ -260,7 +261,7 @@ (:copier nil)) (sap-maker (missing-arg) :type (function () sb!sys:system-area-pointer)) - (length 0 :type length) + (length 0 :type disassem-length) (virtual-location 0 :type address) (storage-info nil :type (or null storage-info)) (code nil :type (or null sb!kernel:code-component)) @@ -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) - ;; OFFS-HOOKs, popped as they're 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) @@ -354,9 +290,15 @@ (declare (type compiled-function fun)) (sb!kernel:%simple-fun-next fun)) -(defun fun-address (function) - (declare (type compiled-function function)) - (- (sb!kernel:get-lisp-obj-address function) sb!vm:fun-pointer-lowtag)) +(defun fun-address (fun) + (declare (type compiled-function fun)) + (ecase (sb!kernel:widetag-of fun) + (#.sb!vm:simple-fun-header-widetag + (- (sb!kernel:get-lisp-obj-address fun) sb!vm:fun-pointer-lowtag)) + (#.sb!vm:closure-header-widetag + (fun-address (sb!kernel:%closure-fun fun))) + (#.sb!vm:funcallable-instance-header-widetag + (fun-address (sb!kernel:funcallable-instance-fun fun))))) ;;; the offset of FUNCTION from the start of its code-component's ;;; instruction area @@ -506,7 +448,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 +469,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 +510,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 +523,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))) @@ -911,7 +853,7 @@ debug-fun source-form-cache hooks) (declare (type (function () sb!sys:system-area-pointer) sap-maker) - (type length length) + (type disassem-length length) (type (or null address) virtual-location) (type (or null sb!di:debug-fun) debug-fun) (type (or null source-form-cache) source-form-cache)) @@ -1389,7 +1331,7 @@ (length (code-inst-area-length code))) (declare (type sb!kernel:code-component code) (type offset start-offset) - (type length length)) + (type disassem-length length)) (let ((segments nil)) (when code (let ((fun-map (code-fun-map code)) @@ -1531,9 +1473,7 @@ (compile nil lambda))) (defun compiled-fun-or-lose (thing &optional (name thing)) - (cond ((or (symbolp thing) - (and (listp thing) - (eq (car thing) 'setf))) + (cond ((legal-fun-name-p thing) (compiled-fun-or-lose (fdefinition thing) thing)) ((functionp thing) thing) @@ -1571,7 +1511,7 @@ code-component (use-labels t)) (declare (type (or address sb!sys:system-area-pointer) address) - (type length length) + (type disassem-length length) (type stream stream) (type (or null sb!kernel:code-component) code-component) (type (member t nil) use-labels)) @@ -2016,8 +1956,7 @@ assoc-with (sb!di:debug-var-symbol (aref (dstate-debug-vars dstate) - storage-location)) - stream)) + storage-location)))) dstate) t)))