From: Taylor R Campbell Date: Fri, 11 Jan 2019 06:35:27 +0000 (+0000) Subject: Use a much simpler endian-independent execute cache mechanism. X-Git-Tag: mit-scheme-pucked-10.1.10~6^2~43 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1496f4c1d507dab5521309520de5c77ba3b5d82d;p=mit-scheme.git Use a much simpler endian-independent execute cache mechanism. Requires no changes to the SVM1 byte code, so existing unlinked .com files will continue to work (except for those created in the past couple hours with my big-endian bodge that entailed no changes to the little-endian hack), although built bands will confuse the microcode because what cmpint stores in execute caches in memory changed. - Before linking, an execution cache is simply the two words, as before on little-endian systems: (fixnum) (symbol) - After linking, the frame size remains untouched and the name is replaced by the untagged address of the target: (fixnum) (untagged) - INVOCATION:UUO-LINK now generates an (indirect-jump (pc-relative )) instruction, which already does the right thing: dereferences PC + offset to find a instruction address, and then jumps to that address. --- diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm index 747cc7652..fd8c39352 100644 --- a/src/compiler/machines/svm/assembler-runtime.scm +++ b/src/compiler/machines/svm/assembler-runtime.scm @@ -163,6 +163,7 @@ USA. (add-instruction-assembler! 'LOAD (load-assembler)) (add-instruction-assembler! 'LOAD-ADDRESS (load-address-assembler)) (add-instruction-assembler! 'JUMP (jump-assembler)) + (add-instruction-assembler! 'INDIRECT-JUMP (indirect-jump-assembler)) (add-instruction-assembler! 'CONDITIONAL-JUMP (cjump1-assembler)) (add-instruction-assembler! 'CONDITIONAL-JUMP (cjump2-assembler))) @@ -268,6 +269,35 @@ USA. ;; Does not fit into a smaller number of bytes; no fixing necessary. offset)) +(define (pc-relative-stats-unsigned nbits make-sample) + (let ((high (-1+ (expt 2 nbits))) + (low 0)) + (let* ((bit-width (fixed-instruction-width (make-sample high))) + (byte-width (/ bit-width 8))) + (list nbits byte-width bit-width + (+ low byte-width) (+ high byte-width))))) + +(define (pc-relative-selector-unsigned stats make-inst) + (let ((nbits (car stats)) + (byte-width (cadr stats)) + (bit-width (caddr stats))) + (cons + (named-lambda (pc-relative-selector-handler offset) + (let ((operand (fix-offset-unsigned (- offset byte-width) nbits))) + (assemble-fixed-instruction bit-width (make-inst operand)))) + (cddr stats)))) + +(define-integrable (fix-offset-unsigned offset nbits) + (if (or (and (= nbits 16) + (let ((low 0) (high #xFF)) + (and (<= low offset) (<= offset high)))) + (and (= nbits 32) + (let ((low 0) (high #xFFFF)) + (and (<= low offset) (<= offset high))))) + (unsigned-integer->bit-string nbits offset) + ;; Does not fit into a smaller number of bytes; no fixing necessary. + offset)) + (define (store-assembler) (let ((make-sample (lambda (offset) (inst:store 'WORD rref:word-0 @@ -338,6 +368,22 @@ USA. ,(pc-relative-selector 16bit-stats make-inst) ,(pc-relative-selector 32bit-stats make-inst)))))))) +(define (indirect-jump-assembler) + (let ((make-sample (lambda (offset) + (inst:indirect-jump (ea:pc-relative offset))))) + (let (( 8bit-stats (pc-relative-stats-unsigned 8 make-sample)) + (16bit-stats (pc-relative-stats-unsigned 16 make-sample)) + (32bit-stats (pc-relative-stats-unsigned 32 make-sample))) + (rule-matcher + ((PC-RELATIVE (- (? label) *PC*))) + (let ((make-inst (lambda (offset) + (inst:indirect-jump (ea:pc-relative offset))))) + `((VARIABLE-WIDTH-EXPRESSION + (- ,label *PC*) + ,(pc-relative-selector-unsigned 8bit-stats make-inst) + ,(pc-relative-selector-unsigned 16bit-stats make-inst) + ,(pc-relative-selector-unsigned 32bit-stats make-inst)))))))) + (define (cjump2-assembler) (let ((make-sample (lambda (offset) (inst:conditional-jump 'EQ rref:word-0 rref:word-1 @@ -668,8 +714,10 @@ USA. (let ((limit (expt 2 n-bits))) (define-pvt (symbol 'UNSIGNED- n-bits) (symbol 'U n-bits) 'INTEGER (lambda (object) - (and (exact-nonnegative-integer? object) - (< object limit))) + (or (and (bit-string? object) + (= n-bits (bit-string-length object))) + (and (exact-nonnegative-integer? object) + (< object limit)))) (symbol 'ENCODE-UNSIGNED-INTEGER- n-bits) (symbol 'DECODE-UNSIGNED-INTEGER- n-bits))))) @@ -724,19 +772,30 @@ USA. ;;;; Primitive codecs (define (encode-unsigned-integer-8 n write-byte) - (write-byte n)) + (if (bit-string? n) + (write-bytes n 1 write-byte) + (write-byte n))) (define (encode-unsigned-integer-16 n write-byte) - (write-byte (remainder n #x100)) - (write-byte (quotient n #x100))) + (if (bit-string? n) + (write-bytes n 2 write-byte) + (begin + (write-byte (remainder n #x100)) + (write-byte (quotient n #x100))))) (define (encode-unsigned-integer-32 n write-byte) - (encode-unsigned-integer-16 (remainder n #x10000) write-byte) - (encode-unsigned-integer-16 (quotient n #x10000) write-byte)) + (if (bit-string? n) + (write-bytes n 4 write-byte) + (begin + (encode-unsigned-integer-16 (remainder n #x10000) write-byte) + (encode-unsigned-integer-16 (quotient n #x10000) write-byte)))) (define (encode-unsigned-integer-64 n write-byte) - (encode-unsigned-integer-32 (remainder n #x100000000) write-byte) - (encode-unsigned-integer-32 (quotient n #x100000000) write-byte)) + (if (bit-string? n) + (write-bytes n 8 write-byte) + (begin + (encode-unsigned-integer-32 (remainder n #x100000000) write-byte) + (encode-unsigned-integer-32 (quotient n #x100000000) write-byte)))) (define (decode-unsigned-integer-8 read-byte) (read-byte)) diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm index 98710395b..56ebaadd8 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -348,21 +348,17 @@ USA. (vector-ref result 0)))))) (define (read-procedure-cache block index) - (let ((word (system-vector-ref block index))) - (if (object-type? (ucode-type fixnum) word) + (let ((frame-size (system-vector-ref block index))) + (assert (object-type? (ucode-type fixnum) frame-size)) + (if (object-type? (ucode-type interned-symbol) + (system-vector-ref block (1+ index))) ;; Unlinked. - (vector 'INTERPRETED (system-vector-ref block (1+ index)) word) + (let ((name (system-vector-ref block (1+ index)))) + (vector 'INTERPRETED name frame-size)) ;; Linked. - (let ((offset (compiled-code-block/index->offset index)) - (bytes address-units-per-object)) - (let ((arity (read-unsigned-integer block offset 16)) - (opcode (read-unsigned-integer block (+ offset bytes -2) 8)) - (operand (read-unsigned-integer block (+ offset bytes -1) 8))) - (if (and (= opcode svm1-inst:ijump-u8) (= operand 0)) - (vector 'COMPILED (read-procedure block (+ offset bytes)) arity) - (error (string-append "disassembler/read-procedure-cache:" - " Unexpected instruction") - opcode operand))))))) + (let* ((offset (compiled-code-block/index->offset (1+ index))) + (procedure (read-procedure block offset))) + (vector 'COMPILED procedure frame-size))))) (define (read-procedure block offset) (with-absolutely-no-interrupts diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm index 797313789..f4bcb56fa 100644 --- a/src/compiler/machines/svm/machine.scm +++ b/src/compiler/machines/svm/machine.scm @@ -141,6 +141,7 @@ USA. (define-inst entry-point label) (define-inst jump address) +(define-inst indirect-jump offset) (define (inst:trap n . args) (list (cons* 'TRAP n args))) @@ -222,14 +223,6 @@ USA. (define (ea:address label) (ea:pc-relative `(- ,label *PC*))) -(define ea:uuo-entry-address - (let ((offset - ;; LABEL is the uuo-link-label, but the PC to jump to is two - ;; opcode bytes before the following word (the link address). - (- address-units-per-object 2))) - (named-lambda (ea:uuo-entry-address label) - (ea:pc-relative `(- (+ ,label ,offset) *PC*))))) - (define (ea:stack-pop) (ea:post-increment rref:stack-pointer 'WORD)) diff --git a/src/compiler/machines/svm/rules.scm b/src/compiler/machines/svm/rules.scm index 23d892481..40f2d2097 100644 --- a/src/compiler/machines/svm/rules.scm +++ b/src/compiler/machines/svm/rules.scm @@ -651,16 +651,16 @@ USA. continuation (expect-no-exit-interrupt-checks) (LAP ,@(clear-map!) - ,@(inst:jump (ea:uuo-entry-address - (free-uuo-link-label name frame-size))))) + ,@(inst:indirect-jump + (ea:address (free-uuo-link-label name frame-size))))) (define-rule statement (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name)) continuation (expect-no-exit-interrupt-checks) (LAP ,@(clear-map!) - ,@(inst:jump (ea:uuo-entry-address - (global-uuo-link-label name frame-size))))) + ,@(inst:indirect-jump + (ea:address (global-uuo-link-label name frame-size))))) (define-rule statement (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension)) @@ -1347,16 +1347,8 @@ USA. (lambda (cache) (let ((frame-size (car cache)) (label (cdr cache))) - (case endianness - ((BIG) - `((,name . ,label) - (#f . ,(allocate-constant-label)) - (,frame-size . ,(allocate-constant-label)))) - ((LITTLE) - `((,frame-size . ,label) - (,name . ,(allocate-constant-label)))) - (else - (error "Unknown endianness:" endianness)))))) + `((,frame-size . ,(allocate-constant-label)) + (,name . ,label))))) (cdr name.caches))) name.caches-list)) diff --git a/src/microcode/cmpintmd/svm1.c b/src/microcode/cmpintmd/svm1.c index 66f4d886b..d6c46a38e 100644 --- a/src/microcode/cmpintmd/svm1.c +++ b/src/microcode/cmpintmd/svm1.c @@ -294,80 +294,27 @@ compiled_closure_entry_to_target (insn_t * entry) the calling process without having to find and change all the places in the compiled code that refer to it. - Prior to linking, the execution cache has two pieces of - information: (1) the name of the procedure being called (a symbol), - and (2) the number of arguments that will be passed to the - procedure. It is laid out in memory like this (on a 32-bit - little-endian machine): - - 0x00 frame-size (fixnum) - 0x04 name encoded as symbol - - After linking, the cache is changed as follows: - - 0x00 frame-size (u16) - 0x02 SVM1_INST_IJUMP_U8 - 0x03 offset = 0 - 0x04 32-bit address - - On a 64-bit machine, the post-linking layout is: - - 0x00 frame-size (u16) - 0x02 4 padding bytes - 0x06 SVM1_INST_IJUMP_U8 - 0x07 offset = 0 - 0x08 64-bit address - - On a big-endian machine, the frame size comes after the - name/instructions: - - (unlinked, Scheme objects, any word size) - name encoded as symbol - padding #f - frame-size (fixnum below 2^16) - - (linked, 32-bit) - 0x00 2 padding bytes - 0x02 SVM1_INST_IJUMP_U8 - 0x03 offset = 0 - 0x04 32-bit address - 0x08 2 padding bytes - 0x0a frame-size (u16) - - (linked, 64-bit) - 0x00 6 padding bytes - 0x06 SVM1_INST_IJUMP_U8 - 0x07 offset = 0 - 0x08 64-bit address - 0x10 6 padding bytes - 0x1e frame-size (fixnum below 2^16) - */ + Initially, the execution cache stores the frame size and the name of + the procedure being called (a symbol); after linking, the name is + replaced by the (untagged) address of the code to execute. + + On real machines, execute caches usually have machine instructions + that perform the jump, but we have no need for that in SVM1 where we + already have an instruction to make an indirect jump to the address + stored at a PC-relative location in memory. */ unsigned int read_uuo_frame_size (SCHEME_OBJECT * saddr) { -#ifdef WORDS_BIGENDIAN - insn_t * addr = (((insn_t *) (saddr + 3)) - 2); - unsigned hi = (addr[0]); - unsigned lo = (addr[1]); -#else - insn_t * addr = ((insn_t *) saddr); - unsigned lo = (addr[0]); - unsigned hi = (addr[1]); -#endif - return ((hi << 8) | lo); + return (OBJECT_DATUM (saddr[0])); } SCHEME_OBJECT read_uuo_symbol (SCHEME_OBJECT * saddr) { -#ifdef WORDS_BIGENDIAN - return (saddr[0]); -#else return (saddr[1]); -#endif } - + insn_t * read_uuo_target (SCHEME_OBJECT * saddr) { @@ -383,40 +330,7 @@ read_uuo_target_no_reloc (SCHEME_OBJECT * saddr) void write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr) { - unsigned long frame_size = (read_uuo_frame_size (saddr)); - insn_t * addr = ((insn_t *) saddr); - insn_t * end = ((insn_t *) (saddr + 1)); - -#ifndef WORDS_BIGENDIAN - /* Write the frame size. */ - (*addr++) = (frame_size & 0x00FF); - (*addr++) = ((frame_size & 0xFF00) >> 8); -#endif - - /* Pad to a word boundary, minus two bytes. */ - while (addr < (end - 2)) - (*addr++) = 0; - - /* Write the instruction prefix. */ - (*addr++) = SVM1_INST_IJUMP_U8; - (*addr++) = 0; - - /* We now have a word-aligned address. Write the target here. */ - assert (addr == ((insn_t *) (saddr + 1))); (saddr[1]) = ((SCHEME_OBJECT) target); - -#ifdef WORDS_BIGENDIAN - /* Pad to a word boundary, minus one 16-bit quantity. */ - addr = ((insn_t *) (saddr + 2)); - end = ((insn_t *) (saddr + 3)); - while (addr < (end - 2)) - (*addr++) = 0; - - /* Write the frame size. */ - (*addr++) = ((frame_size & 0xFF00) >> 8); - (*addr++) = (frame_size & 0x00FF); - assert (addr == ((insn_t *) (saddr + 3))); -#endif } unsigned long diff --git a/src/microcode/cmpintmd/svm1.h b/src/microcode/cmpintmd/svm1.h index 09a556745..67c1746c6 100644 --- a/src/microcode/cmpintmd/svm1.h +++ b/src/microcode/cmpintmd/svm1.h @@ -62,11 +62,7 @@ typedef uint8_t insn_t; #define CLOSURE_ENTRY_SIZE 5 /* Size of execution cache in SCHEME_OBJECTS. */ -#ifdef WORDS_BIGENDIAN -#define UUO_LINK_SIZE 3 -#else #define UUO_LINK_SIZE 2 -#endif #define READ_UUO_TARGET(a, r) read_uuo_target (a) #define UTILITY_RESULT_DEFINED 1