From f8e53dad68891d715015b6e3f28fcfdc43807330 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 7 Aug 1987 17:12:59 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/machines/bobcat/dassm1.scm | 62 ++ v7/src/compiler/machines/bobcat/dassm2.scm | 281 +++++++ v7/src/compiler/machines/bobcat/dassm3.scm | 866 +++++++++++++++++++++ 3 files changed, 1209 insertions(+) create mode 100644 v7/src/compiler/machines/bobcat/dassm1.scm create mode 100644 v7/src/compiler/machines/bobcat/dassm2.scm create mode 100644 v7/src/compiler/machines/bobcat/dassm3.scm diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm new file mode 100644 index 000000000..1af33086e --- /dev/null +++ b/v7/src/compiler/machines/bobcat/dassm1.scm @@ -0,0 +1,62 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 1.1 1987/08/07 17:12:13 cph Exp $ + +Copyright (c) 1987 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. |# + +;;;; 68000 Disassembler + +(declare (usual-integrations)) + +(define disassembler:symbolize-output? true) + +(define disassembly-stream) +(define setup-table!) ;; Temporary +(define compiler:write-lap-file) +(define compiler:write-constants-file) + +;;; Little bit of abstraction for instructions shipped outside + +(define-integrable (make-instruction offset label? code) + (cons* offset label? code)) + +(define-integrable instruction-offset car) +(define-integrable instruction-label? cadr) +(define-integrable instruction-code cddr) + +;; INSTRUCTION-STREAM-CONS is (cons (delay )) + +(define-integrable instruction-stream? pair?) +(define-integrable instruction-stream-null? null?) +(define-integrable instruction-stream-head car) + +(define-integrable (instruction-stream-tail stream) + (force (cdr stream))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm new file mode 100644 index 000000000..d532e61f0 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -0,0 +1,281 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 1.1 1987/08/07 17:12:40 cph Exp $ + +Copyright (c) 1987 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. |# + +;;;; 68000 Disassembler + +(declare (usual-integrations)) + +(define ((with-info-to-file type receiver) filename) + (let ((filename (->pathname filename))) + (let ((block (file->block (pathname-new-type filename "com")))) + (fluid-let ((*symbol-table)) + (setup-table! (pathname-new-type filename "binf")) + (call-with-output-file (pathname-new-type filename type) + (lambda (port) (receiver block port))))))) + +(define (block-code->port! block port) + (define (instruction-output-string label? instruction) + (let ((string (with-output-to-string + (lambda () + (if label? (format "~%~s:" label?)) + (format "~% ") + (display instruction))))) + (string-downcase! string) + string)) + + (let ((last-valid-offset (block-code-ending-offset block))) + (let loop ((offset (block-code-starting-offset block))) + (disassemble-one-instruction block offset + (lambda (new-offset label? instruction) + (write-string (instruction-output-string label? instruction) port) + (and (<= new-offset last-valid-offset) + (loop new-offset))))))) + +(define (block-constants->port! block port) + (define (constant-output-string label? constant) + (with-output-to-string + (lambda () + (if label? + (format "~%~s:" (string-downcase label?))) + (format "~% ~o" constant)))) + + (let ((last-valid-index (block-constants-ending-index block))) + (let loop ((index (block-constants-starting-index block))) + (and (<= index last-valid-index) + (let ((offset (block-index->offset index))) + (write-string + (constant-output-string (lookup-label block offset) + (system-vector-ref block index)) + port) + (loop (1+ index))))))) + +(set! compiler:write-lap-file + (with-info-to-file "lap" + (lambda (block port) + (newline port) + (write-string "Executable Code:" port) + (newline port) + (block-code->port! block port) + (newline port) + (newline port) + (write-string "Constants:" port) + (newline port) + (block-constants->port! block port)))) + +(set! compiler:write-constants-file + (with-info-to-file "con" block-constants->port!)) + +(set! disassembly-stream + (named-lambda (disassembly-stream start) + (disassemble-anything start + (lambda (base block offset) + (let ((last-valid-offset (block-code-ending-offset block))) + (let loop ((offset offset)) + (disassemble-one-instruction block offset + (lambda (new-offset label? instruction) + (if (> new-offset last-valid-offset) + '() + ;; INSTRUCTION-STREAM-CONS + (cons (make-instruction offset label? instruction) + (delay (loop new-offset)))))))))))) + +(define (disassemble-anything thing continuation) + (cond ((compiled-code-address? thing) + (let ((block (compiled-code-address->block thing))) + (continuation (primitive-datum block) + block + (compiled-code-address->offset thing)))) + ((integer? thing) + (continuation 0 0 thing)) + (else + (error "Unknown entry to disassemble" thing)))) + +(define (make-address base offset label?) + (or label? offset)) + +(define *block) +(define *initial-offset) +(define *current-offset) +(define *valid?) +(define *ir) + +(define (disassemble-one-instruction block offset receiver) + (define (make-losing-instruction size) + (if (eq? size 'W) + `(DC W ,(bit-string->unsigned-integer *ir)) + `(DC L ,(bit-string->unsigned-integer (bit-string-append (get-word) + *ir))))) + + (fluid-let ((*block block) + (*initial-offset offset) + (*current-offset offset) + (*valid? true) + (*ir)) + (set! *ir (get-word)) + (receiver *current-offset + (lookup-label block offset) + (let ((size (dcw? block offset))) + (if size + (make-losing-instruction size) + (let ((instruction + (((vector-ref opcode-dispatch (extract *ir 12 16)))))) + (if *valid? + instruction + (make-losing-instruction 'W)))))))) + +(define (undefined-instruction) + ;; This losing assignment removes a 'call/cc'. Too bad. + (set! *valid? false) + '()) + +(define (undefined) + undefined-instruction) + +;;;; Compiler specific information + +(define data-register-assignments + ;; D0 serves multiple functions, not handled now + '((7 . REFERENCE-MASK))) + +(define address-register-assignments + '((4 . FRAME-POINTER) + (5 . FREE-POINTER) + (6 . REGS-POINTER) + (7 . STACK-POINTER))) + +(define interpreter-register-assignments + (let-syntax () + (define-macro (make-table) + (define (make-entries index names) + (if (null? names) + '() + (cons `(,index . (ENTRY ,(car names))) + (make-entries (+ index 6) (cdr names))))) + `'(;; Interpreter registers + (0 . (REG MEMORY-TOP)) + (4 . (REG STACK-GUARD)) + (8 . (REG VALUE)) + (12 . (REG ENVIRONMENT)) + (16 . (REG TEMPORARY)) + (20 . (REG INTERPRETER-CALL-RESULT:ENCLOSE)) + ;; Interpreter entry points + ,@(make-entries + #x00F0 + '(apply error wrong-number-of-arguments interrupt-procedure + interrupt-continuation lookup-apply lookup access + unassigned? unbound? set! define primitive-apply + enclose setup-lexpr return-to-interpreter safe-lookup + cache-variable reference-trap assignment-trap)) + ,@(make-entries + #x0228 + '(uuo-link uuo-link-trap cache-reference-apply + safe-reference-trap unassigned?-trap + cache-variable-multiple uuo-link-multiple)))) + (make-table))) + +(define-integrable (lookup-special-register reg table) + (assq reg table)) + +(define-integrable (special-register reg-pair) + (cdr reg-pair)) + +(define ((register-maker table) mode register) + (let ((special (and disassembler:symbolize-output? + (lookup-special-register register table)))) + (list mode + (if special + (special-register special) + register)))) + +(define make-data-register + (register-maker data-register-assignments)) + +(define make-address-register + (register-maker address-register-assignments)) + +(define (make-address-offset register offset) + (if (not disassembler:symbolize-output?) + `(@AO ,register ,offset) + (let ((special + (lookup-special-register register address-register-assignments))) + (if special + (if (eq? (special-register special) 'REGS-POINTER) + (let ((interpreter-register + (lookup-special-register offset + interpreter-register-assignments))) + (if interpreter-register + (special-register interpreter-register) + `(@AO REGS-POINTER ,offset))) + `(@AO ,(special-register special) ,offset)) + `(@AO ,register ,offset))))) + +(define (make-pc-relative thunk) + ;; Done this way to force order of evaluation + (let* ((reference-offset *current-offset) + (pco (thunk))) + (offset->pc-relative pco reference-offset))) + +(define-integrable (offset->pc-relative pco reference-offset) + (let ((absolute (+ pco reference-offset))) + (if disassembler:symbolize-output? + (let ((answ (lookup-label *block absolute))) + (if answ + `(@PCR ,answ) + `(@PCO ,(- pco (- reference-offset *initial-offset))))) + `(@PCO ,(- pco (- reference-offset *initial-offset)))))) + +(define *symbol-table) + +;; Temporary Kludge + +(set! setup-table! + (named-lambda (setup-table! filename) + (set! *symbol-table + (make-binary-searcher (compiler-info-labels (fasload filename)) + offset/label-info=? + offset/label-infosigned-integer (get-word)))) + (if (zero? (extract *ir 7 8)) + `(,(make-address-offset address-register offset) + ,(make-data-register 'D data-register)) + `(,(make-data-register 'D data-register) + ,(make-address-offset address-register offset)))))) + + +(define ((logical-immediate keyword)) + (let ((size (decode-bwl (extract *ir 6 8)))) + (cond ((null? size) + (undefined-instruction)) + ((= (extract *ir 0 6) #b111100) + (if (eq? size 'L) + (undefined-instruction) + `(,keyword ,size (& ,(fetch-immediate size)) (SR)))) + (else + (let ((ea (decode-ea-d&a))) + `(,keyword ,size (& ,(fetch-immediate size)) ,ea)))))) + +(define %ORI (logical-immediate 'ORI)) +(define %ANDI (logical-immediate 'ANDI)) +(define %EORI (logical-immediate 'EORI)) + +(define ((arithmetic-immediate keyword)) + (let ((size (decode-bwl (extract *ir 6 8)))) + (if (null? size) + (undefined-instruction) + (let ((ea (decode-ea-d&a))) + `(,keyword ,size (& ,(fetch-immediate size)) ,ea))))) + +(define %SUBI (arithmetic-immediate 'SUBI)) +(define %ADDI (arithmetic-immediate 'ADDI)) +(define %CMPI (arithmetic-immediate 'CMPI)) + +(define ((%MOVE size)) + (let ((sea (decode-ea-b=>-A size))) + (let ((dea (decode-ea-MOVE-destination size))) + `(MOVE ,size ,sea ,dea)))) + +(define %MOVE-byte (%MOVE 'B)) +(define %MOVE-word (%MOVE 'W)) +(define %MOVE-long (%MOVE 'L)) + +(define miscellaneous-dispatch + (let ((NEGX/MOVE<-SR + (lambda () + (if (= (extract *ir 6 8) #b11) %MOVE<-SR %NEGX))) + (CLR (lambda () %CLR)) + (NEG/MOVE->CCR + (lambda () + (if (= (extract *ir 6 8) #b11) %MOVE->CCR %NEG))) + (NOT/MOVE->SR + (lambda () + (if (= (extract *ir 6 8) #b11) %MOVE->SR %NOT))) + (NBCD/PEA/SWAP/MOVEM-registers->ea/EXT + (lambda () + (if (= (extract *ir 7 8) 0) + (if (= (extract *ir 6 7) 0) + %NBCD + (if (= (extract *ir 3 6) 0) + %SWAP + %PEA)) + (if (= (extract *ir 3 6) 0) + %EXT + %MOVEM-registers->ea)))) + (TST/TAS/illegal + (lambda () + (if (not (= (extract *ir 6 8) #b11)) + %TST + (if (not (= (extract *ir 0 6) #b111100)) + %TAS + %ILLEGAL)))) + (MOVEM-ea->registers (lambda () %MOVEM-ea->registers)) + (all-the-rest + (lambda () + ((vector-ref all-the-rest-dispatch (extract *ir 6 8))))) + (CHK/LEA + (lambda () + ((vector-ref CHK/LEA-dispatch (extract *ir 6 8)))))) + (vector NEGX/MOVE<-SR + CHK/LEA + CLR + CHK/LEA + NEG/MOVE->CCR + CHK/LEA + NOT/MOVE->SR + CHK/LEA + NBCD/PEA/SWAP/MOVEM-registers->ea/EXT + CHK/LEA + TST/TAS/illegal + CHK/LEA + MOVEM-ea->registers + CHK/LEA + all-the-rest + CHK/LEA))) + +(define all-the-rest-dispatch + (vector undefined + (lambda () ((vector-ref all-the-rest-1-dispatch (extract *ir 3 6)))) + (lambda () %JSR) + (lambda () %JMP))) + +(define all-the-rest-1-dispatch + (vector (lambda () %TRAP) + (lambda () %TRAP) + (lambda () %LINK) + (lambda () %UNLK) + (lambda () %MOVE->USP) + (lambda () %MOVE<-USP) + (lambda () + (let ((register (extract *ir 0 3))) + (if (= register #b100) + undefined-instruction + (lambda () + `(,(vector-ref #(RESET NOP STOP RTE () RTS TRAPV RTR) + register)))))) + undefined)) + +(define ((single-ea-d&a keyword)) + `(,keyword ,(decode-bwl (extract *ir 6 8)) + ,(decode-ea-d&a))) + +(define %NEGX (single-ea-d&a 'NEGX)) +(define %CLR (single-ea-d&a 'CLR)) +(define %NEG (single-ea-d&a 'NEG)) +(define %NOT (single-ea-d&a 'NOT)) +(define %TST (single-ea-d&a 'TST)) + + +(define (%MOVE<-SR) + `(MOVE W (SR) ,(decode-ea-d&a))) + +(define (%MOVE->CCR) + `(MOVE W ,(decode-ea-d 'W) (CCR))) + +(define (%MOVE->SR) + `(MOVE W ,(decode-ea-d 'W) (SR))) + +(define (%NBCD) + `(NBCD ,(decode-ea-d&a))) + +(define (%SWAP) + `(SWAP ,(make-data-register 'D (extract *ir 0 3)))) + +(define (%PEA) + `(PEA ,(decode-ea-c))) + +(define (%EXT) + `(EXT ,(decode-wl (extract *ir 6 7)) + ,(make-data-register 'D (extract *ir 0 3)))) + +(define (%TAS) + `(TAS B ,(decode-ea-d&a))) + +(define (%ILLEGAL) + '(ILLEGAL)) + +(define (%TRAP) + `(TRAP (& ,(extract *ir 0 4)))) + +(define (%LINK) + `(LINK ,(make-address-register 'A (extract *ir 0 3)))) + +(define (%UNLK) + `(UNLK ,(make-address-register 'A (extract *ir 0 3)))) + +(define (%MOVE->USP) + `(MOVE L ,(make-address-register 'A (extract *ir 0 3)) (USP))) + +(define (%MOVE<-USP) + `(MOVE L (USP) ,(make-address-register 'A (extract *ir 0 3)))) + +(define (%JSR) + `(JSR ,(decode-ea-c))) + +(define (%JMP) + `(JMP ,(decode-ea-c))) + +(define (%MOVEM-registers->ea) + (let ((mode (extract *ir 3 6)) + (size (decode-wl (extract *ir 6 7)))) + (if (= mode 4) + `(MOVEM ,size + ,(decode-@-aregister-list (get-word)) + (make-address-register '@-A (extract *ir 0 3))) + (let ((ea (decode-ea-c))) + `(MOVEM ,size + ,(decode-c@a+register-list (get-word)) + ,ea))))) + +(define (%MOVEM-ea->registers) + (let ((mode (extract *ir 3 6)) + (size (decode-wl (extract *ir 6 7)))) + (let ((ea (if (= mode #b011) + (make-address-register '@A+ (extract *ir 0 3)) + (decode-ea-c&a size)))) + `(MOVEM ,size ,ea ,(decode-c@a+register-list (get-word)))))) + +(define (decode-@-aregister-list word) + (define (loop n registers) + (if (null? registers) + '() + (if (zero? (bit-string-ref word n)) + (loop (1+ n) (cdr registers)) + (cons (car registers) + (loop (1+ n) (cdr registers)))))) + (loop 0 '(A7 A6 A5 A4 A3 A2 A1 A0 D7 D6 D5 D4 D3 D2 D1 D0))) + +(define (decode-c@a+register-list word) + (define (loop n registers) + (if (null? registers) + '() + (if (zero? (bit-string-ref word n)) + (loop (1+ n) (cdr registers)) + (cons (car registers) + (loop (1+ n) (cdr registers)))))) + (loop 0 '(D0 D1 D2 D3 D4 D5 D6 D7 A0 A1 A2 A3 A4 A5 A6 A7))) + +(define CHK/LEA-dispatch + (vector undefined + undefined + (lambda () %CHK) + (lambda () %LEA))) + +(define (%CHK) + `(CHK ,(decode-ea-d 'W) + ,(make-data-register 'D (extract *ir 9 12)))) + +(define (%LEA) + `(LEA ,(decode-ea-c) + ,(make-address-register 'A (extract *ir 9 12)))) + +(define (%Scc) + `(S ,(decode-cc (extract *ir 8 12)) + ,(decode-ea-d&a))) + +(define (%DBcc) + `(DB ,(decode-cc (extract *ir 8 12)) + ,(make-data-register 'D (extract *ir 0 3)) + ,(make-pc-relative (lambda () (fetch-immediate 'W))))) + +(define (%Bcc/%BSR) + (let ((cc (decode-cc (extract *ir 8 12))) + (displacement (extract+ *ir 0 8))) + ((access append ()) + (cond ((eq? cc 'T) '(BRA)) + ((eq? cc 'F) '(BSR)) + (else `(B , cc))) + (cond ((= displacement 0) + `(W ,(make-pc-relative (lambda () (fetch-immediate 'W))))) + ((= displacement -1) + `(L (make-pc-relative (lambda () (fetch-immediate 'L))))) + (else + `(B ,(make-pc-relative (lambda () displacement)))))))) + +(define (%MOVEQ) + `(MOVEQ (& ,(extract+ *ir 0 8)) + ,(make-data-register 'D (extract *ir 9 12)))) + +(define ((logical keyword)) + (let ((size (decode-bwl (extract *ir 6 8))) + (register (extract *ir 9 12))) + (if (= (extract *ir 8 9) #b0) + `(,keyword ,size + ,(decode-ea-d size) + ,(make-data-register 'D register)) + `(,keyword ,size + ,(make-data-register 'D register) + ,(decode-ea-m&a))))) + +(define %OR (logical 'OR)) +(define %AND (logical 'AND)) + +(define (%EOR) + `(EOR ,(decode-bwl (extract *ir 6 8)) + ,(make-data-register 'D (extract *ir 9 12)) + ,(decode-ea-d&a))) + +(define ((binary keyword)) + (let ((size (decode-bwl (extract *ir 6 8))) + (register (extract *ir 9 12))) + (if (= (extract *ir 8 9) #b0) + `(,keyword ,size + ,(decode-ea-b=>-A size) + ,(make-data-register 'D register)) + `(,keyword ,size + ,(make-data-register 'D register) + ,(decode-ea-m&a))))) + +(define %ADD (binary 'ADD)) +(define %SUB (binary 'SUB)) + +(define (%CMP) + (let ((size (decode-bwl (extract *ir 6 8)))) + `(CMP ,size + ,(decode-ea-b=>-A size) + ,(make-data-register 'D (extract *ir 9 12))))) + +(define ((binary-address keyword)) + (let ((size (decode-wl (extract *ir 8 9)))) + `(,keyword ,size + ,(decode-ea-all size) + ,(make-address-register 'A (extract *ir 9 12))))) + +(define %ADDA (binary-address 'ADD)) +(define %SUBA (binary-address 'SUB)) +(define %CMPA (binary-address 'CMP)) + +(define ((binary-extended keyword)) + (define (receiver mode maker) + `(,keyword ,(decode-bwl (extract *ir 6 8)) + ,(maker mode (extract *ir 0 3)) + ,(maker mode (extract *ir 9 12)))) + (if (= (extract *ir 3 4) #b0) + (receiver 'D make-data-register) + (receiver '@-A make-address-register))) + + +(define %ADDX (binary-extended 'ADDX)) +(define %SUBX (binary-extended 'SUBX)) + +(define (%CMPM) + `(CMPM ,(decode-bwl (extract *ir 6 8)) + ,(make-address-register '@A+ (extract *ir 0 3)) + ,(make-address-register '@A+ (extract *ir 9 12)))) + +(define ((binary-quick keyword)) + (let ((size (decode-bwl (extract *ir 6 8)))) + `(,keyword ,size + (& ,(let ((n (extract *ir 9 12))) + (if (zero? n) 8 n))) + ,(decode-ea-a&-A> size)))) + +(define %ADDQ (binary-quick 'ADDQ)) +(define %SUBQ (binary-quick 'SUBQ)) + +(define ((decimal keyword)) + (define (receiver mode maker) + `(,keyword ,(maker mode (extract *ir 0 3)) + ,(maker mode (extract *ir 9 12)))) + (if (= (extract *ir 3 4) #b0) + (receiver 'D make-data-register) + (receiver '@A- make-address-register))) + +(define %ABCD (decimal 'ABCD)) +(define %SBCD (decimal 'SBCD)) + +(define ((%MUL/%DIV keyword)) + `(,keyword ,(decode-us (extract *ir 8 9)) + ,(decode-ea-d 'W) + ,(make-data-register 'D (extract *ir 9 12)))) + +(define %MUL (%MUL/%DIV 'MUL)) +(define %DIV (%MUL/%DIV 'DIV)) + +(define (%EXG) + (let ((mode (if (= (extract *ir 3 4) #b0) 'D 'A))) + `(EXG (,mode ,(extract *ir 0 3)) + (,mode ,(extract *ir 9 12))))) + +(define (%EXGM) + `(EXG ,(make-address-register 'A (extract *ir 0 3)) + ,(make-data-register 'D (extract *ir 9 12)))) + +(define (shift/rotate) + (let ((size (decode-bwl (extract *ir 6 8))) + (direction (decode-rl (extract *ir 8 9)))) + (if (null? size) + `(,(decode-shift-type (extract *ir 9 11)) + ,direction + ,(decode-ea-m&a)) + `(,(decode-shift-type (extract *ir 3 5)) + ,direction + ,size + ,(if (= (extract *ir 5 6) #b0) + `(& ,(let ((n (extract *ir 9 12))) + (if (zero? n) 8 n))) + `,(make-data-register 'D (extract *ir 9 12))) + ,(make-data-register 'D (extract *ir 0 3)))))) + +;;;; Bit String Manipulation + +(define (fetch-immediate size) + (cond ((eq? size 'B) (extract+ (get-word) 0 8)) + ((eq? size 'W) (bit-string->signed-integer (get-word))) + ((eq? size 'L) (bit-string->signed-integer (get-longword))) + (else (error "Unknown size" 'FETCH-IMMEDIATE size)))) + +(define (make-fetcher size-in-bits) + (let ((size-in-bytes (quotient size-in-bits 8))) + (lambda () + (let ((word (bit-string-allocate size-in-bits))) + (with-interrupt-mask interrupt-mask-none + (lambda (old) + (read-bits! (+ (primitive-datum *block) *current-offset) 0 word))) + (set! *current-offset (+ *current-offset size-in-bytes)) + word)))) + +(define get-word (make-fetcher 16)) +(define get-longword (make-fetcher 32)) +(define-integrable (extract bit-string start end) + (bit-string->unsigned-integer (bit-substring bit-string start end))) + +(define-integrable (extract+ bit-string start end) + (bit-string->signed-integer (bit-substring bit-string start end))) + +;;; Symbolic representation of bit strings + +(define ((symbol-decoder symbols) index) + (vector-ref symbols index)) + +(define decode-bwl (symbol-decoder #(B W L ()))) +(define decode-wl (symbol-decoder #(W L))) +(define decode-rl (symbol-decoder #(R L))) +(define decode-us (symbol-decoder #(U S))) +(define decode-da (symbol-decoder #(D A))) +(define decode-cc + (symbol-decoder #(T F HI LS CC CS NE EQ VC VS PL MI GE LT GT LE))) +(define decode-bit (symbol-decoder #(BTST BCHG BCLR BSET))) +(define decode-shift-type (symbol-decoder #(AS LS ROX RO))) +(define decode-ze (symbol-decoder #(E Z))) + +(define (decode-scale scale) + (vector-ref '#(1 2 4 8) scale)) + +;;;; Effective Addressing + +(define (decode-ea- register size) + (make-data-register 'D register)) + +(define (decode-ea- register size) + (make-address-register 'A register)) + +(define (decode-ea--A> register size) + (if (memq size '(W L)) + (make-address-register 'A register) + (undefined-instruction))) + +(define (decode-ea-<@A> register size) + (make-address-register '@A register)) + +(define (decode-ea-<@A+> register size) + (make-address-register '@A+ register)) + +(define (decode-ea-<@-A> register size) + (make-address-register '@-A register)) + +(define (decode-ea-<@AO> register size) + (make-address-offset register + (bit-string->signed-integer (get-word)))) + +(define (decode-ea- size) + `(W ,(bit-string->signed-integer (get-word)))) + +(define (decode-ea- size) + `(L ,(bit-string->signed-integer (get-longword)))) + +(define (decode-ea-<@PCO> size) + (make-pc-relative (lambda () (bit-string->signed-integer (get-word))))) + +(define (decode-ea-<&> size) + (cond ((eq? size 'B) `(& ,(extract+ (get-word) 0 8))) + ((eq? size 'W) `(& ,(bit-string->signed-integer (get-word)))) + ((eq? size 'L) `(& ,(bit-string->signed-integer (get-longword)))) + (else (error "Unknown size" 'DECODE-EA-<&> size)))) + +;;;; Extended 68020 effective addresses + +(define (decode-ea-<@AOX> register size) + (decode-ea-extension + (lambda (d/a xr w/l scale brs irs bd od operation) + (cond ((eq? (cadr bd) 'B) + (if (= scale 1) + ;; This is the only possibility on a 68000/68010 + `(,@(make-address-register '@AOX register) ,(car bd) + ,d/a + ,xr + ,w/l) + `(,@(make-address-register '@AOXS register) ,(car bd) + (,d/a ,xr) + ,w/l + ,scale))) + ((and (eq? d/a 'D) (eq? w/l 'L) (= scale 1) + (eq? brs 'Z) (eq? irs 'E) + (eq? (cadr od) 'N) (false? operation) + (memq (cadr bd) '(N W))) + (if (eq? (cadr bd) 'N) + (make-data-register '@D xr) + `(,@(make-data-register '@DO xr) ,(car bd)))) + (else + `(,@(make-address-register '@AOF register) ,brs ,bd ,operation + ((,d/a ,xr) ,w/l ,scale) + ,irs ,od)))))) + +(define (decode-ea-<@PCOX> size) + (let ((base-offset *current-offset)) + (decode-ea-extension + (lambda (d/a xr w/l scale brs irs bd od operation) + (cond ((eq? (cadr bd) 'B) + (if (= scale 1) + ;; This is the only possibility on a 68000/68010 + `(@PCOX ,(car bd) ,d/a ,xr ,w/l) + `(@PCOXS ,(car bd) (,d/a ,xr) ,w/l ,scale))) + ((and (eq? brs 'E) (eq? irs 'Z) (false? operation) + (not (eq? (cadr bd) 'N)) (eq? (cadr od) 'N)) + (offset->pc-relative (car bd) base-offset)) + (else + `(@PCOF ,brs ,bd ,operation + ((,d/a ,xr) ,w/l ,scale) + ,irs ,od))))))) + +(define (decode-ea-extension receiver) + (let ((extension (get-word))) + (let ((d/a (decode-da (extract extension 15 16))) + (xr (extract extension 12 15)) + (w/l (decode-wl (extract extension 11 12))) + (scale (decode-scale (extract extension 9 11)))) + (if (not (bit-string-ref extension 8)) + (receiver d/a xr w/l scale 'E 'E + `(,(extract+ extension 0 8) B) + '(0 N) + #F) + (let ((brs (decode-ze (extract extension 7 8))) + (irs (decode-ze (extract extension 6 7))) + (i/is (extract extension 0 3)) + (bd (case (extract extension 4 6) + ((1) '(0 N)) + ((2) `(,(fetch-immediate 'W) W)) + ((3) `(,(fetch-immediate 'L) L)) + (else (error "decode-ea-extension: bad bd-size" + (extract extension 4 6)))))) + (receiver d/a xr w/l scale brs irs bd + (case (if (> i/is 3) (- i/is 4) i/is) + ((0 1) '(0 N)) + ((2) `(,(fetch-immediate 'W) W)) + ((3) `(,(fetch-immediate 'L) L)) + (else (error "decode-ea-extension: bad i/is" i/is))) + (cond ((zero? i/is) #F) + ((> i/is 3) 'POST) + (else 'PRE)))))))) + +(define make-ea-dispatch + (let () + (define (kernel dispatch mode-7) + (vector-set! dispatch 7 + (lambda (register size) + ((vector-ref mode-7 register) size))) + (lambda (mode register size) + ((vector-ref dispatch mode) register size))) + + (lambda (d a @a @a+ @-a @ao @aox w l @pco @pcox &) + (kernel (vector d a @a @a+ @-a @ao @aox '()) + (vector w l @pco @pcox & + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined))))) + +(define (decode-ea-with-size d a @a @a+ @-a @ao @aox w l @pco @pcox &) + (let ((kernel (make-ea-dispatch d a @a @a+ @-a @ao @aox w l @pco @pcox &))) + (lambda (size) + (kernel (extract *ir 3 6) + (extract *ir 0 3) + size)))) + +(define (decode-ea-w/o-size d a @a @a+ @-a @ao @aox w l @pco @pcox &) + (let ((kernel (make-ea-dispatch d a @a @a+ @-a @ao @aox w l @pco @pcox &))) + (lambda () + (kernel (extract *ir 3 6) + (extract *ir 0 3) + '())))) + +(define (decode-ea-undefined register size) + (undefined-instruction)) + +(define (decode-ea-mode-7-undefined size) + (undefined-instruction)) + +(define decode-ea-d + (decode-ea-with-size decode-ea- + decode-ea-undefined + decode-ea-<@A> + decode-ea-<@A+> + decode-ea-<@-A> + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-<@PCO> + decode-ea-<@PCOX> + decode-ea-<&>)) + +(define decode-ea-c + (decode-ea-w/o-size decode-ea-undefined + decode-ea-undefined + decode-ea-<@A> + decode-ea-undefined + decode-ea-undefined + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-<@PCO> + decode-ea-<@PCOX> + decode-ea-mode-7-undefined)) + +(define decode-ea-d&a + (decode-ea-w/o-size decode-ea- + decode-ea-undefined + decode-ea-<@A> + decode-ea-<@A+> + decode-ea-<@-A> + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined)) + +(define decode-ea-c&a + (decode-ea-with-size decode-ea-undefined + decode-ea-undefined + decode-ea-<@A> + decode-ea-undefined + decode-ea-undefined + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined)) + +(define decode-ea-m&a + (decode-ea-w/o-size decode-ea-undefined + decode-ea-undefined + decode-ea-<@A> + decode-ea-<@A+> + decode-ea-<@-A> + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined)) + +(define decode-ea-all + (decode-ea-with-size decode-ea- + decode-ea- + decode-ea-<@A> + decode-ea-<@A+> + decode-ea-<@-A> + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-<@PCO> + decode-ea-<@PCOX> + decode-ea-<&>)) + +(define decode-ea-b=>-A + (decode-ea-with-size decode-ea- + decode-ea--A> + decode-ea-<@A> + decode-ea-<@A+> + decode-ea-<@-A> + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-<@PCO> + decode-ea-<@PCOX> + decode-ea-<&>)) + +(define decode-ea-a&-A> + (decode-ea-with-size decode-ea- + decode-ea--A> + decode-ea-<@A> + decode-ea-<@A+> + decode-ea-<@-A> + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined)) + +(define decode-ea-MOVE-destination + (let ((kernel (make-ea-dispatch decode-ea- + decode-ea- + decode-ea-<@A> + decode-ea-<@A+> + decode-ea-<@-A> + decode-ea-<@AO> + decode-ea-<@AOX> + decode-ea- + decode-ea- + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined + decode-ea-mode-7-undefined))) + (lambda (size) + (kernel (extract *ir 6 9) + (extract *ir 9 12) + size)))) \ No newline at end of file -- 2.25.1