From 6c0dceefff6ab02c645c4eae40ad2be0e44d8bcf Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 12 Jun 2010 17:50:08 -0700 Subject: [PATCH] Finished the disassembler. Debugging the machine (too). * src/Makefile.in: Make sure the assembler-compiler ran, generating compiler/machines/svm/svm1-defns.h, assembler-db.scm, etc. * src/Stage.sh: Punt avoiding subdirs with nothing to stage. A few empty STAGE subdirs should not hurt, and maybe_mv is quiet. * src/compiler/Clean.sh (distclean, maintainer-clean): Use maybe_rm and clean up assembler compilation products. * src/compiler/Stage.sh, src/etc/Stage.sh: Use maybe_mv to avoid errors when the subdir has not been compiled, so that an incomplete compile can be stashed and unstashed without horror. * src/compiler/machines/svm/assembler-compiler.scm (write-copyright+license): Resurrected with the 9.0.1 runtime system's procedures. Used to generate the standard copyright though the GNU standards suggest assembler-db's copyright should be copied. (rt-defn-encoder-constructor): Include the opcode byte. * src/compiler/machines/svm/assembler-rules.scm (interrupt-test-closure): Folded into the enter-closure instruction, which knows the index. * src/compiler/machines/svm/assembler-runtime.scm (init-assembler-instructions!): Build fixed instruction assemblers in smallest-to-largest order, else the largest encoding is always chosen. (assemble-fixed-instruction): Punt consing a new bit-string. (pc-relative-stats, pc-relative-selector): New. The former computes static info about a class of variable-width instructions so that the latter need only cons a handler. Use these in the variable-width instruction encoders. (fix-offset): Fix the width of a pc-relative offset, to force a wider encoding than required by the actual magnitude. Use this procedure in the primitive encoders. The bit tensioner cannot always find an optimal solution, where no instruction is wider than its operands require. Warn when this happens. (decode-rt-coding-type): Return a list headed by the rt-defn name, else signal a coding-error. (coding-error): Signals a condition that the disassembler wants to catch. (define-pvt-signed, encode-signed-*, write-bytes): Accept bit-strings as well as integers. See fix-offset. (encode-unsigned-integer-8): Fixed. (decode-rref): Give symbolic names to the fixed registers. * src/compiler/machines/svm/compiler.pkg: Moved the (compiler disassembler) package to inherit from (compiler assembler). The disassembler uses many definitions in assembler-runtime.scm. * src/compiler/machines/svm/compiler.sf: Syntax make.scm. It is not mentioned in compiler.pkg, from which syntax-files!(decls.scm) gets its list of files to syntax. * src/compiler/machines/svm/decls.scm: Moved lapgen.scm from lapgen-base to lapgen-body because it depends on assembler-runtime. * src/compiler/machines/svm/disassembler.scm: New. * src/compiler/machines/svm/lapgen.scm: Get the entry-types right with those used in svm1-interp.c. (encode-procedure-type): Take the frame size min/max per the RTL, and convert them to required/optional arg counts. Use this in generate/cons-*closure as well as make-procedure-label. (encode-internal-procedure-offset): Punted. This encoding is also generated by encode-continuation-offset. * src/compiler/machines/svm/machine.scm (ea:uuo-entry-address): New, encoding a peculiar type of pc-relative address. (trap:set!, trap:define, trap:unbound?, trap:access): Not defined in svm1-interp.c. (interrupt-test-closure): Folded into the enter-closure instruction. (closure-entry-size, entry-type-size, closure-first-offset): Added an cc-entry type field to each closure entry. * src/compiler/machines/svm/rules.scm (POP-RETURN): Added entry-type and gc-offset half words before inst:interrupt-test-continuation, so that this instruction can push its address on the stack. (INVOCATION:UUO-LINK, INVOCATION:GLOBAL-LINK): Use the new ea:uuo-entry-address. (PROCEDURE-HEADER): Pass min/max directly to make-procedure-label (generate/cons-closure, generate/cons-multiclosure): Added a cc-entry type field before each entry point. Do NOT tag the target register. No need to interrupt-test-closure after entering. (generate-uuos): This is not actually generating LAP. (interpreter-call:cache-reference, interpreter-call:cache-assignment): (interpreter-call:cache-unassigned?): Need an entry point after the trap instructions. (Interpreter Calls, lookup-call, assignment-call): Removed. I could not find the corresponding compiler utilities: comutil_access, comutil_define, comutil_set, comutil_unbound_p_trap. The utilities I DID find want a cache address. Removing these rules left lookup-call and assignment-call unused. * src/etc/compile-svm.sh: Use src/Stage.sh to un/stash the cross-compiler. * src/microcode/cmpint.c, src/microcode/cmpint.h: Move trampoline_type_t to cmpint.h, where svm1-interp.c can include it. * src/microcode/cmpintmd/svm1.c: Use new closure entry point type field in read_cc_entry_type. (store_trampoline_insns): Translate from abstract trampoline kinds to trap-0 operations, e.g. TRAMPOLINE_K_APPLY to SVM1_TRAP_0_OPERATOR_APPLY. * src/microcode/cmpintmd/svm1.h: * src/microcode/svm1-defns.h: * src/microcode/svm1-interp.c: --- src/Makefile.in | 8 +- src/Stage.sh | 9 +- src/compiler/Clean.sh | 10 +- src/compiler/Stage.sh | 11 +- .../machines/svm/assembler-compiler.scm | 53 +- src/compiler/machines/svm/assembler-rules.scm | 1 - .../machines/svm/assembler-runtime.scm | 391 +++++++++------ src/compiler/machines/svm/compiler.pkg | 2 +- src/compiler/machines/svm/compiler.sf | 7 +- src/compiler/machines/svm/disassembler.scm | 465 +++++++++++++++++- src/compiler/machines/svm/lapgen.scm | 50 +- src/compiler/machines/svm/machine.scm | 28 +- src/compiler/machines/svm/rules.scm | 153 +++--- src/etc/Stage.sh | 9 +- src/etc/compile-svm.sh | 52 +- src/microcode/cmpint.c | 23 - src/microcode/cmpint.h | 23 + src/microcode/cmpintmd/svm1.c | 125 ++--- src/microcode/cmpintmd/svm1.h | 14 +- src/microcode/svm1-defns.h | 120 ++--- src/microcode/svm1-interp.c | 146 +++--- 21 files changed, 1123 insertions(+), 577 deletions(-) diff --git a/src/Makefile.in b/src/Makefile.in index d124d1e51..52d736c63 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -83,7 +83,12 @@ all-svm: microcode/svm1-defns.h @$(top_srcdir)/etc/compile-svm.sh "$(MIT_SCHEME_EXE)" $(MAKE) build-bands -microcode/svm1-defns.h: compiler/machines/svm/assembler-rules.scm \ +microcode/svm1-defns.h: compiler/machines/svm/svm1-defns.h + if cmp compiler/machines/svm/svm1-defns.h microcode/svm1-defns.h; \ + then cp compiler/machines/svm/svm1-defns.h microcode/svm1-defns.h; fi + +compiler/machines/svm/svm1-defns.h: \ + compiler/machines/svm/assembler-rules.scm \ compiler/machines/svm/machine.scm \ compiler/machines/svm/assembler-compiler.scm \ compiler/machines/svm/assembler-runtime.scm \ @@ -91,7 +96,6 @@ microcode/svm1-defns.h: compiler/machines/svm/assembler-rules.scm \ ( cd compiler/machines/svm/ \ && $(MIT_SCHEME_EXE) --batch-mode --load compile-assembler \ c-string (pathname-name pathname) #t) "_H"))) - (write-string "/* -*-C-*-\n\n DO NOT EDIT." port) - (write-string " This file was generated by a program.\n\n" port) - (write-string "*/\n\n" port) + (write-string "/* -*-C-*-\n\n" port) + (write-copyright+license pathname port) + (write-string "\n*/\n\n" port) (write-string "/* " port) (write-string title port) (write-string " */\n\n" port) @@ -848,6 +847,17 @@ USA. (write-item (last items) port) (newline port)) +(define (write-copyright+license pathname port) + pathname + (write-string "DO NOT EDIT: this file was generated by a program." port) + (newline port) + (newline port) + (write-mit-scheme-copyright port "" "(C)" #t) + (newline port) + (newline port) + (write-mit-scheme-license port "" #t) + (newline port)) + (define (name->c-string name upcase?) (name-string->c-string (symbol-name name) upcase?)) @@ -988,16 +998,27 @@ USA. (define (rt-defn-encoder-constructor defn) `(LAMBDA (INSTANCE WRITE-BYTE) - ,@(if (null? (defn-coding defn)) - '(INSTANCE WRITE-BYTE UNSPECIFIC) - (map (lambda (item) - (let ((pval `(RT-INSTANCE-PVAL ',(pvar-name item) INSTANCE)) - (pvt (lookup-pvar-type (pvar-type item)))) - (if pvt - `(,(pvt-encoder pvt) ,pval WRITE-BYTE) - `(LET ((PVAL ,pval)) - ((RT-INSTANCE-ENCODER PVAL) PVAL WRITE-BYTE))))) - (defn-coding defn))))) + ,@(if (null? (defn-coding defn)) + (let ((code (defn-code defn))) + (if code + `(INSTANCE + (WRITE-BYTE ,code)) + (error "Nothing to encode:" defn))) + `(,@(let ((code (defn-code defn))) + (if code + `((WRITE-BYTE ,code)) + ;; The datum-* pseudo-instructions have no (op)code. + '())) + ,@(map (lambda (item) + (let ((pval `(RT-INSTANCE-PVAL + ',(pvar-name item) INSTANCE)) + (pvt (lookup-pvar-type (pvar-type item)))) + (if pvt + `(,(pvt-encoder pvt) ,pval WRITE-BYTE) + `(LET ((PVAL ,pval)) + ((RT-INSTANCE-ENCODER PVAL) + PVAL WRITE-BYTE))))) + (defn-coding defn)))))) (define (rt-defn-decoder-constructor defn) (let ((pvars (defn-pvars defn))) diff --git a/src/compiler/machines/svm/assembler-rules.scm b/src/compiler/machines/svm/assembler-rules.scm index 80514dfb6..be0214b4b 100644 --- a/src/compiler/machines/svm/assembler-rules.scm +++ b/src/compiler/machines/svm/assembler-rules.scm @@ -437,7 +437,6 @@ USA. (define-code-sequence instruction (interrupt-test-procedure)) (define-code-sequence instruction (interrupt-test-dynamic-link)) -(define-code-sequence instruction (interrupt-test-closure)) (define-code-sequence instruction (interrupt-test-ic-procedure)) (define-code-sequence instruction (interrupt-test-continuation)) diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm index 6aa470c07..7f3cdc50b 100644 --- a/src/compiler/machines/svm/assembler-runtime.scm +++ b/src/compiler/machines/svm/assembler-runtime.scm @@ -142,9 +142,7 @@ USA. ;; Initialize the assembler's instruction database using the ;; patterns and encoders in the instruction coding type (the ;; "fixed-width instruction" assemblers) as well as special - ;; assemblers that create variable-width-expressions and other - ;; assembler expressions as required by the machine-independent, - ;; top-level, branch-tensioning assembler. + ;; assemblers that create variable-width-expressions. (clear-instructions!) @@ -154,7 +152,9 @@ USA. (lambda (keyword.defns) (add-instruction! (car keyword.defns) - (map fixed-instruction-assembler (cdr keyword.defns)))) + (map fixed-instruction-assembler + ;; Instruction-keywords reverses the definitions. + (reverse! (cdr keyword.defns))))) (instruction-keywords)) ;; Create the variable width instruction assemblers. @@ -218,151 +218,162 @@ USA. (define (assemble-fixed-instruction width lap) (if (and (pair? lap) (pair? (car lap)) (null? (cdr lap))) - (let ((bits (list->bit-string (lap:syntax-instruction (car lap))))) - (if (not (= width (bit-string-length bits))) + (let* ((bits (lap:syntax-instruction (car lap))) + (len (reduce-left + 0 (map bit-string-length bits)))) + (if (not (= len width)) (error "Mis-sized fixed instruction" lap)) - (list bits)) + bits) (error "ASSEMBLE-FIXED-INSTRUCTION: Multiple instructions in LAP" lap))) +(define (pc-relative-stats nbits make-sample) + ;; Returns a list: the byte and bit widths for a class of + ;; variable-width instructions (calculated by measuring a + ;; representative assembled by MAKE-SAMPLE) and the range of offsets + ;; encodable by each. + ;; + ;; The variable-width expression refers to *PC*, which is the PC at + ;; the beginning of this instruction. The instruction will actually + ;; use the PC at the beginning of the next instruction. Thus the + ;; actual range of the encoding is translated upward by this + ;; instruction's width, and the actual offset translated back again + ;; in the pc-relative-selector-handler. + (let ((high (-1+ (expt 2 (-1+ nbits)))) + (low (- (expt 2 (-1+ nbits))))) + (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 stats make-inst) + ;; Create a selector for a variable-width-expression using the stats + ;; calculated earlier by pc-relative-stats. + (let ((nbits (car stats)) + (byte-width (cadr stats)) + (bit-width (caddr stats))) + (cons + (named-lambda (pc-relative-selector-handler offset) + (let ((operand (fix-offset (- offset byte-width) nbits))) + (assemble-fixed-instruction bit-width (make-inst operand)))) + (cddr stats)))) + +(define-integrable (fix-offset offset nbits) + (if (or (and (= nbits 16) + (let ((low #x-80) (high #x7F)) + (and (<= low offset) (<= offset high)))) + (and (= nbits 32) + (let ((low #x-8000) (high #x7FFF)) + (and (<= low offset) (<= offset high))))) + (begin + (warn "Bit tensioner widened encoding" nbits offset) + (signed-integer->bit-string nbits offset)) + ;; Does not fit into a smaller number of bytes; no fixing necessary. + offset)) + (define (store-assembler) - (let ((8bit-width - (fixed-instruction-width - (inst:store 'WORD rref:word-0 (ea:pc-relative #x7F)))) - (16bit-width - (fixed-instruction-width - (inst:store 'BYTE rref:word-1 (ea:pc-relative #x7FFF)))) - (32bit-width - (fixed-instruction-width - (inst:store 'WORD rref:word-2 (ea:pc-relative #x7FFFFFFF))))) - (rule-matcher - ((? scale) (? source) (PC-RELATIVE (- (? addr1) (? addr2)))) - (let ((assembler - (lambda (width) - (lambda (value) - (assemble-fixed-instruction - width (inst:store scale source (ea:pc-relative value))))))) - `((VARIABLE-WIDTH-EXPRESSION - (- ,addr1 ,addr2) - (,(assembler 8bit-width) ,8bit-width #x-80 #x7F) - (,(assembler 16bit-width) ,16bit-width #x-8000 #x7FFF) - (,(assembler 32bit-width) ,32bit-width #x-80000000 #x7FFFFFFF))))))) + (let ((make-sample (lambda (offset) + (inst:store 'WORD rref:word-0 + (ea:pc-relative offset))))) + (let (( 8bit-stats (pc-relative-stats 8 make-sample)) + (16bit-stats (pc-relative-stats 16 make-sample)) + (32bit-stats (pc-relative-stats 32 make-sample))) + (rule-matcher + ((? scale) (? source) (PC-RELATIVE (- (? label) *PC*))) + (let ((make-inst (lambda (offset) + (inst:store scale source + (ea:pc-relative offset))))) + `((VARIABLE-WIDTH-EXPRESSION + (- ,label *PC*) + ,(pc-relative-selector 8bit-stats make-inst) + ,(pc-relative-selector 16bit-stats make-inst) + ,(pc-relative-selector 32bit-stats make-inst)))))))) (define (load-assembler) - (let ((8bit-width - (fixed-instruction-width - (inst:load 'WORD rref:word-0 (ea:pc-relative #x7F)))) - (16bit-width - (fixed-instruction-width - (inst:load 'BYTE rref:word-1 (ea:pc-relative #x7FFF)))) - (32bit-width - (fixed-instruction-width - (inst:load 'WORD rref:word-2 (ea:pc-relative #x7FFFFFFF))))) - (rule-matcher - ((? scale) (? target) (PC-RELATIVE (- (? addr1) (? addr2)))) - (let ((assembler - (lambda (width) - (lambda (value) - (assemble-fixed-instruction - width (inst:load scale target (ea:pc-relative value))))))) - `((VARIABLE-WIDTH-EXPRESSION - (- ,addr1 ,addr2) - (,(assembler 8bit-width) ,8bit-width #x-80 #x7F) - (,(assembler 16bit-width) ,16bit-width #x-8000 #x7FFF) - (,(assembler 32bit-width) ,32bit-width #x-80000000 #x7FFFFFFF))))))) + (let ((make-sample (lambda (offset) + (inst:load 'WORD rref:word-0 + (ea:pc-relative offset))))) + (let (( 8bit-stats (pc-relative-stats 8 make-sample)) + (16bit-stats (pc-relative-stats 16 make-sample)) + (32bit-stats (pc-relative-stats 32 make-sample))) + (rule-matcher + ((? scale) (? target) (PC-RELATIVE (- (? label) *PC*))) + (let ((make-inst (lambda (offset) + (inst:load scale target + (ea:pc-relative offset))))) + `((VARIABLE-WIDTH-EXPRESSION + (- ,label *PC*) + ,(pc-relative-selector 8bit-stats make-inst) + ,(pc-relative-selector 16bit-stats make-inst) + ,(pc-relative-selector 32bit-stats make-inst)))))))) (define (load-address-assembler) - (let ((8bit-width - (fixed-instruction-width - (inst:load-address rref:word-0 (ea:pc-relative #x7F)))) - (16bit-width - (fixed-instruction-width - (inst:load-address rref:word-1 (ea:pc-relative #x7FFF)))) - (32bit-width - (fixed-instruction-width - (inst:load-address rref:word-2 (ea:pc-relative #x7FFFFFFF))))) - (rule-matcher - ((? target) (PC-RELATIVE (- (? addr1) (? addr2)))) - (let ((assembler - (lambda (width) - (lambda (value) - (assemble-fixed-instruction - width (inst:load-address target (ea:pc-relative value))))))) - `((VARIABLE-WIDTH-EXPRESSION - (- ,addr1 ,addr2) - (,(assembler 8bit-width) ,8bit-width #x-80 #x7F) - (,(assembler 16bit-width) ,16bit-width #x-8000 #x7FFF) - (,(assembler 32bit-width) ,32bit-width #x-80000000 #x7FFFFFFF))))))) + (let ((make-sample (lambda (offset) + (inst:load-address rref:word-0 + (ea:pc-relative offset))))) + (let (( 8bit-stats (pc-relative-stats 8 make-sample)) + (16bit-stats (pc-relative-stats 16 make-sample)) + (32bit-stats (pc-relative-stats 32 make-sample))) + (rule-matcher + ((? target) (PC-RELATIVE (- (? label) *PC*))) + (let ((make-inst (lambda (offset) + (inst:load-address target + (ea:pc-relative offset))))) + `((VARIABLE-WIDTH-EXPRESSION + (- ,label *PC*) + ,(pc-relative-selector 8bit-stats make-inst) + ,(pc-relative-selector 16bit-stats make-inst) + ,(pc-relative-selector 32bit-stats make-inst)))))))) (define (jump-assembler) - (let ((8bit-width - (fixed-instruction-width (inst:jump (ea:pc-relative #x7F)))) - (16bit-width - (fixed-instruction-width (inst:jump (ea:pc-relative #x7FFF)))) - (32bit-width - (fixed-instruction-width (inst:jump (ea:pc-relative #x7FFFFFFF))))) - (rule-matcher - ((PC-RELATIVE (- (? addr1) (? addr2)))) - (let ((assembler - (lambda (width) - (lambda (value) - (assemble-fixed-instruction - width (inst:jump (ea:pc-relative value))))))) - `((VARIABLE-WIDTH-EXPRESSION - (- ,addr1 ,addr2) - (,(assembler 8bit-width) ,8bit-width #x-80 #x7F) - (,(assembler 16bit-width) ,16bit-width #x-8000 #x7FFF) - (,(assembler 32bit-width) ,32bit-width #x-80000000 #x7FFFFFFF))))))) + (let ((make-sample (lambda (offset) + (inst:jump (ea:pc-relative offset))))) + (let (( 8bit-stats (pc-relative-stats 8 make-sample)) + (16bit-stats (pc-relative-stats 16 make-sample)) + (32bit-stats (pc-relative-stats 32 make-sample))) + (rule-matcher + ((PC-RELATIVE (- (? label) *PC*))) + (let ((make-inst (lambda (offset) + (inst:jump (ea:pc-relative offset))))) + `((VARIABLE-WIDTH-EXPRESSION + (- ,label *PC*) + ,(pc-relative-selector 8bit-stats make-inst) + ,(pc-relative-selector 16bit-stats make-inst) + ,(pc-relative-selector 32bit-stats make-inst)))))))) (define (cjump2-assembler) - (let ((8bit-width - (fixed-instruction-width - (inst:conditional-jump 'EQ rref:word-0 rref:word-1 - (ea:pc-relative #x7F)))) - (16bit-width - (fixed-instruction-width - (inst:conditional-jump 'EQ rref:word-0 rref:word-1 - (ea:pc-relative #x7FFF)))) - (32bit-width - (fixed-instruction-width - (inst:conditional-jump 'EQ rref:word-0 rref:word-1 - (ea:pc-relative #x7FFFFFFF))))) - (rule-matcher - ((? test) (? src1) (? src2) (PC-RELATIVE (- (? addr1) (? addr2)))) - (let ((assembler - (lambda (width) - (lambda (value) - (assemble-fixed-instruction - width (inst:conditional-jump test src1 src2 - (ea:pc-relative value))))))) - `((VARIABLE-WIDTH-EXPRESSION - (- ,addr1 ,addr2) - (,(assembler 8bit-width) ,8bit-width #x-80 #x7F) - (,(assembler 16bit-width) ,16bit-width #x-8000 #x7FFF) - (,(assembler 32bit-width) ,32bit-width #x-80000000 #x7FFFFFFF))))))) + (let ((make-sample (lambda (offset) + (inst:conditional-jump 'EQ rref:word-0 rref:word-1 + (ea:pc-relative offset))))) + (let (( 8bit-stats (pc-relative-stats 8 make-sample)) + (16bit-stats (pc-relative-stats 16 make-sample)) + (32bit-stats (pc-relative-stats 32 make-sample))) + (rule-matcher + ((? test) (? src1) (? src2) (PC-RELATIVE (- (? label) *PC*))) + (let ((make-inst (lambda (offset) + (inst:conditional-jump test src1 src2 + (ea:pc-relative offset))))) + `((VARIABLE-WIDTH-EXPRESSION + (- ,label *PC*) + ,(pc-relative-selector 8bit-stats make-inst) + ,(pc-relative-selector 16bit-stats make-inst) + ,(pc-relative-selector 32bit-stats make-inst)))))))) (define (cjump1-assembler) - (let ((8bit-width - (fixed-instruction-width - (inst:conditional-jump 'EQ rref:word-0 (ea:pc-relative #x7F)))) - (16bit-width - (fixed-instruction-width - (inst:conditional-jump 'EQ rref:word-0 (ea:pc-relative #x7FFF)))) - (32bit-width - (fixed-instruction-width - (inst:conditional-jump 'EQ rref:word-0 (ea:pc-relative #x7FFFFFFF))))) - (rule-matcher - ((? test) (? source) (PC-RELATIVE (- (? addr1) (? addr2)))) - (let ((assembler - (lambda (width) - (lambda (value) - (assemble-fixed-instruction - width (inst:conditional-jump test source - (ea:pc-relative value))))))) - `((VARIABLE-WIDTH-EXPRESSION - (- ,addr1 ,addr2) - (,(assembler 8bit-width) ,8bit-width #x-80 #x7F) - (,(assembler 16bit-width) ,16bit-width #x-8000 #x7FFF) - (,(assembler 32bit-width) ,32bit-width #x-80000000 #x7FFFFFFF))))))) + (let ((make-sample (lambda (offset) + (inst:conditional-jump 'EQ rref:word-0 + (ea:pc-relative offset))))) + (let (( 8bit-stats (pc-relative-stats 8 make-sample)) + (16bit-stats (pc-relative-stats 16 make-sample)) + (32bit-stats (pc-relative-stats 32 make-sample))) + (rule-matcher + ((? test) (? source) (PC-RELATIVE (- (? label) *PC*))) + (let ((make-inst (lambda (offset) + (inst:conditional-jump test source + (ea:pc-relative offset))))) + `((VARIABLE-WIDTH-EXPRESSION + (- ,label *PC*) + ,(pc-relative-selector 8bit-stats make-inst) + ,(pc-relative-selector 16bit-stats make-inst) + ,(pc-relative-selector 32bit-stats make-inst)))))))) (define (match-rt-coding-type name expression symbol-table) (let loop ((defns (rt-coding-type-defns (rt-coding-type name)))) @@ -378,20 +389,45 @@ USA. (define (decode-rt-coding-type name read-byte) (let ((type (rt-coding-type name)) (code (read-byte))) - (let ((rcd - (find-matching-item (rt-coding-type-defns type) - (lambda (rcd) - (eqv? (rt-defn-code rcd) code))))) - (if (not rcd) - (error "No matching code:" code type)) - (make-rt-instance rcd ((rt-defn-decoder rcd) - read-byte rt-coding-types))))) + (let ((defn + (find-matching-item (rt-coding-type-defns type) + (lambda (defn) + (eqv? (rt-defn-code defn) code))))) + (if defn + (cons (rt-defn-name defn) + ((rt-defn-decoder defn) read-byte)) + (coding-error code type))))) (define (rt-coding-type name) (or (find-matching-item rt-coding-types (lambda (rt-coding-type) (eq? (rt-coding-type-name rt-coding-type) name))) (error:bad-range-argument name 'RT-CODING-TYPE))) + +(define condition-type:coding-error + (make-condition-type + 'rt-coding-error + condition-type:error + '(INVALID-CODE CODING-TYPE) + (lambda (condition port) + (write-string "Coding error: 0x" port) + (write-string (number->string (access-condition condition 'INVALID-CODE) + 16) port) + (write-string " is not a valid " port) + (write (access-condition condition 'CODING-TYPE) port) + (write-string " rt-coding-type." port)))) + +(define coding-error + (let ((signaller (condition-signaller condition-type:coding-error + '(INVALID-CODE CODING-TYPE) + standard-error-handler))) + (named-lambda (coding-error code type) + (call-with-current-continuation + (lambda (continuation) + (with-restart 'CONTINUE "Continue with the next byte." + (lambda () (continuation `(WORD U ,code))) + values + (lambda () (signaller code type)))))))) ;;;; Assembler Machine Dependencies @@ -595,9 +631,11 @@ USA. (let ((limit (expt 2 (- n-bits 1)))) (define-pvt (symbol 'SIGNED- n-bits) (symbol 'S n-bits) 'INTEGER (lambda (object) - (and (exact-integer? object) - (>= object (- limit)) - (< object limit))) + (or (and (bit-string? object) + (= n-bits (bit-string-length object))) + (and (exact-integer? object) + (>= object (- limit)) + (< object limit)))) (symbol 'ENCODE-SIGNED-INTEGER- n-bits) (symbol 'DECODE-SIGNED-INTEGER- n-bits))))) @@ -635,8 +673,7 @@ USA. ;;;; Primitive codecs (define (encode-unsigned-integer-8 n write-byte) - (write-byte (remainder n #x100)) - (write-byte (quotient n #x100))) + (write-byte n)) (define (encode-unsigned-integer-16 n write-byte) (write-byte (remainder n #x100)) @@ -666,27 +703,46 @@ USA. (+ (* (decode-unsigned-integer-32 read-byte) #x100000000) d0))) (define (encode-signed-integer-8 n write-byte) - (write-byte (if (fix:< n 0) - (fix:+ n #x100) - n))) + (if (bit-string? n) + (write-bytes n 1 write-byte) + (write-byte (if (fix:< n 0) + (fix:+ n #x100) + n)))) (define (encode-signed-integer-16 n write-byte) - (encode-unsigned-integer-16 (if (fix:< n 0) - (fix:+ n #x10000) - n) - write-byte)) + (if (bit-string? n) + (write-bytes n 2 write-byte) + (encode-unsigned-integer-16 (if (fix:< n 0) + (fix:+ n #x10000) + n) + write-byte))) (define (encode-signed-integer-32 n write-byte) - (encode-unsigned-integer-32 (if (< n 0) - (+ n #x100000000) - n) - write-byte)) + (if (bit-string? n) + (write-bytes n 4 write-byte) + (encode-unsigned-integer-32 (if (< n 0) + (+ n #x100000000) + n) + write-byte))) (define (encode-signed-integer-64 n write-byte) - (encode-unsigned-integer-64 (if (< n 0) - (+ n #x10000000000000000) - n) - write-byte)) + (if (bit-string? n) + (write-bytes n 8 write-byte) + (encode-unsigned-integer-64 (if (< n 0) + (+ n #x10000000000000000) + n) + write-byte))) + +(define (write-bytes bits bytes write-byte) + (if (not (= (* bytes 8) (bit-string-length bits))) + (error "Wrong number of bytes" bytes bits)) + (let loop ((start 0) + (end (bit-string-length bits))) + (if (fix:< start end) + (let ((next (fix:+ start 8))) + (write-byte (bit-string->unsigned-integer + (bit-substring bits start next))) + (loop next end))))) (define (decode-signed-integer-8 read-byte) (let ((n (read-byte))) @@ -779,4 +835,11 @@ USA. write-byte))) (define (decode-rref read-byte) - (register-reference (decode-unsigned-integer-8 read-byte))) \ No newline at end of file + (let ((regnum (decode-unsigned-integer-8 read-byte))) + (list 'R + (cond ((= regnum regnum:interpreter-register-block) 'IBLOCK) + ((= regnum regnum:stack-pointer) 'SP) + ((= regnum regnum:free-pointer) 'FREE) + ((= regnum regnum:value) 'VALUE) + ((= regnum regnum:dynamic-link) 'DLINK) + (else regnum))))) \ No newline at end of file diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index cef0dceb2..5668454a5 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -746,7 +746,7 @@ USA. (define-package (compiler disassembler) (files "machines/svm/disassembler") - (parent (compiler)) + (parent (compiler assembler)) (export () compiler:write-lap-file compiler:disassemble) diff --git a/src/compiler/machines/svm/compiler.sf b/src/compiler/machines/svm/compiler.sf index f0d149fee..ecf826cf6 100644 --- a/src/compiler/machines/svm/compiler.sf +++ b/src/compiler/machines/svm/compiler.sf @@ -40,13 +40,9 @@ USA. ;; Guarantee that the necessary syntactic transforms and optimizers ;; are loaded. (if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!) - ;; Refer to the cref package model (compiler.pkg) for syntax/load - ;; environments. + ;; Assume there are no os-type-specific files or packages. (let* ((xref (->environment '(cross-reference))) - - ;; Assume there are no os-type-specific files or packages. (pmodel ((access read-package-model xref) "compiler" 'unix)) - (env (lambda (filename) (->environment @@ -88,6 +84,7 @@ USA. ;; Resyntax any files that need it. ((access syntax-files! (->environment '(COMPILER)))) +(sf-conditionally "make") ;; Rebuild the package constructors and cref. (cref/generate-constructors "compiler" 'ALL) \ No newline at end of file diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm index 23394bf93..236801e55 100644 --- a/src/compiler/machines/svm/disassembler.scm +++ b/src/compiler/machines/svm/disassembler.scm @@ -1,8 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009 Massachusetts Institute of Technology +Copyright (C) 2010 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -38,8 +36,465 @@ USA. ;;;; Top level entries (define (compiler:write-lap-file filename #!optional symbol-table?) - (error "unimplemented" 'compiler:write-lap-file filename + (let ((pathname (->pathname filename)) + (symbol-table? (if (default-object? symbol-table?) #t symbol-table?))) + (with-output-to-file (pathname-new-type pathname "lap") + (lambda () + (let ((com-file (pathname-new-type pathname "com"))) + (let ((object (fasload com-file))) + (if (compiled-code-address? object) + (let ((block (compiled-code-address->block object))) + (disassembler/write-compiled-code-block + block + (compiled-code-block/dbg-info block symbol-table?))) + (begin + (if (not + (and (scode/comment? object) + (dbg-info-vector? (scode/comment-text object)))) + (error "Not a compiled file" com-file)) + (let ((blocks + (vector->list + (dbg-info-vector/blocks-vector + (scode/comment-text object))))) + (if (not (null? blocks)) + (do ((blocks blocks (cdr blocks))) + ((null? blocks) unspecific) + (disassembler/write-compiled-code-block + (car blocks) + (compiled-code-block/dbg-info (car blocks) + symbol-table?)) + (if (not (null? (cdr blocks))) + (begin + (write-char #\page) + (newline)))))))))))))) + +(define disassembler/base-address) (define (compiler:disassemble entry) - (error "unimplemented" 'compiler:disassemble entry)) \ No newline at end of file + (let ((block (compiled-entry/block entry))) + (let ((info (compiled-code-block/dbg-info block #t))) + (fluid-let ((disassembler/write-offsets? #t) + (disassembler/write-addresses? #t) + (disassembler/base-address (object-datum block))) + (newline) + (newline) + (disassembler/write-compiled-code-block block info))))) + +(define (disassembler/write-compiled-code-block block info) + (let ((symbol-table (and info (dbg-info/labels info)))) + (write-string "Disassembly of ") + (write block) + (call-with-values + (lambda () (compiled-code-block/filename-and-index block)) + (lambda (filename index) + (if filename + (begin + (write-string " (Block ") + (write index) + (write-string " in ") + (write-string filename) + (write-string ")"))))) + (write-string ":\n") + (write-string "Code:\n\n") + (disassembler/write-instruction-stream + symbol-table + (disassembler/instructions/compiled-code-block block symbol-table)) + (write-string "\nConstants:\n\n") + (disassembler/write-constants-block block symbol-table) + (newline))) + +(define (disassembler/instructions/compiled-code-block block symbol-table) + (disassembler/instructions block + (compiled-code-block/code-start block) + (compiled-code-block/code-end block) + symbol-table)) + +(define (disassembler/instructions/address start-address end-address) + (disassembler/instructions #f start-address end-address #f)) + +(define (disassembler/write-instruction-stream symbol-table instruction-stream) + (fluid-let ((*unparser-radix* 16)) + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction comment) + (disassembler/write-instruction + symbol-table + offset + (lambda () + (if comment + (let ((s (with-output-to-string + (lambda () (display instruction))))) + (if (< (string-length s) 40) + (write-string (string-pad-right s 40)) + (write-string s)) + (write-string "; ") + (display comment)) + (write instruction)))))))) + +(define (disassembler/for-each-instruction instruction-stream procedure) + (let loop ((instruction-stream instruction-stream)) + (if (not (disassembler/instructions/null? instruction-stream)) + (disassembler/instructions/read instruction-stream + (lambda (offset instruction comment instruction-stream) + (procedure offset instruction comment) + (loop (instruction-stream))))))) + +(define (disassembler/write-constants-block block symbol-table) + (fluid-let ((*unparser-radix* 16)) + (let ((end (system-vector-length block))) + (let loop ((index (compiled-code-block/marked-start block))) + (cond ((not (< index end)) 'DONE) + ((object-type? (ucode-type linkage-section) + (system-vector-ref block index)) + (loop (disassembler/write-linkage-section block + symbol-table + index))) + (else + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-constant block + symbol-table + (system-vector-ref block index)))) + (loop (1+ index)))))))) + +(define (write-constant block symbol-table constant) + (write-string (cdr (write-to-string constant 60))) + (cond ((lambda? constant) + (let ((expression (lambda-body constant))) + (if (and (compiled-code-address? expression) + (eq? (compiled-code-address->block expression) block)) + (begin + (write-string " (") + (let ((offset (compiled-code-address->offset expression))) + (let ((label + (disassembler/lookup-symbol symbol-table offset))) + (if label + (write-string label) + (write offset)))) + (write-string ")"))))) + ((compiled-code-address? constant) + (write-string " (offset ") + (write (compiled-code-address->offset constant)) + (write-string " in ") + (write (compiled-code-address->block constant)) + (write-string ")")) + (else #f))) + +(define (disassembler/write-linkage-section block symbol-table index) + (let* ((field (object-datum (system-vector-ref block index))) + (descriptor (integer-divide field #x10000))) + (let ((kind (integer-divide-quotient descriptor)) + (length (integer-divide-remainder descriptor))) + + (define (write-caches offset size writer) + (let loop ((index (1+ (+ offset index))) + (how-many (quotient (- length offset) size))) + (if (zero? how-many) + 'DONE + (begin + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (writer block index))) + (loop (+ size index) (-1+ how-many)))))) + + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () + (write-string "#[LINKAGE-SECTION ") + (write kind) (write-string " ") (write length) + (write-string "]"))) + (case kind + ((0 3) + (write-caches + compiled-code-block/procedure-cache-offset + compiled-code-block/objects-per-procedure-cache + disassembler/write-procedure-cache)) + ((1) + (write-caches + 0 + compiled-code-block/objects-per-variable-cache + (lambda (block index) + (disassembler/write-variable-cache "Reference" block index)))) + ((2) + (write-caches + 0 + compiled-code-block/objects-per-variable-cache + (lambda (block index) + (disassembler/write-variable-cache "Assignment" block index)))) + (else + (error "disassembler/write-linkage-section: Unknown section kind" + kind))) + (1+ (+ index length))))) + +(define-integrable (variable-cache-name cache) + ((ucode-primitive primitive-object-ref 2) cache 1)) + +(define (disassembler/write-variable-cache kind block index) + (write-string kind) + (write-string " cache to ") + (write (variable-cache-name (disassembler/read-variable-cache block index)))) + +(define (disassembler/write-procedure-cache block index) + (let ((result (disassembler/read-procedure-cache block index))) + (write (-1+ (vector-ref result 2))) + (write-string " argument procedure cache to ") + (case (vector-ref result 0) + ((COMPILED INTERPRETED) + (write (vector-ref result 1))) + ((VARIABLE) + (write-string "variable ") + (write (vector-ref result 1))) + (else + (error "disassembler/write-procedure-cache: Unknown cache kind" + (vector-ref result 0)))))) + +(define (disassembler/write-instruction symbol-table offset write-instruction) + (if symbol-table + (let ((label (dbg-labels/find-offset symbol-table offset))) + (if label + (begin + (write-char #\Tab) + (write-string (dbg-label/name label)) + (write-char #\:) + (newline))))) + + (if disassembler/write-addresses? + (begin + (write-string + (number->string (+ offset disassembler/base-address) 16)) + (write-char #\Tab))) + + (if disassembler/write-offsets? + (begin + (write-string (number->string offset 16)) + (write-char #\Tab))) + + (if symbol-table + (write-string " ")) + (write-instruction) + (newline)) + + +;;;; i386/dassm2.scm + +(define (disassembler/read-variable-cache block index) + ((ucode-primitive primitive-object-set-type 2) + (ucode-type quad) + (system-vector-ref block index))) + +(define (disassembler/read-procedure-cache block index) + (fluid-let ((*block block)) + (let ((offset (compiled-code-block/index->offset index)) + (word (system-vector-ref block index))) + (if (object-type? (ucode-type fixnum) word) + ;; Unlinked. + (vector 'INTERPRETED (system-vector-ref block (1+ index)) word) + ;; Linked; + (let ((arity (read-unsigned-integer offset 16)) + (opcode (read-unsigned-integer (+ offset 2) 8)) + (operand (read-unsigned-integer (+ offset 3) 8))) + (if (and (= opcode svm1-inst:ijump-u8) (= operand 0)) + (vector 'COMPILED (read-procedure (+ offset 4)) arity) + (error (string-append "disassembler/read-procedure-cache:" + " Unexpected instruction") + opcode operand))))))) + +(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 comment state) + (make-instruction offset + instruction + comment + (lambda () (loop offset* state))))) + '()))) + +(define-integrable (disassembler/instructions/null? obj) + (null? obj)) + +(define (disassembler/instructions/read instruction-stream receiver) + (receiver (instruction-offset instruction-stream) + (instruction-instruction instruction-stream) + (instruction-comment instruction-stream) + (instruction-next instruction-stream))) + +(define-structure (instruction (type vector)) + (offset false read-only true) + (instruction false read-only true) + (comment false read-only true) + (next false read-only true)) + +(define *block) +(define *current-offset) +(define *symbol-table) +(define *valid?) + +(define (disassemble-one-instruction block offset symbol-table state receiver) + (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* ((word (next-unsigned-16-bit-word)) + (label (find-label *current-offset))) + (receiver *current-offset + (if label + `(BLOCK-OFFSET ,label) + `(WORD U ,word)) + #F + 'INSTRUCTION))) + ((external-label-marker? symbol-table offset state) + (let ((word (next-unsigned-16-bit-word))) + (receiver *current-offset + `(ENTRY ,(decipher-entry-type-code word)) + #F + 'EXTERNAL-LABEL-OFFSET))) + (else + (let ((instruction (disassemble-next-instruction))) + (if (or *valid? (not (eq? 'BYTE (car instruction)))) + (receiver *current-offset + instruction + (disassembler/guess-comment instruction state) + (disassembler/next-state instruction state)) + (let ((inst `(BYTE U ,(caddr instruction)))) + (receiver (1+ start-offset) + inst + #F + (disassembler/next-state inst state)))))))))) + +(define (decipher-entry-type-code code) + (case code + ((#xFFFE) 'EXPRESSION) ; aka CET_EXPRESSION via read_cc_entry_type + ((#xFFFD) 'INTERNAL-PROCEDURE) ; aka CET_INTERNAL_PROCEDURE + ((#xFFFC) 'INTERNAL-CONTINUATION) ; etc. + ((#xFFFB) 'TRAMPOLINE) + ((#xFFFA) 'RETURN-TO-INTERPRETER) + ((#xFFFF #xFFF9 #xFFF8) code) ; invalid + (else + (if (fix:> code #x8000) + `(CONTINUATION ,(fix:- code #x8000)) + (let ((n-required (fix:and code #x7F)) + (n-optional (fix:and (fix:lsh code -7) #x7F)) + (rest? (not (fix:zero? (fix:and code #x4000))))) + `(ARITY ,n-required ,n-optional ,rest?)))))) + +(define (disassembler/initial-state) + 'INSTRUCTION-NEXT) + +(define (disassembler/next-state instruction state) + state ; ignored + (cond ((and disassembler/compiled-code-heuristics? + (memq (car instruction) + '(trap-trap-0 + trap-trap-1-wr trap-trap-2-wr trap-trap-3-wr + jump-pcr-s8 jump-pcr-s16 jump-pcr-s32 + jump-indir-wr))) + 'EXTERNAL-LABEL) + (else + 'INSTRUCTION))) + +(define (disassembler/guess-comment instruction state) + state ; ignored + (let loop ((insn instruction)) + (and (pair? insn) + (if (and (memq (car insn) '(PCR-S8 PCR-S16 PCR-S32)) + (pair? (cdr insn)) + (exact-integer? (cadr insn)) + (not (zero? (cadr insn)))) + (+ (cadr insn) *current-offset) + (or (loop (car insn)) + (loop (cdr insn))))))) + +(define (disassembler/lookup-symbol symbol-table offset) + (and symbol-table + (let ((label (dbg-labels/find-offset symbol-table offset))) + (and label + (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 + (dbg-label/external? label))) + (and *block + (not (eq? state 'INSTRUCTION)) + (let loop ((offset (+ offset 4))) + (let ((contents (read-bits (- offset 2) 16))) + (if (bit-string-clear! contents 0) + (let ((offset (- offset (offset-word->offset contents)))) + (and (positive? offset) + (loop offset))) + (= offset (offset-word->offset contents)))))))) + +(define (read-procedure offset) + (with-absolutely-no-interrupts + (lambda () + ((ucode-primitive primitive-object-set-type 2) + (ucode-type compiled-entry) + ((ucode-primitive make-non-pointer-object 1) + (read-unsigned-integer offset 32)))))) + +(define (read-unsigned-integer offset size) + (bit-string->unsigned-integer (read-bits offset size))) + +(define (read-signed-integer offset size) + (bit-string->signed-integer (read-bits offset size))) + +(define (read-bits offset size-in-bits) + (let ((word (bit-string-allocate size-in-bits)) + (bit-offset (* offset addressing-granularity))) + (with-absolutely-no-interrupts + (lambda () + (if *block + (read-bits! *block bit-offset word) + (read-bits! offset 0 word)))) + 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 next-unsigned-byte (make-unsigned-reader 8)) +(define next-unsigned-16-bit-word (make-unsigned-reader 16)) + +(define (find-label offset) + (and disassembler/symbolize-output? + (disassembler/lookup-symbol *symbol-table offset))) + +;; These are used by dassm1.scm + +(define compiled-code-block/procedure-cache-offset 0) +(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) + + +;;;; i386/dasm3.scm + +(define (disassemble-next-instruction) + (bind-condition-handler + (list condition-type:coding-error) + (lambda (condition) + (continue)) + (lambda () + (decode-rt-coding-type 'instruction next-unsigned-byte)))) \ No newline at end of file diff --git a/src/compiler/machines/svm/lapgen.scm b/src/compiler/machines/svm/lapgen.scm index a09d0b42c..96fa5a221 100644 --- a/src/compiler/machines/svm/lapgen.scm +++ b/src/compiler/machines/svm/lapgen.scm @@ -88,44 +88,38 @@ USA. ,@(inst:label label))) (define (make-expression-label label) - (make-external-label label #xFFFF)) + (make-external-label label #xFFFE)) (define (make-internal-entry-label label) - (make-external-label label #xFFFE)) + (make-external-label label #xFFFD)) (define (make-internal-continuation-label label) - (make-external-label label #xFFFD)) + (make-external-label label #xFFFC)) -(define (make-procedure-label n-required n-optional rest? label) - (make-external-label label - (encode-procedure-type n-required n-optional rest?))) +(define (make-procedure-label min max internal-label) + (make-external-label internal-label (encode-procedure-type min max))) (define (make-internal-procedure-label label) - (make-external-label label (encode-internal-procedure-offset label #xFFFE))) + (make-external-label label #xFFFD)) (define (make-continuation-label entry-label label) entry-label - (make-external-label label (encode-continuation-offset label #xFFFD))) - -(define (encode-procedure-type n-required n-optional rest?) - (guarantee-exact-nonnegative-integer n-required) - (guarantee-exact-nonnegative-integer n-optional) - (if (not (and (< n-required #x80) (< n-optional #x80))) - (error "Can't encode procedure arity:" n-required n-optional)) - (fix:or n-required - (fix:or (fix:lsh n-optional 7) - (if rest? #x4000 0)))) - -(define (encode-internal-procedure-offset label default) - (let ((offset - (rtl-procedure/next-continuation-offset (label->object label)))) - (if offset - (begin - (guarantee-exact-nonnegative-integer offset) - (if (not (< offset #x7FF8)) - (error "Can't encode internal-procedure offset:" offset)) - (+ offset #x8000)) - default))) + (make-external-label label (encode-continuation-offset label #xFFFC))) + +(define (encode-procedure-type min-frame max-frame) + (let ((n-required (-1+ min-frame)) + (n-optional (if (negative? max-frame) + ;; Do NOT include rest arg. + (- (abs max-frame) min-frame 1) + (- max-frame min-frame))) + (rest? (negative? max-frame))) + (guarantee-exact-nonnegative-integer n-required) + (guarantee-exact-nonnegative-integer n-optional) + (if (not (and (< n-required #x80) (< n-optional #x80))) + (error "Can't encode procedure arity:" n-required n-optional)) + (fix:or n-required + (fix:or (fix:lsh n-optional 7) + (if rest? #x4000 0))))) (define (encode-continuation-offset label default) (let ((offset diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm index d51e119a5..994cad264 100644 --- a/src/compiler/machines/svm/machine.scm +++ b/src/compiler/machines/svm/machine.scm @@ -206,6 +206,11 @@ USA. (define (ea:address label) (ea:pc-relative `(- ,label *PC*))) +(define (ea:uuo-entry-address label) + ;; LABEL is the uuo-link-label, but the PC to jump to is AFTER the u16 + ;; frame-size. + (ea:pc-relative `(- (+ ,label 2) *PC*))) + (define (ea:stack-pop) (ea:post-increment rref:stack-pointer 'WORD)) @@ -257,7 +262,8 @@ USA. ;; This group returns; push return address. link assignment - lookup safe-lookup set! unassigned? define unbound? access) + ;; set! define unbound? access + lookup safe-lookup unassigned?) (define-syntax define-interrupt-tests (sc-macro-transformer @@ -268,8 +274,7 @@ USA. `(DEFINE-INST ,(symbol-append 'INTERRUPT-TEST- name))) (cdr form)))))) -(define-interrupt-tests - closure dynamic-link procedure continuation ic-procedure) +(define-interrupt-tests dynamic-link procedure continuation ic-procedure) ;;;; Machine registers, register references. @@ -510,22 +515,22 @@ USA. ;; See microcode/cmpintmd/svm1.c for a description of the layout. -(define-integrable closure-entry-size 3) +(define-integrable closure-entry-size 5) +(define-integrable entry-type-size 2) ;; Offset of the first object in the closure from the address of the -;; first closure entry point, in words. In order to make this work, -;; we add padding to the closure-count field so that the first entry -;; is aligned on an object boundary. +;; first closure entry point, in words. -;; The canonical entry point for a closure with no entry points is the +;; The first entry point for a closure with no entry points is the ;; head of the vector of value cells. (define (closure-first-offset count entry) entry (if (= count 0) 1 - (+ (integer-ceiling (* count closure-entry-size) + (+ (integer-ceiling (- (* count closure-entry-size) entry-type-size) address-units-per-object) + ;; Targets. count))) ;; Offset of the first object in the closure from the address of the @@ -534,7 +539,10 @@ USA. (define (closure-object-first-offset count) (if (= count 0) 1 - (+ 2 (closure-first-offset count 0)))) + (+ 1 ;; Header + 1 ;; Count + (closure-first-offset count 0) ;; Entries and targets. + ))) ;; Increment from one closure entry address to another, in bytes. diff --git a/src/compiler/machines/svm/rules.scm b/src/compiler/machines/svm/rules.scm index f0a689b57..0788d1326 100644 --- a/src/compiler/machines/svm/rules.scm +++ b/src/compiler/machines/svm/rules.scm @@ -629,14 +629,16 @@ USA. continuation (expect-no-exit-interrupt-checks) (LAP ,@(clear-map!) - ,@(inst:jump (ea:address (free-uuo-link-label name frame-size))))) + ,@(inst:jump (ea:uuo-entry-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:address (global-uuo-link-label name frame-size))))) + ,@(inst:jump (ea:uuo-entry-address + (global-uuo-link-label name frame-size))))) (define-rule statement (INVOCATION:CACHE-REFERENCE (? frame-size) @@ -801,7 +803,7 @@ USA. (PROCEDURE-HEADER (? internal-label) (? min) (? max)) (LAP (EQUATE ,(internal->external-label internal-label) ,internal-label) ,@(simple-procedure-header - (make-procedure-label min (- (abs max) min) (< max 0) internal-label) + (make-procedure-label min max internal-label) inst:interrupt-test-procedure))) ;; Interrupt check placement @@ -983,8 +985,10 @@ USA. ;;;; Closures: +(define-integrable (low-byte short) (fix:and short #xFF)) +(define-integrable (high-byte short) (fix:lsh short -8)) + (define (generate/cons-closure target procedure-label min max size) - min max ;;No entry format word necessary. (let ((target (word-target target)) (temp (word-temporary)) (free rref:free-pointer) @@ -994,32 +998,38 @@ USA. 1 ;; targets size ;; variables )) + (entry-type (encode-procedure-type min max)) (label (internal->external-label procedure-label)) (count-offset (* 1 address-units-per-object)) (entry-offset (* 2 address-units-per-object)) (target-offset (* 3 address-units-per-object))) (LAP ;; header - ,@(inst:load-non-pointer temp (ucode-type manifest-closure) total-words) + ,@(inst:load-non-pointer temp + (ucode-type manifest-closure) (-1+ total-words)) ,@(inst:store 'WORD temp (ea:indirect free)) - ;; entry count: 1 (little-endian short) + ;; entry count ,@(inst:load-immediate temp 1) ,@(inst:store 'BYTE temp (ea:offset free count-offset 'BYTE)) ,@(inst:load-immediate temp 0) ,@(inst:store 'BYTE temp (ea:offset free (1+ count-offset) 'BYTE)) - ,@(inst:load-address target (ea:offset free entry-offset 'BYTE)) - ,@(inst:load-pointer target (ucode-type compiled-entry) target) + ;; entry type + ,@(inst:load-immediate temp (low-byte entry-type)) + ,@(inst:store 'BYTE temp (ea:offset free (- entry-offset 2) 'BYTE)) + ,@(inst:load-immediate temp (high-byte entry-type)) + ,@(inst:store 'BYTE temp (ea:offset free (- entry-offset 1) 'BYTE)) - ;; entry: (inst:enter-closure 0) + ;; entry point + ,@(inst:load-address target (ea:offset free entry-offset 'BYTE)) ,@(inst:load-immediate temp svm1-inst:enter-closure) ,@(inst:store 'BYTE temp (ea:offset free entry-offset 'BYTE)) ,@(inst:load-immediate temp 0) ,@(inst:store 'BYTE temp (ea:offset free (+ 1 entry-offset) 'BYTE)) ,@(inst:store 'BYTE temp (ea:offset free (+ 2 entry-offset) 'BYTE)) - ;; target: procedure-label + ;; target ,@(inst:load-address temp (ea:address label)) ,@(inst:load-pointer temp (ucode-type compiled-entry) temp) ,@(inst:store 'WORD temp (ea:offset free target-offset 'BYTE)) @@ -1027,10 +1037,9 @@ USA. ,@(inst:load-address free (ea:offset free total-words 'WORD))))) (define (generate/cons-multiclosure target nentries size entries) - (let ((free rref:free-pointer) - (little-end (lambda (short) (fix:and short #xFF))) - (big-end (lambda (short) (fix:lsh short -8)))) - (let ((entry-words (integer-ceiling (* closure-entry-size nentries) + (let ((free rref:free-pointer)) + (let ((entry-words (integer-ceiling (- (* closure-entry-size nentries) + entry-type-size) address-units-per-object))) (let ((target (word-target target)) (temp (word-temporary)) @@ -1045,16 +1054,28 @@ USA. (first-target-woffset (+ 1 1 entry-words))) (define (generate-entries entries index offset) - (LAP - ,@(inst:load-immediate temp svm1-inst:enter-closure) - ,@(inst:store 'BYTE temp (ea:offset free offset 'BYTE)) - ,@(inst:load-immediate temp (little-end index)) - ,@(inst:store 'BYTE temp (ea:offset free (1+ offset) 'BYTE)) - ,@(inst:load-immediate temp (big-end index)) - ,@(inst:store 'BYTE temp (ea:offset free (+ 2 offset) 'BYTE)) - ,@(if (null? (cdr entries)) - (LAP) - (generate-entries (cdr entries) (1+ index) (+ 3 offset))))) + (let ((entry-type (let ((entry (car entries))) + (let ((min (cadr entry)) + (max (caddr entry))) + (encode-procedure-type min max))))) + (LAP + ;; entry type + ,@(inst:load-immediate temp (low-byte entry-type)) + ,@(inst:store 'BYTE temp (ea:offset free (- offset 2) 'BYTE)) + ,@(inst:load-immediate temp (high-byte entry-type)) + ,@(inst:store 'BYTE temp (ea:offset free (- offset 1) 'BYTE)) + + ;; entry point + ,@(inst:load-immediate temp svm1-inst:enter-closure) + ,@(inst:store 'BYTE temp (ea:offset free offset 'BYTE)) + ,@(inst:load-immediate temp (low-byte index)) + ,@(inst:store 'BYTE temp (ea:offset free (1+ offset) 'BYTE)) + ,@(inst:load-immediate temp (high-byte index)) + ,@(inst:store 'BYTE temp (ea:offset free (+ 2 offset) 'BYTE)) + ,@(if (null? (cdr entries)) + (LAP) + (generate-entries (cdr entries) (1+ index) + (+ offset closure-entry-size)))))) (define (generate-targets entries woffset) (let ((label (internal->external-label (caar entries)))) @@ -1069,17 +1090,17 @@ USA. (LAP ;; header ,@(inst:load-non-pointer temp - (ucode-type manifest-closure) total-words) + (ucode-type manifest-closure) + (-1+ total-words)) ,@(inst:store 'WORD temp (ea:indirect free)) ;; entry count (little-endian short) - ,@(inst:load-immediate temp (little-end nentries)) + ,@(inst:load-immediate temp (low-byte nentries)) ,@(inst:store 'BYTE temp (ea:offset free count-offset 'BYTE)) - ,@(inst:load-immediate temp (big-end nentries)) + ,@(inst:load-immediate temp (high-byte nentries)) ,@(inst:store 'BYTE temp (ea:offset free (1+ count-offset) 'BYTE)) ,@(inst:load-address target (ea:offset free first-entry-offset 'BYTE)) - ,@(inst:load-pointer target (ucode-type compiled-entry) target) ,@(generate-entries entries 0 first-entry-offset) @@ -1095,9 +1116,7 @@ USA. (simple-procedure-header (make-internal-procedure-label internal-label) inst:interrupt-test-procedure) - (simple-procedure-header - (make-internal-entry-label internal-label) - inst:interrupt-test-closure))))) + (make-internal-entry-label internal-label))))) (define-rule statement (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) @@ -1304,8 +1323,8 @@ USA. (lambda (cache) (let ((frame-size (car cache)) (label (cdr cache))) - (LAP (,frame-size . ,label) - (,name . ,(allocate-constant-label)))))) + `((,frame-size . ,label) + (,name . ,(allocate-constant-label)))))) (cdr name.caches))) name.caches-list)) @@ -1325,7 +1344,8 @@ USA. (LAP ,@(clear-map!) ,@(if safe? (trap:safe-lookup cache) - (trap:lookup cache))))) + (trap:lookup cache)) + ,@(make-internal-continuation-label (generate-label))))) (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value)) @@ -1335,7 +1355,8 @@ USA. (let* ((cache (interpreter-call-temporary extension)) (value (interpreter-call-temporary value))) (LAP ,@(clear-map!) - ,@(trap:assignment cache value)))) + ,@(trap:assignment cache value) + ,@(make-internal-continuation-label (generate-label))))) (define-rule statement (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension)) @@ -1343,66 +1364,8 @@ USA. cont ; ignored (let ((cache (interpreter-call-temporary extension))) (LAP ,@(clear-map!) - ,@(trap:unassigned? cache)))) - -;;;; Interpreter Calls - -;;; All the code that follows is obsolete. It hasn't been used in a while. -;;; It is provided in case the relevant switches are turned off, but there -;;; is no real reason to do this. Perhaps the switches should be removed. - -(define-rule statement - (INTERPRETER-CALL:ACCESS (? cont) (? environment) (? name)) - (QUALIFIER (interpreter-call-argument? environment)) - cont ; ignored - (lookup-call trap:access environment name)) - -(define-rule statement - (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?)) - (QUALIFIER (interpreter-call-argument? environment)) - cont ; ignored - (lookup-call (if safe? trap:safe-lookup trap:lookup) environment name)) - -(define-rule statement - (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name)) - (QUALIFIER (interpreter-call-argument? environment)) - cont ; ignored - (lookup-call trap:unassigned? environment name)) - -(define-rule statement - (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name)) - (QUALIFIER (interpreter-call-argument? environment)) - cont ; ignored - (lookup-call trap:unbound? environment name)) - -(define (lookup-call trap environment name) - (let ((environment-reg (interpreter-call-temporary environment)) - (name-reg (word-temporary))) - (LAP ,@(clear-map (clear-map!)) - ,@(load-constant name-reg name) - ,@(trap environment-reg name-reg)))) - -(define-rule statement - (INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value)) - (QUALIFIER (and (interpreter-call-argument? environment) - (interpreter-call-argument? value))) - cont ; ignored - (assignment-call trap:define environment name value)) - -(define-rule statement - (INTERPRETER-CALL:SET! (? cont) (? environment) (? name) (? value)) - (QUALIFIER (and (interpreter-call-argument? environment) - (interpreter-call-argument? value))) - cont ; ignored - (assignment-call trap:set! environment name value)) - -(define (assignment-call trap environment name value) - (let ((environment-reg (interpreter-call-temporary environment)) - (name-reg (word-temporary)) - (value-reg (interpreter-call-temporary value))) - (LAP ,@(clear-map!) - ,@(load-constant (INST-EA ,name-reg) name) - ,@(trap environment-reg name-reg value-reg)))) + ,@(trap:unassigned? cache) + ,@(make-internal-continuation-label (generate-label))))) ;;;; Synthesized Data diff --git a/src/etc/Stage.sh b/src/etc/Stage.sh index 79177c9e2..84be07610 100755 --- a/src/etc/Stage.sh +++ b/src/etc/Stage.sh @@ -37,7 +37,9 @@ DIRNAME="STAGE${2}" case "${1}" in make) - mkdir "${DIRNAME}" && mv -f *.com *.bci "${DIRNAME}/." + mkdir "${DIRNAME}" + maybe_mv *.com "${DIRNAME}/." + maybe_mv *.bci "${DIRNAME}/." ;; make-cross) mkdir "$DIRNAME" @@ -47,7 +49,10 @@ make-cross) maybe_mv *.fni "$DIRNAME" ;; unmake) - mv -f "${DIRNAME}"/* . && rmdir "${DIRNAME}" + if [ -d "${DIRNAME}" ]; then + maybe_mv "${DIRNAME}"/* . + rmdir "${DIRNAME}" + fi ;; remove) rm -rf "${DIRNAME}" diff --git a/src/etc/compile-svm.sh b/src/etc/compile-svm.sh index fecc14723..a3e49536d 100755 --- a/src/etc/compile-svm.sh +++ b/src/etc/compile-svm.sh @@ -19,51 +19,49 @@ # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA # 02110-1301, USA. -# Build a cross-compiler targeting the Scheme Virtual Machine. Use it -# to cross-compile everything. Use the new machine to finish the +# Build a cross-compiler targeting a new Scheme Virtual Machine. Use +# it to cross-compile everything. Use the new machine to finish the # cross-compile, leaving the build tree ready for build-bands.sh. set -e . etc/functions.sh -if [ -f lib/x-compiler.com ]; then - rm -v lib/x-runtime.com - rm -v lib/x-compiler.com - run_cmd ./Stage.sh remove 0 - run_cmd ./Stage.sh make-cross 0 - run_cmd ./Stage.sh unmake X -fi +# Remove the cross-compiler's bands and stash its products (if any). +run_cmd rm -f lib/x-runtime.com +run_cmd rm -f lib/x-compiler.com +run_cmd ./Stage.sh remove 0 +run_cmd ./Stage.sh make-cross 0 -# Compile the cross-compiler. +# Restore its host-compiled .com's (if any). +run_cmd ./Stage.sh unmake X -# This script follows the example of LIARC's compile-boot- -# compiler.sh script, which takes pains to syntax the target -# compiler withOUT the host compiler present. +# Compile the cross-compiler. +# Syntax prerequisites. for DIR in runtime sf cref; do run_cmd_in_dir $DIR "${@}" --batch-mode --load $DIR.sf > 7), ((n & 0x4000) != 0)); return (false); } n = (read_u16 (address - 4)); @@ -124,22 +126,12 @@ write_cc_entry_type (cc_entry_type_t * cet, insn_t * address) n = (0xFFF8 + 2); break; - case CET_CLOSURE: - return ((*address) != SVM1_INST_ENTER_CLOSURE); - default: return (true); } write_u16 (n, (address - 4)); return (false); } - -/* The offset is encoded as two bytes. It's relative to its own - address, _not_ relative to the entry address, and points to the - first non-marked word in the block. */ - -#define CC_ENTRY_REFERENCE_OFFSET \ - (CC_ENTRY_OFFSET_SIZE + (2 * (sizeof (SCHEME_OBJECT)))) bool read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) @@ -149,23 +141,14 @@ read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) unsigned int index = (read_u16 (address + 1)); (ceo->offset) = ((sizeof (SCHEME_OBJECT)) - + CLOSURE_COUNT_SIZE - + (index * CLOSURE_ENTRY_SIZE)); + + CLOSURE_ENTRY_OFFSET + (index * CLOSURE_ENTRY_SIZE)); (ceo->continued_p) = false; } else { unsigned int n = (read_u16 (address - 2)); - if (n < 0x8000) - { - (ceo->offset) = (n + CC_ENTRY_REFERENCE_OFFSET); - (ceo->continued_p) = false; - } - else - { - (ceo->offset) = (n - 0x8000); - (ceo->continued_p) = true; - } + ceo->offset = (n >> 1); + ceo->continued_p = ((n & 1) != 0); } return (false); } @@ -175,24 +158,12 @@ read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) bool write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address) { - unsigned long offset; + unsigned int code; if ((*address) == SVM1_INST_ENTER_CLOSURE) return (true); /* not supported */ - offset = (ceo->offset); - if (ceo->continued_p) - { - offset -= CC_ENTRY_REFERENCE_OFFSET; - if (! (offset < 0x8000)) - return (true); - } - else - { - if (! (offset < 0x8000)) - return (true); - offset += 0x8000; - } - write_u16 (offset, (address - 2)); + code = (ceo->offset) << 1; + write_u16 (code + (ceo->continued_p ? 1 : 0), address - 2); return (false); } @@ -224,27 +195,29 @@ write_u16 (unsigned int n, insn_t * address) 0x00 TC_MANIFEST_CLOSURE | n_words == 12 0x04 count == 3 - 0x06 2 padding bytes (next address must be word-aligned) + 0x06 2 cc-entry type bytes (next address must be word-aligned) 0x08 SVM1_INST_ENTER_CLOSURE 0x09 index == 0 - 0x0B SVM1_INST_ENTER_CLOSURE - 0x0C index == 1 + 0x0B 2 cc-entry type (arity) bytes + 0x0D SVM1_INST_ENTER_CLOSURE + 0x0E index == 1 - 0x0E SVM1_INST_ENTER_CLOSURE - 0x0F index == 2 + 0x10 2 cc-entry type (arity) bytes + 0x12 SVM1_INST_ENTER_CLOSURE + 0x13 index == 2 - 0x11 3 padding bytes (next address must be word-aligned) + 0x15 3 padding bytes (next address must be word-aligned) - 0x14 target 0 - 0x18 target 1 - 0x1C target 2 + 0x18 target 0 + 0x1C target 1 + 0x20 target 2 - 0x20 value cell 0 - 0x24 value cell 1 - 0x28 value cell 2 - 0x2C value cell 3 + 0x24 value cell 0 + 0x28 value cell 1 + 0x2C value cell 2 + 0x30 value cell 3 */ @@ -257,7 +230,7 @@ compiled_closure_count (SCHEME_OBJECT * block) insn_t * compiled_closure_start (SCHEME_OBJECT * block) { - return (((insn_t *) block) + CLOSURE_COUNT_SIZE); + return (((insn_t *) block) + CLOSURE_ENTRY_OFFSET); } insn_t * @@ -286,11 +259,11 @@ compiled_closure_entry_to_target (insn_t * entry) { unsigned int index = (read_u16 (entry + 1)); insn_t * block - = (entry - (CLOSURE_COUNT_SIZE + (index * CLOSURE_ENTRY_SIZE))); + = (entry - (CLOSURE_ENTRY_OFFSET + (index * CLOSURE_ENTRY_SIZE))); unsigned int count = (read_u16 (block)); SCHEME_OBJECT * targets = (skip_compiled_closure_padding - (block + (CLOSURE_COUNT_SIZE + (count * CLOSURE_ENTRY_SIZE)))); + (block + (CLOSURE_ENTRY_START + (count * CLOSURE_ENTRY_SIZE)))); return (targets[index]); } @@ -308,19 +281,19 @@ compiled_closure_entry_to_target (insn_t * entry) procedure. It is laid out in memory like this (on a 32-bit machine): - 0x00 n-args encoded as fixnum + 0x00 frame-size (fixnum) 0x04 name encoded as symbol After linking, the cache is changed as follows: - 0x00 n-args + 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 n-args + 0x00 frame-size (u16) 0x02 4 padding bytes 0x06 SVM1_INST_IJUMP_U8 0x07 offset = 0 @@ -405,6 +378,42 @@ bool store_trampoline_insns (insn_t * entry, byte_t code) { (entry[0]) = SVM1_INST_TRAP_TRAP_0; - (entry[1]) = code; + switch (code) + { + case TRAMPOLINE_K_RETURN_TO_INTERPRETER: + entry[1] = SVM1_TRAP_0_RETURN_TO_INTERPRETER; break; + case TRAMPOLINE_K_APPLY: + entry[1] = SVM1_TRAP_0_OPERATOR_APPLY; break; + case TRAMPOLINE_K_LEXPR_PRIMITIVE: + entry[1] = SVM1_TRAP_0_OPERATOR_LEXPR; break; + case TRAMPOLINE_K_PRIMITIVE: + entry[1] = SVM1_TRAP_0_OPERATOR_PRIMITIVE; break; + case TRAMPOLINE_K_LOOKUP: + entry[1] = SVM1_TRAP_0_OPERATOR_LOOKUP; break; + case TRAMPOLINE_K_1_0: + entry[1] = SVM1_TRAP_0_OPERATOR_1_0; break; + case TRAMPOLINE_K_2_1: + entry[1] = SVM1_TRAP_0_OPERATOR_2_1; break; + case TRAMPOLINE_K_2_0: + entry[1] = SVM1_TRAP_0_OPERATOR_2_0; break; + case TRAMPOLINE_K_3_2: + entry[1] = SVM1_TRAP_0_OPERATOR_3_2; break; + case TRAMPOLINE_K_3_1: + entry[1] = SVM1_TRAP_0_OPERATOR_3_1; break; + case TRAMPOLINE_K_3_0: + entry[1] = SVM1_TRAP_0_OPERATOR_3_0; break; + case TRAMPOLINE_K_4_3: + entry[1] = SVM1_TRAP_0_OPERATOR_4_3; break; + case TRAMPOLINE_K_4_2: + entry[1] = SVM1_TRAP_0_OPERATOR_4_2; break; + case TRAMPOLINE_K_4_1: + entry[1] = SVM1_TRAP_0_OPERATOR_4_1; break; + case TRAMPOLINE_K_4_0: + entry[1] = SVM1_TRAP_0_OPERATOR_4_0; break; + case TRAMPOLINE_K_REFLECT_TO_INTERFACE: + entry[1] = SVM1_TRAP_0_REFLECT_TO_INTERFACE; break; + default: + return (true); + } return (false); } diff --git a/src/microcode/cmpintmd/svm1.h b/src/microcode/cmpintmd/svm1.h index ec2acb5af..1475c57bc 100644 --- a/src/microcode/cmpintmd/svm1.h +++ b/src/microcode/cmpintmd/svm1.h @@ -44,13 +44,17 @@ typedef byte_t insn_t; instructions are stored. */ #define CC_ENTRY_GC_TRAP_SIZE 0 -/* Size of closure count in insn_t units. Only first two bytes - contain the count, but we must add padding to move the first entry - to a word boundary. */ -#define CLOSURE_COUNT_SIZE SIZEOF_SCHEME_OBJECT +/* Size of closure count in insn_t units. */ +#define CLOSURE_COUNT_SIZE 2 + +/* Offset of first (canonical) closure entry point in insn_t units. */ +#define CLOSURE_ENTRY_OFFSET SIZEOF_SCHEME_OBJECT + +/* Offset to start of first closure entry -- the entry type (format) word. */ +#define CLOSURE_ENTRY_START (CLOSURE_ENTRY_OFFSET - CC_ENTRY_TYPE_SIZE) /* Size of closure entry in insn_t units. */ -#define CLOSURE_ENTRY_SIZE 3 +#define CLOSURE_ENTRY_SIZE 5 /* Size of execution cache in SCHEME_OBJECTS. */ #define UUO_LINK_SIZE 2 diff --git a/src/microcode/svm1-defns.h b/src/microcode/svm1-defns.h index f122811d3..4245af33c 100644 --- a/src/microcode/svm1-defns.h +++ b/src/microcode/svm1-defns.h @@ -1,6 +1,11 @@ /* -*-C-*- - DO NOT EDIT. This file was generated by a program. +DO NOT EDIT: this file was generated by a program. + +Copyright (C) 2010 Massachusetts Institute of Technology + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ @@ -200,7 +205,7 @@ DECODE_SIGNED_32 (value) #define SVM1_INST_START_CODE 0x01 -#define SVM1_INST_END_CODE 0xcf +#define SVM1_INST_END_CODE 0xce #define SVM1_INST_BINDINGS(binder) \ binder (SVM1_INST_STORE_B_WR_ADDR, store_b_wr_addr); \ @@ -354,7 +359,6 @@ binder (SVM1_INST_TRAP_TRAP_3_WR, trap_trap_3_wr); \ binder (SVM1_INST_INTERRUPT_TEST_PROCEDURE, interrupt_test_procedure); \ binder (SVM1_INST_INTERRUPT_TEST_DYNAMIC_LINK, interrupt_test_dynamic_link); \ - binder (SVM1_INST_INTERRUPT_TEST_CLOSURE, interrupt_test_closure); \ binder (SVM1_INST_INTERRUPT_TEST_IC_PROCEDURE, interrupt_test_ic_procedure); \ binder (SVM1_INST_INTERRUPT_TEST_CONTINUATION, interrupt_test_continuation); \ binder (SVM1_INST_FLONUM_HEADER_U8, flonum_header_u8); \ @@ -1216,284 +1220,282 @@ #define SVM1_INST_INTERRUPT_TEST_DYNAMIC_LINK 0x97 -#define SVM1_INST_INTERRUPT_TEST_CLOSURE 0x98 - -#define SVM1_INST_INTERRUPT_TEST_IC_PROCEDURE 0x99 +#define SVM1_INST_INTERRUPT_TEST_IC_PROCEDURE 0x98 -#define SVM1_INST_INTERRUPT_TEST_CONTINUATION 0x9a +#define SVM1_INST_INTERRUPT_TEST_CONTINUATION 0x99 -#define SVM1_INST_FLONUM_HEADER_U8 0x9b +#define SVM1_INST_FLONUM_HEADER_U8 0x9a #define DECODE_SVM1_INST_FLONUM_HEADER_U8(target, value) \ DECODE_WORD_REGISTER (target); \ DECODE_UNSIGNED_8 (value) -#define SVM1_INST_FLONUM_HEADER_U16 0x9c +#define SVM1_INST_FLONUM_HEADER_U16 0x9b #define DECODE_SVM1_INST_FLONUM_HEADER_U16(target, value) \ DECODE_WORD_REGISTER (target); \ DECODE_UNSIGNED_16 (value) -#define SVM1_INST_FLONUM_HEADER_U32 0x9d +#define SVM1_INST_FLONUM_HEADER_U32 0x9c #define DECODE_SVM1_INST_FLONUM_HEADER_U32(target, value) \ DECODE_WORD_REGISTER (target); \ DECODE_UNSIGNED_32 (value) -#define SVM1_INST_FLONUM_HEADER 0x9e +#define SVM1_INST_FLONUM_HEADER 0x9d #define DECODE_SVM1_INST_FLONUM_HEADER(target, n_elts) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (n_elts) -#define SVM1_INST_COPY_WR 0x9f +#define SVM1_INST_COPY_WR 0x9e #define DECODE_SVM1_INST_COPY_WR(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_COPY_FR 0xa0 +#define SVM1_INST_COPY_FR 0x9f #define DECODE_SVM1_INST_COPY_FR(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_NEGATE_WR 0xa1 +#define SVM1_INST_NEGATE_WR 0xa0 #define DECODE_SVM1_INST_NEGATE_WR(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_NEGATE_FR 0xa2 +#define SVM1_INST_NEGATE_FR 0xa1 #define DECODE_SVM1_INST_NEGATE_FR(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_INCREMENT_WR 0xa3 +#define SVM1_INST_INCREMENT_WR 0xa2 #define DECODE_SVM1_INST_INCREMENT_WR(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_INCREMENT_FR 0xa4 +#define SVM1_INST_INCREMENT_FR 0xa3 #define DECODE_SVM1_INST_INCREMENT_FR(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_DECREMENT_WR 0xa5 +#define SVM1_INST_DECREMENT_WR 0xa4 #define DECODE_SVM1_INST_DECREMENT_WR(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_DECREMENT_FR 0xa6 +#define SVM1_INST_DECREMENT_FR 0xa5 #define DECODE_SVM1_INST_DECREMENT_FR(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_ABS_WR 0xa7 +#define SVM1_INST_ABS_WR 0xa6 #define DECODE_SVM1_INST_ABS_WR(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_ABS_FR 0xa8 +#define SVM1_INST_ABS_FR 0xa7 #define DECODE_SVM1_INST_ABS_FR(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_OBJECT_TYPE 0xa9 +#define SVM1_INST_OBJECT_TYPE 0xa8 #define DECODE_SVM1_INST_OBJECT_TYPE(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_OBJECT_DATUM 0xaa +#define SVM1_INST_OBJECT_DATUM 0xa9 #define DECODE_SVM1_INST_OBJECT_DATUM(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_OBJECT_ADDRESS 0xab +#define SVM1_INST_OBJECT_ADDRESS 0xaa #define DECODE_SVM1_INST_OBJECT_ADDRESS(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_FIXNUM_TO_INTEGER 0xac +#define SVM1_INST_FIXNUM_TO_INTEGER 0xab #define DECODE_SVM1_INST_FIXNUM_TO_INTEGER(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_INTEGER_TO_FIXNUM 0xad +#define SVM1_INST_INTEGER_TO_FIXNUM 0xac #define DECODE_SVM1_INST_INTEGER_TO_FIXNUM(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_NOT 0xae +#define SVM1_INST_NOT 0xad #define DECODE_SVM1_INST_NOT(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_FLONUM_ALIGN 0xaf +#define SVM1_INST_FLONUM_ALIGN 0xae #define DECODE_SVM1_INST_FLONUM_ALIGN(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_FLONUM_LENGTH 0xb0 +#define SVM1_INST_FLONUM_LENGTH 0xaf #define DECODE_SVM1_INST_FLONUM_LENGTH(target, source) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source) -#define SVM1_INST_SQRT 0xb1 +#define SVM1_INST_SQRT 0xb0 #define DECODE_SVM1_INST_SQRT(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_ROUND 0xb2 +#define SVM1_INST_ROUND 0xb1 #define DECODE_SVM1_INST_ROUND(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_CEILING 0xb3 +#define SVM1_INST_CEILING 0xb2 #define DECODE_SVM1_INST_CEILING(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_FLOOR 0xb4 +#define SVM1_INST_FLOOR 0xb3 #define DECODE_SVM1_INST_FLOOR(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_TRUNCATE 0xb5 +#define SVM1_INST_TRUNCATE 0xb4 #define DECODE_SVM1_INST_TRUNCATE(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_LOG 0xb6 +#define SVM1_INST_LOG 0xb5 #define DECODE_SVM1_INST_LOG(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_EXP 0xb7 +#define SVM1_INST_EXP 0xb6 #define DECODE_SVM1_INST_EXP(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_COS 0xb8 +#define SVM1_INST_COS 0xb7 #define DECODE_SVM1_INST_COS(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_SIN 0xb9 +#define SVM1_INST_SIN 0xb8 #define DECODE_SVM1_INST_SIN(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_TAN 0xba +#define SVM1_INST_TAN 0xb9 #define DECODE_SVM1_INST_TAN(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_ACOS 0xbb +#define SVM1_INST_ACOS 0xba #define DECODE_SVM1_INST_ACOS(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_ASIN 0xbc +#define SVM1_INST_ASIN 0xbb #define DECODE_SVM1_INST_ASIN(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_ATAN 0xbd +#define SVM1_INST_ATAN 0xbc #define DECODE_SVM1_INST_ATAN(target, source) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source) -#define SVM1_INST_ADD_WR 0xbe +#define SVM1_INST_ADD_WR 0xbd #define DECODE_SVM1_INST_ADD_WR(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_ADD_FR 0xbf +#define SVM1_INST_ADD_FR 0xbe #define DECODE_SVM1_INST_ADD_FR(target, source1, source2) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source1); \ DECODE_FLOAT_REGISTER (source2) -#define SVM1_INST_SUBTRACT_WR 0xc0 +#define SVM1_INST_SUBTRACT_WR 0xbf #define DECODE_SVM1_INST_SUBTRACT_WR(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_SUBTRACT_FR 0xc1 +#define SVM1_INST_SUBTRACT_FR 0xc0 #define DECODE_SVM1_INST_SUBTRACT_FR(target, source1, source2) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source1); \ DECODE_FLOAT_REGISTER (source2) -#define SVM1_INST_MULTIPLY_WR 0xc2 +#define SVM1_INST_MULTIPLY_WR 0xc1 #define DECODE_SVM1_INST_MULTIPLY_WR(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_MULTIPLY_FR 0xc3 +#define SVM1_INST_MULTIPLY_FR 0xc2 #define DECODE_SVM1_INST_MULTIPLY_FR(target, source1, source2) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source1); \ DECODE_FLOAT_REGISTER (source2) -#define SVM1_INST_QUOTIENT 0xc4 +#define SVM1_INST_QUOTIENT 0xc3 #define DECODE_SVM1_INST_QUOTIENT(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_REMAINDER 0xc5 +#define SVM1_INST_REMAINDER 0xc4 #define DECODE_SVM1_INST_REMAINDER(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_LSH 0xc6 +#define SVM1_INST_LSH 0xc5 #define DECODE_SVM1_INST_LSH(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_AND 0xc7 +#define SVM1_INST_AND 0xc6 #define DECODE_SVM1_INST_AND(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_ANDC 0xc8 +#define SVM1_INST_ANDC 0xc7 #define DECODE_SVM1_INST_ANDC(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_OR 0xc9 +#define SVM1_INST_OR 0xc8 #define DECODE_SVM1_INST_OR(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_XOR 0xca +#define SVM1_INST_XOR 0xc9 #define DECODE_SVM1_INST_XOR(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_MAX_UNSIGNED 0xcb +#define SVM1_INST_MAX_UNSIGNED 0xca #define DECODE_SVM1_INST_MAX_UNSIGNED(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_MIN_UNSIGNED 0xcc +#define SVM1_INST_MIN_UNSIGNED 0xcb #define DECODE_SVM1_INST_MIN_UNSIGNED(target, source1, source2) \ DECODE_WORD_REGISTER (target); \ DECODE_WORD_REGISTER (source1); \ DECODE_WORD_REGISTER (source2) -#define SVM1_INST_DIVIDE 0xcd +#define SVM1_INST_DIVIDE 0xcc #define DECODE_SVM1_INST_DIVIDE(target, source1, source2) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source1); \ DECODE_FLOAT_REGISTER (source2) -#define SVM1_INST_ATAN2 0xce +#define SVM1_INST_ATAN2 0xcd #define DECODE_SVM1_INST_ATAN2(target, source1, source2) \ DECODE_FLOAT_REGISTER (target); \ DECODE_FLOAT_REGISTER (source1); \ diff --git a/src/microcode/svm1-interp.c b/src/microcode/svm1-interp.c index 0baf15a7a..db8ac4cca 100644 --- a/src/microcode/svm1-interp.c +++ b/src/microcode/svm1-interp.c @@ -77,14 +77,29 @@ typedef byte_t tc_t; #define FLOAT_REF(a) (* (FLOAT_ADDR (a))) -typedef byte_t * inst_defn_t (void); +typedef bool inst_defn_t (void); static inst_defn_t * inst_defns [256]; -#define DEFINE_INST(name) static byte_t * insn_##name (void) -#define NEXT_PC return (PC) -#define OFFSET_PC(o) return (PC + (o)) -#define COND_OFFSET_PC(p, o) return ((p) ? (PC + (o)) : PC) -#define NEW_PC(addr) return (addr) +#define DEFINE_INST(name) static bool insn_##name (void) +#define NEXT_PC return (1) +#define OFFSET_PC(o) do \ +{ \ + PC = PC + (o); \ + return (1); \ +} while (0) + +#define COND_OFFSET_PC(p, o) do \ +{ \ + if (p) { PC = PC + (o); } \ + return (1); \ +} while (0) + +#define NEW_PC(addr) do \ +{ \ + PC = (addr); \ + return (1); \ +} while (0) + static long svm1_result; #define EXIT_VM(code) do \ @@ -113,10 +128,10 @@ struct address_s #define DECODE_ADDRESS(name) address_t name; decode_address (&name) static void decode_address (address_t *); -typedef byte_t * trap_0_t (void); -typedef byte_t * trap_1_t (wreg_t); -typedef byte_t * trap_2_t (wreg_t, wreg_t); -typedef byte_t * trap_3_t (wreg_t, wreg_t, wreg_t); +typedef bool trap_0_t (void); +typedef bool trap_1_t (wreg_t); +typedef bool trap_2_t (wreg_t, wreg_t); +typedef bool trap_3_t (wreg_t, wreg_t, wreg_t); static trap_0_t * traps_0 [256]; static trap_1_t * traps_1 [256]; @@ -134,7 +149,7 @@ static void initialize_decoder_tables (void); static int initialized_p = 0; static int little_endian_p; -static byte_t * execute_instruction (void); +static bool execute_instruction (void); static void compute_little_endian_p (void) @@ -163,13 +178,13 @@ initialize_svm1 (void) WREG_SET (i, 0); for (i = 0; (i < N_FLOAT_REGISTERS); i += 1) FREG_SET (i, 0.0); - WREG_SET (SVM1_REG_INTERPRETER_REGISTER_BLOCK, (word_t)Registers); + WREG_SET (SVM1_REG_INTERPRETER_REGISTER_BLOCK, ((word_t)Registers)); } #define IMPORT_REGS() do \ { \ - WREG_SET (SVM1_REG_STACK_POINTER, ((SCHEME_OBJECT) stack_pointer)); \ - WREG_SET (SVM1_REG_FREE_POINTER, ((SCHEME_OBJECT) Free)); \ + WREG_SET (SVM1_REG_STACK_POINTER, ((word_t)stack_pointer)); \ + WREG_SET (SVM1_REG_FREE_POINTER, ((word_t)Free)); \ WREG_SET (SVM1_REG_VALUE, GET_VAL); \ } while (0) @@ -178,7 +193,7 @@ initialize_svm1 (void) stack_pointer \ = ((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_STACK_POINTER))); \ Free = ((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_FREE_POINTER))); \ - SET_VAL (WREG_REF (SVM1_REG_VALUE)); \ + SET_VAL ((SCHEME_OBJECT) (WREG_REF (SVM1_REG_VALUE))); \ } while (0) long @@ -186,20 +201,14 @@ C_to_interface (void * address) { IMPORT_REGS (); PC = address; - while (1) - { - byte_t * new_pc = (execute_instruction ()); - if (new_pc == 0) - break; - PC = new_pc; - } + while (execute_instruction ()); EXPORT_REGS (); return (svm1_result); } static jmp_buf k_execute_instruction; -static byte_t * +static bool execute_instruction (void) { if ((setjmp (k_execute_instruction)) != 0) @@ -207,7 +216,7 @@ execute_instruction (void) return ((* (inst_defns[NEXT_BYTE])) ()); } -static insn_t * +static bool illegal_instruction (void) { signal_illegal_instruction (); @@ -468,8 +477,10 @@ DEFINE_INST (load_immediate_fr_flt) NEXT_PC; } +#define TYPE_CODE_MASK_LOW (N_TYPE_CODES - 1U) + #define X_MAKE_OBJECT(t, d) \ - (MAKE_OBJECT (((t) & TYPE_CODE_MASK), ((d) & DATUM_MASK))) + (MAKE_OBJECT (((t) & TYPE_CODE_MASK_LOW), ((d) & DATUM_MASK))) #define X_MAKE_PTR(t, a) (X_MAKE_OBJECT (t, (ADDRESS_TO_DATUM (a)))) @@ -660,21 +671,6 @@ DEFINE_INST (icall_u32) push_icall_entry (PC - 5); IJUMP (offset); } - -DEFINE_INST (enter_closure) -{ - DECODE_SVM1_INST_ENTER_CLOSURE (index); - { - byte_t * block = (PC - (CLOSURE_COUNT_SIZE - + ((index + 1) * CLOSURE_ENTRY_SIZE))); - unsigned int count = (read_u16 (block)); - SCHEME_OBJECT * targets - = (skip_compiled_closure_padding - (block + (CLOSURE_COUNT_SIZE + (count * CLOSURE_ENTRY_SIZE)))); - push_object (MAKE_CC_BLOCK (((SCHEME_OBJECT *) block) - 1)); - NEW_PC (BYTE_ADDR (OBJECT_ADDRESS (targets[index]))); - } -} /* Conditional jumps */ @@ -782,7 +778,7 @@ DEFINE_INST (trap_trap_0) return ((* (traps_0[code])) ()); } -static byte_t * +static bool illegal_trap_0 (void) { signal_illegal_instruction (); @@ -795,7 +791,7 @@ DEFINE_INST (trap_trap_1_wr) return ((* (traps_1[code])) (r1)); } -static byte_t * +static bool illegal_trap_1 (wreg_t r1) { signal_illegal_instruction (); @@ -808,7 +804,7 @@ DEFINE_INST (trap_trap_2_wr) return ((* (traps_2[code])) (r1, r2)); } -static byte_t * +static bool illegal_trap_2 (wreg_t r1, wreg_t r2) { signal_illegal_instruction (); @@ -821,7 +817,7 @@ DEFINE_INST (trap_trap_3_wr) return ((* (traps_3[code])) (r1, r2, r3)); } -static byte_t * +static bool illegal_trap_3 (wreg_t r1, wreg_t r2, wreg_t r3) { signal_illegal_instruction (); @@ -833,16 +829,16 @@ illegal_trap_3 (wreg_t r1, wreg_t r2, wreg_t r3) EXPORT_REGS () #define TRAP_SUFFIX(result) \ + IMPORT_REGS (); \ if ((result).scheme_p) \ { \ - IMPORT_REGS (); \ NEW_PC ((result).arg.new_pc); \ } \ else \ EXIT_VM ((result).arg.interpreter_code) #define DEFINE_TRAP_0(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (void) \ { \ TRAP_PREFIX (result); \ @@ -855,7 +851,7 @@ trap_##nl (void) \ } #define DEFINE_TRAP_1(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (wreg_t source1) \ { \ TRAP_PREFIX (result); \ @@ -868,7 +864,7 @@ trap_##nl (wreg_t source1) \ } #define DEFINE_TRAP_2(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (wreg_t source1, wreg_t source2) \ { \ TRAP_PREFIX (result); \ @@ -881,7 +877,7 @@ trap_##nl (wreg_t source1, wreg_t source2) \ } #define DEFINE_TRAP_3(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (wreg_t source1, wreg_t source2, wreg_t source3) \ { \ TRAP_PREFIX (result); \ @@ -894,7 +890,7 @@ trap_##nl (wreg_t source1, wreg_t source2, wreg_t source3) \ } #define DEFINE_TRAP_R0(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (void) \ { \ TRAP_PREFIX (result); \ @@ -907,7 +903,7 @@ trap_##nl (void) \ } #define DEFINE_TRAP_R1(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (wreg_t source1) \ { \ TRAP_PREFIX (result); \ @@ -920,7 +916,7 @@ trap_##nl (wreg_t source1) \ } #define DEFINE_TRAP_R2(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (wreg_t source1, wreg_t source2) \ { \ TRAP_PREFIX (result); \ @@ -933,7 +929,7 @@ trap_##nl (wreg_t source1, wreg_t source2) \ } #define DEFINE_TRAP_R3(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (wreg_t source1, wreg_t source2, wreg_t source3) \ { \ TRAP_PREFIX (result); \ @@ -946,7 +942,7 @@ trap_##nl (wreg_t source1, wreg_t source2, wreg_t source3) \ } #define DEFINE_TRAMPOLINE(nl, util_name) \ -byte_t * \ +bool \ trap_##nl (void) \ { \ TRAP_PREFIX (result); \ @@ -1012,17 +1008,18 @@ DEFINE_TRAMPOLINE (operator_primitive, operator_primitive_trap) DEFINE_TRAMPOLINE (reflect_to_interface, reflect_to_interface) DEFINE_TRAMPOLINE (return_to_interpreter, return_to_interpreter) +#define INTERRUPT_TEST \ + (((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_FREE_POINTER))) \ + >= GET_MEMTOP) \ + || (((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_STACK_POINTER))) \ + < GET_STACK_GUARD) + #define DEFINE_INTERRUPT_TEST(name, a1, a2) \ DEFINE_INST (interrupt_test_##name) \ { \ - if ((((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_FREE_POINTER))) \ - >= GET_MEMTOP) \ - || (((SCHEME_OBJECT *) (WREG_REF (SVM1_REG_STACK_POINTER))) \ - >= GET_STACK_GUARD)) \ + if (INTERRUPT_TEST) \ { \ - utility_result_t result; \ - \ - EXPORT_REGS (); \ + TRAP_PREFIX(result); \ compiler_interrupt_common ((&result), (a1), (a2)); \ TRAP_SUFFIX (result); \ } \ @@ -1030,13 +1027,36 @@ DEFINE_INST (interrupt_test_##name) \ } DEFINE_INTERRUPT_TEST (procedure, (PC - 1), SHARP_F) -DEFINE_INTERRUPT_TEST (closure, 0, SHARP_F) DEFINE_INTERRUPT_TEST (ic_procedure, (PC - 1), GET_ENV) -DEFINE_INTERRUPT_TEST (continuation, (PC - 1), GET_VAL) +DEFINE_INTERRUPT_TEST (continuation, 0, GET_VAL) DEFINE_INTERRUPT_TEST (dynamic_link, (PC - 1), (MAKE_CC_STACK_ENV (WREG_REF (SVM1_REG_DYNAMIC_LINK)))) + +DEFINE_INST (enter_closure) +{ + DECODE_SVM1_INST_ENTER_CLOSURE (index); + + if (INTERRUPT_TEST) + { + TRAP_PREFIX(result); + compiler_interrupt_common ((&result), PC - 3, SHARP_F); + TRAP_SUFFIX (result); + } + + { + byte_t * block = (PC - (CLOSURE_ENTRY_START + + ((index + 1) * CLOSURE_ENTRY_SIZE))); + unsigned int count = (read_u16 (block)); + SCHEME_OBJECT * targets + = (skip_compiled_closure_padding + (block + (CLOSURE_ENTRY_START + (count * CLOSURE_ENTRY_SIZE)))); + push_object (MAKE_CC_ENTRY (((SCHEME_OBJECT *) + (block + CLOSURE_ENTRY_OFFSET)))); + NEW_PC (BYTE_ADDR (OBJECT_ADDRESS (targets[index]))); + } +} DEFINE_INST (flonum_header_u8) { -- 2.25.1