anchor.diff:  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;;
  -;;; Compute the reaching definitions of a program.  
  -;;;
  -;;; A DEFINITION is a CONS of an INSTRUCTION and a LEXICAL-LOCATION
  -;;; that is an output of that instruction.  A definition is said to
  -;;; REACH an instruction I if and only if there exists an execution
  -;;; path from the definition to I in which the lexical location is not
  -;;; the output of any other instruction.
  -;;;
  -;;; The REACHING DEFINITIONS of an instruction I is a SET of
  -;;; DEFINITIONS that reach I.  
  -;;;
  -;;; The problem of computing the reaching definitions of a procedure
  -;;; is a so-called FORWARD DATAFLOW problem, in that it can be solved
  -;;; by fixpoint iteration, starting from the initial instruction and
  -;;; following successors until a fixpoint is reached.  
  -
  -(defun compute-reaching-definitions-for-procedure (procedure)
  -  (let ((atable (make-hash-table :test #'eq))
  -	(btable (make-hash-table :test #'eq)))
  -    (flet ((same-set-p (s1 s2)
  -	     (and (subsetp s1 s2 :test #'equal)
  -		  (subsetp s2 s1 :test #'equal))))
  -      (flet ((lexical-outputs (instruction)
  -	       (remove-if-not (lambda (output)
  -				(typep output 'sicl-mir:lexical-location))
  -			      (sicl-mir:outputs instruction))))
  -	(flet ((b-to-a (instruction)
  -		 (let* ((before (gethash instruction btable))
  -			(locations (lexical-outputs instruction))
  -			(stripped (remove-if (lambda (x)
  -					       (member (cdr x) locations
  -						       :test #'eq))
  -					     before))
  -			(new-definitions (mapcar (lambda (location)
  -						   (cons instruction location))
  -						 locations))
  -			(after (append new-definitions stripped)))
  -		   (setf (gethash instruction atable) after))))
  -	  ;; A function that returns only the successors of an
  -	  ;; instruction I that have the same owner as I does.
  -	  (flet ((sp-successors (instruction)
  -		   (remove-if-not (lambda (succ)
  -				    (eq (owner instruction) (owner succ)))
  -				  (successors instruction))))
  -	    (labels ((traverse (instruction)
  -		       (multiple-value-bind (value present-p)
  -			   (gethash instruction btable)
  -			 (let* ((new (apply
  -				      #'concatenate 'list
  -				      (mapcar (lambda (inst)
  -						(gethash inst atable))
  -					      (predecessors instruction))))
  -				(unique (remove-duplicates new :test #'equal)))
  -			   (when (or (not present-p)
  -				     (not (same-set-p value unique)))
  -			     (setf (gethash instruction btable) new)
  -			     (b-to-a instruction)
  -			     (mapc #'traverse (sp-successors instruction)))))))
  -	      (traverse (initial-instruction procedure)))))))
  -    btable))
  -
  -(defun compute-reaching-definitions (program)
  -  (let ((*program* program))
  -    (loop for procedure in (procedures program)
  -	  append
  -	  (loop for instruction being each hash-key
  -		using (hash-value definitions)
  -		of (compute-reaching-definitions-for-procedure procedure)
  -		collect (cons instruction definitions)))))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Compute DU-chains.
  -;;;
  -;;; A UD-chain is a not a chain at all, but rather a mapping that
  -;;; takes a DEFINITION and returns a set of INSTRUCTIONS that might
  -;;; use that definition.  Recall that a definition is a CONS of an
  -;;; INSTRUCTION and a LEXICAL-LOCATION.  
  -
  -(defun compute-du-chains (program)
  -  (let* (;; Start by computing the reaching definitions.  Recall that
  -	 ;; we obtain a list for each instruction in the program.  The
  -	 ;; list has the instruction as its CAR and the definitions
  -	 ;; that reach that definition as its CDR.
  -	 (reaching-definitions (compute-reaching-definitions program))
  -	 ;; To obtain every definition in the program, one way is to
  -	 ;; uniquify the lists of the definitions returned by the
  -	 ;; reaching definitions.  It's a bit wasteful since there are
  -	 ;; a lot of duplicates, but who is counting? 
  -	 (definitions (remove-duplicates
  -		       (reduce #'append
  -			       (mapcar #'cdr reaching-definitions)
  -			       :from-end t)
  -		       :test #'equal)))
  -    (mapcar (lambda (definition)
  -	      (cons definition
  -		    (loop for rd in reaching-definitions
  -			  when (and (member (cdr definition)
  -					    (sicl-mir:inputs (car rd))
  -					    :test #'eq)
  -				    (member definition (cdr rd)
  -					    :test #'equal))
  -			    collect (car rd))))
  -	    definitions)))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Compute web sets.
  -;;;
  -;;; Two DU-chains are said to INTERSECT if and only if:
  -;;;
  -;;;   * They concern the same lexical location, and
  -;;;
  -;;;   * They have at least one using instruction in common.
  -;;;
  -;;; A WEB is a maximal set of intersecting DU-chains.  The concept of
  -;;; a web is an important one, because when there are several distinct
  -;;; webs for one particular lexical location, then this is a result of
  -;;; the programmer having used the same variable name for several
  -;;; distinct purposes.  By recognizing such distinct usages, we can
  -;;; improve register allocation because the number of conflicts in the
  -;;; allocation graph decreases then.
  -;;;
  -;;; This function returns a list of as many elements as there are
  -;;; lexical locations in the program.  Each element of the list is a
  -;;; list of webs.  A web is represented as a list of three elements:
  -;;;
  -;;;   * The first element is the lexical location concerned by the
  -;;;     web.
  -;;;
  -;;;   * The second element is a list of defining instructions.
  -;;;
  -;;;   * The third element is a list of using instructions.
  -;;; 
  -;;; Most sublists of the top-level list will contain a single element,
  -;;; in particular sublists for temporary variables allocated by the
  -;;; compiler.
  -;;;
  -;;; Recall that a DU-chain is represented as a list with the CAR being
  -;;; a CONS cell of an defining instruction and a lexical location, and
  -;;; the CDR being a list of using instructions. 
  -
  -;;; From a non-empty list of DU-chains concerning the same lexical
  -;;; location, exctract a single web consisting of all the DU-chains in
  -;;; the list that instersect the first DU-chain of the list.  Return
  -;;; two values: the web that was calculated, and a list of the
  -;;; remaining DU-chains that do not instersect the first one.
  -(defun extract-one-web (du-chains)
  -  (let* ((first (car du-chains))
  -	 (rest (cdr du-chains))
  -	 (web (list (cdar first) (list (caar first)) (cdr first))))
  -    (loop for chain = (find-if-not
  -		       (lambda (chain)
  -			 (null (intersection (cdr chain) (third web)
  -					     :test #'eq)))
  -		       rest)
  -	  until (null chain)
  -	  do (setf rest (remove chain rest :test #'eq))
  -	     (push (caar chain) (second web))
  -	     (setf (third web) (union (third web) (cdr chain) :test #'eq)))
  -    (values web rest)))
  -  
  -;;; Given a (possibly empty) list of DU-chains concerning the same
  -;;; lexical location, return a list of distinct webs correspodning to
  -;;; those DU-chains.
  -;;;
  -;;; We do not expect there to be very many different du-chains
  -;;; concerning one particular location, so we can afford to use a
  -;;; recusive solution.
  -(defun chains-to-webs (du-chains)
  -  (if (null du-chains)
  -      '()
  -      (multiple-value-bind (web rest)
  -	  (extract-one-web du-chains)
  -	(cons web (chains-to-webs rest)))))
  -
  -(defun compute-web-sets (program)
  -  (let ((du-chains (compute-du-chains program))
  -	(webs '()))
  -    (loop until (null du-chains)
  -	  for lexical-location = (cdar (car du-chains))
  -	  do (let ((related-chains
  -		     (remove lexical-location du-chains
  -			     :key #'cdar :test-not #'eq)))
  -	       (setf du-chains
  -		     (set-difference du-chains related-chains :test #'eq))
  -	       (push (chains-to-webs related-chains) webs)))
  -    webs))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Uniquify web.
  -;;;
  -;;; Given a web, allocate a new lexical location and replace the
  -;;; existing lexical location in all the defining and all the using
  -;;; instructions by the new one.
  -;;; 
  -;;; The purpose of this transformation is to make sure that each
  -;;; lexical location of the program is concerned by a single web, so
  -;;; that we can use lexical locations as the unit for register
  -;;; allocation.  When we discover that we have more than one distinct
  -;;; web for a particular lexical location, we uniquify all but one of
  -;;; them.  For most lexical locations, there is a single web, so for
  -;;; most lexical locations, this function will never be called.
  -;;;
  -;;; Recall that a web is represented as a list of three elements: The
  -;;; lexical location concerned by the web, a list of defining
  -;;; instructions, and a list of using instructions.
  -
  -(defun uniquify-web (web)
  -  (let* ((old (first web))
  -	 (name (sicl-mir:name old))
  -	 (new (sicl-mir:make-lexical-location name)))
  -    (mapc (lambda (instruction)
  -	    (nsubstitute new old (sicl-mir:outputs instruction)))
  -	  (second web))
  -    (mapc (lambda (instruction)
  -	    (nsubstitute new old (sicl-mir:inputs instruction)))
  -	  (third web))))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Uniquify webs.
  -;;;
  -;;; Make sure that every lexical location in a program corresponds to
  -;;; a unique web.
  -
  -(defun uniquify-webs (program)
  -  (let ((*program* program))
  -    ;; Recall that the web sets computed by COMPUTE-WEB-SETS is a list
  -    ;; that has as many elements as there are lexical locations in the
  -    ;; program.  Each element of the top-level list is a set of webs
  -    ;; represented as a list, all concerning the same lexical
  -    ;; location.  We uniqify all but one (the first) web in the list.
  -    (mapc (lambda (web-set)
  -	    (unless (null (cdr web-set))
  -	      (touch program 'instruction-graph))
  -	    (mapc #'uniquify-web (cdr web-set)))
  -	  (compute-web-sets program)))
  -  nil)
  -
  -(set-processor 'unique-webs 'uniquify-webs)
  -
  -(add-dependencies 'unique-webs
  -		  '(procedures
  -		    instruction-ownership))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Depth-first pre-order and post-order traversal of a flowchart.
  -
  -(defun depth-first-pre-order (initial-instruction)
  -  (let ((table (make-hash-table :test #'eq))
  -	(result '()))
  -    (labels ((traverse (instruction)
  -	       (unless (gethash instruction table)
  -		 (setf (gethash instruction table) t)
  -		 (loop for succ in (successors instruction)
  -		       do (traverse succ))
  -		 (push instruction result))))
  -      (traverse initial-instruction))
  -    result))
  -
  -(defun depth-first-post-order (initial-instruction)
  -  (reverse (depth-first-pre-order initial-instruction)))
  -
  -(defun backward-depth-first-pre-order (initial-instruction)
  -  (let ((table (make-hash-table :test #'eq))
  -	(result '()))
  -    (labels ((traverse (instruction)
  -	       (unless (gethash instruction table)
  -		 (setf (gethash instruction table) t)
  -		 (loop for pred in (predecessors instruction)
  -		       do (traverse pred))
  -		 (push instruction result))))
  -      (traverse initial-instruction))
  -    result))
  -  
  -(defun backward-depth-first-post-order (initial-instruction)
  -  (reverse (backward-depth-first-pre-order initial-instruction)))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Find loops.  
  -;;;
  -;;; A loop can only be the result of a TAGBODY form.  Whenever there
  -;;; is a non-trivial strongly connected component in the instruction
  -;;; graph, we have a loop.  The only restriction on loops in Common
  -;;; Lisp is that the TAGBODY form introduces a unique instruction that
  -;;; dominates every other instruction in the strongly connected
  -;;; component.  Another way of saying the same thing is that it is not
  -;;; possible to transfer control from the outside of a TAGBODY form
  -;;; into it (we shall se later that we can ignore control arcs from a
  -;;; nested procedure).  
  -;;;
  -;;; If we compute a dominance tree of all the instructions in a
  -;;; strongly connected component S, then a nested loop shows up as a
  -;;; (sub) strongly connected component immediately dominated by some
  -;;; other instruction than the one that dominates the entire component
  -;;; S.  Let us say that I0 is the instruction that dominates every
  -;;; instruction in the strongly connected component.  Let I10, I11,
  -;;; ..., I1n be the instructions in S that are immediately dominated
  -;;; by I0.  If we remove I0 and I10, I11, ... I1n from S and the
  -;;; remaining instructions contain a strongly connected component T,
  -;;; this means that there is a nested loop, and since I0 is not the
  -;;; instruction that immediately dominates them, there must be some
  -;;; other instruction I that does.  
  -;;;
  -;;; Notice that a nested loop detected this way may or may not be the
  -;;; result of a nested TAGBODY form.  It could also appear because the
  -;;; tags and the GO forms of the top-level loop form such a nested
  -;;; loop "by accident".  But we still want to count it as a nested
  -;;; loop.  And it is unlikely that such a nested loop would appear by
  -;;; accident.  
  -;;;
  -;;; Finally, it is possible that a nested loop that appears by
  -;;; accident, i.e., that is not the result of a nested TAGBODY form,
  -;;; can not be detected by the method describe above, because there is
  -;;; no restriction preventing a GO into the middle of it.  As a result
  -;;; we might have a real nested loop, but since the instructions in it
  -;;; are all directly dominated by I0, then we won't find it.
  -
  -;;; Kosaraju's algoritm is a simple algorithm for finding the strongly
  -;;; connected components of an instruction graph.  The return value is
  -;;; a set (represented as a list) of strongly connected components,
  -;;; each represented as a list of instructions.  A trivial component
  -;;; will be represented as a list of a single element.
  -(defun kosaraju (initial-instruction)
  -  (let ((pre (depth-first-pre-order initial-instruction))
  -	(table (make-hash-table :test #'eq))
  -	(result '())
  -	(temp '()))
  -    (labels ((traverse (instruction)
  -	       (unless (gethash instruction table)
  -		 (setf (gethash instruction table) t)
  -		 (loop for pred in (predecessors instruction)
  -		       do (traverse pred))
  -		 (push instruction temp))))
  -      (loop until (null pre)
  -	    for initial = (pop pre)
  -	    unless (gethash initial table)
  -	      do (setf temp '())
  -		 (traverse initial)
  -		 (push temp result))
  -      result)))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
   ;;; Compute the spill cost of every lexical location.
   ;;;
   ;;; The spill cost is computed once all new lexical locations have
  
positive.code: 
  (defun (setf successors) (new-successors instruction)
    (setf (sicl-mir:successors instruction) new-successors))
  
  (defun inputs (instruction)
    (sicl-mir:inputs instruction))
  
negative.code: 
  (add-dependencies 'lexical-depth
  		  '(location-ownership))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  