7
7
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
10
"$Header: /project/cmucl/cvsroot/src/compiler/x86/float.lisp,v 1.44 2006/07/19 02:54:31 rtoy Exp $")
10
"$Header: /project/cmucl/cvsroot/src/compiler/x86/float.lisp,v 1.56 2008/02/04 20:33:22 rtoy Exp $")
12
12
;;; **********************************************************************
161
161
;;; The x86 can't store a long-float to memory without popping the
162
162
;;; stack and marking a register as empty, so it is necessary to
163
163
;;; restore the register from memory.
165
164
(defun store-long-float (ea)
844
843
(define-vop (move-complex-double-double-float-argument)
845
844
(:args (x :scs (complex-double-double-reg) :target y)
846
(nfp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg))))
845
(fp :scs (any-reg) :load-if (not (sc-is y complex-double-double-reg))))
848
847
(:note "complex double-double-float argument move")
883
882
(complex-double-double-stack
884
883
(let ((real-tn (complex-double-double-reg-real-hi-tn x)))
885
884
(cond ((zerop (tn-offset real-tn))
886
(inst fstd (ea-for-cddf-real-hi-stack y)))
885
(inst fstd (ea-for-cddf-real-hi-stack y fp)))
888
887
(inst fxch real-tn)
889
(inst fstd (ea-for-cddf-real-hi-stack y))
888
(inst fstd (ea-for-cddf-real-hi-stack y fp))
890
889
(inst fxch real-tn))))
891
(let ((real-tn (complex-double-double-reg-real-hi-tn x)))
890
(let ((real-tn (complex-double-double-reg-real-lo-tn x)))
892
891
(cond ((zerop (tn-offset real-tn))
893
(inst fstd (ea-for-cddf-real-lo-stack y)))
892
(inst fstd (ea-for-cddf-real-lo-stack y fp)))
895
894
(inst fxch real-tn)
896
(inst fstd (ea-for-cddf-real-lo-stack y))
895
(inst fstd (ea-for-cddf-real-lo-stack y fp))
897
896
(inst fxch real-tn))))
898
897
(let ((imag-tn (complex-double-double-reg-imag-hi-tn x)))
899
898
(inst fxch imag-tn)
900
(inst fstd (ea-for-cddf-imag-hi-stack y))
899
(inst fstd (ea-for-cddf-imag-hi-stack y fp))
901
900
(inst fxch imag-tn))
902
901
(let ((imag-tn (complex-double-double-reg-imag-lo-tn x)))
903
902
(inst fxch imag-tn)
904
(inst fstd (ea-for-cddf-imag-lo-stack y))
903
(inst fstd (ea-for-cddf-imag-lo-stack y fp))
905
904
(inst fxch imag-tn))))
920
919
;;;; Arithmetic VOPs:
922
;; Save the top-of-stack to memory and reload it. This ensures that
923
;; the stack top has the desired precision.
924
(defmacro save-and-reload-tos (tmp)
922
929
;;; dtc: The floating point arithmetic vops.
924
931
;;; Note: Although these can accept x and y on the stack or pointed to
963
970
(:temporary (:sc single-reg :offset fr0-offset
964
971
:from :eval :to :result) fr0)
972
(:temporary (:sc single-stack) tmp)
965
973
(:results (r :scs (single-reg single-stack)))
966
974
(:arg-types single-float single-float)
967
975
(:result-types single-float)
976
984
;; x, y, and r are the same register.
977
985
((and (sc-is x single-reg) (location= x r) (location= y r))
978
986
(cond ((zerop (tn-offset r))
988
(save-and-reload-tos tmp))
992
(save-and-reload-tos tmp)
983
993
;; XX the source register will not be valid.
984
994
(note-next-instruction vop :internal-error)
1009
1019
(inst fld (ea-for-sf-desc y)))))
1010
1020
;; ST(i) = ST(i) op ST0
1011
1021
(inst ,fop-sti r)))
1022
(unless (zerop (tn-offset r))
1024
(save-and-reload-tos tmp)
1025
(unless (zerop (tn-offset r))
1012
1027
(when (policy node (or (= debug 3) (> safety speed)))
1013
(note-next-instruction vop :internal-error)
1028
(note-next-instruction vop :internal-error)
1015
1030
;; y and r are the same register.
1016
1031
((and (sc-is y single-reg) (location= y r))
1017
1032
(cond ((zerop (tn-offset r))
1037
1052
(inst fld (ea-for-sf-desc x)))))
1038
1053
;; ST(i) = ST(0) op ST(i)
1039
1054
(inst ,fopr-sti r)))
1056
(unless (zerop (tn-offset r))
1058
(save-and-reload-tos tmp)
1059
(unless (zerop (tn-offset r))
1040
1061
(when (policy node (or (= debug 3) (> safety speed)))
1041
(note-next-instruction vop :internal-error)
1062
(note-next-instruction vop :internal-error)
1043
1064
;; The default case
1045
1066
;; Get the result to ST0.
1858
1880
(with-empty-tn@fp-top(y)
1859
1881
(note-this-location vop :internal-error)
1860
1882
(inst fild x))))))))
1861
1884
(frob %single-float/signed %single-float single-reg single-float)
1862
1885
(frob %double-float/signed %double-float double-reg double-float)
1864
1887
(frob %long-float/signed %long-float long-reg long-float))
1889
(define-vop (%single-float/signed)
1890
(:args (x :scs (signed-stack signed-reg) :target temp))
1891
(:temporary (:sc signed-stack) temp)
1892
(:temporary (:sc single-stack) sf-temp)
1893
(:results (y :scs (single-reg)))
1894
(:arg-types signed-num)
1895
(:result-types single-float)
1896
(:policy :fast-safe)
1897
(:note "inline float coercion")
1898
(:translate %single-float)
1900
(:save-p :compute-only)
1905
(with-empty-tn@fp-top(y)
1906
(note-this-location vop :internal-error)
1909
(inst fld sf-temp)))
1911
(with-empty-tn@fp-top(y)
1912
(note-this-location vop :internal-error)
1915
(inst fld sf-temp))))))
1866
1917
(macrolet ((frob (name translate to-sc to-type)
1867
1918
`(define-vop (,name)
1868
1919
(:args (x :scs (unsigned-reg)))
1881
1932
(note-this-location vop :internal-error)
1882
1933
(inst fildl (make-ea :dword :base esp-tn)))
1883
1934
(inst add esp-tn 8)))))
1884
1936
(frob %single-float/unsigned %single-float single-reg single-float)
1885
1937
(frob %double-float/unsigned %double-float double-reg double-float)
1887
1939
(frob %long-float/unsigned %long-float long-reg long-float))
1942
(define-vop (%single-float/unsigned)
1943
(:args (x :scs (unsigned-reg)))
1944
(:results (y :scs (single-reg)))
1945
(:arg-types unsigned-num)
1946
(:result-types single-float)
1947
(:policy :fast-safe)
1948
(:note "inline float coercion")
1949
(:translate %single-float)
1951
(:save-p :compute-only)
1955
(with-empty-tn@fp-top(y)
1956
(note-this-location vop :internal-error)
1957
(inst fildl (make-ea :dword :base esp-tn))
1958
(inst fstp (make-ea :dword :base esp-tn))
1959
(inst fld (make-ea :dword :base esp-tn)))
1960
(inst add esp-tn 8)))
1889
1962
;;; These should be no-ops but the compiler might want to move
1890
1963
;;; some things around
1891
1964
(macrolet ((frob (name translate from-sc from-type to-sc to-type)
1933
2007
(frob %long-float/double-float %long-float double-reg double-float
1934
2008
long-reg long-float))
2010
(define-vop (%single-float/double-float)
2011
(:args (x :scs (double-reg) :target y))
2012
(:results (y :scs (single-reg)))
2013
(:arg-types double-float)
2014
(:result-types single-float)
2015
(:policy :fast-safe)
2016
(:note "inline float coercion")
2017
(:translate %single-float)
2018
(:temporary (:sc single-stack) sf-temp)
2020
(:save-p :compute-only)
2022
(note-this-location vop :internal-error)
2024
((zerop (tn-offset x))
2026
((zerop (tn-offset y))
2027
;; x is in ST0, y is also in ST0
2031
;; x is in ST0, y is in another reg. not ST0
2032
;; Save st0 (x) to memory, swap, reload, then swap back.
2038
((zerop (tn-offset y))
2039
;; y is in ST0, x is in another reg. not ST0
2040
;; Swap, save x to memory, reload, swap back
2046
;; Neither x or y are in ST0, and they are not in
2049
;; Get x to st0. Store it away. Swap back. Get y to st0,
1938
2059
(macrolet ((frob (trans from-sc from-type round-p)
1939
2060
`(define-vop (,(symbolicate trans "/" from-type))
2268
2389
;;;; Float mode hackery:
2270
(deftype float-modes () '(unsigned-byte 32)) ; really only 16
2391
(deftype float-modes () '(unsigned-byte 24))
2271
2392
(defknown floating-point-modes () float-modes (flushable))
2272
2393
(defknown ((setf floating-point-modes)) (float-modes)
2275
(defconstant npx-env-size (* 7 vm:word-bytes))
2276
(defconstant npx-cw-offset 0)
2277
(defconstant npx-sw-offset 4)
2279
2396
(define-vop (floating-point-modes)
2280
2397
(:results (res :scs (unsigned-reg)))
2281
2398
(:result-types unsigned-num)
2282
2399
(:translate floating-point-modes)
2283
2400
(:policy :fast-safe)
2284
(:temporary (:sc unsigned-reg :offset eax-offset :target res
2401
(:temporary (:sc unsigned-stack) cw-stack)
2402
(:temporary (:sc unsigned-reg :offset eax-offset) sw-reg)
2287
(inst sub esp-tn npx-env-size) ; make space on stack
2288
(inst wait) ; Catch any pending FPE exceptions
2289
(inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
2290
(inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state
2291
;; Current status to high word
2292
(inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
2293
;; Exception mask to low word
2294
(inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
2295
(inst add esp-tn npx-env-size) ; Pop stack
2296
(inst xor eax #x3f) ; Flip exception mask to trap enable bits
2405
(inst fnstcw cw-stack)
2406
(inst and sw-reg #xff) ; mask exception flags
2407
(inst shl sw-reg 16)
2408
(inst byte #x66) ; operand size prefix
2409
(inst or sw-reg cw-stack)
2410
(inst xor sw-reg #x3f) ; invert exception mask
2299
2413
(define-vop (set-floating-point-modes)
2300
2414
(:args (new :scs (unsigned-reg) :to :result :target res))
2303
2417
(:result-types unsigned-num)
2304
2418
(:translate (setf floating-point-modes))
2305
2419
(:policy :fast-safe)
2306
(:temporary (:sc unsigned-reg :offset eax-offset
2307
:from :eval :to :result) eax)
2309
(inst sub esp-tn npx-env-size) ; make space on stack
2310
(inst wait) ; Catch any pending FPE exceptions
2420
(:temporary (:sc unsigned-stack) cw-stack)
2421
(:temporary (:sc byte-reg :offset al-offset) sw-reg)
2422
(:temporary (:sc unsigned-reg :offset ecx-offset) old)
2424
(inst mov cw-stack new)
2425
(inst xor cw-stack #x3f) ; invert exception mask
2427
(inst fldcw cw-stack) ; always update the control word
2430
(inst cmp cl-tn sw-reg) ; compare exception flags
2431
(inst jmp :z DONE) ; skip updating the status word
2432
(inst sub esp-tn 28)
2311
2433
(inst fstenv (make-ea :dword :base esp-tn))
2313
(inst xor eax #x3f) ; turn trap enable bits into exception mask
2314
(inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
2315
(inst shr eax 16) ; position status word
2316
(inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
2434
(inst mov (make-ea :byte :base esp-tn :disp 4) cl-tn)
2317
2435
(inst fldenv (make-ea :dword :base esp-tn))
2318
(inst add esp-tn npx-env-size) ; Pop stack
2436
(inst add esp-tn 28)
2319
2438
(move res new)))
5110
5229
(define-vop (make-complex-double-double-float)
5111
5230
(:translate complex)
5112
5231
(:args (real :scs (double-double-reg) :target r
5113
:load-if (not (location= real r)))
5232
:load-if (not (location= real r))
5114
5234
(imag :scs (double-double-reg) :to :save))
5115
5235
(:arg-types double-double-float double-double-float)
5116
5236
(:results (r :scs (complex-double-double-reg) :from (:argument 0)
5169
5289
(inst fxch real)
5170
5290
(inst fstd (ea-for-cddf-real-hi-stack r))
5171
5291
(inst fxch real))))
5172
(cond ((zerop (tn-offset real))
5292
(let ((real-lo (double-double-reg-lo-tn real)))
5293
(cond ((zerop (tn-offset real-lo))
5173
5294
(inst fstd (ea-for-cddf-real-lo-stack r)))
5176
5297
(inst fstd (ea-for-cddf-real-lo-stack r))
5178
(let ((imag-val (complex-double-double-reg-imag-hi-tn imag)))
5298
(inst fxch real-lo))))
5299
(let ((imag-val (double-double-reg-hi-tn imag)))
5179
5300
(inst fxch imag-val)
5180
5301
(inst fstd (ea-for-cddf-imag-hi-stack r))
5181
5302
(inst fxch imag-val))
5182
(let ((imag-val (complex-double-double-reg-imag-lo-tn imag)))
5303
(let ((imag-val (double-double-reg-lo-tn imag)))
5183
5304
(inst fxch imag-val)
5184
5305
(inst fstd (ea-for-cddf-imag-lo-stack r))
5185
5306
(inst fxch imag-val))))))
5187
5308
(define-vop (complex-double-double-float-value)
5188
(:args (x :scs (complex-double-double-reg) :target r
5309
(:args (x :scs (complex-double-double-reg descriptor-reg) :target r
5189
5310
:load-if (not (sc-is x complex-double-double-stack))))
5190
5311
(:arg-types complex-double-double-float)
5191
5312
(:results (r :scs (double-double-reg)))
5224
5345
(complex-double-double-stack
5225
5346
(let ((r-hi (double-double-reg-hi-tn r)))
5226
5347
(with-empty-tn@fp-top (r-hi)
5227
(inst fld (ecase slot
5348
(inst fldd (ecase slot
5228
5349
(:real (ea-for-cddf-real-hi-stack x))
5229
5350
(:imag (ea-for-cddf-imag-hi-stack x))))))
5230
5351
(let ((r-lo (double-double-reg-lo-tn r)))
5231
5352
(with-empty-tn@fp-top (r-lo)
5232
(inst fld (ecase slot
5353
(inst fldd (ecase slot
5233
5354
(:real (ea-for-cddf-real-lo-stack x))
5234
(:imag (ea-for-cddf-imag-lo-stack x))))))))))
5355
(:imag (ea-for-cddf-imag-lo-stack x)))))))
5357
(let ((r-hi (double-double-reg-hi-tn r)))
5358
(with-empty-tn@fp-top (r-hi)
5359
(inst fldd (ecase slot
5360
(:real (ea-for-cddf-real-hi-desc x))
5361
(:imag (ea-for-cddf-imag-hi-desc x))))))
5362
(let ((r-lo (double-double-reg-lo-tn r)))
5363
(with-empty-tn@fp-top (r-lo)
5364
(inst fldd (ecase slot
5365
(:real (ea-for-cddf-real-lo-desc x))
5366
(:imag (ea-for-cddf-imag-lo-desc x))))))))))
5236
5368
(define-vop (realpart/complex-double-double-float complex-double-double-float-value)
5237
5369
(:translate realpart)
added
removed
src/compiler/x86/float.lisp
