#| -*-Scheme-*-

$Id: rgproc.scm,v 4.19 2007/04/29 20:16:05 cph Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; RTL Generation: Procedure Headers
;;; package: (compiler rtl-generator generate/procedure-header)

(declare (usual-integrations))

(define (generate/procedure-header procedure body inline?)
  (scfg*scfg->scfg!
   (let ((context (make-reference-context (procedure-block procedure))))
     (set-reference-context/offset! context 0)
     (if (procedure/ic? procedure)
	 (scfg*scfg->scfg!
	  (if inline?
	      (make-null-cfg)
	      (rtl:make-ic-procedure-header (procedure-label procedure)))
	  (setup-ic-frame procedure context))
	 (scfg*scfg->scfg!
	  (cond (inline?
		 ;; Paranoia
		 (if (not (procedure/virtually-open? procedure))
		     (error "Inlining a real closure!" procedure))
		 (make-null-cfg))
		((procedure/closure? procedure)
		 (let ((needs-entry?
			(or (procedure-rest procedure)
			    (closure-procedure-needs-external-descriptor?
			     procedure))))
		   (cond ((not (procedure/trivial-closure? procedure))
			  (let* ((block (procedure-closing-block procedure))
				 (nentries (block-entry-number
					    (block-shared-block block))))
			    (if (or (not needs-entry?) (zero? nentries))
				;; It's not an open procedure but it looks like
				;; one at the rtl level.
				(rtl:make-open-procedure-header
				 (procedure-label procedure))
				(rtl:make-closure-header
				 (procedure-label procedure)
				 nentries
				 (closure-block-entry-number block)))))
			 (needs-entry?
			  (with-values
			      (lambda () (procedure-arity-encoding procedure))
			    (lambda (min max)
			      (rtl:make-procedure-header
			       (procedure-label procedure)
			       min max))))
			 (else
			  ;; It's not an open procedure but it looks like one
			  ;; at the rtl level.
			  (rtl:make-open-procedure-header
			   (procedure-label procedure))))))
		((procedure-rest procedure)
		 (with-values (lambda () (procedure-arity-encoding procedure))
		   (lambda (min max)
		     (if (open-procedure-needs-dynamic-link? procedure)
			 (scfg*scfg->scfg!
			  (rtl:make-procedure-header
			   (procedure-label procedure)
			   (1+ min)
			   (-1+ max))
			  (rtl:make-pop-link))
			 (rtl:make-procedure-header (procedure-label procedure)
						    min max)))))
		(else
		 (rtl:make-open-procedure-header (procedure-label procedure))))
	  (setup-stack-frame procedure context))))
   body))

(define (setup-ic-frame procedure context)
  (scfg*->scfg!
   (map (let ((block (procedure-block procedure)))
	  (lambda (name value)
	    (generate/rvalue value scfg*scfg->scfg!
	     (lambda (expression)
	       (load-temporary-register scfg*scfg->scfg! expression
		(lambda (expression)
		  (wrap-with-continuation-entry
		   context
		   (lambda (cont-label)
		     (rtl:make-interpreter-call:set!
		      cont-label
		      (rtl:make-fetch register:environment)
		      (intern-scode-variable! block (variable-name name))
		      expression)))))))))
	(procedure-names procedure)
	(procedure-values procedure))))

(define (setup-stack-frame procedure context)
  (let ((block (procedure-block procedure)))
    (define (cellify-variables variables)
      (scfg*->scfg! (map cellify-variable variables)))

    (define (cellify-variable variable)
      (if (and (variable-in-cell? variable)
	       (not (and (variable-source-node variable)
			 (procedure-inline-code? procedure))))
	  (let ((locative
		 (let ((register (variable/register variable)))
		   (or register
		       (stack-locative-offset
			(rtl:make-fetch register:stack-pointer)
			(variable-offset block variable))))))
	    (rtl:make-assignment
	     locative
	     (rtl:make-cell-cons (rtl:make-fetch locative))))
	  (make-null-cfg)))

    (let ((names (procedure-names procedure))
	  (values (procedure-values procedure)))
      (scfg-append!
       (setup-bindings names values '())
       (cellify-variables (procedure-required-arguments procedure))
       (cellify-variables (procedure-optional procedure))
       (let ((rest (procedure-rest procedure)))
	 (if rest
	     (cellify-variable rest)
	     (make-null-cfg)))
       (scfg*->scfg! (map (lambda (name value)
			    (close-binding context name value))
			  names values))))))

(define (setup-bindings names values pushes)
  (if (null? names)
      (scfg*->scfg! pushes)
      (setup-bindings (cdr names)
		      (cdr values)
		      (letrec-value (car names) (car values)
		       (lambda (scfg expression)
			 (cons (scfg*scfg->scfg!
				scfg
				(make-auxiliary-push (car names) expression))
			       pushes))))))

(define (make-auxiliary-push variable value)
  (rtl:make-push (if (variable-in-cell? variable)
		     (rtl:make-cell-cons value)
		     value)))

(define (letrec-value name value recvr)
  (cond ((constant? value)
	 (recvr (make-null-cfg)
		(rtl:make-constant (constant-value value))))
	((procedure? value)
	 (enqueue-procedure! value)
	 (case (procedure/type value)
	   ((CLOSURE)
	    (let ((closing-block (procedure-closing-block value)))
	      (recvr
	       (make-null-cfg)
	       (if (eq? closing-block (block-shared-block closing-block))
		   (make-non-trivial-closure-cons value false)
		   (let ((how (procedure-closure-cons value)))
		     (cond ((or (not (eq? (car how) 'INDIRECTED))
				(not (eq? (variable-block (cdr how))
					  (variable-block name))))
			    (make-cons-closure-redirection value))
			   ((not (variable-in-cell? name))
			    (error "letrec-value: Non-indirected shared sibling!"
				   value))
			   (else
			    (rtl:make-constant
			     (make-unassigned-reference-trap)))))))))
	   ((IC)
	    (with-values (lambda () (make-ic-cons value 'USE-ENV)) recvr))
	   ((TRIVIAL-CLOSURE)
	    ;; This is not an error.
	    ;; It can be the consequence of bad style.
	    ;;(warn "Letrec value is trivial closure" value)
	    (recvr (make-null-cfg)
		   (make-trivial-closure-cons value)))
	   ((OPEN-EXTERNAL OPEN-INTERNAL)
	    (error "Letrec value is open procedure" value))
	   (else
	    (error "Unknown procedure type" value))))
	((block? value)
	 (for-each
	  (lambda (block*)
	    (enqueue-procedure!
	     (block-procedure (car (block-children block*)))))
	  (block-grafted-blocks value))
	 (recvr (make-null-cfg)
		(make-non-trivial-closure-cons
		 (indirection-block-procedure value)
		 value)))
	(else
	 (error "Unknown letrec binding value" value))))

(define (close-binding context name value)
  (cond ((block? value)
	 (letrec-close context name
		       (indirection-block-procedure value)))
	((and (procedure? value)
	      (not (procedure/trivial-or-virtual? value)))
	 (let ((closing-block (procedure-closing-block value)))
	   (if (eq? closing-block (block-shared-block closing-block))
	       (letrec-close context name value)
	       (let ((how (procedure-closure-cons value)))
		 (cond ((or (not (eq? (car how) 'INDIRECTED))
			    (not (eq? (variable-block (cdr how))
				      (variable-block name))))
			(make-null-cfg))
		       ((not (variable-in-cell? name))
			(error "close-binding: Non-indirected shared sibling!"
			       value))
		       (else
			(find-variable/locative
			 context name
			 (lambda (locative)
			   (rtl:make-assignment
			    locative
			    (make-cons-closure-indirection value)))
			 (lambda (environment name)
			   environment
			   (error "close-binding: IC letrec name" name))
			 (lambda (name)
			   (error "close-binding: cached letrec name"
				  name)))))))))
	(else
	 (make-null-cfg))))

(define (letrec-close context variable value)
  (load-closure-environment
   value
   (find-variable/value/simple
    context variable
    "letrec-close: Missing closure variable")
   context))