;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10 -*-

(defun trap-on ()
  (let ((old-trap-state (hw:trap-off)))
    (hw:write-memory-control
      (hw:dpb-unboxed hw:$$trap-enable k-hw:%%memory-control-master-trap-enable
		      (hw:read-memory-control)))
    ;; Let mmfio clear out.
    (hw:nop)
    (hw:nop)
    (hw:nop)
    old-trap-state))

(defun dt-and-ovf-trap-handler-1 ()
  (let* ((save-sstep   (vinc:modify-single-step-trap   hw:$$trap-disable))
	 (save-async   (vinc:modify-asynchronous-traps hw:$$trap-disable))
	 (save-pc      gr::*save-trap-pc*)
	 (save-pc+     gr::*save-trap-pc+*)
	 (save-oreg    gr::*save-oreg*)
	 (save-jcond   gr::*save-jcond*)
	 (save-status  gr::*save-status*)
	 (save-left    gr::*save-left*)
	 (save-right   gr::*save-right*)
	 (save-q       (hw:read-q-register))
	 (memstat      (hw:read-memory-status))
	 (vma          (hw:read-vma))
	 (md (progn
	       (when (= hw:$$wmd-valid (hw:ldb memstat k-hw:%%memory-status-md-written-lately 0))
		 (hw:vma-start-write-no-gc-trap-unboxed trap:*magic-garbage-location*)
		 (hw:memory-wait)
		 (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed trap:*magic-garbage-location*)
		 (hw:read-md))
	       (trap-on)
	       (hw:read-md))))
    (if (k2:this-is-a-breakpoint? save-pc)
	(li:error "should not happen")
      (progn
	(modify-asynchronous-traps save-async)
	(multiple-value-bind (answer result-status)
	    (dt-and-ovf-trap-handler-2 save-pc save-left save-right save-status)
	  (hw:read-md)
	  (hw:nop)
	  (hw:trap-off)
	  (vinc:modify-single-step-trap save-sstep)
	  (setq gr:*kbug-trap* nil)
	  (setq gr::*save-right* answer)
	  (setq gr::*save-status*  result-status))))
    (setq gr::*save-trap-pc*      save-pc)
    (setq gr::*save-trap-pc+*     save-pc+)
    (setq gr::*save-oreg*    save-oreg)
    (setq gr::*save-jcond*   save-jcond)
    (hw:load-q-register save-q)
    (hw:write-md-unboxed md)
    (hw:vma-start-write-no-gc-trap-unboxed trap:*magic-garbage-location*)
    (vmem:write-md-generic md
			   (hw:ldb-not memstat k-hw:%%memory-status-md-not-boxed-bit 0))
    (vmem:write-vma-generic vma
			    (hw:ldb-not memstat k-hw:%%memory-status-vma-not-boxed-bit 0))))

(defun dt-and-ovf-trap-handler-2 (trap-pc left right status)
  (let* ((result nil)
	 (rstat  nil)
	 (pc-loc (pc->unboxed-locative trap-pc))
 	 (instl (progn (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed pc-loc)
		       (hw:read-md)))
 	 (insth (progn (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed (hw:32-1+ pc-loc))
		       (hw:read-md))))
    (dispatch k-hw:%%i-dtp-check-high insth  ;; dispatch on datatype check code
       ((vinc:$$dtc-both-fixnum vinc:$$dtc-both-fixnum-with-overflow)
	(when (or (zerop (k2:boxed-bit left)) (zerop (k2:boxed-bit right)))
	  (li:error "Fixnum datatype trap on unboxed data!" left right))
	(let ((op-info (decode-alu-op insth instl)))
	  (multiple-value-setq (result rstat)
	    (dispatch (byte 2. 5.) op-info
		      (binary-op
			(handle-binary-op insth instl op-info left right status))
		      (t (li:error "Unhandled unary/binary"))))))
       (t
	 (li:error "Illegal/unhandled datatype check code specified!")))
  (values result (hw:dpb (hw:ldb rstat (byte 4. 16.) 0) (byte 4. 16.) status))))

(defun overflow-trap-handler ()
  (hw:jump 'datatype-trap-handler))

(defun datatype-trap-handler ()
  (HW:CH-OPEN-CALL GR::*TRAP-TEMP1*)
     (HW:CH-TOPEN-CALL)
     (HW:OPEN-FRAME)
     (SETF (HW:O0)  GR::*RETURN-16*)
     (SETF (HW:O1)  GR::*RETURN-17*)
     (SETF (HW:O2)  GR::*RETURN-18*)
     (SETF (HW:O3)  GR::*RETURN-19*)
     (SETF (HW:O4)  GR::*RETURN-20*)
     (SETF (HW:O5)  GR::*RETURN-21*)
     (SETF (HW:O6)  GR::*RETURN-22*)
     (SETF (HW:O7)  GR::*RETURN-23*)
     (SETF (HW:O8)  GR::*RETURN-24*)
     (SETF (HW:O9)  GR::*RETURN-25*)
     (SETF (HW:O10) GR::*RETURN-26*)
     (SETF (HW:O11) GR::*RETURN-27*)
     (SETF (HW:O12) GR::*RETURN-28*)
     (SETF (HW:O13) GR::*RETURN-29*)
     (SETF (HW:O14) (HW:LDB (HW:READ-PROCESSOR-STATUS) K-HW:%%PROCESSOR-STATUS-RETURN-CODE 0.))
     (SETF (HW:O15) GR::*NUMBER-OF-RETURN-VALUES*)

     (HW:OPEN-FRAME)
     (SETF (HW:O0)  GR::*RETURN-0*)
     (SETF (HW:O1)  GR::*RETURN-1*)
     (SETF (HW:O2)  GR::*RETURN-2*)
     (SETF (HW:O3)  GR::*RETURN-3*)
     (SETF (HW:O4)  GR::*RETURN-4*)
     (SETF (HW:O5)  GR::*RETURN-5*)
     (SETF (HW:O6)  GR::*RETURN-6*)
     (SETF (HW:O7)  GR::*RETURN-7*)
     (SETF (HW:O8)  GR::*RETURN-8*)
     (SETF (HW:O9)  GR::*RETURN-9*)
     (SETF (HW:O10) GR::*RETURN-10*)
     (SETF (HW:O11) GR::*RETURN-11*)
     (SETF (HW:O12) GR::*RETURN-12*)
     (SETF (HW:O13) GR::*RETURN-13*)
     (SETF (HW:O14) GR::*RETURN-14*)
     (SETF (HW:O15) GR::*RETURN-15*)

     (dt-and-ovf-trap-handler-1)

     (SETQ GR::*RETURN-0*  (HW:O0))
     (SETQ GR::*RETURN-1*  (HW:O1))
     (SETQ GR::*RETURN-2*  (HW:O2))
     (SETQ GR::*RETURN-3*  (HW:O3))
     (SETQ GR::*RETURN-4*  (HW:O4))
     (SETQ GR::*RETURN-5*  (HW:O5))
     (SETQ GR::*RETURN-6*  (HW:O6))
     (SETQ GR::*RETURN-7*  (HW:O7))
     (SETQ GR::*RETURN-8*  (HW:O8))
     (SETQ GR::*RETURN-9*  (HW:O9))
     (SETQ GR::*RETURN-10* (HW:O10))
     (SETQ GR::*RETURN-11* (HW:O11))
     (SETQ GR::*RETURN-12* (HW:O12))
     (SETQ GR::*RETURN-13* (HW:O13))
     (SETQ GR::*RETURN-14* (HW:O14))
     (SETQ GR::*RETURN-15* (HW:O15))

     (setq gr::*trap-temp1* (hw:call 'flush-open-frame 0))

     (SETQ GR::*RETURN-16*  (HW:O0))
     (SETQ GR::*RETURN-17*  (HW:O1))
     (SETQ GR::*RETURN-18*  (HW:O2))
     (SETQ GR::*RETURN-19*  (HW:O3))
     (SETQ GR::*RETURN-20*  (HW:O4))
     (SETQ GR::*RETURN-21*  (HW:O5))
     (SETQ GR::*RETURN-22*  (HW:O6))
     (SETQ GR::*RETURN-23*  (HW:O7))
     (SETQ GR::*RETURN-24*  (HW:O8))
     (SETQ GR::*RETURN-25*  (HW:O9))
     (SETQ GR::*RETURN-26* (HW:O10))
     (SETQ GR::*RETURN-27* (HW:O11))
     (SETQ GR::*RETURN-28* (HW:O12))
     (SETQ GR::*RETURN-29* (HW:O13))
     (SETQ GR::*TRAP-TEMP1* (HW:O14))
     (SETQ GR::*NUMBER-OF-RETURN-VALUES* (HW:O15))

     (setq gr::*trap-temp2* (hw:call 'flush-open-frame 0))

     (if (zerop gr::*trap-temp1*)
	 (hw:ch-return-one-value)
	 (hw:ch-return-multiple-values))

     (hw:nop)

  (if gr:*kbug-trap*
      (hw:jump 'non-modifying-exit)
    (hw:jump 'modifying-exit)))


(defafun falu-test ()
k-test-first-trap-vector-loc  ; #o000  "First location reserved for trap vectors."
  ;; trap
loc-0
  (alu setl gr::*save-oreg* r0 r0 bw-32 boxed-left)
  (alu setl gr::*save-left* r0 r0 bw-32 boxed-left)
  (alu setr gr::*save-right* r0 r0 bw-32 boxed-right)
  (alu pass-status gr::*save-status* r0 r0 bw-32 unboxed)
  (alu-field extract-bit-right gr::*save-jcond* r0 processor-status (byte 1. (+ 32. 17.)) unboxed)
  (alu-field field-and gr::*save-trap* gr::*trap-mask* trap-register (byte 31. 0.) unboxed)
  (alu prioritize-r gr::*trap-temp1* r0 gr::*save-trap* bw-32 unboxed)
  (alu-field set-bit-right gr::*trap-temp1* r0 gr::*trap-temp1* (byte 1. 5.) unboxed)
  (alu merge-r gr::*save-trap-pc*  gr::*trap-dtp-code-5* trap-pc bw-24 boxed)
  (alu merge-r gr::*save-trap-pc+* gr::*trap-dtp-code-5* trap-pc+  bw-24 boxed next-pc-dispatch)
  (nop)
  (nop)
  ;; non-modifying-exit
loc-12
  (alu-field field-pass processor-control gr::*save-jcond* processor-control (byte 1. 4.))
  (alu load-status-r nop r0 gr::*save-status* bw-32)
  (alu setl gr:*trap-temp1* gr::*save-trap-pc*  gr::*save-right*  bw-32 boxed-left)
  (alu setl gr:*trap-temp1* gr::*save-trap-pc+* gr::*save-right*  bw-32 boxed-left)
  (alu setl gr:*trap-temp1* gr::*save-oreg* gr::*save-right* bw-32 next-pc-dispatch br-jindir boxed-left)
  (nop)
  (nop)
  (nop)
  ;; modifying-exit
loc-20
  (alu-field field-pass processor-control gr::*save-jcond* processor-control (byte 1. 4.))
  (alu load-status-r nop r0 gr::*save-status* bw-32)
  (alu setl gr:*trap-temp1* gr::*save-trap-pc*  gr::*save-right* bw-32 boxed-left)
  (alu setl gr:*trap-temp1* gr::*save-trap-pc+* gr::*save-right* bw-32 boxed-left)
  (alu setl gr:*trap-temp1* gr::*save-oreg* gr::*save-right* bw-32 next-pc-dispatch br-jindir boxed-left)
  (nop)
  (nop)
  (nop)
  ;; diagnostic-trap-exit
loc-28
  (alu setl nop gr::*save-trap-pc*  gr::*save-right* bw-32)
  (alu setl nop gr::*save-trap-pc+* gr::*save-right* bw-32)
  (move nop gr::*save-oreg* bw-32 next-pc-dispatch)
  (nop)
  ;; trap-vector-table
loc-32
trap-vector-reset					;Bit 31 - addr 32 - Highest priority
  (unconditional-branch reset-trap-handler ())
trap-vector-trace  					;Bit 30 - addr 33
  (unconditional-branch trace-trap-handler ())
trap-vector-icache-parity				;Bit 29 - addr 34
  (unconditional-branch icache-parity-trap-handler ())
trap-vector-icache-nubus-err				;Bit 28 - addr 35
  (unconditional-branch icache-nubus-error-trap-handler ())
trap-vector-icache-nubus-timeout		 	;Bit 27 - addr 36
  (unconditional-branch icache-nubus-timeout-trap-handler ())
trap-vector-icache-page-fault				;Bit 26 - addr 37
  (unconditional-branch icache-map-fault-trap-handler ())
trap-vector-proc-mread-parity				;Bit 25 - addr 38
  (unconditional-branch memory-read-parity-trap-handler ())
trap-vector-proc-mread-nubus-err		 	;Bit 24 - addr 39
  (unconditional-branch memory-read-nubus-error-trap-handler ())
trap-vector-proc-mread-nubus-timeout			;Bit 23- addr 40
  (unconditional-branch memory-read-nubus-timeout-trap-handler ())
trap-vector-proc-mread-page-fault			;Bit 22 - addr 41
  (unconditional-branch memory-read-page-fault-trap-handler ())
trap-vector-proc-mread-transporter			;Bit 21 - addr 42
  (unconditional-branch memory-read-transporter-trap-handler ())
trap-vector-proc-mwrite-nubus-err			;Bit 20 - addr 43
  (unconditional-branch memory-write-nubus-error-trap-handler ())
trap-vector-proc-mwrite-nubus-timeout			;Bit 19-  addr 44
  (unconditional-branch memory-write-nubus-timeout-trap-handler ())
trap-vector-proc-mwrite-page-fault			;Bit 18 - addr 45
  (unconditional-branch memory-write-page-fault-trap-handler ())
trap-vector-proc-mwrite-gc				;Bit 17 - addr 46
  (unconditional-branch memory-write-gc-trap-handler ())
trap-vector-floating-point				;Bit 16 - addr 47
  (unconditional-branch floating-point-trap-handler ())
trap-vector-heap-empty					;Bit 15 - addr 48
  (unconditional-branch heap-empty-trap-handler ())
trap-vector-instruction-bit				;Bit 14 - addr 49
  (unconditional-branch instruction-trap-handler ())
trap-vector-datatype					;Bit 13 - addr 50
  (unconditional-branch datatype-trap-handler ())
trap-vector-overflow					;Bit 12 - addr 51
  (jump overflow-trap-handler ())
trap-vector-spare11					;Bit 11 - addr 52
  (unconditional-branch spare11-trap-handler ())
trap-vector-interrupt7					;Bit 10 - addr 53
  (unconditional-branch debugger-trap-handler ())
trap-vector-interrupt6					;Bit 09 - addr 54
  (unconditional-branch interrupt6-trap-handler ())
trap-vector-interrupt5					;Bit 08 - addr 55
  (unconditional-branch interrupt5-trap-handler ())
trap-vector-interrupt4					;Bit 07 - addr 56
  (unconditional-branch iop-trap-handler ())
trap-vector-interrupt3					;Bit 06 - addr 57
  (unconditional-branch interrupt3-trap-handler ())
trap-vector-interrupt2					;Bit 05 - addr 58
  (unconditional-branch interrupt2-trap-handler ())
trap-vector-interrupt1					;Bit 04 - addr 59
  (unconditional-branch interrupt1-trap-handler ())
trap-vector-interrupt0					;Bit 03 - addr 60
  (unconditional-branch interrupt0-trap-handler ())
trap-vector-timer-1024					;Bit 02 - addr 61
  (unconditional-branch timer-1024-trap-handler ())
trap-vector-timer-16384					;Bit 01 - addr 62
  (unconditional-branch timer-16384-trap-handler ())
trap-vector-spurious					;Bit 00 - addr 63
k-test-last-trap-vector-loc ; #o077  "Last location reserved for trap vectors."
  (unconditional-branch spurious-trap-handler ())


;; locations reserved for use by the test code

k-test-entry-loc            ; #o100  "This is normally a jump to the real entry."
  (unconditional-branch k-test-code-loc ())
k-test-exit-loc             ; #o101  "Normally a halt instruction."
  (unconditional-branch k-test-exit-loc ())
k-test-bits-arg-loc         ; #o102  "(low word) 32 bits of switches passed to tests."
k-test-word-arg-loc         ; #o102  "(high word)One word argument to tests."
  (nop)
k-test-internal-result-loc  ; #o103  "(low word)"
k-test-external-result-loc  ; #o103  "(high word"
  (nop)
k-test-expected-value-loc   ; #o104  "(low word)"
k-test-incorrect-value-loc  ; #o104  "(high word"
  (nop)
k-test-address-loc          ; #o105  "(low word)"
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)


k-test-trap-code-loc        ; #o120  "Traps vector to this location."
 ;; these are the labels that traps vector to
 ;; I've kept them around in case we want to handle certain traps specially.
 ;; For now they all refer to the same location which simply loops on itself.
 reset-trap-handler 
 trace-trap-handler 
 icache-parity-trap-handler 
 icache-nubus-error-trap-handler 
 icache-nubus-timeout-trap-handler 
 icache-map-fault-trap-handler 
 memory-read-parity-trap-handler 
 memory-read-nubus-error-trap-handler 
 memory-read-nubus-timeout-trap-handler 
 memory-read-page-fault-trap-handler 
 memory-read-transporter-trap-handler 
 memory-write-nubus-error-trap-handler 
 memory-write-nubus-timeout-trap-handler 
 memory-write-page-fault-trap-handler 
 memory-write-gc-trap-handler 
 floating-point-trap-handler 
 heap-empty-trap-handler 
 instruction-trap-handler 
 datatype-trap-handler 
 overflow-trap-handler 
 spare11-trap-handler 
 debugger-trap-handler 
 interrupt6-trap-handler 
 interrupt5-trap-handler 
 iop-trap-handler 
 interrupt3-trap-handler 
 interrupt2-trap-handler 
 interrupt1-trap-handler 
 interrupt0-trap-handler 
 timer-1024-trap-handler 
 timer-16384-trap-handler 
 spurious-trap-handler 

  (unconditional-branch k-test-trap-code-loc ())
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)
  (nop)

k-test-code-loc               ;#o140  "Test code lives here."
setup
  (movei processor-control 7)
  (movei bus-control #X79)
  (movei open-active-return #xffffff)
  (movei vma 0)
  (nop)
  (movei memory-map #x0f)
  (movei memory-map #x0f)
  (nop)
first-test
  (movei a0 32.)
 loop
  (alu load-status-r nop a0 a0 bw-8)
  (alu-field set-bit-left a1 gr:*all-zero* ignore 0 pw-ri)
  (move md a1)
  (move vma-start-write gr:*zero* unboxed-md)
  (memory-wait)
  (move vma-start-read gr:*zero* unboxed-md)
  (memory-wait)
  (move a2 md)
  (alu xor nop a1 a2 bw-32 unboxed)
  (test br-not-equal)
  (branch fail ())
  (alu l-r a0 a0 gr:*one* bw-8)
  (test br-not-zero)
  (branch loop ())
 pass
  ;; set up success completion code and jump to exit location
  (movei md k-test-passed)
  (movei vma-start-write k-test-external-result-loc unboxed-vma)
  (unconditional-branch k-test-exit-loc ())
 fail
  ;; set up 
  ;;        failure completion code
  ;;        address being tested
  ;;        expected value
  ;;        incorrect value
  ;; and jump to exit location
  (movei md k-test-failed)
  (movei vma-start-write k-test-external-result-loc unboxed-vma)
  (move md gr:*zero*)
  (movei vma-start-write k-test-address-loc unboxed-vma)
  (move md a1)
  (movei vma-start-write k-test-expected-value-loc unboxed-vma)
  (move md a2)
  (movei vma-start-write k-test-incorrect-value-loc unboxed-vma)
  (unconditional-branch k-test-exit-loc ())

  )