From: Guillermo J. Rozas Date: Tue, 11 Aug 1992 02:19:44 +0000 (+0000) Subject: Replace stubs by the real thing. X-Git-Tag: 20090517-FFI~9151 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f0ea4c3ee7b69e325bd0ca3af750206c94d582bb;p=mit-scheme.git Replace stubs by the real thing. --- diff --git a/v7/src/compiler/machines/i386/dassm2.scm b/v7/src/compiler/machines/i386/dassm2.scm index 2daafdab1..fedc7feb0 100644 --- a/v7/src/compiler/machines/i386/dassm2.scm +++ b/v7/src/compiler/machines/i386/dassm2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/dassm2.scm,v 1.3 1992/02/28 20:22:42 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/dassm2.scm,v 1.4 1992/08/11 02:19:44 jinx Exp $ $MC68020-Header: /scheme/compiler/bobcat/RCS/dassm2.scm,v 4.18 1991/05/07 13:46:04 jinx Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -37,11 +37,6 @@ MIT in each case. |# ;;; package: (compiler disassembler) (declare (usual-integrations)) - -(define-integrable compiled-code-block/bytes-per-object 4) -(define-integrable compiled-code-block/objects-per-procedure-cache 2) -(define-integrable compiled-code-block/objects-per-variable-cache 1) -(define-integrable compiled-code-block/procedure-cache-offset 1) (define (disassembler/read-variable-cache block index) (let-syntax ((ucode-type @@ -54,17 +49,29 @@ MIT in each case. |# (system-vector-ref block index)))) (define (disassembler/read-procedure-cache block index) - block index ; ignored - (error "disassembler/read-procedure-cache: Not yet written")) + (fluid-let ((*block block)) + (let* ((offset (compiled-code-block/index->offset index))) + (let ((opcode (read-unsigned-integer (+ offset 3) 8)) + (arity (read-unsigned-integer offset 16))) + (case opcode + ((#xe9) ; (JMP (@PCR label)) + ;; This should learn how to decode the new trampolines. + (vector 'COMPILED + (read-procedure (+ offset 4)) + arity)) + (else + (error "disassembler/read-procedure-cache: Unknown opcode" + opcode block index))))))) (define (disassembler/instructions block start-offset end-offset symbol-table) (let loop ((offset start-offset) (state (disassembler/initial-state))) (if (and end-offset (< offset end-offset)) - (disassemble-one-instruction block offset symbol-table state - (lambda (offset* instruction state) - (make-instruction offset - instruction - (lambda () (loop offset* state))))) + (disassemble-one-instruction + block offset symbol-table state + (lambda (offset* instruction state) + (make-instruction offset + instruction + (lambda () (loop offset* state))))) '()))) (define-integrable (disassembler/instructions/null? obj) @@ -83,19 +90,56 @@ MIT in each case. |# (define *block) (define *current-offset) (define *symbol-table) -(define *ir) (define *valid?) (define (disassemble-one-instruction block offset symbol-table state receiver) - block offset symbol-table state receiver ; ignored - (error "disassemble-one-instruction: Not yet written")) + (fluid-let ((*block block) + (*current-offset offset) + (*symbol-table symbol-table) + (*valid? true)) + (let ((start-offset *current-offset)) + ;; External label markers come in two parts: + ;; An entry type descriptor, and a gc offset. + (cond ((eq? state 'EXTERNAL-LABEL-OFFSET) + (let* ((offset (next-unsigned-16-bit-word)) + (label (find-label *current-offset))) + (receiver *current-offset + (if label + `(BLOCK-OFFSET ,label) + `(WORD U ,offset)) + 'INSTRUCTION))) + ((external-label-marker? symbol-table offset state) + (receiver *current-offset + `(WORD U ,(next-unsigned-16-bit-word)) + 'EXTERNAL-LABEL-OFFSET)) + (else + (let ((instruction (disassemble-next-instruction))) + (if (or *valid? (not (eq? 'BYTE (car instruction)))) + (receiver *current-offset + instruction + (disassembler/next-state instruction state)) + (let ((inst `(BYTE U ,(caddr instruction)))) + (receiver (1+ start-offset) + inst + (disassembler/next-state inst state)))))))))) (define (disassembler/initial-state) 'INSTRUCTION-NEXT) (define (disassembler/next-state instruction state) - instruction state ; ignored - (error "disassembler/next-state: Not yet written")) + state ; ignored + (if (and disassembler/compiled-code-heuristics? + (or (memq (car instruction) '(JMP RET)) + (and (eq? (car instruction) 'CALL) + (let ((operand (cadr instruction))) + (or (and (pair? operand) + (eq? (car operand) 'ENTRY)) + (let ((entry + (interpreter-register? operand))) + (and entry + (eq? (car entry) 'ENTRY)))))))) + 'EXTERNAL-LABEL + 'INSTRUCTION)) (define (disassembler/lookup-symbol symbol-table offset) (and symbol-table @@ -104,6 +148,9 @@ MIT in each case. |# (dbg-label/name label))))) (define (external-label-marker? symbol-table offset state) + (define-integrable (offset-word->offset word) + (fix:quotient (bit-string->unsigned-integer word) 2)) + (if symbol-table (let ((label (dbg-labels/find-offset symbol-table (+ offset 4)))) (and label @@ -113,11 +160,10 @@ MIT in each case. |# (let loop ((offset (+ offset 4))) (let ((contents (read-bits (- offset 2) 16))) (if (bit-string-clear! contents 0) - (let ((offset - (- offset (bit-string->unsigned-integer contents)))) + (let ((offset (- offset (offset-word->offset contents)))) (and (positive? offset) (loop offset))) - (= offset (bit-string->unsigned-integer contents)))))))) + (= offset (offset-word->offset contents)))))))) (define (read-procedure offset) (with-absolutely-no-interrupts @@ -130,7 +176,11 @@ MIT in each case. |# ((ucode-primitive primitive-object-set-type 2) (ucode-type compiled-entry) ((ucode-primitive make-non-pointer-object 1) - (read-unsigned-integer offset 32))))))) + (+ (read-unsigned-integer offset 32) + (+ (if *block + (object-datum *block) + 0) + (+ offset 4))))))))) (define (read-unsigned-integer offset size) (bit-string->unsigned-integer (read-bits offset size))) @@ -143,4 +193,130 @@ MIT in each case. |# (if *block (read-bits! *block bit-offset word) (read-bits! offset 0 word)))) - word)) \ No newline at end of file + word)) + +(define-integrable (make-unsigned-reader nbits) + (let ((nbytes (fix:quotient nbits 8))) + (lambda () + (let ((offset *current-offset)) + (let ((word (read-bits offset nbits))) + (set! *current-offset (+ offset nbytes)) + (bit-string->unsigned-integer word)))))) + +(define-integrable (make-signed-reader nbits) + (let ((nbytes (fix:quotient nbits 8))) + (lambda () + (let ((offset *current-offset)) + (let ((word (read-bits offset nbits))) + (set! *current-offset (+ offset nbytes)) + (bit-string->signed-integer word)))))) + +(define next-byte (make-signed-reader 8)) +(define next-unsigned-byte (make-unsigned-reader 8)) +(define next-16-bit-word (make-signed-reader 16)) +(define next-unsigned-16-bit-word (make-unsigned-reader 16)) +(define next-32-bit-word (make-signed-reader 32)) +(define next-unsigned-32-bit-word (make-unsigned-reader 32)) + +(define (find-label offset) + (and disassembler/symbolize-output? + (disassembler/lookup-symbol *symbol-table offset))) + +(define (interpreter-register? operand) + (define (regs-pointer? reg) + (if (symbol? reg) + (eq? reg 'ESI) + (= reg 6))) + + (define (offset->register offset) + (let ((place (assq offset interpreter-register-offsets))) + (and place + (cdr place)))) + + (and (pair? operand) + (or (and (eq? (car operand) '@R) + (regs-pointer? (cadr operand)) + (offset->register 0)) + (and (eq? (car operand) '@RO) + (regs-pointer? (caddr operand)) + (offset->register (cadddr operand)))))) + +(define interpreter-register-offsets + (letrec ((make-entries + (lambda (kind offset names) + (if (null? names) + '() + (cons (cons offset `(,kind ,(car names))) + (make-entries kind + (+ offset 4) + (cdr names))))))) + (append + (make-entries + 'REGISTER 0 + '(memtop + stack-guard + val + env + compiler-temp + expr + return-code + lexpr-actuals + primitive + closure-free + closure-space)) + + (make-entries + 'ENTRY #x40 ; 16 * 4 + '(scheme-to-interface + scheme-to-interface/call + trampoline-to-interface + interrupt-procedure + interrupt-continuation + interrupt-closure + interrupt-dlink + primitive-apply + primitive-lexpr-apply + assignment-trap + reference-trap + safe-reference-trap + link + error + primitive-error + short-primitive-apply)) + + (make-entries + 'ENTRY #x-80 + '(&+ + &- + &* + &/ + &= + &< + &> + 1+ + -1+ + zero? + positive? + negative? + quotient + remainder + modulo + shortcircuit-apply ; Used by rules3, for speed. + shortcircuit-apply-size-1 ; Small frames, save time and space. + shortcircuit-apply-size-2 + shortcircuit-apply-size-3 + shortcircuit-apply-size-4 + shortcircuit-apply-size-5 + shortcircuit-apply-size-6 + shortcircuit-apply-size-7 + shortcircuit-apply-size-8))))) + +;; These are used by dassm1.scm + +(define compiled-code-block/procedure-cache-offset 1) +(define compiled-code-block/objects-per-procedure-cache 2) +(define compiled-code-block/objects-per-variable-cache 1) + +;; global variable used by runtime/udata.scm -- Moby yuck! + +(set! compiled-code-block/bytes-per-object 4) \ No newline at end of file