head	1.4;
access;
symbols;
locks; strict;


1.4
date	94.10.31.04.27.28;	author ram;	state Exp;
branches;
next	1.3;

1.3
date	91.10.18.17.59.10;	author ram;	state Exp;
branches;
next	1.2;

1.2
date	91.10.03.16.38.16;	author ram;	state Exp;
branches;
next	1.1;

1.1
date	91.08.25.18.11.47;	author ram;	state Exp;
branches;
next	;


desc
@Stuff to check register allocation by grovelling the assembly output.
Rather hueristic.
@


1.4
log
@Fix headed boilerplate.
@
text
@;;; -*- Package: ASSEMBLER -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: $")
;;;
;;; **********************************************************************
;;;
;;;    Stuff to verify the legality of register allocation by examining the
;;; assembly output.  If the same register holds two things (live TNs) at the
;;; same time, we have a problem.
;;;
(in-package "ASSEMBLER")
(export '(segment-check-registers))
(in-package "C")
(import '(do-live-tns ir2-block-live-in ir2-block-block print-tn sb-kind tn
	  vop-block vop-info vop-info-save-p vop-save-set tn-reads tn-kind
	  tn-number tn-writes vop-refs vop vop-info-arg-costs
	  vop-info-result-costs vop-info-move-args vop-results vop-args
	  vop-temps vop-info-arg-types vop-info-name)
	"ASSEMBLER")
(in-package "ASSEMBLER")

;;; The segment we are currently checking.
;;;
(defvar *check-segment*)

;;; The exclusive end of the block we are currently checking.
;;;
(defvar *check-end*)

;;; REGISTER-LOSSAGE-ERROR  --  Internal
;;;
;;;    Print out a hopefully-descriptive error message describing the context
;;; in which a register is twice-used.  Old is the cons (TN . Instruction)
;;; describing the previously live value.
;;;
(defun register-lossage-error (sb offset tn write-p old inst)
  (let ((tn-name (with-output-to-string (s)
		   (print-tn tn s)))
	(old-name (with-output-to-string (s)
		    (print-tn (car old) s)))
	(old-inst (cdr old)))
    (cerror "Ignore it."
	    "Location ~D in ~A SB in use by both ~A and ~A:~%~A~&"
	    offset (sb-name sb) tn-name old-name
	    (with-output-to-string (s)
	      (dump-segment
	       *check-segment* :stream s
	       :start inst :end (if old-inst (node-next old-inst) *check-end*)
	       :markers `((,inst "*** ~A ~:[read~;written~] here:~%"
				 ,tn-name ,write-p)
			  (,(cdr old) "*** ~A read here:~%" ,old-name)))))))


;;; FIND-TARGETING-PATH  --  Internal
;;;
;;;    Return true if TN is targeted into Old-TN (possibly indirectly through
;;; multiple TNs.)  We do a graph walk to find indirect targeting paths.  Flags
;;; is has a T entry for every TN that we have already reached during the walk.
;;;
(defun find-targeting-path (tn old-tn flags)
  (cond
   ((gethash tn flags) nil)
   (t
    (setf (gethash tn flags) t)
    (do ((ref (tn-reads tn) (tn-ref-next ref)))
	((null ref) nil)
      (let ((target (tn-ref-target ref)))
	(when target
	  (let ((ttn (tn-ref-tn target)))
	    (when (or (eq ttn old-tn)
		      (eq (tn-ref-load-tn target) old-tn)
		      (find-targeting-path ttn old-tn flags))
	      (return t)))))))))

(defparameter ignored-optimizable-vops '(c:allocate-full-call-frame))

;;; CHECK-FOR-EXCEPTIONS  --  Internal
;;;
;;;   This is one place where a hueristic component enters.  We ignore
;;; sequences where the first TN (TN) is targeted into the second TN (Old)
;;; along a read path.  If TN is a load-tn, then we scan the refs for Inst's
;;; VOP to find the original TN.
;;;
;;;   We also ignore any cases where Old is written by certain VOPs that can be
;;; entirely optimized away.
;;;
(defun check-for-exceptions (tn old write-p inst)
  (declare (ignore write-p))
  (or (find-targeting-path 
       (if (eq (tn-kind tn) :load)
	   (do ((ref (vop-refs (node-vop inst))
		     (tn-ref-next-ref ref)))
	       ((eq (tn-ref-load-tn ref) tn) (tn-ref-tn ref)))
	   tn)
       (car old)
       (make-hash-table :test #'eq))
      (do ((ref (tn-writes (car old)) (tn-ref-next ref)))
	  ((null ref) nil)
	(when (member (vop-info-name (vop-info (tn-ref-vop ref)))
		      ignored-optimizable-vops)
	  (return t)))))


;;; NOTE-TN-REF  --  Internal
;;;
;;;    Notice a reference to TN by Inst.  If there is a problem, signal an
;;; error.  If the TN has no number, we guess that it is a random TN (not
;;; allocated by the allocator), so we ignore the reference.
;;;
(defun note-tn-ref (tn write-p inst)
  (if (tn-number tn)
      (let* ((sc (tn-sc tn))
	     (sb (sc-sb sc)))
	(when (eq (sb-kind sb) :finite)
	  (let ((live (finite-sb-live-tns sb)))
	    (loop for i from (tn-offset tn)
	      repeat (sc-element-size sc) do
	      (let ((old (svref live i)))
		(when (and old (not (eq (car old) tn))
			   (not (check-for-exceptions tn old write-p inst)))
		  (register-lossage-error sb i tn write-p old inst)))
	      (setf (svref live i) (if write-p nil (cons tn inst)))))))
      (assert (and (eq (tn-kind tn) :normal)
		   (not (or (tn-reads tn) (tn-writes tn))))))

  (undefined-value))


;;; CLEAR-LIVE-SET  --  Internal
;;;
;;;    Mark all registers as unused.
;;;
(defun clear-live-set ()
  (dolist (sb (backend-sb-list *backend*))
    (when (eq (sb-kind sb) :finite)
      (fill (finite-sb-live-tns sb) nil))))


;;; CHECK-BLOCK-INIT  --  Internal
;;;
;;;    Set up the FINITE-SB-LIVE-TNS to represent the TNs live at a particular
;;; point.  We mark the TNs, but record no instruction, since we don't know
;;; where the read is.
;;;
(defun check-block-init (block live)
  (clear-live-set)
  (do-live-tns (tn live block)
    (let* ((sc (tn-sc tn))
	   (sb (sc-sb sc)))
      (when (eq (sb-kind sb) :finite)
	(loop for offset from (tn-offset tn)
	      repeat (sc-element-size sc) do
	  (setf (svref (finite-sb-live-tns sb) offset)
		(cons tn nil))))))
  (undefined-value))


;;; NOTE-MORE-REFS  --  Internal
;;;
;;;    Do NOTE-TN-REF on the more operand to a VOP.  Costs are the fixed
;;; operand costs (to skip them.)  Ops is the full arg/result list.  
;;;
(defun note-more-refs (costs ops write-p inst)
  (do ((cost costs (cdr cost))
       (op ops (tn-ref-across op)))
      ((null cost)
       (do ((op op (tn-ref-across op)))
	   ((null op))
	 (note-tn-ref (tn-ref-tn op) write-p inst))))
  (undefined-value))


;;; FIND-BRANCH-TARGETS  --  Internal
;;;
;;;    Return a bit-vector with 1 elements for the offsets of all labels that
;;; have an intra-block jump to them.  Labels with no VOP are block start
;;; labels.
;;;
(defun find-branch-targets (elsewhere)
  (let* ((last (label-%position elsewhere))
	 (res (make-array (1+ last) :element-type 'bit :initial-element 0)))
    (do ((node (node-prev elsewhere) (node-prev node))) 
	((null node))
      (when (and (instruction-p node)
		 (inst-class-p node relative-branch))
	(do-constants (lab node)
	  (when (label-p lab)
	    (let ((lab-vop (node-vop lab)))
	      (when (and lab-vop
			 (eq (ir2-block-block (vop-block lab-vop))
			     (ir2-block-block (vop-block (node-vop node)))))
		(let ((pos (label-%position lab)))
		  (when (<= pos last)
		    (setf (sbit res pos) 1)))))))))
    res))


;;; Call VOPs that don't happen to have the MOVE-ARGUMENTS attribute.
;;;
(defparameter stray-call-vops '(c:call-variable c:call-out))

;;; SEGMENT-CHECK-REGISTERS  --  Interface
;;;
;;;    Check the validity of register allocation in a segment.  Elsewhere is
;;; the (now inserted) elsewhere segment, which we use to determine the start
;;; of elsewhere code (so that we can ignore it.)  We detect most (but not all)
;;; allocation errors.  Code for each Ir2-block must be contiguous (so this
;;; must be called before assembly optimization.)  We go back to the IR2 to
;;; find the live TNs at block ends and call sites.
;;;
;;;    We clear the live set at all labels that are the target of intra-block
;;; jumps, since there might be some weird control flow going on that could
;;; cause spurious errors.
;;;
(defun segment-check-registers (*check-segment* elsewhere)
  (let ((*check-end* nil)
	(targets (find-branch-targets elsewhere))
	(call-vop nil)
	(state :normal)
	(block nil))
    (declare (type (member :normal :call :assembly-call) state)
	     (inline member))
    (do ((node (node-prev elsewhere) (node-prev node))) 
	((null node))
      (typecase node
	(instruction
	 (let* ((vop (node-vop node))
		(info (vop-info vop)))
	   (unless (eq call-vop vop)
	     (ecase state
	       (:call
		(note-more-refs (vop-info-arg-costs (vop-info call-vop))
				(vop-args call-vop)
				nil (node-next node)))
	       ((:assembly-call :normal)))
	     (setq state :normal))
	   
	   (when (eq state :normal)
	     (let ((vblock (vop-block vop)))
	       (unless (eq vblock block)
		 (setq block vblock)
		 (setq *check-end* (node-next node))
		 (check-block-init block (ir2-block-live-in block))))
	     
	     (cond
	      ((or (vop-info-move-args info)
		   (member (vop-info-name info) stray-call-vops
			   :test #'eq))
	       (setq state :call  call-vop vop)
	       (note-more-refs (vop-info-result-costs info)
			       (vop-results vop) t node))
	      ((inst-class-p node assembly-call)
	       (setq state :assembly-call  call-vop vop)
	       (note-more-refs nil (vop-temps vop) t node))))
	   
	   (do-results (res node)
	     (note-tn-ref res t node))
	   (do-arguments (arg node)
	     (note-tn-ref arg nil node))))
	(label
	 (unless (zerop (sbit targets (label-%position node)))
	   (clear-live-set))))))
	   
  (undefined-value))
@


1.3
log
@Added FIND-BRANCH-TARGETS to try to avoid being confused by intra-block control
transfer.
@
text
@a5 2
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@@cs.cmu.edu.
d8 1
a8 1
  "$Header: assem-check.lisp,v 1.2 91/10/03 16:38:16 ram Locked $")
@


1.2
log
@Added some more special case checks.
@
text
@d10 1
a10 1
  "$Header: assem-check.lisp,v 1.1 91/08/25 18:11:47 ram Locked $")
d21 5
a25 5
(import '(do-live-tns ir2-block-live-in print-tn sb-kind tn vop-block vop-info 
	   vop-info-save-p vop-save-set tn-reads tn-kind tn-number tn-writes
	   vop-refs vop vop-info-arg-costs vop-info-result-costs
	   vop-info-move-args vop-results vop-args vop-temps
	   vop-info-arg-types vop-info-name)
d136 10
d153 1
a153 3
  (dolist (sb (backend-sb-list *backend*))
    (when (eq (sb-kind sb) :finite)
      (fill (finite-sb-live-tns sb) nil)))
d180 25
d218 4
d224 1
d232 39
a270 35
      (when (instruction-p node)
	(let* ((vop (node-vop node))
	       (info (vop-info vop)))
	  (unless (eq call-vop vop)
	    (ecase state
	      (:call
	       (note-more-refs (vop-info-arg-costs (vop-info call-vop))
			       (vop-args call-vop)
			       nil (node-next node)))
	      ((:assembly-call :normal)))
	    (setq state :normal))

	  (when (eq state :normal)
	    (let ((vblock (vop-block vop)))
	      (unless (eq vblock block)
		(setq block vblock)
		(setq *check-end* (node-next node))
		(check-block-init block (ir2-block-live-in block))))

	    (cond
	     ((or (vop-info-move-args info)
		  (member (vop-info-name info) stray-call-vops
			  :test #'eq))
	      (setq state :call  call-vop vop)
	      (note-more-refs (vop-info-result-costs info)
			      (vop-results vop) t node))
	     ((inst-class-p node assembly-call)
	      (setq state :assembly-call  call-vop vop)
	      (note-more-refs nil (vop-temps vop) t node))))

	  (do-results (res node)
	    (note-tn-ref res t node))
	  (do-arguments (arg node)
	    (note-tn-ref arg nil node))))))

@


1.1
log
@Initial revision
@
text
@d10 1
a10 1
  "$Header: assem-opt.lisp,v 1.5 91/02/25 15:31:24 ram Exp $")
d25 1
a25 1
	   vop-info-arg-types)
d82 1
d87 3
a89 3
;;; write/read sequences where the written TN is targeted into the read TN.  If
;;; TN is a load-tn, then we scan the refs for Inst's VOP to find the original
;;; TN.
d91 3
d95 14
a108 8
  (find-targeting-path 
   (if (eq (tn-kind tn) :load)
       (do ((ref (vop-refs (node-vop inst))
		 (tn-ref-next-ref ref)))
	   ((eq (tn-ref-load-tn ref) tn) (tn-ref-tn ref)))
       tn)
   (car old)
   (make-hash-table :test #'eq)))
d172 4
d190 2
a191 1
    (declare (type (member :normal :call :assembly-call) state))
a196 1
;	(format t "~&Node = ~S, state = ~S, VOP = ~S~%" node state vop)
d214 3
a216 1
	     ((vop-info-move-args info)
@