From: Matt Birkholz Date: Sat, 20 Mar 2010 20:45:04 +0000 (-0700) Subject: Got the (incomplete) svm1 back end complete enough to generate LAP. X-Git-Tag: 20100708-Gtk~84 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=08f05ab7693fb7795231bb1c1f5288edeb55418f;p=mit-scheme.git Got the (incomplete) svm1 back end complete enough to generate LAP. * src/Makefile.in (all-svm): New target, analogous to all-liarc. * src/compiler/configure: Added make.bin to LINKS, so a purely interpreted compiler can be loaded. * src/compiler/machines/svm/assembler-compiler.scm (write-copyright+license): Punted. (rt-defn-decoder-constructor): Removed leftover references to coding-type, which became an implicit rt-coding-type parameter. * src/compiler/machines/svm/assembler-runtime.scm (init-assembler-instructions!): New skeleton. Error actions. (make-symbol-table): Renamed "make-typed-symbol-table", to keep it distinct from back/symtab.scm's "symbol-table", which is used by the assembler top-level (back/bittop.scm, back/bitutl.scm). (Assembler Machine Dependencies): New. Just the required (per CREF analysis) bindings, pilfered from i386/assmd.scm. (Instructions, Memory addressing, Traps, Machine registers): Removed to machine.scm. (Register references): Removed to lapgen.scm, except word-register-reference? and float-register-reference?. Then had to copy register-reference?, and import register-reference AND reference->register. (Symbolic addresses): Commented out for now. * src/compiler/machines/svm/compile-assembler.scm: Punt loading write-mit-scheme-copyright from ../../../runtime/version, and the commented out LAP macrology. * src/compiler/machines/svm/compiler.pkg (compiler lap-syntaxer): Include CREF, for decls.scm. Moved assembler-runtime.scm, assembler-db.scm, and svm1-opcodes.scm to (compiler assembler). (compiler assembler): Added back/symtab.scm to complete the machine-independent assembler top-level. Import from (compiler lap-syntaxer) some of the register-reference procedures that just moved to lapgen.scm. Import add-instruction!. * src/compiler/machines/svm/compiler.sf: Load option SF. This file is intended to run in a band withOUT an existing (compiler) package. * src/compiler/machines/svm/decls.scm (init-packages): No longer used. (setup-source-nodes! env): Typo. * src/compiler/machines/svm/disassembler.scm: For now a no-op. Deleted the code copied verbatim from i386/dassm1.scm. * src/compiler/machines/svm/lapgen.scm (available-machine-registers): New. (Register references): New from assembler-runtime. (register-reference): Fixed to include the un-available-machine-registers. (rref:word-0, etc.): New. (make-internal-procedure-label): Fixed to use new encode-internal-procedure-offset. (encode-internal-procedure-offset): New. Copied from encode-continuation-offset. (invert-condition): Make conditions a proper alist. (interpreter-call-argument?, interpreter-call-temporary) (rtl:simple-offset?, simple-offset->ea!): New from i386, like interpreter-call-argument->machine-register!, BUT uses prefix-instructions!, if necessary, and a temporary which, with Good Luck, will use the same alias as the argument. (parse-memory-address): Fixed to avoid thinking (un-thunking?) #f. * src/compiler/machines/svm/lapopt.scm (optimize-linear-lap): Now a no-op. Deleted the code copied verbatim from i386/lapopt, i.e. all of it. * src/compiler/machines/svm/machine.scm (Architecture Parameters): Needed endianness, scheme-datum-width, and some *-fixnum/*-limit bindings. (Instructions, Memory addressing, Traps, Machine registers): New from assembler-runtime.scm. This makes the regnum:*, inst:*, trap:* and ea:* bindings available to (compiler lap-syntaxer) AND (compiler lap-optimizer), assuming the latter eventually wants to generate some LAP, as in other back-ends. (interpreter-register:environment, etc.): New from i386. (define-machine-register): Closing the syntactic environment around e.g., interpreter-value-register, causes it to be renamed. Generate defines with bare symbols for binding names. (interpreter-regs-pointer?, interpreter-regs-pointer): New. No-ops. (rtl:machine-register?): Map ALL registers, including dynamic-link, environment, and all of the interpreter-call-result: registers. (Closure format): Added a closure-entry-size binding, as in other architectures, a reflection of CLOSURE_ENTRY_SIZE in microcode/cmpintmd/svm1.h. * src/compiler/machines/svm/make.scm: New. Cribbed from i386. * src/compiler/machines/svm/rgspcm.scm: Typo. * src/compiler/machines/svm/rules.scm: Fixed some typos, e.g. source vs. target, trap:[compiler-]lexpr-apply, etc. Added a few rules for CONSTANTs and CONS-POINTERs. Expect just an effective address from parse-memory-address. (interrupt-check): Punted, along with shared closure interrupt code. simple-procedure-header only needs to generate an interrupt-test-* instruction. (generate/cons-closure, generate/cons-multi-closure): Replaced the old i386 code. (generate/closure-header): Replaced the old i386 code. Use simple-procedure-header. (generate/make-magic-closure-constant, make-closure-longword) (make-closure-code-longword): Punted. Compiled closure entries do not even have a format word! (CONS-MULTICLOSURE, generate/quotation-header, generate/remote-link) (generate/remote-links): Replaced the old i386 code. (generate/constants-block): Finished skeletal code. (INTERPRETER-CALL:): Provide interpreter-call-temporary argument to the trap:* instructions. (integer-power-of-2?): Added, for FIXNUM-2-ARGS. * src/configure.ac (ALL_TARGET): Set to "all-svm". * src/etc/compile-svm.sh: New. * src/microcode/cmpintmd/svm1.c, svm1.h: Extern read_u16, for svm1-interp. * src/microcode/option.c (add_to_library_path, quote_string) (strlen_after_quoting, must_quote_char_p): Removed. No longer in use. * src/microcode/svm1-interp.c (enter_closure): Use CLOSURE_COUNT_SIZE, CLOSURE_ENTRY_SIZE, skip_compiled_closure_padding and read_u16. This makes enter_closure look like the other closure handling procedures in cmpintmd/svm1.c. --- diff --git a/src/Makefile.in b/src/Makefile.in index b23f2db6b..9a1bc6512 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -77,6 +77,10 @@ all-native: compile-microcode @$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" --compiler $(MAKE) build-bands +all-svm: compile-microcode + @$(top_srcdir)/etc/compile-svm.sh "$(MIT_SCHEME_EXE)" + $(MAKE) build-bands + all-liarc: @$(top_srcdir)/etc/c-compile.sh "$(MIT_SCHEME_EXE)" --compiler $(MAKE) compile-liarc-bundles build-bands @@ -174,7 +178,8 @@ install-auxdir-top: $(INSTALL_DATA) $(top_srcdir)/etc/optiondb.scm $(DESTDIR)$(AUXDIR)/. $(INSTALL_DATA) lib/*.com $(DESTDIR)$(AUXDIR)/. -.PHONY: all all-native all-liarc macosx-app compile-microcode build-bands +.PHONY: all all-native all-liarc all-svm macosx-app +.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 diff --git a/src/compiler/configure b/src/compiler/configure index b6a7fd104..6d233b3ac 100755 --- a/src/compiler/configure +++ b/src/compiler/configure @@ -39,7 +39,7 @@ if test -z "${MACHINE}"; then exit 1 fi -LINKS="compiler.cbf compiler.pkg compiler.sf make.com" +LINKS="compiler.cbf compiler.pkg compiler.sf make.com make.bin" if test x${MACHINE} = xC; then LINKS="${LINKS} make.so" fi diff --git a/src/compiler/machines/svm/assembler-compiler.scm b/src/compiler/machines/svm/assembler-compiler.scm index 297c0beed..76dc7307b 100644 --- a/src/compiler/machines/svm/assembler-compiler.scm +++ b/src/compiler/machines/svm/assembler-compiler.scm @@ -697,8 +697,8 @@ USA. (call-with-output-file pathname (lambda (port) (write-string "#| -*-Scheme-*-\n\n" port) - (write-copyright+license pathname port) - (newline port) + (write-string "DO NOT EDIT." port) + (write-string " This file was generated by a program.\n\n" port) (write-string "|#\n\n" port) (write-string ";;;; " port) (write-string title port) @@ -761,9 +761,8 @@ USA. (string-append "SCM_" (name-string->c-string (pathname-name pathname) #t) "_H"))) - (write-string "/* -*-C-*-\n\n" port) - (write-copyright+license pathname port) - (newline port) + (write-string "/* -*-C-*-\n\n DO NOT EDIT." port) + (write-string " This file was generated by a program.\n\n" port) (write-string "*/\n\n" port) (write-string "/* " port) (write-string title port) @@ -849,17 +848,6 @@ USA. (write-item (last items) port) (newline port)) -(define (write-copyright+license pathname port) - pathname - (write-string "DO NOT EDIT: this file was generated by a program." port) - (newline port) - (newline port) - (write-mit-scheme-copyright port) - (newline port) - (newline port) - (write-mit-scheme-license port) - (newline port)) - (define (name->c-string name upcase?) (name-string->c-string (symbol-name name) upcase?)) @@ -1019,12 +1007,10 @@ USA. (let ((pvt (lookup-pvar-type (pvar-type pv)))) (if pvt `(,(pvt-decoder pvt) READ-BYTE) - `(DECODE-RT-CODING-TYPE ',(pvar-type pv) - READ-BYTE - CODING-TYPES)))))) + `(DECODE-RT-CODING-TYPE ',(pvar-type pv) READ-BYTE)))))) `(LAMBDA (READ-BYTE) ,@(cond((fix:= n-pvars 0) - `(READ-BYTE CODING-TYPES '())) + `(READ-BYTE '())) ((fix:= n-pvars 1) `((LIST ,(body (car pvars))))) (else diff --git a/src/compiler/machines/svm/assembler-runtime.scm b/src/compiler/machines/svm/assembler-runtime.scm index 530537cec..74980ab77 100644 --- a/src/compiler/machines/svm/assembler-runtime.scm +++ b/src/compiler/machines/svm/assembler-runtime.scm @@ -110,7 +110,7 @@ USA. (type symbol-binding-type) (value symbol-binding-value)) -(define (make-symbol-table) +(define (make-typed-symbol-table) (make-strong-eq-hash-table)) (define (define-symbol name type value symbol-table) @@ -121,7 +121,36 @@ USA. ;;;; Top level -;;; **** where are real top-level entries? **** +(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))) + (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)) (define (match-rt-coding-type name expression symbol-table) (let loop ((defns (rt-coding-type-defns (rt-coding-type name)))) @@ -152,6 +181,52 @@ USA. (eq? (rt-coding-type-name rt-coding-type) name))) (error:bad-range-argument name 'RT-CODING-TYPE))) +;;;; 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. + 56) + +(define-integrable padding-string + ;; Pad with zero, the distinguished invalid opcode. + (unsigned-integer->bit-string 8 0)) + +(define-integrable block-offset-width + ;; Block offsets are encoded words + 16) + +(define maximum-block-offset + (- (expt 2 (-1+ block-offset-width)) 1)) + +(define-integrable (block-offset->bit-string offset start?) + (unsigned-integer->bit-string block-offset-width + (+ (* 2 offset) + (if start? 0 1)))) + +;;; Machine dependent instruction order + +(define (instruction-insert! bits block position receiver) + (let ((l (bit-string-length bits))) + (bit-substring-move-right! bits 0 l block position) + (receiver (+ position l)))) + +(define-integrable (instruction-initial-position block) + block ; ignored + 0) + +(define-integrable instruction-append bit-string-append) + +;;; end let-syntax +) + ;;;; Patterns (define (parse-pattern pattern) @@ -258,261 +333,7 @@ USA. (k (reverse! expressions) pvals)))) (k pattern pvals)))) -;;;; Instructions - -(define-syntax define-inst - (sc-macro-transformer - (lambda (form environment) - (if (syntax-match? '(SYMBOL * SYMBOL) (cdr form)) - (let ((tag (cadr form)) - (params (cddr form))) - (let ((name (symbol-append 'INST: tag))) - `(BEGIN - (DEFINE-INTEGRABLE (,name ,@params) - (LIST (LIST ',tag ,@params))) - (DEFINE-INTEGRABLE (,(symbol-append name '?) INST) - (EQ? (CAR INST) ',tag))))) - (ill-formed-syntax form))))) - -(define-syntax define-unary-operations - (sc-macro-transformer - (lambda (form environment) - (if (syntax-match? '(* SYMBOL) (cdr form)) - `(BEGIN - ,@(let loop ((names (cdr form))) - (if (pair? names) - (cons `(DEFINE-INST ,(car names) TARGET SOURCE) - (loop (cdr names))) - '()))) - (ill-formed-syntax form))))) - -(define-syntax define-generic-unary-operations - (sc-macro-transformer - (lambda (form 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) - (if (syntax-match? '(* SYMBOL) (cdr form)) - `(BEGIN - ,@(let loop ((names (cdr form))) - (if (pair? names) - (cons `(DEFINE-INST ,(car names) TARGET SOURCE1 SOURCE2) - (loop (cdr names))) - '()))) - (ill-formed-syntax form))))) - -(define-syntax define-generic-binary-operations - (sc-macro-transformer - (lambda (form 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-inst load-immediate target value) -(define-inst copy-block size size-type from to) - -(define (load-immediate-operand? n) - (or (and (exact-integer? n) - (<= #x80000000 n < #x100000000)) - (flo:flonum? n))) - -;; TYPE and DATUM can be constants or registers; address is a register. -(define-inst load-pointer target type address) -(define-inst load-non-pointer target type datum) - -(define-inst label label) -(define-inst entry-point label) - -(define-inst jump address) - -(define (inst:trap n . args) - (list (cons* 'TRAP n args))) - -(define (inst:conditional-jump condition source arg3 #!optional arg4) - (list (cons* 'CONDITIONAL-JUMP - condition - source - arg3 - (if (default-object? arg4) '() (list arg4))))) - -(define (inst:conditional-jump? inst) - (eq? (car inst) 'CONDITIONAL-JUMP)) - -;; N-ELTS is a constant or a register. -(define-inst flonum-header target n-elts) - -(define-inst datum-u8 expression) -(define-inst datum-u16 expression) -(define-inst datum-u32 expression) -(define-inst datum-s8 expression) -(define-inst datum-s16 expression) -(define-inst datum-s32 expression) - -(define-generic-unary-operations - copy negate increment decrement abs) - -(define-unary-operations - object-type object-datum object-address - fixnum->integer integer->fixnum address->integer integer->address - not - sqrt round ceiling floor truncate - 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 - / atan2) - -;;;; Memory addressing - -(define-syntax define-ea - (sc-macro-transformer - (lambda (form environment) - (if (syntax-match? '(SYMBOL * SYMBOL) (cdr form)) - (let ((tag (cadr form)) - (params (cddr form))) - (let ((name (symbol-append 'EA: tag))) - `(BEGIN - (DEFINE-INTEGRABLE (,name ,@params) - (INST-EA (,tag ,@(map (lambda (p) (list 'UNQUOTE p)) - params)))) - (DEFINE-INTEGRABLE (,(symbol-append name '?) EA) - (AND (PAIR? EA) - (EQ? (CAR EA) ',tag)))))) - (ill-formed-syntax form))))) - -(define-ea indirect base) -(define-ea offset base offset scale) -(define-ea indexed base offset oscale index iscale) -(define-ea pre-decrement base scale) -(define-ea pre-increment base scale) -(define-ea post-decrement base scale) -(define-ea post-increment base scale) -(define-ea pc-relative offset) - -(define (memory-reference? ea) - (or (ea:indirect? ea) - (ea:offset? ea) - (ea:indexed? ea) - (ea:pre-decrement? ea) - (ea:pre-increment? ea) - (ea:post-decrement? ea) - (ea:post-increment? ea) - (ea:pc-relative? ea))) - -(define (ea:address label) - (ea:pc-relative `(- ,label *PC*))) - -(define (ea:stack-pop) - (ea:post-increment regnum:stack-pointer 'WORD)) - -(define (ea:stack-push) - (ea:pre-decrement regnum:stack-pointer 'WORD)) - -(define (ea:stack-ref index) - (ea:offset regnum:stack-pointer index 'WORD)) - -(define (ea:alloc-word) - (ea:post-increment regnum:free-pointer 'WORD)) - -(define (ea:alloc-byte) - (ea:post-increment regnum:free-pointer 'BYTE)) - -(define (ea:alloc-float) - (ea:post-increment regnum:free-pointer 'FLOAT)) - -;;;; Traps - -(define-syntax define-traps - (sc-macro-transformer - (lambda (form environment) - environment - `(BEGIN - ,@(map (lambda (name) - `(DEFINE (,(symbol-append 'TRAP: name) . ARGS) - (APPLY INST:TRAP ',name ARGS))) - (cddr form)))))) - -(define-traps - ;; This group doesn't return; don't push return address. - apply lexpr-apply cache-reference-apply lookup-apply - primitive-apply primitive-lexpr-apply - error primitive-error - &+ &- &* &/ 1+ -1+ quotient remainder modulo - &= &< &> zero? positive? negative? - - ;; This group returns; push return address. - link conditionally-serialize - reference-trap safe-reference-trap assignment-trap unassigned?-trap - lookup safe-lookup set! unassigned? define unbound? access) - -(define-syntax define-interrupt-tests - (sc-macro-transformer - (lambda (form environment) - environment - `(BEGIN - ,@(map (lambda (name) - `(DEFINE-INST ,(symbol-append 'INTERRUPT-TEST- name))) - (cddr form)))))) - -(define-interrupt-tests - interrupt-test-closure interrupt-test-dynamic-link interrupt-test-procedure - interrupt-test-continuation interrupt-test-ic-procedure) - -;;;; Machine registers - -(define-integrable number-of-machine-registers 512) -(define-integrable number-of-temporary-registers 512) - -(define-syntax define-fixed-registers - (sc-macro-transformer - (lambda (form environment) - (if (syntax-match? '(* SYMBOL) (cdr form)) - (let ((alist - (let loop ((names (cdr form)) (index 0)) - (if (pair? names) - (cons (cons (car names) index) - (loop (cdr names) (+ index 1))) - '())))) - `(BEGIN - ,@(map (lambda (p) - `(DEFINE-INTEGRABLE ,(symbol-append 'REGNUM: (car p)) - ,(cdr p))) - alist) - (DEFINE FIXED-REGISTERS ',alist))) - (ill-formed-syntax form))))) - -(define-fixed-registers - stack-pointer - dynamic-link - free-pointer - value - environment) - -(define-integrable regnum:float-0 256) +;;;; Registers (define (any-register? object) (and (index-fixnum? object) @@ -529,25 +350,8 @@ USA. (fix:>= object regnum:float-0) (fix:- object regnum:float-0))) -(define available-machine-registers - (let loop ((r regnum:environment)) - (if (< r number-of-machine-registers) - (cons r (loop (+ r 1))) - '()))) - -;;;; Register references - -(define register-reference - (let ((references - (list->vector - (map (lambda (r) `(R ,r)) available-machine-registers)))) - (lambda (register) - (guarantee-limited-index-fixnum register - number-of-machine-registers - 'REGISTER-REFERENCE) - (vector-ref references register)))) - (define (register-reference? object) + ;; Copied from lapgen.scm, for assembler rule compilation (withOUT lapgen). (and (pair? object) (eq? (car object) 'R) (pair? (cdr object)) @@ -571,12 +375,6 @@ USA. (fix:>= (cadr object) regnum:float-0) (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)) ;;;; Symbolic expressions @@ -595,6 +393,7 @@ USA. (map (lambda (expression) (cond ((se-integer? expression) 'INTEGER) ((se-float? expression) 'FLOAT) + ;;((se-address? expression) 'ADDRESS) (else (loop expression)))) (cdr expression)))) (and (pair? types) @@ -633,6 +432,7 @@ USA. (define-integrable (se-float? object) (flo:flonum? object)) +#| (define (se-address? object) ???) @@ -641,6 +441,7 @@ USA. (define (se-address:- address1 address2) ???) +|# (define-symbolic-operator '+ (lambda (types) @@ -650,9 +451,10 @@ USA. (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)))) +;; (if (se-address? (car pvals)) +;; (se-address:+ (car pvals) (apply + (cdr pvals))) +;; (apply + pvals)))) + (apply + pvals))) (define-symbolic-operator '- (lambda (types) @@ -667,11 +469,12 @@ USA. (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))))) +;; (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) @@ -920,6 +723,9 @@ 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)) diff --git a/src/compiler/machines/svm/compile-assembler.scm b/src/compiler/machines/svm/compile-assembler.scm index 47756879c..ef864dfbb 100644 --- a/src/compiler/machines/svm/compile-assembler.scm +++ b/src/compiler/machines/svm/compile-assembler.scm @@ -26,23 +26,6 @@ USA. (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () (let ((environment (make-top-level-environment))) - #; - (environment-define-macro environment 'LAP - (rsc-macro-transformer - (lambda (form environment) - (if (syntax-match? '(* DATUM) (cdr form)) - `(,(close-syntax 'QUASIQUOTE environment) ,(cdr form)) - (ill-formed-syntax form))))) - - ;; The 20090107 snapshot does not have write-mit-scheme-copyright. - (if (not (environment-bound? environment 'WRITE-MIT-SCHEME-COPYRIGHT)) - (begin - (eval '(define inits '()) environment) - (eval '(define (add-boot-init! thunk) - (set! inits (cons thunk inits))) environment) - (load "../../../runtime/version" environment) - (eval '(for-each (lambda (thunk) (thunk)) inits) environment))) - (load "machine" environment) (load "assembler-runtime" environment) (load "assembler-compiler" environment) diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index 35e23088c..f1749ca48 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -27,6 +27,7 @@ USA. (global-definitions "../runtime/runtime") (global-definitions "../sf/sf") +(global-definitions "../cref/cref") (define-package (compiler) (files "base/switch" @@ -668,10 +669,7 @@ USA. (export (compiler top-level) register-allocation)) (define-package (compiler lap-syntaxer) - (files "machines/svm/assembler-runtime" ;ea:*, inst:* procedures - "machines/svm/assembler-db" - "machines/svm/svm1-opcodes" - "back/lapgn1" ;LAP generator + (files "back/lapgn1" ;LAP generator "back/lapgn2" ; " " "back/lapgn3" ; " " "back/regmap" ;Hardware register allocator @@ -731,12 +729,20 @@ USA. optimize-linear-lap)) (define-package (compiler assembler) - (files "back/bitutl" ;Assembly blocks + (files "machines/svm/assembler-runtime" + "machines/svm/assembler-db" + "machines/svm/svm1-opcodes" + "back/symtab" ;Symbol tables. + "back/bitutl" ;Assembly blocks "back/bittop" ;Assembler top level ) (parent (compiler)) (export (compiler) instruction-append) + (import (compiler lap-syntaxer) + add-instruction! + reference->register + register-reference) (export (compiler top-level) assemble)) diff --git a/src/compiler/machines/svm/compiler.sf b/src/compiler/machines/svm/compiler.sf index 139f0b50d..f0d149fee 100644 --- a/src/compiler/machines/svm/compiler.sf +++ b/src/compiler/machines/svm/compiler.sf @@ -25,7 +25,10 @@ USA. ;;;; Script to incrementally syntax the compiler -(load-option 'CREF) +(with-loader-base-uri "../lib" ;Use the accompanying sf and cref. + (lambda () + (load-option 'CREF) + (load-option 'SF))) ;; Guarantee that the compiler's package structure exists. (if (not (name->package '(COMPILER))) @@ -39,7 +42,7 @@ USA. (if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!) ;; Refer to the cref package model (compiler.pkg) for syntax/load ;; environments. - (let* ((xref (begin (load-option 'CREF)(->environment '(cross-reference)))) + (let* ((xref (->environment '(cross-reference))) ;; Assume there are no os-type-specific files or packages. (pmodel ((access read-package-model xref) "compiler" 'unix)) diff --git a/src/compiler/machines/svm/decls.scm b/src/compiler/machines/svm/decls.scm index b7c3f4c82..dcbde3432 100644 --- a/src/compiler/machines/svm/decls.scm +++ b/src/compiler/machines/svm/decls.scm @@ -60,14 +60,7 @@ USA. (package/files (car packages))) (package/name (car packages)) (loop (cdr packages))) - (error "No package for file" file)))))) - - (define (init-packages pmodel) - (let* ((pathname (pmodel/pathname pmodel)) - (package-set (package-set-pathname pathname))) - (if (not (file-exists? package-set)) - (cref/generate-trivial-constructor pathname)) - (construct-packages-from-file (fasload package-set)))) + (error "No package for file" filename)))))) (set! source-hash (make-string-hash-table)) (set! source-nodes diff --git a/src/compiler/machines/svm/disassembler.scm b/src/compiler/machines/svm/disassembler.scm new file mode 100644 index 000000000..23394bf93 --- /dev/null +++ b/src/compiler/machines/svm/disassembler.scm @@ -0,0 +1,45 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009 Massachusetts Institute of Technology + +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. + +|# + +;;;; Disassembler: User Level +;;; package: (compiler disassembler) + +(declare (usual-integrations)) + +;;; Flags that control disassembler behavior + +(define disassembler/symbolize-output? #t) +(define disassembler/compiled-code-heuristics? #t) +(define disassembler/write-offsets? #t) +(define disassembler/write-addresses? #f) + +;;;; Top level entries + +(define (compiler:write-lap-file filename #!optional symbol-table?) + (error "unimplemented" 'compiler:write-lap-file filename + (if (default-object? symbol-table?) #t symbol-table?))) + +(define (compiler:disassemble entry) + (error "unimplemented" 'compiler:disassemble entry)) \ No newline at end of file diff --git a/src/compiler/machines/svm/lapgen.scm b/src/compiler/machines/svm/lapgen.scm index a57cb2e4c..2492a6778 100644 --- a/src/compiler/machines/svm/lapgen.scm +++ b/src/compiler/machines/svm/lapgen.scm @@ -18,7 +18,7 @@ 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. |# @@ -30,6 +30,12 @@ USA. ;;;; Register-allocator interface +(define available-machine-registers + (let loop ((r regnum:environment)) + (if (< r number-of-machine-registers) + (cons r (loop (+ r 1))) + '()))) + (define (sort-machine-registers registers) registers) @@ -37,28 +43,41 @@ USA. (cond ((register-value-class=word? register) 'WORD) ((register-value-class=float? register) 'FLOAT) (else (error:bad-range-argument register 'REGISTER-TYPE)))) - -(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) - -(define (pseudo-register-home register) - (error "Attempt to access temporary register:" register)) + +;;;; 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) @@ -82,6 +101,28 @@ USA. (define (register->home-transfer source target) (inst:store 'WORD (register-reference source) (pseudo-register-home target))) + +(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 @@ -116,7 +157,7 @@ USA. (encode-procedure-type n-required n-optional rest?))) (define (make-internal-procedure-label label) - (make-external-label label (encode-continuation-offset label #xFFFE))) + (make-external-label label (encode-internal-procedure-offset label #xFFFE))) (define (make-continuation-label entry-label label) entry-label @@ -131,14 +172,25 @@ USA. (fix:or (fix:lsh n-optional 7) (if rest? #x4000 0)))) -(define (encode-continuation-offset label default) +(define (encode-internal-procedure-offset label default) (let ((offset (rtl-procedure/next-continuation-offset (label->object label)))) (if offset (begin (guarantee-exact-nonnegative-integer offset) (if (not (< offset #x7FF8)) - (error "Can't encode next-continuation offset:" offset)) + (error "Can't encode internal-procedure offset:" offset)) + (+ offset #x8000)) + default))) + +(define (encode-continuation-offset label default) + (let ((offset + (rtl-continuation/next-continuation-offset (label->object label)))) + (if offset + (begin + (guarantee-exact-nonnegative-integer offset) + (if (not (< offset #x7FF8)) + (error "Can't encode continuation offset:" offset)) (+ offset #x8000)) default))) @@ -174,14 +226,14 @@ USA. (define (invert-condition condition) (let loop ((conditions - '((EQ NEQ) - (LT GE) - (GT LE) - (SLT SGE) - (SGT SLE) - (CMP NCMP) - (FIX NFIX) - (IFIX NIFIX)))) + '((EQ . NEQ) + (LT . GE) + (GT . LE) + (SLT . SGE) + (SGT . SLE) + (CMP . NCMP) + (FIX . NFIX) + (IFIX . NIFIX)))) (if (not (pair? conditions)) (error:bad-range-argument condition 'INVERT-CONDITION)) (cond ((eq? (caar conditions) condition) (cdar conditions)) @@ -212,14 +264,77 @@ USA. (define (float-temporary) (register-reference (allocate-temporary-register! 'FLOAT))) + +(define (interpreter-call-argument? expression) + (or (rtl:register? expression) + (and (rtl:cons-pointer? expression) + (rtl:machine-constant? (rtl:cons-pointer-type expression)) + (rtl:machine-constant? (rtl:cons-pointer-datum expression))) + (rtl:simple-offset? expression))) + +(define (interpreter-call-temporary expression) + (case (car expression) + ((REGISTER) + (register-reference + (move-to-temporary-register! (rtl:register-number expression) 'WORD))) + ((CONS-POINTER) + (let ((temp (word-temporary)) + (type (rtl:machine-constant-value + (rtl:cons-pointer-type expression))) + (datum (rtl:machine-constant-value + (rtl:cons-pointer-datum expression)))) + (prefix-instructions! + (LAP ,@(inst:load-non-pointer temp type datum))) + temp)) + ((OFFSET) + (let ((temp (word-temporary)) + (source (simple-offset->ea! expression))) + (prefix-instructions! + (LAP ,@(inst:load 'WORD temp source))) + temp)) + (else + (error "Unexpected interpreter-call argument" (car expression))))) + +(define (rtl:simple-offset? expression) + (and (rtl:offset? expression) + (let ((base (rtl:offset-base expression)) + (offset (rtl:offset-offset expression))) + (if (rtl:register? base) + (or (rtl:machine-constant? offset) + (rtl:register? offset)) + (and (rtl:offset-address? base) + (rtl:machine-constant? offset) + (rtl:register? (rtl:offset-address-base base)) + (rtl:register? (rtl:offset-address-offset base))))) + expression)) + +(define (simple-offset->ea! offset) + (let ((base (rtl:offset-base offset)) + (offset (rtl:offset-offset offset))) + (cond ((not (rtl:register? base)) + (ea:indexed (word-source (rtl:register-number + (rtl:offset-address-base base))) + (rtl:machine-constant-value offset) 'WORD + (word-source (rtl:register-number + (rtl:offset-address-offset base))) 'WORD)) + ((rtl:machine-constant? offset) + (ea:offset (word-source (rtl:register-number base)) + (rtl:machine-constant-value offset) 'WORD)) + (else + (ea:indexed (word-source (rtl:register-number base)) + 0 'WORD + (word-source (rtl:register-number offset)) 'WORD))))) (define (parse-memory-ref expression) (pattern-lookup memory-ref-rules expression)) (define (parse-memory-address expression) - (receive (scale ea) (pattern-lookup memory-address-rules expression) - scale - ea)) + (let ((thunk (pattern-lookup memory-address-rules expression))) + (and thunk + (receive (scale ea) + (thunk) + scale + ea)))) (define (make-memory-rules offset-operator?) (list (rule-matcher ((? scale offset-operator?) diff --git a/src/compiler/machines/svm/lapopt.scm b/src/compiler/machines/svm/lapopt.scm index d10dcfc36..276388ea3 100644 --- a/src/compiler/machines/svm/lapopt.scm +++ b/src/compiler/machines/svm/lapopt.scm @@ -18,7 +18,7 @@ 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. |# @@ -29,345 +29,4 @@ USA. (declare (usual-integrations)) (define (optimize-linear-lap instructions) - (rewrite-lap instructions)) - -;; i386 LAPOPT uses its own pattern matcher because we want to match -;; patterns while ignoring comments. - -(define (comment? thing) - (and (pair? thing) - (eq? (car thing) 'COMMENT))) - -(define (match pat thing dict) ; -> #F or dictionary (alist) - (if (pair? pat) - (if (eq? (car pat) '?) - (cond ((assq (cadr pat) dict) - => (lambda (pair) - (and (equal? (cdr pair) thing) - dict))) - (else (cons (cons (cadr pat) thing) dict))) - (and (pair? thing) - (let ((dict* (match (car pat) (car thing) dict))) - (and dict* - (match (cdr pat) (cdr thing) dict*))))) - (and (eqv? pat thing) - dict))) - -(define (match-sequence pats things dict comments success fail) - ;; SUCCESS = (lambda (dict* comments* things-tail) ...) - ;; FAIL = (lambda () ...) - - (define (eat-comment) - (match-sequence pats (cdr things) dict (cons (car things) comments) - success fail)) - - (cond ((not (pair? pats)) - (if (and (pair? things) - (comment? (car things))) - (eat-comment) - (success dict comments things))) - ((not (pair? things)) - (fail)) - ((comment? (car things)) - (eat-comment)) - ((match (car pats) (car things) dict) - => (lambda (dict*) - (match-sequence (cdr pats) (cdr things) dict* comments - success fail))) - (else (fail)))) - -(define-structure (rule) - name ; used only for information - pattern ; INSNs (in reverse order) - predicate ; (lambda (dict) ...) -> bool - constructor) ; (lambda (dict) ...) -> lap - -(define *rules* - (make-strong-eq-hash-table)) - -;; Rules are indexed by the last opcode in the pattern. - -(define (define-lapopt name pattern predicate constructor) - (let ((pattern (reverse pattern))) - (let ((rule (make-rule name - pattern - (if ((access procedure? system-global-environment) - predicate) - predicate - (lambda (dict) dict #T)) - constructor))) - (if (or (not (pair? pattern)) - (not (pair? (car pattern)))) - (error "Illegal LAPOPT pattern - must end with opcode" - (reverse pattern))) - (let ((key (caar pattern))) - (hash-table/put! *rules* key - (cons rule (hash-table/get *rules* key '())))))) - name) - -(define (find-rules instruction) - (hash-table/get *rules* (car instruction) '())) - -;; Rules are tried in the reverse order in which they are defined. -;; -;; Rules are matched against the LAP from the bottom up. -;; -;; Once a rule has been applied, the rewritten LAP is matched again, -;; so a rule must rewrite to something different to avoid a loop. -;; (One way to ensure this is to always rewrite to fewer instructions.) - -(define (rewrite-lap lap) - (let loop ((unseen (reverse lap)) (finished '())) - (if (null? unseen) - finished - (if (comment? (car unseen)) - (loop (cdr unseen) (cons (car unseen) finished)) - (let try-rules ((rules (find-rules (car unseen)))) - (if (null? rules) - (loop (cdr unseen) (cons (car unseen) finished)) - (let ((rule (car rules))) - (match-sequence - (rule-pattern rule) - unseen - '(("empty")) ; initial dict, distinct from #F and () - '() ; initial comments - (lambda (dict comments unseen*) - (let ((dict (alist->dict dict))) - (if ((rule-predicate rule) dict) - (let ((rewritten - (cons - `(COMMENT (LAP-OPT ,(rule-name rule))) - (append comments - ((rule-constructor rule) dict))))) - (loop (append (reverse rewritten) unseen*) - finished)) - (try-rules (cdr rules))))) - (lambda () - (try-rules (cdr rules))))))))))) - -;; The DICT passed to the rule predicate and action procedures is a -;; procedure mapping pattern names to their matched values. - -(define (alist->dict dict) - (lambda (symbol) - (cond ((assq symbol dict) => cdr) - (else (error "Undefined lapopt pattern symbol" symbol dict))))) - - -(define-lapopt 'PUSH-POP->MOVE - `((PUSH (? reg1)) - (POP (? reg2))) - #F - (lambda (dict) - `((MOV W ,(dict 'reg2) ,(dict 'reg1))))) - -(define-lapopt 'PUSH-POP->NOP - `((PUSH (? reg)) - (POP (? reg))) - #F - (lambda (dict) - dict - `())) - -;; The following rules must have the JMP else we don't know if the -;; register that we are avoiding loading is dead. - -(define-lapopt 'LOAD-PUSH-POP-JUMP->REGARGETTED-LOAD-JUMP - ;; Note that reg1 must match a register because of the PUSH insn. - `((MOV W (? reg1) (? ea/value)) - (PUSH (? reg1)) - (POP (R ,ecx)) - (JMP (@RO B 6 (? hook-offset)))) - #F - (lambda (dict) - `((MOV W (R ,ecx) ,(dict 'ea/value)) - (JMP (@RO B 6 ,(dict 'hook-offset)))))) - -(define-lapopt 'LOAD-STACKTOPWRITE-POP-JUMP->RETARGETTED-LOAD-JUMP - `((MOV W (? reg) (? ea/value)) - (MOV W (@r ,esp) (? reg)) - (POP (R ,ecx)) - (JMP (@RO B 6 (? hook-offset)))) - #F - (lambda (dict) - `((MOV W (R ,ecx) ,(dict 'ea/value)) - (ADD W (R ,esp) (& 4)) - (JMP (@RO B 6 ,(dict 'hook-offset)))))) - - -(define-lapopt 'STACKWRITE-POP-JUMP->RETARGETTED-LOAD-JUMP - `((MOV W (@RO B ,esp (? stack-offset)) (? ea/value)) - (ADD W (R ,esp) (& (? stack-offset))) - (POP (R ,ecx)) - (JMP (@RO B 6 (? hook-offset)))) - #F - (lambda (dict) - `((MOV W (R ,ecx) ,(dict 'ea/value)) - (ADD W (R ,esp) (& ,(+ 4 (dict 'stack-offset)))) - (JMP (@RO B 6 ,(dict 'hook-offset)))))) - -;; The following rules recognize arithmetic followed by tag injection, -;; and fold the tag-injection into the arithmetic. We can do this -;; because we know the bottom six bits of the fixnum are all 0. This -;; is particularly crafty in the generic arithmetic case, as it does -;; not mess up the overflow detection. -;; -;; These patterns match the code generated by subtractions too. - -(define fixnum-tag (object-type 1)) - -(define-lapopt 'FIXNUM-ADD-CONST-TAG - `((ADD W (R (? reg)) (& (? const))) - (OR W (R (? reg)) (& ,fixnum-tag)) - (ROR W (R (? reg)) (& 6))) - #F - (lambda (dict) - `((ADD W (R ,(dict 'reg)) (& ,(+ (dict 'const) fixnum-tag))) - (ROR W (R ,(dict 'reg)) (& 6))))) - -(define-lapopt 'FIXNUM-ADD-REG-TAG - `((ADD W (R (? reg)) (R (? reg-2))) - (OR W (R (? reg)) (& ,fixnum-tag)) - (ROR W (R (? reg)) (& 6))) - #F - (lambda (dict) - `((LEA (R ,(dict 'reg)) (@ROI B ,(dict 'reg) ,fixnum-tag ,(dict 'reg-2) 1)) - (ROR W (R ,(dict 'reg)) (& 6))))) - -(define-lapopt 'GENERIC-ADD-TAG - `((ADD W (R (? reg)) (& (? const))) - (JO (@PCR (? label))) - (OR W (R (? reg)) (& ,fixnum-tag)) - (ROR W (R (? reg)) (& 6))) - #F - (lambda (dict) - `((ADD W (R ,(dict 'reg)) (& ,(+ (dict 'const) fixnum-tag))) - (JO (@PCR ,(dict 'label))) - (ROR W (R ,(dict 'reg)) (& 6))))) - -;; If the fixnum tag is even, the zero LSB works as a place to hold -;; the overflow from addition which can be discarded by masking it -;; out. We must arrange that the constant is positive, so we don't -;; borrow from the tag bits. - -(if (even? fixnum-tag) - (define-lapopt 'FIXNUM-ADD-CONST-IN-PLACE - `((SAL W (? reg) (& ,scheme-type-width)) - (ADD W (? reg) (& (? const))) - (OR W (? reg) (& ,fixnum-tag)) - (ROR W (? reg) (& ,scheme-type-width))) - #F - (lambda (dict) - (let ((const (sar-32 (dict 'const) scheme-type-width)) - (mask (make-non-pointer-literal - fixnum-tag - (-1+ (expt 2 scheme-datum-width))))) - (let ((const - (if (negative? const) - (+ const (expt 2 scheme-datum-width)) - const))) - `(,(if (= const 1) - `(INC W ,(dict 'reg)) ; shorter instruction - `(ADD W ,(dict 'reg) (& ,const))) - (AND W ,(dict 'reg) (& ,mask)))))))) - -;; Similar tag-injection combining rule for fix:or is a little more -;; general. - -(define (or-32-signed x y) - (bit-string->signed-integer - (bit-string-or (signed-integer->bit-string 32 x) - (signed-integer->bit-string 32 y)))) - -(define (ror-32-signed w count) - (let ((bs (signed-integer->bit-string 32 w))) - (bit-string->signed-integer - (bit-string-append (bit-substring bs count 32) - (bit-substring bs 0 count))))) - -(define (sar-32 w count) - (let ((bs (signed-integer->bit-string 32 w))) - (bit-string->signed-integer (bit-substring bs count 32)))) - -(define-lapopt 'OR-OR - `((OR W (R (? reg)) (& (? const-1))) - (OR W (R (? reg)) (& (? const-2)))) - #F - (lambda (dict) - `((OR W (R ,(dict 'reg)) - (& ,(or-32-signed (dict 'const-1) (dict 'const-2))))))) - -;; These rules match a whole fixnum detag-AND/OR-retag operation. In -;; principle, these operations could be done in rulfix.scm, but the -;; instruction combiner wants all the intermediate steps. - -(define-lapopt 'FIXNUM-OR-CONST-IN-PLACE - `((SAL W (? reg) (& ,scheme-type-width)) - (OR W (? reg) (& (? const))) - (OR W (? reg) (& ,fixnum-tag)) - (ROR W (? reg) (& ,scheme-type-width))) - #F - (lambda (dict) - `((OR W ,(dict 'reg) - (& ,(object-datum (sar-32 (dict 'const) scheme-type-width))))))) - -(define-lapopt 'FIXNUM-AND-CONST-IN-PLACE - `((SAL W (? reg) (& ,scheme-type-width)) - (AND W (? reg) (& (? const))) - (OR W (? reg) (& ,fixnum-tag)) - (ROR W (? reg) (& ,scheme-type-width))) - #F - (lambda (dict) - `((AND W ,(dict 'reg) - (& ,(make-non-pointer-literal - fixnum-tag - (object-datum (sar-32 (dict 'const) scheme-type-width)))))))) - -;; FIXNUM-NOT. The first (partial) pattern uses the XOR operation to -;; put the tag bits in the low part of the result. This pattern -;; occurs in the hash table hash functions, where the OBJECT->FIXNUM -;; has been shared by CSE. - -(define-lapopt 'FIXNUM-NOT-TAG - `((NOT W (? reg)) - (AND W (? reg) (& #x-40)) - (OR W (? reg) (& ,fixnum-tag)) - (ROR W (? reg) (& ,scheme-type-width))) - #F - (lambda (dict) - (let ((magic-bits (+ (* -1 (expt 2 scheme-type-width)) fixnum-tag))) - `((XOR W ,(dict 'reg) (& ,magic-bits)) - (ROR W ,(dict 'reg) (& ,scheme-type-width)))))) - -(define-lapopt 'FIXNUM-NOT-IN-PLACE - `((SAL W (? reg) (& ,scheme-type-width)) - (NOT W (? reg)) - (AND W (? reg) (& #x-40)) - (OR W (? reg) (& ,fixnum-tag)) - (ROR W (? reg) (& ,scheme-type-width))) - #F - (lambda (dict) - `((XOR W ,(dict 'reg) (& ,(-1+ (expt 2 scheme-datum-width))))))) - -;; CLOSURES -;; -;; This rule recognizes code duplicated at the end of the CONS-CLOSURE -;; and CONS-MULTICLOSURE and the following CONS-POINTER. (This happens -;; because of the hack of storing the entry point as a tagged object -;; in the closure to allow GC to work correctly with relative jumps in -;; the closure code. A better fix would be to alter the GC to make -;; absolute the addresses during closure transport.) -;; -;; The rule relies on the fact the REG-TEMP is a temporary for the -;; expansions of CONS-CLOSURE and CONS-MULTICLOSURE, so it is dead -;; afterwards, and is specific in matching because it is the only code -;; that stores an entry at a negative offset from the free pointer. - -(define-lapopt 'CONS-CLOSURE-FIXUP - `((LEA (? reg-temp) (@RO UW (? regno-closure) #xA0000000)) - (MOV W (@RO B ,regnum:free-pointer -4) (? regno-temp)) - (LEA (? reg-object) (@RO UW (? regno-closure) #xA0000000))) - #F - (lambda (dict) - `((LEA ,(dict 'reg-object) (@RO UW ,(dict 'regno-closure) #xA0000000)) - (MOV W (@RO B ,regnum:free-pointer -4) ,(dict 'reg-object))))) \ No newline at end of file + instructions) \ No newline at end of file diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm index 691215e3e..07fcdd9e9 100644 --- a/src/compiler/machines/svm/machine.scm +++ b/src/compiler/machines/svm/machine.scm @@ -28,13 +28,21 @@ USA. (declare (usual-integrations)) +;;;; Architecture Parameters + (define use-pre/post-increment? #t) +(define-integrable endianness 'LITTLE) +(define-integrable addressing-granularity 8) (define-integrable scheme-type-width 6) (define-integrable scheme-type-limit #x40) (define-integrable scheme-object-width 32) ;could be 64 too + +(define-integrable scheme-datum-width + ;; See "***" below. + (- scheme-object-width scheme-type-width)) + (define-integrable float-width 64) (define-integrable float-alignment scheme-object-width) -(define-integrable addressing-granularity 8) (define-integrable address-units-per-float (quotient float-width addressing-granularity)) @@ -42,8 +50,282 @@ USA. (define-integrable address-units-per-object (quotient scheme-object-width addressing-granularity)) +(define-integrable signed-fixnum/upper-limit + ;; *** This is (expt 2 (-1+ scheme-datum-width)), manually constant-folded. + #x02000000) + +(define-integrable signed-fixnum/lower-limit + (- signed-fixnum/upper-limit)) + +(define-integrable unsigned-fixnum/upper-limit + (* 2 signed-fixnum/upper-limit)) + (define-integrable (stack->memory-offset offset) offset) (define-integrable ic-block-first-parameter-offset 2) + +;;;; Instructions + +(define-syntax define-inst + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(SYMBOL * SYMBOL) (cdr form)) + (let ((tag (cadr form)) + (params (cddr form))) + (let ((name (symbol-append 'INST: tag))) + `(BEGIN + (DEFINE-INTEGRABLE (,name ,@params) + (LIST (LIST ',tag ,@params))) + (DEFINE-INTEGRABLE (,(symbol-append name '?) INST) + (EQ? (CAR INST) ',tag))))) + (ill-formed-syntax form))))) + +(define-syntax define-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) TARGET SOURCE) + (loop (cdr names))) + '()))) + (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) + environment + (if (syntax-match? '(* SYMBOL) (cdr form)) + `(BEGIN + ,@(let loop ((names (cdr form))) + (if (pair? names) + (cons `(DEFINE-INST ,(car names) TARGET SOURCE1 SOURCE2) + (loop (cdr names))) + '()))) + (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-inst load-immediate target value) +(define-inst copy-block size size-type from to) + +(define (load-immediate-operand? n) + (or (and (exact-integer? n) + (<= #x80000000 n < #x100000000)) + (flo:flonum? n))) + +;; TYPE and DATUM can be constants or registers; address is a register. +(define-inst load-pointer target type address) +(define-inst load-non-pointer target type datum) + +(define-inst label label) +(define-inst entry-point label) + +(define-inst jump address) + +(define (inst:trap n . args) + (list (cons* 'TRAP n args))) + +(define (inst:conditional-jump condition source arg3 #!optional arg4) + (list (cons* 'CONDITIONAL-JUMP + condition + source + arg3 + (if (default-object? arg4) '() (list arg4))))) + +(define (inst:conditional-jump? inst) + (eq? (car inst) 'CONDITIONAL-JUMP)) + +;; N-ELTS is a constant or a register. +(define-inst flonum-header target n-elts) + +(define-inst datum-u8 expression) +(define-inst datum-u16 expression) +(define-inst datum-u32 expression) +(define-inst datum-s8 expression) +(define-inst datum-s16 expression) +(define-inst datum-s32 expression) + +(define-generic-unary-operations + copy negate increment decrement abs) + +(define-unary-operations + object-type object-datum object-address + fixnum->integer integer->fixnum address->integer integer->address + not + sqrt round ceiling floor truncate + 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 + / atan2) + +;;;; Memory addressing + +(define-syntax define-ea + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(SYMBOL * SYMBOL) (cdr form)) + (let ((tag (cadr form)) + (params (cddr form))) + (let ((name (symbol-append 'EA: tag))) + `(BEGIN + (DEFINE-INTEGRABLE (,name ,@params) + (INST-EA (,tag ,@(map (lambda (p) (list 'UNQUOTE p)) + params)))) + (DEFINE-INTEGRABLE (,(symbol-append name '?) EA) + (AND (PAIR? EA) + (EQ? (CAR EA) ',tag)))))) + (ill-formed-syntax form))))) + +(define-ea indirect base) +(define-ea offset base offset scale) +(define-ea indexed base offset oscale index iscale) +(define-ea pre-decrement base scale) +(define-ea pre-increment base scale) +(define-ea post-decrement base scale) +(define-ea post-increment base scale) +(define-ea pc-relative offset) + +(define (memory-reference? ea) + (or (ea:indirect? ea) + (ea:offset? ea) + (ea:indexed? ea) + (ea:pre-decrement? ea) + (ea:pre-increment? ea) + (ea:post-decrement? ea) + (ea:post-increment? ea) + (ea:pc-relative? ea))) + +(define (ea:address label) + (ea:pc-relative `(- ,label *PC*))) + +(define (ea:stack-pop) + (ea:post-increment regnum:stack-pointer 'WORD)) + +(define (ea:stack-push) + (ea:pre-decrement regnum:stack-pointer 'WORD)) + +(define (ea:stack-ref index) + (ea:offset regnum:stack-pointer index 'WORD)) + +(define (ea:alloc-word) + (ea:post-increment regnum:free-pointer 'WORD)) + +(define (ea:alloc-byte) + (ea:post-increment regnum:free-pointer 'BYTE)) + +(define (ea:alloc-float) + (ea:post-increment regnum:free-pointer 'FLOAT)) + +;;;; Traps + +(define-syntax define-traps + (sc-macro-transformer + (lambda (form environment) + environment + `(BEGIN + ,@(map (lambda (name) + `(DEFINE (,(symbol-append 'TRAP: name) . ARGS) + (APPLY INST:TRAP ',name ARGS))) + (cdr form)))))) + +(define-traps + ;; This group doesn't return; don't push return address. + apply lexpr-apply cache-reference-apply lookup-apply + primitive-apply primitive-lexpr-apply + error primitive-error + &+ &- &* &/ 1+ -1+ quotient remainder modulo + &= &< &> zero? positive? negative? + + ;; This group returns; push return address. + link conditionally-serialize + reference-trap safe-reference-trap assignment-trap unassigned?-trap + lookup safe-lookup set! unassigned? define unbound? access) + +(define-syntax define-interrupt-tests + (sc-macro-transformer + (lambda (form environment) + environment + `(BEGIN + ,@(map (lambda (name) + `(DEFINE-INST ,(symbol-append 'INTERRUPT-TEST- name))) + (cdr form)))))) + +(define-interrupt-tests + closure dynamic-link procedure continuation ic-procedure) + +;;;; Machine registers + +(define-integrable number-of-machine-registers 512) +(define-integrable number-of-temporary-registers 512) + +(define-syntax define-fixed-registers + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(* SYMBOL) (cdr form)) + (let ((alist + (let loop ((names (cdr form)) (index 0)) + (if (pair? names) + (cons (cons (car names) index) + (loop (cdr names) (+ index 1))) + '())))) + `(BEGIN + ,@(map (lambda (p) + `(DEFINE-INTEGRABLE ,(symbol-append 'REGNUM: (car p)) + ,(cdr p))) + alist) + (DEFINE FIXED-REGISTERS ',alist))) + (ill-formed-syntax form))))) + +(define-fixed-registers + stack-pointer + dynamic-link + free-pointer + value + environment) + +(define-integrable regnum:float-0 256) + +(define-integrable regnum:word-0 regnum:environment) (define-integrable (machine-register-known-value register) register @@ -62,19 +344,39 @@ USA. ;;;; RTL Generator Interface +(define (interpreter-register:environment) + (rtl:make-machine-register regnum:environment)) + +(define (interpreter-register:access) + (rtl:make-machine-register regnum:environment)) + +(define (interpreter-register:cache-reference) + (rtl:make-machine-register regnum:environment)) + +(define (interpreter-register:cache-unassigned?) + (rtl:make-machine-register regnum:environment)) + +(define (interpreter-register:lookup) + (rtl:make-machine-register regnum:environment)) + +(define (interpreter-register:unassigned?) + (rtl:make-machine-register regnum:environment)) + +(define (interpreter-register:unbound?) + (rtl:make-machine-register regnum:environment)) + (define-syntax define-machine-register (sc-macro-transformer (lambda (form environment) (if (syntax-match? '(symbol identifier) (cdr form)) (let ((name (symbol-append 'INTERPRETER- (cadr form))) - (offset (close-syntax (caddr form) environment))) + (regnum (close-syntax (caddr form) environment))) `(BEGIN - (DEFINE (,(close-syntax name environment)) - (RTL:MAKE-MACHINE-REGISTER ,offset)) - (DEFINE (,(close-syntax (symbol-append name '?) environment) - EXPRESSION) + (DEFINE (,name) + (RTL:MAKE-MACHINE-REGISTER ,regnum)) + (DEFINE (,(symbol-append name '?) EXPRESSION) (AND (RTL:REGISTER? EXPRESSION) - (FIX:= (RTL:REGISTER-NUMBER EXPRESSION) ,offset))))) + (FIX:= (RTL:REGISTER-NUMBER EXPRESSION) ,regnum))))) (ill-formed-syntax form))))) (define-machine-register stack-pointer regnum:stack-pointer) @@ -82,12 +384,36 @@ USA. (define-machine-register free-pointer regnum:free-pointer) (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) + (define (rtl:machine-register? rtl-register) (case rtl-register ((STACK-POINTER) (interpreter-stack-pointer)) ((FREE) (interpreter-free-pointer)) + ((DYNAMIC-LINK) (interpreter-dynamic-link)) ((VALUE) (interpreter-value-register)) - (else #f))) + ((ENVIRONMENT) + (interpreter-register:environment)) + ((INTERPRETER-CALL-RESULT:ACCESS) + (interpreter-register:access)) + ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) + (interpreter-register:cache-reference)) + ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) + (interpreter-register:cache-unassigned?)) + ((INTERPRETER-CALL-RESULT:LOOKUP) + (interpreter-register:lookup)) + ((INTERPRETER-CALL-RESULT:UNASSIGNED?) + (interpreter-register:unassigned?)) + ((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)))) (define (rtl:interpreter-register->offset locative) (error "Unknown register type:" locative)) @@ -144,16 +470,22 @@ USA. ;; See microcode/cmpintmd/svm1.c for a description of the layout. +(define-integrable closure-entry-size 3) + ;; Offset of the first object in the closure from the address of the ;; first closure entry point, in words. In order to make this work, ;; we add padding to the closure-count field so that the first entry ;; is aligned on an object boundary. +;; The canonical entry point for a closure with no entry points is the +;; head of the vector of value cells. + (define (closure-first-offset count entry) entry (if (= count 0) 1 - (+ (integer-ceiling (* count 3) address-units-per-object) + (+ (integer-ceiling (* count closure-entry-size) + address-units-per-object) count))) ;; Offset of the first object in the closure from the address of the @@ -167,7 +499,8 @@ USA. ;; Increment from one closure entry address to another, in bytes. (define (closure-entry-distance count entry entry*) - (* 3 (- entry* entry))) + count + (* closure-entry-size (- entry* entry))) ;; Increment from a given closure address to the first closure ;; address, in bytes. Usually negative. diff --git a/src/compiler/machines/svm/make.scm b/src/compiler/machines/svm/make.scm new file mode 100644 index 000000000..4d8dbcbbe --- /dev/null +++ b/src/compiler/machines/svm/make.scm @@ -0,0 +1,32 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 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. + +|# + +;;;; Compiler: System Construction + +(declare (usual-integrations)) + +(let ((value ((load "base/make") "svm1"))) + (set! (access compiler:compress-top-level? (->environment '(compiler))) #t) + value) \ No newline at end of file diff --git a/src/compiler/machines/svm/rgspcm.scm b/src/compiler/machines/svm/rgspcm.scm index eaad7bb21..ff5fd039f 100644 --- a/src/compiler/machines/svm/rgspcm.scm +++ b/src/compiler/machines/svm/rgspcm.scm @@ -18,12 +18,13 @@ 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. |# -;;;; RTL Generation: Special primitive combinations. Intel i386 version. +;;;; RTL Generation: Special primitive combinations. Scheme Virtual +;;;; Machine version. ;;; package: (compiler rtl-generator) (declare (usual-integrations)) diff --git a/src/compiler/machines/svm/rules.scm b/src/compiler/machines/svm/rules.scm index 2c5935a64..4aefcb33c 100644 --- a/src/compiler/machines/svm/rules.scm +++ b/src/compiler/machines/svm/rules.scm @@ -18,7 +18,7 @@ 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. |# @@ -42,15 +42,22 @@ USA. (define-rule statement (ASSIGN (? thunk parse-memory-ref) - (REGISTER (? target))) + (REGISTER (? source))) (receive (scale target) (thunk) (inst:store scale (word-source source) target))) +(define-rule statement + (ASSIGN (? thunk parse-memory-ref) + (CONSTANT (? constant))) + (receive (scale target) (thunk) + (let ((temp (word-temporary))) + (LAP ,@(load-constant temp constant) + ,@(inst:store scale temp target))))) + (define-rule statement (ASSIGN (REGISTER (? target)) - (? thunk parse-memory-address)) - (let ((source (thunk))) - (inst:load-address (word-target target) source))) + (? source-ea parse-memory-address)) + (inst:load-address (word-target target) source-ea)) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -133,6 +140,31 @@ USA. type datum))) +(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)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:PROCEDURE (? label)))) + (let ((temp (word-temporary))) + (LAP ,@(inst:load-address temp (ea:address (rtl-procedure/external-label + (label->object label)))) + ,@(inst:load-pointer (word-target target) type temp)))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-POINTER (MACHINE-CONSTANT (? type)) + (ENTRY:CONTINUATION (? label)))) + (let ((temp (word-temporary))) + (LAP ,@(inst:load-address temp (ea:address label)) + ,@(inst:load-pointer (word-target target) type temp)))) + (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) @@ -196,6 +228,13 @@ USA. (word-source source2)) (LAP)) +(define-rule predicate + (EQ-TEST (REGISTER (? source1)) (CONSTANT (? constant))) + (QUALIFIER (non-pointer-object? constant)) + (let ((temp (word-temporary))) + (simple-branches! 'EQ (word-source source1) temp) + (load-constant temp constant))) + (define-rule predicate (PRED-1-ARG INDEX-FIXNUM? (REGISTER (? source))) @@ -474,21 +513,12 @@ USA. ,@(inst:jump (ea:indirect temp))))))) (let ((checks (get-exit-interrupt-checks))) (if (null? checks) - (make-new-sblock (pop-return)) - (memoize-associated-bblock 'POP-RETURN - (lambda () - (make-new-sblock - (let ((label (generate-label 'INTERRUPT))) - (LAP ,@(interrupt-check label checks) - ,@(pop-return) - ,@(inst:label label) - ,@(trap:interrupt-continuation))))))))))) - -(define (memoize-associated-bblock name generator) - (or (block-association name) - (let ((bblock (generator))) - (block-associate! name bblock) - bblock))) + (make-new-sblock + (pop-return)) + (make-new-sblock + (LAP ,@(inst:interrupt-test-continuation) + ,@(pop-return))))))) + (LAP)) (define-rule statement (INVOCATION:APPLY (? frame-size) (? continuation)) @@ -497,7 +527,7 @@ USA. (LAP ,@(clear-map!) ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) ,@(inst:load-immediate rref:word-1 frame-size) - ,@(trap:apply))) + ,@(trap:apply rref:word-0 rref:word-1))) (define-rule statement (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) @@ -522,7 +552,7 @@ USA. (LAP ,@(clear-map!) ,@(inst:load-address rref:word-0 (ea:address label)) ,@(inst:load-immediate rref:word-1 number-pushed) - ,@(trap:compiler-lexpr-apply))) + ,@(trap:lexpr-apply rref:word-0 rref:word-1))) (define-rule statement (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) @@ -532,7 +562,7 @@ USA. ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) ,@(inst:object-address rref:word-0 rref:word-0) ,@(inst:load-immediate rref:word-1 number-pushed) - ,@(trap:compiler-lexpr-apply))) + ,@(trap:lexpr-apply rref:word-0 rref:word-1))) (define-rule statement (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) @@ -554,12 +584,12 @@ USA. (REGISTER (? extension))) continuation (expect-no-exit-interrupt-checks) - (let ((set-extension (load-machine-register! extension regnum:word-2))) + (let ((set-extension (load-machine-register! extension regnum:word-0))) (LAP ,@set-extension ,@(clear-map!) - ,@(inst:load-immediate rref:word-0 frame-size) - ,@(inst:load-address rref:word-2 (ea:address *block-label*)) - ,@(trap:cache-reference-apply)))) + ,@(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)))) (define-rule statement (INVOCATION:LOOKUP (? frame-size) @@ -568,28 +598,30 @@ USA. (? name)) continuation (expect-no-entry-interrupt-checks) - (let ((set-environment (load-machine-register! environment regnum:word-2))) + (let ((set-environment (load-machine-register! environment regnum:word-0))) (LAP ,@set-environment ,@(clear-map!) - ,@(inst:load-immediate rref:word-0 frame-size) + ,@(inst:load-immediate rref:word-2 frame-size) ,@(load-constant rref:word-1 name) - ,@(trap:lookup-apply)))) + ,@(trap:lookup-apply rref:word-0 rref:word-1 rref:word-2)))) (define-rule statement (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) continuation ; ignored (LAP ,@(clear-map!) - (if (eq? primitive compiled-error-procedure) - (LAP ,@(inst:load-immediate rref:word-0 frame-size) - ,@(trap:error)) - (LAP ,@(load-constant rref:word-0 primitive) - ,@(let ((arity (primitive-procedure-arity primitive))) - (if (>= arity 0) - (trap:primitive-apply) - (LAP ,@(inst:load-immediate rref:word-1 frame-size) - ,@(if (= arity -1) - (trap:primitive-lexpr-apply) - (trap:apply))))))))) + ,@(if (eq? primitive compiled-error-procedure) + (LAP ,@(inst:load-immediate rref:word-0 frame-size) + ,@(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))))))))) (define-syntax define-primitive-invocation (sc-macro-transformer @@ -639,12 +671,12 @@ USA. (if (= frame-size 0) (if (= register rref:stack-pointer) (LAP) - (inst:copy rref:stack-pointer register)) + (inst:copy 'WORD rref:stack-pointer register)) (let ((temp (word-temporary))) (LAP ,@(inst:load-address temp (ea:offset register (- frame-size) 'WORD)) ,@(inst:copy-block frame-size 'WORD rref:stack-pointer temp) - ,@(inst:copy rref:stack-pointer temp))))) + ,@(inst:copy 'WORD rref:stack-pointer temp))))) ;;;; Procedure headers @@ -662,30 +694,12 @@ USA. ;;; interrupt handler that saves and restores the dynamic link ;;; register. -(define (interrupt-check label checks) - ;; This always does interrupt checks in line. - (LAP ,@(if (or (memq 'INTERRUPT checks) (memq 'HEAP checks)) - (LAP ,@(inst:compare 'WORD - rref:free-pointer - rref:memtop-pointer) - ,@(inst:conditional-jump 'UGE (ea:address label))) - (LAP)) - ,@(if (memq 'STACK checks) - (LAP ,@(inst:compare 'WORD - rref:stack-pointer - rref:stack-guard) - ,@(inst:conditional-jump 'ULT (ea:address label))) - (LAP)))) - -(define (simple-procedure-header label trap) +(define (simple-procedure-header label interrupt-test) (let ((checks (get-entry-interrupt-checks))) (if (null? checks) label - (let ((gc-label (generate-label))) - (LAP (LABEL ,gc-label) - ,@(trap) - ,@label - ,@(interrupt-check gc-label checks)))))) + (LAP ,@label + ,@(interrupt-test))))) (define-rule statement (CONTINUATION-ENTRY (? label)) @@ -700,14 +714,11 @@ USA. (define-rule statement (IC-PROCEDURE-HEADER (? internal-label)) (get-entry-interrupt-checks) ; force search - (let ((external-label (internal->external-label internal-label)) - (gc-label (generate-label))) + (let ((external-label (internal->external-label internal-label))) (LAP (ENTRY-POINT ,external-label) (EQUATE ,external-label ,internal-label) - (LABEL ,gc-label) - ,@(trap:interrupt-ic-procedure) ,@(make-expression-label internal-label) - ,@(interrupt-check gc-label)))) + ,@(inst:interrupt-test-ic-procedure)))) (define-rule statement (OPEN-PROCEDURE-HEADER (? internal-label)) @@ -716,15 +727,15 @@ USA. ,@(simple-procedure-header (make-internal-procedure-label internal-label) (if (rtl-procedure/dynamic-link? rtl-proc) - trap:interrupt-dlink - trap:interrupt-procedure))))) + inst:interrupt-test-dynamic-link + inst:interrupt-test-procedure))))) (define-rule statement (PROCEDURE-HEADER (? internal-label) (? min) (? max)) (LAP (EQUATE ,(internal->external-label internal-label) ,internal-label) ,@(simple-procedure-header (make-procedure-label min (- (abs max) min) (< max 0) internal-label) - trap:interrupt-procedure))) + inst:interrupt-test-procedure))) ;; Interrupt check placement ;; @@ -905,132 +916,121 @@ USA. ;;;; Closures: -;; Since i386 instructions are pc-relative, the GC can't relocate them unless -;; there is a way to find where the closure was in old space before being -;; transported. The first entry point (tagged as an object) is always -;; the last component of closures with any entry points. - (define (generate/cons-closure target procedure-label min max size) + min max ;;No entry format word necessary. (let ((target (word-target target)) - (temp (word-temporary))) - (LAP ,@(inst:load-address - temp - (ea:address `(- ,(internal->external-label procedure-label) 5))) - (MOV W (@R ,regnum:free-pointer) - (&U ,(make-non-pointer-literal (ucode-type manifest-closure) - (+ 4 size)))) - (MOV W (@RO B ,regnum:free-pointer 4) - (&U ,(make-closure-code-longword min max 8))) - (LEA ,target (@RO B ,regnum:free-pointer 8)) - ;; (CALL (@PCR )) - (MOV B (@RO B ,regnum:free-pointer 8) (&U #xe8)) - (SUB W ,temp ,target) - (MOV W (@RO B ,regnum:free-pointer 9) ,temp) ; displacement - (ADD W (R ,regnum:free-pointer) (& ,(* 4 (+ 5 size)))) - (LEA ,temp (@RO UW - ,mtarget - ,(make-non-pointer-literal (ucode-type compiled-entry) - 0))) - (MOV W (@RO B ,regnum:free-pointer -4) ,temp) - ,@(trap:conditionally-serialize)))) + (temp (word-temporary)) + (free rref:free-pointer) + (total-words (+ 1 ;; header + 1 ;; count + 1 ;; padded entry + 1 ;; targets + size ;; variables + )) + (label (internal->external-label procedure-label)) + (count-offset (* 1 address-units-per-object)) + (entry-offset (* 2 address-units-per-object)) + (target-offset (* 3 address-units-per-object))) + (LAP + ;; header + ,@(inst:load-non-pointer temp (ucode-type manifest-closure) total-words) + ,@(inst:store 'WORD temp (ea:indirect free)) + + ;; entry count: 1 (little-endian short) + ,@(inst:load-immediate temp 1) + ,@(inst:store 'BYTE temp (ea:offset free count-offset 'BYTE)) + ,@(inst:load-immediate temp 0) + ,@(inst:store 'BYTE temp (ea:offset free (1+ count-offset) 'BYTE)) + + ,@(inst:load-pointer target + (ucode-type compiled-entry) + (ea:offset free entry-offset 'BYTE)) + + ;; entry: (inst:enter-closure 0) + ,@(inst:load-immediate temp svm1-inst:enter-closure) + ,@(inst:store 'BYTE temp (ea:offset free entry-offset 'BYTE)) + ,@(inst:load-immediate temp 0) + ,@(inst:store 'BYTE temp (ea:offset free (+ 1 entry-offset) 'BYTE)) + ,@(inst:store 'BYTE temp (ea:offset free (+ 2 entry-offset) 'BYTE)) + + ;; target: procedure-label + ,@(inst:load-pointer temp (ucode-type compiled-entry) (ea:address label)) + ,@(inst:store 'WORD temp (ea:offset free target-offset 'BYTE)) + + ,@(inst:load-address free (ea:offset free total-words 'WORD))))) (define (generate/cons-multiclosure target nentries size entries) - (let ((target (word-target target)) - (temp (word-temporary))) - (with-pc - (lambda (pc-label pc-reg) - (define (generate-entries entries offset) - (let ((entry (car entries)) - (rest (cdr entries))) - (LAP (MOV W (@RO B ,regnum:free-pointer -9) - (&U ,(make-closure-code-longword (cadr entry) - (caddr entry) - offset))) - (MOV B (@RO B ,regnum:free-pointer -5) (&U #xe8)) - (LEA ,temp (@RO W - ,pc-reg - (- ,(internal->external-label (car entry)) - ,pc-label))) - (SUB W ,temp (R ,regnum:free-pointer)) - (MOV W (@RO B ,regnum:free-pointer -4) ,temp) - ,@(if (null? rest) - (LAP) - (LAP (ADD W (R ,regnum:free-pointer) (& 10)) - ,@(generate-entries rest (+ 10 offset))))))) - - (LAP (MOV W (@R ,regnum:free-pointer) - (&U ,(make-non-pointer-literal - (ucode-type manifest-closure) - (+ size (quotient (* 5 (1+ nentries)) 2))))) - (MOV W (@RO B ,regnum:free-pointer 4) - (&U ,(make-closure-longword nentries 0))) - (LEA ,target (@RO B ,regnum:free-pointer 12)) - (ADD W (R ,regnum:free-pointer) (& 17)) - ,@(generate-entries entries 12) - (ADD W (R ,regnum:free-pointer) - (& ,(+ (* 4 size) (if (odd? nentries) 7 5)))) - (LEA ,temp - (@RO UW - ,mtarget - ,(make-non-pointer-literal (ucode-type compiled-entry) - 0))) - (MOV W (@RO B ,regnum:free-pointer -4) ,temp) - ,@(trap:conditionally-serialize)))))) + (let ((free rref:free-pointer) + (little-end (lambda (short) (fix:and short #xFF))) + (big-end (lambda (short) (fix:lsh short -8)))) + (let ((entry-words (integer-ceiling (* closure-entry-size nentries) + address-units-per-object))) + (let ((target (word-target target)) + (temp (word-temporary)) + (total-words (+ 1 ;; header + 1 ;; count + entry-words ;; padded entries + nentries ;; targets + size ;; variables + )) + (count-offset (* 1 address-units-per-object)) + (first-entry-offset (* 2 address-units-per-object)) + (first-target-woffset (+ 1 1 entry-words))) + + (define (generate-entries entries index offset) + (LAP + ,@(inst:load-immediate temp svm1-inst:enter-closure) + ,@(inst:store 'BYTE temp (ea:offset free offset 'BYTE)) + ,@(inst:load-immediate temp (little-end index)) + ,@(inst:store 'BYTE temp (ea:offset free (1+ offset) 'BYTE)) + ,@(inst:load-immediate temp (big-end index)) + ,@(inst:store 'BYTE temp (ea:offset free (+ 2 offset) 'BYTE)) + ,@(if (null? (cdr entries)) + (LAP) + (generate-entries (cdr entries) (1+ index) (+ 3 offset))))) + + (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:store 'WORD temp (ea:offset free woffset 'WORD)) + ,@(if (null? (cdr entries)) + (LAP) + (generate-targets (cdr entries) (1+ woffset)))))) + + (LAP + ;; header + ,@(inst:load-non-pointer temp + (ucode-type manifest-closure) total-words) + ,@(inst:store 'WORD temp (ea:indirect free)) + + ;; entry count (little-endian short) + ,@(inst:load-immediate temp (little-end nentries)) + ,@(inst:store 'BYTE temp (ea:offset free count-offset 'BYTE)) + ,@(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)) + + ,@(generate-entries entries 0 first-entry-offset) + + ,@(generate-targets entries first-target-woffset) + + ,@(inst:load-address free (ea:offset free total-words 'WORD))))))) -(define closure-share-names - '#(closure-0-interrupt closure-1-interrupt closure-2-interrupt - closure-3-interrupt closure-4-interrupt closure-5-interrupt - closure-6-interrupt closure-7-interrupt)) - -(define (generate/closure-header internal-label nentries entry) - nentries ; ignored - (let ((external-label (internal->external-label internal-label)) - (checks (get-entry-interrupt-checks))) +(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 (make-internal-procedure-label internal-label) - trap:interrupt-procedure)) - (let* ((prefix - (lambda (gc-label) - (LAP (LABEL ,gc-label) - ,@(if (zero? entry) - (LAP) - (LAP (ADD W (@R ,esp) (& ,(* 10 entry))))) - ,@(trap:interrupt-closure)))) - (label+adjustment - (lambda () - (LAP ,@(make-internal-entry-label external-label) - (ADD W (@R ,esp) - (&U ,(generate/make-magic-closure-constant entry))) - (LABEL ,internal-label)))) - (suffix - (lambda (gc-label) - (LAP ,@(label+adjustment) - ,@(interrupt-check gc-label checks))))) - (if (null? checks) - (LAP ,@(label+adjustment)) - (if (>= entry (vector-length closure-share-names)) - (let ((gc-label (generate-label))) - (LAP ,@(prefix gc-label) - ,@(suffix gc-label))) - (share-instruction-sequence! - (vector-ref closure-share-names entry) - suffix - (lambda (gc-label) - (LAP ,@(prefix gc-label) - ,@(suffix gc-label)))))))))) - -(define (generate/make-magic-closure-constant entry) - (- (make-non-pointer-literal (ucode-type compiled-entry) 0) - (+ (* entry 10) 5))) - -(define (make-closure-longword code-word pc-offset) - (+ code-word (* #x20000 pc-offset))) - -(define (make-closure-code-longword frame/min frame/max pc-offset) - (make-closure-longword (make-procedure-code-word frame/min frame/max) - pc-offset)) + inst:interrupt-test-procedure)) + (LAP ,@(simple-procedure-header + (make-internal-entry-label external-label) + inst:interrupt-test-closure))))) (define-rule statement (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) @@ -1047,12 +1047,17 @@ USA. (CONS-MULTICLOSURE (? nentries) (? size) (? entries))) (case nentries ((0) - (let ((target (word-target target))) - (LAP (MOV W ,target (R ,regnum:free-pointer)) - (MOV W (@R ,regnum:free-pointer) - (&U ,(make-non-pointer-literal (ucode-type manifest-vector) - size))) - (ADD W (R ,regnum:free-pointer) (& ,(* 4 (1+ size))))))) + (let ((target (word-target target)) + (temp (word-temporary))) + (LAP ,@(inst:load-pointer target + (ucode-type compiled-entry) rref:free-pointer) + + ,@(inst:load-non-pointer temp (ucode-type manifest-vector) size) + ,@(inst:store 'WORD temp (ea:indirect rref:free-pointer)) + + ,@(inst:load-address rref:free-pointer + (ea:offset rref:free-pointer + (1+ size) 'WORD))))) ((1) (let ((entry (vector-ref entries 0))) (generate/cons-closure target @@ -1066,107 +1071,109 @@ USA. ;;; This is invoked by the top level of the LAP generator. (define (generate/quotation-header environment-label free-ref-label n-sections) - (let ((t1 (word-temporary)) - (t2 (word-temporary)) - (t3 (word-temporary))) - (LAP ,@(inst:store 'WORD regnum:environment (ea:address environment-label)) - ,@(inst:load-address t1 (ea:address *block-label*)) - ,@(inst:load-address t2 (ea:address free-ref-label)) - ,@(inst:load-immediate t3 n-sections) - ,@(trap:link t1 t2 t3) - ,@(make-internal-continuation-label (generate-label))))) + (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)))) (define (generate/remote-link code-block-label environment-offset free-ref-offset n-sections) - (let ((t1 (word-temporary)) - (t2 (word-temporary)) - (t3 (word-temporary))) - (LAP ,@(inst:load-address t1 (ea:address code-block-label)) - ,@(inst:load-address t2 (ea:offset t1 environment-offset 'WORD)) - ,@(inst:store 'WORD regnum:environment (ea:indirect t2)) - ,@(inst:load-address t2 (ea:offset t1 free-ref-offset 'WORD)) - ,@(inst:load-immediate t3 n-sections) - ,@(trap:link t1 t2 t3) - ,@(make-internal-continuation-label (generate-label))))) - -(define (generate/remote-links n-blocks vector-label nsects) + (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)))) + +(define (generate/remote-links n-blocks vector-label n-sections) (if (> n-blocks 0) - (let ((loop (generate-label)) - (bytes (generate-label)) - (end (generate-label))) - (LAP ,@(inst:load-immediate regnum:word-0 0) - ,@(inst:store 'WORD regnum:word-0 (ea:stack-push)) - ,@(inst:label loop) - ;; Get index - ,@(inst:load 'WORD regnum:word-0 (ea:stack-ref 0)) - ;; Get vector - ,@(inst:load 'WORD regnum:word-1 (ea:address vector-label)) - ;; Get n-sections for this cc-block - ,@(inst:load-immediate regnum:word-2 0) - ,@(inst:load-address regnum:word-3 (ea:address bytes)) - ,@(inst:load 'BYTE regnum:word-3 - (ea:indexed regnum:word-3 - 1 'BYTE - regnum:word-0 'BYTE)) - ;; address of vector - ,@(object-address regnum:word-1 regnum:word-1) - - - - ;; Store n-sections in arg - (MOV W ,regnum:utility-arg-4 (R ,ebx)) - ;; vector-ref -> cc block - (MOV W (R ,edx) (@ROI B ,edx 4 ,ecx 4)) - ;; address of cc-block - (AND W (R ,edx) (R ,regnum:datum-mask)) - ;; cc-block length - (MOV W (R ,ebx) (@R ,edx)) - ;; Get environment - (MOV W (R ,ecx) ,regnum:environment) - ;; Eliminate length tags - (AND W (R ,ebx) (R ,regnum:datum-mask)) - ;; Store environment - (MOV W (@RI ,edx ,ebx 4) (R ,ecx)) - ;; Get NMV header - (MOV W (R ,ecx) (@RO B ,edx 4)) - ;; Eliminate NMV tag - (AND W (R ,ecx) (R ,regnum:datum-mask)) - ;; Address of first free reference - (LEA (R ,ebx) (@ROI B ,edx 8 ,ecx 4)) - ;; Invoke linker - ,@(trap:link) - ,@(make-internal-continuation-label (generate-label)) - ;; Increment counter and loop - (INC W (@R ,esp)) - (CMP W (@R ,esp) (& ,n-blocks)) - (JL (@PCR ,loop)) - (JMP (@PCR ,end)) - (LABEL ,bytes) - ,@(let walk ((bytes (vector->list nsects))) - (if (null? bytes) - (LAP) - (LAP (BYTE U ,(car bytes)) - ,@(walk (cdr bytes))))) - (LABEL ,end) - ;; Pop counter - (POP (R ,eax)))) + (let ((loop-label (generate-label)) + (bytes-label (generate-label)) + (end-label (generate-label)) + + (rref:index rref:word-0) + (rref:bytes rref:word-1) + (rref:vector rref:word-2) + (rref:block rref:word-3) + (rref:n-sections rref:word-4) + (rref:sections rref:word-5) + (rref:length rref:word-6)) + (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:label loop-label) + + ;; Get n-sections for this cc-block. + ,@(inst:load-immediate rref:n-sections 0) + ,@(inst:load 'BYTE rref:n-sections + (ea:indexed rref:bytes 0 'BYTE rref:index 'BYTE)) + ;; Get cc-block. + ,@(inst:load 'WORD rref:block + (ea:indexed rref:vector 1 'WORD rref:index 'WORD)) + ,@(inst:object-address rref:block rref:block) + ;; Get cc-block length. + ,@(inst:load 'WORD rref:length (ea:indirect rref:block)) + ,@(inst:object-datum rref:length rref:length) + ;; Store environment. + ,@(inst:store 'WORD rref:environment + (ea:indexed rref:block 0 'BYTE rref:length 'WORD)) + ;; Get NMV length. + ,@(inst:load 'WORD rref:length (ea:offset rref:block 1 'WORD)) + ,@(inst:object-datum rref:length rref:length) + ;; Address of first section. + ,@(inst:load-address rref:sections + (ea:indexed rref:block 2 'WORD rref:length 'WORD)) + ;; Invoke linker + ,@(trap:link rref:block rref:sections rref:n-sections) + ,@(make-internal-continuation-label (generate-label)) + + ;; Increment counter and loop + ,@(inst:increment 'WORD rref:index rref:index) + ,@(inst:load-immediate rref:length n-blocks) + ,@(inst:conditional-jump 'LT rref:index rref:length + (ea:address loop-label)) + ,@(inst:jump (ea:address end-label)) + + ,@(inst:label bytes-label) + ,@(let walk ((bytes (vector->list n-sections))) + (if (null? bytes) + (LAP) + (LAP ,@(inst:datum-u8 (car bytes)) + ,@(walk (cdr bytes))))) + + ,@(inst:label end-label))) (LAP))) +(define-integrable linkage-type:operator 0) +(define-integrable linkage-type:reference 1) +(define-integrable linkage-type:assignment 2) +(define-integrable linkage-type:global-operator 3) + (define (generate/constants-block constants references assignments uuo-links global-links static-vars) (receive (labels code) - (???3 linkage-type:operator (???4 uuo-links) - linkage-type:reference references - linkage-type:assignment assignments - linkage-type:global-operator (???4 global-links)) + (generate/sections + linkage-type:operator (generate/uuos uuo-links) + linkage-type:reference references + linkage-type:assignment assignments + linkage-type:global-operator (generate/uuos global-links)) (let ((environment-label (allocate-constant-label))) (values (LAP ,@code - ,@(???2 (map (lambda (pair) - (cons #f (cdr pair))) - static-vars)) - ,@(???2 constants) + ,@(generate/constants (map (lambda (pair) + (cons #f (cdr pair))) + static-vars)) + ,@(generate/constants constants) ;; Placeholder for the debugging info filename (SCHEME-OBJECT ,(allocate-constant-label) DEBUGGING-INFO) ;; Placeholder for the load time environment if needed @@ -1178,20 +1185,21 @@ USA. (if (pair? labels) (car labels) #f) (length labels))))) -(define (???3 . groups) +(define (generate/sections . groups) (let loop ((groups groups)) (if (pair? groups) (let ((linkage-type (car groups)) (entries (cadr groups))) (if (pair? entries) (receive (labels code) (loop (cddr groups)) - (receive (label code*) (???1 linkage-type entries) + (receive (label code*) + (generate/section linkage-type entries) (values (cons label labels) (LAP ,@code* ,@code)))) (loop (cddr groups)))) (values '() (LAP))))) -(define (???1 linkage-type entries) +(define (generate/section linkage-type entries) (if (pair? entries) (let ((label (allocate-constant-label))) (values label @@ -1199,24 +1207,26 @@ USA. ,label ,(make-linkage-type-marker linkage-type (length entries))) - ,@(???2 entries)))) + ,@(generate/constants entries)))) (values #f (LAP)))) -(define (???2 entries) +(define (generate/constants entries) (let loop ((entries entries)) (if (pair? entries) (LAP (SCHEME-OBJECT ,(cdar entries) ,(caar entries)) ,@(loop (cdr entries))) (LAP)))) -(define (???4 links) - (append-map (lambda (entry) - (append-map (let ((name (car entry))) - (lambda (p) - (list p - (cons name (allocate-constant-label))))) - (cdr entry))) - links)) +(define (generate/uuos name.caches-list) + (append-map (lambda (name.caches) + (append-map (let ((name (car name.caches))) + (lambda (cache) + (let ((frame-size (car cache)) + (label (cdr cache))) + (LAP (,frame-size . ,label) + (,name . ,(allocate-constant-label)))))) + (cdr name.caches))) + name.caches-list)) (define (make-linkage-type-marker linkage-type n-entries) (let ((type-offset #x10000)) @@ -1230,36 +1240,29 @@ USA. (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?)) (QUALIFIER (interpreter-call-argument? extension)) cont ; ignored - (let ((set-extension - (interpreter-call-argument->machine-register! extension edx))) - (LAP ,@set-extension - ,@(clear-map!) + (let ((cache (interpreter-call-temporary extension))) + (LAP ,@(clear-map!) ,@(if safe? - (trap:safe-reference-trap) - (trap:reference-trap))))) + (trap:safe-lookup cache) + (trap:lookup cache))))) (define-rule statement (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value)) (QUALIFIER (and (interpreter-call-argument? extension) (interpreter-call-argument? value))) cont ; ignored - (let* ((set-extension - (interpreter-call-argument->machine-register! extension edx)) - (set-value (interpreter-call-argument->machine-register! value ebx))) - (LAP ,@set-extension - ,@set-value - ,@(clear-map!) - ,@(trap:assignment-trap)))) + (let* ((cache (interpreter-call-temporary extension)) + (value (interpreter-call-temporary value))) + (LAP ,@(clear-map!) + ,@(trap:assignment-trap cache value)))) (define-rule statement (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension)) (QUALIFIER (interpreter-call-argument? extension)) cont ; ignored - (let ((set-extension - (interpreter-call-argument->machine-register! extension edx))) - (LAP ,@set-extension - ,@(clear-map!) - ,@(trap:unassigned?-trap)))) + (let ((cache (interpreter-call-temporary extension))) + (LAP ,@(clear-map!) + ,@(trap:unassigned?-trap cache)))) ;;;; Interpreter Calls @@ -1292,12 +1295,11 @@ USA. (lookup-call trap:unbound? environment name)) (define (lookup-call trap environment name) - (let ((set-environment - (interpreter-call-argument->machine-register! environment edx))) - (LAP ,@set-environment - ,@(clear-map (clear-map!)) - ,@(load-constant regnum:word-1 name) - ,@(trap)))) + (let ((environment-reg (interpreter-call-temporary environment)) + (name-reg (word-temporary))) + (LAP ,@(clear-map (clear-map!)) + ,@(load-constant name-reg name) + ,@(trap environment-reg name-reg)))) (define-rule statement (INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value)) @@ -1314,15 +1316,12 @@ USA. (assignment-call trap:set! environment name value)) (define (assignment-call trap environment name value) - (let* ((set-environment - (interpreter-call-argument->machine-register! environment edx)) - (set-value (interpreter-call-argument->machine-register! value eax))) - (LAP ,@set-environment - ,@set-value - ,@(clear-map!) - (MOV W ,regnum:utility-arg-4 (R ,eax)) - ,@(load-constant (INST-EA (R ,ebx)) name) - ,@(trap)))) + (let ((environment-reg (interpreter-call-temporary environment)) + (name-reg (word-temporary)) + (value-reg (interpreter-call-temporary value))) + (LAP ,@(clear-map!) + ,@(load-constant (INST-EA ,name-reg) name) + ,@(trap environment-reg name-reg value-reg)))) ;;;; Synthesized Data @@ -1478,6 +1477,13 @@ USA. (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) diff --git a/src/configure.ac b/src/configure.ac index 5d2d23dde..490d06153 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -47,6 +47,11 @@ c) INSTALL_COM=: INSTALL_LIARC_BUNDLES=install-liarc-bundles ;; +svm1) + ALL_TARGET=all-svm + INSTALL_COM='$(INSTALL_DATA)' + INSTALL_LIARC_BUNDLES= + ;; *) ALL_TARGET=all-native INSTALL_COM='$(INSTALL_DATA)' diff --git a/src/etc/compile-svm.sh b/src/etc/compile-svm.sh new file mode 100755 index 000000000..02082d467 --- /dev/null +++ b/src/etc/compile-svm.sh @@ -0,0 +1,104 @@ +#!/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. + +# 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. + +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