Skip to content
Snippets Groups Projects
Commit 664ec74f authored by ram's avatar ram
Browse files

Change block numbering to the one computed at ir2-conversion time &

shared with profile info.
parent 57e3d58e
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.31 1992/08/03 19:03:35 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.32 1993/03/12 15:35:50 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -158,21 +158,18 @@ ...@@ -158,21 +158,18 @@
(undefined-value)) (undefined-value))
;;; FIND-TLF-AND-BLOCK-NUMBERS -- Internal ;;; FIND-TLF-NUMBER -- Internal
;;; ;;;
;;; Scan all the blocks, caching the block numbering in the BLOCK-FLAG and ;;; Scan all the blocks, determining if all locations are in the same TLF,
;;; determining if all locations are in the same TLF. ;;; and returing it or NIL.
;;; ;;;
(defun find-tlf-and-block-numbers (fun) (defun find-tlf-number (fun)
(declare (type clambda fun)) (declare (type clambda fun))
(let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))) (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
(num 0)) (declare (type (or index null) res))
(declare (type index num) (type (or index null) res))
(do-environment-ir2-blocks (2block (lambda-environment fun)) (do-environment-ir2-blocks (2block (lambda-environment fun))
(let ((block (ir2-block-block 2block))) (let ((block (ir2-block-block 2block)))
(when (eq (block-info block) 2block) (when (eq (block-info block) 2block)
(setf (block-flag block) num)
(incf num)
(unless (eql (source-path-tlf-number (unless (eql (source-path-tlf-number
(node-source-path (node-source-path
(continuation-next (continuation-next
...@@ -230,8 +227,13 @@ ...@@ -230,8 +227,13 @@
(vector-push-extend (vector-push-extend
(dpb (length valid-succ) compiled-debug-block-nsucc-byte 0) (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
*byte-buffer*) *byte-buffer*)
(dolist (b valid-succ) (let ((base (block-number
(write-var-integer (block-flag b) *byte-buffer*))) (node-block
(lambda-bind (environment-function env))))))
(dolist (b valid-succ)
(write-var-integer
(the index (- (block-number b) base))
*byte-buffer*))))
(undefined-value)) (undefined-value))
...@@ -249,7 +251,7 @@ ...@@ -249,7 +251,7 @@
(declare (type clambda fun) (type hash-table var-locs)) (declare (type clambda fun) (type hash-table var-locs))
(setf (fill-pointer *byte-buffer*) 0) (setf (fill-pointer *byte-buffer*) 0)
(let ((*previous-location* 0) (let ((*previous-location* 0)
(tlf-num (find-tlf-and-block-numbers fun)) (tlf-num (find-tlf-number fun))
(env (lambda-environment fun)) (env (lambda-environment fun))
(prev-locs nil) (prev-locs nil)
(prev-block nil)) (prev-block nil))
...@@ -575,9 +577,11 @@ ...@@ -575,9 +577,11 @@
(defun compute-1-debug-function (fun var-locs) (defun compute-1-debug-function (fun var-locs)
(declare (type clambda fun) (type hash-table var-locs)) (declare (type clambda fun) (type hash-table var-locs))
(let* ((dfun (dfun-from-fun fun)) (let* ((dfun (dfun-from-fun fun))
(level (cookie-debug (actual-level
(lexenv-cookie (node-lexenv (lambda-bind fun)))))) (cookie-debug (lexenv-cookie (node-lexenv (lambda-bind fun)))))
(level (if *collect-dynamic-statistics*
(max actual-level 2)
actual-level)))
(cond ((zerop level)) (cond ((zerop level))
((and (<= level 1) ((and (<= level 1)
(let ((od (lambda-optional-dispatch fun))) (let ((od (lambda-optional-dispatch fun)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment