Newer
Older
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.3 1997/03/26 20:29:14 dtc Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains floating point support for the x86.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Re-written and enhanced by Douglas Crosher, 1996, 1997.
(in-package :x86)
(defmacro ea-for-xf-desc(tn slot)
`(make-ea
:dword :base ,tn :disp (- (* ,slot vm:word-bytes) vm:other-pointer-type)))
(defun ea-for-sf-desc(tn)
(ea-for-xf-desc tn vm:single-float-value-slot))
(defun ea-for-df-desc(tn)
(ea-for-xf-desc tn vm:double-float-value-slot))
(defmacro ea-for-xf-stack(tn kind)
`(make-ea
:dword :base ebp-tn
:disp (- (* (+ (tn-offset ,tn) (case ,kind (:single 1) (:double 2)))
vm:word-bytes))))
(defun ea-for-sf-stack(tn)
(ea-for-xf-stack tn :single))
(defun ea-for-df-stack(tn)
(ea-for-xf-stack tn :double))
;;; Abstract out the copying of a FP register to the FP stack top, and
;;; provide two alternatives for its implementation. Note: it's not
;;; necessary to distinguish between a single or double register move
;;; here.
;;;
;;; Using a Pop then load.
(defmacro copy-fp-reg-to-fr0 (reg)
`(progn
(assert (not (zerop (tn-offset ,reg))))
(inst fstp fr0-tn)
(inst fld (make-random-tn :kind :normal
:sc (sc-or-lose 'double-reg)
:offset (1- (tn-offset ,reg))))))
;;;
;;; Using Fxch then Fst to restore the original reg contents.
#+nil
(defmacro copy-fp-reg-to-fr0 (reg)
`(progn
(assert (not (zerop (tn-offset ,reg))))
(inst fxch ,reg)
(inst fst ,reg)))
;;;; Move functions:
;;; x is source, y is destination
(define-move-function (load-single 6) (vop x y)
((single-stack) (single-reg))
(with-empty-tn@fp-top(y)
(inst fld (ea-for-sf-stack x))))
(define-move-function (store-single 6) (vop x y)
((single-reg) (single-stack))
(cond ((zerop (tn-offset x))
(inst fst (ea-for-sf-stack y)))
(t
(inst fxch x)
(inst fst (ea-for-sf-stack y))
;; This may not be necessary as ST0 is likely invalid now.
(inst fxch x))))
(define-move-function (load-double 6) (vop x y)
((double-stack) (double-reg))
(with-empty-tn@fp-top(y)
(inst fldd (ea-for-df-stack x))))
(define-move-function (store-double 6) (vop x y)
((double-reg) (double-stack))
(cond ((zerop (tn-offset x))
(inst fstd (ea-for-df-stack y)))
(t
(inst fxch x)
(inst fstd (ea-for-df-stack y))
;; This may not be necessary as ST0 is likely invalid now.
(inst fxch x))))
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
;;; The i387 has instructions to load some useful constants.
;;; This doesn't save much time but might cut down on memory
;;; access and reduce the size of the constant vector (CV).
;;; Intel claims they are stored in a more precise form on chip.
;;; Anyhow, might as well use the feature. It can be turned
;;; off by hacking the "immediate-constant-sc" in vm.lisp.
(define-move-function (load-fp-constant 6) (vop x y)
((fp-single-constant)(single-reg)
(fp-double-constant)(double-reg))
(let ((value (c::constant-value (c::tn-leaf x))))
(with-empty-tn@fp-top(y)
(cond ((zerop value)
(inst fldz))
((or (= value 1s0)(= value 1d0))
(inst fld1))
((= value #.pi)
(inst fldpi))
((= value #.i387-l2t)
(inst fldl2t))
((= value #.i387-l2e)
(inst fldl2e))
((= value #.i387-lg2)
(inst fldlg2))
((= value #.i387-ln2)
(inst fldln2))
(t (warn "Ignoring bogus i387 Constant ~a" value))))))
;;;; Move VOPs:
;;;
;;; Float register to register moves.
;;;
(define-vop (single-move)
(:args (x :scs (single-reg) :target y
:load-if (not (and (sc-is x single-stack)
(sc-is y single-stack)
(location= x y)))))
(:results (y :scs (single-reg)
:load-if (not (and (sc-is x single-stack)
(sc-is y single-stack)
(location= x y)))))
(:note "float move")
(:generator 0
(unless (location= x y)
(cond ((zerop (tn-offset y))
(copy-fp-reg-to-fr0 x))
((zerop (tn-offset x))
(inst fst y))
(t
(inst fxch x)
(inst fst y)
(inst fxch x))))))
(define-move-vop single-move :move (single-reg) (single-reg))
(define-vop (double-move)
(:args (x :scs (double-reg) :target y
:load-if (not (and (sc-is x double-stack)
(sc-is y double-stack)
(location= x y)))))
(:results (y :scs (double-reg)
:load-if (not (and (sc-is x double-stack)
(sc-is y double-stack)
(location= x y)))))
(:note "float move")
(:generator 0
(unless (location= x y)
(cond ((zerop (tn-offset y))
(copy-fp-reg-to-fr0 x))
((zerop (tn-offset x))
(inst fstd y))
(t
(inst fxch x)
(inst fstd y)
(inst fxch x))))))
(define-move-vop double-move :move (double-reg) (double-reg))
;;;
;;; Move from float to a descriptor reg. allocating a new float
;;; object in the process.
;;;
(define-vop (move-from-single)
(:args (x :scs (single-reg) :to :save
:load-if (not (sc-is x fp-single-constant))))
(:results (y :scs (descriptor-reg)))
(:temporary (:sc dword-reg) ndescr)
(:note "float to pointer coercion")
(:generator 13
(if (sc-is x fp-single-constant)
(ecase (c::constant-value (c::tn-leaf x))
(0s0 (load-symbol-value y *fp-constant-0s0*))
(1s0 (load-symbol-value y *fp-constant-1s0*)))
(with-fixed-allocation (y ndescr vm:single-float-type
vm:single-float-size)
(with-tn@fp-top(x)
(inst fst (make-ea :dword :base y
Loading
Loading full blame...