@$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" --compiler
$(MAKE) build-bands
-all-svm: compile-microcode
+all-svm: microcode/svm1-defns.h
+ $(MAKE) compile-microcode
@$(top_srcdir)/etc/compile-svm.sh "$(MIT_SCHEME_EXE)"
$(MAKE) build-bands
+microcode/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 \
+ compiler/machines/svm/compile-assembler.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
$(MAKE) compile-liarc-bundles build-bands
tags TAGS:
$(top_srcdir)/Tags.sh $(SUBDIRS)
+subdir-list:
+ @for D in $(SUBDIRS); do echo $$D; done
+
install: install-standard @INSTALL_LIARC_BUNDLES@
install-standard: install-auxdir-top
.PHONY: compile-microcode build-bands
.PHONY: liarc-dist compile-liarc-bundles install-liarc-bundles
.PHONY: mostlyclean clean distclean maintainer-clean c-clean clean-boot-root
-.PHONY: tags TAGS install install-standard install-auxdir-top
+.PHONY: tags TAGS subdir-list install install-standard install-auxdir-top
--- /dev/null
+#!/bin/sh
+#
+# Copyright (C) 2010 Massachusetts Institute of Technology
+#
+# This file is part of MIT/GNU Scheme.
+#
+# MIT/GNU Scheme is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+# Utility to stage everything used by the compiler. The working
+# directory should be the top-level source directory.
+
+set -e
+
+. 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
+done
case ${1} in
distclean | maintainer-clean)
- echo "rm -f machine compiler.cbf compiler.pkg compiler.sf make.com make.so"
- rm -f machine compiler.cbf compiler.pkg compiler.sf make.com make.so
+ 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
;;
esac
# Utility for MIT/GNU Scheme compiler staging.
+set -e
+
+. ../etc/functions.sh
+
if [ $# -ne 2 ]; then
echo "usage: $0 <command> <tag>"
exit 1
(cd ${D} && mkdir "${S}" && mv -f *.com *.bci "${S}") || exit 1
done
;;
+make-cross)
+ for D in $SUBDIRS; do
+ ( cd $D
+ mkdir "$S"
+ maybe_mv *.com "$S"
+ maybe_mv *.bci "$S"
+ maybe_mv *.moc "$S"
+ maybe_mv *.fni "$S" )
+ done
+ ;;
unmake)
for D in ${SUBDIRS}; do
(cd ${D} && mv -f "${S}"/* . && rmdir "${S}") || exit 1
(error:bad-range-argument pv 'PVAR-INDEX))
(if (eq? (car pvars) pv)
index
- (loop (cdr pvars) (fix:+ index 1)))))
\ No newline at end of file
+ (loop (cdr pvars) (fix:+ index 1)))))
+
+;;; This hides the rule-matcher forms in assembler-runtime.
+(define-syntax RULE-MATCHER
+ (rsc-macro-transformer
+ (lambda (form environment)
+ form environment
+ #f)))
\ No newline at end of file
base)
(define-code-sequence (offset (_ base word-register)
- (_ offset unsigned-8)
+ (_ offset signed-8)
+ (_ oscale scale-factor))
+ base
+ offset
+ oscale)
+
+ (define-code-sequence (offset (_ base word-register)
+ (_ offset signed-16)
(_ oscale scale-factor))
base
offset
\f
;;;; Top level
+;;(define-import instructions (compiler lap-syntaxer))
+
+(define (add-instruction! keyword assemblers)
+ (let ((entry (assq keyword instructions)))
+ (if (pair? entry)
+ (set-cdr! entry assemblers)
+ (set! instructions (cons (cons keyword assemblers) instructions)))))
+
+(define (add-instruction-assembler! keyword assembler)
+ (let ((entry (assq keyword instructions)))
+ (if entry
+ (set-cdr! entry (cons assembler (cdr entry)))
+ (set! instructions (cons (list keyword assembler) instructions)))))
+
+(define (clear-instructions!)
+ (set! instructions '()))
+
(define (init-assembler-instructions!)
;; Initialize the assembler's instruction database using the
- ;; patterns in the instruction coding type.
- (let ((keywords '()))
- (for-each
- (lambda (defn)
- (let* ((keyword (car (rt-defn-pattern defn)))
+ ;; 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.
+
+ (clear-instructions!)
+
+ ;; Create the fixed width instruction assemblers first. They are
+ ;; used to create the variable-width instruction assemblers.
+ (for-each
+ (lambda (keyword.defns)
+ (add-instruction!
+ (car keyword.defns)
+ (map fixed-instruction-assembler (cdr keyword.defns))))
+ (instruction-keywords))
+
+ ;; Create the variable width instruction assemblers.
+ (add-instruction-assembler! 'STORE (store-assembler))
+ (add-instruction-assembler! 'LOAD (load-assembler))
+ (add-instruction-assembler! 'LOAD-ADDRESS (load-address-assembler))
+ (add-instruction-assembler! 'JUMP (jump-assembler))
+ (add-instruction-assembler! 'CONDITIONAL-JUMP (cjump1-assembler))
+ (add-instruction-assembler! 'CONDITIONAL-JUMP (cjump2-assembler)))
+
+(define (instruction-keywords)
+ ;; An alist: instruction keyword X list of rt-defns.
+ (let loop ((keywords '())
+ (defns (rt-coding-type-defns (rt-coding-type 'instruction))))
+ (if (pair? defns)
+ (let* ((defn (car defns))
+ (keyword (car (rt-defn-pattern defn)))
(entry (assq keyword keywords)))
(if entry
- (set-cdr! entry (cons defn (cdr entry)))
- (set! keywords (cons (cons keyword defn) keywords)))))
- (rt-coding-type-defns (rt-coding-type 'instruction)))
- (for-each
- (lambda (keyword.defns)
- (add-instruction!
- (car keyword.defns)
- (map (lambda (defn)
- (let ((pattern (cdr (rt-defn-pattern defn))))
- ;; The matcher.
- (lambda (expr) ;without keyword
- (let ((pvals (match-pattern pattern expr
- (make-typed-symbol-table))))
- (and pvals
- ;; The match result thunk.
- (lambda ()
- (error "cannot yet assemble" expr defn)))))))
- (cdr keyword.defns))))
- keywords)))
-
-;;;(define-import add-instruction! (compiler lap-syntaxer))
-
+ (begin
+ (set-cdr! entry (cons defn (cdr entry)))
+ (loop keywords (cdr defns)))
+ (loop (cons (list keyword defn) keywords)
+ (cdr defns))))
+ keywords)))
+
+(define (fixed-instruction-assembler defn)
+ ;; Return a rule matching the exact instruction pattern in rt-DEFN.
+ ;; It will match only appropriately-sized constants.
+ (lambda (expression) ;without keyword
+ (let ((pvals (match-pattern (cdr (rt-defn-pattern defn))
+ expression
+ (make-typed-symbol-table))))
+ (and pvals
+ ;; The match result thunk.
+ (lambda ()
+ (let ((bytes '()))
+ ((rt-defn-encoder defn)
+ (make-rt-instance defn pvals)
+ (lambda (byte) (set! bytes (cons byte bytes))))
+ (map (lambda (byte)
+ (if (integer? byte)
+ (vector-ref bit-strings byte)
+ byte))
+ (reverse! bytes))))))))
+
+(define bit-strings
+ (let ((v (make-vector 256)))
+ (let loop ((i 0))
+ (if (fix:< i 256)
+ (begin
+ (vector-set! v i (unsigned-integer->bit-string 8 i))
+ (loop (fix:1+ i)))))
+ v))
+
+(define (fixed-instruction-width lap)
+ (if (and (pair? lap) (pair? (car lap)) (null? (cdr lap)))
+ (reduce-left + 0 (map bit-string-length
+ (lap:syntax-instruction (car lap))))
+ (error "FIXED-INSTRUCTION-WIDTH: Multiple instructions in LAP" lap)))
+
+(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)))
+ (error "Mis-sized fixed instruction" lap))
+ (list bits))
+ (error "ASSEMBLE-FIXED-INSTRUCTION: Multiple instructions in LAP" lap)))
+
+(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)))))))
+
+(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)))))))
+
+(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)))))))
+
+(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)))))))
+
+(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)))))))
+
+(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)))))))
+\f
(define (match-rt-coding-type name expression symbol-table)
(let loop ((defns (rt-coding-type-defns (rt-coding-type name))))
(and (pair? defns)
\f
;;;; Assembler Machine Dependencies
-(let-syntax
- ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
-
(define-integrable maximum-padding-length
;; Instructions can be any number of bytes long.
;; Thus the maximum padding is 7 bytes.
0)
(define-integrable instruction-append bit-string-append)
-
-;;; end let-syntax
-)
\f
;;;; Patterns
(define-integrable (pvar-type pv) (caddr pv))
\f
(define (match-pattern pattern expression symbol-table)
+ (let ((pvals (match-pattern* pattern expression symbol-table)))
+ (and pvals (reverse! pvals))))
+
+(define (match-pattern* pattern expression symbol-table)
(let loop ((pattern pattern) (expression expression) (pvals '()))
(if (pair? pattern)
(if (eq? (car pattern) '_)
(let ((pvt (lookup-pvar-type (pvar-type pattern))))
(if pvt
- (and (or ((pvt-predicate pvt) expression)
- (eq? (match-symbolic-expression expression
- symbol-table)
- (pvt-sb-type pvt)))
+ (and ((pvt-predicate pvt) expression)
(cons expression pvals))
(let ((instance
(match-rt-coding-type (pvar-type pattern)
\f
;;;; Registers
-(define (any-register? object)
- (and (index-fixnum? object)
- (fix:< object number-of-machine-registers)
- object))
-
-(define (word-register? object)
- (and (any-register? object)
- (fix:< object regnum:float-0)
- object))
-
-(define (float-register? object)
- (and (any-register? object)
- (fix:>= object regnum:float-0)
- (fix:- object regnum:float-0)))
-
-(define (register-reference? object)
- ;; Copied from lapgen.scm, for assembler rule compilation (withOUT lapgen).
- (and (pair? object)
- (eq? (car object) 'R)
- (pair? (cdr object))
- (index-fixnum? (cadr object))
- (fix:< (cadr object) number-of-machine-registers)
- (null? (cddr object))))
-
(define (word-register-reference? object)
- (and (pair? object)
- (eq? (car object) 'R)
- (pair? (cdr object))
- (index-fixnum? (cadr object))
- (fix:< (cadr object) regnum:float-0)
- (null? (cddr object))))
+ (and (register-reference? object)
+ (fix:< (reference->register object) regnum:float-0)))
(define (float-register-reference? object)
- (and (pair? object)
- (eq? (car object) 'R)
- (pair? (cdr object))
- (index-fixnum? (cadr object))
- (fix:>= (cadr object) regnum:float-0)
- (fix:< (cadr object) number-of-machine-registers)
- (null? (cddr object))))
-\f
-;;;; Symbolic expressions
-
-(define (match-symbolic-expression expression symbol-table)
- (let loop ((expression expression))
- (cond ((symbol? expression)
- (let ((binding (lookup-symbol expression symbol-table)))
- (and binding
- (symbol-binding-type binding))))
- ((and (pair? expression)
- (symbol? (car expression))
- (list? (cdr expression))
- (lookup-symbolic-operator (car expression) #f))
- => (lambda (op)
- (let ((types
- (map (lambda (expression)
- (cond ((se-integer? expression) 'INTEGER)
- ((se-float? expression) 'FLOAT)
- ;;((se-address? expression) 'ADDRESS)
- (else (loop expression))))
- (cdr expression))))
- (and (pair? types)
- (for-all? types (lambda (type) type))
- ((symbolic-operator-matcher op) types)))))
- (else #f))))
-
-(define (symbolic-pval? pval)
- (or (symbol? pval)
- (and (pair? pval)
- (symbol? (car pval)))))
-
-(define (sb-type:address? type) (eq? type 'ADDRESS))
-(define (sb-type:integer? type) (eq? type 'INTEGER))
-(define (sb-type:float? type) (eq? type 'FLOAT))
-
-(define (define-symbolic-operator name matcher evaluator)
- (hash-table/put! symbolic-operators name (cons matcher evaluator)))
-
-(define (symbolic-operator-matcher op)
- (car op))
-
-(define (symbolic-operator-evaluator op)
- (cdr op))
-
-(define (lookup-symbolic-operator name error?)
- (or (hash-table/get symbolic-operators name #f)
- (and error? (error:bad-range-argument name #f))))
-
-(define symbolic-operators
- (make-strong-eq-hash-table))
-
-(define-integrable (se-integer? object)
- (exact-integer? object))
-
-(define-integrable (se-float? object)
- (flo:flonum? object))
-
-#|
-(define (se-address? object)
- ???)
-
-(define (se-address:+ address offset)
- ???)
-
-(define (se-address:- address1 address2)
- ???)
-|#
-\f
-(define-symbolic-operator '+
- (lambda (types)
- (and (or (for-all? types sb-type:integer?)
- (for-all? types sb-type:float?)
- (and (sb-type:address? (car types))
- (for-all? (cdr types) sb-type:integer?)))
- (car types)))
- (lambda (pvals)
-;; (if (se-address? (car pvals))
-;; (se-address:+ (car pvals) (apply + (cdr pvals)))
-;; (apply + pvals))))
- (apply + pvals)))
-
-(define-symbolic-operator '-
- (lambda (types)
- (and (fix:= (length types) 2)
- (let ((t1 (car types))
- (t2 (cadr types)))
- (cond ((and (sb-type:address? t1) (sb-type:integer? t2)) t1)
- ((not (eq? t1 t2)) #f)
- ((or (sb-type:integer? t1) (sb-type:float? t1)) t1)
- ((sb-type:address? t1) 'INTEGER)
- (else #f)))))
- (lambda (pvals)
- (let ((pv1 (car pvals))
- (pv2 (cadr pvals)))
-;; (if (se-address? pv1)
-;; (if (se-address? pv2)
-;; (se-address:- pv1 pv2)
-;; (se-address:+ pv1 (- pv2)))
-;; (- pv1 pv2)))))
- (- pv1 pv2))))
-
-(define-symbolic-operator '*
- (lambda (types)
- (and (or (for-all? types sb-type:integer?)
- (for-all? types sb-type:float?))
- (car types)))
- (lambda (pvals)
- (apply * pvals)))
-
-(define-symbolic-operator '/
- (lambda (types)
- (and (fix:= (length types) 2)
- (let ((t1 (car types))
- (t2 (cadr types)))
- (and (eq? t1 t2)
- (or (sb-type:integer? t1)
- (sb-type:float? t1))
- t1))))
- (lambda (pvals)
- (let ((pv1 (car pvals))
- (pv2 (cadr pvals)))
- (if (exact-integer? pv1)
- (quotient pv1 pv2)
- (/ pv1 pv2)))))
+ (and (register-reference? object)
+ (let ((regnum (reference->register object)))
+ (and (fix:>= regnum regnum:float-0)
+ (fix:< regnum number-of-machine-registers)))))
\f
;;;; Pattern-variable types
(define-pvt 'TYPE-WORD 'TC 'INTEGER
(lambda (object)
- (and (se-integer? object)
- (< object #x40)))
+ (and (exact-nonnegative-integer? object) (< object #x40)))
'ENCODE-UNSIGNED-INTEGER-8
'DECODE-UNSIGNED-INTEGER-8)
(define-pvt 'FLOAT 'FLT 'FLOAT
(lambda (object)
- (se-float? object))
+ (flo:flonum? object))
'ENCODE-FLOAT
'DECODE-FLOAT)
x)))
(else x)))))
-;;;(define-import register-reference (compiler lap-syntaxer))
-;;;(define-import reference->register (compiler lap-syntaxer))
-
(define (encode-rref rref write-byte)
- (encode-unsigned-integer-8 (reference->register rref) write-byte))
+ (let ((regnum (reference->register rref)))
+ (encode-unsigned-integer-8
+ (if (fix:< regnum regnum:float-0)
+ regnum
+ (fix:- regnum regnum:float-0))
+ write-byte)))
(define (decode-rref read-byte)
(register-reference (decode-unsigned-integer-8 read-byte)))
\ No newline at end of file
(lambda ()
(let ((environment (make-top-level-environment)))
(load "machine" environment)
- (load "assembler-runtime" environment)
+ ;; Load assembler-compiler before -runtime.
+ ;; It needs to create RULE-MATCHER anti-syntax.
(load "assembler-compiler" environment)
+ (load "assembler-runtime" environment)
((access compile-assembler-rules environment) "assembler-rules.scm"))))
\ No newline at end of file
(export (compiler)
instruction-append)
(import (compiler lap-syntaxer)
- add-instruction!
- reference->register
- register-reference)
+ instructions)
(export (compiler top-level)
assemble))
;;;; Register-allocator interface
(define available-machine-registers
- (let loop ((r regnum:environment))
+ (let loop ((r regnum:word-0))
(if (< r number-of-machine-registers)
(cons r (loop (+ r 1)))
'())))
(cond ((register-value-class=word? register) 'WORD)
((register-value-class=float? register) 'FLOAT)
(else (error:bad-range-argument register 'REGISTER-TYPE))))
-\f
-;;;; Register references
-
-(define register-reference
- (let ((references (make-vector number-of-machine-registers)))
- (do ((i 0 (+ i 1)))
- ((>= i number-of-machine-registers))
- (vector-set! references i `(R ,i)))
- (lambda (register)
- (guarantee-limited-index-fixnum register
- number-of-machine-registers
- 'REGISTER-REFERENCE)
- (vector-ref references register))))
-
-(define (register-reference? object)
- (and (pair? object)
- (eq? (car object) 'R)
- (pair? (cdr object))
- (index-fixnum? (cadr object))
- (fix:< (cadr object) number-of-machine-registers)
- (null? (cddr object))))
-
-(define-guarantee register-reference "register reference")
-
-(define (reference->register reference)
- (guarantee-register-reference reference 'REFERENCE->REGISTER)
- (cadr reference))
-
-(define-integrable rref:word-0 (register-reference regnum:word-0))
-(define-integrable rref:word-1 (register-reference (+ 1 regnum:word-0)))
-(define-integrable rref:word-2 (register-reference (+ 2 regnum:word-0)))
-(define-integrable rref:word-3 (register-reference (+ 3 regnum:word-0)))
-(define-integrable rref:word-4 (register-reference (+ 4 regnum:word-0)))
-(define-integrable rref:word-5 (register-reference (+ 5 regnum:word-0)))
-(define-integrable rref:word-6 (register-reference (+ 6 regnum:word-0)))
(define (register->register-transfer source target)
(if (= source target)
(LAP)
(begin
(guarantee-registers-compatible source target)
- (inst:copy (register-type target)
- (register-reference target)
- (register-reference source)))))
+ (inst:copy (register-reference target) (register-reference source)))))
(define (reference->register-transfer source target)
(cond ((register-reference? source)
(define (pseudo-register-home register)
(error "Attempt to access temporary register:" register))
-
-(define-syntax define-fixed-register-references
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(* symbol) (cdr form))
- `(BEGIN
- ,@(map (lambda (name)
- `(DEFINE-INTEGRABLE ,(symbol-append 'RREF: name)
- (REGISTER-REFERENCE ,(symbol-append 'REGNUM: name))))
- (cdr form)))
- (ill-formed-syntax form)))))
-
-(define-fixed-register-references
- stack-pointer
- dynamic-link
- free-pointer
- value
- environment)
\f
;;;; Linearizer interface
(define (make-external-label label type-code)
(set! *external-labels* (cons label *external-labels*))
(LAP ,@(inst:datum-u16 type-code)
- ,@(inst:datum-u16 `(- ,label *START*))
+ (BLOCK-OFFSET ,label)
,@(inst:label label)))
(define (make-expression-label label)
(pattern-lookup memory-ref-rules expression))
(define (parse-memory-address expression)
- (let ((thunk (pattern-lookup memory-address-rules expression)))
- (and thunk
- (receive (scale ea)
- (thunk)
- scale
- ea))))
+ (pattern-lookup memory-address-rules expression))
(define (make-memory-rules offset-operator?)
(list (rule-matcher ((? scale offset-operator?)
'())))
(ill-formed-syntax form)))))
-(define-syntax define-generic-unary-operations
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(* SYMBOL) (cdr form))
- `(BEGIN
- ,@(let loop ((names (cdr form)))
- (if (pair? names)
- (cons `(DEFINE-INST ,(car names) TYPE TARGET SOURCE)
- (loop (cdr names)))
- '())))
- (ill-formed-syntax form)))))
-
(define-syntax define-binary-operations
(sc-macro-transformer
(lambda (form environment)
'())))
(ill-formed-syntax form)))))
-(define-syntax define-generic-binary-operations
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (if (syntax-match? '(* SYMBOL) (cdr form))
- `(BEGIN
- ,@(let loop ((names (cdr form)))
- (if (pair? names)
- (cons `(DEFINE-INST ,(car names) TYPE
- TARGET SOURCE1 SOURCE2)
- (loop (cdr names)))
- '())))
- (ill-formed-syntax form)))))
-
(define-inst store size source address)
(define-inst load size target address)
(define-inst load-address target address)
(define (load-immediate-operand? n)
(or (and (exact-integer? n)
- (<= #x80000000 n < #x100000000))
+ (<= #x-80000000 n) (<= n #x7FFFFFFF))
(flo:flonum? n)))
;; TYPE and DATUM can be constants or registers; address is a register.
(define-inst datum-s16 expression)
(define-inst datum-s32 expression)
-(define-generic-unary-operations
- copy negate increment decrement abs)
-
(define-unary-operations
+ copy negate increment decrement abs
object-type object-datum object-address
fixnum->integer integer->fixnum address->integer integer->address
not
log exp cos sin tan acos asin atan
flonum-align flonum-length)
-(define-generic-binary-operations
- + - *)
-
(define-binary-operations
+ + - *
quotient remainder
lsh and andc or xor
max-unsigned min-unsigned
(ea:pc-relative `(- ,label *PC*)))
(define (ea:stack-pop)
- (ea:post-increment regnum:stack-pointer 'WORD))
+ (ea:post-increment rref:stack-pointer 'WORD))
(define (ea:stack-push)
- (ea:pre-decrement regnum:stack-pointer 'WORD))
+ (ea:pre-decrement rref:stack-pointer 'WORD))
(define (ea:stack-ref index)
- (ea:offset regnum:stack-pointer index 'WORD))
+ (ea:offset rref:stack-pointer index 'WORD))
(define (ea:alloc-word)
- (ea:post-increment regnum:free-pointer 'WORD))
+ (ea:post-increment rref:free-pointer 'WORD))
(define (ea:alloc-byte)
- (ea:post-increment regnum:free-pointer 'BYTE))
+ (ea:post-increment rref:free-pointer 'BYTE))
(define (ea:alloc-float)
- (ea:post-increment regnum:free-pointer 'FLOAT))
+ (ea:post-increment rref:free-pointer 'FLOAT))
+
+(define (ea:environment)
+ (ea:offset rref:interpreter-register-block
+ register-block/environment-offset 'WORD))
+
+(define (ea:lexpr-actuals)
+ (ea:offset rref:interpreter-register-block
+ register-block/lexpr-actuals-offset 'WORD))
\f
;;;; Traps
environment
`(BEGIN
,@(map (lambda (name)
- `(DEFINE (,(symbol-append 'TRAP: name) . ARGS)
- (APPLY INST:TRAP ',name ARGS)))
+ (let ((code (if (pair? name) (cadr name) name))
+ (prim (if (pair? name) (car name) name)))
+ `(DEFINE (,(symbol-append 'TRAP: prim) . ARGS)
+ (APPLY INST:TRAP ',code ARGS))))
(cdr form))))))
(define-traps
;; This group doesn't return; don't push return address.
- apply lexpr-apply cache-reference-apply lookup-apply
+ apply lexpr-apply cache-reference-apply
primitive-apply primitive-lexpr-apply
error primitive-error
- &+ &- &* &/ 1+ -1+ quotient remainder modulo
- &= &< &> zero? positive? negative?
+ (&+ add) (&- subtract) (&* multiply) (&/ divide) (1+ increment)
+ (-1+ decrement) quotient remainder modulo
+ (&= equal?) (&< less?) (&> greater?) zero? positive? negative?
;; This group returns; push return address.
- link conditionally-serialize
- reference-trap safe-reference-trap assignment-trap unassigned?-trap
+ link assignment
lookup safe-lookup set! unassigned? define unbound? access)
(define-syntax define-interrupt-tests
(define-interrupt-tests
closure dynamic-link procedure continuation ic-procedure)
\f
-;;;; Machine registers
+;;;; Machine registers, register references.
(define-integrable number-of-machine-registers 512)
(define-integrable number-of-temporary-registers 512)
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (do ((i 0 (+ i 1)))
+ ((>= i number-of-machine-registers))
+ (vector-set! references i `(R ,i)))
+ (lambda (register)
+ (guarantee-limited-index-fixnum register
+ number-of-machine-registers
+ 'REGISTER-REFERENCE)
+ (vector-ref references register))))
+
+(define (register-reference? object)
+ (and (pair? object)
+ (eq? (car object) 'R)
+ (pair? (cdr object))
+ (index-fixnum? (cadr object))
+ (fix:< (cadr object) number-of-machine-registers)
+ (null? (cddr object))))
+
+(define-guarantee register-reference "register reference")
+
+(define (reference->register reference)
+ (guarantee-register-reference reference 'REFERENCE->REGISTER)
+ (cadr reference))
+
(define-syntax define-fixed-registers
(sc-macro-transformer
(lambda (form environment)
`(DEFINE-INTEGRABLE ,(symbol-append 'REGNUM: (car p))
,(cdr p)))
alist)
+ ,@(map (lambda (p)
+ `(DEFINE-INTEGRABLE ,(symbol-append 'RREF: (car p))
+ (REGISTER-REFERENCE ,(cdr p))))
+ alist)
(DEFINE FIXED-REGISTERS ',alist)))
(ill-formed-syntax form)))))
(define-fixed-registers
+ interpreter-register-block
stack-pointer
- dynamic-link
free-pointer
value
- environment)
+ dynamic-link)
(define-integrable regnum:float-0 256)
-(define-integrable regnum:word-0 regnum:environment)
+(define-integrable regnum:word-0 (1+ regnum:dynamic-link))
+
+(define-integrable rref:word-0 (register-reference regnum:word-0))
+(define-integrable rref:word-1 (register-reference (+ 1 regnum:word-0)))
+(define-integrable rref:word-2 (register-reference (+ 2 regnum:word-0)))
+(define-integrable rref:word-3 (register-reference (+ 3 regnum:word-0)))
+(define-integrable rref:word-4 (register-reference (+ 4 regnum:word-0)))
+(define-integrable rref:word-5 (register-reference (+ 5 regnum:word-0)))
+(define-integrable rref:word-6 (register-reference (+ 6 regnum:word-0)))
+(define-integrable rref:word-7 (register-reference (+ 7 regnum:word-0)))
(define-integrable (machine-register-known-value register)
register
(guarantee-limited-index-fixnum register
number-of-machine-registers
'MACHINE-REGISTER-VALUE-CLASS)
- (cond ((or (fix:= register regnum:stack-pointer)
+ (cond ((or (fix:= register regnum:interpreter-register-block)
+ (fix:= register regnum:stack-pointer)
(fix:= register regnum:dynamic-link)
(fix:= register regnum:free-pointer))
value-class=address)
((fix:< register regnum:float-0) value-class=object)
(else value-class=float)))
+
+(define-integrable register-block/memtop-offset 0)
+(define-integrable register-block/int-mask-offset 1)
+(define-integrable register-block/environment-offset 3)
+(define-integrable register-block/lexpr-actuals-offset 7)
+(define-integrable register-block/stack-guard-offset 11)
\f
;;;; RTL Generator Interface
-(define (interpreter-register:environment)
- (rtl:make-machine-register regnum:environment))
-
(define (interpreter-register:access)
- (rtl:make-machine-register regnum:environment))
+ (rtl:make-machine-register regnum:word-0))
(define (interpreter-register:cache-reference)
- (rtl:make-machine-register regnum:environment))
+ (rtl:make-machine-register regnum:word-0))
(define (interpreter-register:cache-unassigned?)
- (rtl:make-machine-register regnum:environment))
+ (rtl:make-machine-register regnum:word-0))
(define (interpreter-register:lookup)
- (rtl:make-machine-register regnum:environment))
+ (rtl:make-machine-register regnum:word-0))
(define (interpreter-register:unassigned?)
- (rtl:make-machine-register regnum:environment))
+ (rtl:make-machine-register regnum:word-0))
(define (interpreter-register:unbound?)
- (rtl:make-machine-register regnum:environment))
+ (rtl:make-machine-register regnum:word-0))
(define-syntax define-machine-register
(sc-macro-transformer
(define-machine-register value-register regnum:value)
(define (interpreter-regs-pointer)
- (error "This machine does not have a register block."))
-(define-integrable (interpreter-regs-pointer? expression)
- expression
- #f)
+ (rtl:make-machine-register regnum:interpreter-register-block))
+
+(define (interpreter-regs-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:interpreter-register-block)))
+
+(define-integrable (interpreter-block-register offset-value)
+ (rtl:make-offset (interpreter-regs-pointer)
+ (rtl:make-machine-constant offset-value)))
+
+(define-integrable (interpreter-block-register? expression offset-value)
+ (and (rtl:offset? expression)
+ (interpreter-regs-pointer? (rtl:offset-base expression))
+ (let ((offset (rtl:offset-offset expression)))
+ (and (rtl:machine-constant? offset)
+ (= (rtl:machine-constant-value offset)
+ offset-value)))))
(define (rtl:machine-register? rtl-register)
(case rtl-register
((FREE) (interpreter-free-pointer))
((DYNAMIC-LINK) (interpreter-dynamic-link))
((VALUE) (interpreter-value-register))
- ((ENVIRONMENT)
- (interpreter-register:environment))
((INTERPRETER-CALL-RESULT:ACCESS)
(interpreter-register:access))
((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
((INTERPRETER-CALL-RESULT:UNBOUND?)
(interpreter-register:unbound?))
(else
- ;; Make this an error so that rtl:interpreter-register->offset is
- ;; never called.
- (error "No such register:" rtl-register))))
+ false)))
(define (rtl:interpreter-register->offset locative)
- (error "Unknown register type:" locative))
+ (case locative
+ ((MEMORY-TOP)
+ register-block/memtop-offset)
+ ((INT-MASK)
+ register-block/int-mask-offset)
+ ((STACK-GUARD)
+ register-block/stack-guard-offset)
+ ((ENVIRONMENT)
+ register-block/environment-offset)
+ (else
+ (error "No such interpreter register" locative))))
\f
(define (rtl:constant-cost expression)
(let ((if-integer
(let ((value ((load "base/make") "svm1")))
(set! (access compiler:compress-top-level? (->environment '(compiler))) #t)
+ ((access init-assembler-instructions! (->environment '(compiler assembler))))
value)
\ No newline at end of file
(ASSIGN (REGISTER (? target))
(? thunk parse-memory-ref))
(receive (scale source) (thunk)
- (inst:load scale (word-target target) source)))
+ (let ((target (case scale
+ ((BYTE WORD) (word-target target))
+ ((FLOAT) (float-target target))
+ (else (error "Unexpected load scale:" scale)))))
+ (inst:load scale target source))))
(define-rule statement
(ASSIGN (? thunk parse-memory-ref)
(REGISTER (? source)))
(receive (scale target) (thunk)
- (inst:store scale (word-source source) target)))
+ (let ((source (case scale
+ ((BYTE WORD) (word-source source))
+ ((FLOAT) (float-source source))
+ (else (error "Unexpected store scale:" scale)))))
+ (inst:store scale source target))))
(define-rule statement
(ASSIGN (? thunk parse-memory-ref)
(CONSTANT (? constant)))
(receive (scale target) (thunk)
- (let ((temp (word-temporary)))
+ (let ((temp (case scale
+ ((BYTE WORD) (word-temporary))
+ ((FLOAT) (float-temporary))
+ (else (error "Unexpected store constant scale:" scale)))))
(LAP ,@(load-constant temp constant)
,@(inst:store scale temp target)))))
(define-rule statement
(ASSIGN (REGISTER (? target))
- (? source-ea parse-memory-address))
- (inst:load-address (word-target target) source-ea))
+ (? thunk parse-memory-address))
+ (receive (scale source-ea) (thunk)
+ scale
+ (inst:load-address (word-target target) source-ea)))
(define-rule statement
(ASSIGN (REGISTER (? target))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type))
- (? source-ea parse-memory-address)))
- (let ((temp (word-temporary)))
- (LAP ,@(inst:load-address temp source-ea)
- ,@(inst:load-pointer (word-target target) type temp))))
+ (? thunk parse-memory-address)))
+ (receive (scale source-ea) (thunk)
+ scale
+ (let ((temp (word-temporary)))
+ (LAP ,@(inst:load-address temp source-ea)
+ ,@(inst:load-pointer (word-target target) type temp)))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(inst:integer->fixnum (word-target target)
source)))
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (OBJECT->FIXNUM (CONSTANT (? value))))
- (QUALIFIER (and (fix:fixnum? value) (load-immediate-operand? value)))
- (inst:load-immediate (word-target target)
- value))
-
;; The next two are no-ops on this architecture.
(define-rule statement
(REGISTER (? source)))
(simple-branches! (case predicate
((ZERO-FIXNUM?) 'EQ)
- ((NEGATIVE-FIXNUM?) 'LT)
- ((POSITIVE-FIXNUM?) 'GT)
+ ((NEGATIVE-FIXNUM?) 'SLT)
+ ((POSITIVE-FIXNUM?) 'SGT)
(else (error "Unknown fixnum predicate:" predicate)))
(word-source source))
(LAP))
(LAP))
(define-rule predicate
- (OVERFLOW-TEST (REGISTER (? source)))
- (simple-branches! 'NFIX source)
+ (OVERFLOW-TEST)
+ ;; The fixnum methods must test for overflow.
(LAP))
\f
(define-rule statement
(lambda (name inst)
(define-fixnum-1-arg-method name
(lambda (target source overflow?)
- overflow?
+ (if overflow? (simple-branches! 'NFIX target))
(inst target source))))))
(standard 'ONE-PLUS-FIXNUM inst:increment)
(standard 'MINUS-ONE-PLUS-FIXNUM inst:decrement)
(lambda (name inst)
(define-fixnum-2-args-method name
(lambda (target source1 source2 overflow?)
- overflow?
+ (if overflow? (simple-branches! 'NFIX target))
(inst target source1 source2))))))
(standard 'PLUS-FIXNUM inst:+)
(standard 'MINUS-FIXNUM inst:-)
(float-target target)
(ea:offset temp 1 'WORD)))))
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->FLOAT (CONSTANT (? value))))
+ (QUALIFIER (flo:flonum? value))
+ (inst:load-immediate (float-target target) value))
+
(define-rule predicate
(FLONUM-PRED-1-ARG (? predicate)
(REGISTER (? source)))
(float-source source1)
(float-source source2))
(LAP))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (OBJECT->FLOAT (CONSTANT (? constant))))
+ (QUALIFIER (flo:flonum? constant))
+ (let ((temp (float-temporary)))
+ (simple-branches! (case predicate
+ ((FLONUM-EQUAL?) 'EQ)
+ ((FLONUM-LESS?) 'LT)
+ ((FLONUM-GREATER?) 'GT)
+ (else (error "Unknown flonum predicate:" predicate)))
+ (float-source source1) temp)
+ (inst:load-immediate temp constant)))
\f
(define-rule statement
(ASSIGN (REGISTER (? target))
(FLONUM-1-ARG (? operation)
(REGISTER (? source))
(? overflow?)))
- (let ((source (word-source source)))
+ (let ((source (float-source source)))
((or (1d-table/get flonum-1-arg-methods operation #f)
(error "Unknown flonum operation:" operation))
- (word-target target)
+ (float-target target)
source
overflow?)))
(define-flonum-1-arg-method name
(lambda (target source overflow?)
overflow?
- (inst target target source))))))
+ (inst target source))))))
(standard 'FLONUM-NEGATE inst:negate)
(standard 'FLONUM-ABS inst:abs)
(standard 'FLONUM-SQRT inst:sqrt)
(REGISTER (? source1))
(REGISTER (? source2))
(? overflow?)))
- (let ((source1 (word-source source1))
- (source2 (word-source source2)))
+ (let ((source1 (float-source source1))
+ (source2 (float-source source2)))
((or (1d-table/get flonum-2-args-methods operation #f)
(error "Unknown flonum operation:" operation))
- (word-target target)
+ (float-target target)
source1
source2
overflow?)))
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (OBJECT->FLOAT (CONSTANT (? value)))
+ (? overflow?)))
+ (let ((source1 (float-source source1))
+ (temp (float-temporary)))
+ (LAP ,@(inst:load-immediate temp value)
+ ,@((or (1d-table/get flonum-2-args-methods operation #f)
+ (error "Unknown flonum operation:" operation))
+ (float-target target)
+ source1
+ temp
+ overflow?))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (OBJECT->FLOAT (CONSTANT (? value)))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (let ((source2 (float-source source2))
+ (temp (float-temporary)))
+ (LAP ,@(inst:load-immediate temp value)
+ ,@((or (1d-table/get flonum-2-args-methods operation #f)
+ (error "Unknown flonum operation:" operation))
+ (float-target target)
+ source2
+ temp
+ overflow?))))
+
(define flonum-2-args-methods
(make-1d-table))
(REGISTER (? extension)))
continuation
(expect-no-exit-interrupt-checks)
- (let ((set-extension (load-machine-register! extension regnum:word-0)))
- (LAP ,@set-extension
- ,@(clear-map!)
- ,@(inst:load-immediate rref:word-2 frame-size)
- ,@(inst:load-address rref:word-1 (ea:address *block-label*))
- ,@(trap:cache-reference-apply rref:word-0 rref:word-1 rref:word-2))))
+ (let ((rref:cache-addr (word-source extension))
+ (rref:block-addr (word-temporary))
+ (rref:frame-size (word-temporary)))
+ (LAP ,@(clear-map!)
+ ,@(inst:load-immediate rref:frame-size frame-size)
+ ,@(inst:load-address rref:block-addr (ea:address *block-label*))
+ ,@(trap:cache-reference-apply
+ rref:cache-addr rref:block-addr rref:frame-size))))
-(define-rule statement
+#| There is no comutil_lookup_apply, no (trap:lookup-apply ...) instruction.
+ (define-rule statement
(INVOCATION:LOOKUP (? frame-size)
(? continuation)
(REGISTER (? environment))
(? name))
continuation
(expect-no-entry-interrupt-checks)
- (let ((set-environment (load-machine-register! environment regnum:word-0)))
- (LAP ,@set-environment
- ,@(clear-map!)
- ,@(inst:load-immediate rref:word-2 frame-size)
- ,@(load-constant rref:word-1 name)
- ,@(trap:lookup-apply rref:word-0 rref:word-1 rref:word-2))))
+ (let ((rref:environment (word-source environment))
+ (rref:frame-size (word-temporary))
+ (rref:name (word-temporary)))
+ (LAP ,@(clear-map!)
+ ,@(inst:load-immediate rref:frame-size frame-size)
+ ,@(load-constant rref:name name)
+ ,@(trap:lookup-apply rref:environment rref:frame-size rref:name))))
+|#
(define-rule statement
(INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
,@(trap:error rref:word-0))
(LAP ,@(load-constant rref:word-0 primitive)
,@(let ((arity (primitive-procedure-arity primitive)))
- (if (>= arity 0)
- (trap:primitive-apply rref:word-0)
- (LAP ,@(inst:load-immediate rref:word-1 frame-size)
- ,@(if (= arity -1)
- (trap:primitive-lexpr-apply rref:word-0
- rref:word-1)
- (trap:apply rref:word-0
- rref:word-1)))))))))
+ (cond
+ ((>= arity 0)
+ (trap:primitive-apply rref:word-0))
+ ((= arity -1)
+ (LAP
+ ,@(inst:load-immediate rref:word-1 (- frame-size 1))
+ ,@(inst:store 'WORD rref:word-1 (ea:lexpr-actuals))
+ ,@(trap:primitive-lexpr-apply rref:word-0)))
+ (else
+ (LAP ,@(inst:load-immediate rref:word-1 frame-size)
+ ,@(trap:apply rref:word-0 rref:word-1)))))))))
(define-syntax define-primitive-invocation
(sc-macro-transformer
(LAP ,@(inst:min-unsigned temp (word-source r1) (word-source r2))
,@(move-frame-up frame-size temp)))))
-(define (move-frame-up frame-size register)
+(define (move-frame-up frame-size source)
(if (= frame-size 0)
- (if (= register rref:stack-pointer)
+ (if (= (reference->register source) regnum:stack-pointer)
(LAP)
- (inst:copy 'WORD rref:stack-pointer register))
+ (inst:copy rref:stack-pointer source))
(let ((temp (word-temporary)))
- (LAP ,@(inst:load-address temp
- (ea:offset register (- frame-size) 'WORD))
+ (LAP ,@(inst:load-address temp (ea:offset source (- frame-size) 'WORD))
,@(inst:copy-block frame-size 'WORD rref:stack-pointer temp)
- ,@(inst:copy 'WORD rref:stack-pointer temp)))))
+ ,@(inst:copy rref:stack-pointer temp)))))
\f
;;;; Procedure headers
,@(inst:load-immediate temp 0)
,@(inst:store 'BYTE temp (ea:offset free (1+ count-offset) 'BYTE))
- ,@(inst:load-pointer target
- (ucode-type compiled-entry)
- (ea:offset free entry-offset 'BYTE))
+ ,@(inst:load-address target (ea:offset free entry-offset 'BYTE))
+ ,@(inst:load-pointer target (ucode-type compiled-entry) target)
;; entry: (inst:enter-closure 0)
,@(inst:load-immediate temp svm1-inst:enter-closure)
,@(inst:store 'BYTE temp (ea:offset free (+ 2 entry-offset) 'BYTE))
;; target: procedure-label
- ,@(inst:load-pointer temp (ucode-type compiled-entry) (ea:address label))
+ ,@(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-targets entries woffset)
(let ((label (internal->external-label (caar entries))))
(LAP
- ,@(inst:load-pointer temp (ucode-type compiled-entry)
- (ea:address label))
+ ,@(inst:load-address temp (ea:address label))
+ ,@(inst:load-pointer temp (ucode-type compiled-entry) temp)
,@(inst:store 'WORD temp (ea:offset free woffset 'WORD))
,@(if (null? (cdr entries))
(LAP)
,@(inst:load-immediate temp (big-end nentries))
,@(inst:store 'BYTE temp (ea:offset free (1+ count-offset) 'BYTE))
- ,@(inst:load-pointer target (ucode-type compiled-entry)
- (ea:offset free first-entry-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)
(define (generate/closure-header internal-label nentries index)
index
(let ((external-label (internal->external-label internal-label)))
- (if (zero? nentries)
- (LAP (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header
+ (LAP (EQUATE ,external-label ,internal-label)
+ ,@(if (zero? nentries)
+ (simple-procedure-header
(make-internal-procedure-label internal-label)
- inst:interrupt-test-procedure))
- (LAP ,@(simple-procedure-header
- (make-internal-entry-label external-label)
+ inst:interrupt-test-procedure)
+ (simple-procedure-header
+ (make-internal-entry-label internal-label)
inst:interrupt-test-closure)))))
\f
(define-rule statement
;;; This is invoked by the top level of the LAP generator.
(define (generate/quotation-header environment-label free-ref-label n-sections)
- (LAP ,@(inst:store 'WORD regnum:environment (ea:address environment-label))
- ,@(inst:load-address rref:word-0 (ea:address *block-label*))
- ,@(inst:load-address rref:word-1 (ea:address free-ref-label))
- ,@(inst:load-immediate rref:word-2 n-sections)
- ,@(trap:link rref:word-0 rref:word-1 rref:word-2)
- ,@(make-internal-continuation-label (generate-label))))
+ (let ((rref:block-addr rref:word-0)
+ (rref:constant-addr rref:word-1)
+ (rref:n-sections rref:word-2))
+ (LAP ,@(inst:load 'WORD rref:word-0 (ea:environment))
+ ,@(inst:store 'WORD rref:word-0 (ea:address environment-label))
+ ,@(inst:load-address rref:block-addr (ea:address *block-label*))
+ ,@(inst:load-address rref:constant-addr (ea:address free-ref-label))
+ ,@(inst:load-immediate rref:n-sections n-sections)
+ ,@(trap:link rref:block-addr rref:constant-addr rref:n-sections)
+ ,@(make-internal-continuation-label (generate-label)))))
(define (generate/remote-link code-block-label
environment-offset
free-ref-offset
n-sections)
- (LAP ,@(inst:load-address rref:word-0 (ea:address code-block-label))
- ,@(inst:load-address rref:word-1
- (ea:offset rref:word-0
- environment-offset 'WORD))
- ,@(inst:store 'WORD regnum:environment (ea:indirect rref:word-1))
- ,@(inst:load-address rref:word-1 (ea:offset rref:word-0
- free-ref-offset 'WORD))
- ,@(inst:load-immediate rref:word-2 n-sections)
- ,@(trap:link rref:word-0 rref:word-1 rref:word-2)
- ,@(make-internal-continuation-label (generate-label))))
+ (let ((rref:block-addr rref:word-0)
+ (rref:constant-addr rref:word-1)
+ (rref:n-sections rref:word-2)
+ (rref:block.environment-addr rref:word-3)
+ (rref:environment rref:word-4))
+ (LAP ,@(inst:load-address rref:block-addr (ea:address code-block-label))
+ ,@(inst:load-address rref:block.environment-addr
+ (ea:offset rref:block-addr
+ environment-offset 'WORD))
+ ,@(inst:load 'WORD rref:environment (ea:environment))
+ ,@(inst:store 'WORD rref:environment
+ (ea:indirect rref:block.environment-addr))
+ ,@(inst:load-address rref:constant-addr
+ (ea:offset rref:block-addr
+ free-ref-offset 'WORD))
+ ,@(inst:load-immediate rref:n-sections n-sections)
+ ,@(trap:link rref:block-addr rref:constant-addr rref:n-sections)
+ ,@(make-internal-continuation-label (generate-label)))))
(define (generate/remote-links n-blocks vector-label n-sections)
(if (> n-blocks 0)
(rref:block rref:word-3)
(rref:n-sections rref:word-4)
(rref:sections rref:word-5)
- (rref:length rref:word-6))
+ (rref:length rref:word-6)
+ (rref:environment rref:word-7))
(LAP
;; Init index, bytes and vector.
,@(inst:load-immediate rref:index 0)
,@(inst:load-address rref:bytes (ea:address bytes-label))
,@(inst:load-address rref:vector (ea:address vector-label))
+ ,@(inst:load 'WORD rref:environment (ea:environment))
,@(inst:label loop-label)
,@(make-internal-continuation-label (generate-label))
;; Increment counter and loop
- ,@(inst:increment 'WORD rref:index rref:index)
+ ,@(inst:increment rref:index rref:index)
,@(inst:load-immediate rref:length n-blocks)
,@(inst:conditional-jump 'LT rref:index rref:length
(ea:address loop-label))
(let* ((cache (interpreter-call-temporary extension))
(value (interpreter-call-temporary value)))
(LAP ,@(clear-map!)
- ,@(trap:assignment-trap cache value))))
+ ,@(trap:assignment cache value))))
(define-rule statement
(INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension))
cont ; ignored
(let ((cache (interpreter-call-temporary extension)))
(LAP ,@(clear-map!)
- ,@(trap:unassigned?-trap cache))))
+ ,@(trap:unassigned? cache))))
\f
;;;; Interpreter Calls
(rtl:constant? (rtl:object->type-expression type))))
(rtl:make-cons-pointer
(rtl:make-machine-constant
- (object-type (rtl:constant-value (rtl:object->type-expression datum))))
+ (object-type (rtl:constant-value (rtl:object->type-expression type))))
datum))
-(define-rule rewriting
- (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
- (QUALIFIER (rtl:machine-constant? datum))
- (rtl:make-cons-pointer type datum))
-
(define-rule rewriting
(CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
(QUALIFIER
(and (rtl:object->datum? datum)
(rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
- (rtl:make-cons-pointer
+ (rtl:make-cons-non-pointer
type
(rtl:make-machine-constant
(object-datum (rtl:constant-value (rtl:object->datum-expression datum))))))
(zero? (rtl:machine-constant-value expression))))))
(else #f)))
\f
-;;;; Fixnums
+;;;; Fixnum rewriting.
(define-rule rewriting
(OBJECT->FIXNUM (REGISTER (? source register-known-value)))
(rtl:make-object->fixnum source))
(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (REGISTER (? operand-1 register-known-value))
- (? operand-2)
- (? overflow?))
- (QUALIFIER (rtl:constant-fixnum-test operand-1 (lambda (n) n #t)))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS MULTIPLY-FIXNUM
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (and (rtl:constant-fixnum-test operand-2 (lambda (n) n #t))))
- (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS (? operator)
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (and (memq operator '(PLUS-FIXNUM MINUS-FIXNUM))
- (rtl:register? operand-1)
- (rtl:constant-fixnum-test operand-2 zero?)))
- (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS (? operator)
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- (? overflow?))
- (QUALIFIER
- (and (memq operator '(FIXNUM-QUOTIENT FIXNUM-REMAINDER))
- (rtl:register? operand-1)
- (rtl:constant-fixnum-test operand-2
- (lambda (n)
- (integer-power-of-2? (abs n))))))
- (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
-
-(define (integer-power-of-2? n)
- (let loop ((power 1) (exponent 0))
- (cond ((< n power) #f)
- ((= n power) exponent)
- (else
- (loop (* 2 power) (1+ exponent))))))
-
-(define-rule rewriting
- (FIXNUM-2-ARGS FIXNUM-LSH
- (? operand-1)
- (REGISTER (? operand-2 register-known-value))
- #F)
- (QUALIFIER (and (rtl:register? operand-1)
- (rtl:constant-fixnum-test operand-2 (lambda (n) n #t))))
- (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F))
+ (OBJECT->FIXNUM (CONSTANT (? value)))
+ (QUALIFIER (fix:fixnum? value))
+ (rtl:make-machine-constant value))
(define (rtl:constant-fixnum? expression)
(and (rtl:constant? expression)
(fix:fixnum? (rtl:constant-value expression))
(rtl:constant-value expression)))
-
-(define (rtl:constant-fixnum-test expression predicate)
- (and (rtl:object->fixnum? expression)
- (let ((expression (rtl:object->fixnum-expression expression)))
- (and (rtl:constant? expression)
- (let ((n (rtl:constant-value expression)))
- (and (fix:fixnum? n)
- (predicate n)))))))
\f
+;;;; Flonum rewriting.
+
(define-rule rewriting
(OBJECT->FLOAT (REGISTER (? operand register-known-value)))
(QUALIFIER
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-# Utility for MIT/GNU Scheme compiler staging.
+# Utility for MIT/GNU Scheme subsystem staging.
+
+set -e
+
+. ../etc/functions.sh
if [ $# -ne 2 ]; then
echo "usage: $0 <command> <tag>"
make)
mkdir "${DIRNAME}" && mv -f *.com *.bci "${DIRNAME}/."
;;
+make-cross)
+ mkdir "$DIRNAME"
+ maybe_mv *.com "$DIRNAME"
+ maybe_mv *.bci "$DIRNAME"
+ maybe_mv *.moc "$DIRNAME"
+ maybe_mv *.fni "$DIRNAME"
+ ;;
unmake)
mv -f "${DIRNAME}"/* . && rmdir "${DIRNAME}"
;;
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-# Cross-compilation process:
-#
-# Using the host compiler, syntax everything used by the target
-# compiler: the target runtime, sf and cref.
-#
-# In the host runtime, load the host-syntaxed target sf and cref,
-# and use them to syntax the target compiler.
-#
-# Create x-compiler.com, a band containing the target runtime, sf,
-# cref and compiler. This band should contain NONE of the old,
-# host compiler code, though the runtime and sf (and cref) were
-# syntaxed by it. It will depend only on the host machine.
-#
-# Remove the host-compiled runtime, sf and cref to STAGE1
-# subdirectories. Use the target compiler, on the host machine,
-# to cross-compile everything. At this point, everything has been
-# cross-compiled by the INTERPRETED target compiler.
-#
-# Finish the cross-compilation and build-bands with the target
-# machine.
+# Build a cross-compiler targeting the 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
-for SUBSYS in runtime sf cref; do
- if [ ! -f $SUBSYS/$SUBSYS-unx.pkd ]; then
- run_cmd_in_dir $SUBSYS \
- "${@}" --batch-mode --compiler --load $SUBSYS.sf </dev/null
- fi
+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
+
+# Compile the cross-compiler.
+
+# 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.
+
+for DIR in runtime sf cref; do
+ run_cmd_in_dir $DIR "${@}" --batch-mode --load $DIR.sf </dev/null
done
-run_cmd_in_dir compiler \
- "${@}" --batch-mode --band runtime.com --load compiler.sf </dev/null
+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.
+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
run_cmd_in_dir runtime \
- ../microcode/scheme --batch-mode --fasl make.bin --library ../lib <<EOF
+ "${@}" --batch-mode --library ../lib --fasl $FASL <<EOF
(disk-save "../lib/x-runtime.com")
EOF
+echo ""
-run_cmd microcode/scheme --batch-mode --library lib --band x-runtime.com <<EOF
-(begin
- (load-option 'SF)
- (load-option 'CREF)
- ;;(load-option 'COMPILER) This fails: compiler/ not found!
- (with-working-directory-pathname "compiler"
- (lambda () (load "machine/make")))
- (disk-save "lib/x-compiler.com"))
+run_cmd_in_dir compiler \
+ "${@}" --batch-mode --library ../lib --band x-runtime.com <<EOF
+(load "compiler.sf")
+EOF
+
+if [ -s compiler/compiler-unx.crf ]; then
+ echo "compiler/compiler-unx.crf:0: error: not empty!"
+ exit 1
+fi
+
+run_cmd_in_dir compiler "${@}" --batch-mode --load compiler.cbf </dev/null
+
+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)
+;;(load-option 'COMPILER)
+;; The above fails! Unable to find package directory: "compiler"
+(with-working-directory-pathname "compiler"
+ (lambda () (load "machine/make")))
+(disk-save "lib/x-compiler.com")
EOF
-make_stage1 ()
-{
- # Unfortunately `make stage1' does not (re)move .bin's.
- # Thus this function.
-
- if [ -d STAGE1 ]; then
- echo "runtime/STAGE1 files already exist."
- exit 1
- fi
- mkdir STAGE1
- mv -f *.bin *.ext *.crf *.fre *.pkd STAGE1/
-}
-
-#run_cmd_in_dir runtime make stage1 # This does not move the .bin's.
-(cd runtime/ && make_stage1)
-#run_cmd_in_dir sf make stage1
-(cd sf/ && make_stage1)
-#run_cmd_in_dir cref make stage1
-(cd cref/ && make_stage1)
-
-run_cmd microcode/scheme --batch-mode --library lib --band x-compiler.com <<EOF
+# Remove host code to STAGEX/ subdirs.
+run_cmd ./Stage.sh make X
+# Dodge unfortunate 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
+
+# Cross-compile everything, producing svm1 .moc's.
+# edwin/snr.scm needs more than --heap 9000!
+run_cmd "${@}" --batch-mode --heap 10000 --library lib \
+ --band x-compiler.com <<EOF
(begin
(load "etc/compile")
- (fluid-let ((compiler:cross-compiling? #t)
- (compiler:generate-lap-files? #t)
- (compiler:intersperse-rtl-in-lap? #t))
- (compile-everything)))
+ (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!
+ (compile-cref compile-dir)
+ (compile-dir "star-parser")
+ (compile-everything))
+ (sf "compiler/base/crsend"))
EOF
-run_cmd microcode/scheme --batch-mode --library lib --band x-compiler.com <<EOF
+# Finish the cross-compilation with the new machine.
+run_cmd_in_dir runtime \
+ ../microcode/scheme --library ../lib --fasl make.bin <<EOF
(begin
- (load "compiler/base/crsend")
+ (load "../compiler/base/crsend")
(finish-cross-compilation:directory ".."))
EOF
+echo ""
+
+# Ready to build-bands.sh with the new machine.
BUNDLES="6001 compiler cref edwin imail sf sos ssp star-parser xdoc xml"
-run_cmd ${HOST_SCHEME_EXE} --heap 4000 <<EOF
+run_cmd ${HOST_SCHEME_EXE} --batch-mode --heap 4000 <<EOF
(begin
(load "etc/utilities")
(generate-c-bundles (quote (${BUNDLES})) "${MDIR}"))
run_cmd_in_dir ()
(
- cd "${1}"
+ D="${1}"
shift
- run_cmd "${@}"
+ cd "${D}"
+ echo "run_cmd in ${D}/:" "${@}"
+ "${@}"
)
get_fasl_file ()
run_cmd rm -rf ${DIRS}
fi
}
+
+maybe_mv ()
+{
+ # When $1 is e.g. *.com, punt.
+ if [ -e "$1" ]; then mv "${@}"; fi
+}
# "config.h", because dependencies are generated by running GCC -M on
# the source files, which refer to "config.h".
-${MIT_SCHEME_EXE:=mit-scheme} <<EOF
+${MIT_SCHEME_EXE:=mit-scheme} --batch-mode <<EOF
(begin
(load "makegen/makegen.scm")
(generate-makefile))
/* -*-C-*-
-DO NOT EDIT: this file was generated by a program.
-
-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, 2010 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify it
-under the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2 of the License, or (at your option)
-any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
-more details.
-
-You should have received a copy of the GNU General Public License along
-with MIT/GNU Scheme; if not, write to the Free Software Foundation, Inc.,
-51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
+ DO NOT EDIT. This file was generated by a program.
*/
#ifndef SCM_SVM1_DEFNS_H
#define SCM_SVM1_DEFNS_H 1
-#define SVM1_REG_STACK_POINTER 0
-#define SVM1_REG_DYNAMIC_LINK 1
+#define SVM1_REG_INTERPRETER_REGISTER_BLOCK 0
+#define SVM1_REG_STACK_POINTER 1
#define SVM1_REG_FREE_POINTER 2
#define SVM1_REG_VALUE 3
-#define SVM1_REG_ENVIRONMENT 4
+#define SVM1_REG_DYNAMIC_LINK 4
#define SVM1_ADDR_START_CODE 0x01
-#define SVM1_ADDR_END_CODE 0x1d
+#define SVM1_ADDR_END_CODE 0x20
#define SVM1_ADDR_BINDINGS(binder) \
binder (SVM1_ADDR_INDIR, indir); \
- binder (SVM1_ADDR_OFFSET_B, offset_b); \
- binder (SVM1_ADDR_OFFSET_W, offset_w); \
- binder (SVM1_ADDR_OFFSET_F, offset_f); \
+ binder (SVM1_ADDR_OFFSET_S8_B, offset_s8_b); \
+ binder (SVM1_ADDR_OFFSET_S8_W, offset_s8_w); \
+ binder (SVM1_ADDR_OFFSET_S8_F, offset_s8_f); \
+ binder (SVM1_ADDR_OFFSET_S16_B, offset_s16_b); \
+ binder (SVM1_ADDR_OFFSET_S16_W, offset_s16_w); \
+ binder (SVM1_ADDR_OFFSET_S16_F, offset_s16_f); \
binder (SVM1_ADDR_INDEX_B_B, index_b_b); \
binder (SVM1_ADDR_INDEX_B_W, index_b_w); \
binder (SVM1_ADDR_INDEX_B_F, index_b_f); \
#define DECODE_SVM1_ADDR_INDIR(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_OFFSET_B 0x02
-#define DECODE_SVM1_ADDR_OFFSET_B(base, offset) \
+#define SVM1_ADDR_OFFSET_S8_B 0x02
+#define DECODE_SVM1_ADDR_OFFSET_S8_B(base, offset) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_SIGNED_8 (offset)
+
+#define SVM1_ADDR_OFFSET_S8_W 0x03
+#define DECODE_SVM1_ADDR_OFFSET_S8_W(base, offset) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_SIGNED_8 (offset)
+
+#define SVM1_ADDR_OFFSET_S8_F 0x04
+#define DECODE_SVM1_ADDR_OFFSET_S8_F(base, offset) \
+ DECODE_WORD_REGISTER (base); \
+ DECODE_SIGNED_8 (offset)
+
+#define SVM1_ADDR_OFFSET_S16_B 0x05
+#define DECODE_SVM1_ADDR_OFFSET_S16_B(base, offset) \
DECODE_WORD_REGISTER (base); \
- DECODE_UNSIGNED_8 (offset)
+ DECODE_SIGNED_16 (offset)
-#define SVM1_ADDR_OFFSET_W 0x03
-#define DECODE_SVM1_ADDR_OFFSET_W(base, offset) \
+#define SVM1_ADDR_OFFSET_S16_W 0x06
+#define DECODE_SVM1_ADDR_OFFSET_S16_W(base, offset) \
DECODE_WORD_REGISTER (base); \
- DECODE_UNSIGNED_8 (offset)
+ DECODE_SIGNED_16 (offset)
-#define SVM1_ADDR_OFFSET_F 0x04
-#define DECODE_SVM1_ADDR_OFFSET_F(base, offset) \
+#define SVM1_ADDR_OFFSET_S16_F 0x07
+#define DECODE_SVM1_ADDR_OFFSET_S16_F(base, offset) \
DECODE_WORD_REGISTER (base); \
- DECODE_UNSIGNED_8 (offset)
+ DECODE_SIGNED_16 (offset)
-#define SVM1_ADDR_INDEX_B_B 0x05
+#define SVM1_ADDR_INDEX_B_B 0x08
#define DECODE_SVM1_ADDR_INDEX_B_B(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_INDEX_B_W 0x06
+#define SVM1_ADDR_INDEX_B_W 0x09
#define DECODE_SVM1_ADDR_INDEX_B_W(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_INDEX_B_F 0x07
+#define SVM1_ADDR_INDEX_B_F 0x0a
#define DECODE_SVM1_ADDR_INDEX_B_F(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_INDEX_W_B 0x08
+#define SVM1_ADDR_INDEX_W_B 0x0b
#define DECODE_SVM1_ADDR_INDEX_W_B(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_INDEX_W_W 0x09
+#define SVM1_ADDR_INDEX_W_W 0x0c
#define DECODE_SVM1_ADDR_INDEX_W_W(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_INDEX_W_F 0x0a
+#define SVM1_ADDR_INDEX_W_F 0x0d
#define DECODE_SVM1_ADDR_INDEX_W_F(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_INDEX_F_B 0x0b
+#define SVM1_ADDR_INDEX_F_B 0x0e
#define DECODE_SVM1_ADDR_INDEX_F_B(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_INDEX_F_W 0x0c
+#define SVM1_ADDR_INDEX_F_W 0x0f
#define DECODE_SVM1_ADDR_INDEX_F_W(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_INDEX_F_F 0x0d
+#define SVM1_ADDR_INDEX_F_F 0x10
#define DECODE_SVM1_ADDR_INDEX_F_F(base, offset, index) \
DECODE_WORD_REGISTER (base); \
DECODE_UNSIGNED_8 (offset); \
DECODE_WORD_REGISTER (index)
-#define SVM1_ADDR_PREDEC_B 0x0e
+#define SVM1_ADDR_PREDEC_B 0x11
#define DECODE_SVM1_ADDR_PREDEC_B(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_PREDEC_W 0x0f
+#define SVM1_ADDR_PREDEC_W 0x12
#define DECODE_SVM1_ADDR_PREDEC_W(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_PREDEC_F 0x10
+#define SVM1_ADDR_PREDEC_F 0x13
#define DECODE_SVM1_ADDR_PREDEC_F(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_PREINC_B 0x11
+#define SVM1_ADDR_PREINC_B 0x14
#define DECODE_SVM1_ADDR_PREINC_B(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_PREINC_W 0x12
+#define SVM1_ADDR_PREINC_W 0x15
#define DECODE_SVM1_ADDR_PREINC_W(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_PREINC_F 0x13
+#define SVM1_ADDR_PREINC_F 0x16
#define DECODE_SVM1_ADDR_PREINC_F(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_POSTDEC_B 0x14
+#define SVM1_ADDR_POSTDEC_B 0x17
#define DECODE_SVM1_ADDR_POSTDEC_B(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_POSTDEC_W 0x15
+#define SVM1_ADDR_POSTDEC_W 0x18
#define DECODE_SVM1_ADDR_POSTDEC_W(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_POSTDEC_F 0x16
+#define SVM1_ADDR_POSTDEC_F 0x19
#define DECODE_SVM1_ADDR_POSTDEC_F(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_POSTINC_B 0x17
+#define SVM1_ADDR_POSTINC_B 0x1a
#define DECODE_SVM1_ADDR_POSTINC_B(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_POSTINC_W 0x18
+#define SVM1_ADDR_POSTINC_W 0x1b
#define DECODE_SVM1_ADDR_POSTINC_W(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_POSTINC_F 0x19
+#define SVM1_ADDR_POSTINC_F 0x1c
#define DECODE_SVM1_ADDR_POSTINC_F(base) \
DECODE_WORD_REGISTER (base)
-#define SVM1_ADDR_PCR_S8 0x1a
+#define SVM1_ADDR_PCR_S8 0x1d
#define DECODE_SVM1_ADDR_PCR_S8(value) \
DECODE_SIGNED_8 (value)
-#define SVM1_ADDR_PCR_S16 0x1b
+#define SVM1_ADDR_PCR_S16 0x1e
#define DECODE_SVM1_ADDR_PCR_S16(value) \
DECODE_SIGNED_16 (value)
-#define SVM1_ADDR_PCR_S32 0x1c
+#define SVM1_ADDR_PCR_S32 0x1f
#define DECODE_SVM1_ADDR_PCR_S32(value) \
DECODE_SIGNED_32 (value)
for (i = 0; (i < N_WORD_REGISTERS); i += 1)
WREG_SET (i, 0);
for (i = 0; (i < N_FLOAT_REGISTERS); i += 1)
- WREG_SET (i, 0.0);
+ FREG_SET (i, 0.0);
+ WREG_SET (SVM1_REG_INTERPRETER_REGISTER_BLOCK, (word_t)Registers);
}
#define IMPORT_REGS() do \
(address->value) = offset_address_value; \
}
-DEFINE_ADDRESS_DECODER (offset_b)
+DEFINE_ADDRESS_DECODER (offset_s8_b)
{
- DECODE_SVM1_ADDR_OFFSET_B (base, offset);
+ DECODE_SVM1_ADDR_OFFSET_S8_B (base, offset);
MAKE_OFFSET_ADDRESS (base, offset, SBYTE);
}
-DEFINE_ADDRESS_DECODER (offset_w)
+DEFINE_ADDRESS_DECODER (offset_s8_w)
{
- DECODE_SVM1_ADDR_OFFSET_W (base, offset);
+ DECODE_SVM1_ADDR_OFFSET_S8_W (base, offset);
MAKE_OFFSET_ADDRESS (base, offset, SWORD);
}
-DEFINE_ADDRESS_DECODER (offset_f)
+DEFINE_ADDRESS_DECODER (offset_s8_f)
{
- DECODE_SVM1_ADDR_OFFSET_F (base, offset);
+ DECODE_SVM1_ADDR_OFFSET_S8_F (base, offset);
+ MAKE_OFFSET_ADDRESS (base, offset, SFLOAT);
+}
+
+DEFINE_ADDRESS_DECODER (offset_s16_b)
+{
+ DECODE_SVM1_ADDR_OFFSET_S16_B (base, offset);
+ MAKE_OFFSET_ADDRESS (base, offset, SBYTE);
+}
+
+DEFINE_ADDRESS_DECODER (offset_s16_w)
+{
+ DECODE_SVM1_ADDR_OFFSET_S16_W (base, offset);
+ MAKE_OFFSET_ADDRESS (base, offset, SWORD);
+}
+
+DEFINE_ADDRESS_DECODER (offset_s16_f)
+{
+ DECODE_SVM1_ADDR_OFFSET_S16_F (base, offset);
MAKE_OFFSET_ADDRESS (base, offset, SFLOAT);
}
projects / mit-scheme.git / commitdiff