From: Matt Birkholz Date: Sat, 10 Apr 2010 23:20:27 +0000 (-0700) Subject: Got the svm1 back end to assemble... something. X-Git-Tag: 20100708-Gtk~71^2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ae556b3374de10e9a7676400d342016b9637a24;p=mit-scheme.git Got the svm1 back end to assemble... something. No disassembler yet. Added lapgen rules until it compiled the whole system. * src/Makefile.in (microcode/svm1-defns.h): Detect changes to machine definition and re-compile it, BEFORE compile-microcode. (subdir-list): New. Cough up SUBDIRS. * src/Stage.sh: New. Uses `make subdir-list' to get SUBDIRS from the Makefile, allowing this script to be invoked with arguments, via shell command line, not make. * src/compiler/Clean.sh: Added make.bin to the remove list. * src/compiler/Stage.sh, src/etc/Stage.sh (make-cross): This new Stage command stashes compilation AND cross-compilation products. * src/compiler/machines/svm/assembler-compiler.scm: Added rule-matcher anti-syntax, so that assembler-runtime.scm can be loaded. * src/compiler/machines/svm/assembler-rules.scm: Changed the offset addressing mode to take signed 8 and 16 bit offsets. * src/compiler/machines/svm/assembler-runtime.scm: Added variable-width instruction encoders to the fixed-width encoders of the machine description. Punted symbolic-expressions. All such are now passed up to the assembler top-level. (match-pattern): Get the list of values leftmost-first. (register-reference?): Punt these redundant definitions. Register references are now part of machine.scm. (any-register?, word-register?, float-register?): Not used. (word-register-reference?, float-register-reference?): Use the register reference munging procedures. (encode-rref): The machine expects float register numbers to start with 0. * src/compiler/machines/svm/compile-assembler.scm: Load assembler-compiler before assembler-runtime. * src/compiler/machines/svm/compiler.pkg: Import instructions; add-instruction! is not sufficient for this assembler. And the register reference procedures are now in scope via the (compiler) package. * src/compiler/machines/svm/lapgen.scm: Punt environment register. Move register reference procedures to machine.scm. Fixed applications of inst:copy. Use BLOCK-OFFSET directives in external labels. Move evaluation of parse-memory-address rule bodies into lapgen rule bodies, where procedures like word-source can gen. LAP. * src/compiler/machines/svm/machine.scm: Added a new fixed register -- the interpreter-register-block -- for easy access to the interpreter's interrupt-mask, lexpr-actuals, etc. Punted the environment register, now accessible via interpreter-register-block. (define-generic-unary-operations, define-generic-binary-operations): Punted. These instructions do not need type parameters. Added them to the corresponding define-bi/unary-operations lists. (load-immediate-operand?): Typo. (ea:environment, ea:lexpr-actuals): New, using the new interpreter- register-block register. Fixed the other ea: procedures to use register references, not numbers. (define-traps): Allow the C-friendly synonyms to be specified. Provide the necessary synonyms for +, -, *, /, 1+, -1+, =, < and >. Punt non-existent traps: the lookup-apply, conditionally-serialize and *-trap traps. The reference-trap trap is actually the lookup trap. The unassigned?-trap trap is actually the unassigned? trap. Etc. (register-reference, register-reference?, etc.): Create the fixed registers and register references from one list. Provide the register reference procedures here, for the (compiler assembler) and (compiler lap-syntaxer) packages, AND assembler-compiler. * src/compiler/machines/svm/make.scm: Initialize the assembler instructions. * src/compiler/machines/svm/rules.scm: Get the right type of target/source for inst:load/store. Fixed applications of inst:copy, inst:increment. Expect a thunk from parse-memory-address. There is no single-arg predicate LT, but there is an SLT. (OVERFLOW-TEST): Without a register argument (or implicit condition register) fixnum methods must test for overflow. Added a few rules to recognize float constants being loaded into registers, used as the second arg. in flonum-pred-2-args instructions, or as an argument to flonum-1/2-arg instructions. Get the correct type of register for flonum instructions. (INVOCATION:CACHE-REFERENCE): Punt fixed registers. Use the extension register if possible, and temporaries for the rest. (INVOCATION:LOOKUP): No such utility, and the lookup-apply trap is no more. (INVOCATION:PRIMITIVE): trap:primitive-lexpr-apply takes just one arg. Store the arg count in the interpreter's lexpr-actuals register. (move-frame-up): Compare registers (numbers), not references. The arg is a reference. inst:load-pointer does not take an address, just a register. (generate/closure-header): Don't skip the external/internal equate when nentries is zero. (generate/quotation-header, generate/remote-link): Rename registers to indicate usage. (generate/remote-links): Keep the interpreter's environment in a temporary register. Typos. Punted several rewrite rules that replace registers with their known values. This is useless here, where instructions like + and load-pointer only take register operands. * src/etc/compile-svm.sh: Re-written to do a proper cross-compilation, with host-compiled cross-compiler. Swaps host and cross compiler products in/out of stages X and 0, respectively. Thus a rebuild does not have to recompile much, not even the previously cross-compiled files. * src/etc/create-makefiles.sh, src/microcode/makegen/makeinit.sh: Use --batch-mode. * src/etc/functions.sh (run_cmd_in_dir): Echo dir name as well as command line. (maybe_mv): New. Punts moving e.g. *.moc if there are none. * src/microcode/svm1-defns.h: New machine definition. See changes to assembler-rules.scm and machine.scm. * src/microcode/svm1-interp.c (initialize_svm1): Initialize new fixed register interpreter-register-block. Fix initialization of the float registers. Added new offset address decoders. --- diff --git a/src/Makefile.in b/src/Makefile.in index 9a1bc6512..423304c6a 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -77,10 +77,21 @@ all-native: compile-microcode @$(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 \ + " exit 1 @@ -38,6 +42,16 @@ make) (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 diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm index 76dc7307b..a2f3e7ae8 100644 --- a/src/compiler/machines/svm/assembler-compiler.scm +++ b/src/compiler/machines/svm/assembler-compiler.scm @@ -1028,4 +1028,11 @@ USA. (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 diff --git a/src/compiler/machines/svm/assembler-rules.scm b/src/compiler/machines/svm/assembler-rules.scm index 373f1a721..80514dfb6 100644 --- a/src/compiler/machines/svm/assembler-rules.scm +++ b/src/compiler/machines/svm/assembler-rules.scm @@ -107,7 +107,14 @@ USA. 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 diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm index 74980ab77..6aa470c07 100644 --- a/src/compiler/machines/svm/assembler-runtime.scm +++ b/src/compiler/machines/svm/assembler-runtime.scm @@ -121,37 +121,249 @@ USA. ;;;; 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))))))) + (define (match-rt-coding-type name expression symbol-table) (let loop ((defns (rt-coding-type-defns (rt-coding-type name)))) (and (pair? defns) @@ -183,13 +395,6 @@ USA. ;;;; 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. @@ -223,9 +428,6 @@ USA. 0) (define-integrable instruction-append bit-string-append) - -;;; end let-syntax -) ;;;; Patterns @@ -272,15 +474,16 @@ USA. (define-integrable (pvar-type pv) (caddr pv)) (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) @@ -335,170 +538,15 @@ USA. ;;;; 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)))) - -;;;; 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) - ???) -|# - -(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))))) ;;;; Pattern-variable types @@ -559,14 +607,13 @@ USA. (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) @@ -723,11 +770,13 @@ USA. 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 diff --git a/src/compiler/machines/svm/compile-assembler.scm b/src/compiler/machines/svm/compile-assembler.scm index ef864dfbb..0443b395d 100644 --- a/src/compiler/machines/svm/compile-assembler.scm +++ b/src/compiler/machines/svm/compile-assembler.scm @@ -27,6 +27,8 @@ USA. (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 diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index f1749ca48..cef0dceb2 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -740,9 +740,7 @@ USA. (export (compiler) instruction-append) (import (compiler lap-syntaxer) - add-instruction! - reference->register - register-reference) + instructions) (export (compiler top-level) assemble)) diff --git a/src/compiler/machines/svm/lapgen.scm b/src/compiler/machines/svm/lapgen.scm index 2492a6778..a09d0b42c 100644 --- a/src/compiler/machines/svm/lapgen.scm +++ b/src/compiler/machines/svm/lapgen.scm @@ -31,7 +31,7 @@ USA. ;;;; 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))) '()))) @@ -43,50 +43,13 @@ USA. (cond ((register-value-class=word? register) 'WORD) ((register-value-class=float? register) 'FLOAT) (else (error:bad-range-argument register 'REGISTER-TYPE)))) - -;;;; 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) @@ -104,25 +67,6 @@ USA. (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) ;;;; Linearizer interface @@ -140,7 +84,7 @@ USA. (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) @@ -329,12 +273,7 @@ USA. (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?) diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm index 07fcdd9e9..d51e119a5 100644 --- a/src/compiler/machines/svm/machine.scm +++ b/src/compiler/machines/svm/machine.scm @@ -93,19 +93,6 @@ USA. '()))) (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) @@ -119,20 +106,6 @@ USA. '()))) (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) @@ -141,7 +114,7 @@ USA. (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. @@ -176,10 +149,8 @@ USA. (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 @@ -187,10 +158,8 @@ USA. 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 @@ -238,22 +207,30 @@ USA. (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)) ;;;; Traps @@ -263,21 +240,23 @@ USA. 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 @@ -292,11 +271,36 @@ USA. (define-interrupt-tests closure dynamic-link procedure continuation ic-procedure) -;;;; 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) @@ -313,19 +317,32 @@ USA. `(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 @@ -335,35 +352,39 @@ USA. (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) ;;;; 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 @@ -385,10 +406,23 @@ USA. (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 @@ -396,8 +430,6 @@ USA. ((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) @@ -411,12 +443,20 @@ USA. ((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)))) (define (rtl:constant-cost expression) (let ((if-integer diff --git a/src/compiler/machines/svm/make.scm b/src/compiler/machines/svm/make.scm index 4d8dbcbbe..65ab4e658 100644 --- a/src/compiler/machines/svm/make.scm +++ b/src/compiler/machines/svm/make.scm @@ -29,4 +29,5 @@ USA. (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 diff --git a/src/compiler/machines/svm/rules.scm b/src/compiler/machines/svm/rules.scm index 4aefcb33c..f0a689b57 100644 --- a/src/compiler/machines/svm/rules.scm +++ b/src/compiler/machines/svm/rules.scm @@ -38,26 +38,39 @@ USA. (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)) @@ -143,10 +156,12 @@ USA. (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)) @@ -257,13 +272,6 @@ USA. (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 @@ -283,8 +291,8 @@ USA. (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)) @@ -305,8 +313,8 @@ USA. (LAP)) (define-rule predicate - (OVERFLOW-TEST (REGISTER (? source))) - (simple-branches! 'NFIX source) + (OVERFLOW-TEST) + ;; The fixnum methods must test for overflow. (LAP)) (define-rule statement @@ -331,7 +339,7 @@ USA. (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) @@ -363,7 +371,7 @@ USA. (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:-) @@ -401,6 +409,12 @@ USA. (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))) @@ -424,16 +438,30 @@ USA. (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))) (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?))) @@ -448,7 +476,7 @@ USA. (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) @@ -471,15 +499,47 @@ USA. (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)) @@ -584,26 +644,31 @@ USA. (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)) @@ -614,14 +679,17 @@ USA. ,@(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 @@ -667,16 +735,15 @@ USA. (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))))) ;;;; Procedure headers @@ -942,9 +1009,8 @@ USA. ,@(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) @@ -954,7 +1020,8 @@ USA. ,@(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))))) @@ -992,8 +1059,8 @@ USA. (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) @@ -1011,8 +1078,8 @@ USA. ,@(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) @@ -1023,13 +1090,13 @@ USA. (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))))) (define-rule statement @@ -1071,27 +1138,39 @@ USA. ;;; 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) @@ -1105,12 +1184,14 @@ USA. (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) @@ -1139,7 +1220,7 @@ USA. ,@(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)) @@ -1254,7 +1335,7 @@ USA. (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)) @@ -1262,7 +1343,7 @@ USA. cont ; ignored (let ((cache (interpreter-call-temporary extension))) (LAP ,@(clear-map!) - ,@(trap:unassigned?-trap cache)))) + ,@(trap:unassigned? cache)))) ;;;; Interpreter Calls @@ -1337,20 +1418,15 @@ USA. (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)))))) @@ -1429,7 +1505,7 @@ USA. (zero? (rtl:machine-constant-value expression)))))) (else #f))) -;;;; Fixnums +;;;; Fixnum rewriting. (define-rule rewriting (OBJECT->FIXNUM (REGISTER (? source register-known-value))) @@ -1437,75 +1513,17 @@ USA. (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))))))) +;;;; Flonum rewriting. + (define-rule rewriting (OBJECT->FLOAT (REGISTER (? operand register-known-value))) (QUALIFIER diff --git a/src/etc/Stage.sh b/src/etc/Stage.sh index f4d229c5b..79177c9e2 100755 --- a/src/etc/Stage.sh +++ b/src/etc/Stage.sh @@ -22,7 +22,11 @@ # 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 " @@ -35,6 +39,13 @@ case "${1}" in 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}" ;; diff --git a/src/etc/compile-svm.sh b/src/etc/compile-svm.sh index 02082d467..fecc14723 100755 --- a/src/etc/compile-svm.sh +++ b/src/etc/compile-svm.sh @@ -19,86 +19,106 @@ # 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 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); }