From 0172964939b6d28e863a7d7fad7f05413ec25052 Mon Sep 17 00:00:00 2001 From: Arthur Gleckler Date: Tue, 25 Jul 1989 12:42:02 +0000 Subject: [PATCH] Open-coding of floating-point arithmetic. --- v7/src/compiler/back/lapgn2.scm | 11 +- v7/src/compiler/back/regmap.scm | 18 +- v7/src/compiler/machines/bobcat/dassm2.scm | 23 +- v7/src/compiler/machines/bobcat/dassm3.scm | 200 +++++++++++++++++- v7/src/compiler/machines/bobcat/decls.scm | 24 ++- v7/src/compiler/machines/bobcat/lapgen.scm | 119 +++++++++-- v7/src/compiler/machines/bobcat/machin.scm | 46 +++- .../compiler/machines/bobcat/make.scm-68040 | 4 +- v7/src/compiler/machines/bobcat/rules1.scm | 70 +++++- v7/src/compiler/machines/bobcat/rules2.scm | 23 +- v7/src/compiler/rtlbase/rgraph.scm | 42 +++- v7/src/compiler/rtlbase/rtlcon.scm | 83 ++++++-- v7/src/compiler/rtlbase/rtlexp.scm | 18 +- v7/src/compiler/rtlbase/rtlty1.scm | 13 +- v7/src/compiler/rtlgen/opncod.scm | 93 +++++++- v7/src/compiler/rtlopt/rcse1.scm | 10 +- 16 files changed, 716 insertions(+), 81 deletions(-) diff --git a/v7/src/compiler/back/lapgn2.scm b/v7/src/compiler/back/lapgn2.scm index bcfbb8d33..9dda33ff3 100644 --- a/v7/src/compiler/back/lapgn2.scm +++ b/v7/src/compiler/back/lapgn2.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -310,6 +310,13 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm index 0a4d55055..36eba50eb 100644 --- a/v7/src/compiler/back/regmap.scm +++ b/v7/src/compiler/back/regmap.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -83,8 +83,9 @@ registers into some interesting sorting order. (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) @@ -326,14 +327,17 @@ registers into some interesting sorting order. (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 diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index ac2f5e078..60c23456c 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -75,7 +75,9 @@ MIT in each case. |# (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)) @@ -329,11 +331,13 @@ MIT in each case. |# (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 @@ -346,7 +350,14 @@ MIT in each case. |# 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)))))))) +) (define (make-pc-relative thunk) (let ((reference-offset *current-offset)) diff --git a/v7/src/compiler/machines/bobcat/dassm3.scm b/v7/src/compiler/machines/bobcat/dassm3.scm index e248da4c8..a3a5a7b29 100644 --- a/v7/src/compiler/machines/bobcat/dassm3.scm +++ b/v7/src/compiler/machines/bobcat/dassm3.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -82,7 +82,6 @@ MIT in each case. |# (if (= (extract *ir 3 6) #b001) %CMPM %EOR)))) - (lambda () (let ((size (extract *ir 6 8))) (cond ((= size #b00) @@ -106,7 +105,7 @@ MIT in each case. |# %ADDX %ADD))) (lambda () shift/rotate/bitop) - undefined)) + (lambda () coprocessor))) ;;;; Operations @@ -587,7 +586,192 @@ MIT in each case. |# `(& ,(extract extension 0 5)) (make-data-register 'D (extract extension 0 3))))) `(,opcode ,source ,offset ,width ,@target)))) + +;;; +;;; 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))))) + +(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)))) + +(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))) ;;;; Bit String Manipulation @@ -606,6 +790,14 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index fe456b9c9..8e53c3629 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -332,10 +332,10 @@ MIT in each case. |# (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" @@ -351,7 +351,8 @@ MIT in each case. |# "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") @@ -366,7 +367,8 @@ MIT in each case. |# 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))) ;;;; Integration Dependencies @@ -383,7 +385,7 @@ MIT in each case. |# (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")) @@ -405,7 +407,8 @@ MIT in each case. |# (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) @@ -476,6 +479,9 @@ MIT in each case. |# (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") diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index edf7aa35b..9af7dc743 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -44,7 +44,7 @@ MIT in each case. |# (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))) @@ -62,26 +62,32 @@ MIT in each case. |# (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) @@ -514,6 +520,90 @@ MIT in each case. |# (cond ((zero? n) (LAP)) (else (LAP (SUB L (& ,(* n #x100)) ,target)))))) +;;;; 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)))) ;;;; OBJECT->DATUM rules - Mhwu ;;; Similar to fixnum rules, but no sign extension @@ -583,6 +673,11 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index 66f52c953..3c459dfd8 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -42,6 +42,8 @@ MIT in each case. |# (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 @@ -118,7 +120,15 @@ MIT in each case. |# (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) @@ -130,28 +140,48 @@ MIT in each case. |# 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)) +(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))) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 59b072ce3..808fd13e0 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-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 @@ -41,4 +41,4 @@ MIT in each case. |# ((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 diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm index 4869b3e15..a3ccda98f 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -93,7 +93,7 @@ MIT in each case. |# (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!) @@ -127,9 +127,15 @@ MIT in each case. |# (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)) (define (convert-object/constant->register target constant conversion) (delete-dead-registers!) @@ -357,8 +363,14 @@ MIT in each case. |# (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)))) @@ -582,7 +594,57 @@ MIT in each case. |# ((register-saved-into-home? register) (pseudo-register-home register)) (else - (reference-alias-register! register 'DATA))))) + (reference-alias-register! register 'DATA))))) + +;;;; 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))))) ;;;; CHAR->ASCII/BYTE-OFFSET (define (load-char-into-register type source target) diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm index f3d9bb49b..83d7d4c51 100644 --- a/v7/src/compiler/machines/bobcat/rules2.scm +++ b/v7/src/compiler/machines/bobcat/rules2.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -320,4 +320,21 @@ MIT in each case. |# (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)))) + +;;;; 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 diff --git a/v7/src/compiler/rtlbase/rgraph.scm b/v7/src/compiler/rtlbase/rgraph.scm index 08e507561..14fe2f2db 100644 --- a/v7/src/compiler/rtlbase/rgraph.scm +++ b/v7/src/compiler/rtlbase/rgraph.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -48,6 +48,7 @@ MIT in each case. |# 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! @@ -59,6 +60,43 @@ MIT in each case. |# (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*) diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 797ccf8d4..e263b5ff3 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -38,6 +38,16 @@ MIT in each case. |# ;;;; 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) @@ -48,16 +58,15 @@ MIT in each case. |# (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) @@ -101,6 +110,18 @@ MIT in each case. |# (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)))))) (define (rtl:make-pop locative) (locative-dereference-for-statement locative @@ -329,13 +350,16 @@ MIT in each case. |# (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) @@ -530,7 +554,7 @@ MIT in each case. |# (expression-simplify operand scfg-append! (lambda (operand) (receiver (rtl:make-fixnum-1-arg operator operand)))))) - + (define-expression-method 'GENERIC-BINARY (lambda (receiver scfg-append! operator operand1 operand2) (expression-simplify operand1 scfg-append! @@ -545,5 +569,36 @@ MIT in each case. |# (expression-simplify operand scfg-append! (lambda (operand) (receiver (rtl:make-generic-unary operator operand)))))) + (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 diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index 307fda4c6..8d4f27764 100644 --- a/v7/src/compiler/rtlbase/rtlexp.scm +++ b/v7/src/compiler/rtlbase/rtlexp.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -73,9 +73,13 @@ MIT in each case. |# 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 @@ -251,6 +255,14 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index b2514b2b7..2f98ae855 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -47,6 +47,8 @@ MIT in each case. |# (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) @@ -66,6 +68,13 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index ac8d09fce..c67173491 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -713,7 +713,96 @@ MIT in each case. |# fixnum-pred (rtl:make-object->fixnum (car expressions))))) '(0)))) - '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?)) + '(ZERO-FIXNUM? POSITIVE-FIXNUM? NEGATIVE-FIXNUM?)) + +;;; 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?)) ;;; Generic arithmetic (define (generic-binary-generator generic-op is-pred?) diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index ee20123f4..f3c105ece 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -297,6 +297,14 @@ MIT in each case. |# (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!) -- 2.25.1