From ea3a3ba6dfdc28a1b8e7889d76ff48471ca8a27c Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Sun, 28 Feb 1993 06:18:24 +0000 Subject: [PATCH] Add generate/remote-links, PC caching, and cache hints for consing. --- v7/src/compiler/machines/spectrum/lapgen.scm | 103 ++++++++++++++++++- v7/src/compiler/machines/spectrum/rules1.scm | 63 ++++++++---- v7/src/compiler/machines/spectrum/rulflo.scm | 38 ++++--- 3 files changed, 164 insertions(+), 40 deletions(-) diff --git a/v7/src/compiler/machines/spectrum/lapgen.scm b/v7/src/compiler/machines/spectrum/lapgen.scm index d42401f84..898f9a198 100644 --- a/v7/src/compiler/machines/spectrum/lapgen.scm +++ b/v7/src/compiler/machines/spectrum/lapgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: lapgen.scm,v 4.42 1993/02/18 06:02:44 gjr Exp $ +$Id: lapgen.scm,v 4.43 1993/02/28 06:16:36 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -80,6 +80,12 @@ MIT in each case. |# (define-integrable (sort-machine-registers registers) registers) +;; *** +;; Note: fp16-fp31 only exist on PA-RISC 1.1 or later. +;; If compiling for PA-RISC 1.0, truncate this +;; list after fp15. +;; *** + (define available-machine-registers ;; g1 removed from this list since it is the target of ADDIL, ;; needed to expand some rules. g31 may want to be removed @@ -95,6 +101,9 @@ MIT in each case. |# g31 ;; fp0 fp1 fp2 fp3 fp4 fp5 fp6 fp7 fp8 fp9 fp10 fp11 fp12 fp13 fp14 fp15 + ;; The following are only available on newer processors + fp16 fp17 fp18 fp19 fp20 fp21 fp22 fp23 + fp24 fp25 fp26 fp27 fp28 fp29 fp30 fp31 )) (define-integrable (float-register? register) @@ -117,6 +126,8 @@ MIT in each case. |# GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT + FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT) register)) ((register-value-class=word? register) 'GENERAL) @@ -131,7 +142,7 @@ MIT in each case. |# (vector-set! references register (INST-EA (GR ,register))) (loop (1+ register))))) (let loop ((register 32) (fpr 0)) - (if (< register 48) + (if (< register 64) (begin (vector-set! references register (INST-EA (FPR ,fpr))) (loop (1+ register) (1+ fpr))))) @@ -156,7 +167,7 @@ MIT in each case. |# ;; Load a Scheme constant into a machine register. (if (non-pointer-object? constant) (load-immediate (non-pointer->literal constant) target) - (load-pc-relative (constant->label constant) target))) + (load-pc-relative (constant->label constant) target 'CONSTANT))) (define (load-non-pointer type datum target) ;; Load a Scheme non-pointer constant, defined by type and datum, @@ -261,7 +272,9 @@ MIT in each case. |# (LAP ,@(load-offset d b regnum:addil-result) (FSTDS () ,r (OFFSET 0 0 ,regnum:addil-result)))))) -(define (load-pc-relative label target) +#| +(define (load-pc-relative label target type) + type ; ignored ;; Load a pc-relative location's contents into a machine register. ;; This assumes that the offset fits in 14 bits! ;; We should have a pseudo-op for LDW that does some "branch" tensioning. @@ -270,7 +283,8 @@ MIT in each case. |# (DEP () 0 31 2 ,regnum:addil-result) (LDW () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target))) -(define (load-pc-relative-address label target) +(define (load-pc-relative-address label target type) + type ; ignored ;; Load a pc-relative address into a machine register. ;; This assumes that the offset fits in 14 bits! ;; We should have a pseudo-op for LDO that does some "branch" tensioning. @@ -278,6 +292,85 @@ MIT in each case. |# ;; Clear the privilege level, making this a memory address. (DEP () 0 31 2 ,regnum:addil-result) (LDO () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target))) +|# + +;; These versions of load-pc-... remember what they obtain, to avoid +;; doing the sequence multiple times. +;; In addition, they assume that the code is running in the least +;; privilege, and avoid the DEP in the sequences above. + +(define-integrable *privilege-level* 3) + +(define-integrable (close? label label*) + ;; Heuristic + label label* ; ignored + compiler:compile-by-procedures?) + +(define (load-pc-relative label target type) + (load-pc-relative-internal label target type + (lambda (offset base target) + (LAP (LDW () (OFFSET ,offset 0 ,base) + ,target))))) + +(define (load-pc-relative-address label target type) + (load-pc-relative-internal label target type + (lambda (offset base target) + (LAP (LDO () (OFFSET ,offset 0 ,base) + ,target))))) + +(define (load-pc-relative-internal label target type gen) + (with-values (lambda () (get-typed-label type)) + (lambda (label* alias type*) + (define (closer label* alias) + (let ((temp (standard-temporary!))) + (set-typed-label! type label temp) + (LAP (LDO () (OFFSET (- ,label ,label*) 0 ,alias) ,temp) + ,@(gen 0 temp target)))) + + (cond ((not label*) + (let ((temp (standard-temporary!)) + (here (generate-label))) + (let ((value `(+ ,here ,(+ 8 *privilege-level*)))) + (set-typed-label! 'CODE value temp) + (LAP (LABEL ,here) + (BL () ,temp (@PCO 0)) + ,@(if (or (eq? type 'CODE) (close? label label*)) + (gen (INST-EA (- ,label ,value)) temp target) + (closer value temp)))))) + ((or (eq? type* type) (close? label label*)) + (gen (INST-EA (- ,label ,label*)) alias target)) + (else + (closer label* alias)))))) + +;;; Typed labels provide further optimization. There are two types, +;;; CODE and CONSTANT, that say whether the label is located in the +;;; code block or the constants block of the output. Statistically, +;;; a label is likely to be closer to another label of the same type +;;; than to a label of the other type. + +(define (get-typed-label type) + (let ((entries (register-map-labels *register-map* 'GENERAL))) + (let loop ((entries* entries)) + (cond ((null? entries*) + ;; If no entries of the given type, use any entry that is + ;; available. + (let loop ((entries entries)) + (cond ((null? entries) + (values false false false)) + ((pair? (caar entries)) + (values (cdaar entries) (cadar entries) (caaar entries))) + (else + (loop (cdr entries)))))) + ((and (pair? (caar entries*)) + (eq? type (caaar entries*))) + (values (cdaar entries*) (cadar entries*) type)) + (else + (loop (cdr entries*))))))) + +(define (set-typed-label! type label alias) + (set! *register-map* + (set-machine-register-label *register-map* alias (cons type label))) + unspecific) ;; COMIBTN, COMIBFN, and COMBN are pseudo-instructions that nullify ;; the following instruction when the branch is taken. Since COMIBT, diff --git a/v7/src/compiler/machines/spectrum/rules1.scm b/v7/src/compiler/machines/spectrum/rules1.scm index 4a5e887af..b1f3afdaa 100644 --- a/v7/src/compiler/machines/spectrum/rules1.scm +++ b/v7/src/compiler/machines/spectrum/rules1.scm @@ -1,9 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules1.scm,v 4.33 1990/07/22 18:55:17 jinx Rel $ -$MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $ +$Id: rules1.scm,v 4.34 1993/02/28 06:18:12 gjr Exp $ -Copyright (c) 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1989-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -64,8 +63,14 @@ MIT in each case. |# ;; tag the contents of a register (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source)))) - ;; *** Why doesn't it work when qualifier is used? *** ;; (QUALIFIER (fits-in-5-bits-signed? type)) + ;; This qualifier does not work because the qualifiers are not + ;; tested in the rtl compressor. The qualifier is combined with + ;; the rule body into a single procedure, and the rtl compressor + ;; cannot invoke it since it is not in the context of the lap + ;; generator. Thus the qualifier is not checked, the RTL instruction + ;; is compressed, and then the lap generator fails when the qualifier + ;; fails. (deposit-type type (standard-move-to-target! source target))) (define-rule statement @@ -108,8 +113,10 @@ MIT in each case. |# (define-rule statement ;; pop an object off the stack - (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 22) 1)) - (LAP (LDWM () (OFFSET 4 0 22) ,(standard-target! target)))) + (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? reg)) 1)) + (QUALIFIER (= reg regnum:stack-pointer)) + (LAP + (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,(standard-target! target)))) ;;;; Loading of Constants @@ -147,29 +154,31 @@ MIT in each case. |# ;; load the address of a variable reference cache (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) (load-pc-relative (free-reference-label name) - (standard-target! target))) + (standard-target! target) + 'CONSTANT)) (define-rule statement ;; load the address of an assignment cache (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) (load-pc-relative (free-assignment-label name) - (standard-target! target))) + (standard-target! target) + 'CONSTANT)) (define-rule statement ;; load the address of a procedure's entry point (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) - (load-pc-relative-address label (standard-target! target))) + (load-pc-relative-address label (standard-target! target) 'CODE)) (define-rule statement ;; load the address of a continuation (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) - (load-pc-relative-address label (standard-target! target))) + (load-pc-relative-address label (standard-target! target) 'CODE)) ;;; Spectrum optimizations (define (load-entry label target) (let ((target (standard-target! target))) - (LAP ,@(load-pc-relative-address label target) + (LAP ,@(load-pc-relative-address label target 'CODE) ,@(address->entry target)))) (define-rule statement @@ -201,15 +210,25 @@ MIT in each case. |# (define-rule statement ;; Push an object register on the heap - (ASSIGN (POST-INCREMENT (REGISTER 21) 1) (? source register-expression)) - (QUALIFIER (word-register? source)) - (LAP (STWM () ,(standard-source! source) (OFFSET 4 0 21)))) + ;; *** IMPORTANT: This uses a STWS instruction with the cache hint set. + ;; The cache hint prevents newer HP PA processors from loading a cache + ;; line from memory when it is about to be overwritten. + ;; In theory this could cause a problem at the very end (64 bytes) of the + ;; heap, since the last cache line may overlap the next area (the stack). + ;; *** + (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (? source register-expression)) + (QUALIFIER (and (= reg regnum:free-pointer) + (word-register? source))) + (LAP + (STWS (MA C) ,(standard-source! source) (OFFSET 4 0 ,regnum:free-pointer)))) (define-rule statement ;; Push an object register on the stack - (ASSIGN (PRE-INCREMENT (REGISTER 22) -1) (? source register-expression)) - (QUALIFIER (word-register? source)) - (LAP (STWM () ,(standard-source! source) (OFFSET -4 0 22)))) + (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (? source register-expression)) + (QUALIFIER (and (word-register? source) + (= reg regnum:stack-pointer))) + (LAP + (STWM () ,(standard-source! source) (OFFSET -4 0 ,regnum:stack-pointer)))) ;; Cheaper, common patterns. @@ -220,12 +239,14 @@ MIT in each case. |# (standard-source! address))) (define-rule statement - (ASSIGN (POST-INCREMENT (REGISTER 21) 1) (MACHINE-CONSTANT 0)) - (LAP (STWM () 0 (OFFSET 4 0 21)))) + (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (MACHINE-CONSTANT 0)) + (QUALIFIER (= reg regnum:free-pointer)) + (LAP (STWS (MA C) 0 (OFFSET 4 0 ,regnum:free-pointer)))) (define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 22) -1) (MACHINE-CONSTANT 0)) - (LAP (STWM () 0 (OFFSET -4 0 22)))) + (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (MACHINE-CONSTANT 0)) + (QUALIFIER (= reg regnum:stack-pointer)) + (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer)))) ;;;; CHAR->ASCII/BYTE-OFFSET diff --git a/v7/src/compiler/machines/spectrum/rulflo.scm b/v7/src/compiler/machines/spectrum/rulflo.scm index 997460c2a..956196f0a 100644 --- a/v7/src/compiler/machines/spectrum/rulflo.scm +++ b/v7/src/compiler/machines/spectrum/rulflo.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rulflo.scm,v 4.35 1993/02/12 01:57:47 gjr Exp $ +$Id: rulflo.scm,v 4.36 1993/02/28 06:18:24 gjr Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -54,13 +54,15 @@ MIT in each case. |# (let ((source (flonum-source! source)) (temp (standard-temporary!))) (let ((target (standard-target! target))) - (LAP ; (STW () 0 (OFFSET 0 0 21)) ; make heap parsable forwards - (DEPI () #b100 31 3 21) ; quad align - (COPY () 21 ,target) - ,@(deposit-type (ucode-type flonum) target) - ,@(load-non-pointer (ucode-type manifest-nm-vector) 2 temp) - (STWM () ,temp (OFFSET 4 0 21)) - (FSTDS (MA) ,source (OFFSET 8 0 21)))))) + (LAP + ;; make heap parsable forwards + ;; (STW () 0 (OFFSET 0 0 ,regnum:free-pointer)) + (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align + (COPY () ,regnum:free-pointer ,target) + ,@(deposit-type (ucode-type flonum) target) + ,@(load-non-pointer (ucode-type manifest-nm-vector) 2 temp) + (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer)) + (FSTDS (MA) ,source (OFFSET 8 0 ,regnum:free-pointer)))))) (define-rule statement ;; convert a flonum object to a floating-point number @@ -68,6 +70,10 @@ MIT in each case. |# (let ((source (standard-move-to-temporary! source))) (LAP ,@(object->address source) (FLDDS () (OFFSET 4 0 ,source) ,(flonum-target! target))))) + +(define-rule statement + (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT 0.))) + (LAP (FCPY (DBL) 0 ,(flonum-target! target)))) ;;;; Flonum Arithmetic @@ -99,15 +105,19 @@ MIT in each case. |# (define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg (lambda (target source) - #| - ;; No zero on the floating-point co-processor. Need to create one. - (let ((temp (if (= target source) (flonum-temporary!) target))) - (LAP (FSUB (DBL) ,temp ,temp ,temp) - (FSUB (DBL) ,temp ,source ,target))) - |# ;; The status register (fr0) reads as 0 for non-store instructions. (LAP (FSUB (DBL) 0 ,source ,target)))) +(define-rule statement + (ASSIGN (REGISTER (? target)) + (FLONUM-2-ARGS FLONUM-SUBTRACT + (OBJECT->FLOAT (CONSTANT 0.)) + (REGISTER (? source)) + (? overflow))) + overflow? ; ignore + (let ((source (flonum-source! source))) + (LAP (FSUB (DBL) 0 ,source ,(flonum-target! target))))) + (define-rule statement (ASSIGN (REGISTER (? target)) (FLONUM-2-ARGS (? operation) -- 2.25.1