Skip to content
Snippets Groups Projects
float.lisp 64.9 KiB
Newer Older
ram's avatar
ram committed
;;; -*- 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 $")
ram's avatar
ram committed
;;;
;;; **********************************************************************
;;;
;;; 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.
ram's avatar
ram committed
;;;

ram's avatar
ram committed


(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)))

ram's avatar
ram committed

;;;; 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))))
ram's avatar
ram committed

(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))))
ram's avatar
ram committed

;;; 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))
ram's avatar
ram committed
	      ((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))
ram's avatar
ram committed
	      ((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))))
ram's avatar
ram committed
  (: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...