X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug-dump.lisp;h=43a1a1e526abee38dcbaa511d6a5490fd3b8fdb5;hb=fc999187f3f80dfcf170348df676386b8403e261;hp=73f3aedb5e6dc1c24ea544a4eaed742d53109db8;hpb=20748f2dd7965dcd1446a1cb27e5a5af18a0e5bb;p=sbcl.git diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 73f3aed..43a1a1e 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -71,7 +71,7 @@ (when (and (lambda-var-p leaf) (or (not (member (tn-kind tn) '(:environment :debug-environment))) - (rassoc leaf (lexenv-variables (node-lexenv node)))) + (rassoc leaf (lexenv-vars (node-lexenv node)))) (or (null spilled) (not (member tn spilled)))) (let ((num (gethash leaf var-locs))) @@ -175,14 +175,14 @@ ;;; Dump the successors of Block, being careful not to fly into space ;;; on weird successors. -(defun dump-block-successors (block env) - (declare (type cblock block) (type physenv env)) +(defun dump-block-successors (block physenv) + (declare (type cblock block) (type physenv physenv)) (let* ((tail (component-tail (block-component block))) (succ (block-succ block)) (valid-succ (if (and succ (or (eq (car succ) tail) - (not (eq (block-physenv (car succ)) env)))) + (not (eq (block-physenv (car succ)) physenv)))) () succ))) (vector-push-extend @@ -190,7 +190,7 @@ *byte-buffer*) (let ((base (block-number (node-block - (lambda-bind (physenv-function env)))))) + (lambda-bind (physenv-lambda physenv)))))) (dolist (b valid-succ) (write-var-integer (the index (- (block-number b) base)) @@ -209,17 +209,17 @@ (setf (fill-pointer *byte-buffer*) 0) (let ((*previous-location* 0) (tlf-num (find-tlf-number fun)) - (env (lambda-physenv fun)) + (physenv (lambda-physenv fun)) (prev-locs nil) (prev-block nil)) (collect ((elsewhere)) - (do-physenv-ir2-blocks (2block env) + (do-physenv-ir2-blocks (2block physenv) (let ((block (ir2-block-block 2block))) (when (eq (block-info block) 2block) (when prev-block (dump-block-locations prev-block prev-locs tlf-num var-locs)) (setq prev-block block prev-locs ()) - (dump-block-successors block env))) + (dump-block-successors block physenv))) (collect ((here prev-locs)) (dolist (loc (ir2-block-locations 2block)) @@ -240,7 +240,7 @@ ;;; Return a list of DEBUG-SOURCE structures containing information ;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always -;;; dump the Start-Positions, since it is too hard figure out whether +;;; dump the START-POSITIONS, since it is too hard figure out whether ;;; we need them or not. (defun debug-source-for-info (info) (declare (type source-info info)) @@ -277,12 +277,7 @@ ;;; a vector whose element size is an integer multiple of output byte ;;; size. (defun coerce-to-smallest-eltype (seq) - (let ((maxoid #-sb-xc-host 0 - ;; An initial value of 255 prevents us from - ;; specializing the array to anything smaller than - ;; (UNSIGNED-BYTE 8), which keeps the cross-compiler's - ;; portable specialized array output functions happy. - #+sb-xc-host 255)) + (let ((maxoid 0)) (flet ((frob (x) (if (typep x 'unsigned-byte) (when (>= x maxoid) @@ -294,7 +289,30 @@ (frob i)) (dovector (i seq) (frob i))) - (coerce seq `(simple-array (integer 0 ,maxoid) (*)))))) + (let ((specializer `(unsigned-byte + ,(etypecase maxoid + ((unsigned-byte 8) 8) + ((unsigned-byte 16) 16) + ((unsigned-byte 32) 32))))) + ;; cross-compilers beware! It would be possible for the + ;; upgraded-array-element-type of (UNSIGNED-BYTE 16) to be + ;; (SIGNED-BYTE 17) or (UNSIGNED-BYTE 23), and this is + ;; completely valid by ANSI. However, the cross-compiler + ;; doesn't know how to dump (in practice) anything but the + ;; above three specialized array types, so make it break here + ;; if this is violated. + #+sb-xc-host + (aver + ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are + ;; worried about whether the host's implementation of arrays. + (let ((uaet (upgraded-array-element-type specializer))) + (dolist (et '((unsigned-byte 8) + (unsigned-byte 16) + (unsigned-byte 32)) + nil) + (when (and (subtypep et uaet) (subtypep uaet et)) + (return t))))) + (coerce seq `(simple-array ,specializer (*))))))) ;;;; variables @@ -304,16 +322,16 @@ (make-sc-offset (sc-number (tn-sc tn)) (tn-offset tn))) -;;; Dump info to represent Var's location being TN. ID is an integer -;;; that makes Var's name unique in the function. Buffer is the vector -;;; we stick the result in. If Minimal is true, we suppress name -;;; dumping, and set the minimal flag. +;;; Dump info to represent VAR's location being TN. ID is an integer +;;; that makes VAR's name unique in the function. BUFFER is the vector +;;; we stick the result in. If MINIMAL, we suppress name dumping, and +;;; set the minimal flag. ;;; -;;; The debug-var is only marked as always-live if the TN is -;;; environment live and is an argument. If a :debug-environment TN, +;;; The DEBUG-VAR is only marked as always-live if the TN is +;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN, ;;; then we also exclude set variables, since the variable is not ;;; guaranteed to be live everywhere in that case. -(defun dump-1-variable (fun var tn id minimal buffer) +(defun dump-1-var (fun var tn id minimal buffer) (declare (type lambda-var var) (type (or tn null) tn) (type index id) (type clambda fun)) (let* ((name (leaf-debug-name var)) @@ -348,12 +366,12 @@ (vector-push-extend (tn-sc-offset save-tn) buffer))) (values)) -;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES +;;; Return a vector suitable for use as the DEBUG-FUN-VARS ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a ;;; hash table in which we enter the translation from LAMBDA-VARS to ;;; the relative position of that variable's location in the resulting ;;; vector. -(defun compute-variables (fun level var-locs) +(defun compute-vars (fun level var-locs) (declare (type clambda fun) (type hash-table var-locs)) (collect ((vars)) (labels ((frob-leaf (leaf tn gensym-p) @@ -366,8 +384,7 @@ (frob-leaf leaf (leaf-info leaf) gensym-p)))) (frob-lambda fun t) (when (>= level 2) - (dolist (x (ir2-physenv-environment - (physenv-info (lambda-physenv fun)))) + (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun)))) (let ((thing (car x))) (when (lambda-var-p thing) (frob-leaf thing (cdr x) (= level 3))))) @@ -376,8 +393,8 @@ (frob-lambda let (= level 3))))) (let ((sorted (sort (vars) #'string< - :key #'(lambda (x) - (symbol-name (leaf-debug-name (car x)))))) + :key (lambda (x) + (symbol-name (leaf-debug-name (car x)))))) (prev-name nil) (id 0) (i 0) @@ -391,18 +408,18 @@ (incf id)) (t (setq id 0 prev-name name))) - (dump-1-variable fun var (cdr x) id nil buffer) + (dump-1-var fun var (cdr x) id nil buffer) (setf (gethash var var-locs) i)) (incf i)) (coerce buffer 'simple-vector)))) -;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES of +;;; Return a vector suitable for use as the DEBUG-FUN-VARS of ;;; FUN, representing the arguments to FUN in minimal variable format. -(defun compute-minimal-variables (fun) +(defun compute-minimal-vars (fun) (declare (type clambda fun)) (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t))) (dolist (var (lambda-vars fun)) - (dump-1-variable fun var (leaf-info var) 0 t buffer)) + (dump-1-var fun var (leaf-info var) 0 t buffer)) (coerce buffer 'simple-vector))) ;;; Return VAR's relative position in the function's variables (determined @@ -418,14 +435,14 @@ ;;;; arguments/returns -;;; Return a vector to be used as the -;;; COMPILED-DEBUG-FUN-ARGUMENTS for Fun. If fun is the -;;; MAIN-ENTRY for an optional dispatch, then look at the ARGLIST to -;;; determine the syntax, otherwise pretend all arguments are fixed. +;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN. +;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at +;;; the ARGLIST to determine the syntax, otherwise pretend all +;;; arguments are fixed. ;;; ;;; ### This assumption breaks down in EPs other than the main-entry, ;;; since they may or may not have supplied-p vars, etc. -(defun compute-arguments (fun var-locs) +(defun compute-args (fun var-locs) (declare (type clambda fun) (type hash-table var-locs)) (collect ((res)) (let ((od (lambda-optional-dispatch fun))) @@ -462,8 +479,8 @@ ;;; (Must be known values return...) (defun compute-debug-returns (fun) (coerce-to-smallest-eltype - (mapcar #'(lambda (loc) - (tn-sc-offset loc)) + (mapcar (lambda (loc) + (tn-sc-offset loc)) (return-info-locations (tail-set-info (lambda-tail-set fun)))))) ;;;; debug functions @@ -499,21 +516,21 @@ (let ((od (lambda-optional-dispatch fun))) (or (not od) (not (eq (optional-dispatch-main-entry od) fun))))) - (setf (compiled-debug-fun-variables dfun) - (compute-minimal-variables fun)) + (setf (compiled-debug-fun-vars dfun) + (compute-minimal-vars fun)) (setf (compiled-debug-fun-arguments dfun) :minimal)) (t - (setf (compiled-debug-fun-variables dfun) - (compute-variables fun level var-locs)) + (setf (compiled-debug-fun-vars dfun) + (compute-vars fun level var-locs)) (setf (compiled-debug-fun-arguments dfun) - (compute-arguments fun var-locs)))) + (compute-args fun var-locs)))) (when (>= level 2) (multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs) (setf (compiled-debug-fun-tlf-number dfun) tlf-num) (setf (compiled-debug-fun-blocks dfun) blocks))) - (if (external-entry-point-p fun) + (if (xep-p fun) (setf (compiled-debug-fun-returns dfun) :standard) (let ((info (tail-set-info (lambda-tail-set fun)))) (when info @@ -546,25 +563,30 @@ ;;; called after assembly so that source map information is available. (defun debug-info-for-component (component) (declare (type component component)) - (collect ((dfuns)) - (let ((var-locs (make-hash-table :test 'eq)) - (*byte-buffer* (make-array 10 - :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t))) - (dolist (fun (component-lambdas component)) - (clrhash var-locs) - (dfuns (cons (label-position (block-label (lambda-block fun))) - (compute-1-debug-fun fun var-locs)))) - (let* ((sorted (sort (dfuns) #'< :key #'car)) - (fun-map (compute-debug-fun-map sorted))) - (make-compiled-debug-info :name (component-name component) - :fun-map fun-map))))) + (let ((dfuns nil) + (var-locs (make-hash-table :test 'eq)) + (*byte-buffer* (make-array 10 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t))) + (dolist (lambda (component-lambdas component)) + (clrhash var-locs) + (push (cons (label-position (block-label (lambda-block lambda))) + (compute-1-debug-fun lambda var-locs)) + dfuns)) + (let* ((sorted (sort dfuns #'< :key #'car)) + (fun-map (compute-debug-fun-map sorted))) + (make-compiled-debug-info :name (component-name component) + :fun-map fun-map)))) ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of ;;; BITS must be evenly divisible by eight. (defun write-packed-bit-vector (bits byte-buffer) (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer)) + + ;; Enforce constraint from CMU-CL-era comment. + (aver (zerop (mod (length bits) 8))) + (multiple-value-bind (initial step done) (ecase *backend-byte-order* (:little-endian (values 0 1 8))