;  applies various simplifications to the IR 

(in-package "VERRAZANO-FRONTEND")

; name all the anonymous types in the IR
(defun name-anonymous-elements (ir)
  (apply-to-elements #'(lambda (el)
			 (when (anonymous? el)
			   (name-anonymous el))) ir))

; apply a naming policy to all the names in the IR
(defun translate-element-names (ir)
  (apply-to-elements #'(lambda (el)
			 (when (named? el)
			   (translate-name el))) ir))

; make sure GCC-XML isn't lying to us about c-names
(defun fixup-c-names (ir)
  (apply-to-edges #'fixup-c-name ir))

; fixup a c-name to match what's in symbol table
(defun fixup-c-name (e)
  (when (named? e)
    (setf (named-c-name e)
	  (subseq (named-c-name e) 
		  0 (position #\Space (named-c-name e))))))

; resolve casing conflicts in the IR
(defun resolve-casing-conflicts (ir)
  (apply-to-nodes #'resolve-casing-conflicts-in ir))

; resolve casing conflicts in a namespace
(defun resolve-casing-conflicts-in (node)
  (when (namespace? node)
    (recase-namespace node)))

; unnest definitions that cannot be nested
(defun unnest-definitions (ir)
  (apply-to-pairs #'unnest-pair ir '(defines)))

; unnset a pair of definitions
(defun unnest-pair (parent node)
  (when (not (namespace? node))
    (lift-edges parent node (find-all #'defines-edge? (node-edges node)))))

; find all artificial nodes and mark them as such
(defun mark-artificial-types (ir)
  (apply-to-elements #'check-and-mark-artificial ir))

; mark a given node as artificial or not
(defgeneric check-and-mark-artificial (node))

(defmethod check-and-mark-artificial (node-or-edge)
  (declare (ignore node-or-edge)))

(defmethod check-and-mark-artificial ((node fundamental-type))
  (set-note node 'artificial t))

(defmethod check-and-mark-artificial ((edge allocates))
  (when (or (starts-with "__" (named-name edge))
	    (search "_ *INTERNAL* " (named-c-name edge)))
    (set-note edge 'artificial t)))

; mark the topological ordering of each node
(defun mark-node-orders (ir)
  (apply-to-nodes-prepost #'(lambda (n)
			      (when (alias-type? n)
				(mark-node-order n)))
			  #'(lambda (n)
			      (when (not (alias-type? n))
				(mark-node-order n))) ir))

; mark the order of the given node
(defun mark-node-order (node)
  (setf (node-order node) (get-next-integer)))

; promote and demote class-types and struct-types as necessary
(defun categorize-composite-types (ir)
  (let ((structs nil)
	(classes nil))
    (apply-to-nodes #'(lambda (n)
			(case (real-type n)
			  ('class-type (push n classes))
			  ('struct-type (push n structs)))) ir)
    (homogenize-node-types classes ir 'class-type)
    (homogenize-node-types structs ir 'struct-type)))

; lift static methods out of their classes
(defun lift-methods (ir)
  (apply-to-pairs #'lift-methods-in ir '(defines)))

; lift the methods in a given class
(defun lift-methods-in (parent node)
  (when (class-type? node)
    (let ((to-lift (find-all #'method? (node-edges node))))
      (mapc #'(lambda (e)
		(prepare-for-lifting e node)) to-lift)
      (lift-edges parent node to-lift))))

; prepare the given method for lifting
(defun prepare-for-lifting (e n)
  (let ((m (edge-target e)))
    (when (not (static-method? e))
      (let ((sa (make-instance 'receives
			       :name "this"
			       :target n
			       :virtual (virtual-method? e)
			       :index (lookup-vtable-index e n))))
	(prepend-edge m sa)))))

; make converters and operators less special
(defun lower-special-functions (ir)
  (apply-to-edges #'lower-converters ir)
  (apply-to-edges #'lower-operators ir)
  (apply-to-edges #'lower-constructors ir)
  (apply-to-edges #'lower-destructors ir))

; lower all the converters in a class
(defun lower-converters (edge)
  (when (converter-function? edge)
    (name-converter edge (function-return-type edge))))
    
; if the input is an operator, lower it
(defun lower-operators (edge)
  (when (operator-function? edge)
    (name-operator edge)))

; if the input is a constructor, lower it
(defun lower-constructors (edge)
  (when (constructor-function? edge)
    (name-constructor edge)))

; if the input is a destructor, lower it
(defun lower-destructors (edge)
  (when (destructor-function? edge)
    (name-destructor edge)))

; disambiguate overloading in each namespace
(defun disambiguate-overloading (ir)
  (apply-to-nodes #'disambiguate-overloading-in ir))

; disambiguate overloading in a given namespace
(defun disambiguate-overloading-in (node)
  (when (namespace? node)
    (let ((seen (make-hash-table :test #'equal)))
      (apply-to-outgoing #'(lambda (e)
			     (disambiguate-function e seen)) node '(allocates)))))

; rename a function if it's name is ambiguous
(defun disambiguate-function (fun seen)
  (let* ((name (named-name fun))
	 (counter (gethash name seen)))
    (if counter
      (progn
	(setf (named-name fun) (format nil "~A-~A" name counter))
	(setf (gethash name seen) (+ counter 1)))
      (setf (gethash name seen) 1))))

; annotate IR with offsets of concrete types
(defun annotate-object-offsets (ir)
  (apply-to-nodes #'annotate-base-offsets ir))

; annotate the offset of each base within a composite type
(defun annotate-base-offsets (node)
  (when (composite-type? node)
    (let ((pbe (edge-to-primary-base node))
	  (offset 0))
      (when pbe (incf offset (concrete-type-size (edge-target pbe))))
      (dolist (npbe (remove pbe (edges-to-bases node)))
	(setf (extends-edge-offset npbe) offset)
	(incf offset (concrete-type-size (edge-target npbe)))))))

; mark morally virtual functions of classes
(defun mark-morally-virtual-functions (ir)
  (apply-to-nodes #'mark-moral-virtuals-in-class ir))

; mark the morally-virtual functions in each class
(defun mark-moral-virtuals-in-class (node)
  (when (composite-type? node)
    (mapc #'mark-moral-virtuals-in-class
	  (all-adjacent-nodes node '(extends)))
    (dolist (fun (class-methods node))
      (when (morally-virtual-method? fun node)
	(setf (allocates-edge-virtual fun) t)))))

; annotate the IR with vtables
(defun annotate-class-vtables (ir)
  (apply-to-nodes #'annotate-class-vtable ir))

; annotate a given class with its vtable
(defun annotate-class-vtable (node)
  (when (not (get-note node 'virtual-table))
    (when (composite-type? node)
      (cond
	((category0-class? node) nil)
	((category1-class? node) (build-category1-vtable node))
	((category2-class? node) (build-category2-vtable node))))))

; build a vtable for a category-1 class
(defun build-category1-vtable (node)
  (let ((vtbl nil))
    (push nil vtbl)
    (push nil vtbl)
    (dolist (vfun (class-virtual-methods node))
      (when (virtual-destructor? vfun) (push-end nil vtbl))
      (push-end vfun vtbl))
    (set-note node 'virtual-table vtbl)))

; build a vtable for a category-2 class
(defun build-category2-vtable (node)
  (apply-to-adjacent #'annotate-class-vtable node '(extends))
  (let* ((pvt (primary-base-vtable node))
	 (vtbl (copy-list pvt)))
    (dolist (vfun (class-virtual-methods node))
      (when (not (overrides-primary-method? vfun pvt))
	(when (virtual-destructor? vfun) (push-end nil vtbl))
	(push-end vfun vtbl)))
    (dolist (npvt (non-primary-base-vtables node))
      (push-extend npvt vtbl))
    (set-note node 'virtual-table vtbl)))

; move all edges matching predicate up one level
(defun lift-edges (parent node edges)
  (dolist (edge edges) (combine-name node edge (edge-target edge)))
  (setf (node-edges parent) (append edges (node-edges parent)))
  (setf (node-edges node)
	(remove-if #'(lambda (e) (member e edges)) (node-edges node))))

; homogenize the types in a list
(defun homogenize-node-types (lst ir to-type)
  (dolist (node lst)
    (when (not (eq (type-of node) to-type))
      (change-node-type node ir to-type))))

; change the type of an node
(defun change-node-type (node ir new-type)
  (let ((irn (make-instance new-type)))
    (copy-class-or-struct node irn)
    (dolist (edge (find-incoming-edges node ir))
      (setf (edge-target edge) irn))))

; copy the members of a class or struct to another object
(defun copy-class-or-struct (from to)
  (setf (annotable-notes to) (annotable-notes from))
  (setf (node-edges to) (node-edges from))
  (setf (node-mark to) (node-mark from))
  (setf (node-order to) (node-order from))
  (setf (named-name to) (named-name from)))