#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/rules3.scm,v 4.24 1990/04/09 21:07:36 cph 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/spectrum/rules3.scm,v 4.25 1990/07/22 18:55:38 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
MIT in each case. |#
;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
\f
;;;; Closures. These two statements are intertwined:
-;; Magic for compiled entries.
-
-(define compiled-entry-type-im5
- (let* ((qr (integer-divide (ucode-type compiled-entry) 2))
- (immed (integer-divide-quotient qr)))
- (if (or (not (= scheme-type-width 6))
- (not (zero? (integer-divide-remainder qr)))
- (not (<= 0 immed #x1F)))
- (error "closure header rule assumptions violated!"))
- (if (<= immed #x0F)
- immed
- (- immed #x20))))
-
-(define-integrable (address->entry register)
- (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register)))
-
(define-rule statement
;; This depends on the following facts:
- ;; 1- tc_compiled_entry is a multiple of two.
+ ;; 1- TC_COMPILED_ENTRY is a multiple of two.
;; 2- all the top 6 bits in a data address are 0 except the quad bit
;; 3- type codes are 6 bits long.
- (CLOSURE-HEADER (? internal-label))
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ entry ; Used only if entries may not be word-aligned.
+ (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)))
(LAP (LABEL ,gc-label)
,@(invoke-interface code:compiler-interrupt-closure)
,@(make-external-label internal-entry-code-word external-label)
+ ;; This code must match the code and count in microcode/cmpint2.h
(DEP () 0 31 2 ,regnum:ble-return)
,@(address->entry regnum:ble-return)
(STWM () ,regnum:ble-return (OFFSET -4 0 22))
(LABEL ,internal-label)
,@(interrupt-check gc-label)))))
-(define (cons-closure target label min max size ->entry?)
- (let ((flush-reg (clear-registers! regnum:ble-return)))
- (need-register! regnum:ble-return)
- (let ((dest (standard-target! target)))
- ;; Note: dest is used as a temporary before the BLE instruction,
- ;; and is written immediately afterwards.
- (LAP ,@flush-reg
- ,@(load-non-pointer (ucode-type manifest-closure) (+ 4 size) dest)
- (STWM () ,dest (OFFSET 4 0 21))
- ,@(load-immediate
- (+ (* (make-procedure-code-word min max) #x10000) 4)
- dest)
- (STWM () ,dest (OFFSET 4 0 21))
- ,@(load-pc-relative-address
- (rtl-procedure/external-label (label->object label))
- 1)
- (BLE ()
- (OFFSET ,hook:compiler-store-closure-code
- 4
- ,regnum:scheme-to-interface-ble))
- (COPY () ,regnum:free-pointer ,dest)
- ,@(if ->entry?
- (address->entry dest)
- (LAP))
- ,@(load-offset (* 4 size)
- regnum:free-pointer
- regnum:free-pointer)))))
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? size)))
+ (cons-closure target procedure-label min max size))
(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))
+ (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+ ;; entries is a vector of all the entry points
+ (case nentries
+ ((0)
+ (let ((dest (standard-target! target)))
+ (LAP ,@(load-non-pointer (ucode-type manifest-vector)
+ (+ 4 size)
+ dest)
+ (STWM () ,dest (OFFSET 4 0 ,regnum:free-pointer))
+ ,@(load-offset -4 regnum:free-pointer dest))))
+ ((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)))))
+\f
+(define (cons-closure target entry min max size)
+ (let* ((flush-reg (require-registers! regnum:first-arg
+ #| regnum:addil-result |#
+ regnum:ble-return))
+ (target (standard-target! target)))
+ (LAP ,@flush-reg
+ ;; Vector header
+ ,@(load-non-pointer (ucode-type manifest-closure)
+ (+ size closure-entry-size)
+ regnum:first-arg)
+ (STWM () ,regnum:first-arg (OFFSET 4 0 ,regnum:free-pointer))
+ ;; Entry point is result.
+ ,@(load-offset 4 regnum:free-pointer target)
+ ,@(cons-closure-entry entry min max 8)
+ ;; Allocate space for closed-over variables
+ ,@(load-offset (* 4 size)
+ regnum:free-pointer
+ regnum:free-pointer))))
+
+(define (cons-multiclosure target nentries size entries)
+ (let* ((flush-reg (require-registers! regnum:first-arg
+ #| regnum:addil-result |#
+ regnum:ble-return))
+ (target (standard-target! target)))
+ (define (generate-entries offset entries)
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (LAP ,@(cons-closure-entry (car entry) (cadr entry) (caddr entry)
+ offset)
+ ,@(generate-entries (+ offset (* 4 closure-entry-size))
+ (cdr entries))))))
+
+ (LAP ,@flush-reg
+ ;; Vector header
+ ,@(load-non-pointer (ucode-type manifest-closure)
+ (+ 1 (* closure-entry-size nentries) size)
+ regnum:first-arg)
+ (STWM () ,regnum:first-arg (offset 4 0 ,regnum:free-pointer))
+ ;; Number of closure entries
+ ,@(load-entry-format nentries 0 target)
+ (STWM () ,target (offset 4 0 ,regnum:free-pointer))
+ ;; First entry point is result.
+ ,@(load-offset 4 21 target)
+ ,@(generate-entries 12 entries)
+ ;; Allocate space for closed-over variables
+ ,@(load-offset (* 4 size)
+ regnum:free-pointer
+ regnum:free-pointer))))
+\f
+;; Magic for compiled entries.
+
+(define compiled-entry-type-im5
+ (let* ((qr (integer-divide (ucode-type compiled-entry) 2))
+ (immed (integer-divide-quotient qr)))
+ (if (or (not (= scheme-type-width 6))
+ (not (zero? (integer-divide-remainder qr)))
+ (not (<= 0 immed #x1F)))
+ (error "HPPA RTL rules3: closure header rule assumptions violated!"))
+ (if (<= immed #x0F)
+ immed
+ (- immed #x20))))
+
+(define-integrable (address->entry register)
+ (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register)))
+
+(define (load-entry-format code-word gc-offset dest)
+ (load-immediate (+ (* code-word #x10000)
+ (quotient gc-offset 2))
+ dest))
+
+(define (cons-closure-entry entry min max offset)
+ ;; Call an out-of-line hook to do this.
+ ;; Making the instructions is a lot of work!
+ ;; Perhaps there should be a closure hook invoked and the real
+ ;; entry point could follow. It would also be easier on the GC.
+ (let ((entry-label (rtl-procedure/external-label (label->object entry))))
+ (LAP ,@(load-entry-format (make-procedure-code-word min max)
+ offset
+ regnum:first-arg)
+ (BLE ()
+ (OFFSET ,hook:compiler-store-closure-entry
+ 4
+ ,regnum:scheme-to-interface-ble))
+ (LDO ()
+ (OFFSET (- ,entry-label (+ *PC* 4))
+ 0
+ ,regnum:ble-return)
+ ,regnum:addil-result))))
\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/spectrum/rulfix.scm,v 4.34 1990/04/02 15:30:02 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/spectrum/rulfix.scm,v 4.35 1990/07/22 18:56:13 jinx Exp $
+$MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $
+$MC68020-Header: lapgen.scm,v 4.35 90/07/20 15:53:40 GMT jinx Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
MIT in each case. |#
;;;; LAP Generation Rules: Fixnum Rules
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(OBJECT->FIXNUM (CONSTANT 4))
#F))
(standard-unary-conversion source target object->index-fixnum))
+\f
+#|
+;; Superseded by code below
;; This is a patch for the time being. Probably only one of these pairs
;; of rules is needed.
(OBJECT->FIXNUM (CONSTANT 4))
#F))
(standard-unary-conversion source target fixnum->index-fixnum))
+|#
(define-integrable (fixnum->index-fixnum src tgt)
(LAP (SHD () ,src 0 30 ,tgt)))
(FIXNUM-1-ARG (? operation)
(REGISTER (? source))
(? overflow?)))
+ (QUALIFIER (fixnum-1-arg/operator? operation))
(standard-unary-conversion source target
(lambda (source target)
((fixnum-1-arg/operator operation) target source overflow?))))
-(define (fixnum-1-arg/operator operation)
+(define-integrable (fixnum-1-arg/operator operation)
(lookup-arithmetic-method operation fixnum-methods/1-arg))
+(define-integrable (fixnum-1-arg/operator? operation)
+ (arithmetic-method? operation fixnum-methods/1-arg))
+
(define fixnum-methods/1-arg
(list 'FIXNUM-METHODS/1-ARG))
-(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (if overflow?
- (LAP (ADDI (NSV) ,fixnum-1 ,src ,tgt))
- (LAP (ADDI () ,fixnum-1 ,src ,tgt)))))
-
-(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
- (lambda (tgt src overflow?)
- (if overflow?
- (LAP (ADDI (NSV) ,(- fixnum-1) ,src ,tgt))
- (LAP (ADDI () ,(- fixnum-1) ,src ,tgt)))))
-
(define-rule statement
;; execute a binary fixnum operation
(ASSIGN (REGISTER (? target))
(REGISTER (? source1))
(REGISTER (? source2))
(? overflow?)))
+ (QUALIFIER (fixnum-2-args/operator? operation))
(standard-binary-conversion source1 source2 target
(lambda (source1 source2 target)
((fixnum-2-args/operator operation) target source1 source2 overflow?))))
-(define (fixnum-2-args/operator operation)
+(define-integrable (fixnum-2-args/operator operation)
(lookup-arithmetic-method operation fixnum-methods/2-args))
+(define-integrable (fixnum-2-args/operator? operation)
+ (arithmetic-method? operation fixnum-methods/2-args))
+
(define fixnum-methods/2-args
(list 'FIXNUM-METHODS/2-ARGS))
-(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (LAP (ADD (NSV) ,src1 ,src2 ,tgt))
- (LAP (ADD () ,src1 ,src2 ,tgt)))))
-
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
- (lambda (tgt src1 src2 overflow?)
- (if overflow?
- (LAP (SUB (NSV) ,src1 ,src2 ,tgt))
- (LAP (SUB () ,src1 ,src2 ,tgt)))))
+;; Some operations are too long to do in-line.
+;; Use out-of-line utilities.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (QUALIFIER (fixnum-2-args/special-operator? operation))
+ (special-binary-operation
+ operation
+ (fixnum-2-args/special-operator operation)
+ target source1 source2 overflow?))
+
+(define-integrable (fixnum-2-args/special-operator operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args/special))
+
+(define-integrable (fixnum-2-args/special-operator? operation)
+ (arithmetic-method? operation fixnum-methods/2-args/special))
+
+(define fixnum-methods/2-args/special
+ (list 'FIXNUM-METHODS/2-ARGS/SPECIAL))
+\f
+;; Note: Bit-wise operations never overflow, therefore they always
+;; skip the branch (cond = TR). Perhaps they should error?
+
+;; Note: The commas in the macros do not follow normal QUASIQUOTE patterns.
+;; This is due to a bad interaction between QUASIQUOTE and LAP!
+
+(let-syntax
+ ((unary-fixnum
+ (macro (name instr nsv fixed-operand)
+ `(define-arithmetic-method ',name fixnum-methods/1-arg
+ (lambda (tgt src overflow?)
+ (if overflow?
+ (LAP (,instr (,nsv) ,fixed-operand ,',src ,',tgt))
+ (LAP (,instr () ,fixed-operand ,',src ,',tgt)))))))
+
+ (binary-fixnum
+ (macro (name instr nsv)
+ `(define-arithmetic-method ',name fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if overflow?
+ (LAP (,instr (,nsv) ,',src1 ,',src2 ,',tgt))
+ (LAP (,instr () ,',src1 ,',src2 ,',tgt)))))))
+
+ (binary-out-of-line
+ (macro (name . regs)
+ `(define-arithmetic-method ',name fixnum-methods/2-args/special
+ (cons ,(symbol-append 'HOOK:COMPILER- name)
+ (lambda ()
+ ,(if (null? regs)
+ `(LAP)
+ `(require-registers! ,@regs))))))))
+
+ (unary-fixnum ONE-PLUS-FIXNUM ADDI NSV ,fixnum-1)
+ (unary-fixnum MINUS-ONE-PLUS-FIXNUM ADDI NSV ,(- fixnum-1))
+ (unary-fixnum FIXNUM-NOT SUBI TR ,(- fixnum-1))
+
+ (binary-fixnum PLUS-FIXNUM ADD NSV)
+ (binary-fixnum MINUS-FIXNUM SUB NSV)
+ (binary-fixnum FIXNUM-AND AND TR)
+ (binary-fixnum FIXNUM-ANDC ANDCM TR)
+ (binary-fixnum FIXNUM-OR OR TR)
+ (binary-fixnum FIXNUM-XOR XOR TR)
+
+ (binary-out-of-line MULTIPLY-FIXNUM fp4 fp5)
+ (binary-out-of-line FIXNUM-QUOTIENT fp4 fp5)
+ (binary-out-of-line FIXNUM-REMAINDER fp4 fp5 regnum:addil-result)
+ (binary-out-of-line FIXNUM-LSH))
\f
+;;; Out of line calls.
+
+;; Arguments are passed in regnum:first-arg and regnum:second-arg.
+;; Result is returned in regnum:first-arg, and a boolean is returned
+;; in regnum:second-arg indicating wheter there was overflow.
+
+(define (special-binary-operation operation hook target source1 source2 ovflw?)
+ (define (->machine-register source machine-reg)
+ (let ((code (load-machine-register! source machine-reg)))
+ ;; Prevent it from being allocated again.
+ (need-register! machine-reg)
+ code))
+
+ (if (not (pair? hook))
+ (error "special-binary-operation: Unknown operation" operation))
+
+ (let* ((extra ((cdr hook)))
+ (load-1 (->machine-register source1 regnum:first-arg))
+ (load-2 (->machine-register source2 regnum:second-arg)))
+ ;; Make regnum:first-arg the only alias for target
+ (delete-register! target)
+ (add-pseudo-register-alias! target regnum:first-arg)
+ (LAP ,@extra
+ ,@load-1
+ ,@load-2
+ ;; Hopefully a peep-hole optimizer will switch this instruction
+ ;; and the preceding one, and remove the nop.
+ (BLE () (OFFSET ,(car hook) 4 ,regnum:scheme-to-interface-ble))
+ (NOP ())
+ ,@(if (not ovflw?)
+ (LAP)
+ (LAP (COMICLR (=) 0 ,regnum:second-arg 0))))))
+
+;;; Binary operations with one argument constant.
+
(define-rule statement
;; execute binary fixnum operation with constant second arg
(ASSIGN (REGISTER (? target))
(REGISTER (? source))
(OBJECT->FIXNUM (CONSTANT (? constant)))
(? overflow?)))
+ (QUALIFIER
+ (fixnum-2-args/operator/register*constant? operation constant overflow?))
(standard-unary-conversion source target
(lambda (source target)
((fixnum-2-args/operator/register*constant operation)
(OBJECT->FIXNUM (CONSTANT (? constant)))
(REGISTER (? source))
(? overflow?)))
+ (QUALIFIER
+ (fixnum-2-args/operator/constant*register? operation constant overflow?))
(standard-unary-conversion source target
(lambda (source target)
(if (fixnum-2-args/commutative? operation)
((fixnum-2-args/operator/constant*register operation)
target constant source overflow?)))))
\f
-(define (fixnum-2-args/commutative? operator)
- (memq operator '(PLUS-FIXNUM MULTIPLY-FIXNUM)))
+(define (define-arithconst-method name table qualifier code-gen)
+ (define-arithmetic-method name table
+ (cons code-gen qualifier)))
-(define (fixnum-2-args/operator/register*constant operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/register*constant))
+(define (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM
+ MULTIPLY-FIXNUM
+ FIXNUM-AND
+ FIXNUM-OR
+ FIXNUM-XOR)))
+
+(define-integrable (fixnum-2-args/operator/register*constant operation)
+ (car (lookup-arithmetic-method operation
+ fixnum-methods/2-args/register*constant)))
+
+(define (fixnum-2-args/operator/register*constant? operation constant ovflw?)
+ (let ((handler (arithmetic-method? operation
+ fixnum-methods/2-args/register*constant)))
+ (and handler
+ ((cddr handler) constant ovflw?))))
(define fixnum-methods/2-args/register*constant
(list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
-(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant
+(define-integrable (fixnum-2-args/operator/constant*register operation)
+ (car (lookup-arithmetic-method operation
+ fixnum-methods/2-args/constant*register)))
+
+(define (fixnum-2-args/operator/constant*register? operation constant ovflw?)
+ (let ((handler (arithmetic-method? operation
+ fixnum-methods/2-args/constant*register)))
+ (or (and handler
+ ((cddr handler) constant ovflw?))
+ (and (fixnum-2-args/commutative? operation)
+ (fixnum-2-args/operator/register*constant? operation
+ constant ovflw?)))))
+
+(define fixnum-methods/2-args/constant*register
+ (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
+
+(define (guarantee-signed-fixnum n)
+ (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
+ n)
+
+(define (signed-fixnum? n)
+ (and (exact-integer? n)
+ (>= n signed-fixnum/lower-limit)
+ (< n signed-fixnum/upper-limit)))
+\f
+(define-arithconst-method 'PLUS-FIXNUM fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (fits-in-11-bits-signed? (* constant fixnum-1)))
(lambda (tgt src constant overflow?)
(guarantee-signed-fixnum constant)
(let ((value (* constant fixnum-1)))
(ADD (NSV) ,src ,temp ,tgt)))))
(load-offset value src tgt)))))
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant
+(define-arithconst-method 'MINUS-FIXNUM fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (fits-in-11-bits-signed? (* constant fixnum-1)))
(lambda (tgt src constant overflow?)
(guarantee-signed-fixnum constant)
(let ((value (- (* constant fixnum-1))))
(SUB (NSV) ,src ,temp ,tgt)))))
(load-offset value src tgt)))))
-(define (fixnum-2-args/operator/constant*register operation)
- (lookup-arithmetic-method operation fixnum-methods/2-args/constant*register))
-
-(define fixnum-methods/2-args/constant*register
- (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
-
-(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register
+(define-arithconst-method 'MINUS-FIXNUM fixnum-methods/2-args/constant*register
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (fits-in-11-bits-signed? (* constant fixnum-1)))
(lambda (tgt constant src overflow?)
(guarantee-signed-fixnum constant)
(let ((value (* constant fixnum-1)))
,@(if overflow?
(LAP (SUB (NSV) ,temp ,src ,tgt))
(LAP (SUB () ,temp ,src ,tgt)))))))))
+\f
+(define-arithconst-method 'FIXNUM-LSH fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ constant ovflw? ; ignored
+ true)
+ (lambda (tgt src shift overflow?)
+ ;; What does overflow mean for a logical shift?
+ ;; The code commented out below corresponds to arithmetic shift
+ ;; overflow conditions.
+ (guarantee-signed-fixnum shift)
+ (cond ((zero? shift)
+ (cond ((not overflow?)
+ (copy src tgt))
+ ((= src tgt)
+ (LAP (SKIP (TR))))
+ (else
+ (LAP (COPY (TR) ,src ,tgt)))))
+ ((negative? shift)
+ ;; Right shift
+ (let ((shift (- shift)))
+ (cond ((< shift scheme-datum-width)
+ (LAP (SHD () 0 ,src ,shift ,tgt)
+ ;; clear shifted bits
+ (DEP (,(if overflow? 'TR 'NV))
+ 0 31 ,scheme-type-width ,tgt)))
+ ((not overflow?)
+ (copy 0 tgt))
+ (else
+ (LAP (COPY (TR) 0 ,tgt))))))
+ (else
+ ;; Left shift
+ (cond ((>= shift scheme-datum-width)
+ (if (not overflow?)
+ (copy 0 tgt)
+ #| (LAP (COMICLR (=) 0 ,src ,tgt)) |#
+ (LAP (COMICLR (TR) 0 ,src ,tgt))))
+ (overflow?
+ #|
+ ;; Arithmetic overflow condition accomplished
+ ;; by skipping all over the place.
+ ;; Another possibility is to use the shift-and-add
+ ;; instructions, that compute correct signed overflow
+ ;; conditions.
+ (let ((nkept (- 32 shift))
+ (temp (standard-temporary!)))
+ (LAP (ZDEP () ,src ,(- nkept 1) ,nkept ,tgt)
+ (EXTRS (=) ,src ,(- shift 1) ,shift ,temp)
+ (COMICLR (<>) -1 ,temp 0)
+ (SKIP (TR))))
+ |#
+ (LAP (ZDEP (TR) ,src ,(- nbits 1) ,nbits ,tgt)))
+ (else
+ (let ((nbits (- 32 shift)))
+ (LAP (ZDEP () ,src ,(- nbits 1) ,nbits ,tgt)))))))))
+
+(define-integrable (divisible? m n)
+ (zero? (remainder m n)))
+
+(define (integer-log-base-2? n)
+ (let loop ((power 1) (exponent 0))
+ (cond ((< n power) false)
+ ((= n power) exponent)
+ (else
+ (loop (* 2 power) (1+ exponent))))))
+\f
+(define-arithconst-method 'MULTIPLY-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ (let ((factor (abs constant)))
+ (or (integer-log-base-2? factor)
+ (and (<= factor 64)
+ (or (not ovflw?)
+ (<= factor (expt 2 scheme-type-width)))))))
-(define (guarantee-signed-fixnum n)
- (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
- n)
-
-(define (signed-fixnum? n)
- (and (exact-integer? n)
- (>= n signed-fixnum/lower-limit)
- (< n signed-fixnum/upper-limit)))
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (let ((skip (if overflow? 'NSV 'NV)))
+ (case constant
+ ((0)
+ (if overflow?
+ (LAP (COPY (TR) 0 ,tgt))
+ (LAP (COPY () 0 ,tgt))))
+ ((1)
+ (if overflow?
+ (LAP (COPY (TR) ,src ,tgt))
+ (copy src tgt)))
+ ((-1)
+ (LAP (SUB (,skip) 0 ,src ,tgt)))
+ (else
+ (let* ((factor (abs constant))
+ (src+ (if (negative? constant) tgt src))
+ (xpt (integer-log-base-2? factor)))
+ (cond ((not overflow?)
+ (LAP ,@(if (negative? constant)
+ (LAP (SUB () 0 ,src ,tgt))
+ (LAP))
+ ,@(if xpt
+ (LAP (SHD () ,src+ 0 ,(- 32 xpt) ,tgt))
+ (expand-factor tgt src+ factor false 'NV
+ (lambda ()
+ (LAP))))))
+ ((and xpt (> xpt 6))
+ (let* ((high (standard-temporary!))
+ (low (if (or (= src tgt) (negative? constant))
+ (standard-temporary!)
+ src))
+ (nbits (- 32 xpt))
+ (core
+ (LAP (SHD () ,low 0 ,nbits ,tgt)
+ (SHD (=) ,high ,low ,(-1+ nbits) ,high)
+ (COMICLR (<>) -1 ,high 0)
+ (SKIP (TR)))))
+ (if (negative? constant)
+ (LAP (EXTRS () ,src 0 1 ,high)
+ (SUB () 0 ,src ,low)
+ (SUBB () 0 ,high ,high)
+ ,@core)
+ (LAP ,@(if (not (= src low))
+ (LAP (COPY () ,src ,low))
+ (LAP))
+ (EXTRS () ,low 0 1 ,high)
+ ,@core))))
+ (else
+ (LAP ,@(if (negative? constant)
+ (LAP (SUB (SV) 0 ,src ,tgt))
+ (LAP))
+ ,@(expand-factor tgt src+ factor (negative? constant)
+ 'NSV
+ (lambda ()
+ (LAP (SKIP (TR))))))))))))))
+\f
+(define (expand-factor tgt src factor skipping? condition skip)
+ (define (sh3add condition src1 src2 tgt)
+ (LAP (SH3ADD (,condition) ,src1 ,src2 ,tgt)))
+
+ (define (sh2add condition src1 src2 tgt)
+ (LAP (SH2ADD (,condition) ,src1 ,src2 ,tgt)))
+
+ (define (sh1add condition src1 src2 tgt)
+ (LAP (SH1ADD (,condition) ,src1 ,src2 ,tgt)))
+
+ (define (handle factor fixed)
+ (define (wrap instr next value)
+ (let ((code? (car next))
+ (result-reg (cadr next))
+ (temp-reg (caddr next))
+ (code (cadddr next)))
+ (list true
+ tgt
+ temp-reg
+ (LAP ,@code
+ ,@(if code?
+ (skip)
+ (LAP))
+ ,@(instr condition result-reg value tgt)))))
+
+ (cond ((zero? factor) (list false 0 fixed (LAP)))
+ ((= factor 1) (list false fixed fixed (LAP)))
+ ((divisible? factor 8)
+ (wrap sh3add (handle (/ factor 8) fixed) 0))
+ ((divisible? factor 4)
+ (wrap sh2add (handle (/ factor 4) fixed) 0))
+ ((divisible? factor 2)
+ (wrap sh1add (handle (/ factor 2) fixed) 0))
+ (else
+ (let* ((f1 (-1+ factor))
+ (fixed (if (or (not (= fixed src))
+ (not (= src tgt))
+ (and (integer-log-base-2? f1)
+ (< f1 16)))
+ fixed
+ (standard-temporary!))))
+ (cond ((divisible? f1 8)
+ (wrap sh3add (handle (/ f1 8) fixed) fixed))
+ ((divisible? f1 4)
+ (wrap sh2add (handle (/ f1 4) fixed) fixed))
+ (else
+ (wrap sh1add (handle (/ f1 2) fixed) fixed)))))))
+
+ (let ((result (handle factor src)))
+ (let ((result-reg (cadr result))
+ (temp-reg (caddr result))
+ (code (cadddr result)))
+
+ (LAP ,@(cond ((= temp-reg src)
+ (LAP))
+ ((not skipping?)
+ (LAP (COPY () ,src ,temp-reg)))
+ (else
+ (LAP (COPY (TR) ,src ,temp-reg)
+ ,@(skip))))
+ ,@code
+ ,@(cond ((= result-reg tgt)
+ (LAP))
+ ((eq? concition 'NV)
+ (LAP (COPY () ,result-reg ,tgt)))
+ (else
+ (LAP (COPY (TR) ,result-reg ,tgt)
+ ,@(skip))))))))
+\f
+;;;; Division
+
+(define-arithconst-method 'FIXNUM-QUOTIENT
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ (let ((factor (abs constant)))
+ (and (or (not ovflw?) (= factor 1))
+ (fits-in-11-bits-signed? (* (- factor 1) fixnum-1))
+ (integer-log-base-2? factor))))
+ (lambda (tgt src constant ovflw?)
+ (guarantee-signed-fixnum constant)
+ (case constant
+ ((1)
+ (if ovflw?
+ (LAP (COPY (TR) ,src ,tgt))
+ (copy src tgt)))
+ ((-1)
+ (let ((skip (if ovflw? 'NSV 'NV)))
+ (LAP (SUB (,skip) 0 ,src ,tgt))))
+ (else
+ (let* ((factor (abs constant))
+ (xpt (integer-log-base-2? factor))
+ (sign (standard-temporary!)))
+ (if (or (not xpt) ovflw?)
+ (error "fixnum-quotient: Inconsistency" constant ovflw?))
+ (LAP ,@(if (negative? constant)
+ (LAP (SUB (>=) 0 ,src ,tgt))
+ (LAP (ADD (>=) 0 ,src ,tgt)))
+ (ADDI () ,(* (-1+ factor) fixnum-1) ,tgt ,tgt)
+ (EXTRS () ,tgt 0 1 ,sign)
+ (SHD () ,sign ,tgt ,xpt ,tgt)
+ (DEP () 0 31 ,scheme-type-width ,tgt)))))))
+
+(define-arithconst-method 'FIXNUM-REMAINDER
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ (and (not ovflw?)
+ (integer-log-base-2? (abs constant))))
+ (lambda (tgt src constant ovflw?)
+ (guarantee-signed-fixnum constant)
+ (case constant
+ ((1 -1)
+ (LAP (COPY () 0 ,tgt)))
+ (else
+ (let ((sign (standard-temporary!))
+ (len (let ((xpt (integer-log-base-2? (abs constant))))
+ (and xpt (+ xpt scheme-type-width)))))
+ (let ((sgn-len (- 32 len)))
+ (if (or ovflw? (not len))
+ (error "fixnum-remainder: Inconsistency" constant ovflw?))
+ (LAP (EXTRS () ,src 0 1 ,sign)
+ (EXTRU (=) ,src 31 ,len ,tgt)
+ (DEP () ,sign ,(- sgn-len 1) ,sgn-len ,tgt))))))))
\f
;;;; Predicates
-;;; This is a kludge. It assumes that the last instruction of the
-;;; arithmetic operation that may cause an overflow condition will
-;;; skip the following instruction if there was no overflow. Ie., the
-;;; last instruction will conditionally nullify using NSV. The code
-;;; for the alternative is a real kludge because we can't force the
-;;; arithmetic instruction that precedes this code to use the inverted
-;;; condition. Hopefully the peephole optimizer will fix this if it
-;;; is ever generated. The linearizer attempts not to use this
-;;; branch.
+;; This is a kludge. It assumes that the last instruction of the
+;; arithmetic operation that may cause an overflow condition will skip
+;; the following instruction if there was no overflow, ie., the last
+;; instruction will nullify using NSV (or TR if overflow is
+;; impossible). The code for the alternative is a real kludge because
+;; we can't force the arithmetic instruction that precedes this code
+;; to use the inverted condition. Hopefully a peep-hole optimizer
+;; will fix this. The linearizer attempts to use the "good" branch.
(define-rule predicate
(OVERFLOW-TEST)
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
- (compare (fixnum-pred-1->cc predicate)
+ (compare (fixnum-pred->cc predicate)
(standard-source! source)
0))
-(define (fixnum-pred-1->cc predicate)
- (case predicate
- ((ZERO-FIXNUM?) '=)
- ((NEGATIVE-FIXNUM?) '<)
- ((POSITIVE-FIXNUM?) '>)
- (else (error "unknown fixnum predicate" predicate))))
-\f
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(REGISTER (? source1))
(REGISTER (? source))
(OBJECT->FIXNUM (CONSTANT (? constant))))
(compare-fixnum/constant*register (invert-condition-noncommutative
- (fixnum-pred-2->cc predicate))
+ (fixnum-pred->cc predicate))
constant
(standard-source! source)))
(FIXNUM-PRED-2-ARGS (? predicate)
(OBJECT->FIXNUM (CONSTANT (? constant)))
(REGISTER (? source)))
- (compare-fixnum/constant*register (fixnum-pred-2->cc predicate)
+ (compare-fixnum/constant*register (fixnum-pred->cc predicate)
constant
(standard-source! source)))
(guarantee-signed-fixnum n)
(compare-immediate cc (* n fixnum-1) r))
-(define (fixnum-pred-2->cc predicate)
+(define (fixnum-pred->cc predicate)
(case predicate
- ((EQUAL-FIXNUM?) '=)
- ((LESS-THAN-FIXNUM?) '<)
- ((GREATER-THAN-FIXNUM?) '>)
- (else (error "unknown fixnum predicate" predicate))))
\ No newline at end of file
+ ((ZERO-FIXNUM? EQUAL-FIXNUM?) '=)
+ ((NEGATIVE-FIXNUM? LESS-THAN-FIXNUM?) '<)
+ ((POSITIVE-FIXNUM? GREATER-THAN-FIXNUM?) '>)
+ (else
+ (error "fixnum-pred->cc: unknown predicate" predicate))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff