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

;;;; Compiled Function Objects and Linker

(export '(DEFAFUN NDISASSEMBLE PRINS LINK))
  
(zl:defsubst nsymbol-function (symbol)
  (get symbol 'ncompiled-function))

(defun create-ncompiled-function (name code local-refs refs immediates entry-points)
  (let ((cfun (setf (nsymbol-function name)
		    (make-ncompiled-function :name name))))
    (setf (ncompiled-function-starting-address cfun) nil)
    (setf (ncompiled-function-code         cfun) (concatenate 'vector code))
    (setf (ncompiled-function-length       cfun) (length code))
    (setf (ncompiled-function-local-refs   cfun) local-refs)
    (setf (ncompiled-function-refs         cfun) refs)
    (setf (ncompiled-function-immediates   cfun) immediates)
    (setf (ncompiled-function-entry-points cfun) entry-points)
    cfun))


(defmacro defafun (name arglist &body instructions)
  "Define an assembly function, takes a body of assembly code.
installs a compiled-function structure on the symbol name"
  `(setf (nsymbol-function ',name)
	 (assemble-instruction-list ',name '(,name . ,instructions) '((,(length arglist) . ,name)))))

(defun cc (defun)
  (let ((f (c defun)))
    (setf (nsymbol-function (ncompiled-function-name f))
	  f)
    f))
  
(defun get-ncompiled-function (fcn)
  (cond
    ((ncompiled-function-p fcn) fcn)
    ((symbolp fcn)
     (nsymbol-function fcn))
    (t (cerror "foo" "unknown function thing ~s" fcn))))
  
(defun ndisassemble (fcn)
  "Print disassembled code of FCN"
  (let ((f (get-ncompiled-function fcn)))
    (let ((code (ncompiled-function-code f)))
      (case code
	(:in-cold-load (cold::cold-disassemble f))
	(:in-memory
	 (kbug::disassemble-fcn-from-memory f))
	(t (if (typep code 'sequence)
	       (pr-dis (ncompiled-function-code f))
	     (error "don't know where this code is: ~a" code))))))
  fcn)

(defun prins (fcn)
  "Print instructions of FCN in hex"
  (let ((f (get-ncompiled-function fcn)))
    (format t "~&Start: ~x" (ncompiled-function-starting-address f))
    (map nil #'(lambda (i)
		 (format t "~&~16,'0x" i))
	 (ncompiled-function-code f)))
  fcn)

(defun link (function starting-address &optional (do-callees t))
  "Relocate and resolve references of FUNCTION given STARTING-ADDRESS"
  (let* ((cfun (get-ncompiled-function function))
	 (code (ncompiled-function-code cfun)))
    ;; do this first to get recursive calls
    (setf (ncompiled-function-starting-address cfun) starting-address)
    ;; Link local ref addresses
    (dolist (local-ref (ncompiled-function-local-refs cfun))
      (let ((iaddr (car local-ref)))
	(setf (aref code iaddr)
	      (dpb (ldb (byte (byte-size hw:%%i-branch-address)
			      0)
			(+ starting-address (cdr local-ref)))
		   hw:%%i-branch-address
		   (aref code iaddr)))))
    ;; Link Refs
    (dolist (ref (ncompiled-function-refs cfun))
      (let ((reffun (get-ncompiled-function (if (symbolp (cdr ref))
						(cdr ref)
					      (second ref))))
;	    (nargs (third ref))
	    )
	(if reffun
	    (let ((refstart (ncompiled-function-starting-address reffun)))
	      (if refstart
		  (setf (aref code (car ref))
			(logior (logand #xFFFFFFFFFF000000
					(aref code (car ref)))
				refstart))
		(format t "~&~S is not yet linked" (cdr ref)))
	      (pushnew (cons cfun (car ref)) (ncompiled-function-callees reffun) :test #'equal))
	  (format t "~&~S is undefined" (cdr ref)))))
    ;; Do callees
    ;; do entry points too
    (when do-callees
      (dolist (callee (nc::ncompiled-function-callees cfun))
	(let ((callee-code (nc::ncompiled-function-code (car callee)))
	      (addr (+ (nc::ncompiled-function-starting-address (car callee))
		       (cdr callee))))
	  (case callee-code
	    (:in-memory
	     (kbug::write-inst addr (logior (logand #xFFFFFFFFFF000000 (kbug::read-inst addr))
					    starting-address)))))))

    ))