From cc2c72cd774aa1be3bf8ebe4fe25dd82ecc6e4ab Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Thu, 20 Aug 1992 01:28:14 +0000 Subject: [PATCH] New MIPS closure code. Works on newer R3000 systems (with larger cache-line sizes) and on R4000 systems in 32-bit mode. --- v7/src/compiler/machines/mips/instr1.scm | 12 +- v7/src/compiler/machines/mips/lapgen.scm | 41 ++- v7/src/compiler/machines/mips/machin.scm | 15 +- v7/src/compiler/machines/mips/rules3.scm | 191 +++++++------- v7/src/compiler/machines/mips/rulfix.scm | 78 +++--- v7/src/microcode/cmpauxmd/mips.m4 | 305 ++++++++++++++++------- 6 files changed, 404 insertions(+), 238 deletions(-) diff --git a/v7/src/compiler/machines/mips/instr1.scm b/v7/src/compiler/machines/mips/instr1.scm index 8b272b8ad..1478a444c 100644 --- a/v7/src/compiler/machines/mips/instr1.scm +++ b/v7/src/compiler/machines/mips/instr1.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -358,4 +358,10 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/mips/lapgen.scm b/v7/src/compiler/machines/mips/lapgen.scm index a55a7da56..bc04d4051 100644 --- a/v7/src/compiler/machines/mips/lapgen.scm +++ b/v7/src/compiler/machines/mips/lapgen.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; RTL Rules for MIPS. Shared utilities. +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -80,15 +81,15 @@ MIT in each case. |# (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 @@ -558,6 +559,9 @@ MIT in each case. |# (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))) @@ -636,4 +640,23 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/mips/machin.scm b/v7/src/compiler/machines/mips/machin.scm index fb9ad2edf..9e4a18e41 100644 --- a/v7/src/compiler/machines/mips/machin.scm +++ b/v7/src/compiler/machines/mips/machin.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -32,7 +32,8 @@ Technology nor of any adaptation thereof in any advertising, 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)) @@ -72,8 +73,8 @@ MIT in each case. |# (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) @@ -195,9 +196,11 @@ MIT in each case. |# (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. @@ -221,6 +224,8 @@ MIT in each case. |# (,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) diff --git a/v7/src/compiler/machines/mips/rules3.scm b/v7/src/compiler/machines/mips/rules3.scm index 366d8c085..35e069217 100644 --- a/v7/src/compiler/machines/mips/rules3.scm +++ b/v7/src/compiler/machines/mips/rules3.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; LAP Generation Rules: Invocations and Entries +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -517,42 +518,60 @@ MIT in each case. |# (+ (* 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)) (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) @@ -561,67 +580,65 @@ MIT in each case. |# (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))))))))) ;;;; Entry Header ;;; This is invoked by the top level of the LAP generator. diff --git a/v7/src/compiler/machines/mips/rulfix.scm b/v7/src/compiler/machines/mips/rulfix.scm index 284fa82ab..3f63a8494 100644 --- a/v7/src/compiler/machines/mips/rulfix.scm +++ b/v7/src/compiler/machines/mips/rulfix.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -33,6 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; LAP Generation Rules: Fixnum Rules +;;; package: (compiler lap-syntaxer) (declare (usual-integrations)) @@ -293,17 +294,18 @@ MIT in each case. |# (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)) (define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args @@ -344,19 +346,20 @@ MIT in each case. |# (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))) @@ -448,17 +451,18 @@ MIT in each case. |# (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) diff --git a/v7/src/microcode/cmpauxmd/mips.m4 b/v7/src/microcode/cmpauxmd/mips.m4 index 5706408ec..148da0033 100644 --- a/v7/src/microcode/cmpauxmd/mips.m4 +++ b/v7/src/microcode/cmpauxmd/mips.m4 @@ -1,9 +1,8 @@ -/* #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 @@ -53,10 +52,11 @@ #### 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 @@ -94,27 +94,33 @@ #### 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. #### - #### - 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. #### + #### - 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 @@ -123,7 +129,7 @@ #### Notice that register gr25 is used for the index used to #### dispatch into the trampolines and interface routines. - .verstamp 1 31 + # .verstamp 1 31 .text .align 2 .set noat @@ -140,9 +146,11 @@ define(free, 9) 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) @@ -185,6 +193,8 @@ C_to_interface: 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 @@ -216,37 +226,39 @@ hook_jump_table: # $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 @@ -258,6 +270,7 @@ trampoline_to_interface: # ...scheme_to_interface-96 .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 @@ -303,6 +316,159 @@ after_overflow: 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: @@ -346,66 +512,11 @@ interface_initialize: 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: -- 2.25.1