anchor.diff:     ;; instructions. 
      (%predecessors :initform nil :accessor predecessors)
      ;; This table maps each instruction of the program to
  -   ;; the code object to which the instruction belongs.
  -   (%instruction-code :initform nil :accessor instruction-code)
  -   ;; This table maps each location of the program to the code object
  -   ;; to which the location belongs.
  -   (%location-code :initform nil :accessor location-code)
  -   ;; For each instruction, give a set of locations together with
  -   ;; their use distance immediately before the instruction.
  +   ;; an instruction-info instance. 
  +   (%instruction-info :initform nil :accessor instruction-info)
  +   ;; This table maps each location of the program to
  +   ;; a location-info instance.
  +   (%location-info :initform nil :accessor location-info)
  +   ;; All the procedures of this program.
  +   (%procedures :initform '() :accessor procedures)))
  +
  +;;; This variable holds the current program that is being processed.
  +;;; By doing it this way, we avoid having to pass it as an argument to
  +;;; every function, and we also avoid the need for back pointers in
  +;;; every class.
  +(defparameter *program* nil)
  +
  +(defun map-instructions (function)
  +  (assert (not (null *program*)))
  +  (maphash (lambda (instruction info)
  +	     (declare (ignore info))
  +	     (funcall function instruction))
  +	   (instruction-info *program*)))
  +
  +(defun map-locations (function)
  +  (assert (not (null *program*)))
  +  (maphash (lambda (location info)
  +	     (declare (ignore info))
  +	     (funcall function location))
  +	   (location-info *program*)))
  +
  +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  +;;;
  +;;; Instruction info.
  +;;;
  +;;; We need a lot of information about an instruction.  Rather than
  +;;; storing that information in the instruction itself, we store it in
  +;;; an INSTRUCTION-INFO object.  There is one such object for each
  +;;; instruction, we put it in a hash table with the instruction as a key. 
  +
  +(defgeneric predecessors (instruction-or-info))
  +(defgeneric (setf predecessors) (new instruction-or-info))
  +(defgeneric procedure (instruction-or-info))
  +(defgeneric (setf procedure) (new instruction-or-info))
  +(defgeneric basic-block (instruction-or-info))
  +(defgeneric (setf basic-block) (new instruction-or-info))
  +(defgeneric pre-locations (instruction-or-info))
  +(defgeneric (setf pre-locations) (new instruction-or-info))
  +(defgeneric post-locations (instruction-or-info))
  +(defgeneric (setf post-locations) (new instruction-or-info))
  +
  +(defclass instruction-info ()
  +  (;; The list of predecessor instructions of this instruction. 
  +   (%predecessors :initform nil :accessor predecessors)
  +   ;; The procedure to which this instruction belongs.
  +   (%procedure :initform nil :accessor procedure)
  +   ;; The basic block to which this instruction belongs.
  +   (%basic-block :initform nil :accessor basic-block)
  +   ;; A set of CONS pairs (location . distance) that are valid
  +   ;; immediatly before this instruction.
      (%pre-locations :initform nil :accessor pre-locations)
  -   ;; For each instruction, give a set of locations together with
  -   ;; their use distance immediately after the instruction.
  -   (%post-locations :initform nil :accessor post-locations)
  -   ;; All the code objects of this program.
  -   (%code-objects :initform '() :accessor code-objects)))
  +   ;; A set of CONS pairs (location . distance) that are valid
  +   ;; immediatly after this instruction.
  +   (%post-locations :initform nil :accessor post-locations)))
  +
  +(defmethod predecessors ((instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (predecessors (gethash instruction (instruction-info *program*))))
  +
  +(defmethod (setf predecessors) (new (instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (setf (predecessors (gethash instruction (instruction-info *program*)))
  +	new))
  +
  +(defmethod procedure ((instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (procedure (gethash instruction (instruction-info *program*))))
  +
  +(defmethod (setf procedure) (new (instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (setf (procedure (gethash instruction (instruction-info *program*)))
  +	new))
  +
  +(defmethod basic-block ((instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (basic-block (gethash instruction (instruction-info *program*))))
  +
  +(defmethod (setf basic-block) (new (instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (setf (basic-block (gethash instruction (instruction-info *program*)))
  +	new))
  +
  +(defmethod pre-locations ((instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (pre-locations (gethash instruction (instruction-info *program*))))
  +
  +(defmethod (setf pre-locations) (new (instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (setf (pre-locations (gethash instruction (instruction-info *program*)))
  +	new))
  +
  +(defmethod post-locations ((instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (post-locations (gethash instruction (instruction-info *program*))))
  +
  +(defmethod (setf post-locations) (new (instruction p2:instruction))
  +  (assert (not (null *program*)))
  +  (setf (post-locations (gethash instruction (instruction-info *program*)))
  +	new))
  +
  +(defun successors (instruction)
  +  (p2:successors instruction))
  +
  +(defun inputs (instruction)
  +  (p2:inputs instruction))
  +
  +(defun outputs (instruction)
  +  (p2:outputs instruction))
  +
  +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  +;;;
  +;;; Location info.
  +;;;
  +;;; As with instructions, We need a som information about a
  +;;; location.  Again, rather than storing that information in the
  +;;; location itself, we store it in an LOCATION-INFO object.  There is
  +;;; one such object for each location, we put it in a hash table
  +;;; with the location as a key.
  +
  +(defclass location-info ()
  +  (;; The procedure to which this instruction belongs.
  +   (%procedure :initform nil :accessor procedure)))
  +
  +(defmethod procedure ((location sicl-env:lexical-location))
  +  (assert (not (null *program*)))
  +  (procedure (gethash location (location-info *program*))))
  +
  +(defmethod (setf procedure) (new (location sicl-env:lexical-location))
  +  (assert (not (null *program*)))
  +  (setf (procedure (gethash location (location-info *program*)))
  +	new))
  +
  +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  +;;;
  +;;; An instances of the PROCEDURE class represents a single procedure.
  +;;; An instruction is the INITIAL INSTRUCTION of a procedure if and
  +;;; only if it is either the initial instruction of a PROGRAM (see
  +;;; below) or the INPUT of an ENCLOSE instruction.  The initial
  +;;; instruction of a procedure does not have any predecessors.  A
  +;;; procedure can be the input of at most one ENCLOSE instructions.
  +;;; To preserve this property, inlining a procedure must duplicate
  +;;; it, all the instructions in it, and all the lexical locations in
  +;;; it.
  +;;;
  +;;; The procedures of a program are nested, and the outermost
  +;;; procedure is at NESTING DEPTH 0.  A procedure B is IMMEDIATELY
  +;;; NESTED inside a procedure A if and only if its initial instruction
  +;;; is the INPUT to an ENCLOSE instruction that belongs to procedure
  +;;; A.  A procedure B immediately nested inside a procedure A has a
  +;;; nesting depth with is one greater than the nesting depth of A.
  +;;;
  +;;; An INSTRUCTION is said to be PRESENT in a procedure A if it can
  +;;; be reached from the initial instruction of A by following
  +;;; successor arcs only.
  +;;; 
  +;;; An INSTRUCTION is said to BELONG to a procedure A if it is
  +;;; present in A, but it is not present in any procedure with a
  +;;; smaller nesting depth than that of A. 
  +;;; 
  +;;; An INSTRUCTION can be present in several procedures, but can
  +;;; belong to only one.  An instruction is present in more than one
  +;;; procedures when it belongs to some procedure A, but it can also be
  +;;; reached from an instruction in a procedure B nested inside A, so
  +;;; that B has a nesting depth that is greater than that of A. Such a
  +;;; situation is the result of a RETURN-FROM or a GO form that
  +;;; transfers control from one procedure to an enclosing procedure.
  +
  +(defclass procedure ()
  +  ((%initial-instruction
  +    :initarg :initial-instruction :accessor initial-instruction)
  +   ;; Instructions that belong to this procedure. 
  +   (%instructions :initform '() :accessor instructions)
  +   ;; Locations that  belong to this procedure. 
  +   (%locations :initform '() :accessor locations)
  +   (%nesting-depth :initarg :nesting-depth :accessor nesting-depth)
  +   (%lexical-depth :initform nil :accessor lexical-depth)
  +   ;; The basic blocks that belong to this procedure.
  +   (%basic-blocks :initform '() :accessor basic-blocks)))
  +
  +(defun make-procedure (initial-instruction nesting-depth)
  +  (make-instance 'procedure
  +    :initial-instruction initial-instruction
  +    :nesting-depth nesting-depth))
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;;
   ;;; For each instruction in a complete instruction graph, determine
  -;;; all the nested code objects, and to which code object each
  +;;; all the nested procedures, and to which procedure each
   ;;; instruction belongs.
   
   (defun compute-instruction-ownership (program)
     (with-accessors ((initial-instruction initial-instruction)
  -		   (instruction-code instruction-code)
  -		   (code-objects code-objects))
  +		   (instruction-info instruction-info)
  +		   (procedures procedures))
         program
  -    (setf instruction-code (make-hash-table :test #'eq))
  -    (let* ((first (make-code-object initial-instruction 0))
  -	   (worklist (list first)))
  -      (push first code-objects)
  -      (flet
  -	  ((handle-single-code-object (code-object)
  -	     (labels
  -		 ((aux (instruction)
  -		    (when (null (gethash instruction instruction-code))
  -		      (setf (gethash instruction instruction-code)
  -			    code-object)
  -		      (when (typep instruction 'p2:enclose-instruction)
  -			(let ((new (make-code-object
  -				    (p2:code instruction)
  -				    (1+ (nesting-depth code-object)))))
  -			  (push new code-objects)
  -			  (setf worklist (append worklist (list new)))))
  -		      (mapc #'aux (p2:successors instruction)))))
  -	       (aux (initial-instruction code-object)))))
  -	(loop until (null worklist)
  -	      do (handle-single-code-object (pop worklist)))))
  -    (maphash (lambda (instruction code-object)
  -	       (push instruction (instructions code-object)))
  -	     instruction-code)))
  +    (let ((*program* program))
  +      (setf instruction-info (make-hash-table :test #'eq))
  +      (let* ((first (make-procedure initial-instruction 0))
  +	     (worklist (list first)))
  +	(push first procedures)
  +	(flet
  +	    ((handle-single-procedure (procedure)
  +	       (labels
  +		   ((aux (instruction)
  +		      (when (null (gethash instruction instruction-info))
  +			(setf (gethash instruction instruction-info)
  +			      (make-instance 'instruction-info))
  +			(setf (procedure instruction) procedure)
  +			(when (typep instruction 'p2:enclose-instruction)
  +			  (let ((new (make-procedure
  +				      (p2:code instruction)
  +				      (1+ (nesting-depth procedure)))))
  +			    (push new procedures)
  +			    (setf worklist (append worklist (list new)))))
  +			(mapc #'aux (successors instruction)))))
  +		 (aux (initial-instruction procedure)))))
  +	  (loop until (null worklist)
  +		do (handle-single-procedure (pop worklist)))))
  +      (map-instructions
  +       (lambda (instruction)
  +	 (push instruction (instructions (procedure instruction))))))))
   
   (defun ensure-instruction-ownership (program)
  -  (when (null (instruction-code program))
  +  (when (null (instruction-info program))
       (compute-instruction-ownership program)))
   
  -(defun instruction-owner (instruction program)
  -  (ensure-instruction-ownership program)
  -  (gethash instruction (instruction-code program)))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Determine the predecessors of every instruction in a program
  +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  +;;;
  +;;; Determine the predecessors of every instruction in a program.
   
   (defun compute-predecessors (program)
     (ensure-instruction-ownership program)
  -  (with-accessors ((instruction-code instruction-code)
  -		   (predecessors predecessors))
  -      program
  -    (setf predecessors (make-hash-table :test #'eq))
  -    (maphash (lambda (instruction code)
  -	       (declare (ignore code))
  -	       (loop for successor in (p2:successors instruction)
  -		     do (push instruction (gethash successor predecessors))))
  -	      instruction-code)))
  -
  -(defun ensure-predecessors (program)
  -  (when (null (predecessors program))
  -    (compute-predecessors program)))
  -
  -(defun instruction-predecessors (instruction program)
  -  (ensure-predecessors program)
  -  (gethash instruction (predecessors program)))
  +  (let ((*program* program))
  +    (map-instructions
  +     (lambda (instruction)
  +       (loop for successor in (successors instruction)
  +	     do (push instruction (predecessors successor)))))))
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;;
   ;;; For each location in a complete instruction graph, determine
  -;;; to which code object each location belongs.
  +;;; to which procedure each location belongs.
   
   (defun compute-location-ownership (program)
  -  (with-accessors ((location-code location-code)
  -		   (code-objects code-objects))
  -      program
  -    (ensure-instruction-ownership program)
  -    (setf location-code (make-hash-table :test #'eq))
  -    (let ((sorted-code
  -	    (sort (copy-list code-objects) #'< :key #'nesting-depth)))
  -      (loop for code-object in sorted-code
  -	    do (loop for instruction in (instructions code-object)
  -		     do (loop for info in (append (p2:inputs instruction)
  -						  (p2:outputs instruction))
  -			      for location = (sicl-env:location info)
  -			      do (when (null (gethash location location-code))
  -				   (setf (gethash location location-code)
  -					 code-object))))))
  -    (maphash (lambda (location code-object)
  -	       (push location (locations code-object)))
  -	     location-code)))
  +  (let ((*program* program))
  +    (with-accessors ((procedures procedures))
  +	program
  +      (ensure-instruction-ownership program)
  +      (setf (location-info program) (make-hash-table :test #'eq))
  +      (let ((sorted-code
  +	      (sort (copy-list procedures) #'< :key #'nesting-depth)))
  +	(loop for procedure in sorted-code
  +	      do (loop for instruction in (instructions procedure)
  +		       do (loop for info in (append (inputs instruction)
  +						    (outputs instruction))
  +				for location = (sicl-env:location info)
  +				do (when (null (procedure location))
  +				     (setf (procedure location) procedure))))))
  +      (map-locations (lambda (location)
  +		       (push location (locations (procedure location))))))))
   
   (defun ensure-location-ownership (program)
  -  (when (null (location-code program))
  +  (when (null (location-info program))
       (compute-location-ownership program)))
   
   (defun location-owner (location program)
     (ensure-location-ownership program)
  -  (gethash location (location-code program)))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Determine the LEXICAl DEPTH of each code object in a program.
  -
  -(defun compute-lexical-depth (code-object program)
  -  (setf (lexical-depth code-object)
  -	(loop for location in (locations code-object)
  +  (gethash location (location-info program)))
  +
  +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  +;;;
  +;;; Determine the LEXICAl DEPTH of each procedure in a program.
  +
  +(defun compute-lexical-depth (procedure program)
  +  (setf (lexical-depth procedure)
  +	(loop for location in (locations procedure)
   	      maximize  (let ((owner (location-owner location program)))
  -			  (if (eq owner code-object)
  +			  (if (eq owner procedure)
   			      0
   			      (1+ (lexical-depth owner)))))))
   
   (defun compute-lexical-depths (program)
  -  (with-accessors ((code-objects code-objects))
  -      program
  -    (let ((sorted-code
  -	    (sort (copy-list code-objects) #'< :key #'nesting-depth)))
  -      (loop for code-object in sorted-code
  -	    do (compute-lexical-depth code-object program)))))
  +  (let ((*program* program))
  +    (with-accessors ((procedures procedures))
  +	program
  +      (let ((sorted-code
  +	      (sort (copy-list procedures) #'< :key #'nesting-depth)))
  +	(loop for procedure in sorted-code
  +	      do (compute-lexical-depth procedure program))))))
   
   (defun ensure-lexical-depths (program)
  -  (when (member nil (code-objects program) :key #'lexical-depth)
  +  (when (member nil (procedures program) :key #'lexical-depth)
       (compute-lexical-depths program)))
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
positive.code: (in-package #:sicl-optimize)
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; An instances of the CODE-OBJECT class represents a single code
  ;;; object.  An instruction is the INITIAL INSTRUCTION of a code
  ;;; object if and only if it is either the initial instruction of a
  ;;; PROGRAM (see below) or the INPUT of an ENCLOSE instruction.  The
  ;;; initial instruction of a code object does not have any
  ;;; predecessors.  A code object can be the input of at most one
  ;;; ENCLOSE instructions.  To preserve this property, inlining a code
  ;;; object must duplicate it, all the instructions in it, and all the
  ;;; lexical locations in it.
  ;;;
  ;;; The code objects of a program are nested, and the outermost code
  ;;; object is at NESTING DEPTH 0.  A code object B is IMMEDIATELY
  ;;; NESTED inside a code object A if and only if its initial
  ;;; instruction is the INPUT to an ENCLOSE instruction that belongs to
  ;;; code object A.  A code object B immediately nested inside a code
  ;;; object A has a nesting depth with is one greater than the nesting
  ;;; depth of A.
  ;;;
  ;;; An INSTRUCTION is said to be PRESENT in a code object A if it can
  ;;; be reached from the initial instruction of A by following
  ;;; successor arcs only.
  ;;; 
  ;;; An INSTRUCTION is said to BELONG to a code object A if it is
  ;;; present in A, but it is not present in any code object with a
  ;;; smaller nesting depth than that of A. 
  ;;; 
  ;;; An INSTRUCTION can be present in several code objects, but can
  ;;; belong to only one.  An instruction is present in more than one
  ;;; code objects when it belongs to some code object A, but it can
  ;;; also be reached from an instruction in a code object B nested
  ;;; inside A, so that B has a nesting depth that is greater than that
  ;;; of A. Such a situation is the result of a RETURN-FROM or a GO form
  ;;; that transfers control from one code object to an enclosing code
  ;;; object.
  ;;;
  ;;; A LOCATION is an explicit (present in source code) or implicit
  ;;; (allocated by the compiler) lexical "place" used to store local
  ;;; variables and temporaries.  Locations are not directly used as
  
negative.code:   ((%initial :initarg :initial :accessor initial)
     (%final :initarg :final :accessor final)))
  
  (defun compute-basic-blocks-for-procedure (procedure program)
    (ensure-instruction-ownership program)
    (with-accessors ((instructions instructions)
  		   (basic-blocks basic-blocks))
        procedure
      (let ((remaining instructions))
        (flet ((one-block (instruction)
  	       (let ((initial instruction)
  		     (final instruction))
  		 (loop for preds = (predecessors initial)
  		       while (= (length preds) 1)
  		       for pred = (car preds)
  		       while (eq (procedure pred) procedure)
  		       for succs = (successors pred)
  		       while (= (length succs) 1)
  		       do (setf initial pred)
  			  (setf remaining (remove pred remaining :test #'eq)))
  		 (loop for succs = (successors final)
  		       while (= (length succs) 1)
  		       for succ = (car succs)
  		       while (eq (procedure succ) procedure)
  		       for preds = (predecessors succ)
  		       while (= (length preds) 1)
  		       do (setf final succ)
  			  (setf remaining (remove succ remaining :test #'eq)))
  