cache-line sizes) and on R4000 systems in 32-bit mode.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr1.scm,v 1.5 1992/03/13 11:04:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr1.scm,v 1.6 1992/08/20 01:22:14 jinx Exp $
-Copyright (c) 1987-92 Massachusetts Institute of Technology
+Copyright (c) 1987-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-instruction NOP
;; (SLL 0 0 0)
(()
- (LONG (6 0) (5 0) (5 0) (5 0) (5 0) (6 0))))
\ No newline at end of file
+ (LONG (6 0) (5 0) (5 0) (5 0) (5 0) (6 0))))
+
+(define-instruction LONG
+ ((S (? value))
+ (LONG (32 value SIGNED)))
+ ((U (? value))
+ (LONG (32 value UNSIGNED))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/lapgen.scm,v 1.10 1992/07/29 22:05:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/lapgen.scm,v 1.11 1992/08/20 01:23:26 jinx Exp $
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; RTL Rules for MIPS. Shared utilities.
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(define available-machine-registers
(list
- ;; g0 g1 g2 g3 g4
+ ;; g0 g1 g2 g3
;; g8 g9 g10 g11
- g12 g13 g14 g15 g16 g17 g18 g19
- ;; g20 g21 g22
- g23 g24
+ g12 g13 g14 g15 g16 g17 g18
+ ;; g19 g20 g21 g22 g23
+ g24
;; g26 g27 g28 g29
g30
- g5 g6 g7 g25 ; Allocate last
- ;; g31
+ g7 g6 g5 g4 g25 ; Allocate last
+ ;; g31 ; could be available if handled right
fp0 fp2 fp4 fp6 fp8 fp10 fp12 fp14
fp16 fp18 fp20 fp22 fp24 fp26 fp28 fp30
;; fp1 fp3 fp5 fp7 fp9 fp11 fp13 fp15
(define-integrable reg:lexpr-primitive-arity
(INST-EA (OFFSET #x001C ,regnum:regs-pointer)))
+(define-integrable reg:closure-limit
+ (INST-EA (OFFSET #x0024 ,regnum:regs-pointer)))
+
(define-integrable reg:stack-guard
(INST-EA (OFFSET #x002C ,regnum:regs-pointer)))
(LAP)))))
(LAP ,@clear-regs
,@load-regs
- ,@(clear-map!)))))
\ No newline at end of file
+ ,@(clear-map!)))))
+
+(define (require-register! machine-reg)
+ (flush-register! machine-reg)
+ (need-register! machine-reg))
+
+(define-integrable (flush-register! machine-reg)
+ (prefix-instructions! (clear-registers! machine-reg)))
+
+(define (rtl-target:=machine-register! rtl-reg machine-reg)
+ (if (machine-register? rtl-reg)
+ (begin
+ (require-register! machine-reg)
+ (if (not (= rtl-reg machine-reg))
+ (suffix-instructions!
+ (register->register-transfer machine-reg rtl-reg))))
+ (begin
+ (delete-register! rtl-reg)
+ (flush-register! machine-reg)
+ (add-pseudo-register-alias! rtl-reg machine-reg))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/machin.scm,v 1.6 1991/10/25 12:24:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/machin.scm,v 1.7 1992/08/20 01:25:15 jinx Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;; Machine Model for MIPS
+;;;; Machine Model for MIPS
+;;; package: (compiler)
(declare (usual-integrations))
\f
(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
+ ;; Format + GC offset word
+ ;; JALR/JAL
;; ADDI
3)
(define-integrable regnum:free g9)
(define-integrable regnum:scheme-to-interface g10)
(define-integrable regnum:dynamic-link g11)
+(define-integrable regnum:closure-free g19)
(define-integrable regnum:address-mask g20)
(define-integrable regnum:regs-pointer g21)
(define-integrable regnum:quad-bits g22)
+(define-integrable regnum:closure-hook g23)
(define-integrable regnum:interface-index g25)
;;; Fixed-use registers due to architecture or OS calling conventions.
(,regnum:memtop . ,value-class=address)
(,regnum:free . ,value-class=address)
(,regnum:scheme-to-interface . ,value-class=unboxed)
+ (,regnum:closure-hook . ,value-class=unboxed)
+ (,regnum:closure-free . ,value-class=unboxed)
(,regnum:dynamic-link . ,value-class=address)
(,regnum:address-mask . ,value-class=immediate)
(,regnum:regs-pointer . ,value-class=unboxed)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.11 1992/07/29 22:10:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.12 1992/08/20 01:26:56 jinx Exp $
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(+ (* 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))
- (gc-offset-word
- (build-gc-offset-word
- 8 (make-procedure-code-word min max)))
- (return-label (generate-label)))
- ;; 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+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
- (LI ,regnum:first-arg
- (- ,(rtl-procedure/external-label (label->object label))
- ,return-label))
- ,@(load-immediate 1 (+ size closure-entry-size) #F)
- (LUI 25 ,(quotient gc-offset-word #x10000))
- (ADDI ,dest ,regnum:scheme-to-interface -88)
- (JALR 31 ,dest)
- (ORI 25 25 ,(remainder gc-offset-word #x10000))
- (LABEL ,return-label)
- ,@(add-immediate (* 4 (- (+ size 2))) regnum:free dest)))))
+(define (closure-bump-size nentries nvars)
+ (* (* 4 closure-entry-size)
+ (1+ (quotient (+ (+ nvars (-1+ (* closure-entry-size nentries)))
+ (-1+ closure-entry-size))
+ closure-entry-size))))
+
+(define (closure-test-size nentries nvars)
+ (* 4
+ (+ nvars
+ (-1+ (* nentries closure-entry-size)))))
+
+(define (cons-closure target label min max nvars)
+ ;; Invoke an out-of-line handler to set up the closure's entry point.
+ ;; Arguments:
+ ;; - GR31: "Return address"
+ ;; GR31 points to a manifest closure header word, followed by a
+ ;; two-word closure descriptor, followed by the actual
+ ;; instructions to return to.
+ ;; The first word of the descriptor is the format+gc-offset word of
+ ;; the generated closure.
+ ;; The second word is the PC-relative JAL instruction.
+ ;; It is transformed into an absolute instruction by adding the shifted
+ ;; "return address".
+ ;; - GR4: Value to compare to closure free.
+ ;; - GR5: Increment for closure free.
+ ;; Returns closure in regnum:first-arg (GR4)
+ (rtl-target:=machine-register! target regnum:first-arg)
+ (require-register! regnum:second-arg)
+ (require-register! regnum:fourth-arg)
+ (let ((label-arg (generate-label)))
+ (LAP (ADDI ,regnum:second-arg ,regnum:scheme-to-interface -72)
+ (ADDI ,regnum:first-arg ,regnum:closure-free
+ ,(closure-test-size 1 nvars))
+ (JALR 31 ,regnum:second-arg)
+ (ADDI ,regnum:second-arg 0 ,(closure-bump-size 1 nvars))
+ (LABEL ,label-arg)
+ (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
+ (+ closure-entry-size nvars)))
+ (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max)))
+ (LONG U
+ (+ #x0c000000 ; JAL opcode
+ (/ (- ,(rtl-procedure/external-label (label->object label))
+ ,label-arg)
+ 4))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
- (? min) (? max) (? size)))
- (cons-closure target procedure-label min max size))
+ (? min) (? max) (? nvars)))
+ (cons-closure target procedure-label min max nvars))
\f
(define-rule statement
(ASSIGN (REGISTER (? target))
- (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+ (CONS-MULTICLOSURE (? nentries) (? nvars) (? entries)))
;; entries is a vector of all the entry points
(case nentries
((0)
(LAP (ADD ,dest 0 ,regnum:free)
,@(load-immediate
temp
- (make-non-pointer-literal (ucode-type manifest-vector) size)
+ (make-non-pointer-literal (ucode-type manifest-vector) nvars)
#T)
(SW ,temp (OFFSET 0 ,regnum:free))
- (ADDI ,regnum:free ,regnum:free ,(* 4 (+ size 1))))))
+ (ADDI ,regnum:free ,regnum:free ,(* 4 (+ nvars 1))))))
((1)
(let ((entry (vector-ref entries 0)))
- (cons-closure target (car entry) (cadr entry) (caddr entry) size)))
+ (cons-closure target (car entry) (cadr entry) (caddr entry) nvars)))
(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))))
- (return-label (generate-label)))
- (LAP
- (LI ,regnum:first-arg
- (- ,(rtl-procedure/external-label
- (label->object (car entry)))
- ,return-label))
- (LUI 1 ,(quotient gc-offset-word #x10000))
- (ADDI ,temp ,regnum:scheme-to-interface -80)
- (JALR 31 ,temp)
- (ORI 1 1 ,(remainder gc-offset-word #x10000))
- (LABEL ,return-label)
- ,@(generate-entries (cdr entries)
- (+ (* closure-entry-size 4) offset)))))))
-
- (LAP
- ,@(with-values
- (lambda ()
- (immediate->register
- (make-non-pointer-literal (ucode-type manifest-closure)
- total-size)))
- (lambda (prefix register)
- (LAP ,@prefix
- (SW ,register (OFFSET 0 ,regnum:free)))))
- ,@(with-values
- (lambda ()
- (immediate->register (build-gc-offset-word 0 nentries)))
- (lambda (prefix register)
- (LAP ,@prefix
- (SW ,register (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)))))
+ (cons-multiclosure target nentries nvars (vector->list entries)))))
+
+(define (cons-multiclosure target nentries nvars entries)
+ ;; Invoke an out-of-line handler to set up the closure's entry points.
+ ;; Arguments:
+ ;; - GR31: "Return address"
+ ;; GR31 points to a manifest closure header word, followed by
+ ;; nentries two-word structures, followed by the actual
+ ;; instructions to return to.
+ ;; The first word of each descriptor is the format+gc-offset word of
+ ;; the corresponding entry point of the generated closure.
+ ;; The second word is the PC-relative JAL instruction.
+ ;; It is transformed into an absolute instruction by adding the shifted
+ ;; "return address".
+ ;; - GR4: Value to compare to closure free.
+ ;; - GR5: Increment for closure free.
+ ;; - GR6: number of entries.
+ ;; Returns closure in regnum:first-arg (GR4).
+ (rtl-target:=machine-register! target regnum:first-arg)
+ (require-register! regnum:second-arg)
+ (require-register! regnum:third-arg)
+ (require-register! regnum:fourth-arg)
+ (let ((label-arg (generate-label)))
+ (LAP (ADDI ,regnum:third-arg ,regnum:scheme-to-interface -64)
+ (ADDI ,regnum:first-arg ,regnum:closure-free
+ ,(closure-test-size nentries nvars))
+ (ADDI ,regnum:second-arg 0 ,(closure-bump-size nentries nvars))
+ (JALR 31 ,regnum:third-arg)
+ (ADDI ,regnum:third-arg 0 ,nentries)
+ (LABEL ,label-arg)
+ (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
+ (+ 1
+ (* nentries closure-entry-size)
+ nvars)))
+ ,@(let expand ((offset 12) (entries entries))
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (LAP
+ (LONG U ,(build-gc-offset-word
+ offset
+ (make-procedure-code-word (cadr entry)
+ (caddr entry))))
+ (LONG U
+ (+ #x0c000000 ; JAL opcode
+ (/ (- ,(rtl-procedure/external-label
+ (label->object (car entry)))
+ ,label-arg)
+ 4)))
+ ,@(expand (+ offset (* 4 closure-entry-size))
+ (cdr entries)))))))))
\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/rulfix.scm,v 1.5 1992/03/11 09:31:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulfix.scm,v 1.6 1992/08/20 01:28:14 jinx Exp $
-Copyright (c) 1989-92 Massachusetts Institute of Technology
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; LAP Generation Rules: Fixnum Rules
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
(NOP)))))
(else
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (ADDU ,regnum:first-arg ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,regnum:first-arg ,src1)
- (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow))
- (ADD ,tgt 0 ,regnum:first-arg)))
- (lambda (if-no-overflow)
- (LAP (ADDU ,regnum:first-arg ,src1 ,src1)
- (XOR ,regnum:assembler-temp ,regnum:first-arg ,src1)
- (BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
- (ADD ,tgt 0 ,regnum:first-arg))))))
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (ADDU ,temp ,src1 ,src1)
+ (XOR ,regnum:assembler-temp ,temp ,src1)
+ (BLTZ ,regnum:assembler-temp (@PCR ,if-overflow))
+ (ADD ,tgt 0 ,temp)))
+ (lambda (if-no-overflow)
+ (LAP (ADDU ,temp ,src1 ,src1)
+ (XOR ,regnum:assembler-temp ,temp ,src1)
+ (BGEZ ,regnum:assembler-temp (@PCR ,if-no-overflow))
+ (ADD ,tgt 0 ,temp)))))))
(LAP))
\f
(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
(define (do-multiply tgt src1 src2 overflow?)
(if overflow?
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (MFHI ,regnum:first-arg)
- (SRA ,regnum:assembler-temp ,tgt 31)
- (BNE ,regnum:first-arg ,regnum:assembler-temp
- (@PCR ,if-overflow))
- (NOP)))
- (lambda (if-no-overflow)
- (LAP (MFHI ,regnum:first-arg)
- (SRA ,regnum:assembler-temp ,tgt 31)
- (BEQ ,regnum:first-arg ,regnum:assembler-temp
- (@PCR ,if-no-overflow))
- (NOP)))))
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (MFHI ,temp)
+ (SRA ,regnum:assembler-temp ,tgt 31)
+ (BNE ,temp ,regnum:assembler-temp
+ (@PCR ,if-overflow))
+ (NOP)))
+ (lambda (if-no-overflow)
+ (LAP (MFHI ,temp)
+ (SRA ,regnum:assembler-temp ,tgt 31)
+ (BEQ ,temp ,regnum:assembler-temp
+ (@PCR ,if-no-overflow))
+ (NOP))))))
(LAP (SRA ,regnum:assembler-temp ,src1 ,scheme-type-width)
(MULT ,regnum:assembler-temp ,src2)
(MFLO ,tgt)))
(define (do-left-shift-overflow tgt src power-of-two)
(if (= tgt src)
- (set-current-branches!
- (lambda (if-overflow)
- (LAP (SLL ,regnum:first-arg ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,regnum:first-arg ,power-of-two)
- (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
- (ADD ,tgt 0 ,regnum:first-arg)))
- (lambda (if-no-overflow)
- (LAP (SLL ,regnum:first-arg ,src ,power-of-two)
- (SRA ,regnum:assembler-temp ,regnum:first-arg ,power-of-two)
- (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
- (ADD ,tgt 0 ,regnum:first-arg))))
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (SLL ,temp ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,temp ,power-of-two)
+ (BNE ,regnum:assembler-temp ,src (@PCR ,if-overflow))
+ (ADD ,tgt 0 ,temp)))
+ (lambda (if-no-overflow)
+ (LAP (SLL ,temp ,src ,power-of-two)
+ (SRA ,regnum:assembler-temp ,temp ,power-of-two)
+ (BEQ ,regnum:assembler-temp ,src (@PCR ,if-no-overflow))
+ (ADD ,tgt 0 ,temp)))))
(set-current-branches!
(lambda (if-overflow)
(LAP (SLL ,tgt ,src ,power-of-two)
-/* #define DEBUG_INTERFACE */
- ### -*-Midas-*-
+/* #define DEBUG_INTERFACE */ ### -*-Midas-*-
###
- ### $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/mips.m4,v 1.5 1992/07/30 15:07:46 jinx Exp $
+ ### $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/mips.m4,v 1.6 1992/08/20 01:20:09 jinx Exp $
###
- ### Copyright (c) 1989-91 Massachusetts Institute of Technology
+ ### Copyright (c) 1989-1992 Massachusetts Institute of Technology
###
### This material was developed by the Scheme project at the
### Massachusetts Institute of Technology, Department of
#### references. On MIPS: 0 (always 0), 31 (return address),
#### 28 (global data pointer), and 29 (C stack pointer).
#### - super temporaries, not preserved accross procedure calls and
- #### always usable. On MIPS: 2-15. 4-7 are argument registers,
- #### 2 and 3 are return registers.
+ #### always usable. On MIPS: 1-15, and 24-25.
+ #### 4-7 are argument registers,
+ #### 2 and 3 are return registers.
#### - preserved registers saved by the callee if they are written.
- #### On MIPS: 16-25
+ #### On MIPS: 16-23.
####
#### 3) Arguments, if passed on a stack, are popped by the caller
#### or by the procedure return instruction (as on the VAX). Thus
#### dynamically. scheme_to_interface_linked and
#### trampoline_to_interface can be reached at fixed offsets from
#### scheme_to_interface.
- #### - gr2 is the returned value register
+ #### - gr1 is the assembler temporary.
+ #### - gr2 is the returned value register.
#### - gr3 contains the Scheme stack pointer.
- #### - gr4 - gr7 are used by C for arguments and can't be used
- #### permanently by Scheme
+ #### - gr4 - gr7 are used by C for arguments.
#### - gr8 contains a cached version of MemTop.
#### - gr9 contains the Scheme free pointer.
#### - gr10 contains the address of scheme_to_interface.
#### - gr11 contains the dynamic link when needed.
+ #### - gr12 - gr15 have no special uses.
#### <CALLEE SAVES REGISTERS BELOW HERE>
- #### - gr16 - gr 19 aren't used by Scheme
+ #### - gr16 - gr18 have no special uses.
+ #### - gr19 contains the closure free pointer.
#### - gr20 contains the address mask for machine pointers.
#### - gr21 contains a pointer to the Scheme interpreter's
#### "register" block. This block contains the compiler's
#### copy of MemTop, the interpreter's registers (val, env,
#### exp, etc), temporary locations for compiled code.
- #### - gr22 contains the top 6 address bits for heap pointers
+ #### - gr22 contains the top 6 address bits for heap pointers.
+ #### - gr23 contains the closure hook.
#### <CALLEE SAVES REGISTERS ABOVE HERE>
+ #### - gr24 has no special use.
#### - gr25 is used a an index for dispatch into C.
- #### - gr26 and 27 are reserved for the OS
- #### - gr28 contains the pointer to C static variables
- #### - gr29 contains the C stack pointer
+ #### - gr26 and 27 are reserved for the OS.
+ #### - gr28 contains the pointer to C static variables.
+ #### - gr29 contains the C stack pointer.
+ #### - gr30 has no special use.
+ #### - gr31 is used for linkage (JALR, JAL, BGEZAL, and BLTZAL write it).
####
#### All other registers are available to the compiler. A
#### caller-saves convention is used, so the registers need not be
#### Notice that register gr25 is used for the index used to
#### dispatch into the trampolines and interface routines.
\f
- .verstamp 1 31
+ # .verstamp 1 31
.text
.align 2
.set noat
define(s_to_i, 10)
define(dynlink, 11)
+define(closure_free, 19)
define(addr_mask, 20)
define(registers, 21)
define(heap_bits, 22)
+define(closure_reg, 23)
define(tramp_index, 25)
lui $addr_mask,0xfc00
and $heap_bits,$heap_bits,$addr_mask
nor $addr_mask,$0,$addr_mask
+ la $closure_reg,closure_hook
+ lw $closure_free,36($registers)
# ... fall through ...
# Argument (in $C_arg1) is a compiled Scheme entry point. Reload
# the Scheme registers and go to work...any registers not reloaded
# $tramp_index has the offset into the table that is desired.
.globl link_to_interface
link_to_interface: # ...scheme_to_interface-100
- addi $31,$31,4 # Skip over format word ...
+ addi $31,$31,4 # Skip over format word ...
.globl trampoline_to_interface
-trampoline_to_interface: # ...scheme_to_interface-96
+trampoline_to_interface: # ...scheme_to_interface-96
j scheme_to_interface
- add $C_arg2,$0,$31 # Arg2 <- trampoline data area
+ add $C_arg2,$0,$31 # Arg2 <- trampoline data area
- j generate_closure # ...-88
- sw $25,4($free) # ...-84
+ break 1 # ...-88 Used to be generate_closure
+ nop # ...-84
- j push_closure_entry # ...-80
- sw $1,0($free) # ...-76
+ break 2 # ...-80 Used to be push_closure_entry
+ nop # ...-76
- nop # ...-72
- nop # ...-68
- nop # ...-64
- nop # ...-60
- nop # ...-56
- nop # ...-52
- nop # ...-48
- nop # ...-44
- nop # ...-40
- nop # ...-36
- nop # ...-32
- nop # ...-28
- nop # ...-24
- nop # ...-20
- nop # ...-16
- nop # ...-12
- nop # ...-8
- nop # ...-4
+ j cons_closure # -72
+ lw $7,40($registers) # closure limit -68
+
+ j cons_multi # -64
+ lw $7,40($registers) # closure limit -60
+
+ nop # ...-56
+ nop # ...-52
+ nop # ...-48
+ nop # ...-44
+ nop # ...-40
+ nop # ...-36
+ nop # ...-32
+ nop # ...-28
+ nop # ...-24
+ nop # ...-20
+ nop # ...-16
+ nop # ...-12
+ nop # ...-8
+ nop # ...-4
# DO NOT MOVE the following label, it is used above ...
# Argument (in $tramp_index) is index into utility_table for the
.globl scheme_to_interface
scheme_to_interface:
sw $value,8($registers)
+ sw $closure_free,36($registers)
#ifdef DEBUG_INTERFACE
lw $value,Free_Constant
addi $0,$0,0 # Load delay
jal $31,$25 # Redispatch ...
addi $0,$0,0 # Branch delay...
+ .globl closure_hook
+closure_hook:
+ # On arrival:
+ # GR31 has address of JAL instruction we were supposed to have
+ # executed. This code emulates the JAL.
+ # (except that R31 is already set).
+ lw $at,0($31) # Load JAL instruction
+ nop # Load delay slot
+ and $at,$at,$addr_mask # clear JAL opcode
+ sll $at,$at,2 # obtain destination address
+ or $at,$at,$heap_bits # insert top bits into destination
+ j $at # invoke
+ nop # jump delay slot
+
+ .globl cons_closure
+cons_closure:
+ # On arriveal:
+ # - GR31 has the address of the manifest closure header,
+ # followed by the closure descriptor (2 words),
+ # followed by the instructions we need to continue with.
+ # The closure descriptor consists of the format+gc-offset word
+ # followed by a PC-relative JAL instruction.
+ # - GR4 has the address past the first word on this closure
+ # (assuming the entry point is at closure-free).
+ # - GR5 has the increment for closure-free.
+ # On return:
+ # - GR4 has the address of the closure
+ # This code assumes that it can clobber registers 7 and at freely.
+ # lw $7,40($registers) # closure limit
+ lw $at,0($31) # closure header word
+ subu $7,$7,$4 # check if it fits
+ bgez $7,cons_closure_continue
+ or $4,$closure_free,$0 # setup result
+ or $7,$31,$0 # Preserve original return address
+ bgezal $0,invoke_allocate_closure
+ addi $at,$at,2 # Total size = datum(header) + 2
+
+cons_closure_continue:
+ add $closure_free,$closure_free,$5 # allocate
+ lw $5,4($31) # format+gc-offset word
+ lw $7,8($31) # JAL instruction
+ sw $0,-12($4) # Make heap parseable
+ sw $5,-4($4) # Store format+gc-offset
+ srl $5,$31,2 # return address -> JAL destination
+ sw $at,-8($4) # Store closure header
+ and $5,$5,$addr_mask # clear top bits
+ addi $31,$31,12 # Bump past structure
+ addu $5,$5,$7 # JAL instruction
+ j $31 # Return.
+ sw $5,0($4) # Store the JAL instruction
+
+ .globl cons_multi
+cons_multi:
+ # On arriveal:
+ # - GR31 has the address of the manifest closure header,
+ # followed by n closure descriptors (2 words each),
+ # followed by the instructions we need to continue with.
+ # Each closure descriptor consists of the format+gc-offset
+ # word followed by a PC-relative JAL instruction.
+ # - GR4 has the address past the first word on this closure
+ # (assuming the entry point is at closure-free).
+ # - GR5 has the increment for closure-free.
+ # - GR6 has the number of entries (>= 1)
+ # On return:
+ # - GR4 has the address of the closure
+ # This code assumes that it can clobber registers 7 and at freely.
+ # lw $7,40($registers) # closure limit
+ lw $at,0($31) # closure header word
+ subu $7,$7,$4 # check if it fits
+ bgez $7,cons_multi_continue
+ or $4,$closure_free,$0 # setup result
+ or $7,$31,$0 # Preserve original return address
+ bgezal $0,invoke_allocate_closure
+ addi $at,$at,1 # Total size = datum(header) + 1
+
+cons_multi_continue:
+ add $closure_free,$closure_free,$5 # allocate
+ sw $at,-12($4) # Store closure header
+ sh $6,-8($4) # Store number of entries
+ sh $0,-6($4) # Tag as multi-closure
+ addi $7,$4,-4 # Pointer to closure entries
+ srl $5,$31,2 # return-address -> JAL destination
+ and $5,$5,$addr_mask # clear top bits
+ addi $31,$31,4 # bump to first descriptor
+
+store_loop:
+ lw $at,0($31) # format+gc-offset word
+ addi $6,$6,-1 # decrement count
+ addi $31,$31,8 # bump pointer to block
+ sw $at,0($7) # store into closure
+ lw $at,-4($31) # PC-relative JAL
+ addi $7,$7,12 # bump pointer to closure
+ add $at,$at,$5 # absolute JAL instruction
+ bgtz $6,store_loop
+ sw $at,-8($7) # store JAL instruction
+
+ j $31 # return
+ nop # delay slot
+
+invoke_allocate_closure:
+ # $at contains in its datum the minimum size to allocate.
+ # $7 contains the "return address" for cons_closure or cons_multi.
+ # $31 contains the return address for invoke_allocate_closure.
+ addi $sp,$sp,-80
+ # 1 is at, a temp
+ sw $2,80-4($sp)
+ sw $3,80-8($sp)
+ and $4,$at,$addr_mask # total size (- 1)
+ sw $5,80-12($sp)
+ sw $6,80-16($sp)
+ sw $7,80-20($sp) # Original value of r31
+ # sw $8,0($registers) # memtop is read-only
+ la $7,Free
+ sw $9,0($7)
+ sw $10,80-24($sp)
+ sw $11,80-28($sp)
+ sw $12,80-32($sp)
+ sw $13,80-36($sp)
+ sw $14,80-40($sp)
+ sw $15,80-44($sp)
+ # 16-23 are callee saves
+ sw $24,80-48($sp)
+ sw $25,80-52($sp)
+ # 26-29 are taken up by the OS and the C calling convention
+ sw $30,80-56($sp)
+ sw $31,80-60($sp) # return address
+ jal allocate_closure
+ sw $closure_free,36($registers) # uncache
+
+ lw $closure_free,36($registers)
+ lw $31,80-20($sp) # original value of r31
+ lw $30,80-56($sp)
+ lw $25,80-52($sp)
+ lw $24,80-48($sp)
+ lw $15,80-44($sp)
+ lw $14,80-40($sp)
+ lw $13,80-36($sp)
+ lw $12,80-32($sp)
+ lw $11,80-28($sp)
+ lw $10,80-24($sp)
+ lw $9,Free
+ lw $8,0($registers)
+ lw $7,80-60($sp) # return address for invoke...
+ lw $6,80-16($sp)
+ lw $5,80-12($sp)
+ lw $3,80-8($sp)
+ lw $2,80-4($sp)
+ lw $at,0($31) # manifest closure header
+ or $4,$closure_free,$0 # setup result
+
+ j $7
+ addi $sp,$sp,80
+
# Argument 1 (in $C_arg1) is the returned value
.globl interface_to_C
interface_to_C:
nop
ori $25,$25,0xf00 # enable V, Z, O, U traps
ctc1 $25,$31 # write FPU control register
+ nop
j $31 # return
nop
.end interface_initialize
- .globl generate_closure
- .ent generate_closure
-generate_closure:
- .frame $sp,0,$0
- # On arrival:
- # 31 is the return address
- # 1 has the size of the closure (longwords)
- # 4 has the offset from return address to destination
- # 25 has the GC offset and format words
- # Generates the closure on the heap, updating free pointer
- # sw $25,4($free) # Store GC and format words on heap
- lui $25,0x3400
- add $25,$1,$25
- sw $25,0($free) # Store manifest closure header
- add $25,$31,$4 # 25 <- destination address
- and $25,$25,$addr_mask
- srl $25,$25,2 # JAL will unshift at runtime
- lui $4,0x0C00
- or $25,$25,$4 # JAL instruction
- sw $25,8($free) # Store in closure
- lui $25,0x23FF
- ori $25,0xFFF8
- sw $25,12($free) # Store ADDI 31,31,-8
- addi $1,$1,1 # 1 longword header
- sll $1,$1,2 # longwords -> bytes
- j $31 # Done!
- add $free,$free,$1 # Increment Free pointer by size
-
- .end generate_closure
-
- .globl push_closure_entry
- .ent push_closure_entry
-push_closure_entry:
- .frame $sp,0,$0
- # On arrival:
- # 31 is the return address
- # 1 has the GC offset and format words
- # 4 has the offset from return address to destination
- # Push a closure entry on the heap, updating free pointer.
- # The header for the group of closure entries has already been
- # generated.
- # sw $1,0($free) # Store GC and format words on heap
- add $1,$31,$4 # 1 <- destination address
- and $1,$1,$addr_mask
- srl $1,$1,2 # JAL will unshift at runtime
- lui $4,0x0C00
- or $1,$1,$4 # JAL instruction
- sw $1,4($free) # Store in closure
- lui $1,0x23FF
- ori $1,0xFFF8
- sw $1,8($free) # Store ADDI 31,31,-8
- j $31 # Done!
- addi $free,$free,12 # Increment Free pointer
-
- .end push_closure_entry
-
.globl Debug_Tight_Loop
.ent Debug_Tight_Loop
Debug_Tight_Loop:
projects / mit-scheme.git / commitdiff