;;; This phase of the Scheme compiler figures out whether closures must be
;;; stack or heap allocated.  According to Steele's RABBIT paper, a heap
;;; allocated closure is needed for the following reasons:
;;;
;;;	- the Lambda expression is used as an argument to a function.
;;;
;;;	- the Lambda expression is bound to a variable which is used as an
;;;	  argument to a function.
;;;
;;;	- the Lambda expression is bound to a variable which is used as a 
;;;	  function within a closure.
;;;

;*              Copyright 1989 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;* 
;*                       Director of Licensing
;*                       Western Research Laboratory
;*                       Digital Equipment Corporation
;*                       100 Hamilton Avenue
;*                       Palo Alto, California  94301  
;* 
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.  
;* 
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

(module closeana)

;;; External and in-line definitions.

(include "plist.sch")
(include "expform.sch")
(include "lambdaexp.sch")
(include "miscexp.sch")

;;; Closure analysis before transformations is done by the following functions.
;;; The first is called to identify top-level functions which can be directly
;;; called, i.e. they are never assigned.  Once this is done, then further
;;; analysis is done to identify lambda expressions that must be closed over
;;; some variables.

(define (ANALYZE-CLOSURES1A exp)
    (if ($define? exp)
	(let ((var ($define-id exp))
	      (value ($define-exp exp)))
	     (if (and ($lambda? value) (not (id-set! var)))
		 (name-a-lambda var value)))))

(define (ANALYZE-CLOSURES1B exp)
    (set! walk-lambda-id 'top-level)
    (update-lambda-slots exp)
    (walk-$tree assign-lambdas exp)
    (update-lambda-slots exp)
    (walk-$tree inherit-closed exp))

;;; Given that the bindings of lambda functions are now known, it is possible
;;; to count the number of calls to the function.  Those calls which are
;;; marked tail-recursive and actually are, will not be counted.  All others
;;; will have their tail-recursive flag cleared and will be counted.  When
;;; this is done, the following will be known:
;;;
;;;	- all call's with the tail-recursive flag set will become branches.
;;;
;;;	- all lambda expressions which are stack allocated and have 1 real-call
;;;	  can be open coded at the point that they are called and any variable
;;;	  binding can be ignored.

(define (ANALYZE-CLOSURES2 exp)
    (set! walk-lambda-id 'top-level)
    (set! close-lambda-list '())
    (update-lambda-slots exp)
    (walk-$tree mark-tail-calls exp)
    (walk-$tree count-calls exp)
    (generate-lambdas close-lambda-list)
    (update-lambda-slots exp)
    (walk-$tree display-close exp))

;;; WALK-$TREE walks the tree for a function produced by PASS1 and calls the
;;; inspection function.  During the walk, WALK-LAMBDA-ID will be set to the
;;; current lambda-id.

(define (WALK-$TREE function leaf)
    (if (pair? leaf)
	(begin (function leaf)
	       (cond (($set? leaf)
		      (walk-$tree function ($set-exp leaf)))
		     (($define? leaf)
		      (walk-$tree function ($define-exp leaf)))
		     (($lambda? leaf)
		      (let ((old-walk-lambda-id walk-lambda-id))
			   (set! walk-lambda-id ($lambda-id leaf))
			   (walk-$tree-list function ($lambda-body leaf))
			   (set! walk-lambda-id old-walk-lambda-id)))
		     (($call? leaf)
		      (let ((func ($call-func leaf)))
			   (walk-$tree-list function ($call-argl leaf))
			   (walk-$tree function func)))
		     (($if? leaf)
		      (walk-$tree-list function (cdr leaf)))))))

(define (WALK-$TREE-LIST function forms)
    (for-each (lambda (leaf) (walk-$tree function leaf)) forms))

(define WALK-LAMBDA-ID 'top-level)
    
(define WALK-LAMBDA-IDS '(top-level))

(define WALK-LAMBDA-LEXICAL '())

(define CLOSE-LAMBDA-LIST '())

;;; ASSIGN-LAMBDAS tries to figure out if any lambda expression is ever
;;; used for something besides a function.  If so, it must be "closed" on the
;;; heap.
;;;
;;; Once that information has been obtained, then the closure property is
;;; propogated by INHERIT-CLOSED.

(define (ASSIGN-LAMBDAS exp)
    (cond (($set? exp)
	   (if (or (not ($lambda? ($set-exp exp)))
		   (not (eq? (id-lambda ($set-id exp))
			     ($lambda-id ($set-exp exp)))))
	       (assign-lambdas-arg ($set-exp exp))))
	  (($lambda? exp)
	   (for-each assign-lambdas-arg ($lambda-body exp)))
	  (($if? exp)
	   (assign-lambdas-arg ($if-test exp))
	   (assign-lambdas-arg ($if-true exp))
	   (assign-lambdas-arg ($if-false exp)))
	  (($call? exp)
	   (let ((func ($call-func exp)))
		(if ($lambda? func)
		    (begin (let loop ((vars (lambda-reqvars ($lambda-id func)))
				      (vals ($call-argl exp)))
 				(if vars
				    (let ((var (car vars))
					  (val (car vals)))
					 (if (and (symbol? val)
						  (id-lambda val))
					     (set-id-lambda! var
						 (id-lambda val)))
					 (loop (cdr vars) (cdr vals))))))
		    (for-each assign-lambdas-arg ($call-argl exp)))))))

(define (ASSIGN-LAMBDAS-ARG exp)
    (let ((lid (or (and (symbol? exp) (id-lambda exp))
		   ($lambda-id exp))))
	 (if lid
	     (begin (if (or (not (eq? (lambda-nestin lid) 'top-level))
			    (and (symbol? exp)
				 (not (eq? (id-use exp) 'global))))
			(begin (set-lambda-closed! lid #t)
			       (if (log? 'closed)
				   (format sc-icode
					   "~A must be a closed procedure~%"
					   lid))))
		    (lambda-is-procedure lid)))))
  
(define (INHERIT-CLOSED exp)
    (let ((closed-id ($lambda-id exp)))
	 (if (and closed-id (lambda-closed closed-id))
	     (let ((vars (indirect-lambda-lexical closed-id)))
		  (if (log? 'closed)
		      (format sc-icode "~A forces ~A to the display~%"
			      closed-id vars))
		  (for-each
		      (lambda (var) (set-id-display! var #t))
		      vars)))))

;;; The list of lexical variables used with-in the body of lid and all the
;;; lambda expressions which it calls.

(define INDIRECT-LAMBDA-CHECKED '())

(define (INDIRECT-LAMBDA-LEXICAL lid)
    (set! indirect-lambda-checked '())
    (indirect-lambda-lexical1 lid '() '()))

(define (INDIRECT-LAMBDA-LEXICAL1 lid lexvars bound)
    (if (memq lid indirect-lambda-checked)
	lexvars
	(let* ((bound (append (append (lambda-reqvars lid)
				      (lambda-optvars lid))
			      bound))
	       (calls (lambda-calls lid))
	       (lexvars (let loop ((mine (lambda-lexical lid))
				   (lexvars lexvars))
			     (define (ADD-TO-CALLS var)
				     (if (not (memq var calls))
					 (set! calls
					       (cons (id-lambda var)calls)))
				     #t)
			     (if mine
				 (let ((var (car mine)))
				      (if (or (memq var lexvars)
					      (memq var bound)
					      (and (id-lambda var)
						   (lambda-generate
						       (id-lambda var))
						   (not (eq?
							    (lambda-generate
								(id-lambda var))
							    'closed-procedure))
						   (add-to-calls var)))
					  (loop (cdr mine) lexvars)
					  (loop (cdr mine)
						(cons var lexvars))))
				 lexvars))))
	      (set! indirect-lambda-checked (cons lid indirect-lambda-checked))
	      (let loop ((calls calls) (lexvars lexvars))
		   (if calls
		       (let ((call (car calls)))
			    (if (eq? (lambda-nestin call) 'top-level)
				(loop (cdr calls) lexvars)
				(loop (cdr calls)
				      (indirect-lambda-lexical1
					  call
					  lexvars
					  bound))))
		       lexvars)))))
	     
;;; UPDATE-LAMBDA-SLOTS is called to update fields in the lambda records which
;;; may change because of transformations.  The fields updated are
;;; LAMBDA-LEXICAL and LAMBDA-CALLS.

(define (UPDATE-LAMBDA-SLOTS exp)
    (cond ((or ($set? exp) ($if? exp))
	   (for-each update-lambda-slots (cdr exp)))
	  (($define? exp)
	   (set! walk-lambda-id 'top-level)
	   (set! walk-lambda-ids '(top-level))
	   (set! walk-lambda-lexical '())
	   (update-lambda-slots ($define-exp exp)))
	  ((and ($lambda? exp) (not (memq ($lambda-id exp) walk-lambda-ids)))
	   (set! walk-lambda-ids (cons ($lambda-id exp) walk-lambda-ids))
	   (set! walk-lambda-id (car walk-lambda-ids))
	   (set-lambda-calls! walk-lambda-id '())
	   (let ((save-walk-lambda-lexical walk-lambda-lexical)
		 (lex '()))
		(for-each
		    (lambda (exp)
			    (set! walk-lambda-lexical '())
			    (update-lambda-slots exp)
			    (let loop ((vars walk-lambda-lexical))
				 (cond ((null? vars))
				       ((or (memq (car vars) lex)
					    (eq? (id-boundid (car vars))
						 walk-lambda-id))
					(loop (cdr vars)))
				       (else (set! lex (cons (car vars) lex))
					     (loop (cdr vars))))))
		    ($lambda-body exp))
		(set-lambda-lexical! walk-lambda-id lex)
		(set! walk-lambda-lexical save-walk-lambda-lexical)
		(for-each
		    (lambda (x)
			    (set! walk-lambda-lexical
				  (mergeq x walk-lambda-lexical)))
		    lex))
	   (set! walk-lambda-ids (cdr walk-lambda-ids))
	   (set! walk-lambda-id (car walk-lambda-ids)))
	  (($call? exp)
	   (let* ((func ($call-func exp))
		  (lid (or ($lambda-id func)
			   (and (symbol? func) (id-lambda func)))))
		 (when lid
		       (set-lambda-calls! walk-lambda-id
			   (mergeq lid (lambda-calls walk-lambda-id)))
		       (if (symbol? func)
			   (if (memq (lambda-generate lid)
				     '(inline inline-closed))
			       (update-lambda-slots (lambda-$lambda lid)))))
		 (update-lambda-slots func)
		 (for-each update-lambda-slots ($call-argl exp))))
	  ((and (symbol? exp)
		(id-boundid exp)
		(not (eq? (id-boundid exp) walk-lambda-id)))
	   (set! walk-lambda-lexical (mergeq exp walk-lambda-lexical)))))

;;; A simple merge function based on EQ?.

(define (MERGEQ x y)
    (cond ((null? x) y)
	  ((memq x y) y)
	  (else (cons x y))))

;;; MARK-TAIL-CALLS is called to flag all function calls which exit their
;;; containing lambda expression.  The flag is the id of the outer-most lambda
;;; expression that they exit.  Lambda expressions which are called inline
;;; will be so noted and have their generate field set to INLINE and their
;;; nestin field set correctly  at this time.  Similarly, top-level functions
;;; will have their generate field set to PROCEDURE.  Finally, a list of all
;;; lambda-id's will be collected in CLOSE-LAMBDA-LIST.

(define (MARK-TAIL-CALLS exp)
    (cond (($lambda? exp)
	   (let ((lid ($lambda-id exp)))
		(set! close-lambda-list (cons lid close-lambda-list))
		(set-lambda-str-calls! lid '())
		(set-lambda-tail-calls! lid '())
		(set-lambda-real-calls! lid '())	
		(if (eq? (lambda-nestin lid) 'top-level)
		    (if (not (lambda-generate lid)) (lambda-is-procedure lid))
		    (set-lambda-$lambda! lid exp))
		(mark-tail-calls1 (car (last-pair ($lambda-body exp))) lid)))
	  ((and ($call? exp) ($lambda? ($call-func exp)))
	   (let ((lid ($lambda-id ($call-func exp))))
		(set-lambda-nestin! lid walk-lambda-id)
		(lambda-is-inline lid)))))

(define (MARK-TAIL-CALLS1 exp exitid)
    (cond ((and ($call? exp) (not ($call-tail exp)))
	   (set-$call-tail! exp exitid)
	   (if ($lambda? ($call-func exp))
	       (begin (set-lambda-exits! ($lambda-id ($call-func exp)) exitid)
		      (mark-tail-calls1
			  (car (last-pair ($lambda-body ($call-func exp))))
			  exitid))))
	  (($if? exp)
	   (mark-tail-calls1 ($if-true exp) exitid)
	   (mark-tail-calls1 ($if-false exp) exitid))))

;;; Calls are counted by the following function.  Three lists are maintained,
;;; STR-CALLS (self-tail-recursive calls), TAIL-CALLS (other tail calls), and
;;; REAL-CALLS (other calls).  The STR-CALLS and REAL-CALLS are composed of
;;; the caller's lambda-id.  The TAIL-CALLS list is composed of two item
;;; entries of the form (caller-id tail-exit-id).  Note that calls are only
;;; counted for lambda expressions which are internal to a function as those
;;; are the only ones that can be relocated.
 
(define (COUNT-CALLS exp)
    (let* ((func (if ($call? exp) ($call-func exp) #f))
	   (id   (if (symbol? func) (id-lambda func) #f)))
	  (if (and id (not (id-external func)))
	      (cond ((eq? ($call-tail exp) id)
		     (set-lambda-str-calls! id
			 (cons walk-lambda-id (lambda-str-calls id))))
		    (($call-tail exp)
		     (set-lambda-tail-calls! id
			 (cons (list walk-lambda-id ($call-tail exp))
			       (lambda-tail-calls id))))
		    (else
		     (set-lambda-real-calls! id
			 (cons walk-lambda-id (lambda-real-calls id))))))))

;;; Once calls have been counted, it is possible to assign code generation
;;; methods to each of the lambda expressions.  This is done by this function
;;; which is called with a list of lambda expressions.  It makes an initial
;;; pass over the list and inspects those which don't have a code generation
;;; method.  Any lambda expressions that are called once are marked INLINE.
;;; Any others which have real-calls are marked (CLOSED-)PROCEDURE, and the
;;; rest (which have several tail calls) are saved for processing by
;;; GENERATE-TAILS.  Following this, any items with unknown generation methods
;;; are marked as PROCEDURE.

(define (GENERATE-LAMBDAS lambda-list)
    (let ((unknown '()))
	 (for-each
	     (lambda (lid)
		     (let ((real (lambda-real-calls lid))
			   (tail (lambda-tail-calls lid)))
			  (cond ((lambda-generate lid) #t)
				((= 1 (+ (length real) (length tail)))
				 (if tail (set-lambda-exits! lid (cadar tail)))
				 (let ((nestin (if real (car real)
						   (caar tail))))
				      (if (la-nestin-lb? nestin lid)
					  (lambda-is-procedure lid)
					  (begin (set-lambda-nestin! lid
						     nestin)
						 (lambda-is-inline lid)))))
				(real
				 (lambda-is-procedure lid))
				(else (set! unknown (cons lid unknown))))))
	     lambda-list)
	 (for-each lambda-is-procedure
	     (generate-tails (generate-tails unknown 1) 2))))

;;; GENERATE-TAILS attempts to turn the left overs into either INLINE or
;;; INLINE-TAIL calls. This is an iterative process and when no more
;;; conversions can be made, it will mark those left as PROCEDURE.  A lambda
;;; expression may be designated INLINE-TAIL when:
;;;
;;;     1.  All the callers are tail calls within the same procedure.
;;;     2.  All the calls exit the same lambda expression.
;;;
;;; FSM's are defered to the second pass to prevent lambda expressions from
;;; becoming inline-tails that could be inline.

(define (GENERATE-TAILS unknown pass)
    (let ((progress #f)
	  (still-unknown '()))
	 (for-each
	     (lambda (lid)
		     (let ((tails (remove-self-tails lid)))
			  (if (= (length tails) 1)
			      (begin (set-lambda-exits! lid (cadar tails))
				     (set-lambda-nestin! lid (caar tails))
				     (lambda-is-inline lid))
			      (verify-tails lid pass))
			  (if (lambda-generate lid)
			      (set! progress #t)
			      (set! still-unknown (cons lid still-unknown)))))
	     unknown)
	 (if progress
	     (generate-tails still-unknown pass)
	     unknown)))

(define (LAMBDA-IS-PROCEDURE lid)
    (set-lambda-$lambda! lid '())
    (if (lambda-name lid) (assign-known-name (lambda-name lid)))
    (if (lambda-closed lid)
	(begin (set-lambda-nestin! lid 'top-level)
	       (set-lambda-generate! lid 'closed-procedure))
	(set-lambda-generate! lid 'procedure)))

(define (LAMBDA-IS-INLINE lid)
    (if (lambda-name lid) (set-id-display! (lambda-name lid) #f))
    (set-lambda-generate! lid 'inline))

(define (LAMBDA-IS-INLINE-TAIL lid)
    (if (lambda-name lid) (set-id-display! (lambda-name lid) #f))
    (set-lambda-generate! lid 'inline-tail))

(define (REMOVE-SELF-TAILS lid)
    (do ((tails (lambda-tail-calls lid) (cdr tails))
	 (newtails '()))
	((null? tails)
	 (set-lambda-tail-calls! lid newtails)
	 newtails)
	(if (not (eq? (generate-tails-exits (cadar tails)) lid))
	    (set! newtails (cons (car tails) newtails)))))

(define (VERIFY-TAILS lid pass)
    (do ((tails (lambda-tail-calls lid) (cdr tails))
	 (exits  '()))
	((null? tails)
	 (let ((exits (if (= (length exits) 1) (car exits) #f)))
	      (if exits	 
		  (begin (do ((inline-tails (lambda-inline-tails exits)
				  (merge-inline-tails (car ids) inline-tails))
			      (ids (cons lid (lambda-inline-tails lid)) 
				   (cdr ids)))
			     ((null? ids)
			      (set-lambda-inline-tails! exits inline-tails))
			     (set-lambda-exits! (car ids) exits))
			 (set-lambda-inline-tails! lid '())
			 (set-lambda-nestin! lid exits)
			 (lambda-is-inline-tail lid)))))
	(let ((x (generate-tails-exits (cadar tails))))
	     (if (and (not (memq x exits))
		      (or (eq? pass 1)
			  (not (could-inline-tail? (cadar tails) exits))))
		 (set! exits (cons x exits))))))

(define (GENERATE-TAILS-EXITS lid)
    (if (and (memq (lambda-generate lid) '(inline inline-tail))
	     (lambda-exits lid))
	(generate-tails-exits (lambda-exits lid))
	lid))

;;; A lambda expression that could be inline-tailed in the current context is
;;; one whose generation method is unknown and who only tail calls items who's
;;; generation methods are unknown or a member of the exits list.

(define (COULD-INLINE-TAIL? lid exits)
    (and (not (lambda-generate lid))
	 (let loop ((tails (lambda-tail-calls lid)))
	      (if tails
		  (let ((exit (generate-tails-exits (cadar tails))))
		       (if (and (lambda-generate exit) (not (memq exit exits)))
			   #f
			   (loop (cdr tails))))
		  #t))))

;;; The INLINE-TAILS list is ordered such that lambda expressions occur before
;;; those which nest in them and before those which they call.  This is
;;; required to generate correct code.
 
(define (MERGE-INLINE-TAILS lid tails)
    (cond ((null? tails) (list lid))
	  ((or (la-nestin-lb? (car tails) lid)
	       (memq (car tails) (lambda-calls lid)))
	   (cons lid tails))
	  (else (cons (car tails) (merge-inline-tails lid (cdr tails))))))

;;; The following boolean tests whether lambda expression "a" is nested in
;;; lambda expression "b".

(define (LA-NESTIN-LB? la lb)
    (cond ((eq? la lb)          #t)
          ((eq? la 'top-level)  #f)
          (else                 (la-nestin-lb? (lambda-nestin la) lb))))

;;; Once all the code generation modes for each lambda expression have been
;;; decided, the final analysis step is to decide which lexical variables must
;;; be allocated in the display.  A variable must be allocated to the display
;;; if it is used by a "closed" procedure, or it is lexically referenced
;;; across a C procedure boundary.

(define (DISPLAY-CLOSE exp)
    (if ($lambda? exp)
	(let ((id ($lambda-id exp)))
	     (if (memq (lambda-generate id) '(procedure closed-procedure))
		 (for-each
		     (lambda (var)
			     (cond ((and (id-lambda var)
					 (not (eq? (lambda-generate
						       (id-lambda var))
						   'closed-procedure)))
				    (set-id-display! var #f))
				   ((not (id-display var))
				    (if (log? 'closed)
					(format sc-icode
						"~A forces ~A to display~%"
						id var))
				    (set-id-display! var #t))))
		     (lambda-lexical id))))))