;;; -*- Mode:Common-Lisp; Package:L; Base:10; -*-
;;;
;;; preasm
;;;
;;; Lisp code for the new L pre-assembler.
;;;
;;; jsp 21-July-87


;;; Some global switches.  These are accessible via a control panel which pops up after <TERM> M-L.

(define-main-option *preasm-fatal-errors-non-fatal* "Fatal errors don't halt assembler" t (:boolean))
(define-main-option *preasm-print-source-code*      "Print out source code" t (:boolean))
(define-main-option *preasm-print-il-code*          "Print out il code" t (:boolean))
(define-main-option *preasm-print-t-code*           "Print out target code" t (:boolean))
(define-main-option *preasm-optimize*               "Enable optimization" t (:boolean))
(define-main-option *preasm-debug-live-variable-analysis* "Enable lva debugging" '() (:boolean))
(define-main-option *preasm-debug-optimize*         "Enable optimization debugging" t (:boolean))
(define-main-option *preasm-enable-back-end*        "Enable IL-TO-T processing" t (:boolean))
(define-main-option *preasm-enable-il-dumping*      "Enable IL dumping" t (:boolean))
(define-main-option *preasm-sequencing*             "Enable Procedural Printing" t (:boolean))


;;; init-preasm
;;;
;;; This initializes the appropriate structures and variables for preasm.

(defun init-preasm ()
  (initialize-il-instructions)
  'ok)



;;; find-declaration
;;;
;;; This locates or creates a declaration as is appropriate.

(defun find-declaration (sym env source n)
  (cond ((symbolp sym)
	 (put-declaration (new-declaration :symbol sym :kind KIND-UNDEFINED) env))
	((operand? sym)
	 (get-local-declaration (operand-name sym) env))
	((numberp sym)
	 (error-message 0 "Numeric argument ~a at #~d: ~a" sym n source))
	(t
	 (error-message 1 "Non-symbol ~a at #~d: ~a" sym n source))))



;;; preasm-error-count
;;;
;;; This preasm global variable contains the number of times error-message has been called.

(defvar preasm-error-count 0)


;;; error-message
;;;
;;; This is the central error-reporting function.  The error-level comes in three flavors, warning (0),
;;; error (1), and fatal error (2).  As this is only an error-reporting function, it is up to the
;;; processing function to take appropriate action.

(defun error-message (error-level message &rest args)
  "Prints an error message.  Returns NIL."
  (incf preasm-error-count)
  (format t "~&Preasm~a~?" (case error-level
			     (0 " Warning: ")
			     (1 " Error:   ")
			     (2 " Fatal Error: ")
			     (otherwise " Message: ")
			     )
	  message args)
  (if (and (= error-level 2)
	   (not *preasm-fatal-errors-non-fatal*))
      (throw 'preasm-tag '()))
  '()
  )




;;; process-fundef
;;;
;;; This does the brunt of the work in this system.  It creates a symbol for each of the new function
;;; definitions, with a type as specified, kind of FN, and code as returned by a recursive call to
;;; parse-code.  See process-function-def1, -def5, and -def6.
;;; Recall:  (fundef (<name1> <type1> <body1>) (<name2> <type2> <body2>) ... )


(defun process-fundef (il-node env)
  "Compile function definitions."
  (ignore env)
  (if *preasm-sequencing* (format t "~&process-fundef"))
  (loop
    for this-sym in (il-node-defined il-node)	; at this point, these will be real declarations
     as this-src in (il-node-source il-node)
     as this-env = (declaration-value this-sym)
     with n-times = 0
     do (multiple-value-bind (prolog start-n)
	    (process-fundef-aa this-env)
	  (multiple-value-bind (il-nodes additional-fundefs)
	      (parse-source-to-il this-src this-env start-n)

	    (setf (fn-il-nodes this-env) (fixup-prolog prolog il-nodes))
	    
	    (if *preasm-print-source-code*
		(format t "~&~%Source Code ~{~%~s~}~%" this-src))
	    
	    ;; Loop until there are no changes in the length of il-code.  This potentially may take some time.
	    (loop do (incf n-times 1)				; count the number of iterations
		  do (process-fundef-a this-env)		; control-flow and live-variable analysis
		  do (when (not *preasm-optimize*) (return))	; if optimization is off, then break out
		  do (process-fundef-b this-env)		; does nothing
		  until (null (process-fundef-c this-env)))	; peephole optimizations (returns t if any changes)
	    
	    (process-fundef-d this-env)

	    (if *preasm-print-il-code*
		(format t "~&~%IL Code after peephole (~d time~:P around)~{~%~s~}~%" n-times (fn-il-nodes this-env)))
	    
	    ;; Achieve recursive definitions by processing list returned by parse-code.
	    (loop for def in additional-fundefs
		  collecting (apply #'preasm def this-env))
	    ))

     do (when *preasm-enable-back-end*
	  (if *preasm-sequencing* (format t "~&postasm"))
	  (postasm (fn-il-nodes this-env) this-env))

     do (when *preasm-enable-il-dumping*
	  (describe
	  (setf (fn-il-dump this-env)
;		(mapcar #'short-dump-il-node-to-lisp (fn-il-nodes this-env)))))
		(mapcar #'(lisp:lambda (node)
			    (dump-il-node node () 0))
			(fn-il-nodes this-env)))))

     do (if *preasm-print-t-code*
	    (format t "~&~%T Code ~{~%~s~}~%" (fn-t-nodes this-env)))

     collecting (fn-il-nodes this-env) into out-list
     finally (return (cons (fn-il-nodes this-env) out-list))
     )
  )



;;; preasm
;;;
;;; This is the upper-level function.

(defun preasm (source env)
  "Compiles a list of function definitions.  Side effects the environment."
;  (meter
  (catch 'preasm-tag
    (let ((il-nodes (parse-source-to-il source env 0)))	; We can ignore the second value of parse-source-to-il since
							; all i-nodes here should be FUNDEFs.
      (dolist (il-node il-nodes)
	(if (eq *il-fundef-instruction* (il-node-op il-node))
	    (process-fundef il-node env)
	    (error-message 2 "PREASM must be called with FUNDEF statements."))))
    )
;  )
;  (meter:analyze :buffer "foo1")
;  (meter:resume-gc-process t)
  )



;;; newasm
;;;
;;; A stub.

(defun newasm (source env) (preasm source env))




;;; collect-defined-symbols
;;;
;;; Given and environment, this grovels over the contained declarations and sorts the contained declarations
;;; by kind (definition type), and returns them in six lists (ARGS, REGS, LOCALS, TEMPS, CONSTS, and FNS).

(defun collect-defined-symbols (env)
  "Gathers the symbols defined in an environment and returns them in lists sorted by their KIND field:
ARGS, REGS, LOCALS, TEMPS, CONSTS, and FNS."
  (let ((args) (regs) (locals) (temps) (consts) (fns))
    (maphash #'(lisp:lambda (name decl)
		 (ignore name)
		 (when (declaration? decl)
		   (let ((kind (declaration-kind decl)))
		     (select kind
		       (KIND-ARG   (push decl args))
		       (KIND-REG   (push decl regs))
		       (KIND-LOCAL (push decl locals))
		       (KIND-TEMP  (push decl temps))
		       (KIND-CONST (push decl consts))
		       (KIND-FN    (push decl fns))
		       ))))
	     (fn-declarations env))
    (values args regs locals temps consts fns)
    )
  )


;;; fixup-prolog
;;;
;;; This small function fixes the startup-code and renumbers the nodes.

(defun fixup-prolog (prolog main-code)
  (let ((out (cons (first main-code)
		   (nconc prolog (rest main-code))))
	(n -1))
    (mapc #'(lisp:lambda (il-node) (setf (il-node-n il-node) (incf n))) out)
    out)
  )



;;; process-fundef-aa
;;;
;;; This collects all of the symbols within an environment and assembles them in some intelligent fashion so
;;; that appropriate IL code can be glued onto the front of the code for the current function definition.
;;; It is unclear exactly what contained functions should look like, or where they should appear.

(defun process-fundef-aa (env)
  "Collects contained symbols for a given function.  Returns a list of il-nodes."
  (if *preasm-sequencing* (format t "~&process-fundef-aa"))
  (let ((args) (regs) (locals) (temps) (consts) (fns) (out) (n -1))
    (multiple-value-setq (args regs locals temps consts fns)
      (collect-defined-symbols env))

    (setq args (fn-args env))			; re-do arguments because their order is important.

    (when args
      (push (new-il-node :op *il-argdef-instruction*
			 :defined args
			 :written args		; fool LVA into thinking that arguments are live from start
			 :type  (mapcar #'(lisp:lambda (decl) (declaration-type decl)) args)
			 ) out))
;    (when locals
;      (push (new-il-node :op *il-localdef-instruction*
;			 :defined locals
;			 :written locals	; initialized locals are in fact written at head.
;			 :type  (mapcar #'(lisp:lambda (decl) (declaration-type decl)) locals)
;			 :value (mapcar #'(lisp:lambda (decl) (declaration-value decl)) locals)
;			 ) out))
;    (when temps
;      (push (new-il-node :op *il-tempdef-instruction*
;			 :defined temps
;			 :type  (mapcar #'(lisp:lambda (decl) (declaration-type decl)) temps)
;			 ) out))
;;    (when consts
;;      (dolist (decl consts)
;;	(push (new-il-node :op *il-constdef-instruction*
;;			   :written (list decl)
;;			   :defined (list decl)
;;			   :type  (list (declaration-type decl))
;;			   :value (list (declaration-value decl))
;;			   ) out)))
;    (when consts
;      (push (new-il-node :op *il-constdef-instruction*
;			 :defined consts
;			 :type  (mapcar #'(lisp:lambda (decl) (declaration-type decl)) consts)
;			 :value (mapcar #'(lisp:lambda (decl) (declaration-value decl)) consts)
;			 ) out))

    (setq out (nreverse out))
    (mapcar #'(lisp:lambda (node) (setf (il-node-n node) (incf n 1))) out)

    (values out n)
    )
  )




;;; process-fundef-a
;;;
;;; This function converts the source input into a list of il-nodes, builds the control-flow graph, and
;;; performs live-variable analysis.  It returns a list of il-nodes.

(defun process-fundef-a (env)
  (if *preasm-sequencing* (format t "~&process-fundef-a"))
  (let ((il-code (fn-il-nodes env)) (blocks))
    
    (dolist (il-node il-code)
      (setf (il-node-visited il-node) '())
      (setf (il-node-ancestors il-node) '())
      (setf (il-node-offspring il-node) '())
      (setf (il-node-need il-node) '())
      (setf (il-node-have il-node) '())
      (setf (il-node-alive il-node) '()))

    ;; Build the control-flow graph
    (build-control-flow-graph il-code env)

    ;; Partial optimization, including comment removal and label consolidation.
    (setq il-code (pre-optimize il-code))

    (if *preasm-debug-live-variable-analysis*
	(format t "~&~%IL Code after control-flow~{~%~s~}~%" il-code))

    ;; Block building and live-variable analysis.
    (setq blocks (analyze-blocks il-code env))


;    ;; Build the need tree, starting at each terminal il-node.
;    ;; If there are no terminal nodes, then attempt to start at the lexically last node.
;    (dolist (il-node il-code) (setf (il-node-visited il-node) '()))
;    (if (loop for il-node in il-code
;	      never (when (null (il-node-offspring il-node))
;		      (build-need-tree il-node)))
;	(progn
;	  (error-message 0 "Cant find a terminal node in ~a" env)
;	  (build-need-tree (car (last il-code)))))

;    (if *preasm-debug-live-variable-analysis*
;	(format t "~&~%IL Code after need tree~{~%~s~}~%" il-code))

;    ;; Build the have tree, starting at each entry il-node.
;    ;; If there are no entry nodes, then try the first node.
;    (autologous-have-tree il-code)
;    (if (loop for il-node on il-code
;	      never (when (null (il-node-ancestors (first il-node)))
;		      (build-have-tree il-node)))
;	(progn
;	  (error-message 0 "Cant find an entry node in ~a" env)
;	  (build-have-tree il-code)))

;    (if *preasm-debug-live-variable-analysis*
;	(format t "~&~%IL Code after have-tree~{~%~s~}~%" il-code))


;    ;; Form the intersection of the two, which is the live tree.
;    (dolist (il-node il-code)
;      (let ((live (intersection (il-node-need il-node) (il-node-have il-node))))
;	(setf (il-node-alive il-node) (nremove '() live))))

    ;; And find the newly-live and newly-dead lists.
    (loop for il-node in il-code do
	  ;; newly-live
	  (setf (il-node-newly-live il-node)
		(set-similarities (il-node-written il-node) (il-node-alive il-node)))
	  
	  ;; newly-dead
	  (setf (il-node-newly-dead il-node)
		(set-difference (il-node-alive il-node)
				(loop for child in (il-node-offspring il-node)
				      nconc (copy-list (il-node-alive child)))))

	  )

    (setf (fn-il-nodes env) il-code)
    )
  )


;;; process-fundef-b
;;;
;;; Does nothing, now.

(defun process-fundef-b (env)
  (ignore env)
  (if *preasm-sequencing* (format t "~&process-fundef-b"))
  )



;;; process-fundef-c
;;;
;;; This performs some optimizations on the processed code.  It returns true iff there were any changes.

(defun process-fundef-c (env)
  (if *preasm-sequencing* (format t "~&process-fundef-c"))
  (let ((il-code (fn-il-nodes env)))

    (multiple-value-bind (re-optimize? new-il-nodes)
	(optimize-il-nodes il-code)

      (when re-optimize?
	(setf (fn-il-nodes env) new-il-nodes)
	(process-fundef-c env))

      re-optimize?)))



;;; optimize-il-nodes
;;;
;;; Loops linearly through the il code, recording whether a change was made anywhere along the way.

(defun optimize-il-nodes (il-code)
  (let ((modified?) (local-change?) (new-il-code) (message) (last-pos 1))
    (if *preasm-debug-optimize* (format t "~:|~%~{~a~%~}" il-code))
    (loop for here on il-code
	  do
	  
	  (when *preasm-debug-optimize*
	    (when local-change?
	      (send *terminal-io* :set-cursorpos 60 last-pos :character)
	      (format t "  <== ~a" message)
	      (tyi)
	      (format t "~:|~%~{~a~%~}" il-code)
	      )
	    (setq last-pos (+ 1 (list-pos (first here) il-code)))
	    )
	  
	  (multiple-value-setq (local-change? new-il-code message)
	    (peephole here il-code))
	  
	  (when local-change?
	    (setq modified? t)
	    (setq il-code new-il-code))
	  )
    
    (values modified? il-code))
  
  )



;;; peephole
;;;
;;; --- some notes go here ---

(defun peephole (here il-code)
  
  (let* ((il-node (first here))
	 (next-il-node (second here))
	 (inst (il-node-op il-node)))
    
    (cond
      
;      ;; Look for multiple label instructions.  Coalese the labels by replacing the current label by the following
;      ;; label in all of the current label's parents.
;      ((and (eq *il-label-instruction* inst)
;	    (eq *il-label-instruction* (il-node-op next-il-node)))
;       (let ((old (first (il-node-defined il-node)))
;	     (new (first (il-node-defined next-il-node))))
;	 (dolist (parent (il-node-ancestors il-node))
;	   (zip-replace new old (il-node-targets parent))))
;       (values t (remove-il-node il-node il-code) "label consolidation"))

;      ;; Look for comment instructions.  Remove them.
;      ((eq *il-comment-instruction* inst)
;       (values t (remove-il-node il-node il-code) "remove comment"))

      ;; Look for non-starting il-code which have no ancestors.  These are dead code, and can be eliminated.
      ((and (null (il-node-ancestors il-node))
	    (neq (first il-code) il-node))
       (values t (remove-il-node il-node il-code) "dead code elimination"))
      
      ;; Look for move statements whose source and target are the same.
      ((and (eq *il-move-instruction* inst)
	    (equal (il-node-read il-node) (il-node-written il-node)))
       ;; Remove the il-node from the over-all list.
       (values t (remove-il-node il-node il-code) "move with identical source and target"))
      
      ;; Look for sequences: (t1 op a1 a2 ...) (t2 move t1) where t1 is dead in all offspring of the MOVE.
      ;; This can be replaced by (t2 op a1 a2 ...).  And boy, this code could be clearer.
      ((and next-il-node
	    (eq *il-move-instruction* (il-node-op next-il-node))			; is the next inst a MOVE?
	    (eq (first (il-node-written il-node))				; is target here source there?
		(first (il-node-read next-il-node)))
	    (= 1 (length (il-node-offspring il-node)))				; make sure that there is only one
	    (member next-il-node (il-node-offspring il-node))			; control path to next node
	    (loop for child in (il-node-offspring next-il-node)			; is temp-var dead in all offspring?
		  with temp-var = (first (il-node-written il-node))
		  never (member temp-var (il-node-alive child))))
       (let ((temp-target (first (il-node-written il-node)))
	     (real-target (first (il-node-written next-il-node))))
	 (zip-replace real-target temp-target (il-node-written il-node))
	 (zip-remove temp-target (il-node-alive il-node))		; ONLY because t1 is dead in all offspring!
	 (values t (remove-il-node next-il-node il-code) "merge (t1 op ...) (t2 move t1) into (t2 op ...)")))

      ;; Look for any statements whose targets are all not live.  These may be optimized out as dead code.
      ((not (null (il-node-written il-node)))
       (if (loop for sym in (il-node-written il-node)
		 with alive = (il-node-alive il-node)
		 thereis (member sym alive))
	   '()
	   (values t (remove-il-node il-node il-code) "dead target elimination")))

      ;; Look for (if x c l1 l2) (label l1), replace IF with (if x not(c) l2).
      ;; Look for (if x c l1) (label l1), remove IF.
      ;; In both cases, control flow remains unchanged.
      ((and (eq *il-if-instruction* inst)
	    (member (true-target il-node) (il-node-defined next-il-node)))
       (if (null (false-target il-node))
	   ;; If no else target, then remove IF statement.
	   (values t (remove-il-node il-node il-code) "(if x c l1) (label l1) -- removing IF")
	   ;; If there is an else target, then modify IF statment.
	   (progn
	     (push-not il-node)
	     (pop (il-node-targets il-node))
	     (values t il-code "(if x c l1 l2) (label l1) -- modifying IF"))))

      ;; Look for (if x c l1 l2) (label l2), replace IF with (if x c l1).  Control flow is unchanged.
      ((and (eq *il-if-instruction* inst)
	    (member (false-target il-node) (il-node-defined next-il-node)))
       (push-not il-node)
       (zip-remove (false-target il-node) (il-node-targets il-node))
       (values t il-code "(if x c l1 l2 ) (label l2) --> (if x c l1)"))

      ;; Look for (if x c l1) (goto l2), replace IF with (if x not(c) l2 l1), remove GOTO.  Update control-flow.
      ((and (eq *il-if-instruction* inst)
	    (null (false-target il-node))
	    (eq *il-goto-instruction* (il-node-op next-il-node)))
       (push-not il-node)
       (push-end (true-target next-il-node) (il-node-targets il-node))
       (remove-c-flow il-node next-il-node)
       (update-c-flow il-node (true-target-node next-il-node))
       (values t (remove-il-node next-il-node il-code) "(if x c l1) (goto l2) --> (if x not(c) l2 l1)"))
      
      ;; Look for GOTO statements whose target is the next statement.  Remove the GOTO.
      ((and (eq *il-goto-instruction* inst)
	    (eq next-il-node (true-target-node il-node)))
       (values t (remove-il-node il-node il-code) "(goto l1) (label l1) -- removing GOTO"))

      ;; Look for labels which are not referenced.  Remove them.
      ((and (eq *il-label-instruction* inst)
	    (neq (first il-code) il-node))
       ;; For each symbol, check all parents.  If every parent does NOT reference a symbol,
       ;; then the label is superfluous.  If all labels are superfluous, then the statement may be removed.
       (loop for lab in (il-node-defined il-node)
	     do (if (null (loop for parent in (il-node-ancestors il-node)
				thereis (member lab (il-node-targets parent))))
		    (zip-remove lab (il-node-defined il-node))))
       (if (null (il-node-defined il-node))
	   (values t (remove-il-node il-node il-code) "Removing unreferenced label")
	   '()))

      ;; Look for jumps to jumps.
      ((and (true-target il-node)
	    (eq *il-goto-instruction* (il-node-op (next-il-node (true-target-node il-node)))))
       (snap-jump il-node (true-target il-node))
       (values t il-code "Snaping (true) jump"))

      ;; Look again for jumps to jumps.
      ((and (false-target il-node)
	    (eq *il-goto-instruction* (il-node-op (next-il-node (false-target-node il-node)))))
       (snap-jump il-node (false-target il-node))
       (values t il-code "Snapping (false) jump"))

      (t '()))					; the default case
    )
  )



;;; snap-jump
;;;
;;; --- some notes go here ---

(defun snap-jump (il-node target)
  (let* ((target-node (target-node target))
	 (after-node  (next-il-node target-node))
	 (new-target  (true-target after-node))
	 (new-node    (target-node new-target)))
    
    ;; Modify the node's targets to reflect new target.  Since the length of (il-node-targets il-node) is
    ;; important, we perform this as a nsubst, rather than a delete and insert.
    (zip-replace new-target target (il-node-targets il-node))
    
    ;; Modify the control-flow tree to reflect the update.  Here, since we want to insure uniqueness of each
    ;; entry, we'll perform a delete and insert.
    
    (remove-c-flow il-node target-node)				; delete old link
    (update-c-flow il-node new-node)				; insert new link
    
    )
  )
 



;;; push-not
;;;
;;; This complements the sense of the CDX field of an IF il-node.  It checks the first element of the CDX; if it is
;;; a NOT, then it removes the element;  if it is something else, then it pushes a NOT.

(defun push-not (il-node)
  (if (eq 'not (first (il-node-cdx il-node)))
      (pop (il-node-cdx il-node))
      (push 'not (il-node-cdx il-node))))





;;; process-fundef-d
;;;
;;; This performs register allocation via graph coloring.

(defun process-fundef-d (env)
  (if *preasm-sequencing* (format t "~&process-fundef-d"))
  (let ((il-code (fn-il-nodes env)))
    ;; remove the written attribute for constant definitions.
    (mapc #'(lisp:lambda (node)
	      (if (eq *il-constdef-instruction* (il-node-op node))
		  (setf (il-node-written node) '())))
	  il-code)
    (allocate-registers-via-coloring env)))