(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)))
;; 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
,(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
(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)))))
;;;; 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))
(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
(define-inst entry-point label)
(define-inst jump address)
+(define-inst indirect-jump offset)
(define (inst:trap n . args)
(list (cons* 'TRAP n args)))
(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))
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))
(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))
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
}
-\f
+
insn_t *
read_uuo_target (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
}
\f
unsigned long
#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
projects / mit-scheme.git / commitdiff