diff --git a/compiler/dyncount.lisp b/compiler/dyncount.lisp index 232fdbdaf34154a4ee383607df7aef0371980bb3..c22853cb93a78d31258aa6b4b4268f48ceb6c58a 100644 --- a/compiler/dyncount.lisp +++ b/compiler/dyncount.lisp @@ -39,15 +39,42 @@ (let* ((info (ir2-component-dyncount-info (component-info component))) (vops (dyncount-info-vops info))) (do-ir2-blocks (block component) - (when (ir2-block-start-vop block) - (let* ((1block (ir2-block-block block)) - (index (1- (block-number 1block))) - (counts (svref vops index))) - (do ((vop (ir2-block-start-vop block) (vop-next vop))) - ((null vop)) - (let* ((vop-name (vop-info-name (vop-info vop))) - (entry (assoc vop-name counts :test #'eq))) - (if entry - (incf (cdr entry)) - (setf counts (acons vop-name 1 counts))))) - (setf (svref vops index) counts)))))) + (let* ((start-vop (ir2-block-start-vop block)) + (1block (ir2-block-block block)) + (block-number (block-number 1block))) + (when (and start-vop block-number) + (let* ((index (1- block-number)) + (counts (svref vops index)) + (length (length counts))) + (do ((vop start-vop (vop-next vop))) + ((null vop)) + (let ((vop-name (vop-info-name (vop-info vop)))) + (do ((i 0 (+ i 4))) + ((or (>= i length) (eq (svref counts i) vop-name)) + (when (>= i length) + (incf length 4) + (let ((new-counts + (make-array length :initial-element 0))) + (when counts + (replace new-counts counts)) + (setf counts new-counts)) + (setf (svref counts i) vop-name)) + (incf (svref counts (1+ i))))))) + (setf (svref vops index) counts))))) + (count-instructions + #'(lambda (vop bytes elsewherep) + (let ((block-number (block-number (ir2-block-block (vop-block vop))))) + (when block-number + (let* ((name (vop-info-name (vop-info vop))) + (counts (svref vops (1- block-number))) + (length (length counts))) + (do ((i 0 (+ i 4))) + ((>= i length) + (error "VOP ~S didn't exist earlier!~% counts=~S" + name counts)) + (when (eq (svref counts i) name) + (incf (svref counts (+ i (if elsewherep 3 2))) bytes) + (return))))))) + *code-segment* + *elsewhere*) + (undefined-value)))