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

(deff dpb-big #'lam:dpb-big)
(deff ldb-big #'lam:ldb-big)

; dest, s1, s2 could be:
;   (open 4)
;   (active 2)
;   (return 0)
;   (global 555)

; (alu dest <- s1 aluop s2)
; (jump condition target)
; (jump-xct-next condition target)
; (sim sim-halt)

(defun parse-reg-adr (reg-adr &aux (limit *registers-per-frame*) base-code offset immediate)
  (declare (values base offset immediate))
  (setq offset (cadr reg-adr))
  (when (< offset 0) (ferror nil "bad offset"))
  (ecase (car reg-adr)
    (open
     (setq base-code %i-base-open))
    (active
     (setq base-code %i-base-active))
    (return
     (setq base-code %i-base-return))
    (global
     (setq base-code %i-base-global)
     (setq limit (* *registers-per-frame* *total-frames*))
     (setq immediate (floor offset *registers-per-frame*))
     (setq offset (remainder offset *registers-per-frame*))))
  (when (>= offset limit)
    (ferror nil "bad reg adr"))
  (values base-code offset immediate))
     

(defstruct (alu-inst (:type :list))
  flag
  dest
  arrow
  s1
  aluop
  s2)

(defun assemble-inst (sym-inst)
  (ecase (car sym-inst)
    (alu (assemble-inst-alu sym-inst))
    ((jump jump-xct-next) (assemble-inst-jump sym-inst))
    (sim (assemble-inst-sim sym-inst))
    (open (assemble-inst-open sym-inst))
    (tail-recursive-open (assemble-inst-tail-recursive-open sym-inst))
    ((call call-xct-next) (assemble-inst-call sym-inst))
    ((tail-recursive-call tail-recursive-call-xct-next) (assemble-inst-tail-recursive-call sym-inst))
    ((return return-xct-next) (assemble-inst-return sym-inst))
    ))
       
(defun assemble-inst-open (sym-inst)
  sym-inst
  (let ((inst 0))
    (setq inst (dpb %i-op-open %%i-opcode 0))
    (list inst)))

(defun assemble-inst-tail-recursive-open (sym-inst)
  sym-inst
  (let ((inst 0))
    (setq inst (dpb %i-op-tail-recursive-open %%i-opcode 0))
    (list inst)))

(defun assemble-inst-call (sym-inst)
  (let ((inst 0))
    (setq inst (dpb %i-op-call %%i-opcode 0))
    (when (not (eq (car sym-inst) 'call-xct-next))
      (setq inst (dpb 1 %%i-jump-n inst)))
    `(,inst %%i-jump-adr (jump-target ,(cadr sym-inst)))))

(defun assemble-inst-tail-recursive-call (sym-inst)
  (let ((inst 0))
    (setq inst (dpb %i-op-tail-recursive-call %%i-opcode 0))
    (when (not (eq (car sym-inst) 'tail-recursive-call-xct-next))
      (setq inst (dpb 1 %%i-jump-n inst)))
    `(,inst %%i-jump-adr (jump-target ,(cadr sym-inst)))))

(defun assemble-inst-return (sym-inst)
  sym-inst
  (let ((inst 0))
    (setq inst (dpb %i-op-return %%i-opcode 0))
    (when (not (eq (car sym-inst) 'return-xct-next))
      (setq inst (dpb 1 %%i-jump-n inst)))
    (list inst)))



(defun assemble-inst-alu (sym-inst &aux (val 0))
  (setq val (dpb-big %i-op-alu %%i-opcode val))
  (let (base-code offset immediate old-immediate)
    ;;dest
    (multiple-value (base-code offset old-immediate)
      (parse-reg-adr (alu-inst-dest sym-inst)))
    (setq val (dpb-big base-code %%i-dest-base val))
    (setq val (dpb-big offset %%i-dest-offset val))
    
    ;;s1
    (multiple-value (base-code offset immediate)
      (parse-reg-adr (alu-inst-s1 sym-inst)))
    (setq val (dpb-big base-code %%i-src-1-base val))
    (setq val (dpb-big offset %%i-src-1-offset val))
    (when (and immediate old-immediate
	       (not (= immediate old-immediate)))
      (ferror nil "inconsistant global bases"))
    
    ;;s2
    (multiple-value (base-code offset immediate)
      (parse-reg-adr (alu-inst-s2 sym-inst)))
    (setq val (dpb-big base-code %%i-src-2-base val))
    (setq val (dpb-big offset %%i-src-2-offset val))
    (when (and immediate old-immediate
	       (not (= immediate old-immediate)))
      (ferror nil "inconsistant global bases"))
    
    (when immediate
      (setq val (dpb-big immediate %%i-immediate val)))
    
    (ecase (alu-inst-aluop sym-inst)
      (setz (setq val (dpb-big %i-aluf-setz %%i-aluf val)))
      (add (setq val (dpb-big %i-aluf-add %%i-aluf val)))
      (set1 (setq val (dpb %i-aluf-set1 %%i-aluf val)))
      (set-source-1 (setq val (dpb %i-aluf-set1 %%i-aluf val)))
      (m-minus-1 (setq val (dpb %i-aluf-src1-minus-1 %%i-aluf val)))
      (m-minus-one (setq val (dpb %i-aluf-src1-minus-1 %%i-aluf val)))
      (sub (setq val (dpb %i-aluf-sub %%i-aluf val)))
      )
    )
  (list val))

(defstruct (jump-inst (:type :list))
  type
  cond
  target)

(defun assemble-inst-jump (sym-inst &aux (val 0))
  (setq val (dpb-big %i-op-jump %%i-opcode val))
  (ecase (jump-inst-type sym-inst)
    (jump (setq val (dpb-big 1 %%i-jump-n val)))
    (jump-xct-next))
  (ecase (jump-inst-cond sym-inst)
    (always (setq val (dpb-big %i-jump-cond-unc %%i-jump-cond val)))
    (less-than (setq val (dpb %i-jump-cond-less-than %%i-jump-cond val)))
    )
  `(,val %%i-jump-adr (jump-target ,(jump-inst-target sym-inst))))

(defun disassemble-inst (inst)
  (select (ldb %%i-opcode inst)
    (%i-op-alu (disassemble-inst-alu inst))
    (%i-op-jump (disassemble-inst-jump inst))
    (%i-op-sim (disassemble-inst-sim inst))
    (%i-op-open (disassemble-inst-open inst))
    (%i-op-tail-recursive-open (disassemble-inst-tail-recursive-open inst))
    (%i-op-call (disassemble-inst-call inst))
    (%i-op-tail-recursive-call (disassemble-inst-tail-recursive-call inst))
    (%i-op-return (disassemble-inst-return inst))
    (t (ferror nil "unknown opcode"))))

(defun disassemble-inst-open (inst)
  inst
  `(open))

(defun disassemble-inst-tail-recursive-open (inst)
  inst
  `(tail-recursive-open))

(defun disassemble-inst-call (inst)
  `(,(ecase (ldb %%i-jump-n inst)
       (0 'call-xct-next)
       (1 'call))
    ,(ldb-big %%i-jump-adr inst)))

(defun disassemble-inst-tail-recursive-call (inst)
  `(,(ecase (ldb %%i-jump-n inst)
       (0 'tail-recursive-call-xct-next)
       (1 'tail-recursive-call))
    ,(ldb-big %%i-jump-adr inst)))

(defun disassemble-inst-return (inst)
  `(,(ecase (ldb %%i-jump-n inst)
       (0 'return-xct-nect)
       (1 'return))
    ))


(defun disassemble-inst-sim (inst)
  `(sim ,(aref *sim-ops* (ldb %%i-immediate inst))))

(defun unparse-reg-adr (base-code offset immediate)
  (let ((result (list nil nil)))
    (select base-code
      (%i-base-active
       (setf (car result) 'active)
       (setf (cadr result) offset))
      (%i-base-open
       (setf (car result) 'open)
       (setf (cadr result) offset))
      (%i-base-return
       (setf (car result) 'return)
       (setf (cadr result) offset))
      (%i-base-global
       (setf (car result) 'global)
       (setf (cadr result) (+ offset immediate)))
      (t
       (ferror nil "unknown base code")))
    result))


(defun disassemble-inst-alu (original-inst)
  (let ((result (make-alu-inst))
	(inst original-inst))
    (setf (alu-inst-flag result) 'alu)
    (setf (alu-inst-arrow result) '<-)
    (setq inst (dpb-big 0 %%i-opcode inst))
    (setf (alu-inst-dest result)
	  (unparse-reg-adr (ldb %%i-dest-base inst)
			   (ldb %%i-dest-offset inst)
			   (ldb %%i-immediate inst)))
    (setq inst (dpb-big 0 %%i-dest-base inst))
    (setq inst (dpb-big 0 %%i-dest-offset inst))
    (setq inst (dpb-big 0 %%i-immediate inst))

    (setf (alu-inst-s1 result)
	  (unparse-reg-adr (ldb %%i-src-1-base inst)
			   (ldb %%i-src-1-offset inst)
			   (ldb %%i-immediate inst)))
    (setq inst (dpb-big 0 %%i-src-1-base inst))
    (setq inst (dpb-big 0 %%i-src-1-offset inst))
    (setq inst (dpb-big 0 %%i-immediate inst))

    (setf (alu-inst-s2 result)
	  (unparse-reg-adr (ldb %%i-src-2-base inst)
			   (ldb %%i-src-2-offset inst)
			   (ldb %%i-immediate inst)))
    (setq inst (dpb-big 0 %%i-src-2-base inst))
    (setq inst (dpb-big 0 %%i-src-2-offset inst))
    (setq inst (dpb-big 0 %%i-immediate inst))
    
    (setf (alu-inst-aluop result)
	  (select (ldb %%i-aluf inst)
	    (%i-aluf-setz 'setz)
	    (%i-aluf-add 'add)
	    (%i-aluf-set1 'set1)
	    (%i-aluf-src1-minus-1 'l-1)
	    (%i-aluf-sub 'sub)
	    (t (ferror nil "unknown alu function"))))
    (setq inst (dpb-big 0 %%i-aluf inst))
    
    (when (not (zerop inst))
      (ferror nil "leftover bits"))
    result))

(defun disassemble-inst-jump (original-inst)
  (let ((result (make-jump-inst))
	(inst original-inst))
    (setq inst (dpb 0 %%i-opcode inst))
    (ecase (ldb %%i-jump-n inst)
      (0 (setf (jump-inst-type result) 'jump-xct-next))
      (1 (setf (jump-inst-type result) 'jump)))
    (setq inst (dpb 0 %%i-jump-n inst))
    (select (ldb %%i-jump-cond inst)
      (%i-jump-cond-unc (setf (jump-inst-cond result) 'always))
      (%i-jump-cond-less-than (setf (jump-inst-cond result) 'less-than))
      (t (ferror nil "unknown jump cond")))
    (setq inst (dpb 0 %%i-jump-cond inst))
    (setf (jump-inst-target result) (ldb-big %%i-jump-adr inst))
    (setq inst (dpb-big 0 %%i-jump-adr inst))
    (when (not (zerop inst))
      (ferror nil "leftover bits"))
    result))


(defun assemble-program (program)
  (loop for sym-inst in program
	collect (cond ((consp sym-inst) (assemble-inst sym-inst))
		      (t sym-inst))))

(defmacro define-asm (name &rest form)
  (declare (arglist name arglist &body body))
  `(define-asm-1 ',name ',form))

(defun define-asm-1 (name form)
  (when (not (symbolp name))
    (ferror nil "name must be symbol"))
  (let ((lambda-exp (si:process-defun-body name form t))
	documentation
	arglist
	declarations
	body
	)
    ;;now we have (named-lambda (foo (documentation "foobar")) (args) (declare (...) (...)) body)
    ;;the declare may be absent
    (setq documentation (cadr (assq 'si:documentation (si:debugging-info lambda-exp))))
    (setq arglist (third lambda-exp))
    (setq body (cdddr lambda-exp))
    (when (eq (caar body) 'declare)
      (setq declarations (cdr (car body)))
      (pop body))

    (when (not (null arglist))
      (ferror nil "no arglist allowed"))

    (putprop name (assemble-program body) 'sim-program)))


(defun store-function-into-main-memory (function starting-adr &aux jump-addresses)
  (putprop function starting-adr 'sim-start-adr)
  (labels ((load-time-update (inst field val)
			     (ecase (car val)
			       (jump-target
				(let ((possible-local (assq (cadr val) jump-addresses)))
				  (cond ((null possible-local)
					 (when (null (get (cadr val) 'sim-start-adr))
					   (ferror nil "unknown jump taget ~s" (cadr val)))
					 (dpb-big (get (cadr val) 'sim-start-adr) (eval field) inst))
					(t
					 (dpb-big (cdr possible-local) (eval field) inst))))))))
    (when (null (get function 'sim-program))
      (ferror nil "no program"))
    (do ((adr starting-adr)
	 (code (get function 'sim-program) (cdr code)))
	((null code)
	 (push (cons '|end| adr) jump-addresses))
      (cond ((consp (car code))
	     (incf adr))
	    (t
	     (push (cons (car code) adr) jump-addresses))))
    (do ((adr starting-adr)
	 numeric-inst
	 (inst-list (get function 'sim-program) (cdr inst-list)))
	((null inst-list))
      (when (consp (car inst-list))
	(setq numeric-inst (caar inst-list))
	(do ((load-time-stuff (cdar inst-list) (cddr load-time-stuff)))
	    ((null load-time-stuff))
	  (setq numeric-inst (load-time-update numeric-inst (car load-time-stuff) (cadr load-time-stuff))))
	(setf (aref (proc-main-memory *proc*) adr) numeric-inst)
	(incf adr)))
    (cdr (assq '|end| jump-addresses))))


(defun assemble-inst-sim (sym-inst &aux inst)
  (setq inst (dpb %i-op-sim %%i-opcode 0))
  (setq inst (dpb (get-sim-op-index (cadr sym-inst)) %%i-immediate inst))
  (list inst))