From 1d2d0e8e1963831700148cd8bed50219fc96483a Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 23 Apr 1990 13:33:35 +0000 Subject: [PATCH] Added OPTIONAL-ARGS marker to the c-d-f-arguments. In DEBUG-INFO-FOR-COMPONENT, give the main entry to an optional-dispatch the original name and NIL kind. Fixed debug location dumping to dump locations in overflow blocks. Split COMPUTE-DEBUG-BLOCKS up into several functions for readability. --- compiler/debug-dump.lisp | 150 +++++++++++++++++++++++++-------------- 1 file changed, 96 insertions(+), 54 deletions(-) diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp index bf5477121..0306455e7 100644 --- a/compiler/debug-dump.lisp +++ b/compiler/debug-dump.lisp @@ -139,13 +139,78 @@ (undefined-value)) +;;; FIND-TLF-AND-BLOCK-NUMBERS -- Internal +;;; +;;; Scan all the blocks, caching the block numbering in the BLOCK-FLAG and +;;; determining if all locations are in the same TLF. +;;; +(defun find-tlf-and-block-numbers (fun) + (declare (type clambda fun)) + (let ((res (node-tlf-number (lambda-bind fun))) + (num 0)) + (do-environment-ir2-blocks (2block (lambda-environment fun)) + (let ((block (ir2-block-block 2block))) + (when (eq (block-info block) 2block) + (setf (block-flag block) num) + (incf num) + (unless (eql (node-tlf-number (continuation-next (block-start block))) + res) + (setq res nil))) + + (dolist (loc (ir2-block-locations 2block)) + (unless (eql (node-tlf-number (vop-node (location-info-vop loc))) + res) + (setq res nil))))) + res)) + + +;;; DUMP-BLOCK-LOCATIONS -- Internal +;;; +;;; Dump out the number of locations and the locations for Block. +;;; +(defun dump-block-locations (block locations tlf-num var-locs) + (declare (type cblock block) (list locations)) + (write-var-integer (1+ (length locations)) *byte-buffer*) + (let ((2block (block-info block))) + (dump-1-location (continuation-next (block-start block)) + 2block :block-start tlf-num + (ir2-block-%label 2block) + (ir2-block-live-out 2block) + var-locs)) + (dolist (loc locations) + (dump-location-from-info loc tlf-num var-locs)) + (undefined-value)) + + +;;; DUMP-BLOCK-SUCCESSORS -- Internal +;;; +;;; 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)) + (let* ((tail (component-tail (block-component block))) + (succ (block-succ block)) + (valid-succ + (if (and succ + (or (eq (car succ) tail) + (not (eq (lambda-environment (block-lambda (car succ))) + env)))) + () + succ))) + (vector-push-extend + (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0) + *byte-buffer*) + (dolist (b valid-succ) + (write-var-integer (block-flag b) *byte-buffer*))) + (undefined-value)) + + ;;; COMPUTE-DEBUG-BLOCKS -- Internal ;;; ;;; Return a vector and an integer (or null) suitable for use as the BLOCKS ;;; and TLF-NUMBER in Fun's debug-function. This requires three passes to ;;; compute: -;;; -- Scan all the blocks, caching the block numbering in the BLOCK-FLAG and -;;; determining if all locations are in the same TLF. ;;; -- Scan all blocks, dumping the header and successors followed by all the ;;; non-elsewhere locations. ;;; -- Dump the elsewhere block header and all the elsewhere locations (if @@ -155,59 +220,27 @@ (declare (type clambda fun) (type hash-table var-locs)) (setf (fill-pointer *byte-buffer*) 0) (let ((*previous-location* 0) - (tlf-num (node-tlf-number (lambda-bind fun)))) - (let ((num 0)) - (do-environment-ir2-blocks (2block (lambda-environment fun)) + (tlf-num (find-tlf-and-block-numbers fun)) + (env (lambda-environment fun)) + (prev-locs nil) + (prev-block nil)) + (collect ((elsewhere)) + (do-environment-ir2-blocks (2block env) (let ((block (ir2-block-block 2block))) (when (eq (block-info block) 2block) - (setf (block-flag block) num) - (incf num) - (unless (eql (node-tlf-number - (continuation-next (block-start block))) - tlf-num) - (setq tlf-num nil))) - + (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))) + + (collect ((here prev-locs)) (dolist (loc (ir2-block-locations 2block)) - (unless (eql (node-tlf-number (vop-node (location-info-vop loc))) - tlf-num) - (setq tlf-num nil)))))) + (if (label-elsewhere-p (location-info-label loc)) + (elsewhere loc) + (here loc))) + (setq prev-locs (here)))) - (collect ((elsewhere)) - (let ((tail (component-tail - (block-component (node-block (lambda-bind fun))))) - (env (lambda-environment fun))) - (do-environment-ir2-blocks (2block env) - (let ((block (ir2-block-block 2block))) - (when (eq (block-info block) 2block) - (let ((succ (let ((s (block-succ block))) - (if (and s - (or (eq (car s) tail) - (not (eq (lambda-environment - (block-lambda (car s))) - env)))) - () - s)))) - (vector-push-extend - (dpb (length succ) compiled-debug-block-nsucc-byte 0) - *byte-buffer*) - (dolist (b succ) - (write-var-integer (block-flag b) *byte-buffer*))) - - (collect ((here)) - (dolist (loc (ir2-block-locations 2block)) - (if (label-elsewhere-p (location-info-label loc)) - (elsewhere loc) - (here loc))) - (write-var-integer (1+ (length (here))) *byte-buffer*) - - (dump-1-location (continuation-next (block-start block)) - 2block :block-start tlf-num - (ir2-block-%label 2block) - (ir2-block-live-out 2block) - var-locs) - - (dolist (loc (here)) - (dump-location-from-info loc tlf-num var-locs))))))) + (dump-block-locations prev-block prev-locs tlf-num var-locs) (when (elsewhere) (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*) @@ -401,7 +434,8 @@ (collect ((res)) (let ((od (lambda-optional-dispatch fun))) (if (and od (eq (optional-dispatch-main-entry od) fun)) - (let ((actual-vars (lambda-vars fun))) + (let ((actual-vars (lambda-vars fun)) + (saw-optional nil)) (dolist (arg (optional-dispatch-arglist od)) (let ((info (lambda-var-arg-info arg)) (actual (pop actual-vars))) @@ -410,7 +444,11 @@ (:keyword (res (arg-info-keyword info))) (:rest - (res 'rest-arg))) + (res 'rest-arg)) + (:optional + (unless saw-optional + (res 'optional-args) + (setq saw-optional t)))) (res (debug-location-for actual var-locs)) (when (arg-info-supplied-p info) (res 'supplied-p) @@ -452,14 +490,18 @@ (dolist (fun (component-lambdas component)) (clrhash var-locs) (let* ((2env (environment-info (lambda-environment fun))) + (dispatch (lambda-optional-dispatch fun)) + (main-p (and dispatch + (eq fun (optional-dispatch-main-entry fun)))) (dfun (make-compiled-debug-function :name (cond ((leaf-name fun)) ((let ((ef (functional-entry-function fun))) (and ef (leaf-name ef)))) + (main-p (leaf-name dispatch)) (t (component-name component))) - :kind (functional-kind fun) + :kind (if main-p nil (functional-kind fun)) :return-pc (tn-sc-offset (ir2-environment-return-pc 2env)) :old-fp (tn-sc-offset -- GitLab