From ba4c80717b36bf6b46eb4c7ccc1deb2d70937ff6 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Mon, 14 Mar 1988 19:16:33 +0000 Subject: [PATCH] Change the representation of compiled procedures and other entries: They are now just the address of an instruction with a gc offset preceding the instruction and an arity/type word preceding that. Compiled closures are done by creating a tiny fake compiled code block which jumps to the right place and sets up the free variables for reference. Uuo style links are now just jump instructions to the correct address. All relocators have been updated to reflect this change. Variable caches have no type code. The relocators know about this. Incorporate JRM's fix to signal to close interrupt gap in hp-ux. New types: TC_COMPILED_ENTRY TC_MANIFEST_CLOSURE TC_LINKAGE_SECTION --- v7/src/compiler/machines/bobcat/dassm1.scm | 54 +++++++++++++++---- v7/src/compiler/machines/bobcat/dassm2.scm | 63 +++++++++++----------- v7/src/compiler/machines/bobcat/instr2.scm | 10 +++- v7/src/compiler/machines/bobcat/lapgen.scm | 34 ++++++------ 4 files changed, 99 insertions(+), 62 deletions(-) diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm index d4f2144d3..e08cb6561 100644 --- a/v7/src/compiler/machines/bobcat/dassm1.scm +++ b/v7/src/compiler/machines/bobcat/dassm1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,15 +37,13 @@ MIT in each case. |# (declare (usual-integrations)) ;;; 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))) @@ -60,6 +58,30 @@ MIT in each case. |# (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)))))) + +;;; 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 @@ -76,7 +98,7 @@ MIT in each case. |# (define (disassembler/instructions/address start-address end-address) (disassembler/instructions false start-address end-address false)) - + (define (disassembler/write-instruction-stream symbol-table instruction-stream) (fluid-let ((*unparser-radix* 16)) (disassembler/for-each-instruction instruction-stream @@ -144,11 +166,21 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index 3a294d8eb..0abf66bcc 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -77,17 +77,23 @@ MIT in each case. |# (*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))))))) (define (disassembler/initial-state) 'INSTRUCTION-NEXT) @@ -99,8 +105,7 @@ MIT in each case. |# (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)) @@ -114,11 +119,11 @@ MIT in each case. |# (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 @@ -243,23 +248,15 @@ MIT in each case. |# (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?)))))) (define (make-pc-relative thunk) (let ((reference-offset *current-offset)) diff --git a/v7/src/compiler/machines/bobcat/instr2.scm b/v7/src/compiler/machines/bobcat/instr2.scm index 96750af4d..50b6fbc3b 100644 --- a/v7/src/compiler/machines/bobcat/instr2.scm +++ b/v7/src/compiler/machines/bobcat/instr2.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -44,7 +44,13 @@ MIT in each case. |# (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)))) ;;;; BCD Arithmetic diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index b16a6732e..cb6fdb8e2 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -168,7 +168,7 @@ MIT in each case. |# (let ((result (case (car expression) ((REGISTER) - (LAP (MOV L ,(coerce->any (cadr expression)) ,target))) + (coerce->target (cadr expression) register)) ((OFFSET) (LAP (MOV L @@ -217,6 +217,12 @@ MIT in each case. |# (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) @@ -251,11 +257,8 @@ MIT in each case. |# (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))) ;;;; Registers/Entries @@ -270,16 +273,15 @@ MIT in each case. |# (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))) -- 2.25.1