Commit 88bb139e authored by nyef's avatar nyef
Browse files

Initial import of perry sources.

parents
;;;
;;; alcor-2.lisp
;;;
;;; DEC Alcor 2 (21172) chipset emulation.
;;;
(cl:in-package :alcor-2)
;;; Memory map
;;;
;;; 00.0000.0000 - 01.ffff.ffff : RAM space, cached.
;;; 02.0000.0000 - 7f.ffff.ffff : Reserved space, cached.
;;; 80.0000.0000 - 85.7fff.ffff : PCI sparce memory spaces, uncached.
;;; 85.8000.0000 - 85.ffff.ffff : PCI sparce I/O spaces, uncached.
;;; 86.0000.0000 - 86.ffff.ffff : PCI dense memory space, uncached.
;;; 87.0000.0000 - 87.ffff.ffff : PCI config space, CSRs, FlashROM, uncached.
;;; 88.0000.0000 - 8b.ffff.ffff : PCI byte/word space, uncached.
;;;
;;; Addresses 8c.0000.0000 and higher are unmapped. (not generated by CPU?)
;;;; Memory access.
(defvar *memory-image*)
(defun init-memory-system ()
;; Minimum memory size is 32 megs (8 megs/DIMM) in bank 0 (of two banks).
;; Per as800 service guide, 6.2.2, page 111.
;; To make instruction fetch cheaper, memory is stored as an array
;; of (unsigned-byte 32) values. (ash (ash 32 20) -2) => #x800000.
(setf *memory-image* (make-array #x800000
:element-type '(unsigned-byte 32)
:initial-element 0))
(values))
(defun memory-read-long (address)
(let ((index (ash address -2)))
(cond ((< index (length *memory-image*))
(aref *memory-image* index))
(t
(error "Memory read long, address #x~X, unmapped" address)))))
(defun memory-write-long (address value)
(let ((index (ash address -2)))
(if (< index (length *memory-image*))
(setf (aref *memory-image* index) value)
(format t "Memory write long, #x~8,'0X to #x~X unmapped, ignoring~%"
value address))))
;;;; Control and Status Registers.
(defconstant +csr-cia-ctrl-writable-bit-mask+ #xb33fffff)
(defconstant +csr-cia-ctrl-initial-value+ #x80000000)
(defvar *csr-cia-ctrl* +csr-cia-ctrl-initial-value+)
(defconstant +csr-cfg-writable-bit-mask+ #x00000003)
(defconstant +csr-cfg-initial-value+ #x00000000)
(defvar *csr-cfg* +csr-cfg-initial-value+)
(defun read-csr (address)
(case address
(#x00000100 ;; CIA_CTRL
*csr-cia-ctrl*)
(#x00000480 ;; CFG
*csr-cfg*)
(t (error "Alcor-2 CSR read #x~8,'0X, unknown" address))))
(defun write-csr (address value)
(case address
(#x00000100 ;; CIA_CTRL
(setf *csr-cia-ctrl* (logand +csr-cia-ctrl-writable-bit-mask+ value)))
(#x00000480 ;; CFG
(setf *csr-cfg* (logand +csr-cfg-writable-bit-mask+ value)))
(t (error "Alcor-2 CSR write #x~8,'0X to #x~8,'0X, unknown"
value address))))
;;;; PCI configuration.
(defun read-pci-config (address)
(declare (ignore address)))
(defun write-pci-config (address value)
(case *csr-cfg*
(0 ;; Type 0 configuration cycle.
(format t "PCI config type 0, IDSEL #x~X function #x~X, reg #x~X~%"
(ldb (byte 5 16) address)
(ldb (byte 3 13) address)
(ash (ldb (byte 6 7) address) 2))
(format t " data #x~8,'0X size ~D offset ~D~%"
value (ldb (byte 2 3) address) (ldb (byte 2 5) address)))
(1 ;; Type 1 configuration cycle.
(error "Alcor-2 PCI config write cycle type 1 unimplemented"))
(t ;; Bogus configuration cycle.
(error "Alcor-2 PCI config write bogus cycle type ~D" *csr-cfg*))))
;;;; PCI Sparse I/O.
(defun read-pci-sparse-io (address)
(let ((size (elt '(:byte :word :tribyte :longword)
(ldb (byte 2 3) address)))
(port-address (ldb (byte 25 5) address)))
(cond
((and (eq size :byte)
(= port-address #x71))
;; "CMOS" RTC data.
0)
((and (eq size :byte)
(= (logandc2 port-address #x100) #x2fd))
;; COM port status?
#x6000)
(t (error "PCI Sparse I/O ~A read from port #x~6,'0X unsupported"
size port-address)))))
(defun write-pci-sparse-io (address value)
(let* ((size-bits (ldb (byte 2 3) address))
(size (elt '(:byte :word :tribyte :longword) size-bits))
(port-address (ldb (byte 25 5) address)))
(format t "Alcor-2: PCI Sparse I/O ~A write #x~v,'0X to port #x~6,'0X~%"
size
(* 2 (1+ size-bits))
(ldb (byte (* 8 (1+ size-bits)) (* 8 (logand 3 port-address)))
value)
port-address)))
;;;; CPU interface.
(defun cpu-read-long (address)
;; 8740000100.
(cond
((< address #x0200000000)
(memory-read-long address))
((<= #x8580000000 address #x85ffffffff)
(read-pci-sparse-io (ldb (byte 31 0) address)))
((< #x86ffffffff address #x8720000000)
(read-pci-config (ldb (byte 21 0) address)))
#+(or)
((<= #x8720000000 address #x873fffffff)
;; PCI interrupt acknowledge, returns "vector data".
)
((< #x873fffffff address #x8780000000)
(read-csr (ldb (byte 30 0) address)))
(t
(error "Cpu read long from #x~x, unmapped" address))))
(defun cpu-read-quad (address)
(dpb (cpu-read-long (+ address 4))
(byte 32 32)
(cpu-read-long address)))
(defun cpu-write-long (address value)
(cond
((< address #x0200000000)
(memory-write-long address value))
((<= #x8580000000 address #x85ffffffff)
(write-pci-sparse-io (ldb (byte 31 0) address) value))
((< #x86ffffffff address #x8720000000)
(write-pci-config (ldb (byte 21 0) address) value))
((< #x873fffffff address #x8780000000)
(write-csr (ldb (byte 30 0) address) value))
(t
(error "Cpu write long to #x~x, unmapped" address))))
(defun cpu-write-quad (address value)
(cpu-write-long address (ldb (byte 32 0) value))
(cpu-write-long (+ address 4) (ldb (byte 32 32) value)))
;;;; Initialization.
(defun init-alcor-2 ()
(init-memory-system))
;;; EOF
This diff is collapsed.
;;;
;;; disassembler.lisp
;;;
;;; Alpha AXP disassembler.
;;;
(cl:in-package :perry)
;;;; Instruction fields.
;;; We use define-symbol-macro for the byte specifiers in order to
;;; have them be effectively constant when compiling code that uses
;;; them without having syntactic silliness like #. or using a
;;; macrolet. This also means that we can use them in this file
;;; without an eval-when.
;; Alpha instructions are all 32 bits wide. There are five basic
;; instruction formats, all of which have a six-bit opcode field in
;; (byte 6 26).
;;
;; 1.: Memory instructions.
;;
;; (byte 6 26): opcode.
;; (byte 5 21): Ra.
;; (byte 5 16): Rb.
;;
;; (byte 16 0): Memory_disp (sign extended).
;; -or-
;; (byte 16 0): Function code (unknown use).
;; -or-
;; (byte 16 0): Branch prediction hints (unknown use).
(define-symbol-macro %%instruction-opcode (byte 6 26))
(define-symbol-macro %%instruction-ra (byte 5 21))
(define-symbol-macro %%instruction-rb (byte 5 16))
(define-symbol-macro %%instruction-memory-disp (byte 16 0))
(define-symbol-macro %%instruction-memory-function (byte 16 0))
(define-symbol-macro %%instruction-branch-hints (byte 16 0))
;; 2.: Branch instructions.
;;
;; (byte 6 26): opcode.
;; (byte 5 21): Ra.
;; (byte 21 0): Branch_disp (sign extended, longword offset).
(define-symbol-macro %%instruction-branch-disp (byte 21 0))
;; 3.: Operate instructions.
;;
;; (byte 6 26): opcode.
;; (byte 5 21): Ra.
;;
;; (byte 5 16): Rb.
;; (byte 3 13): SBZ.
;; (byte 1 12): 1
;; -or-
;; (byte 8 13): Literal (zero extended).
;; (byte 1 12): 0
;;
;; (byte 7 5): Function.
;; (byte 5 0): Rc.
(defconstant %%instruction-operate-register-flag-bit 12)
(define-symbol-macro %%instruction-opreate-literal (byte 8 13))
(define-symbol-macro %%instruction-opreate-function (byte 7 5))
(define-symbol-macro %%instruction-rc (byte 5 0))
;; 4.: Floating-Point Operate instructions.
;;
;; (byte 6 26): opcode.
;; (byte 5 21): Fa.
;; (byte 5 16): Fb.
;; (byte 11 5): Function.
;; (byte 5 0): Fc.
(define-symbol-macro %%instruction-fp-operate-function (byte 11 5))
;; 5.: PALcode instructions.
;;
;; (byte 6 26): opcode.
;; (byte 26 0): PALcode Function.
(define-symbol-macro %%instruction-palcode-function (byte 26 0))
(defparameter *operand-column* 12)
(defvar *inta-instructions* nil)
(defvar *intl-instructions* nil)
(defvar *ints-instructions* nil)
(defvar *intm-instructions* nil)
(defun disassemble-unknown-opcode (instruction)
(format t "<unknown>~vT~(~8,'0X~)" *operand-column* instruction))
(defvar *instruction-decode-table* (make-array 64 :initial-element #'disassemble-unknown-opcode))
(defmacro define-opcode (name (opcode &rest args) &body body)
(let ((fname (intern (format nil "DISASSEMBLE-~A-OPCODE" name))))
`(progn
(defun ,fname ,args ,@body)
(setf (aref *instruction-decode-table* ,opcode) #',fname))))
(defun disassemble-instruction (instruction)
(funcall (aref *instruction-decode-table*
(ldb (byte 6 26) instruction))
instruction))
(defmacro define-unknown-opcode (name opcode)
`(define-opcode ,name (,opcode instruction)
(format t ,(format nil "~A~~vT~~(~~8,'0X~~)" name)
*operand-column* instruction)))
(defmacro define-memory-opcode (name opcode &optional floaty)
`(define-opcode ,name (,opcode instruction)
(format t ,(format nil "~A~~vT~C~~D,#x~~(~~X~~)(R~~D)"
name (if floaty #\F #\R))
*operand-column*
(ldb (byte 5 21) instruction)
(sign-extend (ldb (byte 16 0) instruction) 16)
(ldb (byte 5 16) instruction))))
(defmacro define-integer-operate-opcode (name opcode)
`(define-opcode ,name (,opcode instruction)
(let ((function (getf ,(intern (format nil "*~A-INSTRUCTIONS*" name))
(ldb (byte 7 5) instruction))))
(if (and function
(or (logbitp 12 instruction)
(zerop (ldb (byte 3 13) instruction))))
(format t "~A~vTR~D,~A,R~D"
(car function)
*operand-column*
(ldb (byte 5 21) instruction)
(if (logbitp 12 instruction)
(format nil "~D" (ldb (byte 8 13) instruction))
(format nil "R~D" (ldb (byte 5 16) instruction)))
(ldb (byte 5 0) instruction))
(disassemble-unknown-opcode instruction)))))
;;(defmacro define-floating-operate-opcode (name opcode))
(defmacro define-branch-opcode (name opcode &optional floaty)
`(define-opcode ,name (,opcode instruction)
(format t ,(format nil "~A~~vT~C~~D,~~@D"
name (if floaty #\F #\R))
*operand-column*
(ldb (byte 5 21) instruction)
(sign-extend (ldb (byte 21 0) instruction) 21))))
(defmacro define-operate-opcode-function (opcode function name)
`(setf (getf ,(intern (format nil "*~A-INSTRUCTIONS*" opcode)) ,function)
'(,name)))
(define-opcode call-pal (#x00 instruction)
;; FIXME: Look up PALcode function names.
(format t "CALL_PAL~vT~(~7,'0X~)" *operand-column*
(ldb (byte 26 0) instruction)))
(define-unknown-opcode opc01 #x01)
(define-unknown-opcode opc02 #x02)
(define-unknown-opcode opc03 #x03)
(define-unknown-opcode opc04 #x04)
(define-unknown-opcode opc05 #x05)
(define-unknown-opcode opc06 #x06)
(define-unknown-opcode opc07 #x07)
(define-memory-opcode lda #x08)
(define-memory-opcode ldah #x09)
(define-memory-opcode ldbu #x0a)
(define-memory-opcode ldq_u #x0b)
(define-memory-opcode ldwu #x0c)
(define-memory-opcode stw #x0d)
(define-memory-opcode stb #x0e)
(define-memory-opcode stq_u #x0f)
(define-integer-operate-opcode inta #x10)
(define-integer-operate-opcode intl #x11)
(define-integer-operate-opcode ints #x12)
(define-integer-operate-opcode intm #x13)
;;(define-dispatch-opcode itfp #x14 t)
;;(define-dispatch-opcode fltv #x15 t)
;;(define-dispatch-opcode flti #x16 t)
;;(define-dispatch-opcode fltl #x17 t)
(define-opcode misc (#x18 instruction)
(let ((function (ldb (byte 16 0) instruction)))
(case function
(#x0000
(format t "TRAPB"))
(#x0400
(format t "EXCB"))
(#x4000
(format t "MB"))
(#x4400
(format t "WMB"))
(#x8000
(format t "FETCH~vT(R~D)" *operand-column*
(ldb (byte 5 16) instruction)))
(#xa000
(format t "FETCH_M~vT(R~D)" *operand-column*
(ldb (byte 5 16) instruction)))
(#xc000
(format t "RPCC~vTR~D,R~D" *operand-column*
(ldb (byte 5 21) instruction)
(ldb (byte 5 16) instruction)))
(#xe000
(format t "RC~vT(R~D)" *operand-column*
(ldb (byte 5 21) instruction)))
(#xe800
(format t "ECB~vT(R~D)" *operand-column*
(ldb (byte 5 16) instruction)))
(#xf000
(format t "RS~vT(R~D)" *operand-column*
(ldb (byte 5 21) instruction)))
(#xf800
(format t "WH64~vT(R~D)" *operand-column*
(ldb (byte 5 16) instruction)))
(#xfc00
(format t "WH64EN~vT(R~D)" *operand-column*
(ldb (byte 5 16) instruction)))
(t (format t "unknown misc function ~4,'0X R~D, R~D"
function (ldb (byte 5 21) instruction)
(ldb (byte 5 16) instruction))))))
;;(define-unknown-opcode pal19 #x19)
(define-opcode jmp (#x1a instruction)
(let ((sub-op (ldb (byte 2 14) instruction))
(hint (ldb (byte 14 0) instruction)))
(format t "~A~vTR~D,(R~D),#x~X"
(elt '(jmp jsr ret jsr_coroutine) sub-op)
*operand-column*
(ldb (byte 5 21) instruction)
(ldb (byte 5 16) instruction)
hint)))
;;(define-unknown-opcode pal1b #x1b)
;;(define-dispatch-opcode fpti #x1c t)
;;(define-unknown-opcode pal1d #x1d)
;;(define-unknown-opcode pal1e #x1e)
;;(define-unknown-opcode pal1f #x1f)
(define-memory-opcode ldf #x20 t)
(define-memory-opcode ldg #x21 t)
(define-memory-opcode lds #x22 t)
(define-memory-opcode ldt #x23 t)
(define-memory-opcode stf #x24 t)
(define-memory-opcode stg #x25 t)
(define-memory-opcode sts #x26 t)
(define-memory-opcode stt #x27 t)
(define-memory-opcode ldl #x28)
(define-memory-opcode ldq #x29)
(define-memory-opcode ldl_l #x2a)
(define-memory-opcode ldq_l #x2b)
(define-memory-opcode stl #x2c)
(define-memory-opcode stq #x2d)
(define-memory-opcode stl_c #x2e)
(define-memory-opcode stq_c #x2f)
(define-branch-opcode br #x30)
(define-branch-opcode fbeq #x31 t)
(define-branch-opcode fblt #x32 t)
(define-branch-opcode fble #x33 t)
(define-branch-opcode bsr #x34)
(define-branch-opcode fbne #x35 t)
(define-branch-opcode fbge #x36 t)
(define-branch-opcode fbgt #x37 t)
(define-branch-opcode blbc #x38)
(define-branch-opcode beq #x39)
(define-branch-opcode blt #x3a)
(define-branch-opcode ble #x3b)
(define-branch-opcode blbs #x3c)
(define-branch-opcode bne #x3d)
(define-branch-opcode bge #x3e)
(define-branch-opcode bgt #x3f)
(define-operate-opcode-function inta #x00 addl)
(define-operate-opcode-function inta #x02 s4addl)
(define-operate-opcode-function inta #x09 subl)
(define-operate-opcode-function inta #x0b s4subl)
(define-operate-opcode-function inta #x0f cmpbge)
(define-operate-opcode-function inta #x12 s8addl)
(define-operate-opcode-function inta #x1b s8subl)
(define-operate-opcode-function inta #x1d cmpult)
(define-operate-opcode-function inta #x20 addq)
(define-operate-opcode-function inta #x22 s4addq)
(define-operate-opcode-function inta #x29 subq)
(define-operate-opcode-function inta #x2b s4subq)
(define-operate-opcode-function inta #x2d cmpeq)
(define-operate-opcode-function inta #x32 s8addq)
(define-operate-opcode-function inta #x3b s8subq)
(define-operate-opcode-function inta #x3d cmpule)
(define-operate-opcode-function inta #x40 addl/v)
(define-operate-opcode-function inta #x49 subl/v)
(define-operate-opcode-function inta #x4d cmplt)
(define-operate-opcode-function inta #x60 addq/v)
(define-operate-opcode-function inta #x69 subq/v)
(define-operate-opcode-function inta #x6d cmple)
(define-operate-opcode-function intl #x00 and)
(define-operate-opcode-function intl #x08 bic)
(define-operate-opcode-function intl #x14 cmovlbs)
(define-operate-opcode-function intl #x16 cmovlbc)
(define-operate-opcode-function intl #x20 bis)
(define-operate-opcode-function intl #x24 cmoveq)
(define-operate-opcode-function intl #x26 cmovne)
(define-operate-opcode-function intl #x28 ornot)
(define-operate-opcode-function intl #x40 xor)
(define-operate-opcode-function intl #x44 cmovlt)
(define-operate-opcode-function intl #x46 cmovge)
(define-operate-opcode-function intl #x48 eqv)
(define-operate-opcode-function intl #x61 amask) ;; Ra must be R31
(define-operate-opcode-function intl #x64 cmovle)
(define-operate-opcode-function intl #x66 cmovgt)
(define-operate-opcode-function intl #x6c implver) ;; Ra must be R31, Rb must be literal #1
(define-operate-opcode-function ints #x02 mskbl)
(define-operate-opcode-function ints #x06 extbl)
(define-operate-opcode-function ints #x0b insbl)
(define-operate-opcode-function ints #x12 mskwl)
(define-operate-opcode-function ints #x16 extwl)
(define-operate-opcode-function ints #x1b inswl)
(define-operate-opcode-function ints #x22 mskll)
(define-operate-opcode-function ints #x26 extll)
(define-operate-opcode-function ints #x2b insll)
(define-operate-opcode-function ints #x30 zap)
(define-operate-opcode-function ints #x31 zapnot)
(define-operate-opcode-function ints #x32 mskql)
(define-operate-opcode-function ints #x34 srl)
(define-operate-opcode-function ints #x36 extql)
(define-operate-opcode-function ints #x39 sll)
(define-operate-opcode-function ints #x3b insql)
(define-operate-opcode-function ints #x3c sra)
(define-operate-opcode-function ints #x52 mskwh)
(define-operate-opcode-function ints #x57 inswh)
(define-operate-opcode-function ints #x5a extwh)
(define-operate-opcode-function ints #x62 msklh)
(define-operate-opcode-function ints #x67 inslh)
(define-operate-opcode-function ints #x6a extlh)
(define-operate-opcode-function ints #x72 mskqh)
(define-operate-opcode-function ints #x77 insqh)
(define-operate-opcode-function ints #x7a extqh)
(define-operate-opcode-function intm #x00 mull)
(define-operate-opcode-function intm #x20 mulq)
(define-operate-opcode-function intm #x30 umulh)
(define-operate-opcode-function intm #x40 mull/v)
(define-operate-opcode-function intm #x60 mulq/v)
(defun disassemble-file-range (file offset length)
(let ((buffer (make-array (* length 4) :element-type '(unsigned-byte 8)))
(*operand-column* (+ *operand-column* 10)))
(with-open-file (foo file :element-type '(unsigned-byte 8))
(file-position foo offset)
(read-sequence buffer foo))
(dotimes (i length)
(format t "~8,'0X: " (+ offset (* i 4)))
(let ((instruction (logior (ash (aref buffer (+ (* i 4) 3)) 24)
(ash (aref buffer (+ (* i 4) 2)) 16)
(ash (aref buffer (+ (* i 4) 1)) 8)
(ash (aref buffer (+ (* i 4) 0)) 0))))
(disassemble-instruction instruction)
(terpri)))))
;;; 21164-specific PAL instructions.
(defparameter *ipr-names*
'(
;; Ibox IPRs
#x100 isr
#x101 itb_tag
#x102 itb_pte
#x103 itb_asn
#x104 itb_pte_temp
#x105 itb_ia
#x106 itb_iap
#x107 itb_is
#x108 sirr
#x109 astrr
#x10a aster
#x10b exc_addr
#x10c exc_sum
#x10d exc_mask
#x10e pal_base
#x10f icm
#x110 iplr
#x111 intid
#x112 ifault_va_form
#x113 ivptbr
#x115 hwint_clr
#x116 sl_xmit
#x117 sl_rcv
#x118 icsr
#x119 ic_flush_ctl
#x11a icperr_stat
#x11c pmctr
;; PALtemp IPRs
#x140 |PALtemp0|
#x141 |PALtemp1|
#x142 |PALtemp2|
#x143 |PALtemp3|
#x144 |PALtemp4|
#x145 |PALtemp5|
#x146 |PALtemp6|
#x147 |PALtemp7|
#x148 |PALtemp8|
#x149 |PALtemp9|
#x14a |PALtemp10|
#x14b |PALtemp11|
#x14c |PALtemp12|
#x14d |PALtemp13|
#x14e |PALtemp14|
#x14f |PALtemp15|
#x150 |PALtemp16|
#x151 |PALtemp17|
#x152 |PALtemp18|
#x153 |PALtemp19|
#x154 |PALtemp20|
#x155 |PALtemp21|
#x156 |PALtemp22|
#x157 |PALtemp23|
;; Mbox IPRs
#x200 dtb_asn
#x201 dtb_cm
#x202 dtb_tag
#x203 dtb_pte
#x204 dtb_pte_temp
#x205 mm_stat
#x206 va
#x207 va_form
#x208 mvptbr
#x209 dtb_iap
#x20a dtb_ia
#x20b dtb_is