;;; -*- Mode:LISP; Package:NC; Base:10; Readtable:CL -*-

;;; Copyright (c) 1985 Yale University
;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale University Computer 
;;; Science Department.  Permission to copy this software, to redistribute it, 
;;; and to use it for any purpose is granted, subject to the following restric-
;;; tions and understandings.
;;; 1. Any copy made of this software must include this copyright notice in full.
;;; 2. Users of this software agree to make their best efforts (a) to return
;;;    to the T Project at Yale any improvements or extensions that they make,
;;;    so that these may be included in future releases; and (b) to inform
;;;    the T Project of noteworthy uses of this software.
;;; 3. All materials developed as a consequence of the use of this software
;;;    shall duly acknowledge such use, in accordance with the usual standards
;;;    of acknowledging credit in academic research.
;;; 4. Yale has made no warrantee or representation that the operation of
;;;    this software will be error-free, and Yale is under no obligation to
;;;    provide any services, by way of maintenance, update, or otherwise.
;;; 5. In conjunction with products arising from the use of this material,
;;;    there shall be no use of the name of the Yale University nor of any
;;;    adaptation thereof in any advertising, promotional, or sales literature
;;;    without prior written consent from Yale in each case.
;;;

;;;  Optimization of CPS code tree

;;; Post-CPS code has these properties:
;;;   For every LAMBDA node L:
;;;     - L's body is a call.
;;;     - L's parent is a call, or else L is the top of the tree.
;;;   For every call node N:
;;;     - N's procedure and arguments are all non-calls.
;;;     - N's parent is a LAMBDA.

;;; (SIMPLIFY node-pair)
;;;============================================================================
;;;   Post-CPS optimizer.  All simplifications are done by changing the
;;; structure of the node tree.  NODE-PAIR is a pair whose CAR contains a
;;; leaf-node or a lambda-node.
;;;
;;; There are three requirements for the simplification procedures:
;;;    1) They must return T if the tree has been changed and NIL otherwise.
;;;    2) Only the node being simplified and its descendents may be changed.
;;;    3) If a node is changed the NODE-SIMPLIFIED? flag of that node and all
;;;       its ancestors must be set to NIL.

(defun simplify (node-pair)
  (let ((node (car node-pair)))
    (unless (node-simplified? node)
      (do ((node node (car node-pair)))
	  ((not (cond ((lambda-node? node) (simplify-lambda node))
;		      ((leaf-node?   node) (simplify-leaf   node))
;		      ((object-node? node) (simplify-object node))
		      ))))
      (setf (node-simplified? node) t))))


#||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

;;; (SIMPLIFY-LEAF node)
;;;==========================================================================
;;;   Leaf nodes are simplified only if they are variables with early binding
;;; information.

(defun simplify-leaf (node)
  (if (and (reference-node? node)
	   (not (nonvalue-reference? node)))
      (integrate-support node)))


This was called by simplify call to replace references with primops
primops are now integrated at alphatization time
;;; (INTEGRATE-SUPPORT node)
;;;============================================================================
;;;    NODE is a reference to a variable with early binding.  Integrate if
;;; possible, otherwise nothing.
;;;  
;;; This needs to deal with call exit nodes....

(defun integrate-support (node)
  (let* ((var (reference-variable node))
         (support (get-variable-support var)))
    (if (and support
	     (eq 'constant (support-variant support)))
	(let ((value (support-value support))
	      (type (support-type support)))
	  (if value
	      (integrate-value node value type))))))

(defun integrate-value (node value type)
  (let ((new (if (eq (node-role node) call-proc)
		 (integrable-proc-value value type node)
	       (integrable-value value type node))))
    (if new
	(let ((new (vector->node new)))
	  (replace-node node new)
	  (when (and (primop-node? new)
		     (eq (node-role new) call-proc))
	    ;; this assumes that no primop actually wants an open...
	    (bash-open (node-parent new))
	    (primop.presimplify (primop-value new) (node-parent new)))
	  t))))

(defun integrable-value (exp type node)
  (cond ((eq type 'literal) exp)
        ((primop? exp)
         (if (primop.integrate? exp node) exp))))

(defun integrable-proc-value (exp type node)
  (cond ((primop? exp)
         (if (primop.integrate? exp node) exp))
        ((and (consp type)
              (eq (car type) 'proc))
         (if (arg-check-of-type type (node-parent node)) exp))
        ((eq type 'object)
         (if (consp exp) (caddr exp)))))

||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||#

;;; (SIMPLIFY-LAMBDA node)
;;;============================================================================
;;;     Simplify a lambda node.
;;; (lambda () (x)) => x if the node is an exit.

(defun simplify-lambda (node)
  (simplify-call node)
  (when (and (or (call-exit? node)
		 (let-node? (node-parent node)))
	     (not (lambda-rest-var node))
	     (null (lambda-variables node))
	     (null (call-args (lambda-body node)))
	     (reference-node? (call-proc (lambda-body node)))
	     (variable-binder
	       (reference-variable (call-proc (lambda-body node)))))
    (replace-node node (detach (call-proc (lambda-body node))))
    t))

(defun let-node? (node)
  (and (call-node? node)
       (lambda-node? (call-proc node))))

#||||||||||

;;; (SIMPLIFY-OBJECT node)
;;;============================================================================
;;; Should replace literal proc with (lambda args (undefined-effect))
;;; If in call position should replace with proc

(defun simplify-object (node)
  (simplify (object-proc-pair node))
  (mapl #'simplify (object-operations node))
  (mapl #'simplify (object-methods node))
  (let ((proc (known-value (object-proc node))))
    (cond ((and proc 
                (or (and (node-p proc) (literal-node? proc))
                    (and (consp proc) (eq (car proc) 'literal))))
           (replace-node (object-proc node)
                    (s-exp->node `(lambda p (() c)
                                    (1 ,primop/undefined-effect
                                       c
              (quote . "calling an object that has no procedure"))))))))
  nil)

|||||||||#