From 9a9a8df1ba7c019d8b07b52400fe3b556f8b760d Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Thu, 25 Jan 1990 16:37:05 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/machines/spectrum/dassm3.scm | 725 +++++++++++++++++++ v7/src/compiler/machines/spectrum/inerly.scm | 91 +++ v7/src/compiler/machines/spectrum/insmac.scm | 131 ++++ v7/src/compiler/machines/spectrum/instr1.scm | 278 +++++++ v7/src/compiler/machines/spectrum/instr2.scm | 631 ++++++++++++++++ v7/src/compiler/machines/spectrum/instr3.scm | 473 ++++++++++++ 6 files changed, 2329 insertions(+) create mode 100644 v7/src/compiler/machines/spectrum/dassm3.scm create mode 100644 v7/src/compiler/machines/spectrum/inerly.scm create mode 100644 v7/src/compiler/machines/spectrum/insmac.scm create mode 100644 v7/src/compiler/machines/spectrum/instr1.scm create mode 100644 v7/src/compiler/machines/spectrum/instr2.scm create mode 100644 v7/src/compiler/machines/spectrum/instr3.scm diff --git a/v7/src/compiler/machines/spectrum/dassm3.scm b/v7/src/compiler/machines/spectrum/dassm3.scm new file mode 100644 index 000000000..336ee7f8b --- /dev/null +++ b/v7/src/compiler/machines/spectrum/dassm3.scm @@ -0,0 +1,725 @@ +#| -*-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)) + +;;;; 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)))) + +;;;; 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)) + +(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))))) + +(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)))) + +(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)))))) + +(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))))))) + +(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))))) + +(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)))) + +(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))))) + +(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))))) + +;;;; 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)))) + +;;;; 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))) + +;;;; 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)))))) + +(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 diff --git a/v7/src/compiler/machines/spectrum/inerly.scm b/v7/src/compiler/machines/spectrum/inerly.scm new file mode 100644 index 000000000..807bad7fa --- /dev/null +++ b/v7/src/compiler/machines/spectrum/inerly.scm @@ -0,0 +1,91 @@ +#| -*-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)) + +;;;; 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)))) + + + + + + + + + + + + + + + diff --git a/v7/src/compiler/machines/spectrum/insmac.scm b/v7/src/compiler/machines/spectrum/insmac.scm new file mode 100644 index 000000000..82489e8a4 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/insmac.scm @@ -0,0 +1,131 @@ +#| -*-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)) + +;;;; 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))) + +;;;; 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 diff --git a/v7/src/compiler/machines/spectrum/instr1.scm b/v7/src/compiler/machines/spectrum/instr1.scm new file mode 100644 index 000000000..094a14094 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/instr1.scm @@ -0,0 +1,278 @@ +#| -*-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)) + +(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))))) + +;;;; 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)))) + +(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))) + +(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))))) + +(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 diff --git a/v7/src/compiler/machines/spectrum/instr2.scm b/v7/src/compiler/machines/spectrum/instr2.scm new file mode 100644 index 000000000..af82e5483 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/instr2.scm @@ -0,0 +1,631 @@ +#| -*-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)) + +;;;; 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)) + +;; 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)) + +(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)))))) + + (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)) + +;;;; 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)))))) + + (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)) + +(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)) + +;;;; 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. +|# + +;;;; 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))) + +;;;; 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)) + +;;;; 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 diff --git a/v7/src/compiler/machines/spectrum/instr3.scm b/v7/src/compiler/machines/spectrum/instr3.scm new file mode 100644 index 000000000..30f65e880 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/instr3.scm @@ -0,0 +1,473 @@ +#| -*-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)) + +;;;; 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 + +;;;; 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)))) + +(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)) + +(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)) + +(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)))) + +(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 + +|# + +(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)))) + +#| +;; 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 -- 2.25.1