@$(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 \
( cd compiler/machines/svm/ \
&& $(MIT_SCHEME_EXE) --batch-mode --load compile-assembler \
</dev/null )
- cp compiler/machines/svm/svm1-defns.h microcode/svm1-defns.h
all-liarc:
@$(top_srcdir)/etc/c-compile.sh "$(MIT_SCHEME_EXE)" --compiler
. etc/functions.sh
for SUBDIR in `MAKEFLAGS= make -s subdir-list | sort | uniq`; do
- if [ -x $SUBDIR/Stage.sh ]; then
- # Try to avoid a subdir that was not compiled (else
- # $SUBDIR/Stage.sh will abort).
- if [ "`cd $SUBDIR && echo *.com`" = "*.com" \
- -a "`cd $SUBDIR && echo *.moc`" = "*.moc" ]; then continue; fi
- run_cmd_in_dir $SUBDIR ./Stage.sh "$@"
- fi
+ if [ ! -x $SUBDIR/Stage.sh ]; then continue; fi
+ run_cmd_in_dir $SUBDIR ./Stage.sh "$@"
done
case ${1} in
distclean | maintainer-clean)
- echo "rm -f machine compiler.cbf compiler.pkg compiler.sf"
- rm -f machine compiler.cbf compiler.pkg compiler.sf
- echo "rm -f make.com make.bin make.so"
- rm -f make.com make.bin make.so
+ maybe_rm machine compiler.cbf compiler.pkg compiler.sf
+ maybe_rm make.com make.bin make.so
+ maybe_rm machines/svm/assembler-db.scm
+ maybe_rm machines/svm/assembler-rules.exp
+ maybe_rm machines/svm/svm1-defns.h
+ maybe_rm machines/svm/svm1-opcodes.scm
;;
esac
case "${1}" in
make)
for D in ${SUBDIRS}; do
- (cd ${D} && mkdir "${S}" && mv -f *.com *.bci "${S}") || exit 1
+ ( cd "${D}"
+ mkdir "${S}"
+ maybe_mv *.com "${S}/."
+ maybe_mv *.bci "${S}/." )
done
;;
make-cross)
;;
unmake)
for D in ${SUBDIRS}; do
- (cd ${D} && mv -f "${S}"/* . && rmdir "${S}") || exit 1
+ ( cd "${D}"
+ if [ -d "${S}" ]; then
+ maybe_mv "${S}"/* .
+ rmdir "${S}"
+ fi )
done
;;
remove)
(call-with-output-file pathname
(lambda (port)
(write-string "#| -*-Scheme-*-\n\n" port)
- (write-string "DO NOT EDIT." port)
- (write-string " This file was generated by a program.\n\n" port)
- (write-string "|#\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)
(string-append "SCM_"
(name-string->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)
(write-item (last items) port)
(newline port))
\f
+(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?))
(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)))
\f
(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))
;; 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!)
(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.
(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))))))))
\f
(define (match-rt-coding-type name expression symbol-table)
(let loop ((defns (rt-coding-type-defns (rt-coding-type name))))
(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))))))))
\f
;;;; Assembler Machine Dependencies
(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)))))
;;;; 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))
(+ (* (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)))
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
(define-package (compiler disassembler)
(files "machines/svm/disassembler")
- (parent (compiler))
+ (parent (compiler assembler))
(export ()
compiler:write-lap-file
compiler:disassemble)
;; 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
;; 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
#| -*-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.
;;;; 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)))))
+\f
+(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)))))))
+\f
+(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)))
+\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)))))
+\f
+(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))
+\f
+
+;;;; 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?))))))
+\f
+(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))
+\f
+(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)
+\f
+
+;;;; 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
,@(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
(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))
;; 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
`(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)
\f
;;;; Machine registers, register references.
;; 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
(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.
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)
(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)))
\f
;; Interrupt check placement
\f
;;;; 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)
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))
,@(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))
(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))))
(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)
(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)))))
\f
(define-rule statement
(CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
(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))
(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))
(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))
cont ; ignored
(let ((cache (interpreter-call-temporary extension)))
(LAP ,@(clear-map!)
- ,@(trap:unassigned? cache))))
-\f
-;;;; 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))))
-\f
-(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)))))
\f
;;;; Synthesized Data
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"
maybe_mv *.fni "$DIRNAME"
;;
unmake)
- mv -f "${DIRNAME}"/* . && rmdir "${DIRNAME}"
+ if [ -d "${DIRNAME}" ]; then
+ maybe_mv "${DIRNAME}"/* .
+ rmdir "${DIRNAME}"
+ fi
;;
remove)
rm -rf "${DIRNAME}"
# 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 </dev/null
done
-FASL=make.bin
-# Comment out the next 5 lines for a fully-interpreted cross-compiler.
-# This does not really work because runtime.sf will die during
-# cross-compilation without option *parser in --library ../lib.
+# Compile prerequisites.
for DIR in runtime sf cref; do
run_cmd_in_dir $DIR "${@}" --batch-mode --load $DIR.cbf </dev/null
done
run_cmd_in_dir star-parser "${@}" --batch-mode --load compile.scm </dev/null
FASL=make.com
+# Dump prerequisites into x-runtime.com.
run_cmd_in_dir runtime \
"${@}" --batch-mode --library ../lib --fasl $FASL <<EOF
(disk-save "../lib/x-runtime.com")
EOF
echo ""
+# Syntax compiler, using x-runtime.com.
run_cmd_in_dir compiler \
"${@}" --batch-mode --library ../lib --band x-runtime.com <<EOF
(load "compiler.sf")
+(sf "base/crsend")
EOF
if [ -s compiler/compiler-unx.crf ]; then
exit 1
fi
+# Optionally, compile cross-compiler.
run_cmd_in_dir compiler "${@}" --batch-mode --load compiler.cbf </dev/null
+# Load up everything, because it is all about to go away!
run_cmd "${@}" --batch-mode --library lib --band x-runtime.com <<EOF
-;; Load up everything, because it is all about to go away.
(load-option 'SF)
(load-option 'CREF)
(load-option '*PARSER)
# Remove host code to STAGEX/ subdirs.
run_cmd ./Stage.sh make X
-# Dodge unfortunate incompatibility between 9.0.1 and master.
+# Dodge incompatibility between 9.0.1 and master.
run_cmd_in_dir runtime mv os2winp.ext os2winp.bin STAGEX
-# Restore previously cross-compiled code (if any).
-# (Comment this out to start from scratch with each rebuilt cross-compiler.)
-if [ -e sf/STAGE0 ]; then run_cmd ./Stage.sh unmake 0; fi
+# Restore previously cross-compiled code (if any). (Replace "unmake"
+# with "remove" to start from scratch with each rebuilt
+# cross-compiler.)
+run_cmd ./Stage.sh unmake 0
# Cross-compile everything, producing svm1 .moc's.
# edwin/snr.scm needs more than --heap 9000!
(fluid-let (;;(compiler:generate-lap-files? #t)
;;(compiler:intersperse-rtl-in-lap? #t)
(compiler:cross-compiling? #t))
-
- ;; Compile star-parser before runtime, so runtime.sf does
- ;; not die. Our --library does not include a *PARSER option!
+ ;; Syntax star-parser before runtime, so runtime.sf does not die.
+ ;; Our --library does not already include a *PARSER option!
(compile-cref compile-dir)
(compile-dir "star-parser")
- (compile-everything))
- (sf "compiler/base/crsend"))
+ (compile-everything)))
EOF
# Finish the cross-compilation with the new machine.
STACK_PUSH (reflect_to_interface); \
} while (false)
-typedef enum
-{
- TRAMPOLINE_K_RETURN_TO_INTERPRETER,
- TRAMPOLINE_K_APPLY,
- TRAMPOLINE_K_ARITY, /* unused */
- TRAMPOLINE_K_ENTITY, /* unused */
- TRAMPOLINE_K_INTERPRETED, /* unused */
- TRAMPOLINE_K_LEXPR_PRIMITIVE,
- TRAMPOLINE_K_PRIMITIVE,
- TRAMPOLINE_K_LOOKUP,
- TRAMPOLINE_K_1_0,
- TRAMPOLINE_K_2_1,
- TRAMPOLINE_K_2_0,
- TRAMPOLINE_K_3_2,
- TRAMPOLINE_K_3_1,
- TRAMPOLINE_K_3_0,
- TRAMPOLINE_K_4_3,
- TRAMPOLINE_K_4_2,
- TRAMPOLINE_K_4_1,
- TRAMPOLINE_K_4_0,
- TRAMPOLINE_K_REFLECT_TO_INTERFACE = 0x3A
-} trampoline_type_t;
-
#define TC_TRAMPOLINE_HEADER TC_FIXNUM
#define TRAMPOLINE_TABLE_SIZE 4
start of the trampoline's storage area. */
extern SCHEME_OBJECT * trampoline_storage (SCHEME_OBJECT *);
+typedef enum
+{
+ TRAMPOLINE_K_RETURN_TO_INTERPRETER,
+ TRAMPOLINE_K_APPLY,
+ TRAMPOLINE_K_ARITY, /* unused */
+ TRAMPOLINE_K_ENTITY, /* unused */
+ TRAMPOLINE_K_INTERPRETED, /* unused */
+ TRAMPOLINE_K_LEXPR_PRIMITIVE,
+ TRAMPOLINE_K_PRIMITIVE,
+ TRAMPOLINE_K_LOOKUP,
+ TRAMPOLINE_K_1_0,
+ TRAMPOLINE_K_2_1,
+ TRAMPOLINE_K_2_0,
+ TRAMPOLINE_K_3_2,
+ TRAMPOLINE_K_3_1,
+ TRAMPOLINE_K_3_0,
+ TRAMPOLINE_K_4_3,
+ TRAMPOLINE_K_4_2,
+ TRAMPOLINE_K_4_1,
+ TRAMPOLINE_K_4_0,
+ TRAMPOLINE_K_REFLECT_TO_INTERFACE = 0x3A
+} trampoline_type_t;
+
#ifndef UTILITY_RESULT_DEFINED
#ifdef CMPINT_USE_STRUCS
if ((*address) == SVM1_INST_ENTER_CLOSURE)
{
- make_cc_entry_type (cet, CET_CLOSURE);
+ n = read_u16 (address - 2);
+ make_compiled_procedure_type
+ (cet, (n & 0x007F), ((n & 0x3F80) >> 7), ((n & 0x4000) != 0));
return (false);
}
n = (read_u16 (address - 4));
n = (0xFFF8 + 2);
break;
- case CET_CLOSURE:
- return ((*address) != SVM1_INST_ENTER_CLOSURE);
-
default:
return (true);
}
write_u16 (n, (address - 4));
return (false);
}
-\f
-/* 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)
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);
}
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);
}
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
*/
insn_t *
compiled_closure_start (SCHEME_OBJECT * block)
{
- return (((insn_t *) block) + CLOSURE_COUNT_SIZE);
+ return (((insn_t *) block) + CLOSURE_ENTRY_OFFSET);
}
insn_t *
{
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]);
}
\f
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
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);
}
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
/* -*-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.
*/
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); \
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); \
#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); \
#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 \
#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];
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)
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)
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
{
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)
return ((* (inst_defns[NEXT_BYTE])) ());
}
-static insn_t *
+static bool
illegal_instruction (void)
{
signal_illegal_instruction ();
NEXT_PC;
}
\f
+#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))))
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])));
- }
-}
\f
/* Conditional jumps */
return ((* (traps_0[code])) ());
}
-static byte_t *
+static bool
illegal_trap_0 (void)
{
signal_illegal_instruction ();
return ((* (traps_1[code])) (r1));
}
-static byte_t *
+static bool
illegal_trap_1 (wreg_t r1)
{
signal_illegal_instruction ();
return ((* (traps_2[code])) (r1, r2));
}
-static byte_t *
+static bool
illegal_trap_2 (wreg_t r1, wreg_t r2)
{
signal_illegal_instruction ();
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 ();
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)
\f
#define DEFINE_TRAP_0(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (void) \
{ \
TRAP_PREFIX (result); \
}
#define DEFINE_TRAP_1(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (wreg_t source1) \
{ \
TRAP_PREFIX (result); \
}
#define DEFINE_TRAP_2(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (wreg_t source1, wreg_t source2) \
{ \
TRAP_PREFIX (result); \
}
#define DEFINE_TRAP_3(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (wreg_t source1, wreg_t source2, wreg_t source3) \
{ \
TRAP_PREFIX (result); \
}
\f
#define DEFINE_TRAP_R0(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (void) \
{ \
TRAP_PREFIX (result); \
}
#define DEFINE_TRAP_R1(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (wreg_t source1) \
{ \
TRAP_PREFIX (result); \
}
#define DEFINE_TRAP_R2(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (wreg_t source1, wreg_t source2) \
{ \
TRAP_PREFIX (result); \
}
#define DEFINE_TRAP_R3(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (wreg_t source1, wreg_t source2, wreg_t source3) \
{ \
TRAP_PREFIX (result); \
}
#define DEFINE_TRAMPOLINE(nl, util_name) \
-byte_t * \
+bool \
trap_##nl (void) \
{ \
TRAP_PREFIX (result); \
DEFINE_TRAMPOLINE (reflect_to_interface, reflect_to_interface)
DEFINE_TRAMPOLINE (return_to_interpreter, return_to_interpreter)
\f
+#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); \
} \
}
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])));
+ }
+}
\f
DEFINE_INST (flonum_header_u8)
{
projects / mit-scheme.git / commitdiff