#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.2 1987/12/31 05:50:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.3 1988/03/14 19:15:45 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
;;; Flags that control disassembler behavior
+
(define disassembler/symbolize-output? true)
(define disassembler/compiled-code-heuristics? true)
(define disassembler/write-offsets? true)
+(define disassembler/write-addresses? false)
-;;; Operations exported from the disassembler package
-(define disassembler/instructions)
-(define disassembler/instructions/null?)
-(define disassembler/instructions/read)
-(define disassembler/lookup-symbol)
+;;;; Top level entries
(define (compiler:write-lap-file filename #!optional symbol-table?)
(let ((pathname (->pathname filename)))
(compiler-info/symbol-table
(compiler-info/read-file pathname)))))))))
+(define disassembler/base-address)
+
+(define (disassembler/write-compiled-entry entry)
+ (let ((the-block (compiled-code-address->block entry)))
+ (fluid-let ((disassembler/write-offsets? true)
+ (disassembler/write-addresses? true)
+ (disassembler/base-address (primitive-datum the-block)))
+ (let ((info
+ (compiler-info/read-file
+ (system-vector-ref the-block
+ (- (system-vector-size the-block) 2)))))
+ (newline)
+ (newline)
+ (disassembler/write-compiled-code-block
+ the-block
+ (compiler-info/symbol-table info))))))
+\f
+;;; Operations exported from the disassembler package
+
+(define disassembler/instructions)
+(define disassembler/instructions/null?)
+(define disassembler/instructions/read)
+(define disassembler/lookup-symbol)
+
(define (disassembler/write-compiled-code-block block symbol-table)
(write-string "Code:\n\n")
(disassembler/write-instruction-stream
(define (disassembler/instructions/address start-address end-address)
(disassembler/instructions false start-address end-address false))
-\f
+
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
(fluid-let ((*unparser-radix* 16))
(disassembler/for-each-instruction instruction-stream
(write-string (string-downcase (label-info-name label)))
(write-char #\:)
(newline))))
+
+ (if disassembler/write-addresses?
+ (begin
+ (write-string
+ ((access unparse-number-heuristically number-unparser-package)
+ (+ offset disassembler/base-address) 16 false false))
+ (write-char #\Tab)))
+
(if disassembler/write-offsets?
- (begin (write-string
- ((access unparse-number-heuristically number-unparser-package)
- offset 16 false false))
- (write-char #\Tab)))
+ (begin
+ (write-string
+ ((access unparse-number-heuristically number-unparser-package)
+ offset 16 false false))
+ (write-char #\Tab)))
+
(if symbol-table
(write-string " "))
(write-instruction)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.2 1987/12/31 05:51:14 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.3 1988/03/14 19:16:00 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(*ir)
(*valid? true))
(set! *ir (get-word))
- (let ((instruction
- (if (external-label-marker? symbol-table offset state)
- (make-dc 'W *ir)
- (let ((instruction
- (((vector-ref opcode-dispatch (extract *ir 12 16))))))
- (if *valid?
- instruction
- (make-dc 'W *ir))))))
- (receiver *current-offset
- instruction
- (disassembler/next-state instruction state)))))
+ ;; External label markers come in two parts:
+ ;; An entry type descriptor, and a gc offset.
+ (cond ((eq? state 'EXTERNAL-LABEL-OFFSET)
+ (receiver *current-offset
+ (make-dc 'W *ir)
+ 'INSTRUCTION))
+ ((external-label-marker? symbol-table offset state)
+ (receiver *current-offset
+ (make-dc 'W *ir)
+ 'EXTERNAL-LABEL-OFFSET))
+ (else
+ (let* ((inst
+ (((vector-ref opcode-dispatch (extract *ir 12 16)))))
+ (instruction (if *valid? inst (make-dc 'W *ir))))
+ (receiver *current-offset
+ inst
+ (disassembler/next-state inst state)))))))
\f
(define (disassembler/initial-state)
'INSTRUCTION-NEXT)
(let ((entry
(interpreter-register? (cadr instruction))))
(and entry
- (eq? (car entry) 'ENTRY)
- (not (eq? (cadr entry) 'SETUP-LEXPR)))))))
+ (eq? (car entry) 'ENTRY))))))
'EXTERNAL-LABEL
'INSTRUCTION))
(define (external-label-marker? symbol-table offset state)
(if symbol-table
(sorted-vector/there-exists? symbol-table
- (+ offset 2)
+ (+ offset 4)
label-info-external?)
(and *block
(not (eq? state 'INSTRUCTION))
- (let loop ((offset (+ offset 2)))
+ (let loop ((offset (+ offset 4)))
(let ((contents (read-bits (- offset 2) 16)))
(if (bit-string-clear! contents 0)
(let ((offset
(loop (+ index 4) (1+ i)))))
;; 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
- &+ &- &* &/ &= &< &> 1+ -1+ zero? positive?
- negative? cache-assignment cache-assignment-multiple
- operator-trap)))))
-
-)
+ #x012c
+ '(link error apply
+ lexpr-apply primitive-apply primitive-lexpr-apply
+ cache-reference-apply lookup-apply
+ interrupt-continuation interrupt-ic-procedure
+ interrupt-procedure interrupt-closure
+ lookup safe-lookup set! access unassigned? unbound? define
+ reference-trap safe-reference-trap assignment-trap unassigned?-trap
+ &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))))))
\f
(define (make-pc-relative thunk)
(let ((reference-offset *current-offset))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr2.scm,v 1.13 1987/07/30 21:44:02 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr2.scm,v 1.14 1988/03/14 19:16:16 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(WORD (16 expression SIGNED)))
((L (? expression))
- (WORD (32 expression SIGNED))))
+ (WORD (32 expression SIGNED)))
+
+ ((UW (? expression))
+ (WORD (16 expression UNSIGNED)))
+
+ ((UL (? expression))
+ (WORD (32 expression UNSIGNED))))
\f
;;;; BCD Arithmetic
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.1 1987/12/30 07:05:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.2 1988/03/14 19:16:33 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(let ((result
(case (car expression)
((REGISTER)
- (LAP (MOV L ,(coerce->any (cadr expression)) ,target)))
+ (coerce->target (cadr expression) register))
((OFFSET)
(LAP
(MOV L
(register-reference register)
(reference-alias-register! register false)))
+(define (coerce->target source register)
+ (if (is-alias-for-register? register source)
+ (LAP)
+ (LAP (MOV L ,(coerce->any source)
+ ,(register-reference register)))))
+
(define (code-object-label-initialize code-object)
false)
(INST (BRA (@PCR ,label))))
(define-export (lap:make-entry-point label block-start-label)
- (set! compiler:external-labels
- (cons label compiler:external-labels))
(LAP (ENTRY-POINT ,label)
- (BLOCK-OFFSET ,label)
- (LABEL ,label)))
+ ,@(make-external-label expression-code-word label)))
\f
;;;; Registers/Entries
(INST-EA (@AO 6 ,index)))
(loop (cdr names) (+ index 6)))))
`(BEGIN ,@(loop names start)))))
- (define-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)
- (define-entries #x0228 uuo-link uuo-link-trap cache-reference-apply
- safe-reference-trap unassigned?-trap cache-variable-multiple
- uuo-link-multiple &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?
- cache-assignment cache-assignment-multiple operator-trap
- primitive-lexpr-apply))
+ (define-entries #x012c
+ link error apply
+ lexpr-apply primitive-apply primitive-lexpr-apply
+ cache-reference-apply lookup-apply
+ interrupt-continuation interrupt-ic-procedure
+ interrupt-procedure interrupt-closure
+ lookup safe-lookup set! access unassigned? unbound? define
+ reference-trap safe-reference-trap assignment-trap unassigned?-trap
+ &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))
(define-integrable reg:compiled-memtop (INST-EA (@A 6)))
(define-integrable reg:environment (INST-EA (@AO 6 #x000C)))
projects / mit-scheme.git / commitdiff