#| -*-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
(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
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)
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)
(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)))))
;; 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,
(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.
(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.
;; 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)))
+|#
+\f
+;; 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))))))
+\f
+;;; 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)
\f
;; COMIBTN, COMIBFN, and COMBN are pseudo-instructions that nullify
;; the following instruction when the branch is taken. Since COMIBT,
#| -*-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
;; 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
(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))))
\f
;;;; Loading of Constants
;; 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
(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.
(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))))
\f
;;;; CHAR->ASCII/BYTE-OFFSET
#| -*-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
(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
(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))))
\f
;;;; Flonum Arithmetic
(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)
projects / mit-scheme.git / commitdiff