* 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.
@$(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
$(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
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
(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)
(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)
(write-item (last items) port)
(newline port))
\f
-(define (write-copyright+license pathname port)
- pathname
- (write-string "DO NOT EDIT: this file was generated by a program." port)
- (newline port)
- (newline port)
- (write-mit-scheme-copyright port)
- (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?))
(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
(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)
\f
;;;; 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))))
(eq? (rt-coding-type-name rt-coding-type) name)))
(error:bad-range-argument name 'RT-CODING-TYPE)))
\f
+;;;; Assembler Machine Dependencies
+
+(let-syntax
+ ((ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form))))))
+
+(define-integrable maximum-padding-length
+ ;; Instructions can be any number of bytes long.
+ ;; Thus the maximum padding is 7 bytes.
+ 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
+)
+\f
;;;; Patterns
(define (parse-pattern pattern)
(k (reverse! expressions) pvals))))
(k pattern pvals))))
\f
-;;;; 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)
-\f
-;;;; 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))
-\f
-;;;; 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)
-\f
-;;;; 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)
(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)))
- '())))
-\f
-;;;; 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))
(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))
\f
;;;; Symbolic expressions
(map (lambda (expression)
(cond ((se-integer? expression) 'INTEGER)
((se-float? expression) 'FLOAT)
+ ;;((se-address? expression) 'ADDRESS)
(else (loop expression))))
(cdr expression))))
(and (pair? types)
(define-integrable (se-float? object)
(flo:flonum? object))
+#|
(define (se-address? object)
???)
(define (se-address:- address1 address2)
???)
+|#
\f
(define-symbolic-operator '+
(lambda (types)
(for-all? (cdr types) sb-type:integer?)))
(car types)))
(lambda (pvals)
- (if (se-address? (car pvals))
- (se-address:+ (car pvals) (apply + (cdr pvals)))
- (apply + pvals))))
+;; (if (se-address? (car pvals))
+;; (se-address:+ (car pvals) (apply + (cdr pvals)))
+;; (apply + pvals))))
+ (apply + pvals)))
(define-symbolic-operator '-
(lambda (types)
(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)
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))
(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)
\f
(global-definitions "../runtime/runtime")
(global-definitions "../sf/sf")
+(global-definitions "../cref/cref")
(define-package (compiler)
(files "base/switch"
(export (compiler top-level) register-allocation))
\f
(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
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))
;;;; Script to incrementally syntax the compiler
\f
-(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)))
(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))
(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
--- /dev/null
+#| -*-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))
+\f
+;;; 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
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.
|#
\f
;;;; 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)
(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))
+\f
+;;;; Register references
+
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (do ((i 0 (+ i 1)))
+ ((>= i number-of-machine-registers))
+ (vector-set! references i `(R ,i)))
+ (lambda (register)
+ (guarantee-limited-index-fixnum register
+ number-of-machine-registers
+ 'REGISTER-REFERENCE)
+ (vector-ref references register))))
+
+(define (register-reference? object)
+ (and (pair? object)
+ (eq? (car object) 'R)
+ (pair? (cdr object))
+ (index-fixnum? (cadr object))
+ (fix:< (cadr object) number-of-machine-registers)
+ (null? (cddr object))))
+
+(define-guarantee register-reference "register reference")
+
+(define (reference->register reference)
+ (guarantee-register-reference reference 'REFERENCE->REGISTER)
+ (cadr reference))
+
+(define-integrable rref:word-0 (register-reference regnum:word-0))
+(define-integrable rref:word-1 (register-reference (+ 1 regnum:word-0)))
+(define-integrable rref:word-2 (register-reference (+ 2 regnum:word-0)))
+(define-integrable rref:word-3 (register-reference (+ 3 regnum:word-0)))
+(define-integrable rref:word-4 (register-reference (+ 4 regnum:word-0)))
+(define-integrable rref:word-5 (register-reference (+ 5 regnum:word-0)))
+(define-integrable rref:word-6 (register-reference (+ 6 regnum:word-0)))
(define (register->register-transfer source target)
(if (= source target)
(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)
\f
;;;; Linearizer interface
(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
(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)))
\f
(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))
(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)))))
\f
(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?)
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.
|#
(declare (usual-integrations))
\f
(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))
-\f
-;; 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)))))))))))
-\f
-;; 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))))))
-\f
-;; 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))))))))
-\f
-;; 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))))))))
-\f
-;; 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
(declare (usual-integrations))
\f
+;;;; 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))
(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)
+\f
+;;;; 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)
+\f
+;;;; 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))
+\f
+;;;; 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)
+\f
+;;;; 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
\f
;;;; 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)
(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))
;; 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
;; 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.
--- /dev/null
+#| -*-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
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))
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.
|#
(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))
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))))
(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)))
,@(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))
(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))
(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))
,@(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))
(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)
(? 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
(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)))))
\f
;;;; Procedure headers
;;; 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))
(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))
,@(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)))
\f
;; Interrupt check placement
;;
\f
;;;; 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 <entry>))
- (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)))))))
\f
-(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)))))
\f
(define-rule statement
(CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
(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
;;; 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)))
\f
+(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
(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
,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))
(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))))
\f
;;;; Interpreter Calls
(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))))
\f
(define-rule statement
(INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value))
(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))))
\f
;;;; Synthesized Data
(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)
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)'
--- /dev/null
+#!/bin/sh
+#
+# Copyright (C) 2010 Massachusetts Institute of Technology
+#
+# This file is part of MIT/GNU Scheme.
+#
+# MIT/GNU Scheme is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+# 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 </dev/null
+ fi
+done
+run_cmd_in_dir compiler \
+ "${@}" --batch-mode --band runtime.com --load compiler.sf </dev/null
+
+run_cmd_in_dir runtime \
+ ../microcode/scheme --batch-mode --fasl make.bin --library ../lib <<EOF
+(disk-save "../lib/x-runtime.com")
+EOF
+
+run_cmd microcode/scheme --batch-mode --library lib --band x-runtime.com <<EOF
+(begin
+ (load-option 'SF)
+ (load-option 'CREF)
+ ;;(load-option 'COMPILER) This fails: compiler/ not found!
+ (with-working-directory-pathname "compiler"
+ (lambda () (load "machine/make")))
+ (disk-save "lib/x-compiler.com"))
+EOF
+
+make_stage1 ()
+{
+ # Unfortunately `make stage1' does not (re)move .bin's.
+ # Thus this function.
+
+ if [ -d STAGE1 ]; then
+ echo "runtime/STAGE1 files already exist."
+ exit 1
+ fi
+ mkdir STAGE1
+ mv -f *.bin *.ext *.crf *.fre *.pkd STAGE1/
+}
+
+#run_cmd_in_dir runtime make stage1 # This does not move the .bin's.
+(cd runtime/ && make_stage1)
+#run_cmd_in_dir sf make stage1
+(cd sf/ && make_stage1)
+#run_cmd_in_dir cref make stage1
+(cd cref/ && make_stage1)
+
+run_cmd microcode/scheme --batch-mode --library lib --band x-compiler.com <<EOF
+(begin
+ (load "etc/compile")
+ (fluid-let ((compiler:cross-compiling? #t)
+ (compiler:generate-lap-files? #t)
+ (compiler:intersperse-rtl-in-lap? #t))
+ (compile-everything)))
+EOF
+
+run_cmd microcode/scheme --batch-mode --library lib --band x-compiler.com <<EOF
+(begin
+ (load "compiler/base/crsend")
+ (finish-cross-compilation:directory ".."))
+EOF
#include "errors.h"
#include "svm1-defns.h"
-static unsigned int read_u16 (insn_t *);
static void write_u16 (unsigned int, insn_t *);
\f
bool
return (false);
}
-static unsigned int
+unsigned int
read_u16 (insn_t * address)
{
return
extern long C_to_interface (void *);
extern void initialize_svm1 (void);
extern insn_t * read_uuo_target (SCHEME_OBJECT *);
+extern unsigned int read_u16 (insn_t *);
#endif /* !SCM_CMPINTMD_H_INCLUDED */
return (result);
}
\f
-static bool
-must_quote_char_p (int c)
-{
- return ((c == QUOTE_CHAR) || (c == PATH_DELIMITER));
-}
-
-static unsigned int
-strlen_after_quoting (const char * s)
-{
- const char * scan = s;
- unsigned int n_chars = 0;
- while (true)
- {
- int c = (*scan++);
- if (c == '\0')
- return n_chars;
- if (must_quote_char_p (c))
- n_chars += 1;
- n_chars += 1;
- }
-}
-
-static char *
-quote_string (const char * s)
-{
- const char * scan_in = s;
- char * result = (OS_malloc ((strlen_after_quoting (s)) + 1));
- char * scan_out = result;
- while (true)
- {
- int c = (*scan_in++);
- if (c == '\0')
- break;
- if (must_quote_char_p (c))
- (*scan_out++) = QUOTE_CHAR;
- (*scan_out++) = c;
- }
- (*scan_out) = '\0';
- return result;
-}
-
static unsigned int
strlen_after_unquoting (const char * s)
{
}
xfree (path);
}
-
-static char *
-add_to_library_path (const char * new_dir, const char * library_path)
-{
- const char * quoted_dir = (quote_string (new_dir));
- unsigned int quoted_dir_len = (strlen (quoted_dir));
- char * result = (OS_malloc (quoted_dir_len + (strlen (library_path)) + 2));
- char * end = (result + quoted_dir_len);
- strcpy (result, quoted_dir);
- (*end++) = PATH_DELIMITER;
- strcpy (end, library_path);
- xfree (quoted_dir);
- return (result);
-}
\f
const char *
search_for_library_file (const char * filename)
#include "scheme.h"
#include "svm1-defns.h"
+#include "cmpintmd/svm1.h"
#define SVM1_REG_SP 0
\f
{
DECODE_SVM1_INST_ENTER_CLOSURE (index);
{
- byte_t * block = (PC - (SIZEOF_SCHEME_OBJECT + ((index + 1) * 3)));
- unsigned int count
- = ((((unsigned int) (block[1])) << 8)
- | ((unsigned int) (block[0])));
+ byte_t * block = (PC - (CLOSURE_COUNT_SIZE
+ + ((index + 1) * CLOSURE_ENTRY_SIZE)));
+ unsigned int count = (read_u16 (block));
SCHEME_OBJECT * targets
- = (((SCHEME_OBJECT *) block)
- + (1
- + (((count * 3) + (SIZEOF_SCHEME_OBJECT - 1))
- / SIZEOF_SCHEME_OBJECT)));
+ = (skip_compiled_closure_padding
+ (block + (CLOSURE_COUNT_SIZE + (count * CLOSURE_ENTRY_SIZE))));
push_object (MAKE_CC_BLOCK (((SCHEME_OBJECT *) block) - 1));
NEW_PC (BYTE_ADDR (OBJECT_ADDRESS (targets[index])));
}
projects / mit-scheme.git / commitdiff