--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/dassm3.scm,v 1.1 1990/01/25 16:33:14 jinx Exp $
+
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;; Spectrum Disassembler: Internals
+
+(declare (usual-integrations))
+\f
+;;;; Utilities
+
+(define (get-longword)
+ (let ((word (read-bits *current-offset 32)))
+ (set! *current-offset (+ *current-offset 4))
+ word))
+
+(declare (integrate-operator extract))
+
+(define (extract bit-string start end)
+ (declare (integrate bit-string start end))
+ (bit-string->unsigned-integer (bit-substring bit-string start end)))
+
+#|
+(define disassembly '())
+
+(define (verify-instruction instruction)
+ (let ((bits (car (syntax-instruction instruction))))
+ (if (and (bit-string? bits)
+ (= (bit-string-length bits) 32))
+ (begin (set! disassembly (disassemble-word bits))
+ (newline)
+ (newline)
+ (if (equal? instruction disassembly)
+ (write "EQUAL")
+ (write "************************* NOT EQUAL"))
+ (newline)
+ (newline)
+ (write instruction)
+ (newline)
+ (newline)
+ (write "Disassembly: ")
+ (write disassembly)))))
+
+(define v verify-instruction)
+|#
+
+(define-integrable Mask-2-9 #b0011111111000000)
+(define-integrable Mask-2-16 #b0011111111111111)
+(define-integrable Mask-3-14 #b0001111111111100)
+(define-integrable Mask-3-10 #b0001111111100000)
+(define-integrable Mask-3-5 #b0001110000000000)
+(define-integrable Mask-4-10 #b0000111111100000)
+(define-integrable Mask-4-5 #b0000110000000000)
+(define-integrable Mask-6-9 #b0000001111000000)
+(define-integrable Mask-6-10 #b0000001111100000)
+(define-integrable Mask-11-15 #b0000000000011111)
+(define-integrable mask-copr #b0000000111000000)
+
+(define (land x y)
+ (bit-string->unsigned-integer
+ (bit-string-and (signed-integer->bit-string 32 x)
+ (signed-integer->bit-string 32 y))))
+\f
+;;;; The disassembler proper
+
+(define (disassemble-word word)
+ (let ((hi-halfword (extract word 16 32))
+ (lo-halfword (extract word 0 16)))
+ (let ((opcode (quotient hi-halfword #x400)))
+ ((case opcode
+ ((#x00) sysctl-1)
+ ((#x01) sysctl-2)
+ ((#x02) arith&log)
+ ((#x03) indexed-mem)
+ ((#x04) #| SFUop |# unknown-major-opcode)
+ ((#x05)
+ (lambda (opcode hi lo)
+ opcode hi lo ;ignore
+ `(DIAG () ,(extract word 0 26))))
+ ((#x08 #x0a) ldil&addil)
+ ((#x09 #x0b) #| COPR-w and COPR-dw |# float-mem)
+ ((#x0c) #| COPRop |# float-op)
+ ((#x0d #x10 #x11 #x12 #x13) scalar-load)
+ ((#x18 #x19 #x1a #x1b) scalar-store)
+ ((#x20 #x21 #x22 #x23 #x28 #x29 #x2a #x2b #x30 #x31 #x32 #x33)
+ cond-branch)
+ ((#x24 #x25 #x2c #x2d) addi&subi)
+ ((#x34 #x35) extr&dep)
+ ((#x38 #x39) be&ble)
+ ((#x3a) branch)
+ (else unknown-major-opcode))
+ opcode hi-halfword lo-halfword))))
+
+(define (unknown-major-opcode opcode hi lo)
+ opcode hi lo ;ignore
+ (invalid-instruction))
+\f
+(define (sysctl-1 opcode hi-halfword lo-halfword)
+ ;; BREAK SYNC MFSP MFCTL MTSP MTCTL LDSID
+ ;; Missing other system control:
+ ;; MTSM, RSM, SSM, RFI.
+ opcode ;ignore
+ (let ((opcode-extn (quotient (land lo-halfword Mask-3-10) #x20)))
+ (case opcode-extn
+ ((#x00)
+ (let ((immed-13-hi (land hi-halfword 1023))
+ (immed-13-lo (quotient lo-halfword #x2000))
+ (immed-5 (land lo-halfword #x1f)))
+ `(BREAK () ,immed-5 ,(+ (* immed-13-hi #x100) immed-13-lo))))
+ ((#x20)
+ `(SYNC ()))
+ ((#x25)
+ (let ((target-reg (land hi-halfword #x1f))
+ (space-reg (quotient lo-halfword #x2000)))
+ `(MFSP () ,space-reg ,target-reg)))
+ ((#x45)
+ (let ((ctl-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (target-reg (land lo-halfword #x1f)))
+ `(MFCTL () ,ctl-reg ,target-reg)))
+ ((#xc1)
+ (let ((source-reg hi-halfword)
+ (space-reg (quotient lo-halfword #x2000)))
+ `(MTSP () ,source-reg ,space-reg)))
+ ((#xc2)
+ (let ((ctl-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (source-reg (land hi-halfword #x1f)))
+ `(MTCTL () ,source-reg ,ctl-reg)))
+ ((#x85)
+ (let ((base-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (space-spec (quotient lo-halfword #x4000))
+ (target-reg (land lo-halfword #x1f)))
+ `(LDSID () (OFFSET ,space-spec ,base-reg)
+ ,target-reg)))
+ (else
+ (invalid-instruction)))))
+\f
+(define (sysctl-2 opcode hi-halfword lo-halfword)
+ ;; PROBER PROBERI PROBEW PROBEWI
+ ;; Missing other system control:
+ ;; LPA, LHA, PDTLB, PITLB, PDTLBE, PITLBE, IDTLBA, IITLBA,
+ ;; IDTLBP, IITLBP, PDC, FDC, FIC, FDCE, FICE.
+ opcode ;ignore
+ (let ((opcode-extn (quotient (land lo-halfword Mask-2-9) #x40)))
+ (let ((mnemonic (case opcode-extn
+ ((#x46) 'PROBER)
+ ((#xc6) 'PROBERI)
+ ((#x47) 'PROBEW)
+ ((#xc7) 'PROBEWI)
+ (else (invalid-instruction))))
+ (base-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (priv-reg (land hi-halfword #x1f))
+ (space-spec (quotient lo-halfword #x4000))
+ (target-reg (land lo-halfword #x1f)))
+ `(,mnemonic () (OFFSET ,space-spec ,base-reg)
+ ,priv-reg ,target-reg))))
+\f
+(define (arith&log opcode hi-halfword lo-halfword)
+ opcode ;ignore
+ (let ((opcode-extn (quotient (land Mask-4-10 lo-halfword) #x20)))
+ (let ((source-reg-2 (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (source-reg-1 (land hi-halfword #x1f))
+ (target-reg (land lo-halfword #x1f))
+ (completer (x-arith-log-completer lo-halfword opcode-extn))
+ (mnemonic
+ (case opcode-extn
+ ((#x00) 'ANDCM)
+ ((#x10) 'AND)
+ ((#x12) 'OR)
+ ((#x14) 'XOR)
+ ((#x1c) 'UXOR)
+ ((#x20) 'SUB)
+ ((#x22) 'DS)
+ ((#x26) 'SUBT)
+ ((#x28) 'SUBB)
+ ((#x30) 'ADD)
+ ((#x32) 'SH1ADD)
+ ((#x34) 'SH2ADD)
+ ((#x36) 'SH3ADD)
+ ((#x38) 'ADDC)
+ ((#x44) 'COMCLR)
+ ((#x4c) 'UADDCM)
+ ((#x4e) 'UADDCMT)
+ ((#x50) 'ADDL)
+ ((#x52) 'SH1ADDL)
+ ((#x54) 'SH2ADDL)
+ ((#x56) 'SH3ADDL)
+ ((#x5c) 'DCOR)
+ ((#x5e) 'IDCOR)
+ ((#x60) 'SUBO)
+ ((#x66) 'SUBTO)
+ ((#x68) 'SUBBO)
+ ((#x70) 'ADDO)
+ ((#x72) 'SH1ADDO)
+ ((#x74) 'SH2ADDO)
+ ((#x76) 'SH3ADDO)
+ ((#x78) 'ADDCO)
+ (else (invalid-instruction)))))
+ (cond ((or (eq? mnemonic 'DCOR) (eq? mnemonic 'IDCOR))
+ `(,mnemonic ,completer ,source-reg-2 ,target-reg))
+ ((and (eq? mnemonic 'OR) (zero? source-reg-2))
+ (if (and (zero? source-reg-1) (zero? target-reg))
+ `(NOP ,completer)
+ `(COPY ,completer ,source-reg-1 ,target-reg)))
+ (else
+ `(,mnemonic ,completer ,source-reg-1 ,source-reg-2
+ ,target-reg))))))
+\f
+(define (indexed-mem opcode hi-halfword lo-halfword)
+ ;; LDBX/S LDHX/S LDWX/S LDCWX/S STWS STHS STBS STBYS
+ opcode ;ignore
+ (let ((short-flag (land lo-halfword #x1000)))
+ (let ((base-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (index-or-source (land hi-halfword #x1f))
+ (space-spec (quotient lo-halfword #x4000))
+ (opcode-extn (quotient (land lo-halfword Mask-6-9) #x40))
+ (target-or-index (land lo-halfword #x1f))
+ (cc-print-completer (cc-completer lo-halfword))
+ (um-print-completer (um-completer short-flag lo-halfword)))
+ (let ((mnemonic
+ (if (zero? short-flag)
+ (case opcode-extn
+ ((#x0) 'LDBX)
+ ((#x1) 'LDHX)
+ ((#x2) 'LDWX)
+ ((#x7) 'LDCWX)
+ (else (invalid-instruction)))
+ (case opcode-extn
+ ((#x0) 'LDBS)
+ ((#x1) 'LDHS)
+ ((#x2) 'LDWS)
+ ((#x7) 'LDCWS)
+ ((#x8) 'STBS)
+ ((#x9) 'STHS)
+ ((#xa) 'STWS)
+ ((#xc) 'STBYS)
+ (else (invalid-instruction))))))
+ (if (< opcode-extn 8)
+ `(,mnemonic (,@um-print-completer ,@cc-print-completer)
+ (,(if (zero? short-flag) 'INDEX 'OFFSET)
+ ,(if (zero? short-flag)
+ index-or-source
+ (X-Signed-5-Bit index-or-source))
+ ,space-spec ,base-reg)
+ ,target-or-index)
+ `(,mnemonic (,@um-print-completer ,@cc-print-completer)
+ ,index-or-source
+ (,(if (zero? short-flag) 'INDEX 'OFFSET)
+ ,(if (zero? short-flag)
+ target-or-index
+ (X-Signed-5-Bit target-or-index))
+ ,space-spec ,base-reg)))))))
+\f
+(define (ldil&addil opcode hi-halfword lo-halfword)
+ ;; LDIL ADDIL
+ (let* ((reg (quotient (land Mask-6-10 hi-halfword) #x20))
+ (hi-immed (land hi-halfword #x1f))
+ (immed (assemble-21 (+ (* hi-immed #x10000) lo-halfword))))
+ `(,(if (= opcode #x08) 'LDIL 'ADDIL) () ,immed ,reg)))
+
+(define (float-mem opcode hi-halfword lo-halfword)
+ ;; FLDWX/S FLDDX/S FSTWX/S FSTDX/S
+ (let ((short-flag (land lo-halfword #x1000))
+ (index (land hi-halfword #x1f)))
+ (let ((base-reg (quotient (land Mask-6-10 hi-halfword) #x20))
+ (index (if (zero? short-flag)
+ index
+ (X-Signed-5-Bit index)))
+ (space-spec (quotient lo-halfword #x4000))
+ (opcode-extn (quotient (land lo-halfword Mask-6-9) #x40))
+ (source-or-target (land lo-halfword #x1f))
+ (cc-print-completer (cc-completer lo-halfword))
+ (um-print-completer (um-completer short-flag lo-halfword)))
+ (let ((mnemonic
+ (if (zero? short-flag)
+ (if (= opcode #x09)
+ (if (= opcode-extn 0) 'FLDWX 'FSTWX)
+ (if (= opcode-extn 0) 'FLDDX 'FSTDX))
+ (if (= opcode #x09)
+ (if (= opcode-extn 0) 'FLDWS 'FSTWS)
+ (if (= opcode-extn 0) 'FLDDS 'FSTDS)))))
+ (if (< opcode-extn 8)
+ `(,mnemonic (,@um-print-completer ,@cc-print-completer)
+ (,(if (zero? short-flag) 'INDEX 'OFFSET)
+ ,index ,space-spec ,base-reg)
+ ,source-or-target)
+ `(,mnemonic (,@um-print-completer ,@cc-print-completer)
+ ,source-or-target
+ (,(if (zero? short-flag) 'INDEX 'OFFSET)
+ ,index ,space-spec ,base-reg)))))))
+
+(define (scalar-load opcode hi-halfword lo-halfword)
+ ;; LDO LDB LDH LDW LDWM
+ (let ((base-reg (quotient (land Mask-6-10 hi-halfword) #x20))
+ (space-spec (quotient lo-halfword #x4000))
+ (target-reg (land hi-halfword #x1f))
+ (displacement (XRight2s (land lo-halfword Mask-2-16)))
+ (mnemonic
+ (case opcode
+ ((#x0d) 'LDO)
+ ((#x10) 'LDB)
+ ((#x11) 'LDH)
+ ((#x12) 'LDW)
+ ((#x13) 'LDWM)
+ (else (invalid-instruction)))))
+ (cond ((not (eq? mnemonic 'LDO))
+ `(,mnemonic ()
+ (OFFSET ,displacement ,space-spec ,base-reg)
+ ,target-reg))
+ ((zero? base-reg)
+ `(LDI () ,displacement ,target-reg))
+ (else
+ `(,mnemonic ()
+ (OFFSET ,displacement 0 ,base-reg)
+ ,target-reg)))))
+\f
+(define (scalar-store opcode hi-halfword lo-halfword)
+ ;; STB STH STW STWM
+ (let ((base-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (space-spec (quotient lo-halfword #x4000))
+ (source-reg (land hi-halfword #x1f))
+ (displacement (XRight2s (land lo-halfword Mask-2-16)))
+ (mnemonic
+ (case opcode
+ ((#x18) 'STB)
+ ((#x19) 'STH)
+ ((#x1a) 'STW)
+ ((#x1b) 'STWM)
+ (else (invalid-instruction)))))
+ `(,mnemonic () ,source-reg
+ (OFFSET ,displacement ,space-spec ,base-reg))))
+
+(define (cond-branch opcode hi-halfword lo-halfword)
+ ;; MOVB MOVIB COMB COMIB ADDB ADDIB BVB BB
+ (let* ((reg-2 (quotient (land Mask-6-10 hi-halfword) #x20))
+ (reg-1 (if (and (not (= opcode #x31))
+ (odd? opcode))
+ ;; For odd opcodes, this is immed-5 data, not reg-1
+ (X-Signed-5-Bit (land hi-halfword #x1f))
+ (land hi-halfword #x1f)))
+ (c (quotient lo-halfword #x2000))
+ (word-displacement (collect-14 lo-halfword))
+ (null-completer (nullify-bit lo-halfword))
+ (mnemonic (case opcode
+ ((#x20) 'COMBT)
+ ((#x21) 'COMIBT)
+ ((#x22) 'COMBF)
+ ((#x23) 'COMIBF)
+ ((#x28) 'ADDBT)
+ ((#x29) 'ADDIBT)
+ ((#x2a) 'ADDBF)
+ ((#x2b) 'ADDIBF)
+ ((#x30) 'BVB)
+ ((#x31) 'BB)
+ ((#x32) 'MOVB)
+ ((#x33) 'MOVIB)
+ (else (invalid-instruction))))
+ (completer-symbol
+ (X-Extract-Deposit-Completers c)))
+ (if (eq? mnemonic 'BVB)
+ `(,mnemonic (,@completer-symbol ,@null-completer) ,reg-1
+ ,word-displacement)
+ `(,mnemonic (,@completer-symbol ,@null-completer) ,reg-1 ,reg-2
+ ,word-displacement))))
+\f
+(define (addi&subi opcode hi-halfword lo-halfword)
+ ;; ADDI-T-O SUBI-O COMICLR
+ (let ((opcode-extn (quotient (land 2048 lo-halfword) #x800)))
+ (let ((source-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (target-reg (land hi-halfword #x1f))
+ (immed-value (X-Signed-11-Bit (land lo-halfword 2047)))
+ (completer-symbol (x-arith-log-completer lo-halfword opcode))
+ (mnemonic
+ (if (= opcode-extn 0)
+ (case opcode
+ ((#x24) 'COMICLR)
+ ((#x25) 'SUBI)
+ ((#x2c) 'ADDIT)
+ ((#x2d) 'ADDI)
+ (else (invalid-instruction)))
+ (case opcode
+ ((#x25) 'SUBIO)
+ ((#x2c) 'ADDITO)
+ ((#x2d) 'ADDIO)
+ (else (invalid-instruction))))))
+ `(,mnemonic ,completer-symbol ,immed-value
+ ,source-reg ,target-reg))))
+
+(define (extr&dep opcode hi-halfword lo-halfword)
+ ;; VEXTRU VEXTRS VDEP ZVDEP
+ (let* ((reg-2 (quotient (land Mask-6-10 hi-halfword) #x20))
+ (reg-1 (land hi-halfword #x1f))
+ (c (quotient lo-halfword #x2000))
+ (opcode-extn (quotient (land lo-halfword Mask-3-5) #x400))
+ (cp (quotient (land lo-halfword Mask-6-10) #x20))
+ (clen (land lo-halfword #x1f))
+ (completer-symbol (X-Extract-Deposit-Completers c))
+ (mnemonic
+ (vector-ref (if (= opcode #x34)
+ '#(VSHD *INVALID* SHD *INVALID*
+ VEXTRU VEXTRS EXTRU EXTRS)
+ '#(ZVDEP VDEP ZDEP DEP
+ ZVDEPI VDEPI ZDEPI DEPI))
+ opcode-extn)))
+
+ (define (process reg-1 reg-2)
+ (cond ((or (<= 4 opcode-extn 5)
+ (and (= opcode #x35)
+ (< opcode-extn 2)))
+ ;; Variable dep/ext
+ `(,mnemonic ,completer-symbol ,reg-1 ,(- 32 clen) ,reg-2))
+ ((eq? mnemonic 'VSHD)
+ `(,mnemonic ,completer-symbol ,reg-1 ,reg-2 ,clen))
+ ((eq? mnemonic 'SHD)
+ `(,mnemonic ,completer-symbol ,reg-1 ,reg-2 ,(- 31 cp) ,clen))
+ (else
+ `(,mnemonic ,completer-symbol
+ ,reg-1
+ ,(if (= opcode #x34) cp (- 31 cp))
+ ,(- 32 clen) ,
+ reg-2))))
+
+ (cond ((eq? mnemonic '*INVALID*)
+ (invalid-instruction))
+ ((<= opcode-extn 3)
+ (process reg-1 reg-2))
+ ((= opcode #x34)
+ (process reg-2 reg-1))
+ (else
+ (process (X-Signed-5-Bit reg-1) reg-2)))))
+\f
+(define (be&ble opcode hi-halfword lo-halfword)
+ ;; BE BLE
+ (let ((base-reg (quotient (land Mask-6-10 hi-halfword) #x20))
+ (space-reg (Assemble-3 (quotient lo-halfword #x2000)))
+ (null-completer (nullify-bit lo-halfword))
+ (word-displacement (collect-19 lo-halfword hi-halfword false))
+ (mnemonic (if (= opcode #x38) 'BE 'BLE)))
+ `(,mnemonic ,null-completer
+ (OFFSET ,word-displacement ,space-reg ,base-reg))))
+
+(define (branch opcode hi-halfword lo-halfword)
+ ;; B, BL, BLR, BV, GATE
+ opcode ;ignore
+ (let ((opcode-extension (quotient lo-halfword #x2000)))
+ (case opcode-extension
+ ((0 1)
+ ;; B BL GATE
+ (let ((return-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (word-displacement (collect-19 lo-halfword hi-halfword true))
+ (null-completer (nullify-bit lo-halfword)))
+ (let ((mnemonic (cond ((= opcode-extension 1) 'GATE)
+ ((= return-reg 0) 'B)
+ (else 'BL))))
+ (if (eq? mnemonic 'B)
+ `(,mnemonic ,null-completer ,word-displacement)
+ `(,mnemonic ,null-completer ,return-reg ,word-displacement)))))
+ ((2 6)
+ ;; BLR BV
+ (let ((return-reg (quotient (land Mask-6-10 hi-halfword)
+ #x20))
+ (offset-reg (land hi-halfword #x1f))
+ (null-completer (nullify-bit lo-halfword))
+ (mnemonic (if (= opcode-extension 2)
+ 'BLR
+ 'BV)))
+ `(,mnemonic ,null-completer ,offset-reg ,return-reg)))
+ (else (invalid-instruction)))))
+\f
+;;;; FLoating point operations
+
+(define (float-op opcode hi-halfword lo-halfword)
+ ;; Copr 0 is the floating point copr.
+ opcode ;ignore
+ (if (not (zero? (land (quotient lo-halfword #x40) 7)))
+ (invalid-instruction)
+ ((case (land (quotient lo-halfword #x200) 3)
+ ((0) float-op0)
+ ((1) float-op1)
+ ((2) float-op2)
+ ((3) float-op3))
+ hi-halfword lo-halfword)))
+
+(define (float-op0 hi-halfword lo-halfword)
+ (let ((mnemonic
+ (vector-ref '#(COPR *INVALID* FCPY FABS FSQRT FRND
+ *INVALID* *INVALID*)
+ (quotient lo-halfword #x2000)))
+ (fmt (floating-format (land (quotient lo-halfword #x800) 3)))
+ (r (land (quotient hi-halfword #x20) #x1f))
+ (t (land lo-halfword #x1f)))
+ (if (eq? mnemonic '*INVALID*)
+ (invalid-instruction)
+ `(,mnemonic (,fmt) ,r ,t))))
+
+(define (float-op1 hi-halfword lo-halfword)
+ (let ((mnemonic
+ (vector-ref '#(FCNVFF FCNVXF FCNVFX FCNVFXT)
+ (+ (* 2 (land hi-halfword 1))
+ (quotient lo-halfword #x8000))))
+ (sf (floating-format (land (quotient lo-halfword #x800) 3)))
+ (df (floating-format (land (quotient lo-halfword #x2000) 3)))
+ (r (land (quotient hi-halfword #x20) #x1f))
+ (t (land lo-halfword #x1f)))
+ `(,mnemonic (,sf ,df) ,r ,t)))
+
+(define (float-op2 hi-halfword lo-halfword)
+ (case (quotient lo-halfword #x2000)
+ ((0)
+ (let ((fmt (floating-format (land (quotient lo-halfword #x800) 3)))
+ (r1 (land (quotient hi-halfword #x20) #x1f))
+ (r2 (land hi-halfword #x1f))
+ (c (float-completer (land lo-halfword #x1f))))
+ `(FCMP (,c ,fmt) ,r1 ,r2)))
+ ((1)
+ `(FTEST))
+ (else
+ (invalid-instruction))))
+
+(define (float-op3 hi-halfword lo-halfword)
+ (let ((mnemonic
+ (vector-ref '#(FADD FSUB FMPY FDIV FREM *INVALID* *INVALID* *INVALID*)
+ (quotient lo-halfword #x2000)))
+ (fmt (floating-format (land (quotient lo-halfword #x800) 3)))
+ (r1 (land (quotient hi-halfword #x20) #x1f))
+ (r2 (land hi-halfword #x1f))
+ (t (land lo-halfword #x1f)))
+ (if (eq? mnemonic '*INVALID*)
+ (invalid-instruction)
+ `(,mnemonic (,fmt) ,r1 ,r2 ,t))))
+\f
+;;;; Field extraction
+
+(define (assemble-3 x)
+ (let ((split (integer-divide x 2)))
+ (+ (* (integer-divide-remainder split) 4)
+ (integer-divide-quotient split))))
+
+(define (assemble-12 x y)
+ (let ((split (integer-divide x 2)))
+ (+ (* y #x800)
+ (* (integer-divide-remainder split) #x400)
+ (integer-divide-quotient split))))
+
+(define (assemble-17 x y z)
+ (let ((split (integer-divide y 2)))
+ (+ (* z #x10000)
+ (* x #x800)
+ (* (integer-divide-remainder split) #x400)
+ (integer-divide-quotient split))))
+
+#|
+(define (assemble-21 x) ; Source Dest
+ (+ (* (* (land x 1) #x10000) #x10) ; bit 20 bit 0
+ (* (land x #xffe) #x100) ; bits 9-19 bits 1-11
+ (quotient (land x #xc000) #x80) ; bits 5-6 bits 12-13
+ (quotient (land x #x1f0000) #x4000) ; bits 0-4 bits 14-18
+ (quotient (land x #x3000) #x1000))) ; bits 7-8 bits 19-20
+|#
+
+(define (assemble-21 x)
+ (let ((b (unsigned-integer->bit-string 21 x)))
+ (+ (* (extract b 0 1) #x100000)
+ (* (extract b 1 12) #x200)
+ (* (extract b 14 16) #x80)
+ (* (extract b 16 21) #x4)
+ (extract b 12 14))))
+
+(define (x-signed-5-bit x) ; Sign bit is lo.
+ (let ((sign-bit (land x 1))
+ (hi-bits (quotient x 2)))
+ (if (= sign-bit 0)
+ hi-bits
+ (- hi-bits 16))))
+
+(define (x-signed-11-bit x) ; Sign bit is lo.
+ (let ((sign-bit (land x 1))
+ (hi-bits (quotient x 2)))
+ (if (= sign-bit 0)
+ hi-bits
+ (- hi-bits #x400))))
+
+(define (xright2s d)
+ (let ((sign-bit (land d 1)))
+ (- (quotient d 2)
+ (if (= sign-bit 0)
+ 0
+ #x2000))))
+
+(define-integrable (make-pc-relative value)
+ (offset->pc-relative value *current-offset))
+
+(define (collect-14 lo-halfword)
+ (let* ((sign (land lo-halfword 1))
+ (w (* 4 (assemble-12 (quotient (land lo-halfword #x1ffc) 4)
+ sign))))
+ (make-pc-relative (if (= sign 1)
+ (- w #x4000) ; (expt 2 14)
+ w))))
+
+(define (collect-19 lo-halfword hi-halfword pc-rel?)
+ (let* ((sign (land 1 lo-halfword))
+ (w (* 4 (assemble-17 (land Mask-11-15 hi-halfword)
+ (quotient (land Mask-3-14 lo-halfword)
+ 4)
+ sign)))
+ (disp (if (= sign 1)
+ (- w #x80000) ; (expt 2 19)
+ w)))
+ (if pc-rel?
+ (make-pc-relative disp)
+ disp)))
+\f
+;;;; Completers (modifier suffixes)
+
+(define (x-arith-log-completer lo-halfword xtra)
+ ;; c is 3-bit, f 1-bit
+ (let ((c (quotient lo-halfword #x2000))
+ (f (quotient (land lo-halfword 4096) #x1000)))
+ (let ((index (+ (* f 8) c)))
+ (case xtra
+ ((#x2c #x2d #x30 #x32 #x34 #x36 #x38 #x4c #x4e
+ #x50 #x52 #x54 #x56 #x70 #x72 #x74 #x76 #x78)
+ ;; adds: #x2c #x2d are ADDI
+ (vector-ref
+ '#(() (=) (<) (<=) (NUV) (ZNV) (SV) (OD)
+ (TR) (<>) (>=) (>) (UV) (VNZ) (NSV) (EV))
+ #|
+ '#(() (Eq) (Lt) (LtEq) (NUV) (ZNV) (SV) (OD)
+ (TR) (LtGt) (GtEq) (Gt) (UV) (VNZ) (NSV) (EV))
+ |#
+ index))
+ ((#x20 #x22 #x24 #x25 #x26 #x28 #x44 #x60 #x66 #x68)
+ ;; subtract/compare: #x24 #x25 are SUBI
+ (vector-ref
+ '#(() (=) (<) (<=) (<<) (<<=) (SV) (OD)
+ (TR) (<>) (>=) (>) (>>=) (>>) (NSV) (EV))
+ #|
+ '#(() (Eq) (Lt) (LtEq) (LtLt) (LtLtEq) (SV) (OD)
+ (TR) (LtGt) (GtEq) (Gt) (GtGtEq) (GtGt) (NSV) (EV))
+ |#
+ index))
+ ((0 #x10 #x12 #x14 #x1c)
+ ;; logical
+ (vector-ref
+ '#(() (=) (<) (<=) () () () (OD)
+ (TR) (<>) (>=) (>) () () () (EV))
+ #|
+ '#(() (Eq) (Lt) (LtEq) () () () (OD)
+ (TR) (LtGt) (GtEq) (Gt) () () () (EV))
+ |#
+ index))
+ ((#x5c #x5e)
+ ;; unit
+ (vector-ref '#(() () (SBZ) (SHZ) (SDC) () (SBC) (SHC)
+ (TR) () (NBZ) (NHZ) (NDC) () (NBC) (NHC))
+ index))))))
+\f
+(define (X-Extract-Deposit-Completers c)
+ (vector-ref '#(() (=) (<) (OD) (TR) (<>) (>=) (EV))
+ #| '#(() (Eq) (Lt) (OD) (TR) (LtGt) (GtEq) (EV)) |#
+ c))
+
+(define (cc-completer lo-halfword)
+ (vector-ref '#(() (C) (Q) (P))
+ (quotient (land lo-halfword Mask-4-5) #x400)))
+
+(define (um-completer short-flag lo-halfword)
+ (let ((u-completer (land lo-halfword #x2000))
+ (m-completer (land lo-halfword #x20)))
+ (if (zero? short-flag)
+ (if (zero? u-completer)
+ (if (zero? m-completer) '() '(M))
+ (if (zero? m-completer) '(S) '(SM)))
+ (if (zero? m-completer)
+ '()
+ (if (zero? u-completer) '(MA) '(MB))))))
+
+(define-integrable (nullify-bit lo-halfword)
+ (if (= (land lo-halfword 2) 2) '(N) '()))
+
+(define-integrable (floating-format value)
+ (vector-ref '#(SGL DBL FMT=2 QUAD) value))
+
+(define-integrable (float-completer value)
+ (vector-ref '#(false? false ? !<=> = =T ?= !<> !?>= < ?< !>= !?> <= ?<= !>
+ !?<= > ?> !<= !?< >= ?>= !< !?= <> != !=T !? <=> true? true)
+ value))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/inerly.scm,v 1.1 1990/01/25 16:35:00 jinx Rel $
+$MC68020-Header: inerly.scm,v 1.6 88/08/31 06:00:59 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;; Spectrum Instruction Set Macros. Early version
+;;; NOPs for now.
+
+(declare (usual-integrations))
+\f
+;;;; Transformers and utilities
+
+(define early-instructions '())
+(define early-transformers '())
+
+(define (define-early-transformer name transformer)
+ (set! early-transformers
+ (cons (cons name transformer)
+ early-transformers)))
+
+(define (eq-subset? s1 s2)
+ (or (null? s1)
+ (and (memq (car s1) s2)
+ (eq-subset? (cdr s1) s2))))
+
+;;; Instruction and addressing mode macros
+
+(syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION
+ (macro (opcode . patterns)
+ `(SET! EARLY-INSTRUCTIONS
+ (CONS
+ (LIST ',opcode
+ ,@(map (lambda (pattern)
+ `(early-parse-rule
+ ',(car pattern)
+ (lambda (pat vars)
+ (early-make-rule
+ pat
+ vars
+ (scode-quote
+ (instruction->instruction-sequence
+ ,(parse-instruction (cadr pattern)
+ (cddr pattern)
+ true)))))))
+ patterns))
+ EARLY-INSTRUCTIONS))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/insmac.scm,v 1.1 1990/01/25 16:35:37 jinx Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Spectrum Instruction Set Macros
+
+(declare (usual-integrations))
+\f
+;;;; Definition macros
+
+(syntax-table-define assembler-syntax-table 'DEFINE-SYMBOL-TRANSFORMER
+ (macro (name . alist)
+ `(begin
+ (declare (integrate-operator ,name))
+ (define (,name symbol)
+ (declare (integrate symbol))
+ (let ((place (assq symbol ',alist)))
+ (if (null? place)
+ #F
+ (cdr place)))))))
+
+(syntax-table-define assembler-syntax-table 'DEFINE-TRANSFORMER
+ (macro (name value)
+ `(define ,name ,value)))
+\f
+;;;; Fixed width instruction parsing
+
+(define (parse-instruction first-word tail early?)
+ (cond ((not (null? tail))
+ (error "parse-instruction: Unknown format" (cons first-word tail)))
+ ((eq? (car first-word) 'LONG)
+ (process-fields (cdr first-word) early?))
+ ((eq? (car first-word) 'VARIABLE-WIDTH)
+ (process-variable-width first-word early?))
+ (else
+ (error "parse-instruction: Unknown format" first-word))))
+
+(define (process-variable-width descriptor early?)
+ (let ((binding (cadr descriptor))
+ (clauses (cddr descriptor)))
+ `(LIST
+ ,(variable-width-expression-syntaxer
+ (car binding) ; name
+ (cadr binding) ; expression
+ (map (lambda (clause)
+ (expand-fields
+ (cdadr clause)
+ early?
+ (lambda (code size)
+ (if (not (zero? (remainder size 32)))
+ (error "process-variable-width: bad clause size" size))
+ `((LIST ,(optimize-group-syntax code early?))
+ ,size
+ ,@(car clause)))))
+ clauses)))))
+
+(define (process-fields fields early?)
+ (expand-fields fields
+ early?
+ (lambda (code size)
+ (if (not (zero? (remainder size 32)))
+ (error "process-fields: bad syllable size" size))
+ `(LIST ,(optimize-group-syntax code early?)))))
+
+(define (expand-fields fields early? receiver)
+ (define (expand fields receiver)
+ (if (null? fields)
+ (receiver '() 0)
+ (expand-field
+ (car fields) early?
+ (lambda (car-field car-size)
+ (expand
+ (cdr fields)
+ (lambda (tail tail-size)
+ (receiver (cons car-field tail)
+ (+ car-size tail-size))))))))
+ (expand fields receiver))
+
+(define (expand-field field early? receiver)
+ early? ; ignored for now
+ (let ((size (car field))
+ (expression (cadr field)))
+
+ (define (default type)
+ (receiver (integer-syntaxer expression type size)
+ size))
+
+ (if (null? (cddr field))
+ (default 'UNSIGNED)
+ (case (caddr field)
+ ((PC-REL)
+ (receiver
+ (integer-syntaxer ``(- ,,expression (+ *PC* 8))
+ (cadddr field)
+ size)
+ size))
+ ((BLOCK-OFFSET)
+ (receiver (list 'list ''BLOCK-OFFSET expression)
+ size))
+ (else
+ (default (caddr field)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/instr1.scm,v 1.1 1990/01/25 16:36:17 jinx Exp $
+
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; HP Spectrum instruction utilities
+;;; Originally from Walt Hill, who did the hard part.
+
+(declare (usual-integrations))
+\f
+(define-transformer complx
+ (lambda (completer)
+ (vector (encode-S/SM completer)
+ (cc-val completer)
+ (m-val completer))))
+
+(define-transformer compls
+ (lambda (completer)
+ (vector (encode-MB completer)
+ (cc-val completer)
+ (m-val completer))))
+
+(define-transformer compledb
+ (lambda (completer)
+ (cons (encode-n completer)
+ (extract-deposit-condition completer))))
+
+(define-transformer compled
+ (lambda (completer)
+ (extract-deposit-condition completer)))
+
+(define-transformer complalb
+ (lambda (completer)
+ (cons (encode-n completer)
+ (arith-log-condition completer))))
+
+(define-transformer complaltfb
+ (lambda (completer)
+ (list (encode-n completer)
+ (let ((val (arith-log-condition completer)))
+ (if (not (zero? (cadr val)))
+ (error "complaltfb: Bad completer" completer)
+ (car val))))))
+
+(define-transformer complal
+ (lambda (completer)
+ (arith-log-condition completer)))
+
+(define-transformer fpformat
+ (lambda (completer)
+ (encode-fpformat completer)))
+
+(define-transformer fpcond
+ (lambda (completer)
+ (encode-fpcond completer)))
+
+(define-transformer sr3
+ (lambda (value)
+ (let ((place (assq value '((0 . 0) (1 . 2) (2 . 4) (3 . 6)
+ (4 . 1) (5 . 3) (6 . 5) (7 . 7)))))
+ (if place
+ (cdr place)
+ (error "sr3: Invalid space register descriptor" value)))))
+\f
+;;;; Utilities
+
+(define-integrable (branch-extend-pco disp nullify?)
+ (if (and (= nullify? 1)
+ (negative? disp))
+ 4
+ 0))
+
+(define-integrable (branch-extend-nullify disp nullify?)
+ (if (and (= nullify? 1)
+ (not (negative? disp)))
+ 1
+ 0))
+
+(define-integrable (branch-extend-disp disp)
+ (- disp 4))
+
+(define-integrable (branch-extend-edcc cc)
+ (remainder (+ cc 4) 8))
+
+(define-integrable (encode-N completers)
+ (if (memq 'N completers)
+ 1
+ 0))
+
+(define-integrable (encode-S/SM completers)
+ (if (or (memq 'S completers) (memq 'SM completers))
+ 1
+ 0))
+
+(define-integrable (encode-MB completers)
+ (if (memq 'MB completers)
+ 1
+ 0))
+
+(define-integrable (m-val compl-list)
+ (if (or (memq 'M compl-list)
+ (memq 'SM compl-list)
+ (memq 'MA compl-list)
+ (memq 'MB compl-list))
+ 1
+ 0))
+
+(define-integrable (cc-val compl-list)
+ (cond ((memq 'P compl-list) 3)
+ ((memq 'Q compl-list) 2)
+ ((memq 'C compl-list) 1)
+ (else 0)))
+
+(define-integrable (extract-deposit-condition compl)
+ (cond ((null? compl) 0)
+ ((or (memq 'EQ compl) (memq '= compl)) 1)
+ ((or (memq 'LT compl) (memq '< compl)) 2)
+ ((memq 'OD compl) 3)
+ ((memq 'TR compl) 4)
+ ((or (memq 'LTGT compl) (memq '<> compl)) 5)
+ ((or (memq 'GTEQ compl) (memq '>= compl)) 6)
+ ((memq 'EV compl) 7)
+ (else 0)))
+
+(define-integrable (encode-fpformat compl)
+ (case compl
+ ((DBL) 1)
+ ((SGL) 0)
+ ((QUAD) 3)
+ (else (error "Missing Floating Point Format" compl))))
+\f
+(define-integrable (encode-fpcond fpcond)
+ (let ((place (assq fpcond float-condition-table)))
+ (if place
+ (cadr place)
+ (error "encode-fpcond: Unknown condition" fpcond))))
+
+(define float-condition-table
+ '((false? 0)
+ (false 1)
+ (? 2)
+ (!<=> 3)
+ (= 4)
+ (=T 5)
+ (?= 6)
+ (!<> 7)
+ (!?>= 8)
+ (< 9)
+ (?< 10)
+ (!>= 11)
+ (!?> 12)
+ (<= 13)
+ (?<= 14)
+ (!> 15)
+ (!?<= 16)
+ (> 17)
+ (?> 18)
+ (!<= 19)
+ (!?< 20)
+ (>= 21)
+ (?>= 22)
+ (!< 23)
+ (!?= 24)
+ (<> 25)
+ (!= 26)
+ (!=T 27)
+ (!? 28)
+ (<=> 29)
+ (true? 30)
+ (true 31)))
+\f
+(define (arith-log-condition compl-list)
+ ;; Returns (c f)
+ (let loop ((compl-list compl-list))
+ (if (null? compl-list)
+ '(0 0)
+ (let ((val (assq (car compl-list) arith-log-condition-table)))
+ (if val
+ (cadr val)
+ (loop (cdr compl-list)))))))
+
+(define arith-log-condition-table
+ '((NV (0 0))
+ (EQ (1 0))
+ (= (1 0))
+ (LT (2 0))
+ (< (2 0))
+ (SBZ (2 0))
+ (LTEQ (3 0))
+ (<= (3 0))
+ (SHZ (3 0))
+ (LTLT (4 0))
+ (<< (4 0))
+ (NUV (4 0))
+ (SDC (4 0))
+ (LTLTEQ (5 0))
+ (<<= (5 0))
+ (ZNV (5 0))
+ (SV (6 0))
+ (SBC (6 0))
+ (OD (7 0))
+ (SHC (7 0))
+ (TR (0 1))
+ (LTGT (1 1))
+ (<> (1 1))
+ (GTEQ (2 1))
+ (>= (2 1))
+ (NBZ (2 1))
+ (GT (3 1))
+ (> (3 1))
+ (NHZ (3 1))
+ (GTGTEQ (4 1))
+ (>>= (4 1))
+ (UV (4 1))
+ (NDC (4 1))
+ (GTGT (5 1))
+ (>> (5 1))
+ (VNZ (5 1))
+ (NSV (6 1))
+ (NBC (6 1))
+ (EV (7 1))
+ (NHC (7 1))))
+
+(define-integrable (tf-adjust opcode condition)
+ (+ opcode (* 2 (cadr condition))))
+
+(define (tf-adjust-inverted opcode condition)
+ (+ opcode (* 2 (- 1 (cadr condition)))))
+\f
+(define (make-operator name handler)
+ (lambda (value)
+ (if (exact-integer? value)
+ (handler value)
+ `(,name ,value))))
+
+(let-syntax ((define-operator
+ (macro (name handler)
+ `(define ,name
+ (make-operator ',name ,handler)))))
+
+(define-operator LEFT
+ (lambda (number)
+ (bit-string->signed-integer
+ (bit-substring (signed-integer->bit-string 32 number) 11 32))))
+
+(define-operator RIGHT
+ (lambda (number)
+ (bit-string->unsigned-integer
+ (bit-substring (signed-integer->bit-string 32 number) 0 11)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/instr2.scm,v 1.1 1990/01/25 16:36:42 jinx Exp $
+
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; HP Spectrum Instruction Set Description
+;;; Originally from Walt Hill, who did the hard part.
+
+(declare (usual-integrations))
+\f
+;;;; Memory and offset operations
+
+;;; The long forms of many of the following instructions use register
+;;; 1 -- this may be inappropriate for assembly-language programs, but
+;;; is OK for the output of the compiler.
+(let-syntax ((long-load
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (OFFSET (? offset) (? space) (? base)) (? reg))
+ (VARIABLE-WIDTH (disp offset)
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 reg)
+ (2 space)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (ADDIL () L$,offset ,base)
+ (6 #x0A)
+ (5 base)
+ (21 (quotient disp #x800) ASSEMBLE21:X)
+ ;; (LDW () (OFFSET R$,offset ,space 1) ,reg)
+ (6 ,opcode)
+ (5 1)
+ (5 reg)
+ (2 space)
+ (14 (remainder disp #x800) RIGHT-SIGNED))))))))
+
+ (long-store
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (? reg) (OFFSET (? offset) (? space) (? base)))
+ (VARIABLE-WIDTH (disp offset)
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 reg)
+ (2 space)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (ADDIL () L$,offset ,base)
+ (6 #x0A)
+ (5 base)
+ (21 (quotient disp #x800) ASSEMBLE21:X)
+ ;; (STW () ,reg (OFFSET R$,offset ,space 1))
+ (6 ,opcode)
+ (5 1)
+ (5 reg)
+ (2 space)
+ (14 (remainder disp #x800) RIGHT-SIGNED))))))))
+
+ (load-offset
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (OFFSET (? offset) 0 (? base)) (? reg))
+ (VARIABLE-WIDTH (disp offset)
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 reg)
+ (2 #b00)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (ADDIL () L$,offset ,base)
+ (6 #x0A)
+ (5 base)
+ (21 (quotient disp #x800) ASSEMBLE21:X)
+ ;; (LDO () (OFFSET R$,offset 0 1) ,reg)
+ (6 ,opcode)
+ (5 1)
+ (5 reg)
+ (2 #b00)
+ (14 (remainder disp #x800) RIGHT-SIGNED))))))))
+
+ (load-immediate
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (? offset) (? reg))
+ (VARIABLE-WIDTH (disp offset)
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 0)
+ (5 reg)
+ (2 #b00)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (LDIL () L$,offset ,base)
+ (6 #x08)
+ (5 reg)
+ (21 (quotient disp #x800) ASSEMBLE21:X)
+ ;; (LDO () (OFFSET R$,offset 0 ,reg) ,reg)
+ (6 ,opcode)
+ (5 reg)
+ (5 reg)
+ (2 #b00)
+ (14 (remainder disp #x800) RIGHT-SIGNED))))))))
+
+ (left-immediate
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (? immed-21) (? reg))
+ (LONG (6 ,opcode)
+ (5 reg)
+ (21 immed-21 ASSEMBLE21:X)))))))
+
+ (long-load LDW #x12)
+ (long-load LDWM #x13)
+ (long-load LDH #x11)
+ (long-load LDB #x10)
+
+ (long-store STW #x1a)
+ (long-store STWM #x1b)
+ (long-store STH #x19)
+ (long-store STB #x18)
+
+ (load-offset LDO #x0d)
+ (load-immediate LDI #x0d) ; pseudo-op (LDO complt (OFFSET displ 0) reg)
+
+ (left-immediate LDIL #x08)
+ (left-immediate ADDIL #x0a))
+\f
+;; In the following, the middle completer field (2 bits) appears to be zero,
+;; according to the hardware. Also, the u-bit seems not to exist in the
+;; cache instructions.
+
+(let-syntax ((indexed-load
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl complx) (INDEX (? index-reg) (? space) (? base))
+ (? reg))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 index-reg)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b0)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg))))))
+
+ (indexed-store
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl complx) (? reg)
+ (INDEX (? index-reg) (? space) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 index-reg)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b0)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg))))))
+
+ (indexed-cache
+ (macro (keyword opcode extn bit)
+ `(define-instruction ,keyword
+ (((? compl complx) (INDEX (? index-reg) (? space) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 index-reg)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 ,bit)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 #b00000)))))))
+
+ (indexed-load LDWX #x03 #x2)
+ (indexed-load LDHX #x03 #x1)
+ (indexed-load LDBX #x03 #x0)
+ (indexed-load LDCWX #x03 #x7)
+ (indexed-load FLDWX #x09 #x0)
+ (indexed-load FLDDX #x0B #x0)
+
+ (indexed-store FSTWX #x09 #x8)
+ (indexed-store FSTDX #x0b #x8)
+
+ (indexed-cache PDC #x01 #xd 1)
+ (indexed-cache FDC #x01 #xa 1)
+ (indexed-cache FIC #x01 #xa 0)
+ (indexed-cache FDCE #x01 #xb 1)
+ (indexed-cache FICE #x01 #xb 0))
+\f
+(let-syntax ((scalr-short-load
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compls) (OFFSET (? offset) (? space) (? base))
+ (? reg))
+ (LONG (6 #x03)
+ (5 base)
+ (5 offset RIGHT-SIGNED)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b1)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg))))))
+
+ (scalr-short-store
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compls) (? reg)
+ (OFFSET (? offset) (? space) (? base)))
+ (LONG (6 #x03)
+ (5 base)
+ (5 reg)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b1)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 offset RIGHT-SIGNED))))))
+
+ (float-short-load
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl compls) (OFFSET (? offset) (? space) (? base))
+ (? reg))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 offset RIGHT-SIGNED)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b1)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg))))))
+\f
+ (float-short-store
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl compls) (? reg)
+ (OFFSET (? offset) (? space) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 offset RIGHT-SIGNED)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b1)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg)))))))
+
+ (scalr-short-load LDWS #x02)
+ (scalr-short-load LDHS #x01)
+ (scalr-short-load LDBS #x00)
+ (scalr-short-load LDCWS #x07)
+
+ (scalr-short-store STWS #x0a)
+ (scalr-short-store STHS #x09)
+ (scalr-short-store STBS #x08)
+ (scalr-short-store STBYS #x0c)
+
+ (float-short-load FLDWS #x09 #x00)
+ (float-short-load FLDDS #x0b #x00)
+
+ (float-short-store FSTWS #x09 #x08)
+ (float-short-store FSTDS #x0b #x08))
+\f
+;;;; Control transfer instructions
+
+;;; Note: For the time being the unconditionaly branch instructions are not
+;;; branch tensioned since their range is pretty large (1/2 Mbyte).
+;;; They should be eventually (by using an LDIL,LDI,BLR sequence, for example).
+
+(let-syntax ((branch&link
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (? reg) (@PCR (? label)))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 label PC-REL ASSEMBLE17:X)
+ (3 ,extn)
+ (11 label PC-REL ASSEMBLE17:Y)
+ (1 0)
+ (1 label PC-REL ASSEMBLE17:Z)))
+
+ (((N) (? reg) (@PCR (? label)))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 label PC-REL ASSEMBLE17:X)
+ (3 ,extn)
+ (11 label PC-REL ASSEMBLE17:Y)
+ (1 1)
+ (1 label PC-REL ASSEMBLE17:Z)))
+
+ ((() (? reg) (@PCO (? offset)))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 offset ASSEMBLE17:X)
+ (3 ,extn)
+ (11 offset ASSEMBLE17:Y)
+ (1 0)
+ (1 offset ASSEMBLE17:Z)))
+
+ (((N) (? reg) (@PCO (? offset)))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 offset ASSEMBLE17:X)
+ (3 ,extn)
+ (11 offset ASSEMBLE17:Y)
+ (1 1)
+ (1 offset ASSEMBLE17:Z))))))
+\f
+ (branch
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (@PCR (? l)))
+ (LONG (6 #x3a)
+ (5 #b00000)
+ (5 l PC-REL ASSEMBLE17:X)
+ (3 #b000)
+ (11 l PC-REL ASSEMBLE17:Y)
+ (1 0)
+ (1 l PC-REL ASSEMBLE17:Z)))
+
+ (((N) (@PCR (? l)))
+ (LONG (6 #x3a)
+ (5 #b00000)
+ (5 l PC-REL ASSEMBLE17:X)
+ (3 #b000)
+ (11 l PC-REL ASSEMBLE17:Y)
+ (1 1)
+ (1 l PC-REL ASSEMBLE17:Z)))
+
+ ((() (@PCO (? offset)))
+ (LONG (6 #x3a)
+ (5 #b00000)
+ (5 offset ASSEMBLE17:X)
+ (3 #b000)
+ (11 offset ASSEMBLE17:Y)
+ (1 0)
+ (1 offset ASSEMBLE17:Z)))
+
+ (((N) (@PCO (? offset)))
+ (LONG (6 #x3a)
+ (5 #b00000)
+ (5 offset ASSEMBLE17:X)
+ (3 #b000)
+ (11 offset ASSEMBLE17:Y)
+ (1 1)
+ (1 offset ASSEMBLE17:Z)))))))
+
+ (branch B 0) ; pseudo-op (BL complt 0 displ)
+ (branch&link BL 0)
+ (branch&link GATE 1))
+\f
+(let-syntax ((BV&BLR
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (? offset-reg) (? reg))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 offset-reg)
+ (3 ,extn)
+ (11 #b00000000000)
+ (1 0)
+ (1 #b0)))
+
+ (((N) (? offset-reg) (? reg))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 offset-reg)
+ (3 ,extn)
+ (11 #b00000000000)
+ (1 1)
+ (1 #b0))))))
+
+ (BE&BLE
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (OFFSET (? offset) (? space sr3) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 offset ASSEMBLE17:X)
+ (3 space)
+ (11 offset ASSEMBLE17:Y)
+ (1 0)
+ (1 offset ASSEMBLE17:Z)))
+
+ (((N) (OFFSET (? offset) (? space sr3) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 offset ASSEMBLE17:X)
+ (3 space)
+ (11 offset ASSEMBLE17:Y)
+ (1 1)
+ (1 offset ASSEMBLE17:Z)))))))
+ (BV&BLR BLR 2)
+ (BV&BLR BV 6)
+ (BE&BLE BE #x38)
+ (BE&BLE BLE #x39))
+\f
+;;;; Conditional branch instructions
+
+#|
+
+Branch tensioning notes for the conditional branch instructions:
+
+The sequence
+
+ combt,cc r1,r2,label
+ instr1
+ instr2
+
+becomes
+
+ combf,cc,n r1,r2,tlabel ; pco = 0
+ b label ; no nullification
+tlabel instr1
+ instr2
+
+The sequence
+
+ combt,cc,n r1,r2,label
+ instr1
+ instr2
+
+becomes either
+
+ combf,cc,n r1,r2,tlabel ; pco = 0
+ b,n label ; nullification
+tlabel instr1
+ instr2
+
+when label is downstream (a forwards branch)
+
+or
+
+ combf,cc,n r1,r2,tlabel ; pco = 4
+ b label ; no nullification
+ instr1
+tlabel instr2
+
+when label is upstream (a backwards branch).
+
+This adjusting of the nullify bits, the pc offset, etc. for tlabel are
+performed by the utilities branch-extend-pco, branch-extend-disp, and
+branch-extend-nullify in instr1.
+|#
+\f
+;;;; Compare/compute and branch.
+
+(let-syntax
+ ((defccbranch
+ (macro (keyword completer opcode1 opcode2 opr1)
+ `(define-instruction ,keyword
+ (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCO (? offset)))
+ (LONG (6 ,opcode1)
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (cadr compl))
+ (11 offset ASSEMBLE12:X)
+ (1 (car compl))
+ (1 offset ASSEMBLE12:Y)))
+
+ (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCR (? l)))
+ (VARIABLE-WIDTH
+ (disp `(- ,l (+ *PC* 8)))
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode1)
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (cadr compl))
+ (11 disp ASSEMBLE12:X)
+ (1 (car compl))
+ (1 disp ASSEMBLE12:Y)))
+
+ ((() ())
+ ;; See page comment above.
+ (LONG (6 ,opcode2) ; COMBF
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (cadr compl))
+ (11 (branch-extend-pco disp (car compl)) ASSEMBLE12:X)
+ (1 1)
+ (1 (branch-extend-pco disp (car compl)) ASSEMBLE12:Y)
+
+ (6 #x3a) ; B
+ (5 0)
+ (5 (branch-extend-disp disp) ASSEMBLE17:X)
+ (3 0)
+ (11 (branch-extend-disp disp) ASSEMBLE17:Y)
+ (1 (branch-extend-nullify disp (car compl)))
+ (1 (branch-extend-disp disp) ASSEMBLE17:Z)))))))))
+
+ (define-macro (defcond name opcode1 opcode2 opr1)
+ `(defccbranch ,name complaltfb ,opcode1 ,opcode2 ,opr1))
+
+ (define-macro (defpseudo name opcode opr1)
+ `(defccbranch ,name complalb
+ (TF-adjust ,opcode (cdr compl))
+ (TF-adjust-inverted ,opcode (cdr compl))
+ ,opr1))
+
+ (defcond COMBT #x20 #x22 (reg-1))
+ (defcond COMBF #x22 #x20 (reg-1))
+ (defcond ADDBT #x28 #x2a (reg-1))
+ (defcond ADDBF #x2a #x28 (reg-1))
+
+ (defcond COMIBT #X21 #x23 (immed-5 right-signed))
+ (defcond COMIBF #X23 #x21 (immed-5 right-signed))
+ (defcond ADDIBT #X29 #x2b (immed-5 right-signed))
+ (defcond ADDIBF #X2b #x29 (immed-5 right-signed))
+
+ (defpseudo COMB #X20 (reg-1))
+ (defpseudo ADDB #X28 (reg-1))
+ (defpseudo COMIB #X21 (immed-5 right-signed))
+ (defpseudo ADDIB #x29 (immed-5 right-signed)))
+\f
+;;;; Miscellaneous control
+
+(let-syntax
+ ((defmovb&bb
+ (macro (name opcode opr1 opr2 field2)
+ `(define-instruction ,name
+ (((? compl compledb) (? ,(car opr1)) ,@opr2 (@PCO (? offset)))
+ (LONG (6 ,opcode)
+ (5 ,field2)
+ (5 ,@opr1)
+ (3 (cdr compl))
+ (11 offset ASSEMBLE12:X)
+ (1 (car compl))
+ (1 offset ASSEMBLE12:Y)))
+
+ (((? compl compledb) (? ,(car opr1)) ,@opr2 (@PCR (? l)))
+ (VARIABLE-WIDTH
+ (disp `(- ,l (+ *PC* 8)))
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 ,field2)
+ (5 ,@opr1)
+ (3 (cdr compl))
+ (11 l PC-REL ASSEMBLE12:X)
+ (1 (car compl))
+ (1 l PC-REL ASSEMBLE12:Y)))
+
+ ((() ())
+ ;; See page comment above.
+ (LONG (6 ,opcode) ; MOVB
+ (5 ,field2)
+ (5 ,@opr1)
+ (3 (branch-extend-edcc (cdr compl)))
+ (11 (branch-extend-pco disp (car compl)) ASSEMBLE12:X)
+ (1 1)
+ (1 (branch-extend-pco disp (car compl)) ASSEMBLE12:Y)
+
+ (6 #x3a) ; B
+ (5 0)
+ (5 (branch-extend-disp disp) ASSEMBLE17:X)
+ (3 0)
+ (11 (branch-extend-disp disp) ASSEMBLE17:Y)
+ (1 (branch-extend-nullify disp (car compl)))
+ (1 (branch-extend-disp disp) ASSEMBLE17:Z)))))))))
+
+
+ (defmovb&bb BVB #x30 (reg) () #b00000)
+ (defmovb&bb BB #x31 (reg) ((? pos)) pos)
+ (defmovb&bb MOVB #x32 (reg-1) (? reg-2) reg-2)
+ (defmovb&bb MOVIB #x33 (immed-5 right-signed) (? reg-2) reg-2))
+\f
+;;;; Assembler pseudo-ops
+
+(define-instruction WORD
+ ((() (? expression))
+ (LONG (32 expression SIGNED))))
+
+(define-instruction UWORD
+ ((() (? expression))
+ (LONG (32 expression UNSIGNED))))
+
+(define-instruction EXTERNAL-LABEL
+ ((() (? format-word) (@PCR (? label)))
+ (LONG (16 format-word UNSIGNED)
+ (16 label BLOCK-OFFSET)))
+
+ ((() (? format-word) (@PCO (? offset)))
+ (LONG (16 format-word UNSIGNED)
+ (16 offset UNSIGNED))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/instr3.scm,v 1.1 1990/01/25 16:37:05 jinx Exp $
+
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; HP Spectrum Instruction Set Description
+;;; Originally from Walt Hill, who did the hard part.
+
+(declare (usual-integrations))
+\f
+;;;; Computation instructions
+
+(let-syntax ((arith-logical
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl complal) (? source-reg1) (? source-reg2)
+ (? target-reg))
+ (LONG (6 #x02)
+ (5 source-reg2)
+ (5 source-reg1)
+ (3 (car compl))
+ (1 (cadr compl))
+ (7 ,extn)
+ (5 target-reg)))))))
+
+ (arith-logical ANDCM #x00)
+ (arith-logical AND #x10)
+ (arith-logical OR #x12)
+ (arith-logical XOR #x14)
+ (arith-logical UXOR #x1c)
+ (arith-logical SUB #x20)
+ (arith-logical DS #x22)
+ (arith-logical SUBT #x26)
+ (arith-logical SUBB #x28)
+ (arith-logical ADD #x30)
+ (arith-logical SH1ADD #x32)
+ (arith-logical SH2ADD #x34)
+ (arith-logical SH3ADD #x36)
+ (arith-logical ADDC #x38)
+ (arith-logical COMCLR #x44)
+ (arith-logical UADDCM #x4c)
+ (arith-logical UADDCMT #x4e)
+ (arith-logical ADDL #x50)
+ (arith-logical SH1ADDL #x52)
+ (arith-logical SH2ADDL #x54)
+ (arith-logical SH3ADDL #x56)
+ (arith-logical SUBO #x60)
+ (arith-logical SUBTO #x66)
+ (arith-logical SUBBO #x68)
+ (arith-logical ADDO #x70)
+ (arith-logical SH1ADDO #x72)
+ (arith-logical SH2ADDO #x74)
+ (arith-logical SH3ADDO #x76)
+ (arith-logical ADDCO #x78))
+
+;; WH Maybe someday. (Spec-DefOpcode DCOR 2048 DecimalCorrect) % 02
+;; (Spec-DefOpcode IDCOR 2048 DecimalCorrect) % 02
+\f
+;;;; Assembler pseudo-ops
+
+(define-instruction NOP ; pseudo-op: (OR complt 0 0 0)
+ (((? compl complal))
+ (LONG (6 #x02)
+ (10 #b0000000000)
+ (3 (car compl))
+ (1 (cadr compl))
+ (7 #x12)
+ (5 #b00000))))
+
+(define-instruction COPY ; pseudo-op (OR complt 0 s t)
+ (((? compl complal) (? source-reg) (? target-reg))
+ (LONG (6 #x02)
+ (5 #b00000)
+ (5 source-reg)
+ (3 (car compl))
+ (1 (cadr compl))
+ (7 #x12)
+ (5 target-reg))))
+
+(define-instruction SKIP ; pseudo-op (ADD complt 0 0 0)
+ (((? compl complal))
+ (LONG (6 #x02)
+ (10 #b0000000000)
+ (3 (car compl))
+ (1 (cadr compl))
+ (7 #x30)
+ (5 #b00000))))
+\f
+(let-syntax ((immed-arith
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl complal) (? immed-11) (? source-reg)
+ (? target-reg))
+ (LONG (6 ,opcode)
+ (5 source-reg)
+ (5 target-reg)
+ (3 (car compl))
+ (1 (cadr compl))
+ (1 ,extn)
+ (11 immed-11 RIGHT-SIGNED)))))))
+ (immed-arith ADDI #x2d 0)
+ (immed-arith ADDIO #x2d 1)
+ (immed-arith ADDIT #x2c 0)
+ (immed-arith ADDITO #x2c 1)
+ (immed-arith SUBI #x25 0)
+ (immed-arith SUBIO #x25 1)
+ (immed-arith COMICLR #x24 0))
+
+(define-instruction VSHD
+ (((? compl compled) (? source-reg1) (? source-reg2)
+ (? target-reg))
+ (LONG (6 #x34)
+ (5 source-reg2)
+ (5 source-reg1)
+ (3 compl)
+ (3 0)
+ (5 #b00000)
+ (5 target-reg))))
+
+(define-instruction SHD
+ (((? compl compled) (? source-reg1) (? source-reg2) (? pos)
+ (? target-reg))
+ (LONG (6 #x34)
+ (5 source-reg2)
+ (5 source-reg1)
+ (3 compl)
+ (3 2)
+ (5 (- 31 pos))
+ (5 target-reg))))
+
+(let-syntax ((extr (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? source-reg) (? pos) (? len)
+ (? target-reg))
+ (LONG (6 #x34)
+ (5 source-reg)
+ (5 target-reg)
+ (3 compl)
+ (3 ,extn)
+ (5 pos)
+ (5 (- 32 len)))))))
+ (vextr (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? source-reg) (? len)
+ (? target-reg))
+ (LONG (6 #x34)
+ (5 source-reg)
+ (5 target-reg)
+ (3 compl)
+ (3 ,extn)
+ (5 #b00000)
+ (5 (- 32 len))))))))
+ (extr EXTRU 6)
+ (extr EXTRS 7)
+ (vextr VEXTRU 4)
+ (vextr VEXTRS 5))
+\f
+(let-syntax ((depos
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? source-reg) (? pos) (? len)
+ (? target-reg))
+ (LONG (6 #x35)
+ (5 target-reg)
+ (5 source-reg)
+ (3 compl)
+ (3 ,extn)
+ (5 (- 31 pos))
+ (5 (- 32 len)))))))
+ (vdepos
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? source-reg) (? len)
+ (? target-reg))
+ (LONG (6 #x35)
+ (5 target-reg)
+ (5 source-reg)
+ (3 compl)
+ (3 ,extn)
+ (5 #b00000)
+ (5 (- 32 len)))))))
+ (idepos
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? immed) (? pos) (? len)
+ (? target-reg))
+ (LONG (6 #x35)
+ (5 target-reg)
+ (5 immed RIGHT-SIGNED)
+ (3 compl)
+ (3 ,extn)
+ (5 (- 31 pos))
+ (5 (- 32 len)))))))
+
+ (videpos
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? immed) (? len)
+ (? target-reg))
+ (LONG (6 #x35)
+ (5 target-reg)
+ (5 immed RIGHT-SIGNED)
+ (3 compl)
+ (3 ,extn)
+ (5 #b00000)
+ (5 (- 32 len))))))))
+
+ (idepos DEPI 7)
+ (idepos ZDEPI 6)
+ (videpos VDEPI 5)
+ (videpos ZVDEPI 4)
+ (depos DEP 3)
+ (depos ZDEP 2)
+ (vdepos VDEP 1)
+ (vdepos ZVDEP 0))
+\f
+(let-syntax ((Probe-Read-Write
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (OFFSET 0 (? space) (? base)) (? priv-reg)
+ (? target-reg))
+ (LONG (6 1)
+ (5 base)
+ (5 priv-reg)
+ (2 space)
+ (8 ,extn)
+ (1 #b0)
+ (5 target-reg)))))))
+ (Probe-Read-Write PROBER #x46)
+ (Probe-Read-Write PROBEW #x47)
+ (Probe-Read-Write PROBERI #xc6)
+ (Probe-Read-Write PROBEWI #xc7))
+
+(define-instruction BREAK
+ ((() (? immed-5) (? immed-13))
+ (LONG (6 #b000000)
+ (13 immed-13)
+ (8 #b00000000)
+ (5 immed-5))))
+
+(define-instruction LDSID
+ ((() (OFFSET 0 (? space) (? base)) (? target-reg))
+ (LONG (6 #b000000)
+ (5 base)
+ (5 #b00000)
+ (2 space)
+ (1 #b0)
+ (8 #x85)
+ (5 target-reg))))
+
+(define-instruction MTSP
+ ((() (? source-reg) (? space-reg sr3))
+ (LONG (6 #b000000)
+ (5 #b00000)
+ (5 source-reg)
+ (3 space-reg)
+ (8 #xc1)
+ (5 #b00000))))
+
+(define-instruction MTCTL
+ ((() (? source-reg) (? control-reg))
+ (LONG (6 #b000000)
+ (5 control-reg)
+ (5 source-reg)
+ (3 #b000)
+ (8 #xc2)
+ (5 #b00000))))
+
+(define-instruction MTSAR ; pseudo-oop (MTCLT () source 11)
+ ((() (? source-reg))
+ (LONG (6 #b000000)
+ (5 #x0b)
+ (5 source-reg)
+ (3 #b000)
+ (8 #xc2)
+ (5 #b00000))))
+\f
+(define-instruction MFSP
+ ((() (? space-reg sr3) (? target-reg))
+ (LONG (16 #b0000000000000000)
+ (3 space-reg)
+ (8 #x25)
+ (5 target-reg))))
+
+(define-instruction MFCTL
+ ((() (? control-reg) (? target-reg))
+ (LONG (6 #b000000)
+ (5 control-reg)
+ (5 #b00000)
+ (3 #b000)
+ (8 #x45)
+ (5 target-reg))))
+
+(define-instruction SYNC
+ ((())
+ (LONG (16 #b0000000000000000)
+ (3 #b000)
+ (8 #x20)
+ (5 #b00000))))
+
+#|
+Missing:
+
+LPA
+LHA
+PDTLB
+PITLB
+PDTLBE
+PITLBE
+IDTLBA
+IITLBA
+IDTLBP
+IITLBP
+DIAG
+
+|#
+\f
+(let-syntax ((floatarith-1
+ (macro (keyword extn-a extn-b)
+ `(define-instruction ,keyword
+ ((((? fmt fpformat)) (? source-reg) (? target-reg))
+ (LONG (6 #x0c)
+ (5 source-reg)
+ (5 #b00000)
+ (3 ,extn-a)
+ (2 fmt)
+ (2 ,extn-b)
+ (4 #b0000)
+ (5 target-reg))))))
+ (floatarith-2
+ (macro (keyword extn-a extn-b)
+ `(define-instruction ,keyword
+ ((((? fmt fpformat)) (? source-reg1) (? source-reg2)
+ (? target-reg))
+ (LONG (6 #x0c)
+ (5 source-reg1)
+ (5 source-reg2)
+ (3 ,extn-a)
+ (2 fmt)
+ (2 ,extn-b)
+ (4 #b0000)
+ (5 target-reg)))))))
+
+ (floatarith-2 FADD 0 3)
+ (floatarith-2 FSUB 1 3)
+ (floatarith-2 FMPY 2 3)
+ (floatarith-2 FDIV 3 3)
+ (floatarith-1 FSQRT 4 0)
+ (floatarith-1 FABS 3 0)
+ (floatarith-2 FREM 4 3)
+ (floatarith-1 FRND 5 0)
+ (floatarith-1 FCPY 2 0))
+
+(define-instruction FCMP
+ ((((? cond fpcond) (? fmt fpformat)) (? reg1) (? reg2))
+ (LONG (6 #x0c)
+ (5 reg1)
+ (5 reg2)
+ (3 #b000)
+ (2 fmt)
+ (6 #b100000)
+ (5 cond))))
+
+(let-syntax ((fpconvert
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((((? sf fpformat) (? df fpformat))
+ (? source-reg1)
+ (? reg-t))
+ (LONG (6 #x0c)
+ (5 source-reg1)
+ (4 #b0000)
+ (2 ,extn)
+ (2 df)
+ (2 sf)
+ (6 #b010000)
+ (5 reg-t)))))))
+ (fpconvert FCNVFF 0)
+ (fpconvert FCNVFX 1)
+ (fpconvert FCNVXF 2)
+ (fpconvert FCNVFXT 3))
+
+(define-instruction FTEST
+ ((())
+ (LONG (6 #x0c)
+ (10 #b0000000000)
+ (16 #b0010010000100000))))
+\f
+#|
+;; What SFU is this? -- Jinx
+
+;; WARNING The SFU instruction code below should be
+;; tested before use. WLH 11/18/86
+
+(let-syntax ((multdiv
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (? reg-1) (? reg-2))
+ (LONG (6 #x04)
+ (5 reg-2)
+ (5 reg-1)
+ (5 ,extn)
+ (11 #b11000000000)))))))
+ (multdiv MPYS #x08)
+ (multdiv MPYU #x0a)
+ (multdiv MPYSCV #x0c)
+ (multdiv MPYUCV #x0e)
+ (multdiv MPYACCS #x0d)
+ (multdiv MPYACCU #x0f)
+ (multdiv DIVSIR #x00)
+ (multdiv DIVSFR #x04)
+ (multdiv DIVUIR #x03)
+ (multdiv DIVUFR #x07)
+ (multdiv DIVSIM #x01)
+ (multdiv DIVSFM #x05)
+ (multdiv MDRR #x06))
+
+(define-instruction MDRO
+ ((() (? reg))
+ (LONG (6 #x04)
+ (5 reg)
+ (5 #b00000)
+ (16 #b1000000000000000))))
+
+(let-syntax ((multdivresult
+ (macro (keyword extn-a extn-b)
+ `(define-instruction ,keyword
+ ((() (? reg-t))
+ (LONG (6 #x04)
+ (10 #b0000000000)
+ (5 ,extn-a)
+ (5 #b01000)
+ (1 ,extn-b)
+ (5 reg-t)))))))
+ (multdivresult MDLO 4 0)
+ (multdivresult MDLNV 4 1)
+ (multdivresult MDLV 5 1)
+ (multdivresult MDL 5 0)
+ (multdivresult MDHO 6 0)
+ (multdivresult MDHNV 6 1)
+ (multdivresult MDHV 7 1)
+ (multdivresult MDH 7 0)
+ (multdivresult MDSFUID 0 0))
+|#
\ No newline at end of file
projects / mit-scheme.git / commitdiff