;;; -*- Mode:Common-Lisp; Package:L; Base:10 -*-
;;;
;;; Basic Block code for preasm.
;;;
;;; jsp 23-May-88




;;; block
;;;
;;; This datastructure is the heart of the code-movement optimization.

(define-co block print-block
  ())



;;; Accessors for BLOCKs
;;;

(defaccessor block 'keep :start)
(defaccessor block 'keep :end)
(defaccessor block 'keep :code)
(defaccessor block 'keep :ancestors)
(defaccessor block 'keep :offspring)



;;; print-block
;;;
;;; The printing function for BLOCKs.

(defun print-block (b stream level)
  (ignore level)
  (format stream "~%<block ~~a:~a   (~a:~a)~{~%~a~}~%~>"
	  (or (and (il-node? (block-start b)) (il-node-n (block-start b)))
	      (block-start b))
	  (or (and (il-node? (block-end b)) (il-node-n (block-end b)))
	      (block-end b))
	  (mapcar #'(lisp:lambda (bb) (il-node-n (block-start bb))) (block-ancestors b))
	  (mapcar #'(lisp:lambda (bb) (il-node-n (block-start bb))) (block-offspring b))
	  (block-code b)
	  )
  )






;;; build-blocks
;;;
;;; This loops through a list of il-nodes which have already had their control-flow graph built, breaking the
;;; nodes into blocks.
;;;
;;; Blocks start at any node with more than zero ancestors.
;;; Blocks end at any node with more than zero offspring.

(defun build-blocks (il-code)
  "Breaks IL-CODE into a list of blocks, and returns the list."
  (let* ((il-nodes il-code)
	 (this)
	 (next (pop il-nodes))
	 (out)
	 (block (new-block :start next))
	 )
    (loop do
	  (setq this next			; Note that this requires serial processing.
		next (pop il-nodes))
	  (push this (block-code block))
	  ;; Is it time to finish?  OR  Is it time to start a new block?  OR  Is it time to end this block?
	  (if (or (null next)
		  (il-node-ancestors next)
		  (il-node-offspring this)
		  )
	      ;; Yes.
	      (progn
		(setf (block-end  block) this
		      (block-code block) (nreverse (block-code block)))
		(push block out)
		(setq block (new-block :start next))
		(if (null next) (return))	; Break out.
		)
	      )
	  )
    (nreverse out)				; Fix the output list, and return it.
    )
  )


;;; find-block-start
;;;
;;; Given an il-node which is the start of a block, this finds the block and returns it.

(defun find-block-start (il-node blocks)
  (dolist (block blocks '())
    (if (eq il-node (block-start block))
	(return block))))


;;; find-block-end
;;;
;;; Given an il-node which is the end of a block, this finds the block and returns it.

(defun find-block-end (il-node blocks)
  (dolist (block blocks '())
    (if (eq il-node (block-end block))
	(return block))))



;;; inter-block-control-flow
;;;
;;; Given a list of blocks, this creates the control-flow between the blocks.

(defun inter-block-control-flow (blocks)
  (mapc
    #'(lisp:lambda (block)
	(setf (block-ancestors block)
	      (mapcar #'(lisp:lambda (il-node)
			  (find-block-end il-node blocks))
		      (il-node-ancestors (first (block-code block)))))
	(setf (block-offspring block)
	      (mapcar #'(lisp:lambda (il-node)
			  (find-block-start il-node blocks))
		      (il-node-offspring (first (last (block-code block)))))))
    blocks)
  '()
  )


;;; intra-block-control-flow
;;;
;;; This patches the il-nodes within the block to fill in the default control-flow.

(defun intra-block-control-flow (blocks)
  (mapc #'(lisp:lambda (block)
	    ;; Offspring
	    (mapl #'(lisp:lambda (sub-node-list)
		      (let ((head (first sub-node-list))
			    (next (second sub-node-list)))
			(when next
			  (setf (il-node-offspring head) (list next)))))
		  (block-code block))
	    ;; Ancestors
	    (mapl #'(lisp:lambda (sub-node-list)
		      (let ((head (first sub-node-list))
			    (prev (second sub-node-list)))
			(when prev
			  (setf (il-node-ancestors head) (list prev)))))
		  (reverse (block-code block))))
	blocks))



;;; analyze-blocks
;;;
;;; This groups together the creation and analysis of blocks.

(defun analyze-blocks (il-code env)
  (let ((blocks (build-blocks il-code)))
    (inter-block-control-flow blocks)		; build the cross-block control flow.
    (intra-block-control-flow blocks)		; build the intra-block control flow.
    
    ;; Need tree
    (autologous-block-needs blocks)
    (if (loop for block in blocks
	      never (when (null (block-offspring block))
		      (inter-block-need block)))
	(progn
	  (error-message 0 "Cant find a terminal node in ~a" env)
	  (inter-block-need (car (last blocks)))))
    ;; Clean up the lists
    (mapc #'(lisp:lambda (node) (zip-remove '() (il-node-need node))) il-code)
    
;    (let ((temp-need *il-print-need*) (temp-have *il-print-have*))
;      (setq *il-print-need* t
;	    *il-print-have* '())
;      (format t "~&~%Blocks after need tree: ~%~{~a~}~%" blocks)
;      (setq *il-print-need* temp-need
;	    *il-print-have* temp-have))

    ;; Have tree
    (autologous-block-haves blocks)
    (if (loop for block in blocks
	      never (when (null (block-ancestors block))
		      (inter-block-have block)))
	(progn
	  (error-message 0 "Cant find an entry node in ~a" env)
	  (inter-block-have (car blocks))))
    ;; Clean up the lists
    (mapc #'(lisp:lambda (node) (zip-remove '() (il-node-have node))) il-code)
    
;    (let ((temp-need *il-print-need*) (temp-have *il-print-have*))
;      (setq *il-print-need* '()
;	    *il-print-have* t)
;      (format t "~&~%Blocks after have tree: ~%~{~a~}~%" blocks)
;      (setq *il-print-need* temp-need
;	    *il-print-have* temp-have))

    ;; Alive tree 
    (mapc #'(lisp:lambda (node)
	      (setf (il-node-alive node) (intersection (il-node-have node) (il-node-need node))))
	  il-code)

    blocks)
  )





;;; autologous-block-needs
;;;
;;; This iterates through a list of blocks and copies the autologous needs from the read list to the need list.
;;; The old contents of the needs lists are destroyed.

(defun autologous-block-needs (blocks)
  "Adds all of the autologous reads to the block's code's needs lists.  Returns nil."
  (mapc #'(lisp:lambda (block)
	    (mapc #'(lisp:lambda (il-node)
		      (setf (il-node-need il-node)
			    (or (copy-list (il-node-read il-node))
				'(()))))
		  (block-code block)))
	blocks))




;;; autologous-block-haves
;;;
;;; This iterates through a list of blocks and copies the autologous haves from the written list to the have list.
;;; The old contents of the have lists are destroyed.

(defun autologous-block-haves (blocks)
  "Adds all of the autologous writes to the block's code's have list.  Returns nil."
  (mapc #'(lisp:lambda (block)
	    (mapc #'(lisp:lambda (il-node)
		      (setf (il-node-have il-node) (or (copy-list (il-node-written il-node))
						       '(()))))
		  (block-code block)))
	blocks))




;;; inter-block-need
;;;
;;; Uses intra-block-need to compute the need lists for a list of blocks.

(defun inter-block-need (start &optional (count 0))

;  (format t "~&~V@TEnter inter-block-need ~a:~a"
;	  count (il-node-n (block-start start)) (il-node-n (block-end start)))

  ;; Work within the block.
  (intra-block-need start)

  (let* ((self (block-start start))
	 (reads (il-node-read self))
	 (writes (il-node-written self))
	 (needs (remove-if-not #'(lisp:lambda (need)
				   (or (member need reads)
				       (not (member need writes))))
			       (il-node-need self))))

    (dolist (parent-block (block-ancestors start))
      (let ((propagate-flag nil)				; non-nil iff propagation should be made
	    (parent (block-end parent-block)))
	(dolist (need needs)					; propagate the needs
	  (if (add-need parent need)				; is parent not colored?
	      (setq propagate-flag t)))				; force propagation
	(if propagate-flag (inter-block-need parent-block (1+ count))))
      )
    )

;  (format t "~&~V@TExit  inter-block-need ~a:~a"
;	  count (il-node-n (block-start start)) (il-node-n (block-end start)))


  t)





;;; intra-block-need
;;;
;;; Builds the need information within a block.
;;;
;;; Needs are symbols that are read at a node, and are propagated against flow.  Propagation continues until a node
;;; is encountered where the symbol is written (defined).

(defun intra-block-need (block)
  "Builds the need tree within a block.  Returns NIL."
  (let ((need-list (copy-list (il-node-need (block-end block)))))
    (mapc #'(lisp:lambda (node)
	      (let ((written (il-node-written node)))
		(mapc #'(lisp:lambda (sym)
			  (add-need node sym)
			  (if (member sym written)
			      (zip-remove sym need-list)))
		      need-list)
		(mapc #'(lisp:lambda (sym)
			  (add-need node sym)
			  (if (null (member sym written))
			      (pushnew sym need-list)))
		      (il-node-read node))))
	  (reverse (block-code block)))
    )
  '()
  )





;;; inter-block-have
;;;
;;; Uses intra-block-have to compute the have lists for a list of blocks.

(defun inter-block-have (start &optional (count 0))
  
;  (format t "~&~V@TEnter inter-block-have ~a:~a"
;	  count (il-node-n (block-start start)) (il-node-n (block-end start)))

  ;; Work within the block.
  (intra-block-have start)

  ;; See if there are any propagations needed.
  (let ((haves (il-node-have (block-end start))))
    (dolist (block-child (block-offspring start))
      (let ((propagate-flag nil)
	    (child (block-start block-child)))
	(dolist (have haves)					; propagate all of the haves
	  (if (add-have child have)
	      (setq propagate-flag t)))
	(if propagate-flag (inter-block-have block-child (1+ count))))))

;  (format t "~&~V@TExit  inter-block-have ~a:~a"
;	  count (il-node-n (block-start start)) (il-node-n (block-end start)))

  t)




;;; intra-block-have
;;;
;;; Builds the have information within a block.
;;;
;;; Haves are symbols that are written at a node, propagated with control flow.

(defun intra-block-have (block)
  "Builds the have tree within a block.  Returns NIL."
  (let ((have-list (copy-list (il-node-have (block-start block)))))
    (mapc #'(lisp:lambda (node)
	      (mapc #'(lisp:lambda (sym) (add-have node sym))
		    have-list)
	      (mapc #'(lisp:lambda (sym)
			(add-have node sym)
			(pushnew sym have-list))
		    (il-node-written node)))
	  (block-code block))
    )
  '()
  )