1;;;; floating point support for the x86 2 3;;;; This software is part of the SBCL system. See the README file for 4;;;; more information. 5;;;; 6;;;; This software is derived from the CMU CL system, which was 7;;;; written at Carnegie Mellon University and released into the 8;;;; public domain. The software is in the public domain and is 9;;;; provided with absolutely no warranty. See the COPYING and CREDITS 10;;;; files for more information. 11 12(in-package "SB!VM") 13 14(macrolet ((ea-for-xf-desc (tn slot) 15 `(make-ea-for-object-slot ,tn ,slot other-pointer-lowtag))) 16 (defun ea-for-sf-desc (tn) 17 (ea-for-xf-desc tn single-float-value-slot)) 18 (defun ea-for-df-desc (tn) 19 (ea-for-xf-desc tn double-float-value-slot)) 20 #!+long-float 21 (defun ea-for-lf-desc (tn) 22 (ea-for-xf-desc tn long-float-value-slot)) 23 ;; complex floats 24 (defun ea-for-csf-real-desc (tn) 25 (ea-for-xf-desc tn complex-single-float-real-slot)) 26 (defun ea-for-csf-imag-desc (tn) 27 (ea-for-xf-desc tn complex-single-float-imag-slot)) 28 (defun ea-for-cdf-real-desc (tn) 29 (ea-for-xf-desc tn complex-double-float-real-slot)) 30 (defun ea-for-cdf-imag-desc (tn) 31 (ea-for-xf-desc tn complex-double-float-imag-slot)) 32 #!+long-float 33 (defun ea-for-clf-real-desc (tn) 34 (ea-for-xf-desc tn complex-long-float-real-slot)) 35 #!+long-float 36 (defun ea-for-clf-imag-desc (tn) 37 (ea-for-xf-desc tn complex-long-float-imag-slot))) 38 39(macrolet ((ea-for-xf-stack (tn kind) 40 `(make-ea 41 :dword :base ebp-tn 42 :disp (frame-byte-offset 43 (+ (tn-offset ,tn) 44 (ecase ,kind (:single 0) (:double 1) (:long 2))))))) 45 (defun ea-for-sf-stack (tn) 46 (ea-for-xf-stack tn :single)) 47 (defun ea-for-df-stack (tn) 48 (ea-for-xf-stack tn :double)) 49 #!+long-float 50 (defun ea-for-lf-stack (tn) 51 (ea-for-xf-stack tn :long))) 52 53;;; Telling the FPU to wait is required in order to make signals occur 54;;; at the expected place, but naturally slows things down. 55;;; 56;;; NODE is the node whose compilation policy controls the decision 57;;; whether to just blast through carelessly or carefully emit wait 58;;; instructions and whatnot. 59;;; 60;;; NOTE-NEXT-INSTRUCTION, if supplied, is to be passed to 61;;; #'NOTE-NEXT-INSTRUCTION. 62;;; 63;;; Until 2004-03-15, the implementation of this was buggy; it 64;;; unconditionally emitted the WAIT instruction. It turns out that 65;;; this is the right thing to do anyway; omitting them can lead to 66;;; system corruption on conforming code. -- CSR 67(defun maybe-fp-wait (node &optional note-next-instruction) 68 (declare (ignore node)) 69 #+nil 70 (when (policy node (or (= debug 3) (> safety speed)))) 71 (when note-next-instruction 72 (note-next-instruction note-next-instruction :internal-error)) 73 (inst wait)) 74 75;;; complex float stack EAs 76(macrolet ((ea-for-cxf-stack (tn kind slot &optional base) 77 `(make-ea 78 :dword :base ,base 79 :disp (frame-byte-offset 80 (+ (tn-offset ,tn) 81 -1 82 (* (ecase ,kind 83 (:single 1) 84 (:double 2) 85 (:long 3)) 86 (ecase ,slot (:real 1) (:imag 2)))))))) 87 (defun ea-for-csf-real-stack (tn &optional (base ebp-tn)) 88 (ea-for-cxf-stack tn :single :real base)) 89 (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn)) 90 (ea-for-cxf-stack tn :single :imag base)) 91 (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn)) 92 (ea-for-cxf-stack tn :double :real base)) 93 (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn)) 94 (ea-for-cxf-stack tn :double :imag base)) 95 #!+long-float 96 (defun ea-for-clf-real-stack (tn &optional (base ebp-tn)) 97 (ea-for-cxf-stack tn :long :real base)) 98 #!+long-float 99 (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn)) 100 (ea-for-cxf-stack tn :long :imag base))) 101 102;;; Abstract out the copying of a FP register to the FP stack top, and 103;;; provide two alternatives for its implementation. Note: it's not 104;;; necessary to distinguish between a single or double register move 105;;; here. 106;;; 107;;; Using a Pop then load. 108(defun copy-fp-reg-to-fr0 (reg) 109 (aver (not (zerop (tn-offset reg)))) 110 (inst fstp fr0-tn) 111 (inst fld (make-random-tn :kind :normal 112 :sc (sc-or-lose 'double-reg) 113 :offset (1- (tn-offset reg))))) 114;;; Using Fxch then Fst to restore the original reg contents. 115#+nil 116(defun copy-fp-reg-to-fr0 (reg) 117 (aver (not (zerop (tn-offset reg)))) 118 (inst fxch reg) 119 (inst fst reg)) 120 121;;; The x86 can't store a long-float to memory without popping the 122;;; stack and marking a register as empty, so it is necessary to 123;;; restore the register from memory. 124#!+long-float 125(defun store-long-float (ea) 126 (inst fstpl ea) 127 (inst fldl ea)) 128 129;;;; move functions 130 131;;; X is source, Y is destination. 132(define-move-fun (load-single 2) (vop x y) 133 ((single-stack) (single-reg)) 134 (with-empty-tn@fp-top(y) 135 (inst fld (ea-for-sf-stack x)))) 136 137(define-move-fun (store-single 2) (vop x y) 138 ((single-reg) (single-stack)) 139 (cond ((zerop (tn-offset x)) 140 (inst fst (ea-for-sf-stack y))) 141 (t 142 (inst fxch x) 143 (inst fst (ea-for-sf-stack y)) 144 ;; This may not be necessary as ST0 is likely invalid now. 145 (inst fxch x)))) 146 147(define-move-fun (load-double 2) (vop x y) 148 ((double-stack) (double-reg)) 149 (with-empty-tn@fp-top(y) 150 (inst fldd (ea-for-df-stack x)))) 151 152(define-move-fun (store-double 2) (vop x y) 153 ((double-reg) (double-stack)) 154 (cond ((zerop (tn-offset x)) 155 (inst fstd (ea-for-df-stack y))) 156 (t 157 (inst fxch x) 158 (inst fstd (ea-for-df-stack y)) 159 ;; This may not be necessary as ST0 is likely invalid now. 160 (inst fxch x)))) 161 162#!+long-float 163(define-move-fun (load-long 2) (vop x y) 164 ((long-stack) (long-reg)) 165 (with-empty-tn@fp-top(y) 166 (inst fldl (ea-for-lf-stack x)))) 167 168#!+long-float 169(define-move-fun (store-long 2) (vop x y) 170 ((long-reg) (long-stack)) 171 (cond ((zerop (tn-offset x)) 172 (store-long-float (ea-for-lf-stack y))) 173 (t 174 (inst fxch x) 175 (store-long-float (ea-for-lf-stack y)) 176 ;; This may not be necessary as ST0 is likely invalid now. 177 (inst fxch x)))) 178 179;;; The i387 has instructions to load some useful constants. This 180;;; doesn't save much time but might cut down on memory access and 181;;; reduce the size of the constant vector (CV). Intel claims they are 182;;; stored in a more precise form on chip. Anyhow, might as well use 183;;; the feature. It can be turned off by hacking the 184;;; "immediate-constant-sc" in vm.lisp. 185(eval-when (:compile-toplevel :execute) 186 (setf *read-default-float-format* 187 #!+long-float 'long-float #!-long-float 'double-float)) 188(define-move-fun (load-fp-constant 2) (vop x y) 189 ((fp-constant) (single-reg double-reg #!+long-float long-reg)) 190 (let ((value (tn-value x))) 191 (with-empty-tn@fp-top(y) 192 (cond ((or (eql value 0f0) (eql value 0d0) #!+long-float (eql value 0l0)) 193 (inst fldz)) 194 ((= value 1e0) 195 (inst fld1)) 196 #!+long-float 197 ((= value (coerce pi *read-default-float-format*)) 198 (inst fldpi)) 199 #!+long-float 200 ((= value (log 10e0 2e0)) 201 (inst fldl2t)) 202 #!+long-float 203 ((= value (log 2.718281828459045235360287471352662e0 2e0)) 204 (inst fldl2e)) 205 #!+long-float 206 ((= value (log 2e0 10e0)) 207 (inst fldlg2)) 208 #!+long-float 209 ((= value (log 2e0 2.718281828459045235360287471352662e0)) 210 (inst fldln2)) 211 (t (warn "ignoring bogus i387 constant ~A" value)))))) 212 213(define-move-fun (load-fp-immediate 2) (vop x y) 214 ((fp-single-immediate) (single-reg) 215 (fp-double-immediate) (double-reg)) 216 (let ((value (register-inline-constant (tn-value x)))) 217 (with-empty-tn@fp-top(y) 218 (sc-case y 219 (single-reg 220 (inst fld value)) 221 (double-reg 222 (inst fldd value)))))) 223(eval-when (:compile-toplevel :execute) 224 (setf *read-default-float-format* 'single-float)) 225 226;;;; complex float move functions 227 228(defun complex-single-reg-real-tn (x) 229 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) 230 :offset (tn-offset x))) 231(defun complex-single-reg-imag-tn (x) 232 (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) 233 :offset (1+ (tn-offset x)))) 234 235(defun complex-double-reg-real-tn (x) 236 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) 237 :offset (tn-offset x))) 238(defun complex-double-reg-imag-tn (x) 239 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) 240 :offset (1+ (tn-offset x)))) 241 242#!+long-float 243(defun complex-long-reg-real-tn (x) 244 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg) 245 :offset (tn-offset x))) 246#!+long-float 247(defun complex-long-reg-imag-tn (x) 248 (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg) 249 :offset (1+ (tn-offset x)))) 250 251;;; X is source, Y is destination. 252(define-move-fun (load-complex-single 2) (vop x y) 253 ((complex-single-stack) (complex-single-reg)) 254 (let ((real-tn (complex-single-reg-real-tn y))) 255 (with-empty-tn@fp-top (real-tn) 256 (inst fld (ea-for-csf-real-stack x)))) 257 (let ((imag-tn (complex-single-reg-imag-tn y))) 258 (with-empty-tn@fp-top (imag-tn) 259 (inst fld (ea-for-csf-imag-stack x))))) 260 261(define-move-fun (store-complex-single 2) (vop x y) 262 ((complex-single-reg) (complex-single-stack)) 263 (let ((real-tn (complex-single-reg-real-tn x))) 264 (cond ((zerop (tn-offset real-tn)) 265 (inst fst (ea-for-csf-real-stack y))) 266 (t 267 (inst fxch real-tn) 268 (inst fst (ea-for-csf-real-stack y)) 269 (inst fxch real-tn)))) 270 (let ((imag-tn (complex-single-reg-imag-tn x))) 271 (inst fxch imag-tn) 272 (inst fst (ea-for-csf-imag-stack y)) 273 (inst fxch imag-tn))) 274 275(define-move-fun (load-complex-double 2) (vop x y) 276 ((complex-double-stack) (complex-double-reg)) 277 (let ((real-tn (complex-double-reg-real-tn y))) 278 (with-empty-tn@fp-top(real-tn) 279 (inst fldd (ea-for-cdf-real-stack x)))) 280 (let ((imag-tn (complex-double-reg-imag-tn y))) 281 (with-empty-tn@fp-top(imag-tn) 282 (inst fldd (ea-for-cdf-imag-stack x))))) 283 284(define-move-fun (store-complex-double 2) (vop x y) 285 ((complex-double-reg) (complex-double-stack)) 286 (let ((real-tn (complex-double-reg-real-tn x))) 287 (cond ((zerop (tn-offset real-tn)) 288 (inst fstd (ea-for-cdf-real-stack y))) 289 (t 290 (inst fxch real-tn) 291 (inst fstd (ea-for-cdf-real-stack y)) 292 (inst fxch real-tn)))) 293 (let ((imag-tn (complex-double-reg-imag-tn x))) 294 (inst fxch imag-tn) 295 (inst fstd (ea-for-cdf-imag-stack y)) 296 (inst fxch imag-tn))) 297 298#!+long-float 299(define-move-fun (load-complex-long 2) (vop x y) 300 ((complex-long-stack) (complex-long-reg)) 301 (let ((real-tn (complex-long-reg-real-tn y))) 302 (with-empty-tn@fp-top(real-tn) 303 (inst fldl (ea-for-clf-real-stack x)))) 304 (let ((imag-tn (complex-long-reg-imag-tn y))) 305 (with-empty-tn@fp-top(imag-tn) 306 (inst fldl (ea-for-clf-imag-stack x))))) 307 308#!+long-float 309(define-move-fun (store-complex-long 2) (vop x y) 310 ((complex-long-reg) (complex-long-stack)) 311 (let ((real-tn (complex-long-reg-real-tn x))) 312 (cond ((zerop (tn-offset real-tn)) 313 (store-long-float (ea-for-clf-real-stack y))) 314 (t 315 (inst fxch real-tn) 316 (store-long-float (ea-for-clf-real-stack y)) 317 (inst fxch real-tn)))) 318 (let ((imag-tn (complex-long-reg-imag-tn x))) 319 (inst fxch imag-tn) 320 (store-long-float (ea-for-clf-imag-stack y)) 321 (inst fxch imag-tn))) 322 323 324;;;; move VOPs 325 326;;; float register to register moves 327(define-vop (float-move) 328 (:args (x)) 329 (:results (y)) 330 (:note "float move") 331 (:generator 0 332 (unless (location= x y) 333 (cond ((zerop (tn-offset y)) 334 (copy-fp-reg-to-fr0 x)) 335 ((zerop (tn-offset x)) 336 (inst fstd y)) 337 (t 338 (inst fxch x) 339 (inst fstd y) 340 (inst fxch x)))))) 341 342(define-vop (single-move float-move) 343 (:args (x :scs (single-reg) :target y :load-if (not (location= x y)))) 344 (:results (y :scs (single-reg) :load-if (not (location= x y))))) 345(define-move-vop single-move :move (single-reg) (single-reg)) 346 347(define-vop (double-move float-move) 348 (:args (x :scs (double-reg) :target y :load-if (not (location= x y)))) 349 (:results (y :scs (double-reg) :load-if (not (location= x y))))) 350(define-move-vop double-move :move (double-reg) (double-reg)) 351 352#!+long-float 353(define-vop (long-move float-move) 354 (:args (x :scs (long-reg) :target y :load-if (not (location= x y)))) 355 (:results (y :scs (long-reg) :load-if (not (location= x y))))) 356#!+long-float 357(define-move-vop long-move :move (long-reg) (long-reg)) 358 359;;; complex float register to register moves 360(define-vop (complex-float-move) 361 (:args (x :target y :load-if (not (location= x y)))) 362 (:results (y :load-if (not (location= x y)))) 363 (:note "complex float move") 364 (:generator 0 365 (unless (location= x y) 366 ;; Note the complex-float-regs are aligned to every second 367 ;; float register so there is not need to worry about overlap. 368 (let ((x-real (complex-double-reg-real-tn x)) 369 (y-real (complex-double-reg-real-tn y))) 370 (cond ((zerop (tn-offset y-real)) 371 (copy-fp-reg-to-fr0 x-real)) 372 ((zerop (tn-offset x-real)) 373 (inst fstd y-real)) 374 (t 375 (inst fxch x-real) 376 (inst fstd y-real) 377 (inst fxch x-real)))) 378 (let ((x-imag (complex-double-reg-imag-tn x)) 379 (y-imag (complex-double-reg-imag-tn y))) 380 (inst fxch x-imag) 381 (inst fstd y-imag) 382 (inst fxch x-imag))))) 383 384(define-vop (complex-single-move complex-float-move) 385 (:args (x :scs (complex-single-reg) :target y 386 :load-if (not (location= x y)))) 387 (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))) 388(define-move-vop complex-single-move :move 389 (complex-single-reg) (complex-single-reg)) 390 391(define-vop (complex-double-move complex-float-move) 392 (:args (x :scs (complex-double-reg) 393 :target y :load-if (not (location= x y)))) 394 (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))) 395(define-move-vop complex-double-move :move 396 (complex-double-reg) (complex-double-reg)) 397 398#!+long-float 399(define-vop (complex-long-move complex-float-move) 400 (:args (x :scs (complex-long-reg) 401 :target y :load-if (not (location= x y)))) 402 (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))) 403#!+long-float 404(define-move-vop complex-long-move :move 405 (complex-long-reg) (complex-long-reg)) 406 407;;; Move from float to a descriptor reg. allocating a new float 408;;; object in the process. 409(define-vop (move-from-single) 410 (:args (x :scs (single-reg) :to :save)) 411 (:results (y :scs (descriptor-reg))) 412 (:node-var node) 413 (:note "float to pointer coercion") 414 (:generator 13 415 (with-fixed-allocation (y 416 single-float-widetag 417 single-float-size node) 418 ;; w-f-a checks for empty body 419 nil) 420 (with-tn@fp-top(x) 421 (inst fst (ea-for-sf-desc y))))) 422(define-move-vop move-from-single :move 423 (single-reg) (descriptor-reg)) 424 425(define-vop (move-from-double) 426 (:args (x :scs (double-reg) :to :save)) 427 (:results (y :scs (descriptor-reg))) 428 (:node-var node) 429 (:note "float to pointer coercion") 430 (:generator 13 431 (with-fixed-allocation (y 432 double-float-widetag 433 double-float-size 434 node) 435 nil) 436 (with-tn@fp-top(x) 437 (inst fstd (ea-for-df-desc y))))) 438(define-move-vop move-from-double :move 439 (double-reg) (descriptor-reg)) 440 441#!+long-float 442(define-vop (move-from-long) 443 (:args (x :scs (long-reg) :to :save)) 444 (:results (y :scs (descriptor-reg))) 445 (:node-var node) 446 (:note "float to pointer coercion") 447 (:generator 13 448 (with-fixed-allocation (y 449 long-float-widetag 450 long-float-size 451 node) 452 nil) 453 (with-tn@fp-top(x) 454 (store-long-float (ea-for-lf-desc y))))) 455#!+long-float 456(define-move-vop move-from-long :move 457 (long-reg) (descriptor-reg)) 458 459(define-vop (move-from-fp-constant) 460 (:args (x :scs (fp-constant))) 461 (:results (y :scs (descriptor-reg))) 462 (:generator 2 463 (ecase (sb!c::constant-value (sb!c::tn-leaf x)) 464 (0f0 (load-symbol-value y *fp-constant-0f0*)) 465 (1f0 (load-symbol-value y *fp-constant-1f0*)) 466 (0d0 (load-symbol-value y *fp-constant-0d0*)) 467 (1d0 (load-symbol-value y *fp-constant-1d0*)) 468 #!+long-float 469 (0l0 (load-symbol-value y *fp-constant-0l0*)) 470 #!+long-float 471 (1l0 (load-symbol-value y *fp-constant-1l0*)) 472 #!+long-float 473 (#.pi (load-symbol-value y *fp-constant-pi*)) 474 #!+long-float 475 (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*)) 476 #!+long-float 477 (#.(log 2.718281828459045235360287471352662L0 2l0) 478 (load-symbol-value y *fp-constant-l2e*)) 479 #!+long-float 480 (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*)) 481 #!+long-float 482 (#.(log 2l0 2.718281828459045235360287471352662L0) 483 (load-symbol-value y *fp-constant-ln2*))))) 484(define-move-vop move-from-fp-constant :move 485 (fp-constant) (descriptor-reg)) 486 487;;; Move from a descriptor to a float register. 488(define-vop (move-to-single) 489 (:args (x :scs (descriptor-reg))) 490 (:results (y :scs (single-reg))) 491 (:note "pointer to float coercion") 492 (:generator 2 493 (with-empty-tn@fp-top(y) 494 (inst fld (ea-for-sf-desc x))))) 495(define-move-vop move-to-single :move (descriptor-reg) (single-reg)) 496 497(define-vop (move-to-double) 498 (:args (x :scs (descriptor-reg))) 499 (:results (y :scs (double-reg))) 500 (:note "pointer to float coercion") 501 (:generator 2 502 (with-empty-tn@fp-top(y) 503 (inst fldd (ea-for-df-desc x))))) 504(define-move-vop move-to-double :move (descriptor-reg) (double-reg)) 505 506#!+long-float 507(define-vop (move-to-long) 508 (:args (x :scs (descriptor-reg))) 509 (:results (y :scs (long-reg))) 510 (:note "pointer to float coercion") 511 (:generator 2 512 (with-empty-tn@fp-top(y) 513 (inst fldl (ea-for-lf-desc x))))) 514#!+long-float 515(define-move-vop move-to-long :move (descriptor-reg) (long-reg)) 516 517;;; Move from complex float to a descriptor reg. allocating a new 518;;; complex float object in the process. 519(define-vop (move-from-complex-single) 520 (:args (x :scs (complex-single-reg) :to :save)) 521 (:results (y :scs (descriptor-reg))) 522 (:node-var node) 523 (:note "complex float to pointer coercion") 524 (:generator 13 525 (with-fixed-allocation (y 526 complex-single-float-widetag 527 complex-single-float-size 528 node) 529 (let ((real-tn (complex-single-reg-real-tn x))) 530 (with-tn@fp-top(real-tn) 531 (inst fst (ea-for-csf-real-desc y)))) 532 (let ((imag-tn (complex-single-reg-imag-tn x))) 533 (with-tn@fp-top(imag-tn) 534 (inst fst (ea-for-csf-imag-desc y))))))) 535(define-move-vop move-from-complex-single :move 536 (complex-single-reg) (descriptor-reg)) 537 538(define-vop (move-from-complex-double) 539 (:args (x :scs (complex-double-reg) :to :save)) 540 (:results (y :scs (descriptor-reg))) 541 (:node-var node) 542 (:note "complex float to pointer coercion") 543 (:generator 13 544 (with-fixed-allocation (y 545 complex-double-float-widetag 546 complex-double-float-size 547 node) 548 (let ((real-tn (complex-double-reg-real-tn x))) 549 (with-tn@fp-top(real-tn) 550 (inst fstd (ea-for-cdf-real-desc y)))) 551 (let ((imag-tn (complex-double-reg-imag-tn x))) 552 (with-tn@fp-top(imag-tn) 553 (inst fstd (ea-for-cdf-imag-desc y))))))) 554(define-move-vop move-from-complex-double :move 555 (complex-double-reg) (descriptor-reg)) 556 557#!+long-float 558(define-vop (move-from-complex-long) 559 (:args (x :scs (complex-long-reg) :to :save)) 560 (:results (y :scs (descriptor-reg))) 561 (:node-var node) 562 (:note "complex float to pointer coercion") 563 (:generator 13 564 (with-fixed-allocation (y 565 complex-long-float-widetag 566 complex-long-float-size 567 node) 568 (let ((real-tn (complex-long-reg-real-tn x))) 569 (with-tn@fp-top(real-tn) 570 (store-long-float (ea-for-clf-real-desc y)))) 571 (let ((imag-tn (complex-long-reg-imag-tn x))) 572 (with-tn@fp-top(imag-tn) 573 (store-long-float (ea-for-clf-imag-desc y))))))) 574#!+long-float 575(define-move-vop move-from-complex-long :move 576 (complex-long-reg) (descriptor-reg)) 577 578;;; Move from a descriptor to a complex float register. 579(macrolet ((frob (name sc format) 580 `(progn 581 (define-vop (,name) 582 (:args (x :scs (descriptor-reg))) 583 (:results (y :scs (,sc))) 584 (:note "pointer to complex float coercion") 585 (:generator 2 586 (let ((real-tn (complex-double-reg-real-tn y))) 587 (with-empty-tn@fp-top(real-tn) 588 ,@(ecase format 589 (:single '((inst fld (ea-for-csf-real-desc x)))) 590 (:double '((inst fldd (ea-for-cdf-real-desc x)))) 591 #!+long-float 592 (:long '((inst fldl (ea-for-clf-real-desc x))))))) 593 (let ((imag-tn (complex-double-reg-imag-tn y))) 594 (with-empty-tn@fp-top(imag-tn) 595 ,@(ecase format 596 (:single '((inst fld (ea-for-csf-imag-desc x)))) 597 (:double '((inst fldd (ea-for-cdf-imag-desc x)))) 598 #!+long-float 599 (:long '((inst fldl (ea-for-clf-imag-desc x))))))))) 600 (define-move-vop ,name :move (descriptor-reg) (,sc))))) 601 (frob move-to-complex-single complex-single-reg :single) 602 (frob move-to-complex-double complex-double-reg :double) 603 #!+long-float 604 (frob move-to-complex-double complex-long-reg :long)) 605 606;;;; the move argument vops 607;;;; 608;;;; Note these are also used to stuff fp numbers onto the c-call 609;;;; stack so the order is different than the lisp-stack. 610 611;;; the general MOVE-ARG VOP 612(macrolet ((frob (name sc stack-sc format) 613 `(progn 614 (define-vop (,name) 615 (:args (x :scs (,sc) :target y) 616 (fp :scs (any-reg) 617 :load-if (not (sc-is y ,sc)))) 618 (:results (y)) 619 (:note "float argument move") 620 (:generator ,(case format (:single 2) (:double 3) (:long 4)) 621 (sc-case y 622 (,sc 623 (unless (location= x y) 624 (cond ((zerop (tn-offset y)) 625 (copy-fp-reg-to-fr0 x)) 626 ((zerop (tn-offset x)) 627 (inst fstd y)) 628 (t 629 (inst fxch x) 630 (inst fstd y) 631 (inst fxch x))))) 632 (,stack-sc 633 (if (= (tn-offset fp) esp-offset) 634 ;; C-call 635 (let* ((offset (* (tn-offset y) n-word-bytes)) 636 (ea (make-ea :dword :base fp :disp offset))) 637 (with-tn@fp-top(x) 638 ,@(ecase format 639 (:single '((inst fst ea))) 640 (:double '((inst fstd ea))) 641 #!+long-float 642 (:long '((store-long-float ea)))))) 643 ;; Lisp stack 644 (let ((ea (make-ea 645 :dword :base fp 646 :disp (frame-byte-offset 647 (+ (tn-offset y) 648 ,(case format 649 (:single 0) 650 (:double 1) 651 (:long 2))))))) 652 (with-tn@fp-top(x) 653 ,@(ecase format 654 (:single '((inst fst ea))) 655 (:double '((inst fstd ea))) 656 #!+long-float 657 (:long '((store-long-float ea))))))))))) 658 (define-move-vop ,name :move-arg 659 (,sc descriptor-reg) (,sc))))) 660 (frob move-single-float-arg single-reg single-stack :single) 661 (frob move-double-float-arg double-reg double-stack :double) 662 #!+long-float 663 (frob move-long-float-arg long-reg long-stack :long)) 664 665;;;; complex float MOVE-ARG VOP 666(macrolet ((frob (name sc stack-sc format) 667 `(progn 668 (define-vop (,name) 669 (:args (x :scs (,sc) :target y) 670 (fp :scs (any-reg) 671 :load-if (not (sc-is y ,sc)))) 672 (:results (y)) 673 (:note "complex float argument move") 674 (:generator ,(ecase format (:single 2) (:double 3) (:long 4)) 675 (sc-case y 676 (,sc 677 (unless (location= x y) 678 (let ((x-real (complex-double-reg-real-tn x)) 679 (y-real (complex-double-reg-real-tn y))) 680 (cond ((zerop (tn-offset y-real)) 681 (copy-fp-reg-to-fr0 x-real)) 682 ((zerop (tn-offset x-real)) 683 (inst fstd y-real)) 684 (t 685 (inst fxch x-real) 686 (inst fstd y-real) 687 (inst fxch x-real)))) 688 (let ((x-imag (complex-double-reg-imag-tn x)) 689 (y-imag (complex-double-reg-imag-tn y))) 690 (inst fxch x-imag) 691 (inst fstd y-imag) 692 (inst fxch x-imag)))) 693 (,stack-sc 694 (let ((real-tn (complex-double-reg-real-tn x))) 695 (cond ((zerop (tn-offset real-tn)) 696 ,@(ecase format 697 (:single 698 '((inst fst 699 (ea-for-csf-real-stack y fp)))) 700 (:double 701 '((inst fstd 702 (ea-for-cdf-real-stack y fp)))) 703 #!+long-float 704 (:long 705 '((store-long-float 706 (ea-for-clf-real-stack y fp)))))) 707 (t 708 (inst fxch real-tn) 709 ,@(ecase format 710 (:single 711 '((inst fst 712 (ea-for-csf-real-stack y fp)))) 713 (:double 714 '((inst fstd 715 (ea-for-cdf-real-stack y fp)))) 716 #!+long-float 717 (:long 718 '((store-long-float 719 (ea-for-clf-real-stack y fp))))) 720 (inst fxch real-tn)))) 721 (let ((imag-tn (complex-double-reg-imag-tn x))) 722 (inst fxch imag-tn) 723 ,@(ecase format 724 (:single 725 '((inst fst (ea-for-csf-imag-stack y fp)))) 726 (:double 727 '((inst fstd (ea-for-cdf-imag-stack y fp)))) 728 #!+long-float 729 (:long 730 '((store-long-float 731 (ea-for-clf-imag-stack y fp))))) 732 (inst fxch imag-tn)))))) 733 (define-move-vop ,name :move-arg 734 (,sc descriptor-reg) (,sc))))) 735 (frob move-complex-single-float-arg 736 complex-single-reg complex-single-stack :single) 737 (frob move-complex-double-float-arg 738 complex-double-reg complex-double-stack :double) 739 #!+long-float 740 (frob move-complex-long-float-arg 741 complex-long-reg complex-long-stack :long)) 742 743(define-move-vop move-arg :move-arg 744 (single-reg double-reg #!+long-float long-reg 745 complex-single-reg complex-double-reg #!+long-float complex-long-reg) 746 (descriptor-reg)) 747 748 749;;;; arithmetic VOPs 750 751;;; dtc: the floating point arithmetic vops 752;;; 753;;; Note: Although these can accept x and y on the stack or pointed to 754;;; from a descriptor register, they will work with register loading 755;;; without these. Same deal with the result - it need only be a 756;;; register. When load-tns are needed they will probably be in ST0 757;;; and the code below should be able to correctly handle all cases. 758;;; 759;;; However it seems to produce better code if all arg. and result 760;;; options are used; on the P86 there is no extra cost in using a 761;;; memory operand to the FP instructions - not so on the PPro. 762;;; 763;;; It may also be useful to handle constant args? 764;;; 765;;; 22-Jul-97: descriptor args lose in some simple cases when 766;;; a function result computed in a loop. Then Python insists 767;;; on consing the intermediate values! For example 768;;; 769;;; (defun test(a n) 770;;; (declare (type (simple-array double-float (*)) a) 771;;; (fixnum n)) 772;;; (let ((sum 0d0)) 773;;; (declare (type double-float sum)) 774;;; (dotimes (i n) 775;;; (incf sum (* (aref a i)(aref a i)))) 776;;; sum)) 777;;; 778;;; So, disabling descriptor args until this can be fixed elsewhere. 779(macrolet 780 ((frob (op fop-sti fopr-sti 781 fop fopr sname scost 782 fopd foprd dname dcost 783 lname lcost) 784 #!-long-float (declare (ignore lcost lname)) 785 `(progn 786 (define-vop (,sname) 787 (:translate ,op) 788 (:args (x :scs (single-reg single-stack #+nil descriptor-reg) 789 :to :eval) 790 (y :scs (single-reg single-stack #+nil descriptor-reg) 791 :to :eval)) 792 (:temporary (:sc single-reg :offset fr0-offset 793 :from :eval :to :result) fr0) 794 (:results (r :scs (single-reg single-stack))) 795 (:arg-types single-float single-float) 796 (:result-types single-float) 797 (:policy :fast-safe) 798 (:note "inline float arithmetic") 799 (:vop-var vop) 800 (:save-p :compute-only) 801 (:node-var node) 802 (:generator ,scost 803 ;; Handle a few special cases 804 (cond 805 ;; x, y, and r are the same register. 806 ((and (sc-is x single-reg) (location= x r) (location= y r)) 807 (cond ((zerop (tn-offset r)) 808 (inst ,fop fr0)) 809 (t 810 (inst fxch r) 811 (inst ,fop fr0) 812 ;; XX the source register will not be valid. 813 (note-next-instruction vop :internal-error) 814 (inst fxch r)))) 815 816 ;; x and r are the same register. 817 ((and (sc-is x single-reg) (location= x r)) 818 (cond ((zerop (tn-offset r)) 819 (sc-case y 820 (single-reg 821 ;; ST(0) = ST(0) op ST(y) 822 (inst ,fop y)) 823 (single-stack 824 ;; ST(0) = ST(0) op Mem 825 (inst ,fop (ea-for-sf-stack y))) 826 (descriptor-reg 827 (inst ,fop (ea-for-sf-desc y))))) 828 (t 829 ;; y to ST0 830 (sc-case y 831 (single-reg 832 (unless (zerop (tn-offset y)) 833 (copy-fp-reg-to-fr0 y))) 834 ((single-stack descriptor-reg) 835 (inst fstp fr0) 836 (if (sc-is y single-stack) 837 (inst fld (ea-for-sf-stack y)) 838 (inst fld (ea-for-sf-desc y))))) 839 ;; ST(i) = ST(i) op ST0 840 (inst ,fop-sti r))) 841 (maybe-fp-wait node vop)) 842 ;; y and r are the same register. 843 ((and (sc-is y single-reg) (location= y r)) 844 (cond ((zerop (tn-offset r)) 845 (sc-case x 846 (single-reg 847 ;; ST(0) = ST(x) op ST(0) 848 (inst ,fopr x)) 849 (single-stack 850 ;; ST(0) = Mem op ST(0) 851 (inst ,fopr (ea-for-sf-stack x))) 852 (descriptor-reg 853 (inst ,fopr (ea-for-sf-desc x))))) 854 (t 855 ;; x to ST0 856 (sc-case x 857 (single-reg 858 (unless (zerop (tn-offset x)) 859 (copy-fp-reg-to-fr0 x))) 860 ((single-stack descriptor-reg) 861 (inst fstp fr0) 862 (if (sc-is x single-stack) 863 (inst fld (ea-for-sf-stack x)) 864 (inst fld (ea-for-sf-desc x))))) 865 ;; ST(i) = ST(0) op ST(i) 866 (inst ,fopr-sti r))) 867 (maybe-fp-wait node vop)) 868 ;; the default case 869 (t 870 ;; Get the result to ST0. 871 872 ;; Special handling is needed if x or y are in ST0, and 873 ;; simpler code is generated. 874 (cond 875 ;; x is in ST0 876 ((and (sc-is x single-reg) (zerop (tn-offset x))) 877 ;; ST0 = ST0 op y 878 (sc-case y 879 (single-reg 880 (inst ,fop y)) 881 (single-stack 882 (inst ,fop (ea-for-sf-stack y))) 883 (descriptor-reg 884 (inst ,fop (ea-for-sf-desc y))))) 885 ;; y is in ST0 886 ((and (sc-is y single-reg) (zerop (tn-offset y))) 887 ;; ST0 = x op ST0 888 (sc-case x 889 (single-reg 890 (inst ,fopr x)) 891 (single-stack 892 (inst ,fopr (ea-for-sf-stack x))) 893 (descriptor-reg 894 (inst ,fopr (ea-for-sf-desc x))))) 895 (t 896 ;; x to ST0 897 (sc-case x 898 (single-reg 899 (copy-fp-reg-to-fr0 x)) 900 (single-stack 901 (inst fstp fr0) 902 (inst fld (ea-for-sf-stack x))) 903 (descriptor-reg 904 (inst fstp fr0) 905 (inst fld (ea-for-sf-desc x)))) 906 ;; ST0 = ST0 op y 907 (sc-case y 908 (single-reg 909 (inst ,fop y)) 910 (single-stack 911 (inst ,fop (ea-for-sf-stack y))) 912 (descriptor-reg 913 (inst ,fop (ea-for-sf-desc y)))))) 914 915 (note-next-instruction vop :internal-error) 916 917 ;; Finally save the result. 918 (sc-case r 919 (single-reg 920 (cond ((zerop (tn-offset r)) 921 (maybe-fp-wait node)) 922 (t 923 (inst fst r)))) 924 (single-stack 925 (inst fst (ea-for-sf-stack r)))))))) 926 927 (define-vop (,dname) 928 (:translate ,op) 929 (:args (x :scs (double-reg double-stack #+nil descriptor-reg) 930 :to :eval) 931 (y :scs (double-reg double-stack #+nil descriptor-reg) 932 :to :eval)) 933 (:temporary (:sc double-reg :offset fr0-offset 934 :from :eval :to :result) fr0) 935 (:results (r :scs (double-reg double-stack))) 936 (:arg-types double-float double-float) 937 (:result-types double-float) 938 (:policy :fast-safe) 939 (:note "inline float arithmetic") 940 (:vop-var vop) 941 (:save-p :compute-only) 942 (:node-var node) 943 (:generator ,dcost 944 ;; Handle a few special cases. 945 (cond 946 ;; x, y, and r are the same register. 947 ((and (sc-is x double-reg) (location= x r) (location= y r)) 948 (cond ((zerop (tn-offset r)) 949 (inst ,fop fr0)) 950 (t 951 (inst fxch x) 952 (inst ,fopd fr0) 953 ;; XX the source register will not be valid. 954 (note-next-instruction vop :internal-error) 955 (inst fxch r)))) 956 957 ;; x and r are the same register. 958 ((and (sc-is x double-reg) (location= x r)) 959 (cond ((zerop (tn-offset r)) 960 (sc-case y 961 (double-reg 962 ;; ST(0) = ST(0) op ST(y) 963 (inst ,fopd y)) 964 (double-stack 965 ;; ST(0) = ST(0) op Mem 966 (inst ,fopd (ea-for-df-stack y))) 967 (descriptor-reg 968 (inst ,fopd (ea-for-df-desc y))))) 969 (t 970 ;; y to ST0 971 (sc-case y 972 (double-reg 973 (unless (zerop (tn-offset y)) 974 (copy-fp-reg-to-fr0 y))) 975 ((double-stack descriptor-reg) 976 (inst fstp fr0) 977 (if (sc-is y double-stack) 978 (inst fldd (ea-for-df-stack y)) 979 (inst fldd (ea-for-df-desc y))))) 980 ;; ST(i) = ST(i) op ST0 981 (inst ,fop-sti r))) 982 (maybe-fp-wait node vop)) 983 ;; y and r are the same register. 984 ((and (sc-is y double-reg) (location= y r)) 985 (cond ((zerop (tn-offset r)) 986 (sc-case x 987 (double-reg 988 ;; ST(0) = ST(x) op ST(0) 989 (inst ,foprd x)) 990 (double-stack 991 ;; ST(0) = Mem op ST(0) 992 (inst ,foprd (ea-for-df-stack x))) 993 (descriptor-reg 994 (inst ,foprd (ea-for-df-desc x))))) 995 (t 996 ;; x to ST0 997 (sc-case x 998 (double-reg 999 (unless (zerop (tn-offset x)) 1000 (copy-fp-reg-to-fr0 x))) 1001 ((double-stack descriptor-reg) 1002 (inst fstp fr0) 1003 (if (sc-is x double-stack) 1004 (inst fldd (ea-for-df-stack x)) 1005 (inst fldd (ea-for-df-desc x))))) 1006 ;; ST(i) = ST(0) op ST(i) 1007 (inst ,fopr-sti r))) 1008 (maybe-fp-wait node vop)) 1009 ;; the default case 1010 (t 1011 ;; Get the result to ST0. 1012 1013 ;; Special handling is needed if x or y are in ST0, and 1014 ;; simpler code is generated. 1015 (cond 1016 ;; x is in ST0 1017 ((and (sc-is x double-reg) (zerop (tn-offset x))) 1018 ;; ST0 = ST0 op y 1019 (sc-case y 1020 (double-reg 1021 (inst ,fopd y)) 1022 (double-stack 1023 (inst ,fopd (ea-for-df-stack y))) 1024 (descriptor-reg 1025 (inst ,fopd (ea-for-df-desc y))))) 1026 ;; y is in ST0 1027 ((and (sc-is y double-reg) (zerop (tn-offset y))) 1028 ;; ST0 = x op ST0 1029 (sc-case x 1030 (double-reg 1031 (inst ,foprd x)) 1032 (double-stack 1033 (inst ,foprd (ea-for-df-stack x))) 1034 (descriptor-reg 1035 (inst ,foprd (ea-for-df-desc x))))) 1036 (t 1037 ;; x to ST0 1038 (sc-case x 1039 (double-reg 1040 (copy-fp-reg-to-fr0 x)) 1041 (double-stack 1042 (inst fstp fr0) 1043 (inst fldd (ea-for-df-stack x))) 1044 (descriptor-reg 1045 (inst fstp fr0) 1046 (inst fldd (ea-for-df-desc x)))) 1047 ;; ST0 = ST0 op y 1048 (sc-case y 1049 (double-reg 1050 (inst ,fopd y)) 1051 (double-stack 1052 (inst ,fopd (ea-for-df-stack y))) 1053 (descriptor-reg 1054 (inst ,fopd (ea-for-df-desc y)))))) 1055 1056 (note-next-instruction vop :internal-error) 1057 1058 ;; Finally save the result. 1059 (sc-case r 1060 (double-reg 1061 (cond ((zerop (tn-offset r)) 1062 (maybe-fp-wait node)) 1063 (t 1064 (inst fst r)))) 1065 (double-stack 1066 (inst fstd (ea-for-df-stack r)))))))) 1067 1068 #!+long-float 1069 (define-vop (,lname) 1070 (:translate ,op) 1071 (:args (x :scs (long-reg) :to :eval) 1072 (y :scs (long-reg) :to :eval)) 1073 (:temporary (:sc long-reg :offset fr0-offset 1074 :from :eval :to :result) fr0) 1075 (:results (r :scs (long-reg))) 1076 (:arg-types long-float long-float) 1077 (:result-types long-float) 1078 (:policy :fast-safe) 1079 (:note "inline float arithmetic") 1080 (:vop-var vop) 1081 (:save-p :compute-only) 1082 (:node-var node) 1083 (:generator ,lcost 1084 ;; Handle a few special cases. 1085 (cond 1086 ;; x, y, and r are the same register. 1087 ((and (location= x r) (location= y r)) 1088 (cond ((zerop (tn-offset r)) 1089 (inst ,fop fr0)) 1090 (t 1091 (inst fxch x) 1092 (inst ,fopd fr0) 1093 ;; XX the source register will not be valid. 1094 (note-next-instruction vop :internal-error) 1095 (inst fxch r)))) 1096 1097 ;; x and r are the same register. 1098 ((location= x r) 1099 (cond ((zerop (tn-offset r)) 1100 ;; ST(0) = ST(0) op ST(y) 1101 (inst ,fopd y)) 1102 (t 1103 ;; y to ST0 1104 (unless (zerop (tn-offset y)) 1105 (copy-fp-reg-to-fr0 y)) 1106 ;; ST(i) = ST(i) op ST0 1107 (inst ,fop-sti r))) 1108 (maybe-fp-wait node vop)) 1109 ;; y and r are the same register. 1110 ((location= y r) 1111 (cond ((zerop (tn-offset r)) 1112 ;; ST(0) = ST(x) op ST(0) 1113 (inst ,foprd x)) 1114 (t 1115 ;; x to ST0 1116 (unless (zerop (tn-offset x)) 1117 (copy-fp-reg-to-fr0 x)) 1118 ;; ST(i) = ST(0) op ST(i) 1119 (inst ,fopr-sti r))) 1120 (maybe-fp-wait node vop)) 1121 ;; the default case 1122 (t 1123 ;; Get the result to ST0. 1124 1125 ;; Special handling is needed if x or y are in ST0, and 1126 ;; simpler code is generated. 1127 (cond 1128 ;; x is in ST0. 1129 ((zerop (tn-offset x)) 1130 ;; ST0 = ST0 op y 1131 (inst ,fopd y)) 1132 ;; y is in ST0 1133 ((zerop (tn-offset y)) 1134 ;; ST0 = x op ST0 1135 (inst ,foprd x)) 1136 (t 1137 ;; x to ST0 1138 (copy-fp-reg-to-fr0 x) 1139 ;; ST0 = ST0 op y 1140 (inst ,fopd y))) 1141 1142 (note-next-instruction vop :internal-error) 1143 1144 ;; Finally save the result. 1145 (cond ((zerop (tn-offset r)) 1146 (maybe-fp-wait node)) 1147 (t 1148 (inst fst r)))))))))) 1149 1150 (frob + fadd-sti fadd-sti 1151 fadd fadd +/single-float 2 1152 faddd faddd +/double-float 2 1153 +/long-float 2) 1154 (frob - fsub-sti fsubr-sti 1155 fsub fsubr -/single-float 2 1156 fsubd fsubrd -/double-float 2 1157 -/long-float 2) 1158 (frob * fmul-sti fmul-sti 1159 fmul fmul */single-float 3 1160 fmuld fmuld */double-float 3 1161 */long-float 3) 1162 (frob / fdiv-sti fdivr-sti 1163 fdiv fdivr //single-float 12 1164 fdivd fdivrd //double-float 12 1165 //long-float 12)) 1166 1167(macrolet ((frob (name inst translate sc type) 1168 `(define-vop (,name) 1169 (:args (x :scs (,sc) :target fr0)) 1170 (:results (y :scs (,sc))) 1171 (:translate ,translate) 1172 (:policy :fast-safe) 1173 (:arg-types ,type) 1174 (:result-types ,type) 1175 (:temporary (:sc double-reg :offset fr0-offset 1176 :from :argument :to :result) fr0) 1177 (:ignore fr0) 1178 (:note "inline float arithmetic") 1179 (:vop-var vop) 1180 (:save-p :compute-only) 1181 (:generator 1 1182 (note-this-location vop :internal-error) 1183 (unless (zerop (tn-offset x)) 1184 (inst fxch x) ; x to top of stack 1185 (unless (location= x y) 1186 (inst fst x))) ; Maybe save it. 1187 (inst ,inst) ; Clobber st0. 1188 (unless (zerop (tn-offset y)) 1189 (inst fst y)))))) 1190 1191 (frob abs/single-float fabs abs single-reg single-float) 1192 (frob abs/double-float fabs abs double-reg double-float) 1193 #!+long-float 1194 (frob abs/long-float fabs abs long-reg long-float) 1195 (frob %negate/single-float fchs %negate single-reg single-float) 1196 (frob %negate/double-float fchs %negate double-reg double-float) 1197 #!+long-float 1198 (frob %negate/long-float fchs %negate long-reg long-float)) 1199 1200;;;; comparison 1201 1202(define-vop (=/float) 1203 (:args (x) (y)) 1204 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 1205 (:conditional :e) 1206 (:policy :fast-safe) 1207 (:vop-var vop) 1208 (:save-p :compute-only) 1209 (:note "inline float comparison") 1210 (:ignore temp) 1211 (:generator 3 1212 (note-this-location vop :internal-error) 1213 (cond 1214 ;; x is in ST0; y is in any reg. 1215 ((zerop (tn-offset x)) 1216 (inst fucom y)) 1217 ;; y is in ST0; x is in another reg. 1218 ((zerop (tn-offset y)) 1219 (inst fucom x)) 1220 ;; x and y are the same register, not ST0 1221 ((location= x y) 1222 (inst fxch x) 1223 (inst fucom fr0-tn) 1224 (inst fxch x)) 1225 ;; x and y are different registers, neither ST0. 1226 (t 1227 (inst fxch x) 1228 (inst fucom y) 1229 (inst fxch x))) 1230 (inst fnstsw) ; status word to ax 1231 (inst and ah-tn #x45) ; C3 C2 C0 1232 (inst cmp ah-tn #x40))) 1233 1234(define-vop (=/single-float =/float) 1235 (:translate =) 1236 (:args (x :scs (single-reg)) 1237 (y :scs (single-reg))) 1238 (:arg-types single-float single-float)) 1239 1240(define-vop (=/double-float =/float) 1241 (:translate =) 1242 (:args (x :scs (double-reg)) 1243 (y :scs (double-reg))) 1244 (:arg-types double-float double-float)) 1245 1246#!+long-float 1247(define-vop (=/long-float =/float) 1248 (:translate =) 1249 (:args (x :scs (long-reg)) 1250 (y :scs (long-reg))) 1251 (:arg-types long-float long-float)) 1252 1253(define-vop (<single-float) 1254 (:translate <) 1255 (:args (x :scs (single-reg single-stack descriptor-reg)) 1256 (y :scs (single-reg single-stack descriptor-reg))) 1257 (:arg-types single-float single-float) 1258 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) 1259 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 1260 (:conditional :e) 1261 (:policy :fast-safe) 1262 (:note "inline float comparison") 1263 (:ignore temp) 1264 (:generator 3 1265 ;; Handle a few special cases. 1266 (cond 1267 ;; y is ST0. 1268 ((and (sc-is y single-reg) (zerop (tn-offset y))) 1269 (sc-case x 1270 (single-reg 1271 (inst fcom x)) 1272 ((single-stack descriptor-reg) 1273 (if (sc-is x single-stack) 1274 (inst fcom (ea-for-sf-stack x)) 1275 (inst fcom (ea-for-sf-desc x))))) 1276 (inst fnstsw) ; status word to ax 1277 (inst and ah-tn #x45)) 1278 1279 ;; general case when y is not in ST0 1280 (t 1281 ;; x to ST0 1282 (sc-case x 1283 (single-reg 1284 (unless (zerop (tn-offset x)) 1285 (copy-fp-reg-to-fr0 x))) 1286 ((single-stack descriptor-reg) 1287 (inst fstp fr0) 1288 (if (sc-is x single-stack) 1289 (inst fld (ea-for-sf-stack x)) 1290 (inst fld (ea-for-sf-desc x))))) 1291 (sc-case y 1292 (single-reg 1293 (inst fcom y)) 1294 ((single-stack descriptor-reg) 1295 (if (sc-is y single-stack) 1296 (inst fcom (ea-for-sf-stack y)) 1297 (inst fcom (ea-for-sf-desc y))))) 1298 (inst fnstsw) ; status word to ax 1299 (inst and ah-tn #x45) ; C3 C2 C0 1300 (inst cmp ah-tn #x01))))) 1301 1302(define-vop (<double-float) 1303 (:translate <) 1304 (:args (x :scs (double-reg double-stack descriptor-reg)) 1305 (y :scs (double-reg double-stack descriptor-reg))) 1306 (:arg-types double-float double-float) 1307 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0) 1308 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 1309 (:conditional :e) 1310 (:policy :fast-safe) 1311 (:note "inline float comparison") 1312 (:ignore temp) 1313 (:generator 3 1314 ;; Handle a few special cases 1315 (cond 1316 ;; y is ST0. 1317 ((and (sc-is y double-reg) (zerop (tn-offset y))) 1318 (sc-case x 1319 (double-reg 1320 (inst fcomd x)) 1321 ((double-stack descriptor-reg) 1322 (if (sc-is x double-stack) 1323 (inst fcomd (ea-for-df-stack x)) 1324 (inst fcomd (ea-for-df-desc x))))) 1325 (inst fnstsw) ; status word to ax 1326 (inst and ah-tn #x45)) 1327 1328 ;; General case when y is not in ST0. 1329 (t 1330 ;; x to ST0 1331 (sc-case x 1332 (double-reg 1333 (unless (zerop (tn-offset x)) 1334 (copy-fp-reg-to-fr0 x))) 1335 ((double-stack descriptor-reg) 1336 (inst fstp fr0) 1337 (if (sc-is x double-stack) 1338 (inst fldd (ea-for-df-stack x)) 1339 (inst fldd (ea-for-df-desc x))))) 1340 (sc-case y 1341 (double-reg 1342 (inst fcomd y)) 1343 ((double-stack descriptor-reg) 1344 (if (sc-is y double-stack) 1345 (inst fcomd (ea-for-df-stack y)) 1346 (inst fcomd (ea-for-df-desc y))))) 1347 (inst fnstsw) ; status word to ax 1348 (inst and ah-tn #x45) ; C3 C2 C0 1349 (inst cmp ah-tn #x01))))) 1350 1351#!+long-float 1352(define-vop (<long-float) 1353 (:translate <) 1354 (:args (x :scs (long-reg)) 1355 (y :scs (long-reg))) 1356 (:arg-types long-float long-float) 1357 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 1358 (:conditional :e) 1359 (:policy :fast-safe) 1360 (:note "inline float comparison") 1361 (:ignore temp) 1362 (:generator 3 1363 (cond 1364 ;; x is in ST0; y is in any reg. 1365 ((zerop (tn-offset x)) 1366 (inst fcomd y) 1367 (inst fnstsw) ; status word to ax 1368 (inst and ah-tn #x45) ; C3 C2 C0 1369 (inst cmp ah-tn #x01)) 1370 ;; y is in ST0; x is in another reg. 1371 ((zerop (tn-offset y)) 1372 (inst fcomd x) 1373 (inst fnstsw) ; status word to ax 1374 (inst and ah-tn #x45)) 1375 ;; x and y are the same register, not ST0 1376 ;; x and y are different registers, neither ST0. 1377 (t 1378 (inst fxch y) 1379 (inst fcomd x) 1380 (inst fxch y) 1381 (inst fnstsw) ; status word to ax 1382 (inst and ah-tn #x45))))) ; C3 C2 C0 1383 1384 1385(define-vop (>single-float) 1386 (:translate >) 1387 (:args (x :scs (single-reg single-stack descriptor-reg)) 1388 (y :scs (single-reg single-stack descriptor-reg))) 1389 (:arg-types single-float single-float) 1390 (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) 1391 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 1392 (:conditional :e) 1393 (:policy :fast-safe) 1394 (:note "inline float comparison") 1395 (:ignore temp) 1396 (:generator 3 1397 ;; Handle a few special cases. 1398 (cond 1399 ;; y is ST0. 1400 ((and (sc-is y single-reg) (zerop (tn-offset y))) 1401 (sc-case x 1402 (single-reg 1403 (inst fcom x)) 1404 ((single-stack descriptor-reg) 1405 (if (sc-is x single-stack) 1406 (inst fcom (ea-for-sf-stack x)) 1407 (inst fcom (ea-for-sf-desc x))))) 1408 (inst fnstsw) ; status word to ax 1409 (inst and ah-tn #x45) 1410 (inst cmp ah-tn #x01)) 1411 1412 ;; general case when y is not in ST0 1413 (t 1414 ;; x to ST0 1415 (sc-case x 1416 (single-reg 1417 (unless (zerop (tn-offset x)) 1418 (copy-fp-reg-to-fr0 x))) 1419 ((single-stack descriptor-reg) 1420 (inst fstp fr0) 1421 (if (sc-is x single-stack) 1422 (inst fld (ea-for-sf-stack x)) 1423 (inst fld (ea-for-sf-desc x))))) 1424 (sc-case y 1425 (single-reg 1426 (inst fcom y)) 1427 ((single-stack descriptor-reg) 1428 (if (sc-is y single-stack) 1429 (inst fcom (ea-for-sf-stack y)) 1430 (inst fcom (ea-for-sf-desc y))))) 1431 (inst fnstsw) ; status word to ax 1432 (inst and ah-tn #x45))))) 1433 1434(define-vop (>double-float) 1435 (:translate >) 1436 (:args (x :scs (double-reg double-stack descriptor-reg)) 1437 (y :scs (double-reg double-stack descriptor-reg))) 1438 (:arg-types double-float double-float) 1439 (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0) 1440 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 1441 (:conditional :e) 1442 (:policy :fast-safe) 1443 (:note "inline float comparison") 1444 (:ignore temp) 1445 (:generator 3 1446 ;; Handle a few special cases. 1447 (cond 1448 ;; y is ST0. 1449 ((and (sc-is y double-reg) (zerop (tn-offset y))) 1450 (sc-case x 1451 (double-reg 1452 (inst fcomd x)) 1453 ((double-stack descriptor-reg) 1454 (if (sc-is x double-stack) 1455 (inst fcomd (ea-for-df-stack x)) 1456 (inst fcomd (ea-for-df-desc x))))) 1457 (inst fnstsw) ; status word to ax 1458 (inst and ah-tn #x45) 1459 (inst cmp ah-tn #x01)) 1460 1461 ;; general case when y is not in ST0 1462 (t 1463 ;; x to ST0 1464 (sc-case x 1465 (double-reg 1466 (unless (zerop (tn-offset x)) 1467 (copy-fp-reg-to-fr0 x))) 1468 ((double-stack descriptor-reg) 1469 (inst fstp fr0) 1470 (if (sc-is x double-stack) 1471 (inst fldd (ea-for-df-stack x)) 1472 (inst fldd (ea-for-df-desc x))))) 1473 (sc-case y 1474 (double-reg 1475 (inst fcomd y)) 1476 ((double-stack descriptor-reg) 1477 (if (sc-is y double-stack) 1478 (inst fcomd (ea-for-df-stack y)) 1479 (inst fcomd (ea-for-df-desc y))))) 1480 (inst fnstsw) ; status word to ax 1481 (inst and ah-tn #x45))))) 1482 1483#!+long-float 1484(define-vop (>long-float) 1485 (:translate >) 1486 (:args (x :scs (long-reg)) 1487 (y :scs (long-reg))) 1488 (:arg-types long-float long-float) 1489 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 1490 (:conditional :e) 1491 (:policy :fast-safe) 1492 (:note "inline float comparison") 1493 (:ignore temp) 1494 (:generator 3 1495 (cond 1496 ;; y is in ST0; x is in any reg. 1497 ((zerop (tn-offset y)) 1498 (inst fcomd x) 1499 (inst fnstsw) ; status word to ax 1500 (inst and ah-tn #x45) 1501 (inst cmp ah-tn #x01)) 1502 ;; x is in ST0; y is in another reg. 1503 ((zerop (tn-offset x)) 1504 (inst fcomd y) 1505 (inst fnstsw) ; status word to ax 1506 (inst and ah-tn #x45)) 1507 ;; y and x are the same register, not ST0 1508 ;; y and x are different registers, neither ST0. 1509 (t 1510 (inst fxch x) 1511 (inst fcomd y) 1512 (inst fxch x) 1513 (inst fnstsw) ; status word to ax 1514 (inst and ah-tn #x45))))) 1515 1516;;; Comparisons with 0 can use the FTST instruction. 1517 1518(define-vop (float-test) 1519 (:args (x)) 1520 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 1521 (:conditional :e) 1522 (:info y) 1523 (:variant-vars code) 1524 (:policy :fast-safe) 1525 (:vop-var vop) 1526 (:save-p :compute-only) 1527 (:note "inline float comparison") 1528 (:ignore temp y) 1529 (:generator 2 1530 (note-this-location vop :internal-error) 1531 (cond 1532 ;; x is in ST0 1533 ((zerop (tn-offset x)) 1534 (inst ftst)) 1535 ;; x not ST0 1536 (t 1537 (inst fxch x) 1538 (inst ftst) 1539 (inst fxch x))) 1540 (inst fnstsw) ; status word to ax 1541 (inst and ah-tn #x45) ; C3 C2 C0 1542 (unless (zerop code) 1543 (inst cmp ah-tn code)))) 1544 1545(define-vop (=0/single-float float-test) 1546 (:translate =) 1547 (:args (x :scs (single-reg))) 1548 (:arg-types single-float (:constant (single-float 0f0 0f0))) 1549 (:variant #x40)) 1550(define-vop (=0/double-float float-test) 1551 (:translate =) 1552 (:args (x :scs (double-reg))) 1553 (:arg-types double-float (:constant (double-float 0d0 0d0))) 1554 (:variant #x40)) 1555#!+long-float 1556(define-vop (=0/long-float float-test) 1557 (:translate =) 1558 (:args (x :scs (long-reg))) 1559 (:arg-types long-float (:constant (long-float 0l0 0l0))) 1560 (:variant #x40)) 1561 1562(define-vop (<0/single-float float-test) 1563 (:translate <) 1564 (:args (x :scs (single-reg))) 1565 (:arg-types single-float (:constant (single-float 0f0 0f0))) 1566 (:variant #x01)) 1567(define-vop (<0/double-float float-test) 1568 (:translate <) 1569 (:args (x :scs (double-reg))) 1570 (:arg-types double-float (:constant (double-float 0d0 0d0))) 1571 (:variant #x01)) 1572#!+long-float 1573(define-vop (<0/long-float float-test) 1574 (:translate <) 1575 (:args (x :scs (long-reg))) 1576 (:arg-types long-float (:constant (long-float 0l0 0l0))) 1577 (:variant #x01)) 1578 1579(define-vop (>0/single-float float-test) 1580 (:translate >) 1581 (:args (x :scs (single-reg))) 1582 (:arg-types single-float (:constant (single-float 0f0 0f0))) 1583 (:variant #x00)) 1584(define-vop (>0/double-float float-test) 1585 (:translate >) 1586 (:args (x :scs (double-reg))) 1587 (:arg-types double-float (:constant (double-float 0d0 0d0))) 1588 (:variant #x00)) 1589#!+long-float 1590(define-vop (>0/long-float float-test) 1591 (:translate >) 1592 (:args (x :scs (long-reg))) 1593 (:arg-types long-float (:constant (long-float 0l0 0l0))) 1594 (:variant #x00)) 1595 1596#!+long-float 1597(deftransform eql ((x y) (long-float long-float)) 1598 `(and (= (long-float-low-bits x) (long-float-low-bits y)) 1599 (= (long-float-high-bits x) (long-float-high-bits y)) 1600 (= (long-float-exp-bits x) (long-float-exp-bits y)))) 1601 1602;;;; conversion 1603 1604(macrolet ((frob (name translate to-sc to-type) 1605 `(define-vop (,name) 1606 (:args (x :scs (signed-stack signed-reg) :target temp)) 1607 (:temporary (:sc signed-stack) temp) 1608 (:results (y :scs (,to-sc))) 1609 (:arg-types signed-num) 1610 (:result-types ,to-type) 1611 (:policy :fast-safe) 1612 (:note "inline float coercion") 1613 (:translate ,translate) 1614 (:vop-var vop) 1615 (:save-p :compute-only) 1616 (:generator 5 1617 (sc-case x 1618 (signed-reg 1619 (inst mov temp x) 1620 (with-empty-tn@fp-top(y) 1621 (note-this-location vop :internal-error) 1622 (inst fild temp))) 1623 (signed-stack 1624 (with-empty-tn@fp-top(y) 1625 (note-this-location vop :internal-error) 1626 (inst fild x)))))))) 1627 (frob %single-float/signed %single-float single-reg single-float) 1628 (frob %double-float/signed %double-float double-reg double-float) 1629 #!+long-float 1630 (frob %long-float/signed %long-float long-reg long-float)) 1631 1632(macrolet ((frob (name translate to-sc to-type) 1633 `(define-vop (,name) 1634 (:args (x :scs (unsigned-reg))) 1635 (:results (y :scs (,to-sc))) 1636 (:arg-types unsigned-num) 1637 (:result-types ,to-type) 1638 (:policy :fast-safe) 1639 (:note "inline float coercion") 1640 (:translate ,translate) 1641 (:vop-var vop) 1642 (:save-p :compute-only) 1643 (:generator 6 1644 (inst push 0) 1645 (inst push x) 1646 (with-empty-tn@fp-top(y) 1647 (note-this-location vop :internal-error) 1648 (inst fildl (make-ea :dword :base esp-tn))) 1649 (inst add esp-tn 8))))) 1650 (frob %single-float/unsigned %single-float single-reg single-float) 1651 (frob %double-float/unsigned %double-float double-reg double-float) 1652 #!+long-float 1653 (frob %long-float/unsigned %long-float long-reg long-float)) 1654 1655(macrolet ((frob (name translate from-sc from-type to-sc to-type 1656 &optional to-stack-sc store-inst load-inst) 1657 `(define-vop (,name) 1658 (:args (x :scs (,from-sc) :target y)) 1659 ,@(and to-stack-sc 1660 `((:temporary (:sc ,to-stack-sc) temp))) 1661 (:results (y :scs (,to-sc))) 1662 (:arg-types ,from-type) 1663 (:result-types ,to-type) 1664 (:policy :fast-safe) 1665 (:note "inline float coercion") 1666 (:translate ,translate) 1667 (:vop-var vop) 1668 (:save-p :compute-only) 1669 (:generator 2 1670 (note-this-location vop :internal-error) 1671 ,(if to-stack-sc 1672 `(progn 1673 (with-tn@fp-top (x) 1674 (inst ,store-inst temp)) 1675 (with-empty-tn@fp-top (y) 1676 (inst ,load-inst temp))) 1677 `(unless (location= x y) 1678 (cond 1679 ((zerop (tn-offset x)) 1680 ;; x is in ST0, y is in another reg. not ST0 1681 (inst fst y)) 1682 ((zerop (tn-offset y)) 1683 ;; y is in ST0, x is in another reg. not ST0 1684 (copy-fp-reg-to-fr0 x)) 1685 (t 1686 ;; Neither x or y are in ST0, and they are not in 1687 ;; the same reg. 1688 (inst fxch x) 1689 (inst fst y) 1690 (inst fxch x))))))))) 1691 1692 (frob %single-float/double-float %single-float double-reg double-float 1693 single-reg single-float 1694 single-stack fst fld) 1695 #!+long-float 1696 (frob %single-float/long-float %single-float long-reg 1697 long-float single-reg single-float 1698 single-stack fst fld) 1699 (frob %double-float/single-float %double-float single-reg single-float 1700 double-reg double-float) 1701 #!+long-float 1702 (frob %double-float/long-float %double-float long-reg long-float 1703 double-reg double-float 1704 double-stack fstd fldd) 1705 #!+long-float 1706 (frob %long-float/single-float %long-float single-reg single-float 1707 long-reg long-float) 1708 #!+long-float 1709 (frob %long-float/double-float %long-float double-reg double-float 1710 long-reg long-float)) 1711 1712(macrolet ((frob (trans from-sc from-type round-p) 1713 `(define-vop (,(symbolicate trans "/" from-type)) 1714 (:args (x :scs (,from-sc))) 1715 (:temporary (:sc signed-stack) stack-temp) 1716 ,@(unless round-p 1717 '((:temporary (:sc unsigned-stack) scw) 1718 (:temporary (:sc any-reg) rcw))) 1719 (:results (y :scs (signed-reg))) 1720 (:arg-types ,from-type) 1721 (:result-types signed-num) 1722 (:translate ,trans) 1723 (:policy :fast-safe) 1724 (:note "inline float truncate") 1725 (:vop-var vop) 1726 (:save-p :compute-only) 1727 (:generator 5 1728 ,@(unless round-p 1729 '((note-this-location vop :internal-error) 1730 ;; Catch any pending FPE exceptions. 1731 (inst wait))) 1732 (,(if round-p 'progn 'pseudo-atomic) 1733 ;; Normal mode (for now) is "round to best". 1734 (with-tn@fp-top (x) 1735 ,@(unless round-p 1736 '((inst fnstcw scw) ; save current control word 1737 (move rcw scw) ; into 16-bit register 1738 (inst or rcw (ash #b11 10)) ; CHOP 1739 (move stack-temp rcw) 1740 (inst fldcw stack-temp))) 1741 (sc-case y 1742 (signed-stack 1743 (inst fist y)) 1744 (signed-reg 1745 (inst fist stack-temp) 1746 (inst mov y stack-temp))) 1747 ,@(unless round-p 1748 '((inst fldcw scw))))))))) 1749 (frob %unary-truncate/single-float single-reg single-float nil) 1750 (frob %unary-truncate/double-float double-reg double-float nil) 1751 #!+long-float 1752 (frob %unary-truncate/long-float long-reg long-float nil) 1753 (frob %unary-round single-reg single-float t) 1754 (frob %unary-round double-reg double-float t) 1755 #!+long-float 1756 (frob %unary-round long-reg long-float t)) 1757 1758(macrolet ((frob (trans from-sc from-type round-p) 1759 `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED")) 1760 (:args (x :scs (,from-sc) :target fr0)) 1761 (:temporary (:sc double-reg :offset fr0-offset 1762 :from :argument :to :result) fr0) 1763 ,@(unless round-p 1764 '((:temporary (:sc unsigned-stack) stack-temp) 1765 (:temporary (:sc unsigned-stack) scw) 1766 (:temporary (:sc any-reg) rcw))) 1767 (:results (y :scs (unsigned-reg))) 1768 (:arg-types ,from-type) 1769 (:result-types unsigned-num) 1770 (:translate ,trans) 1771 (:policy :fast-safe) 1772 (:note "inline float truncate") 1773 (:vop-var vop) 1774 (:save-p :compute-only) 1775 (:generator 5 1776 ,@(unless round-p 1777 '((note-this-location vop :internal-error) 1778 ;; Catch any pending FPE exceptions. 1779 (inst wait))) 1780 ;; Normal mode (for now) is "round to best". 1781 (unless (zerop (tn-offset x)) 1782 (copy-fp-reg-to-fr0 x)) 1783 ,@(unless round-p 1784 '((inst fnstcw scw) ; save current control word 1785 (move rcw scw) ; into 16-bit register 1786 (inst or rcw (ash #b11 10)) ; CHOP 1787 (move stack-temp rcw) 1788 (inst fldcw stack-temp))) 1789 (inst sub esp-tn 8) 1790 (inst fistpl (make-ea :dword :base esp-tn)) 1791 (inst pop y) 1792 (inst fld fr0) ; copy fr0 to at least restore stack. 1793 (inst add esp-tn 4) 1794 ,@(unless round-p 1795 '((inst fldcw scw))))))) 1796 (frob %unary-truncate/single-float single-reg single-float nil) 1797 (frob %unary-truncate/double-float double-reg double-float nil) 1798 #!+long-float 1799 (frob %unary-truncate/long-float long-reg long-float nil) 1800 (frob %unary-round single-reg single-float t) 1801 (frob %unary-round double-reg double-float t) 1802 #!+long-float 1803 (frob %unary-round long-reg long-float t)) 1804 1805(define-vop (make-single-float) 1806 (:args (bits :scs (signed-reg) :target res 1807 :load-if (not (or (and (sc-is bits signed-stack) 1808 (sc-is res single-reg)) 1809 (and (sc-is bits signed-stack) 1810 (sc-is res single-stack) 1811 (location= bits res)))))) 1812 (:results (res :scs (single-reg single-stack))) 1813 (:temporary (:sc signed-stack) stack-temp) 1814 (:arg-types signed-num) 1815 (:result-types single-float) 1816 (:translate make-single-float) 1817 (:policy :fast-safe) 1818 (:vop-var vop) 1819 (:generator 4 1820 (sc-case res 1821 (single-stack 1822 (sc-case bits 1823 (signed-reg 1824 (inst mov res bits)) 1825 (signed-stack 1826 (aver (location= bits res))))) 1827 (single-reg 1828 (sc-case bits 1829 (signed-reg 1830 ;; source must be in memory 1831 (inst mov stack-temp bits) 1832 (with-empty-tn@fp-top(res) 1833 (inst fld stack-temp))) 1834 (signed-stack 1835 (with-empty-tn@fp-top(res) 1836 (inst fld bits)))))))) 1837 1838(define-vop (make-single-float-c) 1839 (:results (res :scs (single-reg single-stack))) 1840 (:arg-types (:constant (signed-byte 32))) 1841 (:result-types single-float) 1842 (:info bits) 1843 (:translate make-single-float) 1844 (:policy :fast-safe) 1845 (:vop-var vop) 1846 (:generator 2 1847 (sc-case res 1848 (single-stack 1849 (inst mov res bits)) 1850 (single-reg 1851 (with-empty-tn@fp-top (res) 1852 (inst fld (register-inline-constant :dword bits))))))) 1853 1854(define-vop (make-double-float) 1855 (:args (hi-bits :scs (signed-reg)) 1856 (lo-bits :scs (unsigned-reg))) 1857 (:results (res :scs (double-reg))) 1858 (:temporary (:sc double-stack) temp) 1859 (:arg-types signed-num unsigned-num) 1860 (:result-types double-float) 1861 (:translate make-double-float) 1862 (:policy :fast-safe) 1863 (:vop-var vop) 1864 (:generator 2 1865 (let ((offset (tn-offset temp))) 1866 (storew hi-bits ebp-tn (frame-word-offset offset)) 1867 (storew lo-bits ebp-tn (frame-word-offset (1+ offset))) 1868 (with-empty-tn@fp-top(res) 1869 (inst fldd (make-ea :dword :base ebp-tn 1870 :disp (frame-byte-offset (1+ offset)))))))) 1871 1872(define-vop (make-double-float-c) 1873 (:results (res :scs (double-reg))) 1874 (:arg-types (:constant (signed-byte 32)) (:constant (unsigned-byte 32))) 1875 (:result-types double-float) 1876 (:info hi lo) 1877 (:translate make-double-float) 1878 (:policy :fast-safe) 1879 (:vop-var vop) 1880 (:generator 1 1881 (with-empty-tn@fp-top(res) 1882 (inst fldd (register-inline-constant 1883 :double-float-bits (logior (ash hi 32) lo)))))) 1884 1885#!+long-float 1886(define-vop (make-long-float) 1887 (:args (exp-bits :scs (signed-reg)) 1888 (hi-bits :scs (unsigned-reg)) 1889 (lo-bits :scs (unsigned-reg))) 1890 (:results (res :scs (long-reg))) 1891 (:temporary (:sc long-stack) temp) 1892 (:arg-types signed-num unsigned-num unsigned-num) 1893 (:result-types long-float) 1894 (:translate make-long-float) 1895 (:policy :fast-safe) 1896 (:vop-var vop) 1897 (:generator 3 1898 (let ((offset (tn-offset temp))) 1899 (storew exp-bits ebp-tn (frame-word-offset offset)) 1900 (storew hi-bits ebp-tn (frame-word-offset (1+ offset))) 1901 (storew lo-bits ebp-tn (frame-word-offset (+ offset 2))) 1902 (with-empty-tn@fp-top(res) 1903 (inst fldl (make-ea :dword :base ebp-tn 1904 :disp (frame-byte-offset (+ offset 2)))))))) 1905 1906(define-vop (single-float-bits) 1907 (:args (float :scs (single-reg descriptor-reg) 1908 :load-if (not (sc-is float single-stack)))) 1909 (:results (bits :scs (signed-reg))) 1910 (:temporary (:sc signed-stack :from :argument :to :result) stack-temp) 1911 (:arg-types single-float) 1912 (:result-types signed-num) 1913 (:translate single-float-bits) 1914 (:policy :fast-safe) 1915 (:vop-var vop) 1916 (:generator 4 1917 (sc-case bits 1918 (signed-reg 1919 (sc-case float 1920 (single-reg 1921 (with-tn@fp-top(float) 1922 (inst fst stack-temp) 1923 (inst mov bits stack-temp))) 1924 (single-stack 1925 (inst mov bits float)) 1926 (descriptor-reg 1927 (loadw 1928 bits float single-float-value-slot 1929 other-pointer-lowtag)))) 1930 (signed-stack 1931 (sc-case float 1932 (single-reg 1933 (with-tn@fp-top(float) 1934 (inst fst bits)))))))) 1935 1936(define-vop (double-float-high-bits) 1937 (:args (float :scs (double-reg descriptor-reg) 1938 :load-if (not (sc-is float double-stack)))) 1939 (:results (hi-bits :scs (signed-reg))) 1940 (:temporary (:sc double-stack) temp) 1941 (:arg-types double-float) 1942 (:result-types signed-num) 1943 (:translate double-float-high-bits) 1944 (:policy :fast-safe) 1945 (:vop-var vop) 1946 (:generator 5 1947 (sc-case float 1948 (double-reg 1949 (with-tn@fp-top(float) 1950 (let ((where (make-ea :dword :base ebp-tn 1951 :disp (frame-byte-offset (1+ (tn-offset temp)))))) 1952 (inst fstd where))) 1953 (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp)))) 1954 (double-stack 1955 (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float)))) 1956 (descriptor-reg 1957 (loadw hi-bits float (1+ double-float-value-slot) 1958 other-pointer-lowtag))))) 1959 1960(define-vop (double-float-low-bits) 1961 (:args (float :scs (double-reg descriptor-reg) 1962 :load-if (not (sc-is float double-stack)))) 1963 (:results (lo-bits :scs (unsigned-reg))) 1964 (:temporary (:sc double-stack) temp) 1965 (:arg-types double-float) 1966 (:result-types unsigned-num) 1967 (:translate double-float-low-bits) 1968 (:policy :fast-safe) 1969 (:vop-var vop) 1970 (:generator 5 1971 (sc-case float 1972 (double-reg 1973 (with-tn@fp-top(float) 1974 (let ((where (make-ea :dword :base ebp-tn 1975 :disp (frame-byte-offset (1+ (tn-offset temp)))))) 1976 (inst fstd where))) 1977 (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) 1978 (double-stack 1979 (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float))))) 1980 (descriptor-reg 1981 (loadw lo-bits float double-float-value-slot 1982 other-pointer-lowtag))))) 1983 1984#!+long-float 1985(define-vop (long-float-exp-bits) 1986 (:args (float :scs (long-reg descriptor-reg) 1987 :load-if (not (sc-is float long-stack)))) 1988 (:results (exp-bits :scs (signed-reg))) 1989 (:temporary (:sc long-stack) temp) 1990 (:arg-types long-float) 1991 (:result-types signed-num) 1992 (:translate long-float-exp-bits) 1993 (:policy :fast-safe) 1994 (:vop-var vop) 1995 (:generator 5 1996 (sc-case float 1997 (long-reg 1998 (with-tn@fp-top(float) 1999 (let ((where (make-ea :dword :base ebp-tn 2000 :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) 2001 (store-long-float where))) 2002 (inst movsx exp-bits 2003 (make-ea :word :base ebp-tn 2004 :disp (frame-byte-offset (tn-offset temp))))) 2005 (long-stack 2006 (inst movsx exp-bits 2007 (make-ea :word :base ebp-tn 2008 :disp (frame-byte-offset (tn-offset temp))))) 2009 (descriptor-reg 2010 (inst movsx exp-bits 2011 (make-ea-for-object-slot float (+ 2 long-float-value-slot) 2012 other-pointer-lowtag :word)))))) 2013 2014#!+long-float 2015(define-vop (long-float-high-bits) 2016 (:args (float :scs (long-reg descriptor-reg) 2017 :load-if (not (sc-is float long-stack)))) 2018 (:results (hi-bits :scs (unsigned-reg))) 2019 (:temporary (:sc long-stack) temp) 2020 (:arg-types long-float) 2021 (:result-types unsigned-num) 2022 (:translate long-float-high-bits) 2023 (:policy :fast-safe) 2024 (:vop-var vop) 2025 (:generator 5 2026 (sc-case float 2027 (long-reg 2028 (with-tn@fp-top(float) 2029 (let ((where (make-ea :dword :base ebp-tn 2030 :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) 2031 (store-long-float where))) 2032 (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) 2033 (long-stack 2034 (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) 2035 (descriptor-reg 2036 (loadw hi-bits float (1+ long-float-value-slot) 2037 other-pointer-lowtag))))) 2038 2039#!+long-float 2040(define-vop (long-float-low-bits) 2041 (:args (float :scs (long-reg descriptor-reg) 2042 :load-if (not (sc-is float long-stack)))) 2043 (:results (lo-bits :scs (unsigned-reg))) 2044 (:temporary (:sc long-stack) temp) 2045 (:arg-types long-float) 2046 (:result-types unsigned-num) 2047 (:translate long-float-low-bits) 2048 (:policy :fast-safe) 2049 (:vop-var vop) 2050 (:generator 5 2051 (sc-case float 2052 (long-reg 2053 (with-tn@fp-top(float) 2054 (let ((where (make-ea :dword :base ebp-tn 2055 :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) 2056 (store-long-float where))) 2057 (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2)))) 2058 (long-stack 2059 (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2)))) 2060 (descriptor-reg 2061 (loadw lo-bits float long-float-value-slot 2062 other-pointer-lowtag))))) 2063 2064;;;; float mode hackery 2065 2066(sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16 2067(defknown floating-point-modes () float-modes (flushable)) 2068(defknown ((setf floating-point-modes)) (float-modes) 2069 float-modes) 2070 2071(defconstant npx-env-size (* 7 n-word-bytes)) 2072(defconstant npx-cw-offset 0) 2073(defconstant npx-sw-offset 4) 2074 2075(define-vop (floating-point-modes) 2076 (:results (res :scs (unsigned-reg))) 2077 (:result-types unsigned-num) 2078 (:translate floating-point-modes) 2079 (:policy :fast-safe) 2080 (:temporary (:sc unsigned-reg :offset eax-offset :target res 2081 :to :result) eax) 2082 (:generator 8 2083 (inst sub esp-tn npx-env-size) ; Make space on stack. 2084 (inst wait) ; Catch any pending FPE exceptions 2085 (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions 2086 (inst fldenv (make-ea :dword :base esp-tn)) ; Restore previous state. 2087 ;; Move current status to high word. 2088 (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2))) 2089 ;; Move exception mask to low word. 2090 (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset)) 2091 (inst add esp-tn npx-env-size) ; Pop stack. 2092 (inst xor eax #x3f) ; Flip exception mask to trap enable bits. 2093 (move res eax))) 2094 2095(define-vop (set-floating-point-modes) 2096 (:args (new :scs (unsigned-reg) :to :result :target res)) 2097 (:results (res :scs (unsigned-reg))) 2098 (:arg-types unsigned-num) 2099 (:result-types unsigned-num) 2100 (:translate (setf floating-point-modes)) 2101 (:policy :fast-safe) 2102 (:temporary (:sc unsigned-reg :offset eax-offset 2103 :from :eval :to :result) eax) 2104 (:generator 3 2105 (inst sub esp-tn npx-env-size) ; Make space on stack. 2106 (inst wait) ; Catch any pending FPE exceptions. 2107 (inst fstenv (make-ea :dword :base esp-tn)) 2108 (inst mov eax new) 2109 (inst xor eax #x3f) ; Turn trap enable bits into exception mask. 2110 (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn) 2111 (inst shr eax 16) ; position status word 2112 (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn) 2113 (inst fldenv (make-ea :dword :base esp-tn)) 2114 (inst add esp-tn npx-env-size) ; Pop stack. 2115 (move res new))) 2116 2117#!-long-float 2118(progn 2119 2120;;; Let's use some of the 80387 special functions. 2121;;; 2122;;; These defs will not take effect unless code/irrat.lisp is modified 2123;;; to remove the inlined alien routine def. 2124 2125(macrolet ((frob (func trans op) 2126 `(define-vop (,func) 2127 (:args (x :scs (double-reg) :target fr0)) 2128 (:temporary (:sc double-reg :offset fr0-offset 2129 :from :argument :to :result) fr0) 2130 (:ignore fr0) 2131 (:results (y :scs (double-reg))) 2132 (:arg-types double-float) 2133 (:result-types double-float) 2134 (:translate ,trans) 2135 (:policy :fast-safe) 2136 (:note "inline NPX function") 2137 (:vop-var vop) 2138 (:save-p :compute-only) 2139 (:node-var node) 2140 (:generator 5 2141 (note-this-location vop :internal-error) 2142 (unless (zerop (tn-offset x)) 2143 (inst fxch x) ; x to top of stack 2144 (unless (location= x y) 2145 (inst fst x))) ; maybe save it 2146 (inst ,op) ; clobber st0 2147 (cond ((zerop (tn-offset y)) 2148 (maybe-fp-wait node)) 2149 (t 2150 (inst fst y))))))) 2151 2152 ;; Quick versions of fsin and fcos that require the argument to be 2153 ;; within range 2^63. 2154 (frob fsin-quick %sin-quick fsin) 2155 (frob fcos-quick %cos-quick fcos) 2156 (frob fsqrt %sqrt fsqrt)) 2157 2158;;; Quick version of ftan that requires the argument to be within 2159;;; range 2^63. 2160(define-vop (ftan-quick) 2161 (:translate %tan-quick) 2162 (:args (x :scs (double-reg) :target fr0)) 2163 (:temporary (:sc double-reg :offset fr0-offset 2164 :from :argument :to :result) fr0) 2165 (:temporary (:sc double-reg :offset fr1-offset 2166 :from :argument :to :result) fr1) 2167 (:results (y :scs (double-reg))) 2168 (:arg-types double-float) 2169 (:result-types double-float) 2170 (:policy :fast-safe) 2171 (:note "inline tan function") 2172 (:vop-var vop) 2173 (:save-p :compute-only) 2174 (:generator 5 2175 (note-this-location vop :internal-error) 2176 (case (tn-offset x) 2177 (0 2178 (inst fstp fr1)) 2179 (1 2180 (inst fstp fr0)) 2181 (t 2182 (inst fstp fr0) 2183 (inst fstp fr0) 2184 (inst fldd (make-random-tn :kind :normal 2185 :sc (sc-or-lose 'double-reg) 2186 :offset (- (tn-offset x) 2))))) 2187 (inst fptan) 2188 ;; Result is in fr1 2189 (case (tn-offset y) 2190 (0 2191 (inst fxch fr1)) 2192 (1) 2193 (t 2194 (inst fxch fr1) 2195 (inst fstd y))))) 2196 2197;;; KLUDGE: these versions of fsin, fcos, and ftan simply load a 0.0 2198;;; result if the argument is out of range 2^63 and would thus be 2199;;; hopelessly inaccurate. 2200(macrolet ((frob (func trans op) 2201 `(define-vop (,func) 2202 (:translate ,trans) 2203 (:args (x :scs (double-reg) :target fr0)) 2204 (:temporary (:sc double-reg :offset fr0-offset 2205 :from :argument :to :result) fr0) 2206 ;; FIXME: make that an arbitrary location and 2207 ;; FXCH only when range reduction needed 2208 (:temporary (:sc double-reg :offset fr1-offset 2209 :from :argument :to :result) fr1) 2210 (:temporary (:sc unsigned-reg :offset eax-offset 2211 :from :argument :to :result) eax) 2212 (:results (y :scs (double-reg))) 2213 (:arg-types double-float) 2214 (:result-types double-float) 2215 (:policy :fast-safe) 2216 (:note "inline sin/cos function") 2217 (:vop-var vop) 2218 (:save-p :compute-only) 2219 (:ignore eax) 2220 (:generator 5 2221 (let ((DONE (gen-label)) 2222 (REDUCE (gen-label)) 2223 (REDUCE-LOOP (gen-label))) 2224 (note-this-location vop :internal-error) 2225 (unless (zerop (tn-offset x)) 2226 (inst fxch x) ; x to top of stack 2227 (unless (location= x y) 2228 (inst fst x))) ; maybe save it 2229 (inst ,op) 2230 (inst fnstsw) ; status word to ax 2231 (inst and ah-tn #x04) ; C2 2232 (inst jmp :nz REDUCE) 2233 (emit-label DONE) 2234 (unless (zerop (tn-offset y)) 2235 (inst fstd y)) 2236 (assemble (*elsewhere*) 2237 (emit-label REDUCE) 2238 ;; Else x was out of range so reduce it; ST0 is unchanged. 2239 (with-empty-tn@fp-top (fr1) 2240 (inst fldpi) 2241 (inst fadd fr0)) 2242 (emit-label REDUCE-LOOP) 2243 (inst fprem1) 2244 (inst fnstsw) 2245 (inst and ah-tn #x04) 2246 (inst jmp :nz REDUCE-LOOP) 2247 (inst ,op) 2248 (inst jmp DONE))))))) 2249 (frob fsin %sin fsin) 2250 (frob fcos %cos fcos)) 2251 2252(define-vop (ftan) 2253 (:translate %tan) 2254 (:args (x :scs (double-reg) :target fr0)) 2255 (:temporary (:sc double-reg :offset fr0-offset 2256 :from :argument :to :result) fr0) 2257 (:temporary (:sc double-reg :offset fr1-offset 2258 :from :argument :to :result) fr1) 2259 (:temporary (:sc unsigned-reg :offset eax-offset 2260 :from :argument :to :result) eax) 2261 (:results (y :scs (double-reg))) 2262 (:arg-types double-float) 2263 (:result-types double-float) 2264 (:ignore eax) 2265 (:policy :fast-safe) 2266 (:note "inline tan function") 2267 (:vop-var vop) 2268 (:save-p :compute-only) 2269 (:ignore eax) 2270 (:generator 5 2271 (note-this-location vop :internal-error) 2272 (case (tn-offset x) 2273 (0 2274 (inst fstp fr1)) 2275 (1 2276 (inst fstp fr0)) 2277 (t 2278 (inst fstp fr0) 2279 (inst fstp fr0) 2280 (inst fldd (make-random-tn :kind :normal 2281 :sc (sc-or-lose 'double-reg) 2282 :offset (- (tn-offset x) 2))))) 2283 (inst fptan) 2284 (let ((REDUCE (gen-label)) 2285 (REDUCE-LOOP (gen-label))) 2286 (inst fnstsw) ; status word to ax 2287 (inst and ah-tn #x04) ; C2 2288 (inst jmp :nz REDUCE) 2289 (assemble (*elsewhere*) 2290 (emit-label REDUCE) 2291 ;; Else x was out of range so reduce it; ST0 is unchanged. 2292 (with-empty-tn@fp-top (fr1) 2293 (inst fldpi) 2294 (inst fadd fr0)) 2295 (emit-label REDUCE-LOOP) 2296 (inst fprem1) 2297 (inst fnstsw) 2298 (inst and ah-tn #x04) 2299 (inst jmp :nz REDUCE-LOOP) 2300 (inst fptan) 2301 (inst jmp DONE))) 2302 DONE 2303 ;; Result is in fr1 2304 (case (tn-offset y) 2305 (0 2306 (inst fxch fr1)) 2307 (1) 2308 (t 2309 (inst fxch fr1) 2310 (inst fstd y))))) 2311 2312;;; %exp that handles the following special cases: exp(+Inf) is +Inf; 2313;;; exp(-Inf) is 0; exp(NaN) is NaN. 2314(define-vop (fexp) 2315 (:translate %exp) 2316 (:args (x :scs (double-reg) :target fr0)) 2317 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) 2318 (:temporary (:sc double-reg :offset fr0-offset 2319 :from :argument :to :result) fr0) 2320 (:temporary (:sc double-reg :offset fr1-offset 2321 :from :argument :to :result) fr1) 2322 (:temporary (:sc double-reg :offset fr2-offset 2323 :from :argument :to :result) fr2) 2324 (:results (y :scs (double-reg))) 2325 (:arg-types double-float) 2326 (:result-types double-float) 2327 (:policy :fast-safe) 2328 (:note "inline exp function") 2329 (:vop-var vop) 2330 (:save-p :compute-only) 2331 (:ignore temp) 2332 (:generator 5 2333 (note-this-location vop :internal-error) 2334 (unless (zerop (tn-offset x)) 2335 (inst fxch x) ; x to top of stack 2336 (unless (location= x y) 2337 (inst fst x))) ; maybe save it 2338 ;; Check for Inf or NaN 2339 (inst fxam) 2340 (inst fnstsw) 2341 (inst sahf) 2342 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. 2343 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. 2344 (inst and ah-tn #x02) ; Test sign of Inf. 2345 (inst jmp :z DONE) ; +Inf gives +Inf. 2346 (inst fstp fr0) ; -Inf gives 0 2347 (inst fldz) 2348 (inst jmp-short DONE) 2349 NOINFNAN 2350 (inst fstp fr1) 2351 (inst fldl2e) 2352 (inst fmul fr1) 2353 ;; Now fr0=x log2(e) 2354 (inst fst fr1) 2355 (inst frndint) 2356 (inst fst fr2) 2357 (inst fsubp-sti fr1) 2358 (inst f2xm1) 2359 (inst fld1) 2360 (inst faddp-sti fr1) 2361 (inst fscale) 2362 (inst fld fr0) 2363 DONE 2364 (unless (zerop (tn-offset y)) 2365 (inst fstd y)))) 2366 2367;;; Expm1 = exp(x) - 1. 2368;;; Handles the following special cases: 2369;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN. 2370(define-vop (fexpm1) 2371 (:translate %expm1) 2372 (:args (x :scs (double-reg) :target fr0)) 2373 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) 2374 (:temporary (:sc double-reg :offset fr0-offset 2375 :from :argument :to :result) fr0) 2376 (:temporary (:sc double-reg :offset fr1-offset 2377 :from :argument :to :result) fr1) 2378 (:temporary (:sc double-reg :offset fr2-offset 2379 :from :argument :to :result) fr2) 2380 (:results (y :scs (double-reg))) 2381 (:arg-types double-float) 2382 (:result-types double-float) 2383 (:policy :fast-safe) 2384 (:note "inline expm1 function") 2385 (:vop-var vop) 2386 (:save-p :compute-only) 2387 (:ignore temp) 2388 (:generator 5 2389 (note-this-location vop :internal-error) 2390 (unless (zerop (tn-offset x)) 2391 (inst fxch x) ; x to top of stack 2392 (unless (location= x y) 2393 (inst fst x))) ; maybe save it 2394 ;; Check for Inf or NaN 2395 (inst fxam) 2396 (inst fnstsw) 2397 (inst sahf) 2398 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. 2399 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. 2400 (inst and ah-tn #x02) ; Test sign of Inf. 2401 (inst jmp :z DONE) ; +Inf gives +Inf. 2402 (inst fstp fr0) ; -Inf gives -1.0 2403 (inst fld1) 2404 (inst fchs) 2405 (inst jmp-short DONE) 2406 NOINFNAN 2407 ;; Free two stack slots leaving the argument on top. 2408 (inst fstp fr2) 2409 (inst fstp fr0) 2410 (inst fldl2e) 2411 (inst fmul fr1) ; Now fr0 = x log2(e) 2412 (inst fst fr1) 2413 (inst frndint) 2414 (inst fsub-sti fr1) 2415 (inst fxch fr1) 2416 (inst f2xm1) 2417 (inst fscale) 2418 (inst fxch fr1) 2419 (inst fld1) 2420 (inst fscale) 2421 (inst fstp fr1) 2422 (inst fld1) 2423 (inst fsub fr1) 2424 (inst fsubr fr2) 2425 DONE 2426 (unless (zerop (tn-offset y)) 2427 (inst fstd y)))) 2428 2429(define-vop (flog) 2430 (:translate %log) 2431 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) 2432 (:temporary (:sc double-reg :offset fr0-offset 2433 :from :argument :to :result) fr0) 2434 (:temporary (:sc double-reg :offset fr1-offset 2435 :from :argument :to :result) fr1) 2436 (:results (y :scs (double-reg))) 2437 (:arg-types double-float) 2438 (:result-types double-float) 2439 (:policy :fast-safe) 2440 (:note "inline log function") 2441 (:vop-var vop) 2442 (:save-p :compute-only) 2443 (:generator 5 2444 (note-this-location vop :internal-error) 2445 (sc-case x 2446 (double-reg 2447 (case (tn-offset x) 2448 (0 2449 ;; x is in fr0 2450 (inst fstp fr1) 2451 (inst fldln2) 2452 (inst fxch fr1)) 2453 (1 2454 ;; x is in fr1 2455 (inst fstp fr0) 2456 (inst fldln2) 2457 (inst fxch fr1)) 2458 (t 2459 ;; x is in a FP reg, not fr0 or fr1 2460 (inst fstp fr0) 2461 (inst fstp fr0) 2462 (inst fldln2) 2463 (inst fldd (make-random-tn :kind :normal 2464 :sc (sc-or-lose 'double-reg) 2465 :offset (1- (tn-offset x)))))) 2466 (inst fyl2x)) 2467 ((double-stack descriptor-reg) 2468 (inst fstp fr0) 2469 (inst fstp fr0) 2470 (inst fldln2) 2471 (if (sc-is x double-stack) 2472 (inst fldd (ea-for-df-stack x)) 2473 (inst fldd (ea-for-df-desc x))) 2474 (inst fyl2x))) 2475 (inst fld fr0) 2476 (case (tn-offset y) 2477 ((0 1)) 2478 (t (inst fstd y))))) 2479 2480(define-vop (flog10) 2481 (:translate %log10) 2482 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) 2483 (:temporary (:sc double-reg :offset fr0-offset 2484 :from :argument :to :result) fr0) 2485 (:temporary (:sc double-reg :offset fr1-offset 2486 :from :argument :to :result) fr1) 2487 (:results (y :scs (double-reg))) 2488 (:arg-types double-float) 2489 (:result-types double-float) 2490 (:policy :fast-safe) 2491 (:note "inline log10 function") 2492 (:vop-var vop) 2493 (:save-p :compute-only) 2494 (:generator 5 2495 (note-this-location vop :internal-error) 2496 (sc-case x 2497 (double-reg 2498 (case (tn-offset x) 2499 (0 2500 ;; x is in fr0 2501 (inst fstp fr1) 2502 (inst fldlg2) 2503 (inst fxch fr1)) 2504 (1 2505 ;; x is in fr1 2506 (inst fstp fr0) 2507 (inst fldlg2) 2508 (inst fxch fr1)) 2509 (t 2510 ;; x is in a FP reg, not fr0 or fr1 2511 (inst fstp fr0) 2512 (inst fstp fr0) 2513 (inst fldlg2) 2514 (inst fldd (make-random-tn :kind :normal 2515 :sc (sc-or-lose 'double-reg) 2516 :offset (1- (tn-offset x)))))) 2517 (inst fyl2x)) 2518 ((double-stack descriptor-reg) 2519 (inst fstp fr0) 2520 (inst fstp fr0) 2521 (inst fldlg2) 2522 (if (sc-is x double-stack) 2523 (inst fldd (ea-for-df-stack x)) 2524 (inst fldd (ea-for-df-desc x))) 2525 (inst fyl2x))) 2526 (inst fld fr0) 2527 (case (tn-offset y) 2528 ((0 1)) 2529 (t (inst fstd y))))) 2530 2531(define-vop (fpow) 2532 (:translate %pow) 2533 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) 2534 (y :scs (double-reg double-stack descriptor-reg) :target fr1)) 2535 (:temporary (:sc double-reg :offset fr0-offset 2536 :from (:argument 0) :to :result) fr0) 2537 (:temporary (:sc double-reg :offset fr1-offset 2538 :from (:argument 1) :to :result) fr1) 2539 (:temporary (:sc double-reg :offset fr2-offset 2540 :from :load :to :result) fr2) 2541 (:results (r :scs (double-reg))) 2542 (:arg-types double-float double-float) 2543 (:result-types double-float) 2544 (:policy :fast-safe) 2545 (:note "inline pow function") 2546 (:vop-var vop) 2547 (:save-p :compute-only) 2548 (:generator 5 2549 (note-this-location vop :internal-error) 2550 ;; Setup x in fr0 and y in fr1 2551 (cond 2552 ;; x in fr0; y in fr1 2553 ((and (sc-is x double-reg) (zerop (tn-offset x)) 2554 (sc-is y double-reg) (= 1 (tn-offset y)))) 2555 ;; y in fr1; x not in fr0 2556 ((and (sc-is y double-reg) (= 1 (tn-offset y))) 2557 ;; Load x to fr0 2558 (sc-case x 2559 (double-reg 2560 (copy-fp-reg-to-fr0 x)) 2561 (double-stack 2562 (inst fstp fr0) 2563 (inst fldd (ea-for-df-stack x))) 2564 (descriptor-reg 2565 (inst fstp fr0) 2566 (inst fldd (ea-for-df-desc x))))) 2567 ;; x in fr0; y not in fr1 2568 ((and (sc-is x double-reg) (zerop (tn-offset x))) 2569 (inst fxch fr1) 2570 ;; Now load y to fr0 2571 (sc-case y 2572 (double-reg 2573 (copy-fp-reg-to-fr0 y)) 2574 (double-stack 2575 (inst fstp fr0) 2576 (inst fldd (ea-for-df-stack y))) 2577 (descriptor-reg 2578 (inst fstp fr0) 2579 (inst fldd (ea-for-df-desc y)))) 2580 (inst fxch fr1)) 2581 ;; x in fr1; y not in fr1 2582 ((and (sc-is x double-reg) (= 1 (tn-offset x))) 2583 ;; Load y to fr0 2584 (sc-case y 2585 (double-reg 2586 (copy-fp-reg-to-fr0 y)) 2587 (double-stack 2588 (inst fstp fr0) 2589 (inst fldd (ea-for-df-stack y))) 2590 (descriptor-reg 2591 (inst fstp fr0) 2592 (inst fldd (ea-for-df-desc y)))) 2593 (inst fxch fr1)) 2594 ;; y in fr0; 2595 ((and (sc-is y double-reg) (zerop (tn-offset y))) 2596 (inst fxch fr1) 2597 ;; Now load x to fr0 2598 (sc-case x 2599 (double-reg 2600 (copy-fp-reg-to-fr0 x)) 2601 (double-stack 2602 (inst fstp fr0) 2603 (inst fldd (ea-for-df-stack x))) 2604 (descriptor-reg 2605 (inst fstp fr0) 2606 (inst fldd (ea-for-df-desc x))))) 2607 ;; Neither x or y are in either fr0 or fr1 2608 (t 2609 ;; Load y then x 2610 (inst fstp fr0) 2611 (inst fstp fr0) 2612 (sc-case y 2613 (double-reg 2614 (inst fldd (make-random-tn :kind :normal 2615 :sc (sc-or-lose 'double-reg) 2616 :offset (- (tn-offset y) 2)))) 2617 (double-stack 2618 (inst fldd (ea-for-df-stack y))) 2619 (descriptor-reg 2620 (inst fldd (ea-for-df-desc y)))) 2621 ;; Load x to fr0 2622 (sc-case x 2623 (double-reg 2624 (inst fldd (make-random-tn :kind :normal 2625 :sc (sc-or-lose 'double-reg) 2626 :offset (1- (tn-offset x))))) 2627 (double-stack 2628 (inst fldd (ea-for-df-stack x))) 2629 (descriptor-reg 2630 (inst fldd (ea-for-df-desc x)))))) 2631 2632 ;; Now have x at fr0; and y at fr1 2633 (inst fyl2x) 2634 ;; Now fr0=y log2(x) 2635 (inst fld fr0) 2636 (inst frndint) 2637 (inst fst fr2) 2638 (inst fsubp-sti fr1) 2639 (inst f2xm1) 2640 (inst fld1) 2641 (inst faddp-sti fr1) 2642 (inst fscale) 2643 (inst fld fr0) 2644 (case (tn-offset r) 2645 ((0 1)) 2646 (t (inst fstd r))))) 2647 2648(define-vop (fscalen) 2649 (:translate %scalbn) 2650 (:args (x :scs (double-reg double-stack descriptor-reg) 2651 :to (:argument 2) :target fr0) 2652 (y :scs (signed-stack signed-reg) :target temp)) 2653 (:temporary (:sc double-reg :offset fr0-offset 2654 :from (:argument 2) :to :result) fr0) 2655 (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1) 2656 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) 2657 (:results (r :scs (double-reg))) 2658 (:arg-types double-float signed-num) 2659 (:result-types double-float) 2660 (:policy :fast-safe) 2661 (:note "inline scalbn function") 2662 (:generator 5 2663 ;; Setup x in fr0 and y in fr1 2664 (sc-case x 2665 (double-reg 2666 (case (tn-offset x) 2667 (0 2668 (inst fstp fr1) 2669 (sc-case y 2670 (signed-reg 2671 (inst mov temp y) 2672 (inst fild temp)) 2673 (signed-stack 2674 (inst fild y))) 2675 (inst fxch fr1)) 2676 (1 2677 (inst fstp fr0) 2678 (sc-case y 2679 (signed-reg 2680 (inst mov temp y) 2681 (inst fild temp)) 2682 (signed-stack 2683 (inst fild y))) 2684 (inst fxch fr1)) 2685 (t 2686 (inst fstp fr0) 2687 (inst fstp fr0) 2688 (sc-case y 2689 (signed-reg 2690 (inst mov temp y) 2691 (inst fild temp)) 2692 (signed-stack 2693 (inst fild y))) 2694 (inst fld (make-random-tn :kind :normal 2695 :sc (sc-or-lose 'double-reg) 2696 :offset (1- (tn-offset x))))))) 2697 ((double-stack descriptor-reg) 2698 (inst fstp fr0) 2699 (inst fstp fr0) 2700 (sc-case y 2701 (signed-reg 2702 (inst mov temp y) 2703 (inst fild temp)) 2704 (signed-stack 2705 (inst fild y))) 2706 (if (sc-is x double-stack) 2707 (inst fldd (ea-for-df-stack x)) 2708 (inst fldd (ea-for-df-desc x))))) 2709 (inst fscale) 2710 (unless (zerop (tn-offset r)) 2711 (inst fstd r)))) 2712 2713(define-vop (fscale) 2714 (:translate %scalb) 2715 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0) 2716 (y :scs (double-reg double-stack descriptor-reg) :target fr1)) 2717 (:temporary (:sc double-reg :offset fr0-offset 2718 :from (:argument 0) :to :result) fr0) 2719 (:temporary (:sc double-reg :offset fr1-offset 2720 :from (:argument 1) :to :result) fr1) 2721 (:results (r :scs (double-reg))) 2722 (:arg-types double-float double-float) 2723 (:result-types double-float) 2724 (:policy :fast-safe) 2725 (:note "inline scalb function") 2726 (:vop-var vop) 2727 (:save-p :compute-only) 2728 (:generator 5 2729 (note-this-location vop :internal-error) 2730 ;; Setup x in fr0 and y in fr1 2731 (cond 2732 ;; x in fr0; y in fr1 2733 ((and (sc-is x double-reg) (zerop (tn-offset x)) 2734 (sc-is y double-reg) (= 1 (tn-offset y)))) 2735 ;; y in fr1; x not in fr0 2736 ((and (sc-is y double-reg) (= 1 (tn-offset y))) 2737 ;; Load x to fr0 2738 (sc-case x 2739 (double-reg 2740 (copy-fp-reg-to-fr0 x)) 2741 (double-stack 2742 (inst fstp fr0) 2743 (inst fldd (ea-for-df-stack x))) 2744 (descriptor-reg 2745 (inst fstp fr0) 2746 (inst fldd (ea-for-df-desc x))))) 2747 ;; x in fr0; y not in fr1 2748 ((and (sc-is x double-reg) (zerop (tn-offset x))) 2749 (inst fxch fr1) 2750 ;; Now load y to fr0 2751 (sc-case y 2752 (double-reg 2753 (copy-fp-reg-to-fr0 y)) 2754 (double-stack 2755 (inst fstp fr0) 2756 (inst fldd (ea-for-df-stack y))) 2757 (descriptor-reg 2758 (inst fstp fr0) 2759 (inst fldd (ea-for-df-desc y)))) 2760 (inst fxch fr1)) 2761 ;; x in fr1; y not in fr1 2762 ((and (sc-is x double-reg) (= 1 (tn-offset x))) 2763 ;; Load y to fr0 2764 (sc-case y 2765 (double-reg 2766 (copy-fp-reg-to-fr0 y)) 2767 (double-stack 2768 (inst fstp fr0) 2769 (inst fldd (ea-for-df-stack y))) 2770 (descriptor-reg 2771 (inst fstp fr0) 2772 (inst fldd (ea-for-df-desc y)))) 2773 (inst fxch fr1)) 2774 ;; y in fr0; 2775 ((and (sc-is y double-reg) (zerop (tn-offset y))) 2776 (inst fxch fr1) 2777 ;; Now load x to fr0 2778 (sc-case x 2779 (double-reg 2780 (copy-fp-reg-to-fr0 x)) 2781 (double-stack 2782 (inst fstp fr0) 2783 (inst fldd (ea-for-df-stack x))) 2784 (descriptor-reg 2785 (inst fstp fr0) 2786 (inst fldd (ea-for-df-desc x))))) 2787 ;; Neither x or y are in either fr0 or fr1 2788 (t 2789 ;; Load y then x 2790 (inst fstp fr0) 2791 (inst fstp fr0) 2792 (sc-case y 2793 (double-reg 2794 (inst fldd (make-random-tn :kind :normal 2795 :sc (sc-or-lose 'double-reg) 2796 :offset (- (tn-offset y) 2)))) 2797 (double-stack 2798 (inst fldd (ea-for-df-stack y))) 2799 (descriptor-reg 2800 (inst fldd (ea-for-df-desc y)))) 2801 ;; Load x to fr0 2802 (sc-case x 2803 (double-reg 2804 (inst fldd (make-random-tn :kind :normal 2805 :sc (sc-or-lose 'double-reg) 2806 :offset (1- (tn-offset x))))) 2807 (double-stack 2808 (inst fldd (ea-for-df-stack x))) 2809 (descriptor-reg 2810 (inst fldd (ea-for-df-desc x)))))) 2811 2812 ;; Now have x at fr0; and y at fr1 2813 (inst fscale) 2814 (unless (zerop (tn-offset r)) 2815 (inst fstd r)))) 2816 2817(define-vop (flog1p) 2818 (:translate %log1p) 2819 (:args (x :scs (double-reg) :to :result)) 2820 (:temporary (:sc double-reg :offset fr0-offset 2821 :from :argument :to :result) fr0) 2822 (:temporary (:sc double-reg :offset fr1-offset 2823 :from :argument :to :result) fr1) 2824 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 2825 (:results (y :scs (double-reg))) 2826 (:arg-types double-float) 2827 (:result-types double-float) 2828 (:policy :fast-safe) 2829 (:note "inline log1p function") 2830 (:ignore temp) 2831 (:generator 5 2832 ;; x is in a FP reg, not fr0, fr1. 2833 (inst fstp fr0) 2834 (inst fstp fr0) 2835 (inst fldd (make-random-tn :kind :normal 2836 :sc (sc-or-lose 'double-reg) 2837 :offset (- (tn-offset x) 2))) 2838 ;; Check the range 2839 (inst push #x3e947ae1) ; Constant 0.29 2840 (inst fabs) 2841 (inst fld (make-ea :dword :base esp-tn)) 2842 (inst fcompp) 2843 (inst add esp-tn 4) 2844 (inst fnstsw) ; status word to ax 2845 (inst and ah-tn #x45) 2846 (inst jmp :z WITHIN-RANGE) 2847 ;; Out of range for fyl2xp1. 2848 (inst fld1) 2849 (inst faddd (make-random-tn :kind :normal 2850 :sc (sc-or-lose 'double-reg) 2851 :offset (- (tn-offset x) 1))) 2852 (inst fldln2) 2853 (inst fxch fr1) 2854 (inst fyl2x) 2855 (inst jmp DONE) 2856 2857 WITHIN-RANGE 2858 (inst fldln2) 2859 (inst fldd (make-random-tn :kind :normal 2860 :sc (sc-or-lose 'double-reg) 2861 :offset (- (tn-offset x) 1))) 2862 (inst fyl2xp1) 2863 DONE 2864 (inst fld fr0) 2865 (case (tn-offset y) 2866 ((0 1)) 2867 (t (inst fstd y))))) 2868 2869;;; The Pentium has a less restricted implementation of the fyl2xp1 2870;;; instruction and a range check can be avoided. 2871(define-vop (flog1p-pentium) 2872 (:translate %log1p) 2873 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) 2874 (:temporary (:sc double-reg :offset fr0-offset 2875 :from :argument :to :result) fr0) 2876 (:temporary (:sc double-reg :offset fr1-offset 2877 :from :argument :to :result) fr1) 2878 (:results (y :scs (double-reg))) 2879 (:arg-types double-float) 2880 (:result-types double-float) 2881 (:policy :fast-safe) 2882 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*)) 2883 (:note "inline log1p with limited x range function") 2884 (:vop-var vop) 2885 (:save-p :compute-only) 2886 (:generator 4 2887 (note-this-location vop :internal-error) 2888 (sc-case x 2889 (double-reg 2890 (case (tn-offset x) 2891 (0 2892 ;; x is in fr0 2893 (inst fstp fr1) 2894 (inst fldln2) 2895 (inst fxch fr1)) 2896 (1 2897 ;; x is in fr1 2898 (inst fstp fr0) 2899 (inst fldln2) 2900 (inst fxch fr1)) 2901 (t 2902 ;; x is in a FP reg, not fr0 or fr1 2903 (inst fstp fr0) 2904 (inst fstp fr0) 2905 (inst fldln2) 2906 (inst fldd (make-random-tn :kind :normal 2907 :sc (sc-or-lose 'double-reg) 2908 :offset (1- (tn-offset x))))))) 2909 ((double-stack descriptor-reg) 2910 (inst fstp fr0) 2911 (inst fstp fr0) 2912 (inst fldln2) 2913 (if (sc-is x double-stack) 2914 (inst fldd (ea-for-df-stack x)) 2915 (inst fldd (ea-for-df-desc x))))) 2916 (inst fyl2xp1) 2917 (inst fld fr0) 2918 (case (tn-offset y) 2919 ((0 1)) 2920 (t (inst fstd y))))) 2921 2922(define-vop (flogb) 2923 (:translate %logb) 2924 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) 2925 (:temporary (:sc double-reg :offset fr0-offset 2926 :from :argument :to :result) fr0) 2927 (:temporary (:sc double-reg :offset fr1-offset 2928 :from :argument :to :result) fr1) 2929 (:results (y :scs (double-reg))) 2930 (:arg-types double-float) 2931 (:result-types double-float) 2932 (:policy :fast-safe) 2933 (:note "inline logb function") 2934 (:vop-var vop) 2935 (:save-p :compute-only) 2936 (:generator 5 2937 (note-this-location vop :internal-error) 2938 (sc-case x 2939 (double-reg 2940 (case (tn-offset x) 2941 (0 2942 ;; x is in fr0 2943 (inst fstp fr1)) 2944 (1 2945 ;; x is in fr1 2946 (inst fstp fr0)) 2947 (t 2948 ;; x is in a FP reg, not fr0 or fr1 2949 (inst fstp fr0) 2950 (inst fstp fr0) 2951 (inst fldd (make-random-tn :kind :normal 2952 :sc (sc-or-lose 'double-reg) 2953 :offset (- (tn-offset x) 2)))))) 2954 ((double-stack descriptor-reg) 2955 (inst fstp fr0) 2956 (inst fstp fr0) 2957 (if (sc-is x double-stack) 2958 (inst fldd (ea-for-df-stack x)) 2959 (inst fldd (ea-for-df-desc x))))) 2960 (inst fxtract) 2961 (case (tn-offset y) 2962 (0 2963 (inst fxch fr1)) 2964 (1) 2965 (t (inst fxch fr1) 2966 (inst fstd y))))) 2967 2968(define-vop (fatan) 2969 (:translate %atan) 2970 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)) 2971 (:temporary (:sc double-reg :offset fr0-offset 2972 :from (:argument 0) :to :result) fr0) 2973 (:temporary (:sc double-reg :offset fr1-offset 2974 :from (:argument 0) :to :result) fr1) 2975 (:results (r :scs (double-reg))) 2976 (:arg-types double-float) 2977 (:result-types double-float) 2978 (:policy :fast-safe) 2979 (:note "inline atan function") 2980 (:vop-var vop) 2981 (:save-p :compute-only) 2982 (:generator 5 2983 (note-this-location vop :internal-error) 2984 ;; Setup x in fr1 and 1.0 in fr0 2985 (cond 2986 ;; x in fr0 2987 ((and (sc-is x double-reg) (zerop (tn-offset x))) 2988 (inst fstp fr1)) 2989 ;; x in fr1 2990 ((and (sc-is x double-reg) (= 1 (tn-offset x))) 2991 (inst fstp fr0)) 2992 ;; x not in fr0 or fr1 2993 (t 2994 ;; Load x then 1.0 2995 (inst fstp fr0) 2996 (inst fstp fr0) 2997 (sc-case x 2998 (double-reg 2999 (inst fldd (make-random-tn :kind :normal 3000 :sc (sc-or-lose 'double-reg) 3001 :offset (- (tn-offset x) 2)))) 3002 (double-stack 3003 (inst fldd (ea-for-df-stack x))) 3004 (descriptor-reg 3005 (inst fldd (ea-for-df-desc x)))))) 3006 (inst fld1) 3007 ;; Now have x at fr1; and 1.0 at fr0 3008 (inst fpatan) 3009 (inst fld fr0) 3010 (case (tn-offset r) 3011 ((0 1)) 3012 (t (inst fstd r))))) 3013 3014(define-vop (fatan2) 3015 (:translate %atan2) 3016 (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1) 3017 (y :scs (double-reg double-stack descriptor-reg) :target fr0)) 3018 (:temporary (:sc double-reg :offset fr0-offset 3019 :from (:argument 1) :to :result) fr0) 3020 (:temporary (:sc double-reg :offset fr1-offset 3021 :from (:argument 0) :to :result) fr1) 3022 (:results (r :scs (double-reg))) 3023 (:arg-types double-float double-float) 3024 (:result-types double-float) 3025 (:policy :fast-safe) 3026 (:note "inline atan2 function") 3027 (:vop-var vop) 3028 (:save-p :compute-only) 3029 (:generator 5 3030 (note-this-location vop :internal-error) 3031 ;; Setup x in fr1 and y in fr0 3032 (cond 3033 ;; y in fr0; x in fr1 3034 ((and (sc-is y double-reg) (zerop (tn-offset y)) 3035 (sc-is x double-reg) (= 1 (tn-offset x)))) 3036 ;; x in fr1; y not in fr0 3037 ((and (sc-is x double-reg) (= 1 (tn-offset x))) 3038 ;; Load y to fr0 3039 (sc-case y 3040 (double-reg 3041 (copy-fp-reg-to-fr0 y)) 3042 (double-stack 3043 (inst fstp fr0) 3044 (inst fldd (ea-for-df-stack y))) 3045 (descriptor-reg 3046 (inst fstp fr0) 3047 (inst fldd (ea-for-df-desc y))))) 3048 ((and (sc-is x double-reg) (zerop (tn-offset x)) 3049 (sc-is y double-reg) (zerop (tn-offset x))) 3050 ;; copy x to fr1 3051 (inst fst fr1)) 3052 ;; y in fr0; x not in fr1 3053 ((and (sc-is y double-reg) (zerop (tn-offset y))) 3054 (inst fxch fr1) 3055 ;; Now load x to fr0 3056 (sc-case x 3057 (double-reg 3058 (copy-fp-reg-to-fr0 x)) 3059 (double-stack 3060 (inst fstp fr0) 3061 (inst fldd (ea-for-df-stack x))) 3062 (descriptor-reg 3063 (inst fstp fr0) 3064 (inst fldd (ea-for-df-desc x)))) 3065 (inst fxch fr1)) 3066 ;; y in fr1; x not in fr1 3067 ((and (sc-is y double-reg) (= 1 (tn-offset y))) 3068 ;; Load x to fr0 3069 (sc-case x 3070 (double-reg 3071 (copy-fp-reg-to-fr0 x)) 3072 (double-stack 3073 (inst fstp fr0) 3074 (inst fldd (ea-for-df-stack x))) 3075 (descriptor-reg 3076 (inst fstp fr0) 3077 (inst fldd (ea-for-df-desc x)))) 3078 (inst fxch fr1)) 3079 ;; x in fr0; 3080 ((and (sc-is x double-reg) (zerop (tn-offset x))) 3081 (inst fxch fr1) 3082 ;; Now load y to fr0 3083 (sc-case y 3084 (double-reg 3085 (copy-fp-reg-to-fr0 y)) 3086 (double-stack 3087 (inst fstp fr0) 3088 (inst fldd (ea-for-df-stack y))) 3089 (descriptor-reg 3090 (inst fstp fr0) 3091 (inst fldd (ea-for-df-desc y))))) 3092 ;; Neither y or x are in either fr0 or fr1 3093 (t 3094 ;; Load x then y 3095 (inst fstp fr0) 3096 (inst fstp fr0) 3097 (sc-case x 3098 (double-reg 3099 (inst fldd (make-random-tn :kind :normal 3100 :sc (sc-or-lose 'double-reg) 3101 :offset (- (tn-offset x) 2)))) 3102 (double-stack 3103 (inst fldd (ea-for-df-stack x))) 3104 (descriptor-reg 3105 (inst fldd (ea-for-df-desc x)))) 3106 ;; Load y to fr0 3107 (sc-case y 3108 (double-reg 3109 (inst fldd (make-random-tn :kind :normal 3110 :sc (sc-or-lose 'double-reg) 3111 :offset (1- (tn-offset y))))) 3112 (double-stack 3113 (inst fldd (ea-for-df-stack y))) 3114 (descriptor-reg 3115 (inst fldd (ea-for-df-desc y)))))) 3116 3117 ;; Now have y at fr0; and x at fr1 3118 (inst fpatan) 3119 (inst fld fr0) 3120 (case (tn-offset r) 3121 ((0 1)) 3122 (t (inst fstd r))))) 3123) ; PROGN #!-LONG-FLOAT 3124 3125#!+long-float 3126(progn 3127 3128;;; Lets use some of the 80387 special functions. 3129;;; 3130;;; These defs will not take effect unless code/irrat.lisp is modified 3131;;; to remove the inlined alien routine def. 3132 3133(macrolet ((frob (func trans op) 3134 `(define-vop (,func) 3135 (:args (x :scs (long-reg) :target fr0)) 3136 (:temporary (:sc long-reg :offset fr0-offset 3137 :from :argument :to :result) fr0) 3138 (:ignore fr0) 3139 (:results (y :scs (long-reg))) 3140 (:arg-types long-float) 3141 (:result-types long-float) 3142 (:translate ,trans) 3143 (:policy :fast-safe) 3144 (:note "inline NPX function") 3145 (:vop-var vop) 3146 (:save-p :compute-only) 3147 (:node-var node) 3148 (:generator 5 3149 (note-this-location vop :internal-error) 3150 (unless (zerop (tn-offset x)) 3151 (inst fxch x) ; x to top of stack 3152 (unless (location= x y) 3153 (inst fst x))) ; maybe save it 3154 (inst ,op) ; clobber st0 3155 (cond ((zerop (tn-offset y)) 3156 (maybe-fp-wait node)) 3157 (t 3158 (inst fst y))))))) 3159 3160 ;; Quick versions of FSIN and FCOS that require the argument to be 3161 ;; within range 2^63. 3162 (frob fsin-quick %sin-quick fsin) 3163 (frob fcos-quick %cos-quick fcos) 3164 (frob fsqrt %sqrt fsqrt)) 3165 3166;;; Quick version of ftan that requires the argument to be within 3167;;; range 2^63. 3168(define-vop (ftan-quick) 3169 (:translate %tan-quick) 3170 (:args (x :scs (long-reg) :target fr0)) 3171 (:temporary (:sc long-reg :offset fr0-offset 3172 :from :argument :to :result) fr0) 3173 (:temporary (:sc long-reg :offset fr1-offset 3174 :from :argument :to :result) fr1) 3175 (:results (y :scs (long-reg))) 3176 (:arg-types long-float) 3177 (:result-types long-float) 3178 (:policy :fast-safe) 3179 (:note "inline tan function") 3180 (:vop-var vop) 3181 (:save-p :compute-only) 3182 (:generator 5 3183 (note-this-location vop :internal-error) 3184 (case (tn-offset x) 3185 (0 3186 (inst fstp fr1)) 3187 (1 3188 (inst fstp fr0)) 3189 (t 3190 (inst fstp fr0) 3191 (inst fstp fr0) 3192 (inst fldd (make-random-tn :kind :normal 3193 :sc (sc-or-lose 'double-reg) 3194 :offset (- (tn-offset x) 2))))) 3195 (inst fptan) 3196 ;; Result is in fr1 3197 (case (tn-offset y) 3198 (0 3199 (inst fxch fr1)) 3200 (1) 3201 (t 3202 (inst fxch fr1) 3203 (inst fstd y))))) 3204 3205;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if 3206;;; the argument is out of range 2^63 and would thus be hopelessly 3207;;; inaccurate. 3208(macrolet ((frob (func trans op) 3209 `(define-vop (,func) 3210 (:translate ,trans) 3211 (:args (x :scs (long-reg) :target fr0)) 3212 (:temporary (:sc long-reg :offset fr0-offset 3213 :from :argument :to :result) fr0) 3214 (:temporary (:sc unsigned-reg :offset eax-offset 3215 :from :argument :to :result) eax) 3216 (:results (y :scs (long-reg))) 3217 (:arg-types long-float) 3218 (:result-types long-float) 3219 (:policy :fast-safe) 3220 (:note "inline sin/cos function") 3221 (:vop-var vop) 3222 (:save-p :compute-only) 3223 (:ignore eax) 3224 (:generator 5 3225 (note-this-location vop :internal-error) 3226 (unless (zerop (tn-offset x)) 3227 (inst fxch x) ; x to top of stack 3228 (unless (location= x y) 3229 (inst fst x))) ; maybe save it 3230 (inst ,op) 3231 (inst fnstsw) ; status word to ax 3232 (inst and ah-tn #x04) ; C2 3233 (inst jmp :z DONE) 3234 ;; Else x was out of range so reduce it; ST0 is unchanged. 3235 (inst fstp fr0) ; Load 0.0 3236 (inst fldz) 3237 DONE 3238 (unless (zerop (tn-offset y)) 3239 (inst fstd y)))))) 3240 (frob fsin %sin fsin) 3241 (frob fcos %cos fcos)) 3242 3243(define-vop (ftan) 3244 (:translate %tan) 3245 (:args (x :scs (long-reg) :target fr0)) 3246 (:temporary (:sc long-reg :offset fr0-offset 3247 :from :argument :to :result) fr0) 3248 (:temporary (:sc long-reg :offset fr1-offset 3249 :from :argument :to :result) fr1) 3250 (:temporary (:sc unsigned-reg :offset eax-offset 3251 :from :argument :to :result) eax) 3252 (:results (y :scs (long-reg))) 3253 (:arg-types long-float) 3254 (:result-types long-float) 3255 (:ignore eax) 3256 (:policy :fast-safe) 3257 (:note "inline tan function") 3258 (:vop-var vop) 3259 (:save-p :compute-only) 3260 (:ignore eax) 3261 (:generator 5 3262 (note-this-location vop :internal-error) 3263 (case (tn-offset x) 3264 (0 3265 (inst fstp fr1)) 3266 (1 3267 (inst fstp fr0)) 3268 (t 3269 (inst fstp fr0) 3270 (inst fstp fr0) 3271 (inst fldd (make-random-tn :kind :normal 3272 :sc (sc-or-lose 'double-reg) 3273 :offset (- (tn-offset x) 2))))) 3274 (inst fptan) 3275 (inst fnstsw) ; status word to ax 3276 (inst and ah-tn #x04) ; C2 3277 (inst jmp :z DONE) 3278 ;; Else x was out of range so reduce it; ST0 is unchanged. 3279 (inst fldz) ; Load 0.0 3280 (inst fxch fr1) 3281 DONE 3282 ;; Result is in fr1 3283 (case (tn-offset y) 3284 (0 3285 (inst fxch fr1)) 3286 (1) 3287 (t 3288 (inst fxch fr1) 3289 (inst fstd y))))) 3290 3291;;; Modified exp that handles the following special cases: 3292;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN. 3293(define-vop (fexp) 3294 (:translate %exp) 3295 (:args (x :scs (long-reg) :target fr0)) 3296 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) 3297 (:temporary (:sc long-reg :offset fr0-offset 3298 :from :argument :to :result) fr0) 3299 (:temporary (:sc long-reg :offset fr1-offset 3300 :from :argument :to :result) fr1) 3301 (:temporary (:sc long-reg :offset fr2-offset 3302 :from :argument :to :result) fr2) 3303 (:results (y :scs (long-reg))) 3304 (:arg-types long-float) 3305 (:result-types long-float) 3306 (:policy :fast-safe) 3307 (:note "inline exp function") 3308 (:vop-var vop) 3309 (:save-p :compute-only) 3310 (:ignore temp) 3311 (:generator 5 3312 (note-this-location vop :internal-error) 3313 (unless (zerop (tn-offset x)) 3314 (inst fxch x) ; x to top of stack 3315 (unless (location= x y) 3316 (inst fst x))) ; maybe save it 3317 ;; Check for Inf or NaN 3318 (inst fxam) 3319 (inst fnstsw) 3320 (inst sahf) 3321 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. 3322 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. 3323 (inst and ah-tn #x02) ; Test sign of Inf. 3324 (inst jmp :z DONE) ; +Inf gives +Inf. 3325 (inst fstp fr0) ; -Inf gives 0 3326 (inst fldz) 3327 (inst jmp-short DONE) 3328 NOINFNAN 3329 (inst fstp fr1) 3330 (inst fldl2e) 3331 (inst fmul fr1) 3332 ;; Now fr0=x log2(e) 3333 (inst fst fr1) 3334 (inst frndint) 3335 (inst fst fr2) 3336 (inst fsubp-sti fr1) 3337 (inst f2xm1) 3338 (inst fld1) 3339 (inst faddp-sti fr1) 3340 (inst fscale) 3341 (inst fld fr0) 3342 DONE 3343 (unless (zerop (tn-offset y)) 3344 (inst fstd y)))) 3345 3346;;; Expm1 = exp(x) - 1. 3347;;; Handles the following special cases: 3348;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN. 3349(define-vop (fexpm1) 3350 (:translate %expm1) 3351 (:args (x :scs (long-reg) :target fr0)) 3352 (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp) 3353 (:temporary (:sc long-reg :offset fr0-offset 3354 :from :argument :to :result) fr0) 3355 (:temporary (:sc long-reg :offset fr1-offset 3356 :from :argument :to :result) fr1) 3357 (:temporary (:sc long-reg :offset fr2-offset 3358 :from :argument :to :result) fr2) 3359 (:results (y :scs (long-reg))) 3360 (:arg-types long-float) 3361 (:result-types long-float) 3362 (:policy :fast-safe) 3363 (:note "inline expm1 function") 3364 (:vop-var vop) 3365 (:save-p :compute-only) 3366 (:ignore temp) 3367 (:generator 5 3368 (note-this-location vop :internal-error) 3369 (unless (zerop (tn-offset x)) 3370 (inst fxch x) ; x to top of stack 3371 (unless (location= x y) 3372 (inst fst x))) ; maybe save it 3373 ;; Check for Inf or NaN 3374 (inst fxam) 3375 (inst fnstsw) 3376 (inst sahf) 3377 (inst jmp :nc NOINFNAN) ; Neither Inf or NaN. 3378 (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue. 3379 (inst and ah-tn #x02) ; Test sign of Inf. 3380 (inst jmp :z DONE) ; +Inf gives +Inf. 3381 (inst fstp fr0) ; -Inf gives -1.0 3382 (inst fld1) 3383 (inst fchs) 3384 (inst jmp-short DONE) 3385 NOINFNAN 3386 ;; Free two stack slots leaving the argument on top. 3387 (inst fstp fr2) 3388 (inst fstp fr0) 3389 (inst fldl2e) 3390 (inst fmul fr1) ; Now fr0 = x log2(e) 3391 (inst fst fr1) 3392 (inst frndint) 3393 (inst fsub-sti fr1) 3394 (inst fxch fr1) 3395 (inst f2xm1) 3396 (inst fscale) 3397 (inst fxch fr1) 3398 (inst fld1) 3399 (inst fscale) 3400 (inst fstp fr1) 3401 (inst fld1) 3402 (inst fsub fr1) 3403 (inst fsubr fr2) 3404 DONE 3405 (unless (zerop (tn-offset y)) 3406 (inst fstd y)))) 3407 3408(define-vop (flog) 3409 (:translate %log) 3410 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) 3411 (:temporary (:sc long-reg :offset fr0-offset 3412 :from :argument :to :result) fr0) 3413 (:temporary (:sc long-reg :offset fr1-offset 3414 :from :argument :to :result) fr1) 3415 (:results (y :scs (long-reg))) 3416 (:arg-types long-float) 3417 (:result-types long-float) 3418 (:policy :fast-safe) 3419 (:note "inline log function") 3420 (:vop-var vop) 3421 (:save-p :compute-only) 3422 (:generator 5 3423 (note-this-location vop :internal-error) 3424 (sc-case x 3425 (long-reg 3426 (case (tn-offset x) 3427 (0 3428 ;; x is in fr0 3429 (inst fstp fr1) 3430 (inst fldln2) 3431 (inst fxch fr1)) 3432 (1 3433 ;; x is in fr1 3434 (inst fstp fr0) 3435 (inst fldln2) 3436 (inst fxch fr1)) 3437 (t 3438 ;; x is in a FP reg, not fr0 or fr1 3439 (inst fstp fr0) 3440 (inst fstp fr0) 3441 (inst fldln2) 3442 (inst fldd (make-random-tn :kind :normal 3443 :sc (sc-or-lose 'double-reg) 3444 :offset (1- (tn-offset x)))))) 3445 (inst fyl2x)) 3446 ((long-stack descriptor-reg) 3447 (inst fstp fr0) 3448 (inst fstp fr0) 3449 (inst fldln2) 3450 (if (sc-is x long-stack) 3451 (inst fldl (ea-for-lf-stack x)) 3452 (inst fldl (ea-for-lf-desc x))) 3453 (inst fyl2x))) 3454 (inst fld fr0) 3455 (case (tn-offset y) 3456 ((0 1)) 3457 (t (inst fstd y))))) 3458 3459(define-vop (flog10) 3460 (:translate %log10) 3461 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) 3462 (:temporary (:sc long-reg :offset fr0-offset 3463 :from :argument :to :result) fr0) 3464 (:temporary (:sc long-reg :offset fr1-offset 3465 :from :argument :to :result) fr1) 3466 (:results (y :scs (long-reg))) 3467 (:arg-types long-float) 3468 (:result-types long-float) 3469 (:policy :fast-safe) 3470 (:note "inline log10 function") 3471 (:vop-var vop) 3472 (:save-p :compute-only) 3473 (:generator 5 3474 (note-this-location vop :internal-error) 3475 (sc-case x 3476 (long-reg 3477 (case (tn-offset x) 3478 (0 3479 ;; x is in fr0 3480 (inst fstp fr1) 3481 (inst fldlg2) 3482 (inst fxch fr1)) 3483 (1 3484 ;; x is in fr1 3485 (inst fstp fr0) 3486 (inst fldlg2) 3487 (inst fxch fr1)) 3488 (t 3489 ;; x is in a FP reg, not fr0 or fr1 3490 (inst fstp fr0) 3491 (inst fstp fr0) 3492 (inst fldlg2) 3493 (inst fldd (make-random-tn :kind :normal 3494 :sc (sc-or-lose 'double-reg) 3495 :offset (1- (tn-offset x)))))) 3496 (inst fyl2x)) 3497 ((long-stack descriptor-reg) 3498 (inst fstp fr0) 3499 (inst fstp fr0) 3500 (inst fldlg2) 3501 (if (sc-is x long-stack) 3502 (inst fldl (ea-for-lf-stack x)) 3503 (inst fldl (ea-for-lf-desc x))) 3504 (inst fyl2x))) 3505 (inst fld fr0) 3506 (case (tn-offset y) 3507 ((0 1)) 3508 (t (inst fstd y))))) 3509 3510(define-vop (fpow) 3511 (:translate %pow) 3512 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) 3513 (y :scs (long-reg long-stack descriptor-reg) :target fr1)) 3514 (:temporary (:sc long-reg :offset fr0-offset 3515 :from (:argument 0) :to :result) fr0) 3516 (:temporary (:sc long-reg :offset fr1-offset 3517 :from (:argument 1) :to :result) fr1) 3518 (:temporary (:sc long-reg :offset fr2-offset 3519 :from :load :to :result) fr2) 3520 (:results (r :scs (long-reg))) 3521 (:arg-types long-float long-float) 3522 (:result-types long-float) 3523 (:policy :fast-safe) 3524 (:note "inline pow function") 3525 (:vop-var vop) 3526 (:save-p :compute-only) 3527 (:generator 5 3528 (note-this-location vop :internal-error) 3529 ;; Setup x in fr0 and y in fr1 3530 (cond 3531 ;; x in fr0; y in fr1 3532 ((and (sc-is x long-reg) (zerop (tn-offset x)) 3533 (sc-is y long-reg) (= 1 (tn-offset y)))) 3534 ;; y in fr1; x not in fr0 3535 ((and (sc-is y long-reg) (= 1 (tn-offset y))) 3536 ;; Load x to fr0 3537 (sc-case x 3538 (long-reg 3539 (copy-fp-reg-to-fr0 x)) 3540 (long-stack 3541 (inst fstp fr0) 3542 (inst fldl (ea-for-lf-stack x))) 3543 (descriptor-reg 3544 (inst fstp fr0) 3545 (inst fldl (ea-for-lf-desc x))))) 3546 ;; x in fr0; y not in fr1 3547 ((and (sc-is x long-reg) (zerop (tn-offset x))) 3548 (inst fxch fr1) 3549 ;; Now load y to fr0 3550 (sc-case y 3551 (long-reg 3552 (copy-fp-reg-to-fr0 y)) 3553 (long-stack 3554 (inst fstp fr0) 3555 (inst fldl (ea-for-lf-stack y))) 3556 (descriptor-reg 3557 (inst fstp fr0) 3558 (inst fldl (ea-for-lf-desc y)))) 3559 (inst fxch fr1)) 3560 ;; x in fr1; y not in fr1 3561 ((and (sc-is x long-reg) (= 1 (tn-offset x))) 3562 ;; Load y to fr0 3563 (sc-case y 3564 (long-reg 3565 (copy-fp-reg-to-fr0 y)) 3566 (long-stack 3567 (inst fstp fr0) 3568 (inst fldl (ea-for-lf-stack y))) 3569 (descriptor-reg 3570 (inst fstp fr0) 3571 (inst fldl (ea-for-lf-desc y)))) 3572 (inst fxch fr1)) 3573 ;; y in fr0; 3574 ((and (sc-is y long-reg) (zerop (tn-offset y))) 3575 (inst fxch fr1) 3576 ;; Now load x to fr0 3577 (sc-case x 3578 (long-reg 3579 (copy-fp-reg-to-fr0 x)) 3580 (long-stack 3581 (inst fstp fr0) 3582 (inst fldl (ea-for-lf-stack x))) 3583 (descriptor-reg 3584 (inst fstp fr0) 3585 (inst fldl (ea-for-lf-desc x))))) 3586 ;; Neither x or y are in either fr0 or fr1 3587 (t 3588 ;; Load y then x 3589 (inst fstp fr0) 3590 (inst fstp fr0) 3591 (sc-case y 3592 (long-reg 3593 (inst fldd (make-random-tn :kind :normal 3594 :sc (sc-or-lose 'double-reg) 3595 :offset (- (tn-offset y) 2)))) 3596 (long-stack 3597 (inst fldl (ea-for-lf-stack y))) 3598 (descriptor-reg 3599 (inst fldl (ea-for-lf-desc y)))) 3600 ;; Load x to fr0 3601 (sc-case x 3602 (long-reg 3603 (inst fldd (make-random-tn :kind :normal 3604 :sc (sc-or-lose 'double-reg) 3605 :offset (1- (tn-offset x))))) 3606 (long-stack 3607 (inst fldl (ea-for-lf-stack x))) 3608 (descriptor-reg 3609 (inst fldl (ea-for-lf-desc x)))))) 3610 3611 ;; Now have x at fr0; and y at fr1 3612 (inst fyl2x) 3613 ;; Now fr0=y log2(x) 3614 (inst fld fr0) 3615 (inst frndint) 3616 (inst fst fr2) 3617 (inst fsubp-sti fr1) 3618 (inst f2xm1) 3619 (inst fld1) 3620 (inst faddp-sti fr1) 3621 (inst fscale) 3622 (inst fld fr0) 3623 (case (tn-offset r) 3624 ((0 1)) 3625 (t (inst fstd r))))) 3626 3627(define-vop (fscalen) 3628 (:translate %scalbn) 3629 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) 3630 (y :scs (signed-stack signed-reg) :target temp)) 3631 (:temporary (:sc long-reg :offset fr0-offset 3632 :from (:argument 0) :to :result) fr0) 3633 (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1) 3634 (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp) 3635 (:results (r :scs (long-reg))) 3636 (:arg-types long-float signed-num) 3637 (:result-types long-float) 3638 (:policy :fast-safe) 3639 (:note "inline scalbn function") 3640 (:generator 5 3641 ;; Setup x in fr0 and y in fr1 3642 (sc-case x 3643 (long-reg 3644 (case (tn-offset x) 3645 (0 3646 (inst fstp fr1) 3647 (sc-case y 3648 (signed-reg 3649 (inst mov temp y) 3650 (inst fild temp)) 3651 (signed-stack 3652 (inst fild y))) 3653 (inst fxch fr1)) 3654 (1 3655 (inst fstp fr0) 3656 (sc-case y 3657 (signed-reg 3658 (inst mov temp y) 3659 (inst fild temp)) 3660 (signed-stack 3661 (inst fild y))) 3662 (inst fxch fr1)) 3663 (t 3664 (inst fstp fr0) 3665 (inst fstp fr0) 3666 (sc-case y 3667 (signed-reg 3668 (inst mov temp y) 3669 (inst fild temp)) 3670 (signed-stack 3671 (inst fild y))) 3672 (inst fld (make-random-tn :kind :normal 3673 :sc (sc-or-lose 'double-reg) 3674 :offset (1- (tn-offset x))))))) 3675 ((long-stack descriptor-reg) 3676 (inst fstp fr0) 3677 (inst fstp fr0) 3678 (sc-case y 3679 (signed-reg 3680 (inst mov temp y) 3681 (inst fild temp)) 3682 (signed-stack 3683 (inst fild y))) 3684 (if (sc-is x long-stack) 3685 (inst fldl (ea-for-lf-stack x)) 3686 (inst fldl (ea-for-lf-desc x))))) 3687 (inst fscale) 3688 (unless (zerop (tn-offset r)) 3689 (inst fstd r)))) 3690 3691(define-vop (fscale) 3692 (:translate %scalb) 3693 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0) 3694 (y :scs (long-reg long-stack descriptor-reg) :target fr1)) 3695 (:temporary (:sc long-reg :offset fr0-offset 3696 :from (:argument 0) :to :result) fr0) 3697 (:temporary (:sc long-reg :offset fr1-offset 3698 :from (:argument 1) :to :result) fr1) 3699 (:results (r :scs (long-reg))) 3700 (:arg-types long-float long-float) 3701 (:result-types long-float) 3702 (:policy :fast-safe) 3703 (:note "inline scalb function") 3704 (:vop-var vop) 3705 (:save-p :compute-only) 3706 (:generator 5 3707 (note-this-location vop :internal-error) 3708 ;; Setup x in fr0 and y in fr1 3709 (cond 3710 ;; x in fr0; y in fr1 3711 ((and (sc-is x long-reg) (zerop (tn-offset x)) 3712 (sc-is y long-reg) (= 1 (tn-offset y)))) 3713 ;; y in fr1; x not in fr0 3714 ((and (sc-is y long-reg) (= 1 (tn-offset y))) 3715 ;; Load x to fr0 3716 (sc-case x 3717 (long-reg 3718 (copy-fp-reg-to-fr0 x)) 3719 (long-stack 3720 (inst fstp fr0) 3721 (inst fldl (ea-for-lf-stack x))) 3722 (descriptor-reg 3723 (inst fstp fr0) 3724 (inst fldl (ea-for-lf-desc x))))) 3725 ;; x in fr0; y not in fr1 3726 ((and (sc-is x long-reg) (zerop (tn-offset x))) 3727 (inst fxch fr1) 3728 ;; Now load y to fr0 3729 (sc-case y 3730 (long-reg 3731 (copy-fp-reg-to-fr0 y)) 3732 (long-stack 3733 (inst fstp fr0) 3734 (inst fldl (ea-for-lf-stack y))) 3735 (descriptor-reg 3736 (inst fstp fr0) 3737 (inst fldl (ea-for-lf-desc y)))) 3738 (inst fxch fr1)) 3739 ;; x in fr1; y not in fr1 3740 ((and (sc-is x long-reg) (= 1 (tn-offset x))) 3741 ;; Load y to fr0 3742 (sc-case y 3743 (long-reg 3744 (copy-fp-reg-to-fr0 y)) 3745 (long-stack 3746 (inst fstp fr0) 3747 (inst fldl (ea-for-lf-stack y))) 3748 (descriptor-reg 3749 (inst fstp fr0) 3750 (inst fldl (ea-for-lf-desc y)))) 3751 (inst fxch fr1)) 3752 ;; y in fr0; 3753 ((and (sc-is y long-reg) (zerop (tn-offset y))) 3754 (inst fxch fr1) 3755 ;; Now load x to fr0 3756 (sc-case x 3757 (long-reg 3758 (copy-fp-reg-to-fr0 x)) 3759 (long-stack 3760 (inst fstp fr0) 3761 (inst fldl (ea-for-lf-stack x))) 3762 (descriptor-reg 3763 (inst fstp fr0) 3764 (inst fldl (ea-for-lf-desc x))))) 3765 ;; Neither x or y are in either fr0 or fr1 3766 (t 3767 ;; Load y then x 3768 (inst fstp fr0) 3769 (inst fstp fr0) 3770 (sc-case y 3771 (long-reg 3772 (inst fldd (make-random-tn :kind :normal 3773 :sc (sc-or-lose 'double-reg) 3774 :offset (- (tn-offset y) 2)))) 3775 (long-stack 3776 (inst fldl (ea-for-lf-stack y))) 3777 (descriptor-reg 3778 (inst fldl (ea-for-lf-desc y)))) 3779 ;; Load x to fr0 3780 (sc-case x 3781 (long-reg 3782 (inst fldd (make-random-tn :kind :normal 3783 :sc (sc-or-lose 'double-reg) 3784 :offset (1- (tn-offset x))))) 3785 (long-stack 3786 (inst fldl (ea-for-lf-stack x))) 3787 (descriptor-reg 3788 (inst fldl (ea-for-lf-desc x)))))) 3789 3790 ;; Now have x at fr0; and y at fr1 3791 (inst fscale) 3792 (unless (zerop (tn-offset r)) 3793 (inst fstd r)))) 3794 3795(define-vop (flog1p) 3796 (:translate %log1p) 3797 (:args (x :scs (long-reg) :to :result)) 3798 (:temporary (:sc long-reg :offset fr0-offset 3799 :from :argument :to :result) fr0) 3800 (:temporary (:sc long-reg :offset fr1-offset 3801 :from :argument :to :result) fr1) 3802 (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) 3803 (:results (y :scs (long-reg))) 3804 (:arg-types long-float) 3805 (:result-types long-float) 3806 (:policy :fast-safe) 3807 ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P. 3808 ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around 3809 ;; an enormous PROGN above. Still, it would be probably be good to 3810 ;; add some code to warn about redefining VOPs. 3811 (:note "inline log1p function") 3812 (:ignore temp) 3813 (:generator 5 3814 ;; x is in a FP reg, not fr0, fr1. 3815 (inst fstp fr0) 3816 (inst fstp fr0) 3817 (inst fldd (make-random-tn :kind :normal 3818 :sc (sc-or-lose 'double-reg) 3819 :offset (- (tn-offset x) 2))) 3820 ;; Check the range 3821 (inst push #x3e947ae1) ; Constant 0.29 3822 (inst fabs) 3823 (inst fld (make-ea :dword :base esp-tn)) 3824 (inst fcompp) 3825 (inst add esp-tn 4) 3826 (inst fnstsw) ; status word to ax 3827 (inst and ah-tn #x45) 3828 (inst jmp :z WITHIN-RANGE) 3829 ;; Out of range for fyl2xp1. 3830 (inst fld1) 3831 (inst faddd (make-random-tn :kind :normal 3832 :sc (sc-or-lose 'double-reg) 3833 :offset (- (tn-offset x) 1))) 3834 (inst fldln2) 3835 (inst fxch fr1) 3836 (inst fyl2x) 3837 (inst jmp DONE) 3838 3839 WITHIN-RANGE 3840 (inst fldln2) 3841 (inst fldd (make-random-tn :kind :normal 3842 :sc (sc-or-lose 'double-reg) 3843 :offset (- (tn-offset x) 1))) 3844 (inst fyl2xp1) 3845 DONE 3846 (inst fld fr0) 3847 (case (tn-offset y) 3848 ((0 1)) 3849 (t (inst fstd y))))) 3850 3851;;; The Pentium has a less restricted implementation of the fyl2xp1 3852;;; instruction and a range check can be avoided. 3853(define-vop (flog1p-pentium) 3854 (:translate %log1p) 3855 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) 3856 (:temporary (:sc long-reg :offset fr0-offset 3857 :from :argument :to :result) fr0) 3858 (:temporary (:sc long-reg :offset fr1-offset 3859 :from :argument :to :result) fr1) 3860 (:results (y :scs (long-reg))) 3861 (:arg-types long-float) 3862 (:result-types long-float) 3863 (:policy :fast-safe) 3864 (:guard (member :pentium-style-fyl2xp1 *backend-subfeatures*)) 3865 (:note "inline log1p function") 3866 (:generator 5 3867 (sc-case x 3868 (long-reg 3869 (case (tn-offset x) 3870 (0 3871 ;; x is in fr0 3872 (inst fstp fr1) 3873 (inst fldln2) 3874 (inst fxch fr1)) 3875 (1 3876 ;; x is in fr1 3877 (inst fstp fr0) 3878 (inst fldln2) 3879 (inst fxch fr1)) 3880 (t 3881 ;; x is in a FP reg, not fr0 or fr1 3882 (inst fstp fr0) 3883 (inst fstp fr0) 3884 (inst fldln2) 3885 (inst fldd (make-random-tn :kind :normal 3886 :sc (sc-or-lose 'double-reg) 3887 :offset (1- (tn-offset x))))))) 3888 ((long-stack descriptor-reg) 3889 (inst fstp fr0) 3890 (inst fstp fr0) 3891 (inst fldln2) 3892 (if (sc-is x long-stack) 3893 (inst fldl (ea-for-lf-stack x)) 3894 (inst fldl (ea-for-lf-desc x))))) 3895 (inst fyl2xp1) 3896 (inst fld fr0) 3897 (case (tn-offset y) 3898 ((0 1)) 3899 (t (inst fstd y))))) 3900 3901(define-vop (flogb) 3902 (:translate %logb) 3903 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) 3904 (:temporary (:sc long-reg :offset fr0-offset 3905 :from :argument :to :result) fr0) 3906 (:temporary (:sc long-reg :offset fr1-offset 3907 :from :argument :to :result) fr1) 3908 (:results (y :scs (long-reg))) 3909 (:arg-types long-float) 3910 (:result-types long-float) 3911 (:policy :fast-safe) 3912 (:note "inline logb function") 3913 (:vop-var vop) 3914 (:save-p :compute-only) 3915 (:generator 5 3916 (note-this-location vop :internal-error) 3917 (sc-case x 3918 (long-reg 3919 (case (tn-offset x) 3920 (0 3921 ;; x is in fr0 3922 (inst fstp fr1)) 3923 (1 3924 ;; x is in fr1 3925 (inst fstp fr0)) 3926 (t 3927 ;; x is in a FP reg, not fr0 or fr1 3928 (inst fstp fr0) 3929 (inst fstp fr0) 3930 (inst fldd (make-random-tn :kind :normal 3931 :sc (sc-or-lose 'double-reg) 3932 :offset (- (tn-offset x) 2)))))) 3933 ((long-stack descriptor-reg) 3934 (inst fstp fr0) 3935 (inst fstp fr0) 3936 (if (sc-is x long-stack) 3937 (inst fldl (ea-for-lf-stack x)) 3938 (inst fldl (ea-for-lf-desc x))))) 3939 (inst fxtract) 3940 (case (tn-offset y) 3941 (0 3942 (inst fxch fr1)) 3943 (1) 3944 (t (inst fxch fr1) 3945 (inst fstd y))))) 3946 3947(define-vop (fatan) 3948 (:translate %atan) 3949 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)) 3950 (:temporary (:sc long-reg :offset fr0-offset 3951 :from (:argument 0) :to :result) fr0) 3952 (:temporary (:sc long-reg :offset fr1-offset 3953 :from (:argument 0) :to :result) fr1) 3954 (:results (r :scs (long-reg))) 3955 (:arg-types long-float) 3956 (:result-types long-float) 3957 (:policy :fast-safe) 3958 (:note "inline atan function") 3959 (:vop-var vop) 3960 (:save-p :compute-only) 3961 (:generator 5 3962 (note-this-location vop :internal-error) 3963 ;; Setup x in fr1 and 1.0 in fr0 3964 (cond 3965 ;; x in fr0 3966 ((and (sc-is x long-reg) (zerop (tn-offset x))) 3967 (inst fstp fr1)) 3968 ;; x in fr1 3969 ((and (sc-is x long-reg) (= 1 (tn-offset x))) 3970 (inst fstp fr0)) 3971 ;; x not in fr0 or fr1 3972 (t 3973 ;; Load x then 1.0 3974 (inst fstp fr0) 3975 (inst fstp fr0) 3976 (sc-case x 3977 (long-reg 3978 (inst fldd (make-random-tn :kind :normal 3979 :sc (sc-or-lose 'double-reg) 3980 :offset (- (tn-offset x) 2)))) 3981 (long-stack 3982 (inst fldl (ea-for-lf-stack x))) 3983 (descriptor-reg 3984 (inst fldl (ea-for-lf-desc x)))))) 3985 (inst fld1) 3986 ;; Now have x at fr1; and 1.0 at fr0 3987 (inst fpatan) 3988 (inst fld fr0) 3989 (case (tn-offset r) 3990 ((0 1)) 3991 (t (inst fstd r))))) 3992 3993(define-vop (fatan2) 3994 (:translate %atan2) 3995 (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1) 3996 (y :scs (long-reg long-stack descriptor-reg) :target fr0)) 3997 (:temporary (:sc long-reg :offset fr0-offset 3998 :from (:argument 1) :to :result) fr0) 3999 (:temporary (:sc long-reg :offset fr1-offset 4000 :from (:argument 0) :to :result) fr1) 4001 (:results (r :scs (long-reg))) 4002 (:arg-types long-float long-float) 4003 (:result-types long-float) 4004 (:policy :fast-safe) 4005 (:note "inline atan2 function") 4006 (:vop-var vop) 4007 (:save-p :compute-only) 4008 (:generator 5 4009 (note-this-location vop :internal-error) 4010 ;; Setup x in fr1 and y in fr0 4011 (cond 4012 ;; y in fr0; x in fr1 4013 ((and (sc-is y long-reg) (zerop (tn-offset y)) 4014 (sc-is x long-reg) (= 1 (tn-offset x)))) 4015 ;; x in fr1; y not in fr0 4016 ((and (sc-is x long-reg) (= 1 (tn-offset x))) 4017 ;; Load y to fr0 4018 (sc-case y 4019 (long-reg 4020 (copy-fp-reg-to-fr0 y)) 4021 (long-stack 4022 (inst fstp fr0) 4023 (inst fldl (ea-for-lf-stack y))) 4024 (descriptor-reg 4025 (inst fstp fr0) 4026 (inst fldl (ea-for-lf-desc y))))) 4027 ;; y in fr0; x not in fr1 4028 ((and (sc-is y long-reg) (zerop (tn-offset y))) 4029 (inst fxch fr1) 4030 ;; Now load x to fr0 4031 (sc-case x 4032 (long-reg 4033 (copy-fp-reg-to-fr0 x)) 4034 (long-stack 4035 (inst fstp fr0) 4036 (inst fldl (ea-for-lf-stack x))) 4037 (descriptor-reg 4038 (inst fstp fr0) 4039 (inst fldl (ea-for-lf-desc x)))) 4040 (inst fxch fr1)) 4041 ;; y in fr1; x not in fr1 4042 ((and (sc-is y long-reg) (= 1 (tn-offset y))) 4043 ;; Load x to fr0 4044 (sc-case x 4045 (long-reg 4046 (copy-fp-reg-to-fr0 x)) 4047 (long-stack 4048 (inst fstp fr0) 4049 (inst fldl (ea-for-lf-stack x))) 4050 (descriptor-reg 4051 (inst fstp fr0) 4052 (inst fldl (ea-for-lf-desc x)))) 4053 (inst fxch fr1)) 4054 ;; x in fr0; 4055 ((and (sc-is x long-reg) (zerop (tn-offset x))) 4056 (inst fxch fr1) 4057 ;; Now load y to fr0 4058 (sc-case y 4059 (long-reg 4060 (copy-fp-reg-to-fr0 y)) 4061 (long-stack 4062 (inst fstp fr0) 4063 (inst fldl (ea-for-lf-stack y))) 4064 (descriptor-reg 4065 (inst fstp fr0) 4066 (inst fldl (ea-for-lf-desc y))))) 4067 ;; Neither y or x are in either fr0 or fr1 4068 (t 4069 ;; Load x then y 4070 (inst fstp fr0) 4071 (inst fstp fr0) 4072 (sc-case x 4073 (long-reg 4074 (inst fldd (make-random-tn :kind :normal 4075 :sc (sc-or-lose 'double-reg) 4076 :offset (- (tn-offset x) 2)))) 4077 (long-stack 4078 (inst fldl (ea-for-lf-stack x))) 4079 (descriptor-reg 4080 (inst fldl (ea-for-lf-desc x)))) 4081 ;; Load y to fr0 4082 (sc-case y 4083 (long-reg 4084 (inst fldd (make-random-tn :kind :normal 4085 :sc (sc-or-lose 'double-reg) 4086 :offset (1- (tn-offset y))))) 4087 (long-stack 4088 (inst fldl (ea-for-lf-stack y))) 4089 (descriptor-reg 4090 (inst fldl (ea-for-lf-desc y)))))) 4091 4092 ;; Now have y at fr0; and x at fr1 4093 (inst fpatan) 4094 (inst fld fr0) 4095 (case (tn-offset r) 4096 ((0 1)) 4097 (t (inst fstd r))))) 4098 4099) ; PROGN #!+LONG-FLOAT 4100 4101;;;; complex float VOPs 4102 4103(define-vop (make-complex-single-float) 4104 (:translate complex) 4105 (:args (real :scs (single-reg) :to :result :target r 4106 :load-if (not (location= real r))) 4107 (imag :scs (single-reg) :to :save)) 4108 (:arg-types single-float single-float) 4109 (:results (r :scs (complex-single-reg) :from (:argument 0) 4110 :load-if (not (sc-is r complex-single-stack)))) 4111 (:result-types complex-single-float) 4112 (:note "inline complex single-float creation") 4113 (:policy :fast-safe) 4114 (:generator 5 4115 (sc-case r 4116 (complex-single-reg 4117 (let ((r-real (complex-double-reg-real-tn r))) 4118 (unless (location= real r-real) 4119 (cond ((zerop (tn-offset r-real)) 4120 (copy-fp-reg-to-fr0 real)) 4121 ((zerop (tn-offset real)) 4122 (inst fstd r-real)) 4123 (t 4124 (inst fxch real) 4125 (inst fstd r-real) 4126 (inst fxch real))))) 4127 (let ((r-imag (complex-double-reg-imag-tn r))) 4128 (unless (location= imag r-imag) 4129 (cond ((zerop (tn-offset imag)) 4130 (inst fstd r-imag)) 4131 (t 4132 (inst fxch imag) 4133 (inst fstd r-imag) 4134 (inst fxch imag)))))) 4135 (complex-single-stack 4136 (unless (location= real r) 4137 (cond ((zerop (tn-offset real)) 4138 (inst fst (ea-for-csf-real-stack r))) 4139 (t 4140 (inst fxch real) 4141 (inst fst (ea-for-csf-real-stack r)) 4142 (inst fxch real)))) 4143 (inst fxch imag) 4144 (inst fst (ea-for-csf-imag-stack r)) 4145 (inst fxch imag))))) 4146 4147(define-vop (make-complex-double-float) 4148 (:translate complex) 4149 (:args (real :scs (double-reg) :target r 4150 :load-if (not (location= real r))) 4151 (imag :scs (double-reg) :to :save)) 4152 (:arg-types double-float double-float) 4153 (:results (r :scs (complex-double-reg) :from (:argument 0) 4154 :load-if (not (sc-is r complex-double-stack)))) 4155 (:result-types complex-double-float) 4156 (:note "inline complex double-float creation") 4157 (:policy :fast-safe) 4158 (:generator 5 4159 (sc-case r 4160 (complex-double-reg 4161 (let ((r-real (complex-double-reg-real-tn r))) 4162 (unless (location= real r-real) 4163 (cond ((zerop (tn-offset r-real)) 4164 (copy-fp-reg-to-fr0 real)) 4165 ((zerop (tn-offset real)) 4166 (inst fstd r-real)) 4167 (t 4168 (inst fxch real) 4169 (inst fstd r-real) 4170 (inst fxch real))))) 4171 (let ((r-imag (complex-double-reg-imag-tn r))) 4172 (unless (location= imag r-imag) 4173 (cond ((zerop (tn-offset imag)) 4174 (inst fstd r-imag)) 4175 (t 4176 (inst fxch imag) 4177 (inst fstd r-imag) 4178 (inst fxch imag)))))) 4179 (complex-double-stack 4180 (unless (location= real r) 4181 (cond ((zerop (tn-offset real)) 4182 (inst fstd (ea-for-cdf-real-stack r))) 4183 (t 4184 (inst fxch real) 4185 (inst fstd (ea-for-cdf-real-stack r)) 4186 (inst fxch real)))) 4187 (inst fxch imag) 4188 (inst fstd (ea-for-cdf-imag-stack r)) 4189 (inst fxch imag))))) 4190 4191#!+long-float 4192(define-vop (make-complex-long-float) 4193 (:translate complex) 4194 (:args (real :scs (long-reg) :target r 4195 :load-if (not (location= real r))) 4196 (imag :scs (long-reg) :to :save)) 4197 (:arg-types long-float long-float) 4198 (:results (r :scs (complex-long-reg) :from (:argument 0) 4199 :load-if (not (sc-is r complex-long-stack)))) 4200 (:result-types complex-long-float) 4201 (:note "inline complex long-float creation") 4202 (:policy :fast-safe) 4203 (:generator 5 4204 (sc-case r 4205 (complex-long-reg 4206 (let ((r-real (complex-double-reg-real-tn r))) 4207 (unless (location= real r-real) 4208 (cond ((zerop (tn-offset r-real)) 4209 (copy-fp-reg-to-fr0 real)) 4210 ((zerop (tn-offset real)) 4211 (inst fstd r-real)) 4212 (t 4213 (inst fxch real) 4214 (inst fstd r-real) 4215 (inst fxch real))))) 4216 (let ((r-imag (complex-double-reg-imag-tn r))) 4217 (unless (location= imag r-imag) 4218 (cond ((zerop (tn-offset imag)) 4219 (inst fstd r-imag)) 4220 (t 4221 (inst fxch imag) 4222 (inst fstd r-imag) 4223 (inst fxch imag)))))) 4224 (complex-long-stack 4225 (unless (location= real r) 4226 (cond ((zerop (tn-offset real)) 4227 (store-long-float (ea-for-clf-real-stack r))) 4228 (t 4229 (inst fxch real) 4230 (store-long-float (ea-for-clf-real-stack r)) 4231 (inst fxch real)))) 4232 (inst fxch imag) 4233 (store-long-float (ea-for-clf-imag-stack r)) 4234 (inst fxch imag))))) 4235 4236 4237(define-vop (complex-float-value) 4238 (:args (x :target r)) 4239 (:results (r)) 4240 (:variant-vars offset) 4241 (:policy :fast-safe) 4242 (:generator 3 4243 (cond ((sc-is x complex-single-reg complex-double-reg 4244 #!+long-float complex-long-reg) 4245 (let ((value-tn 4246 (make-random-tn :kind :normal 4247 :sc (sc-or-lose 'double-reg) 4248 :offset (+ offset (tn-offset x))))) 4249 (unless (location= value-tn r) 4250 (cond ((zerop (tn-offset r)) 4251 (copy-fp-reg-to-fr0 value-tn)) 4252 ((zerop (tn-offset value-tn)) 4253 (inst fstd r)) 4254 (t 4255 (inst fxch value-tn) 4256 (inst fstd r) 4257 (inst fxch value-tn)))))) 4258 ((sc-is r single-reg) 4259 (let ((ea (sc-case x 4260 (complex-single-stack 4261 (ecase offset 4262 (0 (ea-for-csf-real-stack x)) 4263 (1 (ea-for-csf-imag-stack x)))) 4264 (descriptor-reg 4265 (ecase offset 4266 (0 (ea-for-csf-real-desc x)) 4267 (1 (ea-for-csf-imag-desc x))))))) 4268 (with-empty-tn@fp-top(r) 4269 (inst fld ea)))) 4270 ((sc-is r double-reg) 4271 (let ((ea (sc-case x 4272 (complex-double-stack 4273 (ecase offset 4274 (0 (ea-for-cdf-real-stack x)) 4275 (1 (ea-for-cdf-imag-stack x)))) 4276 (descriptor-reg 4277 (ecase offset 4278 (0 (ea-for-cdf-real-desc x)) 4279 (1 (ea-for-cdf-imag-desc x))))))) 4280 (with-empty-tn@fp-top(r) 4281 (inst fldd ea)))) 4282 #!+long-float 4283 ((sc-is r long-reg) 4284 (let ((ea (sc-case x 4285 (complex-long-stack 4286 (ecase offset 4287 (0 (ea-for-clf-real-stack x)) 4288 (1 (ea-for-clf-imag-stack x)))) 4289 (descriptor-reg 4290 (ecase offset 4291 (0 (ea-for-clf-real-desc x)) 4292 (1 (ea-for-clf-imag-desc x))))))) 4293 (with-empty-tn@fp-top(r) 4294 (inst fldl ea)))) 4295 (t (error "COMPLEX-FLOAT-VALUE VOP failure"))))) 4296 4297(define-vop (realpart/complex-single-float complex-float-value) 4298 (:translate realpart) 4299 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) 4300 :target r)) 4301 (:arg-types complex-single-float) 4302 (:results (r :scs (single-reg))) 4303 (:result-types single-float) 4304 (:note "complex float realpart") 4305 (:variant 0)) 4306 4307(define-vop (realpart/complex-double-float complex-float-value) 4308 (:translate realpart) 4309 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg) 4310 :target r)) 4311 (:arg-types complex-double-float) 4312 (:results (r :scs (double-reg))) 4313 (:result-types double-float) 4314 (:note "complex float realpart") 4315 (:variant 0)) 4316 4317#!+long-float 4318(define-vop (realpart/complex-long-float complex-float-value) 4319 (:translate realpart) 4320 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) 4321 :target r)) 4322 (:arg-types complex-long-float) 4323 (:results (r :scs (long-reg))) 4324 (:result-types long-float) 4325 (:note "complex float realpart") 4326 (:variant 0)) 4327 4328(define-vop (imagpart/complex-single-float complex-float-value) 4329 (:translate imagpart) 4330 (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg) 4331 :target r)) 4332 (:arg-types complex-single-float) 4333 (:results (r :scs (single-reg))) 4334 (:result-types single-float) 4335 (:note "complex float imagpart") 4336 (:variant 1)) 4337 4338(define-vop (imagpart/complex-double-float complex-float-value) 4339 (:translate imagpart) 4340 (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg) 4341 :target r)) 4342 (:arg-types complex-double-float) 4343 (:results (r :scs (double-reg))) 4344 (:result-types double-float) 4345 (:note "complex float imagpart") 4346 (:variant 1)) 4347 4348#!+long-float 4349(define-vop (imagpart/complex-long-float complex-float-value) 4350 (:translate imagpart) 4351 (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg) 4352 :target r)) 4353 (:arg-types complex-long-float) 4354 (:results (r :scs (long-reg))) 4355 (:result-types long-float) 4356 (:note "complex float imagpart") 4357 (:variant 1)) 4358 4359;;; hack dummy VOPs to bias the representation selection of their 4360;;; arguments towards a FP register, which can help avoid consing at 4361;;; inappropriate locations 4362(defknown double-float-reg-bias (double-float) (values)) 4363(define-vop (double-float-reg-bias) 4364 (:translate double-float-reg-bias) 4365 (:args (x :scs (double-reg double-stack) :load-if nil)) 4366 (:arg-types double-float) 4367 (:policy :fast-safe) 4368 (:note "inline dummy FP register bias") 4369 (:ignore x) 4370 (:generator 0)) 4371(defknown single-float-reg-bias (single-float) (values)) 4372(define-vop (single-float-reg-bias) 4373 (:translate single-float-reg-bias) 4374 (:args (x :scs (single-reg single-stack) :load-if nil)) 4375 (:arg-types single-float) 4376 (:policy :fast-safe) 4377 (:note "inline dummy FP register bias") 4378 (:ignore x) 4379 (:generator 0)) 4380