X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug-dump.lisp;h=5a0df420897a0076ba9c15c0d23ca02a3bdfe7eb;hb=b05f52060838600d14b5d8ad4604a61351dd7017;hp=0a4ddd44eb19580c70119775942f01203f54fe7d;hpb=0aafa73007d42f2bc8e626f98a243019b7e63284;p=sbcl.git diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 0a4ddd4..5a0df42 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -46,10 +46,10 @@ (list location))) location)) -#!-sb-fluid (declaim (inline ir2-block-environment)) -(defun ir2-block-environment (2block) +#!-sb-fluid (declaim (inline ir2-block-physenv)) +(defun ir2-block-physenv (2block) (declare (type ir2-block 2block)) - (block-environment (ir2-block-block 2block))) + (block-physenv (ir2-block-block 2block))) ;;; Given a local conflicts vector and an IR2 block to represent the ;;; set of live TNs, and the VAR-LOCS hash-table representing the @@ -136,7 +136,7 @@ (declare (type clambda fun)) (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))) (declare (type (or index null) res)) - (do-environment-ir2-blocks (2block (lambda-environment fun)) + (do-physenv-ir2-blocks (2block (lambda-physenv fun)) (let ((block (ir2-block-block 2block))) (when (eq (block-info block) 2block) (unless (eql (source-path-tlf-number @@ -173,16 +173,16 @@ (dump-location-from-info loc tlf-num var-locs)) (values)) -;;; 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 environment env)) +;;; Dump the successors of Block, being careful not to fly into space +;;; on weird successors. +(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-environment (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 (environment-function env)))))) + (lambda-bind (physenv-lambda physenv)))))) (dolist (b valid-succ) (write-var-integer (the index (- (block-number b) base)) @@ -198,7 +198,7 @@ (values)) ;;; Return a vector and an integer (or null) suitable for use as the -;;; BLOCKS and TLF-NUMBER in Fun's debug-function. This requires two +;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN. This requires two ;;; passes to compute: ;;; -- Scan all blocks, dumping the header and successors followed ;;; by all the non-elsewhere locations. @@ -209,17 +209,17 @@ (setf (fill-pointer *byte-buffer*) 0) (let ((*previous-location* 0) (tlf-num (find-tlf-number fun)) - (env (lambda-environment fun)) + (physenv (lambda-physenv fun)) (prev-locs nil) (prev-block nil)) (collect ((elsewhere)) - (do-environment-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)) @@ -244,59 +244,56 @@ ;;; we need them or not. (defun debug-source-for-info (info) (declare (type source-info info)) - (assert (not (source-info-current-file info))) - (mapcar #'(lambda (x) - (let ((res (make-debug-source - :from :file - :created (file-info-write-date x) - :compiled (source-info-start-time info) - :source-root (file-info-source-root x) - :start-positions - (unless (eq *byte-compile* 't) - (coerce-to-smallest-eltype - (file-info-positions x))))) - (name (file-info-name x))) - (etypecase name - ((member :lisp) - (setf (debug-source-from res) name) - (setf (debug-source-name res) - (coerce (file-info-forms x) 'simple-vector))) - (pathname - (let* ((untruename (file-info-untruename x)) - (dir (pathname-directory untruename))) - (setf (debug-source-name res) - (namestring - (if (and dir (eq (first dir) :absolute)) - untruename - name)))))) - res)) - (source-info-files info))) + (let* ((file-info (source-info-file-info info)) + (res (make-debug-source + :from :file + :created (file-info-write-date file-info) + :compiled (source-info-start-time info) + :source-root (file-info-source-root file-info) + :start-positions (coerce-to-smallest-eltype + (file-info-positions file-info)))) + (name (file-info-name file-info))) + (etypecase name + ((member :lisp) + (setf (debug-source-from res) name) + (setf (debug-source-name res) + (coerce (file-info-forms file-info) 'simple-vector))) + (pathname + (let* ((untruename (file-info-untruename file-info)) + (dir (pathname-directory untruename))) + (setf (debug-source-name res) + (namestring + (if (and dir (eq (first dir) :absolute)) + untruename + name)))))) + (list res))) + ;;; Given an arbitrary sequence, coerce it to an unsigned vector if ;;; possible. Ordinarily we coerce it to the smallest specialized ;;; vector we can. However, we also have a special hack for ;;; cross-compiling at bootstrap time, when arbitrarily-specialized -;;; aren't fully supported: in that case, we coerce it only to a -;;; vector whose element size is an integer multiple of output byte +;;; vectors aren't fully supported: in that case, we coerce it only to +;;; 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 value of 255 prevents us from + ;; 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)) (flet ((frob (x) (if (typep x 'unsigned-byte) - (when (>= x maxoid) - (setf maxoid x)) - (return-from coerce-to-smallest-eltype - (coerce seq 'simple-vector))))) + (when (>= x maxoid) + (setf maxoid x)) + (return-from coerce-to-smallest-eltype + (coerce seq 'simple-vector))))) (if (listp seq) - (dolist (i seq) - (frob i)) - (dovector (i seq) - (frob i))) + (dolist (i seq) + (frob i)) + (dovector (i seq) + (frob i))) (coerce seq `(simple-array (integer 0 ,maxoid) (*)))))) ;;;; variables @@ -307,19 +304,19 @@ (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) (declare (type lambda-var var) (type (or tn null) tn) (type index id) (type clambda fun)) - (let* ((name (leaf-name var)) + (let* ((name (leaf-debug-name var)) (save-tn (and tn (tn-save-tn tn))) (kind (and tn (tn-kind tn))) (flags 0)) @@ -346,21 +343,21 @@ (vector-push-extend id buffer))) (if tn (vector-push-extend (tn-sc-offset tn) buffer) - (assert minimal)) + (aver minimal)) (when save-tn (vector-push-extend (tn-sc-offset save-tn) buffer))) (values)) -;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES +;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES ;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a -;;; hashtable in which we enter the translation from LAMBDA-VARS to +;;; 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) (declare (type clambda fun) (type hash-table var-locs)) (collect ((vars)) (labels ((frob-leaf (leaf tn gensym-p) - (let ((name (leaf-name leaf))) + (let ((name (leaf-debug-name leaf))) (when (and name (leaf-refs leaf) (tn-offset tn) (or gensym-p (symbol-package name))) (vars (cons leaf tn))))) @@ -369,8 +366,7 @@ (frob-leaf leaf (leaf-info leaf) gensym-p)))) (frob-lambda fun t) (when (>= level 2) - (dolist (x (ir2-environment-environment - (environment-info (lambda-environment 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))))) @@ -380,7 +376,7 @@ (let ((sorted (sort (vars) #'string< :key #'(lambda (x) - (symbol-name (leaf-name (car x)))))) + (symbol-name (leaf-debug-name (car x)))))) (prev-name nil) (id 0) (i 0) @@ -389,7 +385,7 @@ (type index id i)) (dolist (x sorted) (let* ((var (car x)) - (name (symbol-name (leaf-name var)))) + (name (symbol-name (leaf-debug-name var)))) (cond ((and prev-name (string= prev-name name)) (incf id)) (t @@ -399,7 +395,7 @@ (incf i)) (coerce buffer 'simple-vector)))) -;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of +;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES of ;;; FUN, representing the arguments to FUN in minimal variable format. (defun compute-minimal-variables (fun) (declare (type clambda fun)) @@ -408,21 +404,21 @@ (dump-1-variable fun var (leaf-info var) 0 t buffer)) (coerce buffer 'simple-vector))) -;;; Return Var's relative position in the function's variables (determined -;;; from the Var-Locs hashtable.) If Var is deleted, then return DELETED. +;;; Return VAR's relative position in the function's variables (determined +;;; from the VAR-LOCS hashtable). If VAR is deleted, then return DELETED. (defun debug-location-for (var var-locs) (declare (type lambda-var var) (type hash-table var-locs)) (let ((res (gethash var var-locs))) (cond (res) (t - (assert (or (null (leaf-refs var)) - (not (tn-offset (leaf-info var))))) + (aver (or (null (leaf-refs var)) + (not (tn-offset (leaf-info var))))) 'deleted)))) ;;;; arguments/returns ;;; Return a vector to be used as the -;;; COMPILED-DEBUG-FUNCTION-ARGUMENTS for Fun. If fun is 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. ;;; @@ -461,7 +457,7 @@ (coerce-to-smallest-eltype (res)))) -;;; Return a vector of SC offsets describing Fun's return locations. +;;; Return a vector of SC offsets describing FUN's return locations. ;;; (Must be known values return...) (defun compute-debug-returns (fun) (coerce-to-smallest-eltype @@ -474,29 +470,22 @@ ;;; Return a C-D-F structure with all the mandatory slots filled in. (defun dfun-from-fun (fun) (declare (type clambda fun)) - (let* ((2env (environment-info (lambda-environment fun))) + (let* ((2env (physenv-info (lambda-physenv fun))) (dispatch (lambda-optional-dispatch fun)) (main-p (and dispatch (eq fun (optional-dispatch-main-entry dispatch))))) - (make-compiled-debug-function - :name (cond ((leaf-name fun)) - ((let ((ef (functional-entry-function - fun))) - (and ef (leaf-name ef)))) - ((and main-p (leaf-name dispatch))) - (t - (component-name - (block-component (node-block (lambda-bind fun)))))) + (make-compiled-debug-fun + :name (leaf-debug-name fun) :kind (if main-p nil (functional-kind fun)) - :return-pc (tn-sc-offset (ir2-environment-return-pc 2env)) - :old-fp (tn-sc-offset (ir2-environment-old-fp 2env)) - :start-pc (label-position (ir2-environment-environment-start 2env)) - :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env))))) + :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env)) + :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env)) + :start-pc (label-position (ir2-physenv-environment-start 2env)) + :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env))))) -;;; Return a complete C-D-F structure for Fun. This involves +;;; Return a complete C-D-F structure for FUN. This involves ;;; determining the DEBUG-INFO level and filling in optional slots as ;;; appropriate. -(defun compute-1-debug-function (fun var-locs) +(defun compute-1-debug-fun (fun var-locs) (declare (type clambda fun) (type hash-table var-locs)) (let* ((dfun (dfun-from-fun fun)) (actual-level (policy (lambda-bind fun) debug)) @@ -509,137 +498,36 @@ (let ((od (lambda-optional-dispatch fun))) (or (not od) (not (eq (optional-dispatch-main-entry od) fun))))) - (setf (compiled-debug-function-variables dfun) + (setf (compiled-debug-fun-variables dfun) (compute-minimal-variables fun)) - (setf (compiled-debug-function-arguments dfun) :minimal)) + (setf (compiled-debug-fun-arguments dfun) :minimal)) (t - (setf (compiled-debug-function-variables dfun) + (setf (compiled-debug-fun-variables dfun) (compute-variables fun level var-locs)) - (setf (compiled-debug-function-arguments dfun) + (setf (compiled-debug-fun-arguments dfun) (compute-arguments fun var-locs)))) (when (>= level 2) (multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs) - (setf (compiled-debug-function-tlf-number dfun) tlf-num) - (setf (compiled-debug-function-blocks dfun) blocks))) + (setf (compiled-debug-fun-tlf-number dfun) tlf-num) + (setf (compiled-debug-fun-blocks dfun) blocks))) - (if (external-entry-point-p fun) - (setf (compiled-debug-function-returns dfun) :standard) + (if (xep-p fun) + (setf (compiled-debug-fun-returns dfun) :standard) (let ((info (tail-set-info (lambda-tail-set fun)))) (when info (cond ((eq (return-info-kind info) :unknown) - (setf (compiled-debug-function-returns dfun) + (setf (compiled-debug-fun-returns dfun) :standard)) ((/= level 0) - (setf (compiled-debug-function-returns dfun) + (setf (compiled-debug-fun-returns dfun) (compute-debug-returns fun))))))) dfun)) -;;;; minimal debug functions - -;;; Return true if DFUN can be represented as a minimal debug -;;; function. DFUN is a cons ( . C-D-F). -(defun debug-function-minimal-p (dfun) - (declare (type cons dfun)) - (let ((dfun (cdr dfun))) - (and (member (compiled-debug-function-arguments dfun) '(:minimal nil)) - (null (compiled-debug-function-blocks dfun))))) - -;;; Dump a packed binary representation of a DFUN into *BYTE-BUFFER*. -;;; PREV-START and START are the byte offsets in the code where the -;;; previous function started and where this one starts. -;;; PREV-ELSEWHERE is the previous function's elsewhere PC. -(defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere) - (declare (type compiled-debug-function dfun) - (type index prev-start start prev-elsewhere)) - (let* ((name (compiled-debug-function-name dfun)) - (setf-p (and (consp name) (eq (car name) 'setf) - (consp (cdr name)) (symbolp (cadr name)))) - (base-name (if setf-p (cadr name) name)) - (pkg (when (symbolp base-name) - (symbol-package base-name))) - (name-rep - (cond ((stringp base-name) - minimal-debug-function-name-component) - ((not pkg) - minimal-debug-function-name-uninterned) - ((eq pkg (sane-package)) - minimal-debug-function-name-symbol) - (t - minimal-debug-function-name-packaged)))) - (assert (or (atom name) setf-p)) - (let ((options 0)) - (setf (ldb minimal-debug-function-name-style-byte options) name-rep) - (setf (ldb minimal-debug-function-kind-byte options) - (position-or-lose (compiled-debug-function-kind dfun) - *minimal-debug-function-kinds*)) - (setf (ldb minimal-debug-function-returns-byte options) - (etypecase (compiled-debug-function-returns dfun) - ((member :standard) minimal-debug-function-returns-standard) - ((member :fixed) minimal-debug-function-returns-fixed) - (vector minimal-debug-function-returns-specified))) - (vector-push-extend options *byte-buffer*)) - - (let ((flags 0)) - (when setf-p - (setq flags (logior flags minimal-debug-function-setf-bit))) - (when (compiled-debug-function-nfp dfun) - (setq flags (logior flags minimal-debug-function-nfp-bit))) - (when (compiled-debug-function-variables dfun) - (setq flags (logior flags minimal-debug-function-variables-bit))) - (vector-push-extend flags *byte-buffer*)) - - (when (eql name-rep minimal-debug-function-name-packaged) - (write-var-string (package-name pkg) *byte-buffer*)) - (unless (stringp base-name) - (write-var-string (symbol-name base-name) *byte-buffer*)) - - (let ((vars (compiled-debug-function-variables dfun))) - (when vars - (let ((len (length vars))) - (write-var-integer len *byte-buffer*) - (dotimes (i len) - (vector-push-extend (aref vars i) *byte-buffer*))))) - - (let ((returns (compiled-debug-function-returns dfun))) - (when (vectorp returns) - (let ((len (length returns))) - (write-var-integer len *byte-buffer*) - (dotimes (i len) - (write-var-integer (aref returns i) *byte-buffer*))))) - - (write-var-integer (compiled-debug-function-return-pc dfun) - *byte-buffer*) - (write-var-integer (compiled-debug-function-old-fp dfun) - *byte-buffer*) - (when (compiled-debug-function-nfp dfun) - (write-var-integer (compiled-debug-function-nfp dfun) - *byte-buffer*)) - (write-var-integer (- start prev-start) *byte-buffer*) - (write-var-integer (- (compiled-debug-function-start-pc dfun) start) - *byte-buffer*) - (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun) - prev-elsewhere) - *byte-buffer*))) - -;;; Return a byte-vector holding all the debug functions for a -;;; component in the packed binary minimal-debug-function format. -(defun compute-minimal-debug-functions (dfuns) - (declare (list dfuns)) - (setf (fill-pointer *byte-buffer*) 0) - (let ((prev-start 0) - (prev-elsewhere 0)) - (dolist (dfun dfuns) - (let ((start (car dfun)) - (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun)))) - (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere) - (setq prev-start start prev-elsewhere elsewhere)))) - (copy-seq *byte-buffer*)) - ;;;; full component dumping ;;; Compute the full form (simple-vector) function map. -(defun compute-debug-function-map (sorted) +(defun compute-debug-fun-map (sorted) (declare (list sorted)) (let* ((len (1- (* (length sorted) 2))) (funs-vec (make-array len))) @@ -657,39 +545,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)) - ;; FIXME: What is *BYTE-BUFFER* for? Has it become dead code - ;; now that we no longer use minimal-debug-function - ;; representation? - (*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 (node-block (lambda-bind fun)))) - (compute-1-debug-function fun var-locs)))) - (let* ((sorted (sort (dfuns) #'< :key #'car)) - ;; FIXME: CMU CL had - ;; (IF (EVERY #'DEBUG-FUNCTION-MINIMAL-P SORTED) - ;; (COMPUTE-MINIMAL-DEBUG-FUNCTIONS SORTED) - ;; (COMPUTE-DEBUG-FUNCTION-MAP SORTED)) - ;; here. We've gotten rid of the minimal-debug-function - ;; case in SBCL because the minimal representation - ;; couldn't be made to transform properly under package - ;; renaming. Now that that case is gone, a lot of code is - ;; dead, and once everything is known to work, the dead - ;; code should be deleted. - (function-map (compute-debug-function-map sorted))) - (make-compiled-debug-info :name (component-name component) - :function-map function-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))