#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.9 1988/11/07 13:57:02 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.10 1989/07/25 12:42:02 arthur Exp $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(register->register-transfer register temp))
temp))
(load-alias-register! register type))))
+
+(define (float-register-reference register)
+ (register-reference
+ (if (machine-register? register)
+ register
+ (load-alias-register! register 'FLOAT))))
+
(define (load-machine-register! source-register machine-register)
(if (machine-register? source-register)
(if (eqv? source-register machine-register)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.7 1988/11/07 14:33:30 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.8 1989/07/25 12:41:41 arthur Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define (register-type? register type)
;; This predicate is true iff `register' has the given `type'.
- ;; `register' must be a machine register.
- (or (not type)
+ ;; `register' must be a machine register. If `type' is #f, this predicate
+ ;; returns #f iff `register' is not a word register.
+ (or (and (not type) (word-register? register))
(eq? (register-type register) type)))
(define ((register-type-predicate type) register)
(let ((alias (map-entry:find-alias entry type needed-registers)))
(and alias
(or
- ;; If we are reallocating a register of a specific
- ;; type, first see if there is an available register
- ;; of some other type that we can stash the value in.
+ ;; If we are reallocating a register of a specific type, first
+ ;; see if there is an available register of some other
+ ;; assignment-compatible type that we can stash the value in.
(and type
(let ((values
(find-free-register
map
- false (cons alias needed-registers))))
+ (if (register-types-compatible? type false)
+ false
+ type)
+ (cons alias needed-registers))))
(and
values
(bind-allocator-values values
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.12 1988/12/30 07:05:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.13 1989/07/25 12:40:44 arthur Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(variable-cache-name
(system-vector-ref new-block 3))
arity))
- ((#xfc) ; interpreted
+ ((#xfc ; interpreted
+ #x114 ; fixed arity primitive
+ #x11a) ; lexpr primitive
(vector 'INTERPRETED
(system-vector-ref new-block 3)
arity))
(8 . (REGISTER VALUE))
(12 . (REGISTER ENVIRONMENT))
(16 . (REGISTER TEMPORARY))
- ;; Compiler temporaries
+ ;; Old compiled code temporaries
+ ;; Retained for compatibility with old compiled code and should
+ ;; eventually be flushed.
,@(let loop ((index 40) (i 0))
(if (= i 50)
'()
- (cons `(,index . (TEMPORARY ,i))
+ (cons `(,index . (OLD TEMPORARY ,i))
(loop (+ index 4) (1+ i)))))
;; Interpreter entry points
,@(make-entries
lookup safe-lookup set! access unassigned? unbound? define
reference-trap safe-reference-trap assignment-trap
unassigned?-trap
- &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))))))
+ &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))
+ ;; Compiled code temporaries
+ ,@(let loop ((index 720) (i 0))
+ (if (= i 300)
+ '()
+ (cons `(,index . (TEMPORARY ,i))
+ (loop (+ index 12) (1+ i))))))))
+)
\f
(define (make-pc-relative thunk)
(let ((reference-offset *current-offset))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm3.scm,v 4.6 1988/08/29 22:40:41 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm3.scm,v 4.7 1989/07/25 12:40:35 arthur Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(if (= (extract *ir 3 6) #b001)
%CMPM
%EOR))))
-\f
(lambda ()
(let ((size (extract *ir 6 8)))
(cond ((= size #b00)
%ADDX
%ADD)))
(lambda () shift/rotate/bitop)
- undefined))
+ (lambda () coprocessor)))
\f
;;;; Operations
`(& ,(extract extension 0 5))
(make-data-register 'D (extract extension 0 3)))))
`(,opcode ,source ,offset ,width ,@target))))
+\f
+;;;
+;;; COPROCESSOR
+;;;
+(define (coprocessor)
+ (if (= (coprocessor-id) floating-point-coprocessor-id)
+ (floating-point-coprocessor)
+ (undefined-instruction)))
+
+;;;
+;;; FLOATING POINT INSTRUCTIONS
+;;;
+
+(define floating-point-coprocessor-id #b001)
+
+(define (coprocessor-id)
+ (extract *ir 9 12))
+
+(define (floating-point-coprocessor)
+ (let* ((op-class-indicator (extract *ir 6 9))
+ (opcode (extract (peek-word) 0 7)))
+ (cond ((and (= op-class-indicator #b000)
+ (= opcode #b0000000))
+ (let ((ext (get-word)))
+ (let ((keyword (get-fmove-keyword *ir ext)))
+ (if (null? keyword)
+ (undefined-instruction)
+ (case keyword
+ (FMOVE-TO-FP
+ (decode-ordinary-floating-instruction 'FMOVE ext))
+ (FMOVE-FROM-FP
+ (let ((dst-fmt (floating-specifier->mnemonic
+ (extract ext 10 13)))
+ (src-reg (extract ext 7 10)))
+ (if (eq? dst-fmt 'P)
+ '(FMOVE packed decimal)
+ `(FMOVE ,dst-fmt (FP ,src-reg) ,(decode-ea-d 'L)))))
+ (FMOVE-FPcr
+ (let ((reg
+ (cdr (assoc (extract ext 10 13)
+ '((#b001 . FPIAR)
+ (#b010 . FPSR)
+ (#b100 . FPCR))))))
+ (if (= (extract ext 13 14) 1)
+ `(FMOVE ,reg ,(decode-ea-d 'L))
+ `(FMOVE ,(decode-ea-d 'L) ,reg))))
+ (FMOVECR
+ `(FMOVECR X (& ,(extract ext 0 7))
+ (FP ,(extract ext 7 10))))
+ (FMOVEM-FPn
+ '(FMOVEM to FP-s))
+ (FMOVEM-FPcr
+ '(FMOVEM to CR-s)))))))
+ ((= op-class-indicator #b000)
+ (let ((ext (get-word))
+ (opcode-name (floating-opcode->mnemonic opcode)))
+ (decode-ordinary-floating-instruction opcode-name ext)))
+ ((= (extract *ir 7 9) #b01)
+ (let ((float-cc (decode-float-cc (extract *ir 0 6)))
+ (size (extract *ir 6 7)))
+ ((access append ())
+ `(FB ,float-cc)
+ (if (= size 0)
+ `(W ,(make-pc-relative (lambda () (fetch-immediate 'W))))
+ `(L ,(make-pc-relative (lambda () (fetch-immediate 'L))))))))
+ (else
+ (undefined-instruction)))))
+\f
+(define (decode-ordinary-floating-instruction opcode-name ext)
+ (let ((src-spec (extract ext 10 13))
+ (rm (extract ext 14 15))
+ (dst-reg (extract ext 7 10)))
+ (if (= rm 1)
+ `(,opcode-name
+ ,(floating-specifier->mnemonic src-spec)
+ ,(decode-ea-d 'L)
+ (FP ,dst-reg))
+ (if (= src-spec dst-reg)
+ `(,opcode-name (FP ,dst-reg))
+ `(,opcode-name (FP ,src-spec) (FP ,dst-reg))))))
+
+(define (floating-opcode->mnemonic n)
+ (let ((entry (assoc n
+ '((#b0011000 . FABS)
+ (#b0011100 . FACOS)
+ (#b0100010 . FADD)
+ (#b0001100 . FASIN)
+ (#b0001010 . FATAN)
+ (#b0001101 . FATANH)
+ (#b0111000 . FCMP)
+ (#b0011101 . FCOS)
+ (#b0011001 . FCOSH)
+ (#b0100000 . FDIV)
+ (#b0010000 . FETOX)
+ (#b0001000 . FETOXM1)
+ (#b0011110 . FGETEXP)
+ (#b0011111 . FGETMAN)
+ (#b0000001 . FINT)
+ (#b0000011 . FINTRZ)
+ (#b0010101 . FLOG10)
+ (#b0010110 . FLOG2)
+ (#b0010100 . FLOGN)
+ (#b0000110 . FLOGNP1)
+ (#b0100001 . FMOD)
+ (#b0100011 . FMUL)
+ (#b0011010 . FNEG)
+ (#b0100101 . FREM)
+ (#b0100110 . FSCALE)
+ (#b0100100 . FSGLDIV)
+ (#b0100111 . FSGLMUL)
+ (#b0001110 . FSIN)
+ (#b0000010 . FSINH)
+ (#b0000100 . FSQRT)
+ (#b0101000 . FSUB)
+ (#b0001111 . FTAN)
+ (#b0001001 . FTANH)
+ (#b0010010 . FTENTOX)
+ (#b0111010 . FTST)
+ (#b0010001 . FTWOTOX)))))
+ (and entry
+ (cdr entry))))
+
+(define (floating-specifier->mnemonic n)
+ (let ((entry (assoc n
+ '((0 . L)
+ (1 . S)
+ (2 . X)
+ (3 . P)
+ (4 . W)
+ (5 . D)
+ (6 . B)))))
+ (and entry
+ (cdr entry))))
+
+(define (decode-float-cc bits)
+ (cdr (or (assv bits
+ '((1 . EQ) (14 . NE)
+ (2 . GT) (13 . NGT)
+ (3 . GE) (12 . NGE)
+ (4 . LT) (11 . NLT)
+ (5 . LE) (10 . NLE)
+ (6 . GL) (9 . NGL)
+ (4 . MI) (3 . PL)
+ (7 . GLE) (8 . NGLE)
+ (0 . F) (15 . T)))
+ (error "DECODE-FLOAT-CC: Unrecognized floating point condition code" bits))))
+\f
+(define (match-bits? high low pattern-list)
+ (let high-loop ((i 15) (l pattern-list))
+ (cond ((< i 0)
+ (let low-loop ((i 15) (l l))
+ (cond ((< i 0) #t)
+ ((or (eq? (car l) '?)
+ (eq? (if (bit-string-ref low i) 1 0)
+ (car l)))
+ (low-loop (-1+ i) (cdr l)))
+ (else
+ #f))))
+ ((or (eq? (car l) '?)
+ (eq? (if (bit-string-ref high i) 1 0)
+ (car l)))
+ (high-loop (-1+ i) (cdr l)))
+ (else #f))))
+
+(define (get-fmove-keyword high low)
+ (let loop ((l fmove-patterns))
+ (cond ((null? l) '())
+ ((match-bits? high low (caar l))
+ (cdar l))
+ (else
+ (loop (cdr l))))))
+
+(define fmove-patterns
+ '(((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
+ 0 ? 0 ? ? ? ? ? ? 0 0 0 0 0 0 0) . FMOVE-TO-FP)
+ ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
+ 0 1 1 ? ? ? ? ? ? ? ? ? ? ? ? ?) . FMOVE-FROM-FP)
+ ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
+ 1 0 ? ? ? ? 0 0 0 0 0 0 0 0 0 0) . FMOVE-FPcr)
+ ((1 1 1 1 0 0 1 0 0 0 0 0 0 0 0 0
+ 0 1 0 1 1 1 ? ? ? ? ? ? ? ? ? ?) . FMOVECR)
+ ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
+ 1 1 ? ? ? ? 0 0 0 ? ? ? ? ? ? ?) . FMOVEM-FPn)
+ ((1 1 1 1 0 0 1 0 0 0 ? ? ? ? ? ?
+ 1 0 ? ? ? ? 0 0 0 0 0 0 0 0 0 0) . FMOVEM-FPcr)))
\f
;;;; Bit String Manipulation
(define get-word (make-fetcher 16))
(define get-longword (make-fetcher 32))
+
+(define (make-peeker size-in-bits)
+ (lambda ()
+ (read-bits *current-offset size-in-bits)))
+
+(define peek-word (make-peeker 16))
+(define peek-longword (make-peeker 32))
+
(declare (integrate-operator extract extract+))
(define (extract bit-string start end)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.21 1989/04/26 05:09:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.22 1989/07/25 12:40:16 arthur Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(file-dependency/syntax/join
(append (filename/append "base"
"blocks" "cfg1" "cfg2" "cfg3" "constr"
- "contin" "ctypes" "debug" "enumer" "infnew"
- "lvalue" "object" "pmerly" "proced" "refctx"
- "rvalue" "scode" "sets" "subprb" "switch"
- "toplev" "utils")
+ "contin" "crstop" "ctypes" "debug" "enumer"
+ "infnew" "lvalue" "object" "pmerly" "proced"
+ "refctx" "rvalue" "scode" "sets" "subprb"
+ "switch" "toplev" "utils")
(filename/append "back"
"asmmac" "bittop" "bitutl" "insseq" "lapgn1"
"lapgn2" "lapgn3" "linear" "regmap" "symtab"
"sideff" "simapp" "simple" "subfre")
(filename/append "rtlbase"
"regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
- "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2")
+ "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
+ "valclass")
(filename/append "rtlgen"
"fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
"rgretn" "rgrval" "rgstmt" "rtlgen")
lap-generator-syntax-table)
(file-dependency/syntax/join
(filename/append "machines/bobcat"
- "insutl" "instr1" "instr2" "instr3" "instr4")
+ "insutl" "instr1" "instr2" "instr3" "instr4"
+ "flinstr1" "flinstr2")
assembler-syntax-table)))
\f
;;;; Integration Dependencies
(rtl-base
(filename/append "rtlbase"
"regset" "rgraph" "rtlcfg" "rtlexp" "rtlobj"
- "rtlreg" "rtlty1" "rtlty2"))
+ "rtlreg" "rtlty1" "rtlty2" "valclass"))
(cse-base
(filename/append "rtlopt"
"rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr"))
(append
(filename/append "back" "bittop")
(filename/append "machines/bobcat"
- "instr1" "instr2" "instr3" "instr4"))))
+ "instr1" "instr2" "instr3" "instr4"
+ "flinstr1" "flinstr2"))))
(define (file-dependency/integration/join filenames dependencies)
(for-each (lambda (filename)
(define-integration-dependencies "rtlbase" "rtlty2" "machines/bobcat"
"machin")
(define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
+ (define-integration-dependencies "rtlbase" "valclass" "rtlbase"
+ "rtlty1" "rtlty2" "rtlreg")
+
(file-dependency/integration/join
(append
(filename/append "base" "refctx")
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.19 1989/01/18 13:49:56 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.20 1989/07/25 12:40:04 arthur Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(and (effective-address/address-register? source)
(= (+ 8 (lap:ea-operand-1 source)) target)))
(LAP)
- (LAP (MOV L ,source ,(register-reference target)))))
+ (memory->machine-register source target)))
(define (register->register-transfer source target)
(LAP ,(machine->machine-register source target)))
(machine-register->memory source (pseudo-register-home target)))
(define-integrable (pseudo-register-offset register)
- (+ #x000A (register-renumber register)))
+ (+ 180 (* 3 (register-renumber register))))
(define-integrable (pseudo-register-home register)
(offset-reference regnum:regs-pointer
(pseudo-register-offset register)))
(define-integrable (machine->machine-register source target)
- (INST (MOV L
- ,(register-reference source)
- ,(register-reference target))))
+ (cond ((float-register? source)
+ (if (float-register? target)
+ (INST (FMOVE ,source ,target))
+ (error "Moving from floating point register to non-fp register")))
+ ((float-register? target)
+ (error "Moving from non-floating point register to fp register"))
+ (else (INST (MOV L
+ ,(register-reference source)
+ ,(register-reference target))))))
(define-integrable (machine-register->memory source target)
- (INST (MOV L
- ,(register-reference source)
- ,target)))
+ (if (float-register? source)
+ (INST (FMOVE X ,(register-reference source) ,target))
+ (INST (MOV L ,(register-reference source) ,target))))
(define-integrable (memory->machine-register source target)
- (INST (MOV L
- ,source
- ,(register-reference target))))
+ (if (float-register? target)
+ (INST (FMOVE X ,source ,(register-reference target)))
+ (INST (MOV L ,source ,(register-reference target)))))
(package (offset-reference byte-offset-reference)
(cond ((zero? n) (LAP))
(else (LAP (SUB L (& ,(* n #x100)) ,target))))))
\f
+;;;; Flonum Operators
+
+(define (float-target-reference target)
+ (delete-dead-registers!)
+ (register-reference
+ (or (register-alias target 'FLOAT)
+ (allocate-alias-register! target 'FLOAT))))
+
+(define (define-flonum-method operator methods method)
+ (let ((entry (assq operator (cdr methods))))
+ (if entry
+ (set-cdr! entry method)
+ (set-cdr! methods (cons (cons operator method) (cdr methods)))))
+ operator)
+
+(define (lookup-flonum-method operator methods)
+ (cdr (or (assq operator (cdr methods))
+ (error "Unknown operator" operator))))
+
+
+(define flonum-methods/1-arg
+ (list 'FLONUM-METHODS/1-ARG))
+
+(define-integrable (flonum-1-arg/operate operator)
+ (lookup-flonum-method operator flonum-methods/1-arg))
+
+;;; Notice the weird ,', syntax here. If LAP changes, this may also have to change.
+
+(let-syntax
+ ((define-flonum-operation
+ (macro (primitive-name instruction-name)
+ `(define-flonum-method ',primitive-name flonum-methods/1-arg
+ (lambda (source target)
+ (LAP (,instruction-name ,',source ,',target)))))))
+ (define-flonum-operation SINE-FLONUM FSIN)
+ (define-flonum-operation COSINE-FLONUM FCOS)
+ (define-flonum-operation ARCTAN-FLONUM FATAN)
+ (define-flonum-operation EXP-FLONUM FETOX)
+ (define-flonum-operation LN-FLONUM FLOGN)
+ (define-flonum-operation SQRT-FLONUM FSQRT)
+ (define-flonum-operation TRUNCATE-FLONUM FINT))
+
+(define flonum-methods/2-args
+ (list 'FLONUM-METHODS/2-ARGS))
+
+(define-integrable (flonum-2-args/operate operator)
+ (lookup-flonum-method operator flonum-methods/2-args))
+
+(let-syntax
+ ((define-flonum-operation
+ (macro (primitive-name instruction-name)
+ `(define-flonum-method ',primitive-name flonum-methods/2-args
+ (lambda (source target)
+ (LAP (,instruction-name ,',source ,',target)))))))
+ (define-flonum-operation PLUS-FLONUM FADD)
+ (define-flonum-operation MINUS-FLONUM FSUB)
+ (define-flonum-operation MULTIPLY-FLONUM FMUL)
+ (define-flonum-operation DIVIDE-FLONUM FDIV))
+
+(define (invert-float-cc cc)
+ (cdr (or (assq cc
+ '((EQ . NE) (NE . EQ)
+ (GT . NGT) (NGT . GT)
+ (GE . NGE) (NGE . GE)
+ (LT . NLT) (NLT . LT)
+ (LE . NLE) (NLE . LE)
+ (GL . NGL) (NGL . GL)
+ (MI . PL) (PL . MI)))
+ (error "INVERT-FLOAT-CC: Not a known CC" cc))))
+
+
+(define (set-flonum-branches! cc)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (FB ,cc (@PCR ,label))))
+ (lambda (label)
+ (LAP (FB ,(invert-float-cc cc) (@PCR ,label))))))
+
+(define (flonum-predicate->cc predicate)
+ (case predicate
+ ((EQUAL-FLONUM? ZERO-FLONUM?) 'EQ)
+ ((LESS-THAN-FLONUM? NEGATIVE-FLONUM?) 'LT)
+ ((GREATER-THAN-FLONUM? POSITIVE-FLONUM?) 'GT)
+ (else (error "FLONUM-PREDICATE->CC: Unknown predicate" predicate))))\f
;;;; OBJECT->DATUM rules - Mhwu
;;; Similar to fixnum rules, but no sign extension
(define (address-register? register)
(and (< register 16)
(>= register 8)))
+
+(define (float-register? register)
+ (and (< register 24)
+ (>= register 16)))
+
(define-integrable (lap:ea-keyword expression)
(car expression))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.14 1989/01/18 09:58:56 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.15 1989/07/25 12:39:50 arthur Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define-integrable scheme-object-width 32)
(define-integrable scheme-datum-width 24)
(define-integrable scheme-type-width 8)
+(define-integrable flonum-size 2)
+(define-integrable float-alignment 32)
;; It is currently required that both packed characters and objects be
;; integrable numbers of address units. Furthermore, the number of
(define-integrable a5 13)
(define-integrable a6 14)
(define-integrable a7 15)
-(define number-of-machine-registers 16)
+(define-integrable fp0 16)
+(define-integrable fp1 17)
+(define-integrable fp2 18)
+(define-integrable fp3 19)
+(define-integrable fp4 20)
+(define-integrable fp5 21)
+(define-integrable fp6 22)
+(define-integrable fp7 23)
+(define number-of-machine-registers 24)
(define number-of-temporary-registers 50)
(define-integrable regnum:dynamic-link a4)
registers)
(define available-machine-registers
- (list d0 d1 d2 d3 d4 d5 d6 a0 a1 a2 a3))
+ (list d0 d1 d2 d3 d4 d5 d6
+ a0 a1 a2 a3
+ fp0 fp1 fp2 fp3 fp4 fp5 fp6 fp7))
(define initial-non-object-registers
(list d7 a4 a5 a6 a7))
\f
+(define (float-register? register)
+ (if (machine-register? register)
+ (eq? (register-type register) 'FLOAT)
+ (error "FLOAT-REGISTER? valid only for machine registers" register)))
+
+(define (word-register? register)
+ (if (machine-register? register)
+ (memq (register-type register)
+ '(DATA ADDRESS))))
+
+(define (register-types-compatible? type1 type2) (eq? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
+
(define register-type
- (let ((types (make-vector 16)))
- (let loop ((i 0) (j 8))
+ (let ((types (make-vector number-of-machine-registers)))
+ (let loop ((i 0) (j 8) (k 16))
(if (< i 8)
(begin (vector-set! types i 'DATA)
(vector-set! types j 'ADDRESS)
- (loop (1+ i) (1+ j)))))
+ (vector-set! types k 'FLOAT)
+ (loop (1+ i) (1+ j) (1+ k)))))
(lambda (register)
(vector-ref types register))))
(define register-reference
- (let ((references (make-vector 16)))
+ (let ((references (make-vector number-of-machine-registers)))
(let loop ((i 0) (j 8))
(if (< i 8)
(begin (vector-set! references i (INST-EA (D ,i)))
(vector-set! references j (INST-EA (A ,i)))
- (loop (1+ i) (1+ j))))) (lambda (register)
+ (loop (1+ i) (1+ j)))))
+ (let loop ((i 16) (names '(FP0 FP1 FP2 FP3 FP4 FP5 FP6 FP7)))
+ (if (not (null? names))
+ (begin (vector-set! references i (car names))
+ (loop (1+ i) (cdr names)))))
+ (lambda (register)
(vector-ref references register))))
(define mask-reference (INST-EA (D 7)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.45 1989/05/31 20:01:20 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.46 1989/07/25 12:39:34 arthur Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
'((COMPILER MACROS)
(COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (Motorola MC68020)" 4 45 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (Motorola MC68020)" 4 46 '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.22 1989/04/27 20:06:32 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.23 1989/07/25 12:38:20 arthur Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define-rule statement
(ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
- (QUALIFIER (and (pseudo-register? target) (pseudo-register? source)))
+ (QUALIFIER (and (pseudo-word? target) (pseudo-register? source)))
(reuse-pseudo-register-alias! source 'DATA
(lambda (reusable-alias)
(delete-dead-registers!)
(define-rule statement
(ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (QUALIFIER (pseudo-register? target))
+ (QUALIFIER (pseudo-word? target))
(move-to-alias-register! source 'DATA target)
(LAP))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+ (QUALIFIER (pseudo-float? target))
+ (move-to-alias-register! source 'FLOAT target)
+ (LAP))
\f
(define (convert-object/constant->register target constant conversion)
(delete-dead-registers!)
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
+ (QUALIFIER (pseudo-word? r))
(LAP (MOV L ,(standard-register-reference r false) (@A+ 5))))
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
+ (QUALIFIER (pseudo-float? r))
+ (LAP (FMOVE D ,(float-register-reference r) (@A+ 5))))
+
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n)))
(LAP (MOV L ,(indirect-reference! r n) (@A+ 5))))
((register-saved-into-home? register)
(pseudo-register-home register))
(else
- (reference-alias-register! register 'DATA)))))\f
+ (reference-alias-register! register 'DATA)))))
+\f
+;;;; Flonum Operations
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT->OBJECT (REGISTER (? source))))
+ (QUALIFIER (pseudo-float? source))
+ (let ((target (reference-target-alias! target 'DATA)))
+ (LAP (MOV L (A 5) ,target)
+ (OR L (& ,(make-non-pointer-literal (ucode-type flonum) 0)) ,target)
+ ,(load-non-pointer (ucode-type manifest-nm-vector)
+ flonum-size
+ (INST-EA (@A+ 5)))
+ (FMOVE D
+ ,(float-register-reference source)
+ (@A+ 5)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (@ADDRESS->FLOAT (REGISTER (? source))))
+ (QUALIFIER (pseudo-float? target))
+ (LAP (FMOVE D
+ ,(indirect-reference! source 1)
+ ,(reference-target-alias! target 'FLOAT))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-1-ARG (? operator) (REGISTER (? source))))
+ (QUALIFIER (and (pseudo-float? target) (pseudo-float? source)))
+ (let ((source-reference (float-register-reference source)))
+ (let ((target-reference (float-target-reference target)))
+ (LAP ,@((flonum-1-arg/operate operator)
+ source-reference
+ target-reference)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operator)
+ (REGISTER (? source1))
+ (REGISTER (? source2))))
+ (QUALIFIER (and (pseudo-float? target)
+ (pseudo-float? source1)
+ (pseudo-float? source2)))
+ (let ((source1-reference (float-register-reference source1))
+ (source2-reference (float-register-reference source2)))
+ (let ((target-reference (float-target-reference target)))
+ (LAP (FMOVE ,source1-reference ,target-reference)
+ ,@((flonum-2-args/operate operator)
+ source2-reference
+ target-reference)))))\f
;;;; CHAR->ASCII/BYTE-OFFSET
(define (load-char-into-register type source target)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.7 1988/12/13 17:45:25 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.8 1989/07/25 12:38:07 arthur Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(fixnum-predicate/memory*constant
(predicate/memory-operand-reference memory)
constant
- (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
\ No newline at end of file
+ (invert-cc-noncommutative (fixnum-predicate->cc predicate))))
+\f
+;;;; Flonum Predicates
+
+(define-rule predicate
+ (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
+ (QUALIFIER (pseudo-float? register))
+ (set-flonum-branches! (flonum-predicate->cc predicate))
+ (LAP (FTST ,(float-register-reference register))))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? register1))
+ (REGISTER (? register2)))
+ (QUALIFIER (and (pseudo-float? register1) (pseudo-float? register2)))
+ (set-flonum-branches! (flonum-predicate->cc predicate))
+ (LAP (FCMP ,(float-register-reference register2)
+ ,(float-register-reference register1))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.4 1988/11/02 21:51:17 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.5 1989/07/25 12:37:46 arthur Exp $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
register-n-deaths
register-live-length
register-crosses-call?
+ register-value-classes
)
(define (add-rgraph-non-object-register! rgraph register)
(set-rgraph-non-object-registers!
(define-integrable rgraph-register-renumber rgraph-register-bblock)
(define-integrable set-rgraph-register-renumber! set-rgraph-register-bblock!)
+
+;;; Pseudo-register value classes are kept on an association list between value
+;;; classes and lists of pseudo-registers in the class. A register not found
+;;; in any value class list is assumed to have class VALUE, the broadest and
+;;; most common class. This minimizes the space used to store register value
+;;; classifiations at the expense of reduced speed. It is illegal to change
+;;; the value class of a pseudo-register unless its current class is VALUE
+;;; (completely unspecified); this restriction is checked.
+
+(define (rgraph-register-value-class rgraph register)
+ (let loop ((classes (rgraph-register-value-classes rgraph)))
+ (if (null? classes)
+ 'VALUE
+ (let ((class-list (car classes)))
+ (if (memq register (cdr class-list))
+ (car class-list)
+ (loop (cdr classes)))))))
+
+(define (set-rgraph-register-value-class! rgraph register value-class)
+ (let ((old-value-class (rgraph-register-value-class rgraph register)))
+ (if (eq? old-value-class 'VALUE)
+ (if (not (eq? value-class 'VALUE))
+ (let loop ((classes (rgraph-register-value-classes rgraph)))
+ (if (null? classes)
+ (set-rgraph-register-value-classes!
+ rgraph
+ (cons (list value-class register)
+ (rgraph-register-value-classes rgraph)))
+ (let ((class-list (car classes)))
+ (if (eq? value-class (car class-list))
+ (let ((register-list (cdr class-list)))
+ (if (not (memq register register-list))
+ (set-cdr! class-list (cons register register-list))))
+ (loop (cdr classes)))))))
+ (if (not (eq? old-value-class value-class))
+ (error "Illegal register value class change" register value-class)))))
+
(define *rgraphs*)
(define *current-rgraph*)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.16 1989/01/21 09:18:55 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.17 1989/07/25 12:37:32 arthur Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
\f
;;;; Statements
+(define (%make-assign-classified locative expression)
+ (if (rtl:register? locative)
+ (let ((register (rtl:register-number locative)))
+ (if (pseudo-register? register)
+ (set-rgraph-register-value-class!
+ *current-rgraph*
+ register
+ (rtl->value-class expression)))))
+ (%make-assign locative expression))
+
(define (rtl:make-assignment locative expression)
(expression-simplify-for-statement expression
(lambda (expression)
(define (rtl:make-assignment-internal locative expression)
(let ((assign-register
(lambda (locative)
- (if (rtl:non-object-valued-expression? expression)
- ;; We don't know for sure that this register is
- ;; assigned only once. However, if it is assigned
- ;; multiple times, then all of those assignments
- ;; should be non-object valued expressions. This
- ;; constraint is not enforced.
- (add-rgraph-non-object-register!
- *current-rgraph*
- (rtl:register-number locative)))
- (%make-assign locative expression))))
+ (let ((register (rtl:register-number locative)))
+ (if (rtl:non-object-valued-expression? expression)
+ ;; We don't know for sure that this register is
+ ;; assigned only once. However, if it is assigned
+ ;; multiple times, then all of those assignments
+ ;; should be non-object valued expressions. This
+ ;; constraint is not enforced.
+ (add-rgraph-non-object-register! *current-rgraph* register))
+ (%make-assign-classified locative expression)))))
(cond ((rtl:pseudo-register-expression? locative)
(assign-register locative))
((or (rtl:machine-register-expression? locative)
(expression-simplify-for-predicate operand2
(lambda (operand2)
(%make-fixnum-pred-2-args predicate operand1 operand2))))))
+
+(define (rtl:make-flonum-pred-1-arg predicate operand)
+ (expression-simplify-for-predicate operand
+ (lambda (operand)
+ (%make-flonum-pred-1-arg predicate operand))))
+
+(define (rtl:make-flonum-pred-2-args predicate operand1 operand2)
+ (expression-simplify-for-predicate operand1
+ (lambda (operand1)
+ (expression-simplify-for-predicate operand2
+ (lambda (operand2)
+ (%make-flonum-pred-2-args predicate operand1 operand2))))))
\f
(define (rtl:make-pop locative)
(locative-dereference-for-statement locative
(if (rtl:non-object-valued-expression? expression)
(add-rgraph-non-object-register! *current-rgraph*
(rtl:register-number pseudo)))
- (scfg-append! (%make-assign pseudo expression) (receiver pseudo))))
+ (scfg-append! (%make-assign-classified pseudo expression)
+ (receiver pseudo))))
(define (assign-to-address-temporary expression scfg-append! receiver)
(let ((pseudo (rtl:make-pseudo-register)))
(add-rgraph-non-object-register! *current-rgraph*
(rtl:register-number pseudo))
- (scfg-append! (%make-assign pseudo (rtl:make-object->address expression))
+ (scfg-append! (%make-assign-classified
+ pseudo
+ (rtl:make-object->address expression))
(receiver pseudo))))
(define (define-expression-method name method)
(expression-simplify operand scfg-append!
(lambda (operand)
(receiver (rtl:make-fixnum-1-arg operator operand))))))
-
+\f
(define-expression-method 'GENERIC-BINARY
(lambda (receiver scfg-append! operator operand1 operand2)
(expression-simplify operand1 scfg-append!
(expression-simplify operand scfg-append!
(lambda (operand)
(receiver (rtl:make-generic-unary operator operand))))))
+\f(define-expression-method 'FLONUM-1-ARG
+ (lambda (receiver scfg-append! operator operand)
+ (expression-simplify operand scfg-append!
+ (lambda (s-operand)
+ (receiver (rtl:make-flonum-1-arg
+ operator
+ s-operand))))))
+
+(define-expression-method 'FLONUM-2-ARGS
+ (lambda (receiver scfg-append! operator operand1 operand2)
+ (expression-simplify operand1 scfg-append!
+ (lambda (s-operand1)
+ (expression-simplify operand2 scfg-append!
+ (lambda (s-operand2)
+ (receiver (rtl:make-flonum-2-args
+ operator
+ s-operand1
+ s-operand2))))))))
+
+(define-expression-method 'FLOAT->OBJECT
+ (lambda (receiver scfg-append! expression)
+ (expression-simplify expression scfg-append!
+ (lambda (expression)
+ (receiver (rtl:make-float->object expression))))))
+
+(define-expression-method '@ADDRESS->FLOAT
+ (lambda (receiver scfg-append! expression)
+ (expression-simplify expression scfg-append!
+ (lambda (expression)
+ (receiver (rtl:make-@address->float expression))))))
+
;;; end EXPRESSION-SIMPLIFY package
)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.11 1988/12/12 21:30:25 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.12 1989/07/25 12:37:17 arthur Exp $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
CONS-CLOSURE
FIXNUM-1-ARG
FIXNUM-2-ARGS
+ FLONUM-1-ARG
+ FLONUM-2-ARGS
OBJECT->ADDRESS
OBJECT->DATUM
OBJECT->FIXNUM
+ OBJECT->ADDRESS
+ @ADDRESS->FLOAT
ADDRESS->FIXNUM
FIXNUM->ADDRESS
OBJECT->TYPE
(and (rtl:constant-expression?
(rtl:fixnum-2-args-operand-1 expression))
(rtl:constant-expression?
- (rtl:fixnum-2-args-operand-2 expression)))) (else
+ (rtl:fixnum-2-args-operand-2 expression))))
+ ((FLONUM-1-ARG)
+ (rtl:constant-expression? (rtl:flonum-1-arg-operand expression)))
+ ((FLONUM-2-ARGS)
+ (and (rtl:constant-expression?
+ (rtl:flonum-2-args-operand-1 expression))
+ (rtl:constant-expression?
+ (rtl:flonum-2-args-operand-2 expression))))
+ (else
false))
true))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.13 1988/11/08 08:21:03 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.14 1989/07/25 12:37:01 arthur Exp $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-rtl-expression fixnum->object rtl: expression)
(define-rtl-expression fixnum->address rtl: expression)
(define-rtl-expression address->fixnum rtl: expression)
+(define-rtl-expression float->object rtl: expression)
+(define-rtl-expression @address->float rtl: expression)
(define-rtl-expression offset rtl: register number)
(define-rtl-expression pre-increment rtl: register number)
(define-rtl-expression post-increment rtl: register number)
(define-rtl-predicate fixnum-pred-1-arg % predicate operand)
(define-rtl-predicate fixnum-pred-2-args % predicate operand-1 operand-2)
+
+(define-rtl-expression flonum-1-arg rtl: operator operand)
+(define-rtl-expression flonum-2-args rtl: operator operand-1 operand-2)
+
+(define-rtl-predicate flonum-pred-1-arg % predicate operand)
+(define-rtl-predicate flonum-pred-2-args % predicate operand-1 operand-2)
+
(define-rtl-expression generic-unary rtl: operator operand)
(define-rtl-expression generic-binary rtl: operator operand-1 operand-2)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.29 1989/04/18 05:06:06 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.30 1989/07/25 12:32:50 arthur Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
fixnum-pred
(rtl:make-object->fixnum (car expressions)))))
'(0))))
- '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?))\f
+ '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?))
+\f
+;;; Floating Point Arithmetic
+
+(for-each (lambda (flonum-operator)
+ (define-open-coder/value flonum-operator
+ (simple-open-coder
+ (lambda (context expressions finish)
+ (let ((argument (car expressions)))
+ (open-code:with-checks
+ context
+ (list (open-code:type-check argument (ucode-type flonum)))
+ (finish (rtl:make-float->object
+ (rtl:make-flonum-1-arg
+ flonum-operator
+ (rtl:make-@address->float
+ (rtl:make-object->address argument)))))
+ finish
+ flonum-operator
+ expressions)))
+ '(0))))
+ '(SINE-FLONUM COSINE-FLONUM ATAN-FLONUM EXP-FLONUM
+ LN-FLONUM SQRT-FLONUM TRUNCATE-FLONUM))
+
+(for-each (lambda (flonum-operator)
+ (define-open-coder/value flonum-operator
+ (simple-open-coder
+ (lambda (context expressions finish)
+ (let ((arg1 (car expressions))
+ (arg2 (cadr expressions)))
+ (open-code:with-checks
+ context
+ (list (open-code:type-check arg1 (ucode-type flonum))
+ (open-code:type-check arg2 (ucode-type flonum)))
+ (finish
+ (rtl:make-float->object
+ (rtl:make-flonum-2-args
+ flonum-operator
+ (rtl:make-@address->float
+ (rtl:make-object->address arg1))
+ (rtl:make-@address->float
+ (rtl:make-object->address arg2)))))
+ finish
+ flonum-operator
+ expressions)))
+ '(0 1))))
+ '(PLUS-FLONUM MINUS-FLONUM MULTIPLY-FLONUM DIVIDE-FLONUM))
+
+(for-each (lambda (flonum-pred)
+ (define-open-coder/predicate flonum-pred
+ (simple-open-coder
+ (lambda (context expressions finish)
+ (let ((argument (car expressions)))
+ (open-code:with-checks
+ context
+ (list (open-code:type-check argument (ucode-type flonum)))
+ (finish
+ (rtl:make-flonum-pred-1-arg
+ flonum-pred
+ (rtl:make-@address->float
+ (rtl:make-object->address argument))))
+ (lambda (expression)
+ (finish (rtl:make-true-test expression)))
+ flonum-pred
+ expressions)))
+ '(0))))
+ '(ZERO-FLONUM? POSITIVE-FLONUM? NEGATIVE-FLONUM?))
+
+(for-each (lambda (flonum-pred)
+ (define-open-coder/predicate flonum-pred
+ (simple-open-coder
+ (lambda (context expressions finish)
+ (let ((arg1 (car expressions))
+ (arg2 (cadr expressions)))
+ (open-code:with-checks
+ context
+ (list (open-code:type-check arg1 (ucode-type flonum))
+ (open-code:type-check arg2 (ucode-type flonum)))
+ (finish (rtl:make-flonum-pred-2-args
+ flonum-pred
+ (rtl:make-@address->float
+ (rtl:make-object->address arg1))
+ (rtl:make-@address->float
+ (rtl:make-object->address arg2))))
+ (lambda (expression)
+ (finish (rtl:make-true-test expression)))
+ flonum-pred
+ expressions)))
+ '(0 1))))
+ '(EQUAL-FLONUM? LESS-THAN-FLONUM? GREATER-THAN-FLONUM?))\f
;;; Generic arithmetic
(define (generic-binary-generator generic-op is-pred?)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.17 1989/01/21 09:29:50 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.18 1989/07/25 12:32:31 arthur Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(define-trivial-two-arg-method 'FIXNUM-PRED-2-ARGS
rtl:fixnum-pred-2-args-operand-1 rtl:set-fixnum-pred-2-args-operand-1!
rtl:fixnum-pred-2-args-operand-2 rtl:set-fixnum-pred-2-args-operand-2!)
+
+(define-trivial-one-arg-method 'FLONUM-PRED-1-ARG
+ rtl:flonum-pred-1-arg-operand rtl:set-flonum-pred-1-arg-operand!)
+
+(define-trivial-two-arg-method 'FLONUM-PRED-2-ARGS
+ rtl:flonum-pred-2-args-operand-1 rtl:set-flonum-pred-2-args-operand-1!
+ rtl:flonum-pred-2-args-operand-2 rtl:set-flonum-pred-2-args-operand-2!)
+
(define-trivial-one-arg-method 'TRUE-TEST
rtl:true-test-expression rtl:set-true-test-expression!)
projects / mit-scheme.git / commitdiff