#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/compiler.pkg,v 1.1 1990/05/07 04:11:31 jinx Exp $
-$MC68020-Header: comp.pkg,v 1.27 90/01/22 23:45:02 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/compiler.pkg,v 1.2 1990/07/22 20:16:15 jinx Rel $
+$MC68020-Header: comp.pkg,v 1.30 90/05/03 15:16:59 GMT jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
compiler:show-phases?
compiler:show-procedures?
compiler:show-subphases?
- compiler:show-time-reports?))
+ compiler:show-time-reports?
+ compiler:use-multiclosures?))
\f
(define-package (compiler reference-contexts)
(files "base/refctx")
(parent (compiler fg-optimizer))
(export (compiler top-level)
setup-block-types!
- setup-closure-contexts!))
+ setup-closure-contexts!)
+ (export (compiler)
+ indirection-block-procedure))
(define-package (compiler fg-optimizer simplicity-analysis)
(files "fgopt/simple")
(files "rtlgen/rtlgen" ;RTL generator
"rtlgen/rgstmt" ;statements
"rtlgen/fndvar" ;find variables
- "machines/mips/rgspcm" ;special close-coded primitives
+ "machines/mips/rgspcm" ;special close-coded primitives
"rtlbase/rtline" ;linearizer
)
(parent (compiler))
(export (compiler rtl-generator)
generate/rvalue
load-closure-environment
+ make-cons-closure-indirection
+ make-cons-closure-redirection
+ make-closure-redirection
make-ic-cons
make-non-trivial-closure-cons
- make-trivial-closure-cons))
+ make-trivial-closure-cons
+ redirect-closure))
(define-package (compiler rtl-generator generate/combination)
(files "rtlgen/rgcomb")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/decls.scm,v 1.1 1990/05/07 04:12:47 jinx Exp $
-$MC68020-Header: decls.scm,v 4.25 90/01/18 22:43:31 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/decls.scm,v 1.2 1990/07/22 20:18:06 jinx Rel $
+$MC68020-Header: decls.scm,v 4.27 90/05/03 15:17:08 GMT jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Compiler File Dependencies
+;;; package: (compiler declarations)
(declare (usual-integrations))
\f
(source-node/declarations node)))))
filenames))
- (let ((front-end-base
- (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3"
- "contin" "ctypes" "enumer" "lvalue"
- "object" "proced" "rvalue"
- "scode" "subprb" "utils"))
- (mips-base
- (filename/append "machines/mips" "machin"))
- (rtl-base
- (filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlobj"
- "rtlreg" "rtlty1" "rtlty2"))
- (cse-base
- (filename/append "rtlopt"
- "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr"))
- (instruction-base
- (filename/append "machines/mips" "assmd" "machin"))
- (lapgen-base
- (append (filename/append "back" "lapgn3" "regmap")
- (filename/append "machines/mips" "lapgen")))
- (assembler-base
- (append (filename/append "back" "symtab")
- (filename/append "machines/mips"
- "instr1" "instr2a" "instr2b" "instr3")))
- (lapgen-body
- (append
- (filename/append "back" "lapgn1" "lapgn2" "syntax")
- (filename/append "machines/mips"
- "rules1" "rules2" "rules3" "rules4"
- "rulfix" "rulflo"
- )))
- (assembler-body
- (append
- (filename/append "back" "bittop")
- (filename/append "machines/mips"
- "instr1" "instr2a" "instr2b" "instr3"))))
+ (let* ((front-end-base
+ (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3"
+ "contin" "ctypes" "enumer" "lvalue"
+ "object" "proced" "rvalue"
+ "scode" "subprb" "utils"))
+ (mips-base
+ (filename/append "machines/mips" "machin"))
+ (rtl-base
+ (filename/append "rtlbase"
+ "regset" "rgraph" "rtlcfg" "rtlobj"
+ "rtlreg" "rtlty1" "rtlty2"))
+ (cse-base
+ (filename/append "rtlopt"
+ "rcse1" "rcseht" "rcserq" "rcsesr"))
+ (cse-all
+ (append (filename/append "rtlopt"
+ "rcse2" "rcseep")
+ cse-base))
+ (instruction-base
+ (filename/append "machines/mips" "assmd" "machin"))
+ (lapgen-base
+ (append (filename/append "back" "lapgn3" "regmap")
+ (filename/append "machines/mips" "lapgen")))
+ (assembler-base
+ (append (filename/append "back" "symtab")
+ (filename/append "machines/mips"
+ "instr1" "instr2a" "instr2b" "instr3")))
+ (lapgen-body
+ (append
+ (filename/append "back" "lapgn1" "lapgn2" "syntax")
+ (filename/append "machines/mips"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo"
+ )))
+ (assembler-body
+ (append
+ (filename/append "back" "bittop")
+ (filename/append "machines/mips"
+ "instr1" "instr2a" "instr2b" "instr3"))))
(define (file-dependency/integration/join filenames dependencies)
(for-each (lambda (filename)
(file-dependency/integration/make filename dependencies))
filenames))
-
+
(define (file-dependency/integration/make filename dependencies)
(let ((node (filename->source-node filename)))
(for-each (lambda (dependency)
(if (not (eq? node node*))
(source-node/link! node node*))))
dependencies)))
-
+
(define (define-integration-dependencies directory name directory* . names)
(file-dependency/integration/make
(string-append directory "/" name)
(apply filename/append directory* names)))
-
+
(define-integration-dependencies "base" "object" "base" "enumer")
(define-integration-dependencies "base" "enumer" "base" "object")
(define-integration-dependencies "base" "utils" "base" "scode")
(append mips-base front-end-base rtl-base))
(file-dependency/integration/join
- (append cse-base
+ (append cse-all
(filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
"rerite" "rinvex" "rlife" "rtlcsm")
- (filename/append "machines/mips" "rulrew")
- )
+ (filename/append "machines/mips" "rulrew"))
(append mips-base rtl-base))
- (file-dependency/integration/join cse-base cse-base)
+ (file-dependency/integration/join cse-all cse-base)
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
+ (filename/append "rtlbase" "regset"))
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "rcseht" "rcserq")
+ (filename/append "base" "object"))
- (define-integration-dependencies "rtlopt" "rcseht" "base" "object")
- (define-integration-dependencies "rtlopt" "rcserq" "base" "object")
(define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
(let ((dependents
)
(map (lambda (entry)
`(,(car entry)
- (PACKAGE/REFERENCE
- (FIND-PACKAGE '(COMPILER LAP-SYNTAXER)) ',(cadr entry))))
+ (PACKAGE/REFERENCE (FIND-PACKAGE '(COMPILER LAP-SYNTAXER))
+ ',(cadr entry))))
'((LAP:SYNTAX-INSTRUCTION LAP:SYNTAX-INSTRUCTION-EXPANDER)
(INSTRUCTION->INSTRUCTION-SEQUENCE
INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/machin.scm,v 1.1 1990/05/07 04:15:24 jinx Exp $
-$MC68020-Header: machin.scm,v 4.20 90/01/18 22:43:44 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/machin.scm,v 1.2 1990/07/22 20:21:37 jinx Rel $
+$MC68020-Header: machin.scm,v 4.22 90/05/03 15:17:20 GMT jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define-integrable (stack->memory-offset offset) offset)
(define-integrable ic-block-first-parameter-offset 2)
-(define-integrable closure-block-first-offset 2)
(define-integrable execute-cache-size 2) ; Long words per UUO link slot
+(define-integrable closure-entry-size
+ ;; Long words in a single closure entry:
+ ;; GC offset word
+ ;; JALR
+ ;; ADDI
+ 3)
+
+;; Given: the number of entry points in a closure, and a particular
+;; entry point number. Return: the distance from that entry point to
+;; the first variable slot in the closure (in words).
+
+(define (closure-first-offset nentries entry)
+ (if (zero? nentries)
+ 1 ; Strange boundary case
+ (- (* closure-entry-size (- nentries entry)) 1)))
+
+;; Like the above, but from the start of the complete closure object,
+;; viewed as a vector, and including the header word.
+
+(define (closure-object-first-offset nentries)
+ (case nentries
+ ((0)
+ ;; Vector header only
+ 1)
+ ((1)
+ ;; Manifest closure header followed by single entry point
+ (+ 1 closure-entry-size))
+ (else
+ ;; Manifest closure header, number of entries, then entries.
+ (+ 1 1 (* closure-entry-size nentries)))))
+
+;; Bump from one entry point to another -- distance in BYTES
+
+(define (closure-entry-distance nentries entry entry*)
+ nentries ; ignored
+ (* (* closure-entry-size 4) (- entry* entry)))
+
+;; Bump to the canonical entry point. On a RISC (which forces
+;; longword alignment for entry points anyway) there is no need to
+;; canonicalize.
+
+(define (closure-environment-adjustment nentries entry)
+ nentries entry ; ignored
+ 0)
\f
;;;; Machine Registers
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-big,v 4.65 1990/05/07 04:09:24 jinx Exp $
-$MC68020-Header: make.scm,v 4.65 90/01/22 23:45:31 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-big,v 4.73 1990/07/22 20:33:20 jinx Exp $
+$MC68020-Header: make.scm,v 4.73 90/05/03 15:17:24 GMT jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (MIPS)" 4 65 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (MIPS)" 4 73 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-little,v 4.65 1990/05/07 04:09:24 jinx Exp $
-$MC68020-Header: make.scm,v 4.65 90/01/22 23:45:31 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-little,v 4.73 1990/07/22 20:33:20 jinx Exp $
+$MC68020-Header: make.scm,v 4.73 90/05/03 15:17:24 GMT jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (MIPS)" 4 65 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (MIPS)" 4 73 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules1.scm,v 1.1 1990/05/07 04:16:03 jinx Exp $
-$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules1.scm,v 1.2 1990/07/22 20:24:55 jinx Rel $
+$MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
(object->address target)))
(define-rule statement
- ;; add a constant to a register's contents
+ ;; add a distance (in longwords) to a register's contents
(ASSIGN (REGISTER (? target))
(OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
(standard-unary-conversion source target
(lambda (source target)
(add-immediate (* 4 offset) source target))))
+(define-rule statement
+ ;; add a distance (in bytes) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? offset)))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (add-immediate offset source target))))
+
(define-rule statement
;; read an object from memory
(ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
(ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
(CHAR->ASCII (REGISTER (? source))))
(LAP (SB ,(standard-source! source)
- (OFFSET ,offset ,(standard-source! address)))))
+ (OFFSET ,offset ,(standard-source! address)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.1 1990/05/07 04:16:34 jinx Exp $
-$MC68020-Header: rules3.scm,v 4.23 90/01/18 22:44:09 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.2 1990/07/22 20:26:45 jinx Exp $
+$MC68020-Header: rules3.scm,v 4.24 90/05/03 15:17:33 GMT jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(deposit-type (ucode-type compiled-entry) register))
(define-rule statement
- (CLOSURE-HEADER (? internal-label))
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ entry ; ignored -- non-RISCs only
+ (if (zero? nentries)
+ (error "Closure header for closure with no entries!"
+ internal-label))
(let ((procedure (label->object internal-label)))
(let ((gc-label (generate-label))
(external-label (rtl-procedure/external-label procedure)))
(LABEL ,internal-label)
,@(interrupt-check gc-label)))))
-(define (cons-closure target label min max size ->entry?)
+(define (build-gc-offset-word offset code-word)
+ (let ((encoded-offset (quotient offset 2)))
+ (if (eq? endianness 'LITTLE)
+ (+ (* encoded-offset #x10000) code-word)
+ (+ (* code-word #x10000) encoded-offset))))
+
+(define (cons-closure target label min max size)
(let ((flush-reg (clear-registers! regnum:interface-index)))
(need-register! regnum:interface-index)
- (let ((dest (standard-target! target)))
+ (let ((dest (standard-target! target))
+ (gc-offset-word
+ (build-gc-offset-word
+ 8 (make-procedure-code-word min max))))
;; Note: dest is used as a temporary before the JALR
;; instruction, and is written immediately afterwards.
;; The interface (scheme_to_interface-88) expects:
- ;; 1: size of closure = size+3
+ ;; 1: size of closure = size+closure entry size
;; 4: offset to destination label
;; 25: GC offset and arity information
+ ;; NOTE: setup of 25 has implict the endian-ness!
(LAP ,@flush-reg
- ,@(load-immediate (+ size 3) 1)
- (LUI 25 4)
+ ,@(load-immediate (+ size closure-entry-size) 1)
+ (LUI 25 ,(quotient gc-offset-word #x10000))
(PC-RELATIVE-OFFSET 4 16
,(rtl-procedure/external-label (label->object label)))
(ADDI ,dest ,regnum:scheme-to-interface -88) ; + 4
- (JALR ,regnum:linkage ,dest) ; + 8
- (ORI 25 25 ,(make-procedure-code-word min max)) ; +12
+ (JALR 31 ,dest) ; + 8
+ (ORI 25 25 ,(remainder gc-offset-word #x10000)) ; +12
,@(add-immediate (* 4 (- (+ size 2))) ; +16
- regnum:free dest)
- ,@(if ->entry? (address->entry dest) (LAP))))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (MACHINE-CONSTANT (? type))
- (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size))))
- (QUALIFIER (= type (ucode-type compiled-entry)))
- (cons-closure target procedure-label min max size true))
+ regnum:free dest)))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
(? min) (? max) (? size)))
- (QUALIFIER (= type (ucode-type compiled-entry)))
- (cons-closure target procedure-label min max size false))
+ (cons-closure target procedure-label min max size))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+ ;; entries is a vector of all the entry points
+ (case nentries
+ ((0)
+ (let ((dest (standard-target! target))
+ (temp (standard-temporary!)))
+ (LAP (ADD ,dest 0 ,regnum:free)
+ ,@(load-non-pointer
+ (ucode-type manifest-vector) size temp)
+ (SW ,temp (OFFSET 0 ,regnum:free))
+ (ADDI ,regnum:free ,regnum:free ,(* 4 (+ size 1))))))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (cons-closure
+ target (car entry) (cadr entry) (caddr entry) size)))
+ (else
+ (cons-multiclosure target nentries size (vector->list entries)))))
+
+(define (cons-multiclosure target nentries size entries)
+ ;; Assembly support called with:
+ ;; 31 is the return address
+ ;; 1 has the GC offset and format words
+ ;; 4 has the offset from return address to destination
+ ;; Note that none of these are allocatable registers
+ (let ((total-size (+ size 1 (* closure-entry-size nentries)))
+ (dest (standard-target! target))
+ (temp (standard-temporary!)))
+
+ (define (generate-entries entries offset)
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (let ((gc-offset-word
+ (build-gc-offset-word
+ offset
+ (make-procedure-code-word
+ (cadr entry) (caddr entry)))))
+ (LAP
+ (LUI 1 ,(quotient gc-offset-word #x10000))
+ (PC-RELATIVE-OFFSET 4 16 ,(rtl-procedure/external-label
+ (label->object (car entry))))
+ (ADDI ,temp ,regnum:scheme-to-interface -80) ; + 4
+ (JALR 31 ,temp) ; + 8
+ (ORI 1 1 ,(remainder gc-offset-word #x10000)) ; + 12
+ ,@(generate-entries (cdr entries) ; + 16
+ (+ (* closure-entry-size 4)
+ offset)))))))
+
+ (LAP
+ ,@(load-non-pointer (ucode-type manifest-closure) total-size temp)
+ (SW ,temp (OFFSET 0 ,regnum:free))
+ ,@(load-immediate (build-gc-offset-word 0 nentries) temp)
+ (SW ,temp (OFFSET 4 ,regnum:free))
+ (ADDI ,regnum:free ,regnum:free 8)
+ (ADDI ,dest ,regnum:free 4)
+ ,@(generate-entries entries 12)
+ (ADDI ,regnum:free ,regnum:free ,(* 4 size)))))
\f
;;;; Entry Header
;;; This is invoked by the top level of the LAP generator.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulflo.scm,v 1.1 1990/05/07 04:17:41 jinx Exp $
-$MC68020-Header: rules1.scm,v 4.32 90/01/18 22:43:54 GMT cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulflo.scm,v 1.2 1990/07/22 20:28:36 jinx Rel $
+$MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
(lambda (label)
(LAP (BC1F (@PCR ,label)) (NOP))))
(if (eq? cc 'C.GT)
- (LAP (C.LT DOUBLE ,r2 ,r1))
- (LAP (,cc DOUBLE ,r1 ,r2))))
-
\ No newline at end of file
+ (LAP (C.LT DOUBLE ,r2 ,r1) (NOP))
+ (LAP (,cc DOUBLE ,r1 ,r2) (NOP))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff