imactrap.lisp

;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: POWERPC-INTERNALS; Base: 10; Lowercase: T -*-

(in-package "POWERPC-INTERNALS")

;;; Macros in support of traps and exceptions.

(defmacro prepare-trap (popped condition &optional vma)
  (declare (ignore popped))
  (let ((position (position condition *all-conditions* :test #'equal))
	(condition (if (listp condition) (first condition) condition)))
    (assert (not (null position)) (condition)
	    "~S is not a known condition" condition)
    (when (member condition *vma-valid-conditions*)
      (assert (not (null vma)) ()
	      "You need to supply a VMA for the condition ~S" condition))
    (let ((microstate (1+ position)))		;we don't like zero
      (if (null vma)
	`((load-constant arg5 0)
	  ;; This is second in case vma is in arg2!
	  (load-constant arg2 ,microstate))
        `((mov arg5 ,vma)
	  ;; This is second in case vma is in arg2!
	  (load-constant arg2 ,microstate))))))

;;; takes index in 'index' and returns entry in 'tag' and 'data'
(defmacro get-trap-vector-entry (index tag data cr temp2 temp3 temp4 temp5 temp6)
  (let ((index-is-reg? (find-register index))
	(tventrybad (gensym))
	(sk (gensym)))
    (if index-is-reg?
	(check-temporaries (index tag data cr) (temp2 temp3 temp4 temp5 temp6))
        (check-temporaries (tag data cr) (temp2 temp3 temp4 temp5 temp6)))
    (push
      `((label ,tventrybad)
	(halt-machine HaltReasonIllegalTrapVector)	;+++ fixup later
	)
      *function-epilogue*)
    `((get-control-register ,cr)
      (LD ,temp6 PROCESSORSTATE_FEPMODETRAPVECADDRESS (ivory))
      (LD ,temp5 PROCESSORSTATE_TRAPVECBASE (ivory))
      (load-constant ,temp2 #.(sys:%logdpb 3 (byte 2 30) 0))
      (srdi ,temp3 ,cr 30)
      (OR ,temp2 ,cr ,temp2 "Set trap mode to 3")
      (ANDI-DOT ,temp3 ,temp3 3)
      (set-control-register ,temp2)
      (ADDI ,temp4 ,temp3 -3)
      ,@(if index-is-reg?
	    `((ADD ,temp5 ,temp5 ,index))
	    `((ADDI ,temp5 ,temp5 ,index)))
      (CMPI 0 1 ,temp4 0)
      (BC 4 2 ,sk "B.NE")
      (mov ,temp5 ,temp6)
     (unlikely-label ,sk)
      (STD ,temp5 PROCESSORSTATE_TVI (ivory) "Record TVI for tracing (if enabled)")
      (memory-read ,temp5 ,tag ,data PROCESSORSTATE_DATAREAD ,temp6 ,temp4 ,temp3 ,temp2)
      (CheckAdjacentDataTypes ,tag |TypeEvenPC| 2 ,tventrybad ,temp2)
      (set-control-register ,cr "Restore the cr"))))


;;; The post traps

;;; Note that all of these routines shared registers!

(defmacro take-post-trap (tvi arity temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10
			  &optional next-pc next-cp)
  (check-temporaries () (temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10))
  (let ((tvi-is-reg? (find-register tvi))
	(label (gensym))
	(sk (gensym))
	(tag temp2)
	(data temp3)
	(cr temp4)
	(overflow (gensym)))
    `((mov ,temp iFP "save old frame pointer")
      (get-trap-vector-entry ,tvi ,tag ,data ,cr  ,temp5 ,temp6 ,temp7 ,temp8 ,temp9)
      (stack-cache-overflow-check ,temp5 ,temp6 ,temp7 ,temp8 ,temp9 iSP 8)
      (sldi iFP ,arity 3)
      (SUBF iFP iFP iSP)
      (ADDI iFP iFP 8)
      ;; Move operands up stack to make foom for fixed args.
      ,@(loop for i upfrom 0 below 4
	      nconc `((branch-if-zero ,arity ,label)
		      (stack-read-disp isp ,(* (- i) 8) ,temp5)
		      (stack-write-disp isp ,(* (- 4 i) 8) ,temp5)
		      (ADDI ,arity ,arity -1)))
    (label ,label)
      (ADDI iSP iSP ,(* 8 4))
      ;; Build frame header for trap.
      (get-continuation2 ,temp7 ,temp5)
      (load-constant ,temp8 #.1_29 "cr.instruction-trace")
      (clrldi ,cr ,cr 32)
      (ORI ,temp7 ,temp7 #xC0)
      ;; Setup FP|0 (continuation register)
      (stack-write2 iFP ,temp7 ,temp5)
      ;; Setup FP|1 (control register)
      (AND ,temp8 ,cr ,temp8)
      (srdi ,temp8 ,temp8 2)
      (li ,temp6 |TypeFixnum+0xC0|)
      (OR ,temp8 ,cr ,temp8)
      (stack-write2-disp iFP 8 ,temp6 ,temp8)
      ;; Setup iLP
      (ADDI iLP iSP 8)
      ;; Fill in the two fixed arguments.
      (li ,temp6 |TypeFixnum|)
      ,@(if tvi-is-reg?
	    `((mov ,temp8 ,tvi))
	    `((li ,temp8 ,tvi)))
      (stack-write2-disp iFP ,(* 2 8) ,temp6 ,temp8)
      (convert-pc-to-continuation iPC ,temp6 ,temp8 ,temp9)
      (stack-write2-disp iFP ,(* 3 8) ,temp6 ,temp8)
      ;; Set the control register
      (LD ,temp7 PROCESSORSTATE_FCCRTRAPMASK (ivory) "Get CR mask")
      (li ,temp5 1)
      (sldi ,temp5 ,temp5 18 "ValueDispositionValue*4 = 1<<18!")
      (SUBF ,temp6 iFP iLP "Arg size")
      (SUBF ,temp8 ,temp iFP "Caller Frame Size")
      (srdi ,temp6 ,temp6 3 "Arg size in words")
      (sldi ,temp8 ,temp8 ,(- 9 3) "Caller Frame Size in words in place")
      (OR ,temp5 ,temp5 ,temp6)
      (OR ,temp5 ,temp5 ,temp8)
      ;; Compute trap mode
      (TagCdr ,tag ,temp9)
      (srdi ,temp6 ,cr 30)
      (SUBF ,temp8 ,temp6 ,temp9)
      (CMPI 0 1 ,temp8 0)
      (BC 12 0 ,sk "B.LT")
      (mov ,temp6 ,temp9)
     (unlikely-label ,sk)
      (sldi ,temp6 ,temp6 30)
      (AND ,cr ,cr ,temp7 "Mask off unwanted bits")
      (OR ,cr ,cr ,temp6 "Add trap mode")
      (OR ,cr ,cr ,temp5 "Add argsize, apply, disposition, caller FS")
      (set-control-register ,cr)
      ;; Set Continuation
      ,@(cond ((null next-pc)
	       `(;; --- Overkill to Ensure iCP is accurate
		 (PC-TO-iCACHEENT iPC iCP ,temp6 ,temp8)
		 (LD ,temp9 CACHELINE_NEXTPCDATA (iCP))
		 (convert-pc-to-continuation ,temp9 ,temp6 ,temp8 ,temp10)
		 (LD ,temp9 CACHELINE_NEXTCP (iCP))
		 (STD ,temp9 PROCESSORSTATE_CONTINUATIONCP (Ivory))))
	      (t
		`((convert-pc-to-continuation ,next-pc ,temp6 ,temp8 ,temp9)
		  ,@(if next-cp
		      `((STD ,next-cp PROCESSORSTATE_CONTINUATIONCP (Ivory)))
		      `((stzd PROCESSORSTATE_CONTINUATIONCP (Ivory)))))))
      (set-continuation2 ,temp6 ,temp8)
      ;; Set PC
      (convert-continuation-to-pc ,tag ,data iPC ,temp9)
      (srdi ,temp6 ,cr 30 "Save current trap mode")
      (stack-overflow-p ,cr nil ,temp8 ,temp9 ,overflow)	;Destroys CR.
      ;; Can't use this as it will smash the annotation field to point to
      ;; the PC of the trap-handler, punting any useful annotation.
      ;; Worse, it will trigger a cache fill even if the correct CP is
      ;; already valid!!!
      ;; (ContinueToInterpretInstruction-ValidateCache)
      (PC-TO-iCACHEENT iPC iCP ,temp8 ,temp9)
      (ContinueToNextInstruction-NoStall)
      (label ,overflow)
      (branch-if-zero ,temp6 STACKOVERFLOW "Take the overflow if in emulator mode")
      (halt-machine HaltReasonFatalStackOverflow)
      ))) 

(defmacro stack-overflow-handler ()
  `(
    ;; If we come here, we have already advanced the PC and pushed a new
    ;; frame on the stack, so we must preserve iSP in the restartSP for
    ;; retry to work
    (STD iSP PROCESSORSTATE_RESTARTSP (Ivory))
    (clr R31)
    (take-post-trap |TrapVectorStackOverflow| R31 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 iPC)))


;;; The pre traps

;;; Note that all of these routines shared registers!

(defmacro take-pre-trap-1 (tvi temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10)
  (check-temporaries () (temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10))
  (let ((tvi-is-reg? (find-register tvi)))
    `((mov ,temp iFP "save old frame pointer")
      ,@(if tvi-is-reg?
	    `((mov ,temp10 ,tvi "save the trap vector index"))
	    `((li ,temp10 ,tvi "save the trap vector index")))
      (call-subroutine |StartPreTrap|))))
    
;; TVI has been set into TEMP10, old iFP in TEMP
(defmacro start-pre-trap (temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10)
  (check-temporaries () (temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10))
  `((LD ,temp2 PROCESSORSTATE_LINKAGE (Ivory))
    (branch-true ,temp2 |NativeException|)
    (get-trap-vector-entry ,temp10 ,temp2 ,temp3  ,temp4 ,temp5 ,temp6 ,temp7 ,temp8 ,temp9)
    ;; Restore stack pointer
    (LD iSP PROCESSORSTATE_RESTARTSP (ivory))
    (stack-cache-overflow-check ,temp4 ,temp5 ,temp6 ,temp7 ,temp8 iSP 8)
    ;; Build frame header for trap handler.
    (get-continuation2 ,temp4 ,temp5)
    (get-control-register ,temp7)
    (clrldi ,temp7 ,temp7 32)
    (ORI ,temp4 ,temp4 #xC0)
    ;; Setup FP|0
    (stack-push2-with-cdr ,temp4 ,temp5)
    ;; Setup FP|1
    (li ,temp6 |TypeFixnum+0xC0|)
    (stack-push2-with-cdr ,temp6 ,temp7)
    ;; Push the TVI and fault PC
    (mov ,temp6 ,temp10)
    (stack-push-ir |TypeFixnum| ,temp6 ,temp8)
    (convert-pc-to-continuation iPC ,temp6 ,temp8 ,temp9)
    (set-continuation2 ,temp6 ,temp8)
    (STD iCP PROCESSORSTATE_CONTINUATIONCP (Ivory))
    (stack-push2 ,temp6 ,temp8 ,temp9)))

(defmacro take-pre-trap-2 (tvi temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10)
  (declare (ignore tvi))
  (check-temporaries () (temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10))
  `((B |FinishPreTrap|)))

(defmacro finish-pre-trap (temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10)
  (check-temporaries () (temp temp2 temp3 temp4 temp5 temp6 temp7 temp8 temp9 temp10))
  (let ((sk (gensym)))
  `(;; Finish call
    ;; Establish new frame pointer.
    (LD iFP PROCESSORSTATE_RESTARTSP (ivory))
    (ADDI iFP iFP 8 "iFP now points to the start of our new frame")
    ;; Setup iLP
    (ADDI iLP iSP 8 "Points beyond the last argument")
    ;; Setup the control register.
    (LD ,temp4 PROCESSORSTATE_FCCRTRAPMASK (ivory) "Get CR mask")
    (li ,temp5 1)
    (sldi ,temp5 ,temp5 18 "ValueDispositionValue*4 = 1<<18!")
    (SUBF ,temp6 iFP iLP "Arg size")
    (SUBF ,temp8 ,temp iFP "Caller Frame Size")
    (srdi ,temp6 ,temp6 3 "Arg size in words")
    (sldi ,temp8 ,temp8 ,(- 9 3) "Caller Frame Size in words in place")
    (OR ,temp5 ,temp5 ,temp6)
    (OR ,temp5 ,temp5 ,temp8)
    ;; Compute trap mode
    (TagCdr ,temp2 ,temp9)
    (srdi ,temp6 ,temp7 30)
    (SUBF ,temp8 ,temp6 ,temp9)
    (CMPI 0 1 ,temp8 0 "(CMOVGE ,temp8 ,temp9 ,temp6)")
    (BC 12 0 ,sk "B.LT")
    (mov ,temp6 ,temp9)
   (unlikely-label ,sk)
    (sldi ,temp6 ,temp6 30)
    (AND ,temp7 ,temp7 ,temp4 "Mask off unwanted bits")
    (OR ,temp7 ,temp7 ,temp6 "Add trap mode")
    (OR ,temp7 ,temp7 ,temp5 "Add argsize, apply, disposition, caller FS")
    (set-control-register ,temp7)
    ;; Set Continuation is handled above
    ;; Set the PC
    (convert-continuation-to-pc ,temp2 ,temp3 iPC ,temp9)
    (stack-overflow-check ,temp7 nil ,temp8 ,temp9)	;Destroys TEMP7
    ;; Can't use this as it will smash the annotation field to point to
    ;; the PC of the trap-handler, punting any useful annotation.
    ;; Worse, it will trigger a cache fill even if the correct CP is
    ;; already valid!!!
    ;; (ContinueToInterpretInstruction-ValidateCache)
    (PC-TO-iCACHEENT iPC iCP ,temp8 ,temp9)
    (ContinueToNextInstruction-NoStall)
    )))

;; Microstate is in ARG2, VMA is in ARG5.  C.f., prepare-exception which
;; puts the opcode in ARG2 and vma in arg5 (but computes them in
;; exception-handler, so they are free for us)
(defmacro illegal-operand-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterError| t1 t2)
    (passthru "#endif")
    (take-pre-trap-1 |TrapVectorError| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (stack-push-ir |TypeFixnum| arg2 t11)	;the microstate
    (stack-push-ir |TypeLocative| arg5 t11)	;the vma
    (take-pre-trap-2 |TrapVectorError| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro reset-trap-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapVectorReset| t1 t2)
    (passthru "#endif")
    (take-pre-trap-1 |TrapVectorReset| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (take-pre-trap-2 |TrapVectorReset| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro pull-apply-args-trap-handler (argstopull temp13)
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapVectorPullApplyArgs| t1 t2)
    (passthru "#endif")
    (stack-pop2 t11 t12)
    (STD iSP PROCESSORSTATE_RESTARTSP (ivory))	;yes, we do mean to do this!
    (take-pre-trap-1 |TrapVectorPullApplyArgs| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (stack-push-ir |TypeFixnum| ,argstopull ,temp13)
    (stack-push2 t11 t12 ,temp13)
    (take-pre-trap-2 |TrapVectorPullApplyArgs| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro trace-trap-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapVectorTrace| t1 t2)
    (passthru "#endif")
    (take-pre-trap-1 |TrapVectorTrace| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (take-pre-trap-2 |TrapVectorTrace| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro preempt-request-trap-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapVectorPreemptRequest| t1 t2)
    (passthru "#endif")
    (take-pre-trap-1 |TrapVectorPreemptRequest| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (take-pre-trap-2 |TrapVectorPreemptRequest| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro high-priority-sequence-break-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapVectorHighPrioritySequenceBreak| t1 t2)
    (passthru "#endif")
    (take-pre-trap-1 |TrapVectorHighPrioritySequenceBreak| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (take-pre-trap-2 |TrapVectorHighPrioritySequenceBreak| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro low-priority-sequence-break-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapVectorLowPrioritySequenceBreak| t1 t2)
    (passthru "#endif")
    (take-pre-trap-1 |TrapVectorLowPrioritySequenceBreak| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (take-pre-trap-2 |TrapVectorLowPrioritySequenceBreak| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro db-unwind-frame-trap-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapVectorDBUnwindFrame| t1 t2)
    (passthru "#endif")
    (take-pre-trap-1 |TrapVectorDBUnwindFrame| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (LD t11 PROCESSORSTATE_BINDINGSTACKPOINTER (ivory))
    (stack-push-ir |TypeLocative| t11 t12)
    (take-pre-trap-2 |TrapVectorDBUnwindFrame| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro db-unwind-catch-trap-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapVectorDBUnwindCatch| t1 t2)
    (passthru "#endif")
    (take-pre-trap-1 |TrapVectorDBUnwindCatch| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (LD t11 PROCESSORSTATE_BINDINGSTACKPOINTER (ivory))
    (stack-push-ir |TypeLocative| t11 t12)
    (take-pre-trap-2 |TrapVectorDBUnwindCatch| t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))


;;; The Memory Traps.

;;; No physical addresses to worry about!
(defmacro take-memory-trap (tvi)
  `((LD t11 PROCESSORSTATE_VMA (ivory) "Preserve VMA against reading trap vector")
    (take-pre-trap-1 ,tvi t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)
    (stack-push-ir |TypeLocative| t11 t12)
    (take-pre-trap-2 ,tvi t1 t2 t3 t4 t5 t6 t7 t8 t9 t10)))

(defmacro transport-trap-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterTransport| t1 t2)
    (passthru "#endif")
    (take-memory-trap |TrapVectorTransport|)))

(defmacro monitor-trap-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterMonitor| t1 t2)
    (passthru "#endif")
    (take-memory-trap |TrapVectorMonitor|)))

(defmacro page-not-resident-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterPageNotResident| t1 t2)
    (passthru "#endif")
    (take-memory-trap |TrapVectorPageNotResident|)))

(defmacro page-fault-request-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterPageFaultRequest| t1 t2)
    (passthru "#endif")
    (take-memory-trap |TrapVectorPageFaultRequest|)))

(defmacro page-write-fault-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterPageWriteFault| t1 t2)
    (passthru "#endif")
    (take-memory-trap |TrapVectorPageWriteFault|)))

(defmacro uncorrectable-memory-error-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterUncorrectableMemoryError| t1 t2)
    (passthru "#endif")
    (take-memory-trap |TrapVectorUncorrectableMemoryError|)))

(defmacro bus-error-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterMemoryBusError| t1 t2)
    (passthru "#endif")
    (take-memory-trap |TrapVectorMemoryBusError|)))

(defmacro db-cache-miss-trap-handler ()
  `((passthru "#ifdef TRAPMETERING")
    (maybe-meter-trap |TrapMeterDBCacheMiss| t1 t2)
    (passthru "#endif")
    (take-memory-trap |TrapVectorDBCacheMiss|)))


;;; Instruction exceptions, which are special cases of post traps.

;;; The information here is taken verbatim from the iSoft emulator, but the
;;; way that the information is used if different.  We define the information
;;; here for the macroexpanders to create customized exception handler calls.

#||
*instruction-exception-info* is a per-opcode table of information we need to
take an instruction exception.  Each entry is either NIL, meaning an exception
shouldn't happen for that instruction, or a fixnum with the following fields:
(byte 2 0)   arity, the number of arguments to be passed to the trap handler.
             Note that this isn't always the same as the number of operands
             the instruction takes, see ldb for example.
(byte 1 2)   format.  0 means the last argument can be retrieved by looking
             at bits in the instruction.  For reference:
(byte 2 15.) is 00 or 01 for signed, 10 for unsigned, 11 for 
             address-operand.
             1 means the last argument is on the stack.  This is used for
             ldb, dpb, and a few other strange ones.
(byte 1 3)   0 if normal, 1 if arithmetic dispatch.
||#

;; ---*** OpenMCL fills an array with 0 by default???
(defvar *instruction-exception-info* (make-array 400 :initial-element nil))
(defvar *ivory-instruction-opcode-table* (make-hash-table))

;; Have to fill in table, as many instructions default their exception
;; info, but we still need to look up the opcode
(progn
 (setf (gethash 'car *ivory-instruction-opcode-table*) |opcode$K-car|)
 (setf (gethash 'cdr *ivory-instruction-opcode-table*) |opcode$K-cdr|)
 (setf (gethash 'endp *ivory-instruction-opcode-table*) |opcode$K-endp|)
 (setf (gethash 'setup-1d-array *ivory-instruction-opcode-table*) |opcode$K-setup1darray|)
 (setf (gethash 'setup-force-1d-array *ivory-instruction-opcode-table*)
        |opcode$K-setupforce1darray|)
 (setf (gethash 'bind-locative *ivory-instruction-opcode-table*) |opcode$K-bindlocative|)
 (setf (gethash '%restore-binding-stack *ivory-instruction-opcode-table*)
        |opcode$K-restorebindingstack|)
 (setf (gethash '%ephemeralp *ivory-instruction-opcode-table*) |opcode$K-ephemeralp|)
 (setf (gethash 'start-call *ivory-instruction-opcode-table*) |opcode$K-startcall|)
 (setf (gethash '%jump *ivory-instruction-opcode-table*) |opcode$K-jump|)
 (setf (gethash '%tag *ivory-instruction-opcode-table*) |opcode$K-tag|)
 (setf (gethash 'dereference *ivory-instruction-opcode-table*) |opcode$K-dereference|)
 (setf (gethash 'logic-tail-test *ivory-instruction-opcode-table*) |opcode$K-logictailtest|)
 #|| (setf (gethash '%proc-breakpoint *ivory-instruction-opcode-table*)
	   |opcode$K-%proc-breakpoint|) ||#
 (setf (gethash 'double-float-op *ivory-instruction-opcode-table*) |opcode$K-doublefloatop|)
 (setf (gethash 'push-lexical-var *ivory-instruction-opcode-table*) |opcode$K-pushlexicalvar|)
 (setf (gethash 'push-lexical-var *ivory-instruction-opcode-table*) |opcode$K-pushlexicalvar|)
 (setf (gethash 'push-lexical-var *ivory-instruction-opcode-table*) |opcode$K-pushlexicalvar|)
 (setf (gethash 'push-lexical-var *ivory-instruction-opcode-table*) |opcode$K-pushlexicalvar|)
 (setf (gethash 'push-lexical-var *ivory-instruction-opcode-table*) |opcode$K-pushlexicalvar|)
 (setf (gethash 'push-lexical-var *ivory-instruction-opcode-table*) |opcode$K-pushlexicalvar|)
 (setf (gethash 'push-lexical-var *ivory-instruction-opcode-table*) |opcode$K-pushlexicalvar|)
 (setf (gethash 'push-lexical-var *ivory-instruction-opcode-table*) |opcode$K-pushlexicalvar|)
 (setf (gethash '%block-0-write *ivory-instruction-opcode-table*) |opcode$K-block0write|)
 (setf (gethash '%block-1-write *ivory-instruction-opcode-table*) |opcode$K-block1write|)
 (setf (gethash '%block-2-write *ivory-instruction-opcode-table*) |opcode$K-block2write|)
 (setf (gethash '%block-3-write *ivory-instruction-opcode-table*) |opcode$K-block3write|)
 (setf (gethash 'zerop *ivory-instruction-opcode-table*) |opcode$K-zerop|)
 (setf (gethash 'minusp *ivory-instruction-opcode-table*) |opcode$K-minusp|)
 (setf (gethash 'plusp *ivory-instruction-opcode-table*) |opcode$K-plusp|)
 (setf (gethash 'type-member *ivory-instruction-opcode-table*) |opcode$K-typemember|)
 (setf (gethash 'type-member *ivory-instruction-opcode-table*) |opcode$K-typemember|)
 (setf (gethash 'type-member *ivory-instruction-opcode-table*) |opcode$K-typemember|)
 (setf (gethash 'type-member *ivory-instruction-opcode-table*) |opcode$K-typemember|)
 (setf (gethash 'type-member-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-typemembernopop|)
 (setf (gethash 'type-member-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-typemembernopop|)
 (setf (gethash 'type-member-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-typemembernopop|)
 (setf (gethash 'type-member-no-pop *ivory-instruction-opcode-table*)
       |opcode$K-typemembernopop|)
 (setf (gethash 'locate-locals *ivory-instruction-opcode-table*) |opcode$K-locatelocals|)
 (setf (gethash 'catch-close *ivory-instruction-opcode-table*) |opcode$K-catchclose|)
 (setf (gethash '%generic-dispatch *ivory-instruction-opcode-table*)
       |opcode$K-genericdispatch|)
 (setf (gethash '%message-dispatch *ivory-instruction-opcode-table*)
        |opcode$K-messagedispatch|)
 (setf (gethash '%check-preempt-request *ivory-instruction-opcode-table*)
        |opcode$K-checkpreemptrequest|)
 (setf (gethash 'push-global-logic-variable *ivory-instruction-opcode-table*)
        |opcode$K-pushgloballogicvariable|)
 (setf (gethash 'no-op *ivory-instruction-opcode-table*) |opcode$K-noop|)
 (setf (gethash '%halt *ivory-instruction-opcode-table*) |opcode$K-halt|)
 (setf (gethash 'branch-true *ivory-instruction-opcode-table*) |opcode$K-branchtrue|)
 (setf (gethash 'branch-true-else-extra-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchtrueelseextrapop|)
 (setf (gethash 'branch-true-and-extra-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchtrueandextrapop|)
 (setf (gethash 'branch-true-extra-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchtrueextrapop|)
 (setf (gethash 'branch-true-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchtruenopop|)
 (setf (gethash 'branch-true-and-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchtrueandnopop|)
 (setf (gethash 'branch-true-else-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchtrueelsenopop|)
 (setf (gethash 'branch-true-and-no-pop-else-no-pop-extra-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchtrueandnopopelsenopopextrapop|)
 (setf (gethash 'branch-false *ivory-instruction-opcode-table*) |opcode$K-branchfalse|)
 (setf (gethash 'branch-false-else-extra-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchfalseelseextrapop|)
 (setf (gethash 'branch-false-and-extra-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchfalseandextrapop|)
 (setf (gethash 'branch-false-extra-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchfalseextrapop|)
 (setf (gethash 'branch-false-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchfalsenopop|)
 (setf (gethash 'branch-false-and-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchfalseandnopop|)
 (setf (gethash 'branch-false-else-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-branchfalseelsenopop|)
 (setf (gethash 'branch-false-and-no-pop-else-no-pop-extra-pop
                *ivory-instruction-opcode-table*)
        |opcode$K-branchfalseandnopopelsenopopextrapop|)
 (setf (gethash 'push *ivory-instruction-opcode-table*) |opcode$K-push|)
 (setf (gethash 'push-n-nils *ivory-instruction-opcode-table*) |opcode$K-pushnnils|)
 (setf (gethash 'push-address-sp-relative *ivory-instruction-opcode-table*)
        |opcode$K-pushaddresssprelative|)
 (setf (gethash 'push-local-logic-variables *ivory-instruction-opcode-table*)
        |opcode$K-pushlocallogicvariables|)
 (setf (gethash 'return-multiple *ivory-instruction-opcode-table*) |opcode$K-returnmultiple|)
 (setf (gethash 'return-kludge *ivory-instruction-opcode-table*) |opcode$K-returnkludge|)
 (setf (gethash 'take-values *ivory-instruction-opcode-table*) |opcode$K-takevalues|)
 (setf (gethash 'unbind-n *ivory-instruction-opcode-table*) |opcode$K-unbindn|)
 (setf (gethash 'push-instance-variable *ivory-instruction-opcode-table*)
        |opcode$K-pushinstancevariable|)
 (setf (gethash 'push-address-instance-variable *ivory-instruction-opcode-table*)
        |opcode$K-pushaddressinstancevariable|)
 (setf (gethash 'push-instance-variable-ordered *ivory-instruction-opcode-table*)
        |opcode$K-pushinstancevariableordered|)
 (setf (gethash 'push-address-instance-variable-ordered *ivory-instruction-opcode-table*)
        |opcode$K-pushaddressinstancevariableordered|)
 (setf (gethash 'unary-minus *ivory-instruction-opcode-table*) |opcode$K-unaryminus|)
 (setf (gethash 'return-single *ivory-instruction-opcode-table*) |opcode$K-returnsingle|)
 (setf (gethash '%memory-read *ivory-instruction-opcode-table*) |opcode$K-memoryread|)
 (setf (gethash '%memory-read-address *ivory-instruction-opcode-table*)
        |opcode$K-memoryreadaddress|)
 (setf (gethash '%block-0-read *ivory-instruction-opcode-table*) |opcode$K-block0read|)
 (setf (gethash '%block-1-read *ivory-instruction-opcode-table*) |opcode$K-block1read|)
 (setf (gethash '%block-2-read *ivory-instruction-opcode-table*) |opcode$K-block2read|)
 (setf (gethash '%block-3-read *ivory-instruction-opcode-table*) |opcode$K-block3read|)
 (setf (gethash '%block-0-read-shift *ivory-instruction-opcode-table*)
        |opcode$K-block0readshift|)
 (setf (gethash '%block-1-read-shift *ivory-instruction-opcode-table*)
        |opcode$K-block1readshift|)
 (setf (gethash '%block-2-read-shift *ivory-instruction-opcode-table*)
        |opcode$K-block2readshift|)
 (setf (gethash '%block-3-read-shift *ivory-instruction-opcode-table*)
        |opcode$K-block3readshift|)
 (setf (gethash '%block-0-read-test *ivory-instruction-opcode-table*)
        |opcode$K-block0readtest|)
 (setf (gethash '%block-1-read-test *ivory-instruction-opcode-table*)
        |opcode$K-block1readtest|)
 (setf (gethash '%block-2-read-test *ivory-instruction-opcode-table*)
        |opcode$K-block2readtest|)
 (setf (gethash '%block-3-read-test *ivory-instruction-opcode-table*)
        |opcode$K-block3readtest|)
 (setf (gethash 'finish-call-n *ivory-instruction-opcode-table*) |opcode$K-finishcalln|)
 (setf (gethash 'finish-call-n-apply *ivory-instruction-opcode-table*)
        |opcode$K-finishcallnapply|)
 (setf (gethash 'finish-call-tos *ivory-instruction-opcode-table*) |opcode$K-finishcalltos|)
 (setf (gethash 'finish-call-tos-apply *ivory-instruction-opcode-table*)
        |opcode$K-finishcalltosapply|)
 (setf (gethash 'set-to-car *ivory-instruction-opcode-table*) |opcode$K-settocar|)
 (setf (gethash 'set-to-cdr *ivory-instruction-opcode-table*) |opcode$K-settocdr|)
 (setf (gethash 'set-to-cdr-push-car *ivory-instruction-opcode-table*)
        |opcode$K-settocdrpushcar|)
 (setf (gethash 'increment *ivory-instruction-opcode-table*) |opcode$K-increment|)
 (setf (gethash 'decrement *ivory-instruction-opcode-table*) |opcode$K-decrement|)
 (setf (gethash '%pointer-increment *ivory-instruction-opcode-table*)
        |opcode$K-pointerincrement|)
 (setf (gethash '%set-cdr-code-1 *ivory-instruction-opcode-table*) |opcode$K-setcdrcode1|)
 (setf (gethash '%set-cdr-code-2 *ivory-instruction-opcode-table*) |opcode$K-setcdrcode2|)
 (setf (gethash 'push-address *ivory-instruction-opcode-table*) |opcode$K-pushaddress|)
 (setf (gethash 'set-sp-to-address *ivory-instruction-opcode-table*)
        |opcode$K-setsptoaddress|)
 (setf (gethash 'set-sp-to-address-save-tos *ivory-instruction-opcode-table*)
        |opcode$K-setsptoaddresssavetos|)
 (setf (gethash '%read-internal-register *ivory-instruction-opcode-table*)
        |opcode$K-readinternalregister|)
 (setf (gethash '%write-internal-register *ivory-instruction-opcode-table*)
        |opcode$K-writeinternalregister|)
 (setf (gethash '%coprocessor-read *ivory-instruction-opcode-table*)
        |opcode$K-coprocessorread|)
 (setf (gethash '%coprocessor-write *ivory-instruction-opcode-table*)
        |opcode$K-coprocessorwrite|)
 (setf (gethash '%block-0-read-alu *ivory-instruction-opcode-table*)
        |opcode$K-block0readalu|)
 (setf (gethash '%block-1-read-alu *ivory-instruction-opcode-table*)
        |opcode$K-block1readalu|)
 (setf (gethash '%block-2-read-alu *ivory-instruction-opcode-table*)
        |opcode$K-block2readalu|)
 (setf (gethash '%block-3-read-alu *ivory-instruction-opcode-table*)
        |opcode$K-block3readalu|)
 (setf (gethash 'ldb *ivory-instruction-opcode-table*) |opcode$K-ldb|)
 (setf (gethash 'char-ldb *ivory-instruction-opcode-table*) |opcode$K-charldb|)
 (setf (gethash '%p-ldb *ivory-instruction-opcode-table*) |opcode$K-pldb|)
 (setf (gethash '%p-tag-ldb *ivory-instruction-opcode-table*) |opcode$K-ptagldb|)
 (setf (gethash 'branch *ivory-instruction-opcode-table*) |opcode$K-branch|)
 (setf (gethash 'loop-decrement-tos *ivory-instruction-opcode-table*)
        |opcode$K-loopdecrementtos|)
 (setf (gethash 'entry-rest-accepted *ivory-instruction-opcode-table*)
        |opcode$K-entryrestaccepted|)
 (setf (gethash 'entry-rest-not-accepted *ivory-instruction-opcode-table*)
        |opcode$K-entryrestnotaccepted|)
 (setf (gethash 'rplaca *ivory-instruction-opcode-table*) |opcode$K-rplaca|)
 (setf (gethash 'rplacd *ivory-instruction-opcode-table*) |opcode$K-rplacd|)
 (setf (gethash 'multiply *ivory-instruction-opcode-table*) |opcode$K-multiply|)
 (setf (gethash 'quotient *ivory-instruction-opcode-table*) |opcode$K-quotient|)
 (setf (gethash 'ceiling *ivory-instruction-opcode-table*) |opcode$K-ceiling|)
 (setf (gethash 'floor *ivory-instruction-opcode-table*) |opcode$K-floor|)
 (setf (gethash 'truncate *ivory-instruction-opcode-table*) |opcode$K-truncate|)
 (setf (gethash 'round *ivory-instruction-opcode-table*) |opcode$K-round|)
 (setf (gethash 'rational-quotient *ivory-instruction-opcode-table*)
        |opcode$K-rationalquotient|)
 (setf (gethash 'min *ivory-instruction-opcode-table*) |opcode$K-min|)
 (setf (gethash 'max *ivory-instruction-opcode-table*) |opcode$K-max|)
 (setf (gethash '%alu *ivory-instruction-opcode-table*) |opcode$K-alu|)
 (setf (gethash 'logand *ivory-instruction-opcode-table*) |opcode$K-logand|)
 (setf (gethash 'logxor *ivory-instruction-opcode-table*) |opcode$K-logxor|)
 (setf (gethash 'logior *ivory-instruction-opcode-table*) |opcode$K-logior|)
 (setf (gethash 'rot *ivory-instruction-opcode-table*) |opcode$K-rot|)
 (setf (gethash 'lsh *ivory-instruction-opcode-table*) |opcode$K-lsh|)
 (setf (gethash '%multiply-double *ivory-instruction-opcode-table*)
        |opcode$K-multiplydouble|)
 (setf (gethash '%lshc-bignum-step *ivory-instruction-opcode-table*)
        |opcode$K-lshcbignumstep|)
 (setf (gethash 'stack-blt *ivory-instruction-opcode-table*) |opcode$K-stackblt|)
 (setf (gethash 'rgetf *ivory-instruction-opcode-table*) |opcode$K-rgetf|)
 (setf (gethash 'member *ivory-instruction-opcode-table*) |opcode$K-member|)
 (setf (gethash 'assoc *ivory-instruction-opcode-table*) |opcode$K-assoc|)
 (setf (gethash '%pointer-plus *ivory-instruction-opcode-table*) |opcode$K-pointerplus|)
 (setf (gethash '%pointer-difference *ivory-instruction-opcode-table*)
        |opcode$K-pointerdifference|)
 (setf (gethash 'ash *ivory-instruction-opcode-table*) |opcode$K-ash|)
 (setf (gethash 'store-conditional *ivory-instruction-opcode-table*)
        |opcode$K-storeconditional|)
 (setf (gethash '%memory-write *ivory-instruction-opcode-table*) |opcode$K-memorywrite|)
 (setf (gethash '%p-store-contents *ivory-instruction-opcode-table*)
        |opcode$K-pstorecontents|)
 (setf (gethash 'bind-locative-to-value *ivory-instruction-opcode-table*)
        |opcode$K-bindlocativetovalue|)
 (setf (gethash 'unify *ivory-instruction-opcode-table*) |opcode$K-unify|)
 (setf (gethash 'pop-lexical-var *ivory-instruction-opcode-table*) |opcode$K-poplexicalvar|)
 (setf (gethash 'pop-lexical-var *ivory-instruction-opcode-table*) |opcode$K-poplexicalvar|)
 (setf (gethash 'pop-lexical-var *ivory-instruction-opcode-table*) |opcode$K-poplexicalvar|)
 (setf (gethash 'pop-lexical-var *ivory-instruction-opcode-table*) |opcode$K-poplexicalvar|)
 (setf (gethash 'pop-lexical-var *ivory-instruction-opcode-table*) |opcode$K-poplexicalvar|)
 (setf (gethash 'pop-lexical-var *ivory-instruction-opcode-table*) |opcode$K-poplexicalvar|)
 (setf (gethash 'pop-lexical-var *ivory-instruction-opcode-table*) |opcode$K-poplexicalvar|)
 (setf (gethash 'pop-lexical-var *ivory-instruction-opcode-table*) |opcode$K-poplexicalvar|)
 (setf (gethash 'movem-lexical-var *ivory-instruction-opcode-table*)
        |opcode$K-movemlexicalvar|)
 (setf (gethash 'movem-lexical-var *ivory-instruction-opcode-table*)
        |opcode$K-movemlexicalvar|)
 (setf (gethash 'movem-lexical-var *ivory-instruction-opcode-table*)
        |opcode$K-movemlexicalvar|)
 (setf (gethash 'movem-lexical-var *ivory-instruction-opcode-table*)
        |opcode$K-movemlexicalvar|)
 (setf (gethash 'movem-lexical-var *ivory-instruction-opcode-table*)
        |opcode$K-movemlexicalvar|)
 (setf (gethash 'movem-lexical-var *ivory-instruction-opcode-table*)
        |opcode$K-movemlexicalvar|)
 (setf (gethash 'movem-lexical-var *ivory-instruction-opcode-table*)
        |opcode$K-movemlexicalvar|)
 (setf (gethash 'movem-lexical-var *ivory-instruction-opcode-table*)
        |opcode$K-movemlexicalvar|)
 (setf (gethash 'equal-number *ivory-instruction-opcode-table*) |opcode$K-equalnumber|)
 (setf (gethash 'lessp *ivory-instruction-opcode-table*) |opcode$K-lessp|)
 (setf (gethash 'greaterp *ivory-instruction-opcode-table*) |opcode$K-greaterp|)
 (setf (gethash 'eql *ivory-instruction-opcode-table*) |opcode$K-eql|)
 (setf (gethash 'equal-number-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-equalnumbernopop|)
 (setf (gethash 'lessp-no-pop *ivory-instruction-opcode-table*) |opcode$K-lesspnopop|)
 (setf (gethash 'greaterp-no-pop *ivory-instruction-opcode-table*) |opcode$K-greaterpnopop|)
 (setf (gethash 'eql-no-pop *ivory-instruction-opcode-table*) |opcode$K-eqlnopop|)
 (setf (gethash 'eq *ivory-instruction-opcode-table*) |opcode$K-eq|)
 (setf (gethash 'logtest *ivory-instruction-opcode-table*) |opcode$K-logtest|)
 (setf (gethash 'eq-no-pop *ivory-instruction-opcode-table*) |opcode$K-eqnopop|)
 (setf (gethash 'logtest-no-pop *ivory-instruction-opcode-table*) |opcode$K-logtestnopop|)
 (setf (gethash 'add *ivory-instruction-opcode-table*) |opcode$K-add|)
 (setf (gethash 'sub *ivory-instruction-opcode-table*) |opcode$K-sub|)
 (setf (gethash '%32-bit-plus *ivory-instruction-opcode-table*) |opcode$K-32bitplus|)
 (setf (gethash '%32-bit-difference *ivory-instruction-opcode-table*)
       |opcode$K-32bitdifference|)
 (setf (gethash '%add-bignum-step *ivory-instruction-opcode-table*)
        |opcode$K-addbignumstep|)
 (setf (gethash '%sub-bignum-step *ivory-instruction-opcode-table*)
        |opcode$K-subbignumstep|)
 (setf (gethash '%multiply-bignum-step *ivory-instruction-opcode-table*)
        |opcode$K-multiplybignumstep|)
 (setf (gethash '%divide-bignum-step *ivory-instruction-opcode-table*)
        |opcode$K-dividebignumstep|)
 (setf (gethash 'aset-1 *ivory-instruction-opcode-table*) |opcode$K-aset1|)
 (setf (gethash '%allocate-list-block *ivory-instruction-opcode-table*)
        |opcode$K-allocatelistblock|)
 (setf (gethash 'aref-1 *ivory-instruction-opcode-table*) |opcode$K-aref1|)
 (setf (gethash 'aloc-1 *ivory-instruction-opcode-table*) |opcode$K-aloc1|)
 (setf (gethash 'store-array-leader *ivory-instruction-opcode-table*)
        |opcode$K-storearrayleader|)
 (setf (gethash '%allocate-structure-block *ivory-instruction-opcode-table*)
        |opcode$K-allocatestructureblock|)
 (setf (gethash 'array-leader *ivory-instruction-opcode-table*) |opcode$K-arrayleader|)
 (setf (gethash 'aloc-leader *ivory-instruction-opcode-table*) |opcode$K-alocleader|)
 (setf (gethash 'pop-instance-variable *ivory-instruction-opcode-table*)
        |opcode$K-popinstancevariable|)
 (setf (gethash 'movem-instance-variable *ivory-instruction-opcode-table*)
        |opcode$K-moveminstancevariable|)
 (setf (gethash 'pop-instance-variable-ordered *ivory-instruction-opcode-table*)
        |opcode$K-popinstancevariableordered|)
 (setf (gethash 'movem-instance-variable-ordered *ivory-instruction-opcode-table*)
        |opcode$K-moveminstancevariableordered|)
 (setf (gethash '%instance-ref *ivory-instruction-opcode-table*) |opcode$K-instanceref|)
 (setf (gethash '%instance-set *ivory-instruction-opcode-table*) |opcode$K-instanceset|)
 (setf (gethash '%instance-loc *ivory-instruction-opcode-table*) |opcode$K-instanceloc|)
 (setf (gethash '%set-tag *ivory-instruction-opcode-table*) |opcode$K-settag|)
 (setf (gethash '%unsigned-lessp *ivory-instruction-opcode-table*) |opcode$K-unsignedlessp|)
 (setf (gethash '%unsigned-lessp-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-unsignedlesspnopop|)
 (setf (gethash 'pop *ivory-instruction-opcode-table*) |opcode$K-pop|)
 (setf (gethash 'movem *ivory-instruction-opcode-table*) |opcode$K-movem|)
 (setf (gethash '%merge-cdr-no-pop *ivory-instruction-opcode-table*)
        |opcode$K-mergecdrnopop|)
 (setf (gethash 'fast-aref-1 *ivory-instruction-opcode-table*) |opcode$K-fastaref1|)
 (setf (gethash 'fast-aset-1 *ivory-instruction-opcode-table*) |opcode$K-fastaset1|)
 (setf (gethash 'stack-blt-address *ivory-instruction-opcode-table*)
        |opcode$K-stackbltaddress|)
 (setf (gethash 'dpb *ivory-instruction-opcode-table*) |opcode$K-dpb|)
 (setf (gethash 'char-dpb *ivory-instruction-opcode-table*) |opcode$K-chardpb|)
 (setf (gethash '%p-dpb *ivory-instruction-opcode-table*) |opcode$K-pdpb|)
 (setf (gethash '%p-tag-dpb *ivory-instruction-opcode-table*) |opcode$K-ptagdpb|)
 (setf (gethash 'loop-increment-tos-less-than *ivory-instruction-opcode-table*)
        |opcode$K-loopincrementtoslessthan|)
 (setf (gethash 'catch-open *ivory-instruction-opcode-table*) |opcode$K-catchopen|)
 #|| (setf (gethash '%hack *ivory-instruction-opcode-table*) |opcode$K-hack|) ||#
 )



(defmacro define-instruction-exception (instruction opcode arity &rest options)
  `(define-instruction-exception-1 ',instruction ,opcode ,arity ',options))

(defun define-instruction-exception-1 (instruction opcode arity options)
    (setf (gethash instruction *ivory-instruction-opcode-table*) opcode)
    (setf (aref *instruction-exception-info* opcode)
	  (dpb (if (member :stack options) 1 0)
	       (byte 1 3)
	       (dpb (if (member :arithmetic options) 1 0)
		    (byte 1 4)
		    arity))))

(defun instruction-exception-info (opcode)
  #+Genera (declare (values arity stack? arithmetic?))
  (let ((info (aref *instruction-exception-info* opcode)))
    (if (not (null info))
	(values (ldb (byte 3 0) info)
		(ldb-test (byte 1 3) info)
		(ldb-test (byte 1 4) info))
      ;; Undefined instruction exception.
      (values 0 t nil))))

(define-instruction-exception car |opcode$K-car| 1)
(define-instruction-exception cdr |opcode$K-cdr| 1)
(define-instruction-exception set-to-car |opcode$K-settocar| 1)
(define-instruction-exception set-to-cdr |opcode$K-settocdr| 1)
(define-instruction-exception set-to-cdr-push-car |opcode$K-settocdrpushcar| 1)
(define-instruction-exception rplaca |opcode$K-rplaca| 2)
(define-instruction-exception rplacd |opcode$K-rplacd| 2)
(define-instruction-exception rgetf |opcode$K-rgetf| 2)
(define-instruction-exception member |opcode$K-member| 2)
(define-instruction-exception assoc |opcode$K-assoc| 2)
(define-instruction-exception eql |opcode$K-eql| 2 :arithmetic)
(define-instruction-exception eql-no-pop |opcode$K-eqlnopop| 2 :arithmetic)
(define-instruction-exception equal-number |opcode$K-equalnumber| 2 :arithmetic)
(define-instruction-exception equal-number-no-pop |opcode$K-equalnumbernopop| 2 :arithmetic)
(define-instruction-exception greaterp |opcode$K-greaterp|  2 :arithmetic)
(define-instruction-exception greaterp-no-pop |opcode$K-greaterpnopop| 2 :arithmetic)
(define-instruction-exception lessp |opcode$K-lessp| 2 :arithmetic)
(define-instruction-exception lessp-no-pop |opcode$K-lesspnopop| 2 :arithmetic)
(define-instruction-exception plusp |opcode$K-plusp| 1 :arithmetic)
(define-instruction-exception minusp |opcode$K-minusp| 1 :arithmetic)
(define-instruction-exception zerop |opcode$K-zerop| 1 :arithmetic)
(define-instruction-exception logtest |opcode$K-logtest| 2 :arithmetic)
(define-instruction-exception logtest-no-pop |opcode$K-logtestnopop| 2 :arithmetic)
(define-instruction-exception add |opcode$K-add| 2 :arithmetic)
(define-instruction-exception sub |opcode$K-sub| 2 :arithmetic)
(define-instruction-exception unary-minus |opcode$K-unaryminus| 1 :arithmetic)
(define-instruction-exception increment |opcode$K-increment| 1)
(define-instruction-exception decrement |opcode$K-decrement| 1)
(define-instruction-exception multiply |opcode$K-multiply| 2 :arithmetic)
(define-instruction-exception quotient |opcode$K-quotient| 2 :arithmetic)
(define-instruction-exception ceiling |opcode$K-ceiling| 2 :arithmetic)
(define-instruction-exception floor |opcode$K-floor| 2 :arithmetic)
(define-instruction-exception truncate |opcode$K-truncate| 2 :arithmetic)
(define-instruction-exception round |opcode$K-round| 2 :arithmetic)
;(define-instruction-exception remainder 2 :arithmetic)
(define-instruction-exception rational-quotient |opcode$K-rationalquotient| 2 :arithmetic)
(define-instruction-exception double-float-op |opcode$K-doublefloatop| 5 :arithmetic)
(define-instruction-exception max |opcode$K-max| 2 :arithmetic)
(define-instruction-exception min |opcode$K-min| 2 :arithmetic)
(define-instruction-exception logand |opcode$K-logand| 2 :arithmetic)
(define-instruction-exception logior |opcode$K-logior| 2 :arithmetic)
(define-instruction-exception logxor |opcode$K-logxor| 2 :arithmetic)
(define-instruction-exception ash |opcode$K-ash| 2 :arithmetic)
(define-instruction-exception ldb |opcode$K-ldb| 1 :stack)
(define-instruction-exception dpb |opcode$K-dpb| 2 :stack)
(define-instruction-exception aref-1 |opcode$K-aref1| 2)
(define-instruction-exception aset-1 |opcode$K-aset1| 3)
(define-instruction-exception aloc-1 |opcode$K-aloc1| 2)
(define-instruction-exception setup-1d-array |opcode$K-setup1darray| 1)
(define-instruction-exception setup-force-1d-array |opcode$K-setupforce1darray| 1)
(define-instruction-exception fast-aref-1 |opcode$K-fastaref1| 2)
(define-instruction-exception fast-aset-1 |opcode$K-fastaset1| 3)
(define-instruction-exception array-leader |opcode$K-arrayleader| 2)
(define-instruction-exception store-array-leader |opcode$K-storearrayleader| 3)
(define-instruction-exception aloc-leader |opcode$K-alocleader| 2)
(define-instruction-exception loop-decrement-tos |opcode$K-loopdecrementtos| 1 :stack)
(define-instruction-exception loop-increment-tos-less-than |opcode$K-loopincrementtoslessthan| 2 :stack)
(define-instruction-exception block-0-read-alu |opcode$K-block0readalu| 1)
(define-instruction-exception block-1-read-alu |opcode$K-block1readalu| 1)
(define-instruction-exception block-2-read-alu |opcode$K-block2readalu| 1)
(define-instruction-exception block-3-read-alu |opcode$K-block3readalu| 1)
(define-instruction-exception allocate-list-block |opcode$K-allocatelistblock| 2)
(define-instruction-exception allocate-structure-block |opcode$K-allocatestructureblock| 2)
(define-instruction-exception unify |opcode$K-unify| 2)
(define-instruction-exception logic-tail-test |opcode$K-logictailtest| 1)
(define-instruction-exception push-address-sp-relative |opcode$K-pushaddresssprelative| 1)
(define-instruction-exception stack-blt |opcode$K-stackblt| 2)
(define-instruction-exception stack-blt-address |opcode$K-stackbltaddress| 2)
(define-instruction-exception char-ldb |opcode$K-charldb| 1 :stack)
(define-instruction-exception char-dpb |opcode$K-chardpb| 2 :stack)
(define-instruction-exception bind-locative-to-value |opcode$K-bindlocativetovalue| 2)
(define-instruction-exception bind-locative |opcode$K-bindlocative| 1)
(define-instruction-exception restore-binding-stack |opcode$K-restorebindingstack| 1)
(define-instruction-exception push-lexical-var |opcode$K-pushlexicalvar| 1)
(define-instruction-exception pop-lexical-var |opcode$K-poplexicalvar| 2)
(define-instruction-exception movem-lexical-var |opcode$K-movemlexicalvar| 2)
(define-instruction-exception instance-ref |opcode$K-instanceref| 2)
(define-instruction-exception instance-set |opcode$K-instanceset| 3)
(define-instruction-exception instance-loc |opcode$K-instanceloc| 2)
(define-instruction-exception push-instance-variable |opcode$K-pushinstancevariable| 1)
(define-instruction-exception pop-instance-variable |opcode$K-popinstancevariable| 2)
(define-instruction-exception movem-instance-variable |opcode$K-moveminstancevariable| 2)
(define-instruction-exception push-address-instance-variable |opcode$K-pushaddressinstancevariable| 1)
(define-instruction-exception block-0-read-test |opcode$K-block0readtest| 2 :stack)
(define-instruction-exception block-1-read-test |opcode$K-block1readtest| 2 :stack)
(define-instruction-exception block-2-read-test |opcode$K-block2readtest| 2 :stack)
(define-instruction-exception block-3-read-test |opcode$K-block3readtest| 2 :stack)
(define-instruction-exception alu |opcode$K-alu| 2)

;;; Macro to get the instruction exception information into args before
;;; jumping to the instruction exception routine. 'instruction' is the
;;; instruction name, popped is a number representing the number of stack
;;; pops that have occured when this exception was started.

;;; Macro to get the instruction exception information into args before
;;; jumping to the instruction exception routine. 'instruction' is the
;;; instruction name, popped is a number representing the number of stack
;;; pops that have occured when this exception was started.

(defmacro prepare-exception
	  (instruction popped
	   &optional operand tag
		     (fixed-arity nil arity-p) (fixed-arithmetic? nil arith-p))
  (declare (ignore operand popped))
  (let ((opcode (gethash instruction *ivory-instruction-opcode-table*))
	(tag-is-reg? (lisp:and tag (find-register tag))))
    (assert (not (null opcode)) (instruction)
	    "~S is not a known instruction" instruction)
    (multiple-value-bind (arity stack? arithmetic?)
        (instruction-exception-info opcode)
      `(,@(cond
	    (stack?
	     `(;; operand not needed
	       ,@(when tag
		   (if tag-is-reg?
		       `((mov arg6 ,tag "arg6 = tag to dispatch on"))
		       `((li arg6 ,tag "arg6 = tag to dispatch on"))))
	       (li arg3 1 "arg3 = stackp")))
	    (t
	     `(,@(when tag
		   (if tag-is-reg?
		       `((mov arg6 ,tag "arg6 = tag to dispatch on"))
		       `((li arg6 ,tag "arg6 = tag to dispatch on"))))
	       (clr arg3 "arg3 = stackp")
	       ;; If this is an address-format opcode, arg5 is the SCA
	       ;; and will be converted appropriately in the handler
	       )))
	,@(if arity-p
	      (assert (eq arity fixed-arity) () "You lied")
	      `((li arg1 ,arity "arg1 = instruction arity")))
	;; The Handler always loads the opcode (correctly) from iCP, so
	;; that multiple opcodes can share the same preparation
	,@(if arith-p
	      (assert (eq arithmetic? fixed-arithmetic?) () "You lied")
	      `((li arg4 ,(if arithmetic? 1 0) "arg4 = arithmeticp")))
	))))

(defmacro exception-handler (specialp tvi next-pc taillabel &optional fixed-arity)
  (check-temporaries (tvi next-pc) ('arg1 'arg2 'arg3 'arg5 't1 't2 't3 't4))
  (let ((l1 (gensym))
	(l2 (gensym))
	(l3 (gensym))
	(l4 (gensym))
	(l5 (gensym))
	(sk (gensym))
	(sk2 (gensym))
	(sk3 (gensym)))
    `((LD t2 PROCESSORSTATE_LINKAGE (Ivory))
      (LD iSP PROCESSORSTATE_RESTARTSP (ivory) "fix the stack pointer")
      (LD arg2 CACHELINE_INSTRUCTION (iCP) "fetch the real opcode")
      (branch-true t2 |NativeException|)
      ,@(when fixed-arity
	  `((load-constant arg1 ,fixed-arity)))
      ,@(unless (eq specialp :arithmetic)
	  ;; all arithmetic exceptions have an unstacked operand
	  `((branch-if-nonzero arg3 ,l2 "J. if arguments stacked")))
      ;; --- Should be a subroutine
      ;; Push unstacked argument
      (extrdi t1 arg2 16 16  "Get original operand")
      (XORI t3 t1 #o1000 "t3 is non-zero iff SP|POP operand")
      (branch-false t3 ,l2 "SP|POP operand recovered by restoring SP")
      (ADDI arg5 iFP 0 "Assume FP mode")
      (ADDI t3 iSP #.(* -255 8) "SP mode constant")
      (extrdi t4 arg2 8 16 "Get the mode bits")
      (extrdi t2 arg2 8 24 "Extract (8-bit, unsigned) operand")
      (ADDI t4 t4 -2 "t4 = -2 FP, -1 LP, 0 SP, 1 Imm")
      (ANDI-DOT R31 t4 1 "(CMOVLBS t4 iLP arg5)")
      (BC 12 2 ,sk3 "B.EQ")
      (mov arg5 iLP "LP or Immediate mode")
     (unlikely-label ,sk3)      
      (CMPI 0 1 t4 0)
      (BC 4 2 ,sk "B.NE")
      (mov arg5 t3 "SP mode")
     (unlikely-label ,sk)
      (sldi t3 t2 3)
      (ADD arg5 t3 arg5 "Compute operand address")
      (branch-if-less-than-or-equal-to-zero t4 ,l3 "Not immediate mode")
      (exts t1 t2 8)
      (srdi t3 arg2 #.(+ 6 10))
      (ADDI arg5 Ivory PROCESSORSTATE_IMMEDIATE_ARG "Immediate mode constant")
      (ANDI-DOT R31 t3 1 "(CMOVLBC t3 t1 t2)")
      (BC 4 2 ,sk2 "B.NE")
      (mov t2 t1 "Signed immediate")
     (unlikely-label ,sk2)      
      (STW t2 PROCESSORSTATE_IMMEDIATE_ARG+4 (Ivory))
      (label ,l3)
      (load-constant t1 #.(dpb -1 (byte 2 (+ 5 10)) 0))
      (AND t2 arg2 t1)
      (XOR t3 t1 t2)
      (branch-true t3 ,l4 "J. if not address-format operand")
      (SCAtoVMA arg5 t1 t2)
      (li t2 |TypeLocative|)
      (SetTag t2 t1 arg5)
      (B ,l5)
      (label ,l4)
      (LD arg5 0 (arg5) "Fetch the arg")
      (label ,l5)
      (stack-push-with-cdr arg5)
      (label ,l2)
      ,@(if (eq specialp :arithmetic)
	    `((srdi t4 arg2 17 "Get unary/nary bit of opcode")
	      (li arg1 1 "Assume unary")
	      ;(ADDI t4 arg1 -1)
	      (clr ,tvi)
	      (mov t2 iSP)
	      (ANDI-DOT R31 t4 1 "BLBC")
	      (BC 12 2 ,l1 "J. if not binary arithmetic dispatch")
	      (li arg1 2 "Nary -> Binary")
	      (stack-read-tag iSP ,tvi)
	      (ADDI t2 t2 -8)
	      (ANDI-DOT ,tvi ,tvi 7 "low three bits has opcode tag for op2")
	      (label ,l1)
	      (srdi arg2 arg2 #.(- 10 6) "Shift opcode into position")
	      (stack-read-tag t2 t2)
	      (ANDI-DOT arg2 arg2 #.(dpb -1 (byte 5 6) 0) "five bits from the opcode")
	      (ANDI-DOT t2 t2 7)
              (sldi t4 t2 3)
	      (ADD ,tvi t4 ,tvi)
	      (OR ,tvi arg2 ,tvi)
	      (ADDI ,tvi ,tvi |TrapVectorArithmeticInstructionException|)
	      (passthru "#ifdef TRAPMETERING")
	      (maybe-meter-trap |TrapVectorArithmeticInstructionException| t1 t2)
	      (passthru "#endif")
	      )
	    `((srdi arg2 arg2 10 "Shift opcode into position")
	      (ANDI-DOT arg2 arg2 #.(dpb -1 (byte 8 0) 0) "Just 8-bits of opcode")
	      (ADDI ,tvi arg2 |TrapVectorInstructionException|)
	      (passthru "#ifdef TRAPMETERING")
	      (maybe-meter-trap |TrapVectorInstructionException| t1 t2)
	      (passthru "#endif")
	      ))
      ,@(if (eq specialp :loop)
	    `((mov ,next-pc arg5))
	    `((LD ,next-pc CACHELINE_NEXTPCDATA (iCP))))
      (B ,taillabel))))

(defmacro exception-handler-common-tail (tvi arity next-pc)
  (check-temporaries (tvi arity next-pc) ('t1 't2 't3 't4 't5 't6 't7 't8 't9 't10))
  `((take-post-trap ,tvi ,arity t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 ,next-pc)))

;;; Fin.