src/compiler/sparc/float.lisp

   1 ;;;; floating point support for the Sparc
   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 \f
  14 ;;;; float move functions
  15
  16 (define-move-fun (load-single 1) (vop x y)
  17   ((single-stack) (single-reg))
  18   (inst ldf y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes)))
  19
  20 (define-move-fun (store-single 1) (vop x y)
  21   ((single-reg) (single-stack))
  22   (inst stf x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))
  23
  24
  25 (define-move-fun (load-double 2) (vop x y)
  26   ((double-stack) (double-reg))
  27   (let ((nfp (current-nfp-tn vop))
  28         (offset (* (tn-offset x) n-word-bytes)))
  29     (inst lddf y nfp offset)))
  30
  31 (define-move-fun (store-double 2) (vop x y)
  32   ((double-reg) (double-stack))
  33   (let ((nfp (current-nfp-tn vop))
  34         (offset (* (tn-offset y) n-word-bytes)))
  35     (inst stdf x nfp offset)))
  36
  37 ;;; The offset may be an integer or a TN in which case it will be
  38 ;;; temporarily modified but is restored if restore-offset is true.
  39 (defun load-long-reg (reg base offset &optional (restore-offset t))
  40   #!+:sparc-v9
  41   (inst ldqf reg base offset)
  42   #!-:sparc-v9
  43   (let ((reg0 (make-random-tn :kind :normal
  44                               :sc (sc-or-lose 'double-reg)
  45                               :offset (tn-offset reg)))
  46         (reg2 (make-random-tn :kind :normal
  47                               :sc (sc-or-lose 'double-reg)
  48                               :offset (+ 2 (tn-offset reg)))))
  49     (cond ((integerp offset)
  50            (inst lddf reg0 base offset)
  51            (inst lddf reg2 base (+ offset (* 2 n-word-bytes))))
  52           (t
  53            (inst lddf reg0 base offset)
  54            (inst add offset (* 2 n-word-bytes))
  55            (inst lddf reg2 base offset)
  56            (when restore-offset
  57              (inst sub offset (* 2 n-word-bytes)))))))
  58
  59 #!+long-float
  60 (define-move-fun (load-long 2) (vop x y)
  61   ((long-stack) (long-reg))
  62   (let ((nfp (current-nfp-tn vop))
  63         (offset (* (tn-offset x) n-word-bytes)))
  64     (load-long-reg y nfp offset)))
  65
  66 ;;; The offset may be an integer or a TN in which case it will be
  67 ;;; temporarily modified but is restored if restore-offset is true.
  68 (defun store-long-reg (reg base offset &optional (restore-offset t))
  69   #!+:sparc-v9
  70   (inst stqf reg base offset)
  71   #!-:sparc-v9
  72   (let ((reg0 (make-random-tn :kind :normal
  73                               :sc (sc-or-lose 'double-reg)
  74                               :offset (tn-offset reg)))
  75         (reg2 (make-random-tn :kind :normal
  76                               :sc (sc-or-lose 'double-reg)
  77                               :offset (+ 2 (tn-offset reg)))))
  78     (cond ((integerp offset)
  79            (inst stdf reg0 base offset)
  80            (inst stdf reg2 base (+ offset (* 2 n-word-bytes))))
  81           (t
  82            (inst stdf reg0 base offset)
  83            (inst add offset (* 2 n-word-bytes))
  84            (inst stdf reg2 base offset)
  85            (when restore-offset
  86              (inst sub offset (* 2 n-word-bytes)))))))
  87
  88 #!+long-float
  89 (define-move-fun (store-long 2) (vop x y)
  90   ((long-reg) (long-stack))
  91   (let ((nfp (current-nfp-tn vop))
  92         (offset (* (tn-offset y) n-word-bytes)))
  93     (store-long-reg x nfp offset)))
  94
  95 \f
  96 ;;;; Move VOPs:
  97
  98 ;;; Exploit the V9 double-float move instruction. This is conditional
  99 ;;; on the :sparc-v9 feature.
 100 (defun move-double-reg (dst src)
 101   #!+:sparc-v9
 102   (inst fmovd dst src)
 103   #!-:sparc-v9
 104   (dotimes (i 2)
 105     (let ((dst (make-random-tn :kind :normal
 106                                :sc (sc-or-lose 'single-reg)
 107                                :offset (+ i (tn-offset dst))))
 108           (src (make-random-tn :kind :normal
 109                                :sc (sc-or-lose 'single-reg)
 110                                :offset (+ i (tn-offset src)))))
 111       (inst fmovs dst src))))
 112
 113 ;;; Exploit the V9 long-float move instruction. This is conditional
 114 ;;; on the :sparc-v9 feature.
 115 (defun move-long-reg (dst src)
 116   #!+:sparc-v9
 117   (inst fmovq dst src)
 118   #!-:sparc-v9
 119   (dotimes (i 4)
 120     (let ((dst (make-random-tn :kind :normal
 121                                :sc (sc-or-lose 'single-reg)
 122                                :offset (+ i (tn-offset dst))))
 123           (src (make-random-tn :kind :normal
 124                                :sc (sc-or-lose 'single-reg)
 125                                :offset (+ i (tn-offset src)))))
 126       (inst fmovs dst src))))
 127
 128 (macrolet ((frob (vop sc format)
 129              `(progn
 130                 (define-vop (,vop)
 131                   (:args (x :scs (,sc)
 132                             :target y
 133                             :load-if (not (location= x y))))
 134                   (:results (y :scs (,sc)
 135                                :load-if (not (location= x y))))
 136                   (:note "float move")
 137                   (:generator 0
 138                     (unless (location= y x)
 139                       ,@(ecase format
 140                           (:single `((inst fmovs y x)))
 141                           (:double `((move-double-reg y x)))
 142                           (:long `((move-long-reg y x)))))))
 143                 (define-move-vop ,vop :move (,sc) (,sc)))))
 144   (frob single-move single-reg :single)
 145   (frob double-move double-reg :double)
 146   #!+long-float
 147   (frob long-move long-reg :long))
 148
 149
 150 (define-vop (move-from-float)
 151   (:args (x :to :save))
 152   (:results (y))
 153   (:note "float to pointer coercion")
 154   (:temporary (:scs (non-descriptor-reg)) ndescr)
 155   (:variant-vars format size type data)
 156   (:generator 13
 157     (with-fixed-allocation (y ndescr type size))
 158     (ecase format
 159       (:single
 160        (inst stf x y (- (* data n-word-bytes) other-pointer-lowtag)))
 161       (:double
 162        (inst stdf x y (- (* data n-word-bytes) other-pointer-lowtag)))
 163       (:long
 164        (store-long-reg x y (- (* data n-word-bytes)
 165                               other-pointer-lowtag))))))
 166
 167 (macrolet ((frob (name sc &rest args)
 168              `(progn
 169                 (define-vop (,name move-from-float)
 170                   (:args (x :scs (,sc) :to :save))
 171                   (:results (y :scs (descriptor-reg)))
 172                   (:variant ,@args))
 173                 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
 174   (frob move-from-single single-reg :single
 175     single-float-size single-float-widetag single-float-value-slot)
 176   (frob move-from-double double-reg :double
 177     double-float-size double-float-widetag double-float-value-slot)
 178   #!+long-float
 179   (frob move-from-long long-reg :long
 180      long-float-size long-float-widetag long-float-value-slot))
 181
 182 (macrolet ((frob (name sc format value)
 183              `(progn
 184                 (define-vop (,name)
 185                   (:args (x :scs (descriptor-reg)))
 186                   (:results (y :scs (,sc)))
 187                   (:note "pointer to float coercion")
 188                   (:generator 2
 189                     (inst ,(ecase format
 190                              (:single 'ldf)
 191                              (:double 'lddf))
 192                           y x
 193                           (- (* ,value n-word-bytes) other-pointer-lowtag))))
 194                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
 195   (frob move-to-single single-reg :single single-float-value-slot)
 196   (frob move-to-double double-reg :double double-float-value-slot))
 197
 198 #!+long-float
 199 (define-vop (move-to-long)
 200   (:args (x :scs (descriptor-reg)))
 201   (:results (y :scs (long-reg)))
 202   (:note "pointer to float coercion")
 203   (:generator 2
 204     (load-long-reg y x (- (* long-float-value-slot n-word-bytes)
 205                           other-pointer-lowtag))))
 206 #!+long-float
 207 (define-move-vop move-to-long :move (descriptor-reg) (long-reg))
 208
 209 (macrolet ((frob (name sc stack-sc format)
 210              `(progn
 211                 (define-vop (,name)
 212                   (:args (x :scs (,sc) :target y)
 213                          (nfp :scs (any-reg)
 214                               :load-if (not (sc-is y ,sc))))
 215                   (:results (y))
 216                   (:note "float argument move")
 217                   (:generator ,(ecase format (:single 1) (:double 2))
 218                     (sc-case y
 219                       (,sc
 220                        (unless (location= x y)
 221                          ,@(ecase format
 222                              (:single '((inst fmovs y x)))
 223                              (:double '((move-double-reg y x))))))
 224                       (,stack-sc
 225                        (let ((offset (* (tn-offset y) n-word-bytes)))
 226                          (inst ,(ecase format
 227                                   (:single 'stf)
 228                                   (:double 'stdf))
 229                                x nfp offset))))))
 230                 (define-move-vop ,name :move-arg
 231                   (,sc descriptor-reg) (,sc)))))
 232   (frob move-single-float-arg single-reg single-stack :single)
 233   (frob move-double-float-arg double-reg double-stack :double))
 234
 235 #!+long-float
 236 (define-vop (move-long-float-arg)
 237   (:args (x :scs (long-reg) :target y)
 238          (nfp :scs (any-reg) :load-if (not (sc-is y long-reg))))
 239   (:results (y))
 240   (:note "float argument move")
 241   (:generator 3
 242     (sc-case y
 243       (long-reg
 244        (unless (location= x y)
 245          (move-long-reg y x)))
 246       (long-stack
 247        (let ((offset (* (tn-offset y) n-word-bytes)))
 248          (store-long-reg x nfp offset))))))
 249 ;;;
 250 #!+long-float
 251 (define-move-vop move-long-float-arg :move-arg
 252   (long-reg descriptor-reg) (long-reg))
 253
 254 \f
 255 ;;;; Complex float move functions
 256
 257 (defun complex-single-reg-real-tn (x)
 258   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 259                   :offset (tn-offset x)))
 260 (defun complex-single-reg-imag-tn (x)
 261   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 262                   :offset (1+ (tn-offset x))))
 263
 264 (defun complex-double-reg-real-tn (x)
 265   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 266                   :offset (tn-offset x)))
 267 (defun complex-double-reg-imag-tn (x)
 268   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 269                   :offset (+ (tn-offset x) 2)))
 270
 271 #!+long-float
 272 (defun complex-long-reg-real-tn (x)
 273   (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
 274                   :offset (tn-offset x)))
 275 #!+long-float
 276 (defun complex-long-reg-imag-tn (x)
 277   (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
 278                   :offset (+ (tn-offset x) 4)))
 279
 280
 281 (define-move-fun (load-complex-single 2) (vop x y)
 282   ((complex-single-stack) (complex-single-reg))
 283   (let ((nfp (current-nfp-tn vop))
 284         (offset (* (tn-offset x) n-word-bytes)))
 285     (let ((real-tn (complex-single-reg-real-tn y)))
 286       (inst ldf real-tn nfp offset))
 287     (let ((imag-tn (complex-single-reg-imag-tn y)))
 288       (inst ldf imag-tn nfp (+ offset n-word-bytes)))))
 289
 290 (define-move-fun (store-complex-single 2) (vop x y)
 291   ((complex-single-reg) (complex-single-stack))
 292   (let ((nfp (current-nfp-tn vop))
 293         (offset (* (tn-offset y) n-word-bytes)))
 294     (let ((real-tn (complex-single-reg-real-tn x)))
 295       (inst stf real-tn nfp offset))
 296     (let ((imag-tn (complex-single-reg-imag-tn x)))
 297       (inst stf imag-tn nfp (+ offset n-word-bytes)))))
 298
 299
 300 (define-move-fun (load-complex-double 4) (vop x y)
 301   ((complex-double-stack) (complex-double-reg))
 302   (let ((nfp (current-nfp-tn vop))
 303         (offset (* (tn-offset x) n-word-bytes)))
 304     (let ((real-tn (complex-double-reg-real-tn y)))
 305       (inst lddf real-tn nfp offset))
 306     (let ((imag-tn (complex-double-reg-imag-tn y)))
 307       (inst lddf imag-tn nfp (+ offset (* 2 n-word-bytes))))))
 308
 309 (define-move-fun (store-complex-double 4) (vop x y)
 310   ((complex-double-reg) (complex-double-stack))
 311   (let ((nfp (current-nfp-tn vop))
 312         (offset (* (tn-offset y) n-word-bytes)))
 313     (let ((real-tn (complex-double-reg-real-tn x)))
 314       (inst stdf real-tn nfp offset))
 315     (let ((imag-tn (complex-double-reg-imag-tn x)))
 316       (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes))))))
 317
 318
 319 #!+long-float
 320 (define-move-fun (load-complex-long 5) (vop x y)
 321   ((complex-long-stack) (complex-long-reg))
 322   (let ((nfp (current-nfp-tn vop))
 323         (offset (* (tn-offset x) n-word-bytes)))
 324     (let ((real-tn (complex-long-reg-real-tn y)))
 325       (load-long-reg real-tn nfp offset))
 326     (let ((imag-tn (complex-long-reg-imag-tn y)))
 327       (load-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes))))))
 328
 329 #!+long-float
 330 (define-move-fun (store-complex-long 5) (vop x y)
 331   ((complex-long-reg) (complex-long-stack))
 332   (let ((nfp (current-nfp-tn vop))
 333         (offset (* (tn-offset y) n-word-bytes)))
 334     (let ((real-tn (complex-long-reg-real-tn x)))
 335       (store-long-reg real-tn nfp offset))
 336     (let ((imag-tn (complex-long-reg-imag-tn x)))
 337       (store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes))))))
 338
 339 ;;;
 340 ;;; Complex float register to register moves.
 341 ;;;
 342 (define-vop (complex-single-move)
 343   (:args (x :scs (complex-single-reg) :target y
 344             :load-if (not (location= x y))))
 345   (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
 346   (:note "complex single float move")
 347   (:generator 0
 348      (unless (location= x y)
 349        ;; Note the complex-float-regs are aligned to every second
 350        ;; float register so there is not need to worry about overlap.
 351        (let ((x-real (complex-single-reg-real-tn x))
 352              (y-real (complex-single-reg-real-tn y)))
 353          (inst fmovs y-real x-real))
 354        (let ((x-imag (complex-single-reg-imag-tn x))
 355              (y-imag (complex-single-reg-imag-tn y)))
 356          (inst fmovs y-imag x-imag)))))
 357 ;;;
 358 (define-move-vop complex-single-move :move
 359   (complex-single-reg) (complex-single-reg))
 360
 361 (define-vop (complex-double-move)
 362   (:args (x :scs (complex-double-reg)
 363             :target y :load-if (not (location= x y))))
 364   (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
 365   (:note "complex double float move")
 366   (:generator 0
 367      (unless (location= x y)
 368        ;; Note the complex-float-regs are aligned to every second
 369        ;; float register so there is not need to worry about overlap.
 370        (let ((x-real (complex-double-reg-real-tn x))
 371              (y-real (complex-double-reg-real-tn y)))
 372          (move-double-reg y-real x-real))
 373        (let ((x-imag (complex-double-reg-imag-tn x))
 374              (y-imag (complex-double-reg-imag-tn y)))
 375          (move-double-reg y-imag x-imag)))))
 376 ;;;
 377 (define-move-vop complex-double-move :move
 378   (complex-double-reg) (complex-double-reg))
 379
 380 #!+long-float
 381 (define-vop (complex-long-move)
 382   (:args (x :scs (complex-long-reg)
 383             :target y :load-if (not (location= x y))))
 384   (:results (y :scs (complex-long-reg) :load-if (not (location= x y))))
 385   (:note "complex long float move")
 386   (:generator 0
 387      (unless (location= x y)
 388        ;; Note the complex-float-regs are aligned to every second
 389        ;; float register so there is not need to worry about overlap.
 390        (let ((x-real (complex-long-reg-real-tn x))
 391              (y-real (complex-long-reg-real-tn y)))
 392          (move-long-reg y-real x-real))
 393        (let ((x-imag (complex-long-reg-imag-tn x))
 394              (y-imag (complex-long-reg-imag-tn y)))
 395          (move-long-reg y-imag x-imag)))))
 396 ;;;
 397 #!+long-float
 398 (define-move-vop complex-long-move :move
 399   (complex-long-reg) (complex-long-reg))
 400
 401 ;;;
 402 ;;; Move from a complex float to a descriptor register allocating a
 403 ;;; new complex float object in the process.
 404 ;;;
 405 (define-vop (move-from-complex-single)
 406   (:args (x :scs (complex-single-reg) :to :save))
 407   (:results (y :scs (descriptor-reg)))
 408   (:temporary (:scs (non-descriptor-reg)) ndescr)
 409   (:note "complex single float to pointer coercion")
 410   (:generator 13
 411      (with-fixed-allocation (y ndescr complex-single-float-widetag
 412                                complex-single-float-size))
 413      (let ((real-tn (complex-single-reg-real-tn x)))
 414        (inst stf real-tn y (- (* complex-single-float-real-slot
 415                                  n-word-bytes)
 416                               other-pointer-lowtag)))
 417      (let ((imag-tn (complex-single-reg-imag-tn x)))
 418        (inst stf imag-tn y (- (* complex-single-float-imag-slot
 419                                  n-word-bytes)
 420                               other-pointer-lowtag)))))
 421 ;;;
 422 (define-move-vop move-from-complex-single :move
 423   (complex-single-reg) (descriptor-reg))
 424
 425 (define-vop (move-from-complex-double)
 426   (:args (x :scs (complex-double-reg) :to :save))
 427   (:results (y :scs (descriptor-reg)))
 428   (:temporary (:scs (non-descriptor-reg)) ndescr)
 429   (:note "complex double float to pointer coercion")
 430   (:generator 13
 431      (with-fixed-allocation (y ndescr complex-double-float-widetag
 432                                complex-double-float-size))
 433      (let ((real-tn (complex-double-reg-real-tn x)))
 434        (inst stdf real-tn y (- (* complex-double-float-real-slot
 435                                   n-word-bytes)
 436                                other-pointer-lowtag)))
 437      (let ((imag-tn (complex-double-reg-imag-tn x)))
 438        (inst stdf imag-tn y (- (* complex-double-float-imag-slot
 439                                   n-word-bytes)
 440                                other-pointer-lowtag)))))
 441 ;;;
 442 (define-move-vop move-from-complex-double :move
 443   (complex-double-reg) (descriptor-reg))
 444
 445 #!+long-float
 446 (define-vop (move-from-complex-long)
 447   (:args (x :scs (complex-long-reg) :to :save))
 448   (:results (y :scs (descriptor-reg)))
 449   (:temporary (:scs (non-descriptor-reg)) ndescr)
 450   (:note "complex long float to pointer coercion")
 451   (:generator 13
 452      (with-fixed-allocation (y ndescr complex-long-float-widetag
 453                                complex-long-float-size))
 454      (let ((real-tn (complex-long-reg-real-tn x)))
 455        (store-long-reg real-tn y (- (* complex-long-float-real-slot
 456                                        n-word-bytes)
 457                                     other-pointer-lowtag)))
 458      (let ((imag-tn (complex-long-reg-imag-tn x)))
 459        (store-long-reg imag-tn y (- (* complex-long-float-imag-slot
 460                                        n-word-bytes)
 461                                     other-pointer-lowtag)))))
 462 ;;;
 463 #!+long-float
 464 (define-move-vop move-from-complex-long :move
 465   (complex-long-reg) (descriptor-reg))
 466
 467 ;;;
 468 ;;; Move from a descriptor to a complex float register
 469 ;;;
 470 (define-vop (move-to-complex-single)
 471   (:args (x :scs (descriptor-reg)))
 472   (:results (y :scs (complex-single-reg)))
 473   (:note "pointer to complex float coercion")
 474   (:generator 2
 475     (let ((real-tn (complex-single-reg-real-tn y)))
 476       (inst ldf real-tn x (- (* complex-single-float-real-slot n-word-bytes)
 477                              other-pointer-lowtag)))
 478     (let ((imag-tn (complex-single-reg-imag-tn y)))
 479       (inst ldf imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
 480                              other-pointer-lowtag)))))
 481 (define-move-vop move-to-complex-single :move
 482   (descriptor-reg) (complex-single-reg))
 483
 484 (define-vop (move-to-complex-double)
 485   (:args (x :scs (descriptor-reg)))
 486   (:results (y :scs (complex-double-reg)))
 487   (:note "pointer to complex float coercion")
 488   (:generator 2
 489     (let ((real-tn (complex-double-reg-real-tn y)))
 490       (inst lddf real-tn x (- (* complex-double-float-real-slot n-word-bytes)
 491                               other-pointer-lowtag)))
 492     (let ((imag-tn (complex-double-reg-imag-tn y)))
 493       (inst lddf imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
 494                               other-pointer-lowtag)))))
 495 (define-move-vop move-to-complex-double :move
 496   (descriptor-reg) (complex-double-reg))
 497
 498 #!+long-float
 499 (define-vop (move-to-complex-long)
 500   (:args (x :scs (descriptor-reg)))
 501   (:results (y :scs (complex-long-reg)))
 502   (:note "pointer to complex float coercion")
 503   (:generator 2
 504     (let ((real-tn (complex-long-reg-real-tn y)))
 505       (load-long-reg real-tn x (- (* complex-long-float-real-slot n-word-bytes)
 506                                   other-pointer-lowtag)))
 507     (let ((imag-tn (complex-long-reg-imag-tn y)))
 508       (load-long-reg imag-tn x (- (* complex-long-float-imag-slot n-word-bytes)
 509                                   other-pointer-lowtag)))))
 510 #!+long-float
 511 (define-move-vop move-to-complex-long :move
 512   (descriptor-reg) (complex-long-reg))
 513
 514 ;;;
 515 ;;; Complex float move-arg vop
 516 ;;;
 517 (define-vop (move-complex-single-float-arg)
 518   (:args (x :scs (complex-single-reg) :target y)
 519          (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
 520   (:results (y))
 521   (:note "complex single-float argument move")
 522   (:generator 1
 523     (sc-case y
 524       (complex-single-reg
 525        (unless (location= x y)
 526          (let ((x-real (complex-single-reg-real-tn x))
 527                (y-real (complex-single-reg-real-tn y)))
 528            (inst fmovs y-real x-real))
 529          (let ((x-imag (complex-single-reg-imag-tn x))
 530                (y-imag (complex-single-reg-imag-tn y)))
 531            (inst fmovs y-imag x-imag))))
 532       (complex-single-stack
 533        (let ((offset (* (tn-offset y) n-word-bytes)))
 534          (let ((real-tn (complex-single-reg-real-tn x)))
 535            (inst stf real-tn nfp offset))
 536          (let ((imag-tn (complex-single-reg-imag-tn x)))
 537            (inst stf imag-tn nfp (+ offset n-word-bytes))))))))
 538 (define-move-vop move-complex-single-float-arg :move-arg
 539   (complex-single-reg descriptor-reg) (complex-single-reg))
 540
 541 (define-vop (move-complex-double-float-arg)
 542   (:args (x :scs (complex-double-reg) :target y)
 543          (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
 544   (:results (y))
 545   (:note "complex double-float argument move")
 546   (:generator 2
 547     (sc-case y
 548       (complex-double-reg
 549        (unless (location= x y)
 550          (let ((x-real (complex-double-reg-real-tn x))
 551                (y-real (complex-double-reg-real-tn y)))
 552            (move-double-reg y-real x-real))
 553          (let ((x-imag (complex-double-reg-imag-tn x))
 554                (y-imag (complex-double-reg-imag-tn y)))
 555            (move-double-reg y-imag x-imag))))
 556       (complex-double-stack
 557        (let ((offset (* (tn-offset y) n-word-bytes)))
 558          (let ((real-tn (complex-double-reg-real-tn x)))
 559            (inst stdf real-tn nfp offset))
 560          (let ((imag-tn (complex-double-reg-imag-tn x)))
 561            (inst stdf imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
 562 (define-move-vop move-complex-double-float-arg :move-arg
 563   (complex-double-reg descriptor-reg) (complex-double-reg))
 564
 565 #!+long-float
 566 (define-vop (move-complex-long-float-arg)
 567   (:args (x :scs (complex-long-reg) :target y)
 568          (nfp :scs (any-reg) :load-if (not (sc-is y complex-long-reg))))
 569   (:results (y))
 570   (:note "complex long-float argument move")
 571   (:generator 2
 572     (sc-case y
 573       (complex-long-reg
 574        (unless (location= x y)
 575          (let ((x-real (complex-long-reg-real-tn x))
 576                (y-real (complex-long-reg-real-tn y)))
 577            (move-long-reg y-real x-real))
 578          (let ((x-imag (complex-long-reg-imag-tn x))
 579                (y-imag (complex-long-reg-imag-tn y)))
 580            (move-long-reg y-imag x-imag))))
 581       (complex-long-stack
 582        (let ((offset (* (tn-offset y) n-word-bytes)))
 583          (let ((real-tn (complex-long-reg-real-tn x)))
 584            (store-long-reg real-tn nfp offset))
 585          (let ((imag-tn (complex-long-reg-imag-tn x)))
 586            (store-long-reg imag-tn nfp (+ offset (* 4 n-word-bytes)))))))))
 587 #!+long-float
 588 (define-move-vop move-complex-long-float-arg :move-arg
 589   (complex-long-reg descriptor-reg) (complex-long-reg))
 590
 591
 592 (define-move-vop move-arg :move-arg
 593   (single-reg double-reg #!+long-float long-reg
 594    complex-single-reg complex-double-reg #!+long-float complex-long-reg)
 595   (descriptor-reg))
 596
 597 \f
 598 ;;;; Arithmetic VOPs:
 599
 600 (define-vop (float-op)
 601   (:args (x) (y))
 602   (:results (r))
 603   (:policy :fast-safe)
 604   (:note "inline float arithmetic")
 605   (:vop-var vop)
 606   (:save-p :compute-only))
 607
 608 (macrolet ((frob (name sc ptype)
 609              `(define-vop (,name float-op)
 610                 (:args (x :scs (,sc))
 611                        (y :scs (,sc)))
 612                 (:results (r :scs (,sc)))
 613                 (:arg-types ,ptype ,ptype)
 614                 (:result-types ,ptype))))
 615   (frob single-float-op single-reg single-float)
 616   (frob double-float-op double-reg double-float)
 617   #!+long-float
 618   (frob long-float-op long-reg long-float))
 619
 620 (macrolet ((frob (op sinst sname scost dinst dname dcost)
 621              `(progn
 622                 (define-vop (,sname single-float-op)
 623                   (:translate ,op)
 624                   (:generator ,scost
 625                     (inst ,sinst r x y)))
 626                 (define-vop (,dname double-float-op)
 627                   (:translate ,op)
 628                   (:generator ,dcost
 629                     (inst ,dinst r x y))))))
 630   (frob + fadds +/single-float 2 faddd +/double-float 2)
 631   (frob - fsubs -/single-float 2 fsubd -/double-float 2)
 632   (frob * fmuls */single-float 4 fmuld */double-float 5)
 633   (frob / fdivs //single-float 12 fdivd //double-float 19))
 634
 635 #!+long-float
 636 (macrolet ((frob (op linst lname lcost)
 637              `(define-vop (,lname long-float-op)
 638                   (:translate ,op)
 639                   (:generator ,lcost
 640                     (inst ,linst r x y)))))
 641   (frob + faddq +/long-float 2)
 642   (frob - fsubq -/long-float 2)
 643   (frob * fmulq */long-float 6)
 644   (frob / fdivq //long-float 20))
 645
 646 \f
 647 (macrolet ((frob (name inst translate sc type)
 648              `(define-vop (,name)
 649                 (:args (x :scs (,sc)))
 650                 (:results (y :scs (,sc)))
 651                 (:translate ,translate)
 652                 (:policy :fast-safe)
 653                 (:arg-types ,type)
 654                 (:result-types ,type)
 655                 (:note "inline float arithmetic")
 656                 (:vop-var vop)
 657                 (:save-p :compute-only)
 658                 (:generator 1
 659                   (note-this-location vop :internal-error)
 660                   (inst ,inst y x)))))
 661   (frob abs/single-float fabss abs single-reg single-float)
 662   (frob %negate/single-float fnegs %negate single-reg single-float))
 663
 664 (defun negate-double-reg (dst src)
 665   #!+:sparc-v9
 666   (inst fnegd dst src)
 667   #!-:sparc-v9
 668   ;; Negate the MS part of the numbers, then copy over the rest
 669   ;; of the bits.
 670   (inst fnegs dst src)
 671   (let ((dst-odd (make-random-tn :kind :normal
 672                                  :sc (sc-or-lose 'single-reg)
 673                                  :offset (+ 1 (tn-offset dst))))
 674         (src-odd (make-random-tn :kind :normal
 675                                  :sc (sc-or-lose 'single-reg)
 676                                  :offset (+ 1 (tn-offset src)))))
 677     (inst fmovs dst-odd src-odd)))
 678
 679 (defun abs-double-reg (dst src)
 680   #!+:sparc-v9
 681   (inst fabsd dst src)
 682   #!-:sparc-v9
 683   ;; Abs the MS part of the numbers, then copy over the rest
 684   ;; of the bits.
 685   (inst fabss dst src)
 686   (let ((dst-2 (make-random-tn :kind :normal
 687                                :sc (sc-or-lose 'single-reg)
 688                                :offset (+ 1 (tn-offset dst))))
 689         (src-2 (make-random-tn :kind :normal
 690                                :sc (sc-or-lose 'single-reg)
 691                                :offset (+ 1 (tn-offset src)))))
 692     (inst fmovs dst-2 src-2)))
 693
 694 (define-vop (abs/double-float)
 695   (:args (x :scs (double-reg)))
 696   (:results (y :scs (double-reg)))
 697   (:translate abs)
 698   (:policy :fast-safe)
 699   (:arg-types double-float)
 700   (:result-types double-float)
 701   (:note "inline float arithmetic")
 702   (:vop-var vop)
 703   (:save-p :compute-only)
 704   (:generator 1
 705     (note-this-location vop :internal-error)
 706     (abs-double-reg y x)))
 707
 708 (define-vop (%negate/double-float)
 709   (:args (x :scs (double-reg)))
 710   (:results (y :scs (double-reg)))
 711   (:translate %negate)
 712   (:policy :fast-safe)
 713   (:arg-types double-float)
 714   (:result-types double-float)
 715   (:note "inline float arithmetic")
 716   (:vop-var vop)
 717   (:save-p :compute-only)
 718   (:generator 1
 719     (note-this-location vop :internal-error)
 720     (negate-double-reg y x)))
 721
 722 #!+long-float
 723 (define-vop (abs/long-float)
 724   (:args (x :scs (long-reg)))
 725   (:results (y :scs (long-reg)))
 726   (:translate abs)
 727   (:policy :fast-safe)
 728   (:arg-types long-float)
 729   (:result-types long-float)
 730   (:note "inline float arithmetic")
 731   (:vop-var vop)
 732   (:save-p :compute-only)
 733   (:generator 1
 734     (note-this-location vop :internal-error)
 735     #!+:sparc-v9
 736     (inst fabsq y x)
 737     #!-:sparc-v9
 738     (inst fabss y x)
 739     (dotimes (i 3)
 740       (let ((y-odd (make-random-tn
 741                     :kind :normal
 742                     :sc (sc-or-lose 'single-reg)
 743                     :offset (+ i 1 (tn-offset y))))
 744             (x-odd (make-random-tn
 745                     :kind :normal
 746                     :sc (sc-or-lose 'single-reg)
 747                     :offset (+ i 1 (tn-offset x)))))
 748         (inst fmovs y-odd x-odd)))))
 749
 750 #!+long-float
 751 (define-vop (%negate/long-float)
 752   (:args (x :scs (long-reg)))
 753   (:results (y :scs (long-reg)))
 754   (:translate %negate)
 755   (:policy :fast-safe)
 756   (:arg-types long-float)
 757   (:result-types long-float)
 758   (:note "inline float arithmetic")
 759   (:vop-var vop)
 760   (:save-p :compute-only)
 761   (:generator 1
 762     (note-this-location vop :internal-error)
 763     #!+:sparc-v9
 764     (inst fnegq y x)
 765     #!-:sparc-v9
 766     (inst fnegs y x)
 767     (dotimes (i 3)
 768       (let ((y-odd (make-random-tn
 769                     :kind :normal
 770                     :sc (sc-or-lose 'single-reg)
 771                     :offset (+ i 1 (tn-offset y))))
 772             (x-odd (make-random-tn
 773                     :kind :normal
 774                     :sc (sc-or-lose 'single-reg)
 775                     :offset (+ i 1 (tn-offset x)))))
 776         (inst fmovs y-odd x-odd)))))
 777
 778 \f
 779 ;;;; Comparison:
 780
 781 (define-vop (float-compare)
 782   (:args (x) (y))
 783   (:conditional)
 784   (:info target not-p)
 785   (:variant-vars format yep nope)
 786   (:policy :fast-safe)
 787   (:note "inline float comparison")
 788   (:vop-var vop)
 789   (:save-p :compute-only)
 790   (:generator 3
 791     (note-this-location vop :internal-error)
 792     (ecase format
 793       (:single (inst fcmps x y))
 794       (:double (inst fcmpd x y))
 795       (:long (inst fcmpq x y)))
 796     ;; The SPARC V9 doesn't need an instruction between a
 797     ;; floating-point compare and a floating-point branch.
 798     #!-:sparc-v9 (inst nop)
 799     (inst fb (if not-p nope yep) target)
 800     (inst nop)))
 801
 802 (macrolet ((frob (name sc ptype)
 803              `(define-vop (,name float-compare)
 804                 (:args (x :scs (,sc))
 805                        (y :scs (,sc)))
 806                 (:arg-types ,ptype ,ptype))))
 807   (frob single-float-compare single-reg single-float)
 808   (frob double-float-compare double-reg double-float)
 809   #!+long-float
 810   (frob long-float-compare long-reg long-float))
 811
 812 (macrolet ((frob (translate yep nope sname dname #!+long-float lname)
 813              `(progn
 814                 (define-vop (,sname single-float-compare)
 815                   (:translate ,translate)
 816                   (:variant :single ,yep ,nope))
 817                 (define-vop (,dname double-float-compare)
 818                   (:translate ,translate)
 819                   (:variant :double ,yep ,nope))
 820                 #!+long-float
 821                 (define-vop (,lname long-float-compare)
 822                   (:translate ,translate)
 823                   (:variant :long ,yep ,nope)))))
 824   (frob < :l :ge </single-float </double-float #!+long-float </long-float)
 825   (frob > :g :le >/single-float >/double-float #!+long-float >/long-float)
 826   (frob = :eq :ne eql/single-float eql/double-float #!+long-float eql/long-float))
 827
 828 #!+long-float
 829 (deftransform eql ((x y) (long-float long-float))
 830   '(and (= (long-float-low-bits x) (long-float-low-bits y))
 831         (= (long-float-mid-bits x) (long-float-mid-bits y))
 832         (= (long-float-high-bits x) (long-float-high-bits y))
 833         (= (long-float-exp-bits x) (long-float-exp-bits y))))
 834
 835 \f
 836 ;;;; Conversion:
 837
 838 (macrolet ((frob (name translate inst to-sc to-type)
 839              `(define-vop (,name)
 840                 (:args (x :scs (signed-reg) :target stack-temp
 841                           :load-if (not (sc-is x signed-stack))))
 842                 (:temporary (:scs (single-stack) :from :argument) stack-temp)
 843                 (:temporary (:scs (single-reg) :to :result :target y) temp)
 844                 (:results (y :scs (,to-sc)))
 845                 (:arg-types signed-num)
 846                 (:result-types ,to-type)
 847                 (:policy :fast-safe)
 848                 (:note "inline float coercion")
 849                 (:translate ,translate)
 850                 (:vop-var vop)
 851                 (:save-p :compute-only)
 852                 (:generator 5
 853                   (let ((stack-tn
 854                          (sc-case x
 855                            (signed-reg
 856                             (inst st x
 857                                   (current-nfp-tn vop)
 858                                   (* (tn-offset temp) n-word-bytes))
 859                             stack-temp)
 860                            (signed-stack
 861                             x))))
 862                     (inst ldf temp
 863                           (current-nfp-tn vop)
 864                           (* (tn-offset stack-tn) n-word-bytes))
 865                     (note-this-location vop :internal-error)
 866                     (inst ,inst y temp))))))
 867   (frob %single-float/signed %single-float fitos single-reg single-float)
 868   (frob %double-float/signed %double-float fitod double-reg double-float)
 869   #!+long-float
 870   (frob %long-float/signed %long-float fitoq long-reg long-float))
 871
 872 (macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
 873              `(define-vop (,name)
 874                 (:args (x :scs (,from-sc)))
 875                 (:results (y :scs (,to-sc)))
 876                 (:arg-types ,from-type)
 877                 (:result-types ,to-type)
 878                 (:policy :fast-safe)
 879                 (:note "inline float coercion")
 880                 (:translate ,translate)
 881                 (:vop-var vop)
 882                 (:save-p :compute-only)
 883                 (:generator 2
 884                   (note-this-location vop :internal-error)
 885                   (inst ,inst y x)))))
 886   (frob %single-float/double-float %single-float fdtos
 887     double-reg double-float single-reg single-float)
 888   #!+long-float
 889   (frob %single-float/long-float %single-float fqtos
 890     long-reg long-float single-reg single-float)
 891   (frob %double-float/single-float %double-float fstod
 892     single-reg single-float double-reg double-float)
 893   #!+long-float
 894   (frob %double-float/long-float %double-float fqtod
 895     long-reg long-float double-reg double-float)
 896   #!+long-float
 897   (frob %long-float/single-float %long-float fstoq
 898     single-reg single-float long-reg long-float)
 899   #!+long-float
 900   (frob %long-float/double-float %long-float fdtoq
 901     double-reg double-float long-reg long-float))
 902
 903 (macrolet ((frob (trans from-sc from-type inst)
 904              `(define-vop (,(symbolicate trans "/" from-type))
 905                 (:args (x :scs (,from-sc) :target temp))
 906                 (:temporary (:from (:argument 0) :sc single-reg) temp)
 907                 (:temporary (:scs (signed-stack)) stack-temp)
 908                 (:results (y :scs (signed-reg)
 909                              :load-if (not (sc-is y signed-stack))))
 910                 (:arg-types ,from-type)
 911                 (:result-types signed-num)
 912                 (:translate ,trans)
 913                 (:policy :fast-safe)
 914                 (:note "inline float truncate")
 915                 (:vop-var vop)
 916                 (:save-p :compute-only)
 917                 (:generator 5
 918                   (note-this-location vop :internal-error)
 919                   (inst ,inst temp x)
 920                   (sc-case y
 921                     (signed-stack
 922                      (inst stf temp (current-nfp-tn vop)
 923                            (* (tn-offset y) n-word-bytes)))
 924                     (signed-reg
 925                      (inst stf temp (current-nfp-tn vop)
 926                            (* (tn-offset stack-temp) n-word-bytes))
 927                      (inst ld y (current-nfp-tn vop)
 928                            (* (tn-offset stack-temp) n-word-bytes))))))))
 929   (frob %unary-truncate single-reg single-float fstoi)
 930   (frob %unary-truncate double-reg double-float fdtoi)
 931   #!+long-float
 932   (frob %unary-truncate long-reg long-float fqtoi)
 933   ;; KLUDGE -- these two forms were protected by #-sun4.
 934   ;; (frob %unary-round single-reg single-float fstoir)
 935   ;; (frob %unary-round double-reg double-float fdtoir)
 936 )
 937
 938 (deftransform %unary-round ((x) (float) (signed-byte 32))
 939   '(let* ((trunc (truly-the (signed-byte 32) (%unary-truncate x)))
 940           (extra (- x trunc))
 941           (absx (abs extra))
 942           (one-half (float 1/2 x)))
 943      (if (if (oddp trunc)
 944              (>= absx one-half)
 945              (> absx one-half))
 946          (truly-the (signed-byte 32) (%unary-truncate (+ x extra)))
 947          trunc)))
 948
 949 (define-vop (make-single-float)
 950   (:args (bits :scs (signed-reg) :target res
 951                :load-if (not (sc-is bits signed-stack))))
 952   (:results (res :scs (single-reg)
 953                  :load-if (not (sc-is res single-stack))))
 954   (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
 955   (:temporary (:scs (signed-stack)) stack-temp)
 956   (:arg-types signed-num)
 957   (:result-types single-float)
 958   (:translate make-single-float)
 959   (:policy :fast-safe)
 960   (:vop-var vop)
 961   (:generator 4
 962     (sc-case bits
 963       (signed-reg
 964        (sc-case res
 965          (single-reg
 966           (inst st bits (current-nfp-tn vop)
 967                 (* (tn-offset stack-temp) n-word-bytes))
 968           (inst ldf res (current-nfp-tn vop)
 969                 (* (tn-offset stack-temp) n-word-bytes)))
 970          (single-stack
 971           (inst st bits (current-nfp-tn vop)
 972                 (* (tn-offset res) n-word-bytes)))))
 973       (signed-stack
 974        (sc-case res
 975          (single-reg
 976           (inst ldf res (current-nfp-tn vop)
 977                 (* (tn-offset bits) n-word-bytes)))
 978          (single-stack
 979           (unless (location= bits res)
 980             (inst ld temp (current-nfp-tn vop)
 981                   (* (tn-offset bits) n-word-bytes))
 982             (inst st temp (current-nfp-tn vop)
 983                   (* (tn-offset res) n-word-bytes)))))))))
 984
 985 (define-vop (make-double-float)
 986   (:args (hi-bits :scs (signed-reg))
 987          (lo-bits :scs (unsigned-reg)))
 988   (:results (res :scs (double-reg)
 989                  :load-if (not (sc-is res double-stack))))
 990   (:temporary (:scs (double-stack)) temp)
 991   (:arg-types signed-num unsigned-num)
 992   (:result-types double-float)
 993   (:translate make-double-float)
 994   (:policy :fast-safe)
 995   (:vop-var vop)
 996   (:generator 2
 997     (let ((stack-tn (sc-case res
 998                       (double-stack res)
 999                       (double-reg temp))))
1000       (inst st hi-bits (current-nfp-tn vop)
1001             (* (tn-offset stack-tn) n-word-bytes))
1002       (inst st lo-bits (current-nfp-tn vop)
1003             (* (1+ (tn-offset stack-tn)) n-word-bytes)))
1004     (when (sc-is res double-reg)
1005       (inst lddf res (current-nfp-tn vop)
1006             (* (tn-offset temp) n-word-bytes)))))
1007
1008 #!+long-float
1009 (define-vop (make-long-float)
1010     (:args (hi-bits :scs (signed-reg))
1011            (lo1-bits :scs (unsigned-reg))
1012            (lo2-bits :scs (unsigned-reg))
1013            (lo3-bits :scs (unsigned-reg)))
1014   (:results (res :scs (long-reg)
1015                  :load-if (not (sc-is res long-stack))))
1016   (:temporary (:scs (long-stack)) temp)
1017   (:arg-types signed-num unsigned-num unsigned-num unsigned-num)
1018   (:result-types long-float)
1019   (:translate make-long-float)
1020   (:policy :fast-safe)
1021   (:vop-var vop)
1022   (:generator 2
1023     (let ((stack-tn (sc-case res
1024                       (long-stack res)
1025                       (long-reg temp))))
1026       (inst st hi-bits (current-nfp-tn vop)
1027             (* (tn-offset stack-tn) n-word-bytes))
1028       (inst st lo1-bits (current-nfp-tn vop)
1029             (* (1+ (tn-offset stack-tn)) n-word-bytes))
1030       (inst st lo2-bits (current-nfp-tn vop)
1031             (* (+ 2 (tn-offset stack-tn)) n-word-bytes))
1032       (inst st lo3-bits (current-nfp-tn vop)
1033             (* (+ 3 (tn-offset stack-tn)) n-word-bytes)))
1034     (when (sc-is res long-reg)
1035       (load-long-reg res (current-nfp-tn vop)
1036                      (* (tn-offset temp) n-word-bytes)))))
1037
1038 (define-vop (single-float-bits)
1039   (:args (float :scs (single-reg descriptor-reg)
1040                 :load-if (not (sc-is float single-stack))))
1041   (:results (bits :scs (signed-reg)
1042                   :load-if (or (sc-is float descriptor-reg single-stack)
1043                                (not (sc-is bits signed-stack)))))
1044   (:temporary (:scs (signed-stack)) stack-temp)
1045   (:arg-types single-float)
1046   (:result-types signed-num)
1047   (:translate single-float-bits)
1048   (:policy :fast-safe)
1049   (:vop-var vop)
1050   (:generator 4
1051     (sc-case bits
1052       (signed-reg
1053        (sc-case float
1054          (single-reg
1055           (inst stf float (current-nfp-tn vop)
1056                 (* (tn-offset stack-temp) n-word-bytes))
1057           (inst ld bits (current-nfp-tn vop)
1058                 (* (tn-offset stack-temp) n-word-bytes)))
1059          (single-stack
1060           (inst ld bits (current-nfp-tn vop)
1061                 (* (tn-offset float) n-word-bytes)))
1062          (descriptor-reg
1063           (loadw bits float single-float-value-slot
1064                  other-pointer-lowtag))))
1065       (signed-stack
1066        (sc-case float
1067          (single-reg
1068           (inst stf float (current-nfp-tn vop)
1069                 (* (tn-offset bits) n-word-bytes))))))))
1070
1071 (define-vop (double-float-high-bits)
1072   (:args (float :scs (double-reg descriptor-reg)
1073                 :load-if (not (sc-is float double-stack))))
1074   (:results (hi-bits :scs (signed-reg)))
1075   (:temporary (:scs (double-stack)) stack-temp)
1076   (:arg-types double-float)
1077   (:result-types signed-num)
1078   (:translate double-float-high-bits)
1079   (:policy :fast-safe)
1080   (:vop-var vop)
1081   (:generator 5
1082     (sc-case float
1083       (double-reg
1084        (inst stdf float (current-nfp-tn vop)
1085              (* (tn-offset stack-temp) n-word-bytes))
1086        (inst ld hi-bits (current-nfp-tn vop)
1087              (* (tn-offset stack-temp) n-word-bytes)))
1088       (double-stack
1089        (inst ld hi-bits (current-nfp-tn vop)
1090              (* (tn-offset float) n-word-bytes)))
1091       (descriptor-reg
1092        (loadw hi-bits float double-float-value-slot
1093               other-pointer-lowtag)))))
1094
1095 (define-vop (double-float-low-bits)
1096   (:args (float :scs (double-reg descriptor-reg)
1097                 :load-if (not (sc-is float double-stack))))
1098   (:results (lo-bits :scs (unsigned-reg)))
1099   (:temporary (:scs (double-stack)) stack-temp)
1100   (:arg-types double-float)
1101   (:result-types unsigned-num)
1102   (:translate double-float-low-bits)
1103   (:policy :fast-safe)
1104   (:vop-var vop)
1105   (:generator 5
1106     (sc-case float
1107       (double-reg
1108        (inst stdf float (current-nfp-tn vop)
1109              (* (tn-offset stack-temp) n-word-bytes))
1110        (inst ld lo-bits (current-nfp-tn vop)
1111              (* (1+ (tn-offset stack-temp)) n-word-bytes)))
1112       (double-stack
1113        (inst ld lo-bits (current-nfp-tn vop)
1114              (* (1+ (tn-offset float)) n-word-bytes)))
1115       (descriptor-reg
1116        (loadw lo-bits float (1+ double-float-value-slot)
1117               other-pointer-lowtag)))))
1118
1119 #!+long-float
1120 (define-vop (long-float-exp-bits)
1121   (:args (float :scs (long-reg descriptor-reg)
1122                 :load-if (not (sc-is float long-stack))))
1123   (:results (exp-bits :scs (signed-reg)))
1124   (:temporary (:scs (double-stack)) stack-temp)
1125   (:arg-types long-float)
1126   (:result-types signed-num)
1127   (:translate long-float-exp-bits)
1128   (:policy :fast-safe)
1129   (:vop-var vop)
1130   (:generator 5
1131     (sc-case float
1132       (long-reg
1133        (let ((float (make-random-tn :kind :normal
1134                                     :sc (sc-or-lose 'double-reg)
1135                                     :offset (tn-offset float))))
1136          (inst stdf float (current-nfp-tn vop)
1137                (* (tn-offset stack-temp) n-word-bytes)))
1138        (inst ld exp-bits (current-nfp-tn vop)
1139              (* (tn-offset stack-temp) n-word-bytes)))
1140       (long-stack
1141        (inst ld exp-bits (current-nfp-tn vop)
1142              (* (tn-offset float) n-word-bytes)))
1143       (descriptor-reg
1144        (loadw exp-bits float long-float-value-slot
1145               other-pointer-lowtag)))))
1146
1147 #!+long-float
1148 (define-vop (long-float-high-bits)
1149   (:args (float :scs (long-reg descriptor-reg)
1150                 :load-if (not (sc-is float long-stack))))
1151   (:results (high-bits :scs (unsigned-reg)))
1152   (:temporary (:scs (double-stack)) stack-temp)
1153   (:arg-types long-float)
1154   (:result-types unsigned-num)
1155   (:translate long-float-high-bits)
1156   (:policy :fast-safe)
1157   (:vop-var vop)
1158   (:generator 5
1159     (sc-case float
1160       (long-reg
1161        (let ((float (make-random-tn :kind :normal
1162                                     :sc (sc-or-lose 'double-reg)
1163                                     :offset (tn-offset float))))
1164          (inst stdf float (current-nfp-tn vop)
1165                (* (tn-offset stack-temp) n-word-bytes)))
1166        (inst ld high-bits (current-nfp-tn vop)
1167              (* (1+ (tn-offset stack-temp)) n-word-bytes)))
1168       (long-stack
1169        (inst ld high-bits (current-nfp-tn vop)
1170              (* (1+ (tn-offset float)) n-word-bytes)))
1171       (descriptor-reg
1172        (loadw high-bits float (1+ long-float-value-slot)
1173               other-pointer-lowtag)))))
1174
1175 #!+long-float
1176 (define-vop (long-float-mid-bits)
1177   (:args (float :scs (long-reg descriptor-reg)
1178                 :load-if (not (sc-is float long-stack))))
1179   (:results (mid-bits :scs (unsigned-reg)))
1180   (:temporary (:scs (double-stack)) stack-temp)
1181   (:arg-types long-float)
1182   (:result-types unsigned-num)
1183   (:translate long-float-mid-bits)
1184   (:policy :fast-safe)
1185   (:vop-var vop)
1186   (:generator 5
1187     (sc-case float
1188       (long-reg
1189        (let ((float (make-random-tn :kind :normal
1190                                     :sc (sc-or-lose 'double-reg)
1191                                     :offset (+ 2 (tn-offset float)))))
1192          (inst stdf float (current-nfp-tn vop)
1193                (* (tn-offset stack-temp) n-word-bytes)))
1194        (inst ld mid-bits (current-nfp-tn vop)
1195              (* (tn-offset stack-temp) n-word-bytes)))
1196       (long-stack
1197        (inst ld mid-bits (current-nfp-tn vop)
1198              (* (+ 2 (tn-offset float)) n-word-bytes)))
1199       (descriptor-reg
1200        (loadw mid-bits float (+ 2 long-float-value-slot)
1201               other-pointer-lowtag)))))
1202
1203 #!+long-float
1204 (define-vop (long-float-low-bits)
1205   (:args (float :scs (long-reg descriptor-reg)
1206                 :load-if (not (sc-is float long-stack))))
1207   (:results (lo-bits :scs (unsigned-reg)))
1208   (:temporary (:scs (double-stack)) stack-temp)
1209   (:arg-types long-float)
1210   (:result-types unsigned-num)
1211   (:translate long-float-low-bits)
1212   (:policy :fast-safe)
1213   (:vop-var vop)
1214   (:generator 5
1215     (sc-case float
1216       (long-reg
1217        (let ((float (make-random-tn :kind :normal
1218                                     :sc (sc-or-lose 'double-reg)
1219                                     :offset (+ 2 (tn-offset float)))))
1220          (inst stdf float (current-nfp-tn vop)
1221                (* (tn-offset stack-temp) n-word-bytes)))
1222        (inst ld lo-bits (current-nfp-tn vop)
1223              (* (1+ (tn-offset stack-temp)) n-word-bytes)))
1224       (long-stack
1225        (inst ld lo-bits (current-nfp-tn vop)
1226              (* (+ 3 (tn-offset float)) n-word-bytes)))
1227       (descriptor-reg
1228        (loadw lo-bits float (+ 3 long-float-value-slot)
1229               other-pointer-lowtag)))))
1230
1231 \f
1232 ;;;; Float mode hackery:
1233
1234 (sb!xc:deftype float-modes () '(unsigned-byte 32))
1235 (defknown floating-point-modes () float-modes (flushable))
1236 (defknown ((setf floating-point-modes)) (float-modes)
1237   float-modes)
1238
1239 (define-vop (floating-point-modes)
1240   (:results (res :scs (unsigned-reg)))
1241   (:result-types unsigned-num)
1242   (:translate floating-point-modes)
1243   (:policy :fast-safe)
1244   (:vop-var vop)
1245   (:temporary (:sc unsigned-stack) temp)
1246   (:generator 3
1247     (let ((nfp (current-nfp-tn vop)))
1248       (inst stfsr nfp (* n-word-bytes (tn-offset temp)))
1249       (loadw res nfp (tn-offset temp))
1250       (inst nop))))
1251
1252 #+nil
1253 (define-vop (floating-point-modes)
1254   (:results (res :scs (unsigned-reg)))
1255   (:result-types unsigned-num)
1256   (:translate floating-point-modes)
1257   (:policy :fast-safe)
1258   (:vop-var vop)
1259   (:temporary (:sc double-stack) temp)
1260   (:generator 3
1261     (let* ((nfp (current-nfp-tn vop))
1262            (offset (* 4 (tn-offset temp))))
1263       (inst stxfsr nfp offset)
1264       ;; The desired FP mode data is in the least significant 32
1265       ;; bits, which is stored at the next higher word in memory.
1266       (loadw res nfp (+ offset 4))
1267       ;; Is this nop needed? (toy@rtp.ericsson.se)
1268       (inst nop))))
1269
1270 (define-vop (set-floating-point-modes)
1271   (:args (new :scs (unsigned-reg) :target res))
1272   (:results (res :scs (unsigned-reg)))
1273   (:arg-types unsigned-num)
1274   (:result-types unsigned-num)
1275   (:translate (setf floating-point-modes))
1276   (:policy :fast-safe)
1277   (:temporary (:sc unsigned-stack) temp)
1278   (:vop-var vop)
1279   (:generator 3
1280     (let ((nfp (current-nfp-tn vop)))
1281       (storew new nfp (tn-offset temp))
1282       (inst ldfsr nfp (* n-word-bytes (tn-offset temp)))
1283       (move res new))))
1284
1285 #+nil
1286 (define-vop (set-floating-point-modes)
1287   (:args (new :scs (unsigned-reg) :target res))
1288   (:results (res :scs (unsigned-reg)))
1289   (:arg-types unsigned-num)
1290   (:result-types unsigned-num)
1291   (:translate (setf floating-point-modes))
1292   (:policy :fast-safe)
1293   (:temporary (:sc double-stack) temp)
1294   (:temporary (:sc unsigned-reg) my-fsr)
1295   (:vop-var vop)
1296   (:generator 3
1297     (let ((nfp (current-nfp-tn vop))
1298           (offset (* n-word-bytes (tn-offset temp))))
1299       (pseudo-atomic ()
1300         ;; Get the current FSR, so we can get the new %fcc's
1301         (inst stxfsr nfp offset)
1302         (inst ldx my-fsr nfp offset)
1303         ;; Carefully merge in the new mode bits with the rest of the
1304         ;; FSR.  This is only needed if we care about preserving the
1305         ;; high 32 bits of the FSR, which contain the additional
1306         ;; %fcc's on the sparc V9.  If not, we don't need this, but we
1307         ;; do need to make sure that the unused bits are written as
1308         ;; zeroes, according the the V9 architecture manual.
1309         (inst sra new 0)
1310         (inst srlx my-fsr 32)
1311         (inst sllx my-fsr 32)
1312         (inst or my-fsr new)
1313         ;; Save it back and load it into the fsr register
1314         (inst stx my-fsr nfp offset)
1315         (inst ldxfsr nfp offset)
1316         (move res new)))))
1317
1318 #+nil
1319 (define-vop (set-floating-point-modes)
1320   (:args (new :scs (unsigned-reg) :target res))
1321   (:results (res :scs (unsigned-reg)))
1322   (:arg-types unsigned-num)
1323   (:result-types unsigned-num)
1324   (:translate (setf floating-point-modes))
1325   (:policy :fast-safe)
1326   (:temporary (:sc double-stack) temp)
1327   (:temporary (:sc unsigned-reg) my-fsr)
1328   (:vop-var vop)
1329   (:generator 3
1330     (let ((nfp (current-nfp-tn vop))
1331           (offset (* n-word-bytes (tn-offset temp))))
1332       (inst stx new nfp offset)
1333       (inst ldxfsr nfp offset)
1334       (move res new))))
1335
1336 \f
1337 ;;;; Special functions.
1338
1339 #!-long-float
1340 (define-vop (fsqrt)
1341   (:args (x :scs (double-reg)))
1342   (:results (y :scs (double-reg)))
1343   (:translate %sqrt)
1344   (:policy :fast-safe)
1345   (:guard #!+(or :sparc-v7 :sparc-v8 :sparc-v9) t
1346           #!-(or :sparc-v7 :sparc-v8 :sparc-v9) nil)
1347   (:arg-types double-float)
1348   (:result-types double-float)
1349   (:note "inline float arithmetic")
1350   (:vop-var vop)
1351   (:save-p :compute-only)
1352   (:generator 1
1353     (note-this-location vop :internal-error)
1354     (inst fsqrtd y x)))
1355
1356 #!+long-float
1357 (define-vop (fsqrt-long)
1358   (:args (x :scs (long-reg)))
1359   (:results (y :scs (long-reg)))
1360   (:translate %sqrt)
1361   (:policy :fast-safe)
1362   (:arg-types long-float)
1363   (:result-types long-float)
1364   (:note "inline float arithmetic")
1365   (:vop-var vop)
1366   (:save-p :compute-only)
1367   (:generator 1
1368     (note-this-location vop :internal-error)
1369     (inst fsqrtq y x)))
1370
1371 \f
1372 ;;;; Complex float VOPs
1373
1374 (define-vop (make-complex-single-float)
1375   (:translate complex)
1376   (:args (real :scs (single-reg) :target r
1377                :load-if (not (location= real r)))
1378          (imag :scs (single-reg) :to :save))
1379   (:arg-types single-float single-float)
1380   (:results (r :scs (complex-single-reg) :from (:argument 0)
1381                :load-if (not (sc-is r complex-single-stack))))
1382   (:result-types complex-single-float)
1383   (:note "inline complex single-float creation")
1384   (:policy :fast-safe)
1385   (:vop-var vop)
1386   (:generator 5
1387     (sc-case r
1388       (complex-single-reg
1389        (let ((r-real (complex-single-reg-real-tn r)))
1390          (unless (location= real r-real)
1391            (inst fmovs r-real real)))
1392        (let ((r-imag (complex-single-reg-imag-tn r)))
1393          (unless (location= imag r-imag)
1394            (inst fmovs r-imag imag))))
1395       (complex-single-stack
1396        (let ((nfp (current-nfp-tn vop))
1397              (offset (* (tn-offset r) n-word-bytes)))
1398          (unless (location= real r)
1399            (inst stf real nfp offset))
1400          (inst stf imag nfp (+ offset n-word-bytes)))))))
1401
1402 (define-vop (make-complex-double-float)
1403   (:translate complex)
1404   (:args (real :scs (double-reg) :target r
1405                :load-if (not (location= real r)))
1406          (imag :scs (double-reg) :to :save))
1407   (:arg-types double-float double-float)
1408   (:results (r :scs (complex-double-reg) :from (:argument 0)
1409                :load-if (not (sc-is r complex-double-stack))))
1410   (:result-types complex-double-float)
1411   (:note "inline complex double-float creation")
1412   (:policy :fast-safe)
1413   (:vop-var vop)
1414   (:generator 5
1415     (sc-case r
1416       (complex-double-reg
1417        (let ((r-real (complex-double-reg-real-tn r)))
1418          (unless (location= real r-real)
1419            (move-double-reg r-real real)))
1420        (let ((r-imag (complex-double-reg-imag-tn r)))
1421          (unless (location= imag r-imag)
1422            (move-double-reg r-imag imag))))
1423       (complex-double-stack
1424        (let ((nfp (current-nfp-tn vop))
1425              (offset (* (tn-offset r) n-word-bytes)))
1426          (unless (location= real r)
1427            (inst stdf real nfp offset))
1428          (inst stdf imag nfp (+ offset (* 2 n-word-bytes))))))))
1429
1430 #!+long-float
1431 (define-vop (make-complex-long-float)
1432   (:translate complex)
1433   (:args (real :scs (long-reg) :target r
1434                :load-if (not (location= real r)))
1435          (imag :scs (long-reg) :to :save))
1436   (:arg-types long-float long-float)
1437   (:results (r :scs (complex-long-reg) :from (:argument 0)
1438                :load-if (not (sc-is r complex-long-stack))))
1439   (:result-types complex-long-float)
1440   (:note "inline complex long-float creation")
1441   (:policy :fast-safe)
1442   (:vop-var vop)
1443   (:generator 5
1444     (sc-case r
1445       (complex-long-reg
1446        (let ((r-real (complex-long-reg-real-tn r)))
1447          (unless (location= real r-real)
1448            (move-long-reg r-real real)))
1449        (let ((r-imag (complex-long-reg-imag-tn r)))
1450          (unless (location= imag r-imag)
1451            (move-long-reg r-imag imag))))
1452       (complex-long-stack
1453        (let ((nfp (current-nfp-tn vop))
1454              (offset (* (tn-offset r) n-word-bytes)))
1455          (unless (location= real r)
1456            (store-long-reg real nfp offset))
1457          (store-long-reg imag nfp (+ offset (* 4 n-word-bytes))))))))
1458
1459 (define-vop (complex-single-float-value)
1460   (:args (x :scs (complex-single-reg) :target r
1461             :load-if (not (sc-is x complex-single-stack))))
1462   (:arg-types complex-single-float)
1463   (:results (r :scs (single-reg)))
1464   (:result-types single-float)
1465   (:variant-vars slot)
1466   (:policy :fast-safe)
1467   (:vop-var vop)
1468   (:generator 3
1469     (sc-case x
1470       (complex-single-reg
1471        (let ((value-tn (ecase slot
1472                          (:real (complex-single-reg-real-tn x))
1473                          (:imag (complex-single-reg-imag-tn x)))))
1474          (unless (location= value-tn r)
1475            (inst fmovs r value-tn))))
1476       (complex-single-stack
1477        (inst ldf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
1478                                               (tn-offset x))
1479                                            n-word-bytes))))))
1480
1481 (define-vop (realpart/complex-single-float complex-single-float-value)
1482   (:translate realpart)
1483   (:note "complex single float realpart")
1484   (:variant :real))
1485
1486 (define-vop (imagpart/complex-single-float complex-single-float-value)
1487   (:translate imagpart)
1488   (:note "complex single float imagpart")
1489   (:variant :imag))
1490
1491 (define-vop (complex-double-float-value)
1492   (:args (x :scs (complex-double-reg) :target r
1493             :load-if (not (sc-is x complex-double-stack))))
1494   (:arg-types complex-double-float)
1495   (:results (r :scs (double-reg)))
1496   (:result-types double-float)
1497   (:variant-vars slot)
1498   (:policy :fast-safe)
1499   (:vop-var vop)
1500   (:generator 3
1501     (sc-case x
1502       (complex-double-reg
1503        (let ((value-tn (ecase slot
1504                          (:real (complex-double-reg-real-tn x))
1505                          (:imag (complex-double-reg-imag-tn x)))))
1506          (unless (location= value-tn r)
1507            (move-double-reg r value-tn))))
1508       (complex-double-stack
1509        (inst lddf r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
1510                                                (tn-offset x))
1511                                             n-word-bytes))))))
1512
1513 (define-vop (realpart/complex-double-float complex-double-float-value)
1514   (:translate realpart)
1515   (:note "complex double float realpart")
1516   (:variant :real))
1517
1518 (define-vop (imagpart/complex-double-float complex-double-float-value)
1519   (:translate imagpart)
1520   (:note "complex double float imagpart")
1521   (:variant :imag))
1522
1523 #!+long-float
1524 (define-vop (complex-long-float-value)
1525   (:args (x :scs (complex-long-reg) :target r
1526             :load-if (not (sc-is x complex-long-stack))))
1527   (:arg-types complex-long-float)
1528   (:results (r :scs (long-reg)))
1529   (:result-types long-float)
1530   (:variant-vars slot)
1531   (:policy :fast-safe)
1532   (:vop-var vop)
1533   (:generator 4
1534     (sc-case x
1535       (complex-long-reg
1536        (let ((value-tn (ecase slot
1537                          (:real (complex-long-reg-real-tn x))
1538                          (:imag (complex-long-reg-imag-tn x)))))
1539          (unless (location= value-tn r)
1540            (move-long-reg r value-tn))))
1541       (complex-long-stack
1542        (load-long-reg r (current-nfp-tn vop)
1543                       (* (+ (ecase slot (:real 0) (:imag 4)) (tn-offset x))
1544                          n-word-bytes))))))
1545
1546 #!+long-float
1547 (define-vop (realpart/complex-long-float complex-long-float-value)
1548   (:translate realpart)
1549   (:note "complex long float realpart")
1550   (:variant :real))
1551
1552 #!+long-float
1553 (define-vop (imagpart/complex-long-float complex-long-float-value)
1554   (:translate imagpart)
1555   (:note "complex long float imagpart")
1556   (:variant :imag))
1557
1558 \f
1559
1560 ;;;; Complex float arithmetic
1561
1562 #!+complex-fp-vops
1563 (progn
1564
1565 ;; Negate a complex
1566 (macrolet
1567     ((frob (float-type fneg cost)
1568        (let* ((vop-name (symbolicate "%NEGATE/COMPLEX-" float-type))
1569               (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1570               (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
1571               (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1572               (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1573          `(define-vop (,vop-name)
1574             (:args (x :scs (,complex-reg)))
1575             (:arg-types ,c-type)
1576             (:results (r :scs (,complex-reg)))
1577             (:result-types ,c-type)
1578             (:policy :fast-safe)
1579             (:note "inline complex float arithmetic")
1580             (:translate %negate)
1581             (:generator ,cost
1582               (let ((xr (,real-tn x))
1583                     (xi (,imag-tn x))
1584                     (rr (,real-tn r))
1585                     (ri (,imag-tn r)))
1586                 (,@fneg rr xr)
1587                 (,@fneg ri xi)))))))
1588   (frob single (inst fnegs) 4)
1589   (frob double (negate-double-reg) 4))
1590
1591 ;; Add and subtract for two complex arguments
1592 (macrolet
1593     ((frob (op inst float-type cost)
1594        (let* ((vop-name (symbolicate (symbol-name op) "/COMPLEX-" float-type "-FLOAT"))
1595               (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1596               (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
1597               (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1598               (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1599          `(define-vop (,vop-name)
1600            (:args (x :scs (,complex-reg)) (y :scs (,complex-reg)))
1601            (:results (r :scs (,complex-reg)))
1602            (:arg-types ,c-type ,c-type)
1603            (:result-types ,c-type)
1604            (:policy :fast-safe)
1605            (:note "inline complex float arithmetic")
1606            (:translate ,op)
1607            (:generator ,cost
1608             (let ((xr (,real-part x))
1609                   (xi (,imag-part x))
1610                   (yr (,real-part y))
1611                   (yi (,imag-part y))
1612                   (rr (,real-part r))
1613                   (ri (,imag-part r)))
1614               (inst ,inst rr xr yr)
1615               (inst ,inst ri xi yi)))))))
1616   (frob + fadds single 4)
1617   (frob + faddd double 4)
1618   (frob - fsubs single 4)
1619   (frob - fsubd double 4))
1620
1621 ;; Add and subtract a complex and a float
1622
1623 (macrolet
1624     ((frob (size op fop fmov cost)
1625        (let ((vop-name (symbolicate "COMPLEX-" size "-FLOAT-"
1626                                     op
1627                                     "-" size "-FLOAT"))
1628              (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1629              (real-reg (symbolicate size "-REG"))
1630              (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1631              (r-type (symbolicate size "-FLOAT"))
1632              (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1633              (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1634          `(define-vop (,vop-name)
1635               (:args (x :scs (,complex-reg))
1636                      (y :scs (,real-reg)))
1637             (:results (r :scs (,complex-reg)))
1638             (:arg-types ,c-type ,r-type)
1639             (:result-types ,c-type)
1640             (:policy :fast-safe)
1641             (:note "inline complex float/float arithmetic")
1642             (:translate ,op)
1643             (:generator ,cost
1644               (let ((xr (,real-part x))
1645                     (xi (,imag-part x))
1646                     (rr (,real-part r))
1647                     (ri (,imag-part r)))
1648                 (inst ,fop rr xr y)
1649                 (unless (location= ri xi)
1650                   (,@fmov ri xi))))))))
1651
1652   (frob single + fadds (inst fmovs) 2)
1653   (frob single - fsubs (inst fmovs) 2)
1654   (frob double + faddd (move-double-reg) 4)
1655   (frob double - fsubd (move-double-reg) 4))
1656
1657 ;; Add a float and a complex
1658 (macrolet
1659     ((frob (size fop fmov cost)
1660        (let ((vop-name
1661               (symbolicate size "-FLOAT-+-COMPLEX-" size "-FLOAT"))
1662              (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1663              (real-reg (symbolicate size "-REG"))
1664              (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1665              (r-type (symbolicate size "-FLOAT"))
1666              (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1667              (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1668          `(define-vop (,vop-name)
1669               (:args (y :scs (,real-reg))
1670                      (x :scs (,complex-reg)))
1671             (:results (r :scs (,complex-reg)))
1672             (:arg-types ,r-type ,c-type)
1673             (:result-types ,c-type)
1674             (:policy :fast-safe)
1675             (:note "inline complex float/float arithmetic")
1676             (:translate +)
1677             (:generator ,cost
1678               (let ((xr (,real-part x))
1679                     (xi (,imag-part x))
1680                     (rr (,real-part r))
1681                     (ri (,imag-part r)))
1682                 (inst ,fop rr xr y)
1683                 (unless (location= ri xi)
1684                   (,@fmov ri xi))))))))
1685   (frob single fadds (inst fmovs) 1)
1686   (frob double faddd (move-double-reg) 2))
1687
1688 ;; Subtract a complex from a float
1689
1690 (macrolet
1691     ((frob (size fop fneg cost)
1692        (let ((vop-name (symbolicate size "-FLOAT---COMPLEX-" size "-FLOAT"))
1693              (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1694              (real-reg (symbolicate size "-REG"))
1695              (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1696              (r-type (symbolicate size "-FLOAT"))
1697              (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1698              (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1699          `(define-vop (single-float---complex-single-float)
1700               (:args (x :scs (,real-reg)) (y :scs (,complex-reg)))
1701             (:results (r :scs (,complex-reg)))
1702             (:arg-types ,r-type ,c-type)
1703             (:result-types ,c-type)
1704             (:policy :fast-safe)
1705             (:note "inline complex float/float arithmetic")
1706             (:translate -)
1707             (:generator ,cost
1708                (let ((yr (,real-part y))
1709                      (yi (,imag-part y))
1710                      (rr (,real-part r))
1711                      (ri (,imag-part r)))
1712                  (inst ,fop rr x yr)
1713                  (,@fneg ri yi))))
1714        ))
1715
1716   (frob single fsubs (inst fnegs) 2)
1717   (frob double fsubd (negate-double-reg) 2)))
1718
1719 ;; Multiply two complex numbers
1720
1721 #+nil
1722 (macrolet
1723     ((frob (size fmul fadd fsub cost)
1724        (let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
1725              (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1726              (real-reg (symbolicate size "-REG"))
1727              (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1728              (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1729              (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1730          `(define-vop (,vop-name)
1731             (:args (x :scs (,complex-reg))
1732                    (y :scs (,complex-reg)))
1733             (:results (r :scs (,complex-reg)))
1734             (:arg-types ,c-type ,c-type)
1735             (:result-types ,c-type)
1736             (:policy :fast-safe)
1737             (:note "inline complex float multiplication")
1738             (:translate *)
1739             (:temporary (:scs (,real-reg)) prod-1 prod-2 prod-3 prod-4)
1740             (:generator ,cost
1741               (let ((xr (,real-part x))
1742                     (xi (,imag-part x))
1743                     (yr (,real-part y))
1744                     (yi (,imag-part y))
1745                     (rr (,real-part r))
1746                     (ri (,imag-part r)))
1747                 ;; All of the temps are needed in case the result TN happens to
1748                 ;; be the same as one of the arg TN's
1749                 (inst ,fmul prod-1 xr yr)
1750                 (inst ,fmul prod-2 xi yi)
1751                 (inst ,fmul prod-3 xr yi)
1752                 (inst ,fmul prod-4 xi yr)
1753                 (inst ,fsub rr prod-1 prod-2)
1754                 (inst ,fadd ri prod-3 prod-4)))))))
1755
1756   (frob single fmuls fadds fsubs 6)
1757   (frob double fmuld faddd fsubd 6))
1758
1759 (macrolet
1760     ((frob (size fmul fadd fsub cost)
1761        (let ((vop-name (symbolicate "*/COMPLEX-" size "-FLOAT"))
1762              (complex-reg (symbolicate "COMPLEX-" size "-REG"))
1763              (real-reg (symbolicate size "-REG"))
1764              (c-type (symbolicate "COMPLEX-" size "-FLOAT"))
1765              (real-part (symbolicate "COMPLEX-" size "-REG-REAL-TN"))
1766              (imag-part (symbolicate "COMPLEX-" size "-REG-IMAG-TN")))
1767          `(define-vop (,vop-name)
1768             (:args (x :scs (,complex-reg))
1769                    (y :scs (,complex-reg)))
1770             (:results (r :scs (,complex-reg)))
1771             (:arg-types ,c-type ,c-type)
1772             (:result-types ,c-type)
1773             (:policy :fast-safe)
1774             (:note "inline complex float multiplication")
1775             (:translate *)
1776             (:temporary (:scs (,real-reg)) p1 p2)
1777             (:generator ,cost
1778               (let ((xr (,real-part x))
1779                     (xi (,imag-part x))
1780                     (yr (,real-part y))
1781                     (yi (,imag-part y))
1782                     (rr (,real-part r))
1783                     (ri (,imag-part r)))
1784                 (cond ((location= r x)
1785                        (inst ,fmul p1 xr yr)
1786                        (inst ,fmul p2 xr yi)
1787                        (inst ,fmul rr xi yi)
1788                        (inst ,fsub rr p1 xr)
1789                        (inst ,fmul p1 xi yr)
1790                        (inst ,fadd ri p2 p1))
1791                       ((location= r y)
1792                        (inst ,fmul p1 yr xr)
1793                        (inst ,fmul p2 yr xi)
1794                        (inst ,fmul rr yi xi)
1795                        (inst ,fsub rr p1 rr)
1796                        (inst ,fmul p1 yi xr)
1797                        (inst ,fadd ri p2 p1))
1798                       (t
1799                        (inst ,fmul rr yr xr)
1800                        (inst ,fmul ri xi yi)
1801                        (inst ,fsub rr rr ri)
1802                        (inst ,fmul p1 xr yi)
1803                        (inst ,fmul ri xi yr)
1804                        (inst ,fadd ri ri p1)))))))))
1805
1806   (frob single fmuls fadds fsubs 6)
1807   (frob double fmuld faddd fsubd 6))
1808
1809 ;; Multiply a complex by a float.  The case of float * complex is
1810 ;; handled by a deftransform to convert it to the complex*float case.
1811 (macrolet
1812     ((frob (float-type fmul mov cost)
1813        (let* ((vop-name (symbolicate "COMPLEX-"
1814                                      float-type
1815                                      "-FLOAT-*-"
1816                                      float-type
1817                                      "-FLOAT"))
1818               (vop-name-r (symbolicate float-type
1819                                        "-FLOAT-*-COMPLEX-"
1820                                        float-type
1821                                        "-FLOAT"))
1822               (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
1823               (real-sc-type (symbolicate float-type "-REG"))
1824               (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1825               (r-type (symbolicate float-type "-FLOAT"))
1826               (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1827               (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1828          `(progn
1829            ;; Complex * float
1830            (define-vop (,vop-name)
1831              (:args (x :scs (,complex-sc-type))
1832                     (y :scs (,real-sc-type)))
1833              (:results (r :scs (,complex-sc-type)))
1834              (:arg-types ,c-type ,r-type)
1835              (:result-types ,c-type)
1836              (:policy :fast-safe)
1837              (:note "inline complex float arithmetic")
1838              (:translate *)
1839              (:temporary (:scs (,real-sc-type)) temp)
1840              (:generator ,cost
1841               (let ((xr (,real-part x))
1842                     (xi (,imag-part x))
1843                     (rr (,real-part r))
1844                     (ri (,imag-part r)))
1845                 (cond ((location= y rr)
1846                        (inst ,fmul temp xr y) ; xr * y
1847                        (inst ,fmul ri xi y) ; xi * yi
1848                        (,@mov rr temp))
1849                       (t
1850                        (inst ,fmul rr xr y)
1851                        (inst ,fmul ri xi y))))))
1852            ;; Float * complex
1853            (define-vop (,vop-name-r)
1854              (:args (y :scs (,real-sc-type))
1855                     (x :scs (,complex-sc-type)))
1856              (:results (r :scs (,complex-sc-type)))
1857              (:arg-types ,r-type ,c-type)
1858              (:result-types ,c-type)
1859              (:policy :fast-safe)
1860              (:note "inline complex float arithmetic")
1861              (:translate *)
1862              (:temporary (:scs (,real-sc-type)) temp)
1863              (:generator ,cost
1864               (let ((xr (,real-part x))
1865                     (xi (,imag-part x))
1866                     (rr (,real-part r))
1867                     (ri (,imag-part r)))
1868                 (cond ((location= y rr)
1869                        (inst ,fmul temp xr y) ; xr * y
1870                        (inst ,fmul ri xi y) ; xi * yi
1871                        (,@mov rr temp))
1872                       (t
1873                        (inst ,fmul rr xr y)
1874                        (inst ,fmul ri xi y))))))))))
1875   (frob single fmuls (inst fmovs) 4)
1876   (frob double fmuld (move-double-reg) 4))
1877
1878
1879 ;; Divide a complex by a complex
1880
1881 ;; Here's how we do a complex division
1882 ;;
1883 ;; Compute (xr + i*xi)/(yr + i*yi)
1884 ;;
1885 ;; Assume |yi| < |yr|.  Then
1886 ;;
1887 ;; (xr + i*xi)      (xr + i*xi)
1888 ;; ----------- = -----------------
1889 ;; (yr + i*yi)   yr*(1 + i*(yi/yr))
1890 ;;
1891 ;;               (xr + i*xi)*(1 - i*(yi/yr))
1892 ;;             = ---------------------------
1893 ;;                   yr*(1 + (yi/yr)^2)
1894 ;;
1895 ;;               (xr + (yi/yr)*xi) + i*(xi - (yi/yr)*xr)
1896 ;;             = --------------------------------------
1897 ;;                        yr + (yi/yr)*yi
1898 ;;
1899 ;;
1900 ;; We do the similar thing when |yi| > |yr|.  The result is
1901 ;;
1902 ;;
1903 ;; (xr + i*xi)      (xr + i*xi)
1904 ;; ----------- = -----------------
1905 ;; (yr + i*yi)   yi*((yr/yi) + i)
1906 ;;
1907 ;;               (xr + i*xi)*((yr/yi) - i)
1908 ;;             = -------------------------
1909 ;;                  yi*((yr/yi)^2 + 1)
1910 ;;
1911 ;;               (xr*(yr/yi) + xi) + i*(xi*(yr/yi) - xr)
1912 ;;             = ---------------------------------------
1913 ;;                       yi + (yr/yi)*yr
1914 ;;
1915
1916 #+nil
1917 (macrolet
1918     ((frob (float-type fcmp fadd fsub fmul fdiv fabs fmov cost)
1919        (let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
1920              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
1921              (real-reg (symbolicate float-type "-REG"))
1922              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1923              (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1924              (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1925          `(define-vop (,vop-name)
1926             (:args (x :scs (,complex-reg))
1927                    (y :scs (,complex-reg)))
1928             (:results (r :scs (,complex-reg)))
1929             (:arg-types ,c-type ,c-type)
1930             (:result-types ,c-type)
1931             (:policy :fast-safe)
1932             (:note "inline complex float division")
1933             (:translate /)
1934             (:temporary (:sc ,real-reg) ratio)
1935             (:temporary (:sc ,real-reg) den)
1936             (:temporary (:sc ,real-reg) temp-r)
1937             (:temporary (:sc ,real-reg) temp-i)
1938             (:generator ,cost
1939               (let ((xr (,real-part x))
1940                     (xi (,imag-part x))
1941                     (yr (,real-part y))
1942                     (yi (,imag-part y))
1943                     (rr (,real-part r))
1944                     (ri (,imag-part r))
1945                     (bigger (gen-label))
1946                     (done (gen-label)))
1947                 (,@fabs ratio yr)
1948                 (,@fabs den yi)
1949                 (inst ,fcmp ratio den)
1950                 #!-:sparc-v9 (inst nop)
1951                 (inst fb :ge bigger)
1952                 (inst nop)
1953                 ;; The case of |yi| <= |yr|
1954                 (inst ,fdiv ratio yi yr) ; ratio = yi/yr
1955                 (inst ,fmul den ratio yi)
1956                 (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
1957
1958                 (inst ,fmul temp-r ratio xi)
1959                 (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
1960                 (inst ,fdiv temp-r temp-r den)
1961
1962                 (inst ,fmul temp-i ratio xr)
1963                 (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
1964                 (inst b done)
1965                 (inst ,fdiv temp-i temp-i den)
1966
1967                 (emit-label bigger)
1968                 ;; The case of |yi| > |yr|
1969                 (inst ,fdiv ratio yr yi) ; ratio = yr/yi
1970                 (inst ,fmul den ratio yr)
1971                 (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
1972
1973                 (inst ,fmul temp-r ratio xr)
1974                 (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
1975                 (inst ,fdiv temp-r temp-r den)
1976
1977                 (inst ,fmul temp-i ratio xi)
1978                 (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
1979                 (inst ,fdiv temp-i temp-i den)
1980
1981                 (emit-label done)
1982                 (unless (location= temp-r rr)
1983                   (,@fmov rr temp-r))
1984                 (unless (location= temp-i ri)
1985                   (,@fmov ri temp-i))
1986                 ))))))
1987
1988   (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) (inst fmovs) 15)
1989   (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) (move-double-reg) 15))
1990
1991 (macrolet
1992     ((frob (float-type fcmp fadd fsub fmul fdiv fabs cost)
1993        (let ((vop-name (symbolicate "//COMPLEX-" float-type "-FLOAT"))
1994              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
1995              (real-reg (symbolicate float-type "-REG"))
1996              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
1997              (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
1998              (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
1999          `(define-vop (,vop-name)
2000             (:args (x :scs (,complex-reg))
2001                    (y :scs (,complex-reg)))
2002             (:results (r :scs (,complex-reg)))
2003             (:arg-types ,c-type ,c-type)
2004             (:result-types ,c-type)
2005             (:policy :fast-safe)
2006             (:note "inline complex float division")
2007             (:translate /)
2008             (:temporary (:sc ,real-reg) ratio)
2009             (:temporary (:sc ,real-reg) den)
2010             (:temporary (:sc ,real-reg) temp-r)
2011             (:temporary (:sc ,real-reg) temp-i)
2012             (:generator ,cost
2013               (let ((xr (,real-part x))
2014                     (xi (,imag-part x))
2015                     (yr (,real-part y))
2016                     (yi (,imag-part y))
2017                     (rr (,real-part r))
2018                     (ri (,imag-part r))
2019                     (bigger (gen-label))
2020                     (done (gen-label)))
2021                 (,@fabs ratio yr)
2022                 (,@fabs den yi)
2023                 (inst ,fcmp ratio den)
2024                 #!-:sparc-v9 (inst nop)
2025                 (inst fb :ge bigger)
2026                 (inst nop)
2027                 ;; The case of |yi| <= |yr|
2028                 (inst ,fdiv ratio yi yr) ; ratio = yi/yr
2029                 (inst ,fmul den ratio yi)
2030                 (inst ,fmul temp-r ratio xi)
2031                 (inst ,fmul temp-i ratio xr)
2032
2033                 (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
2034                 (inst ,fadd temp-r temp-r xr) ; temp-r = xr + (yi/yr)*xi
2035                 (inst b done)
2036                 (inst ,fsub temp-i xi temp-i) ; temp-i = xi - (yi/yr)*xr
2037
2038
2039                 (emit-label bigger)
2040                 ;; The case of |yi| > |yr|
2041                 (inst ,fdiv ratio yr yi) ; ratio = yr/yi
2042                 (inst ,fmul den ratio yr)
2043                 (inst ,fmul temp-r ratio xr)
2044                 (inst ,fmul temp-i ratio xi)
2045
2046                 (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
2047                 (inst ,fadd temp-r temp-r xi) ; temp-r = xi + xr*(yr/yi)
2048
2049                 (inst ,fsub temp-i temp-i xr) ; temp-i = xi*(yr/yi) - xr
2050
2051                 (emit-label done)
2052
2053                 (inst ,fdiv rr temp-r den)
2054                 (inst ,fdiv ri temp-i den)
2055                 ))))))
2056
2057   (frob single fcmps fadds fsubs fmuls fdivs (inst fabss) 15)
2058   (frob double fcmpd faddd fsubd fmuld fdivd (abs-double-reg) 15))
2059
2060
2061 ;; Divide a complex by a real
2062 (macrolet
2063     ((frob (float-type fdiv cost)
2064        (let* ((vop-name (symbolicate "COMPLEX-" float-type "-FLOAT-/-" float-type "-FLOAT"))
2065               (complex-sc-type (symbolicate "COMPLEX-" float-type "-REG"))
2066               (real-sc-type (symbolicate float-type "-REG"))
2067               (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2068               (r-type (symbolicate float-type "-FLOAT"))
2069               (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2070               (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2071          `(define-vop (,vop-name)
2072            (:args (x :scs (,complex-sc-type)) (y :scs (,real-sc-type)))
2073            (:results (r :scs (,complex-sc-type)))
2074            (:arg-types ,c-type ,r-type)
2075            (:result-types ,c-type)
2076            (:policy :fast-safe)
2077            (:note "inline complex float arithmetic")
2078            (:translate /)
2079            (:generator ,cost
2080             (let ((xr (,real-part x))
2081                   (xi (,imag-part x))
2082                   (rr (,real-part r))
2083                   (ri (,imag-part r)))
2084               (inst ,fdiv rr xr y)      ; xr * y
2085               (inst ,fdiv ri xi y)      ; xi * yi
2086               ))))))
2087   (frob single fdivs 2)
2088   (frob double fdivd 2))
2089
2090 ;; Divide a real by a complex
2091
2092 (macrolet
2093     ((frob (float-type fcmp fadd fmul fdiv fneg fabs cost)
2094        (let ((vop-name (symbolicate float-type "-FLOAT-/-COMPLEX-" float-type "-FLOAT"))
2095              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2096              (real-reg (symbolicate float-type "-REG"))
2097              (r-type (symbolicate float-type "-FLOAT"))
2098              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2099              (real-tn (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2100              (imag-tn (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2101          `(define-vop (,vop-name)
2102             (:args (x :scs (,real-reg))
2103                    (y :scs (,complex-reg)))
2104             (:results (r :scs (,complex-reg)))
2105             (:arg-types ,r-type ,c-type)
2106             (:result-types ,c-type)
2107             (:policy :fast-safe)
2108             (:note "inline complex float division")
2109             (:translate /)
2110             (:temporary (:sc ,real-reg) ratio)
2111             (:temporary (:sc ,real-reg) den)
2112             (:temporary (:sc ,real-reg) temp)
2113             (:generator ,cost
2114               (let ((yr (,real-tn y))
2115                     (yi (,imag-tn y))
2116                     (rr (,real-tn r))
2117                     (ri (,imag-tn r))
2118                     (bigger (gen-label))
2119                     (done (gen-label)))
2120                 (,@fabs ratio yr)
2121                 (,@fabs den yi)
2122                 (inst ,fcmp ratio den)
2123                 #!-:sparc-v9 (inst nop)
2124                 (inst fb :ge bigger)
2125                 (inst nop)
2126                 ;; The case of |yi| <= |yr|
2127                 (inst ,fdiv ratio yi yr) ; ratio = yi/yr
2128                 (inst ,fmul den ratio yi)
2129                 (inst ,fadd den den yr) ; den = yr + (yi/yr)*yi
2130
2131                 (inst ,fmul temp ratio x) ; temp = (yi/yr)*x
2132                 (inst ,fdiv rr x den)   ; rr = x/den
2133                 (inst b done)
2134                 (inst ,fdiv temp temp den) ; temp = (yi/yr)*x/den
2135
2136                 (emit-label bigger)
2137                 ;; The case of |yi| > |yr|
2138                 (inst ,fdiv ratio yr yi) ; ratio = yr/yi
2139                 (inst ,fmul den ratio yr)
2140                 (inst ,fadd den den yi) ; den = yi + (yr/yi)*yr
2141
2142                 (inst ,fmul temp ratio x) ; temp = (yr/yi)*x
2143                 (inst ,fdiv rr temp den) ; rr = (yr/yi)*x/den
2144                 (inst ,fdiv temp x den) ; temp = x/den
2145                 (emit-label done)
2146
2147                 (,@fneg ri temp)))))))
2148
2149   (frob single fcmps fadds fmuls fdivs (inst fnegs) (inst fabss) 10)
2150   (frob double fcmpd faddd fmuld fdivd (negate-double-reg) (abs-double-reg) 10))
2151
2152 ;; Conjugate of a complex number
2153
2154 (macrolet
2155     ((frob (float-type fneg fmov cost)
2156        (let ((vop-name (symbolicate "CONJUGATE/COMPLEX-" float-type "-FLOAT"))
2157              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2158              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2159              (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2160              (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2161          `(define-vop (,vop-name)
2162             (:args (x :scs (,complex-reg)))
2163             (:results (r :scs (,complex-reg)))
2164             (:arg-types ,c-type)
2165             (:result-types ,c-type)
2166             (:policy :fast-safe)
2167             (:note "inline complex conjugate")
2168             (:translate conjugate)
2169             (:generator ,cost
2170               (let ((xr (,real-part x))
2171                     (xi (,imag-part x))
2172                     (rr (,real-part r))
2173                     (ri (,imag-part r)))
2174                 (,@fneg ri xi)
2175                 (unless (location= rr xr)
2176                   (,@fmov rr xr))))))))
2177
2178   (frob single (inst fnegs) (inst fmovs) 4)
2179   (frob double (negate-double-reg) (move-double-reg) 4))
2180
2181 ;; Compare a float with a complex or a complex with a float
2182 #+nil
2183 (macrolet
2184     ((frob (name name-r f-type c-type)
2185        `(progn
2186          (defknown ,name (,f-type ,c-type) t)
2187          (defknown ,name-r (,c-type ,f-type) t)
2188          (defun ,name (x y)
2189            (declare (type ,f-type x)
2190                     (type ,c-type y))
2191            (,name x y))
2192          (defun ,name-r (x y)
2193            (declare (type ,c-type x)
2194                     (type ,f-type y))
2195            (,name-r x y))
2196          )))
2197   (frob %compare-complex-single-single %compare-single-complex-single
2198         single-float (complex single-float))
2199   (frob %compare-complex-double-double %compare-double-complex-double
2200         double-float (complex double-float)))
2201
2202 #+nil
2203 (macrolet
2204     ((frob (trans-1 trans-2 float-type fcmp fsub)
2205        (let ((vop-name
2206               (symbolicate "COMPLEX-" float-type "-FLOAT-"
2207                            float-type "-FLOAT-COMPARE"))
2208              (vop-name-r
2209               (symbolicate float-type "-FLOAT-COMPLEX-"
2210                            float-type "-FLOAT-COMPARE"))
2211              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2212              (real-reg (symbolicate float-type "-REG"))
2213              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2214              (r-type (symbolicate float-type "-FLOAT"))
2215              (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2216              (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2217          `(progn
2218             ;; (= float complex)
2219             (define-vop (,vop-name)
2220               (:args (x :scs (,real-reg))
2221                      (y :scs (,complex-reg)))
2222               (:arg-types ,r-type ,c-type)
2223               (:translate ,trans-1)
2224               (:conditional)
2225               (:info target not-p)
2226               (:policy :fast-safe)
2227               (:note "inline complex float/float comparison")
2228               (:vop-var vop)
2229               (:save-p :compute-only)
2230               (:temporary (:sc ,real-reg) fp-zero)
2231               (:guard #!-:sparc-v9 nil #!+:sparc-v9 t)
2232               (:generator 6
2233                (note-this-location vop :internal-error)
2234                (let ((yr (,real-part y))
2235                      (yi (,imag-part y)))
2236                  ;; Set fp-zero to zero
2237                  (inst ,fsub fp-zero fp-zero fp-zero)
2238                  (inst ,fcmp x yr)
2239                  (inst nop)
2240                  (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2241                  (inst ,fcmp yi fp-zero)
2242                  (inst nop)
2243                  (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2244                  (inst nop))))
2245             ;; (= complex float)
2246             (define-vop (,vop-name-r)
2247               (:args (y :scs (,complex-reg))
2248                      (x :scs (,real-reg)))
2249               (:arg-types ,c-type ,r-type)
2250               (:translate ,trans-2)
2251               (:conditional)
2252               (:info target not-p)
2253               (:policy :fast-safe)
2254               (:note "inline complex float/float comparison")
2255               (:vop-var vop)
2256               (:save-p :compute-only)
2257               (:temporary (:sc ,real-reg) fp-zero)
2258               (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
2259               (:generator 6
2260                (note-this-location vop :internal-error)
2261                (let ((yr (,real-part y))
2262                      (yi (,imag-part y)))
2263                  ;; Set fp-zero to zero
2264                  (inst ,fsub fp-zero fp-zero fp-zero)
2265                  (inst ,fcmp x yr)
2266                  (inst nop)
2267                  (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2268                  (inst ,fcmp yi fp-zero)
2269                  (inst nop)
2270                  (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2271                  (inst nop))))))))
2272   (frob %compare-complex-single-single %compare-single-complex-single
2273         single fcmps fsubs)
2274   (frob %compare-complex-double-double %compare-double-complex-double
2275         double fcmpd fsubd))
2276
2277 ;; Compare two complex numbers for equality
2278 (macrolet
2279     ((frob (float-type fcmp)
2280        (let ((vop-name
2281               (symbolicate "COMPLEX-" float-type "-FLOAT-COMPARE"))
2282              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2283              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2284              (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2285              (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2286          `(define-vop (,vop-name)
2287             (:args (x :scs (,complex-reg))
2288                    (y :scs (,complex-reg)))
2289             (:arg-types ,c-type ,c-type)
2290             (:translate =)
2291             (:conditional)
2292             (:info target not-p)
2293             (:policy :fast-safe)
2294             (:note "inline complex float comparison")
2295             (:vop-var vop)
2296             (:save-p :compute-only)
2297             (:guard #!-:sparc-v9 t #!+:sparc-v9 nil)
2298             (:generator 6
2299               (note-this-location vop :internal-error)
2300               (let ((xr (,real-part x))
2301                     (xi (,imag-part x))
2302                     (yr (,real-part y))
2303                     (yi (,imag-part y)))
2304                 (inst ,fcmp xr yr)
2305                 (inst nop)
2306                 (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2307                 (inst ,fcmp xi yi)
2308                 (inst nop)
2309                 (inst fb (if not-p :ne :eq) target #!+sparc-v9 :fcc0 #!+sparc-v9 :pn)
2310                 (inst nop)))))))
2311   (frob single fcmps)
2312   (frob double fcmpd))
2313
2314 ;; Compare a complex with a complex, for V9
2315 (macrolet
2316     ((frob (float-type fcmp)
2317        (let ((vop-name
2318               (symbolicate "V9-COMPLEX-" float-type "-FLOAT-COMPARE"))
2319              (complex-reg (symbolicate "COMPLEX-" float-type "-REG"))
2320              (c-type (symbolicate "COMPLEX-" float-type "-FLOAT"))
2321              (real-part (symbolicate "COMPLEX-" float-type "-REG-REAL-TN"))
2322              (imag-part (symbolicate "COMPLEX-" float-type "-REG-IMAG-TN")))
2323          `(define-vop (,vop-name)
2324             (:args (x :scs (,complex-reg))
2325                    (y :scs (,complex-reg)))
2326             (:arg-types ,c-type ,c-type)
2327             (:translate =)
2328             (:conditional)
2329             (:info target not-p)
2330             (:policy :fast-safe)
2331             (:note "inline complex float comparison")
2332             (:vop-var vop)
2333             (:save-p :compute-only)
2334             (:temporary (:sc descriptor-reg) true)
2335             (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
2336             (:generator 6
2337               (note-this-location vop :internal-error)
2338               (let ((xr (,real-part x))
2339                     (xi (,imag-part x))
2340                     (yr (,real-part y))
2341                     (yi (,imag-part y)))
2342                 ;; Assume comparison is true
2343                 (load-symbol true t)
2344                 (inst ,fcmp xr yr)
2345                 (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
2346                 (inst ,fcmp xi yi)
2347                 (inst cmove (if not-p :eq :ne) true null-tn :fcc0)
2348                 (inst cmp true null-tn)
2349                 (inst b (if not-p :eq :ne) target :pt)
2350                 (inst nop)))))))
2351   (frob single fcmps)
2352   (frob double fcmpd))
2353
2354 ) ; end progn complex-fp-vops
2355
2356 #!+sparc-v9
2357 (progn
2358
2359 ;; Vops to take advantage of the conditional move instruction
2360 ;; available on the Sparc V9
2361
2362 (defknown (%%max %%min) ((or (unsigned-byte #.n-word-bits)
2363                              (signed-byte #.n-word-bits)
2364                              single-float double-float)
2365                          (or (unsigned-byte #.n-word-bits)
2366                              (signed-byte #.n-word-bits)
2367                              single-float double-float))
2368   (or (unsigned-byte #.n-word-bits)
2369       (signed-byte #.n-word-bits)
2370       single-float double-float)
2371   (movable foldable flushable))
2372
2373 ;; We need these definitions for byte-compiled code
2374 (defun %%min (x y)
2375   (declare (type (or (unsigned-byte 32) (signed-byte 32)
2376                      single-float double-float) x y))
2377   (if (< x y)
2378       x y))
2379
2380 (defun %%max (x y)
2381   (declare (type (or (unsigned-byte 32) (signed-byte 32)
2382                      single-float double-float) x y))
2383   (if (> x y)
2384       x y))
2385
2386 (macrolet
2387     ((frob (name sc-type type compare cmov cost cc max min note)
2388        (let ((vop-name (symbolicate name "-" type "=>" type))
2389              (trans-name (symbolicate "%%" name)))
2390          `(define-vop (,vop-name)
2391             (:args (x :scs (,sc-type))
2392                    (y :scs (,sc-type)))
2393             (:results (r :scs (,sc-type)))
2394             (:arg-types ,type ,type)
2395             (:result-types ,type)
2396             (:policy :fast-safe)
2397             (:note ,note)
2398             (:translate ,trans-name)
2399             (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
2400             (:generator ,cost
2401               (inst ,compare x y)
2402               (cond ((location= r x)
2403                      ;; If x < y, need to move y to r, otherwise r already has
2404                      ;; the max.
2405                      (inst ,cmov ,min r y ,cc))
2406                     ((location= r y)
2407                      ;; If x > y, need to move x to r, otherwise r already has
2408                      ;; the max.
2409                      (inst ,cmov ,max r x ,cc))
2410                     (t
2411                      ;; It doesn't matter what R is, just copy the min to R.
2412                      (inst ,cmov ,max r x ,cc)
2413                      (inst ,cmov ,min r y ,cc))))))))
2414   (frob max single-reg single-float fcmps cfmovs 3
2415         :fcc0 :ge :l "inline float max")
2416   (frob max double-reg double-float fcmpd cfmovd 3
2417         :fcc0 :ge :l "inline float max")
2418   (frob min single-reg single-float fcmps cfmovs 3
2419         :fcc0 :l :ge "inline float min")
2420   (frob min double-reg double-float fcmpd cfmovd 3
2421         :fcc0 :l :ge "inline float min")
2422   ;; Strictly speaking these aren't float ops, but it's convenient to
2423   ;; do them here.
2424   ;;
2425   ;; The cost is here is the worst case number of instructions.  For
2426   ;; 32-bit integer operands, we add 2 more to account for the
2427   ;; untagging of fixnums, if necessary.
2428   (frob max signed-reg signed-num cmp cmove 5
2429         :icc :ge :lt "inline (signed-byte 32) max")
2430   (frob max unsigned-reg unsigned-num cmp cmove 5
2431         :icc :ge :lt "inline (unsigned-byte 32) max")
2432   ;; For fixnums, make the cost lower so we don't have to untag the
2433   ;; numbers.
2434   (frob max any-reg tagged-num cmp cmove 3
2435         :icc :ge :lt "inline fixnum max")
2436   (frob min signed-reg signed-num cmp cmove 5
2437         :icc :lt :ge "inline (signed-byte 32) min")
2438   (frob min unsigned-reg unsigned-num cmp cmove 5
2439         :icc :lt :ge "inline (unsigned-byte 32) min")
2440   ;; For fixnums, make the cost lower so we don't have to untag the
2441   ;; numbers.
2442   (frob min any-reg tagged-num cmp cmove 3
2443         :icc :lt :ge "inline fixnum min"))
2444
2445 #+nil
2446 (define-vop (max-boxed-double-float=>boxed-double-float)
2447   (:args (x :scs (descriptor-reg))
2448          (y :scs (descriptor-reg)))
2449   (:results (r :scs (descriptor-reg)))
2450   (:arg-types double-float double-float)
2451   (:result-types double-float)
2452   (:policy :fast-safe)
2453   (:note "inline float max/min")
2454   (:translate %max-double-float)
2455   (:temporary (:scs (double-reg)) xval)
2456   (:temporary (:scs (double-reg)) yval)
2457   (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
2458   (:vop-var vop)
2459   (:generator 3
2460     (let ((offset (- (* double-float-value-slot n-word-bytes)
2461                      other-pointer-lowtag)))
2462       (inst lddf xval x offset)
2463       (inst lddf yval y offset)
2464       (inst fcmpd xval yval)
2465       (cond ((location= r x)
2466              ;; If x < y, need to move y to r, otherwise r already has
2467              ;; the max.
2468              (inst cmove :l r y :fcc0))
2469             ((location= r y)
2470              ;; If x > y, need to move x to r, otherwise r already has
2471              ;; the max.
2472              (inst cmove :ge r x :fcc0))
2473             (t
2474              ;; It doesn't matter what R is, just copy the min to R.
2475              (inst cmove :ge r x :fcc0)
2476              (inst cmove :l r y :fcc0))))))
2477
2478 ) ; PROGN
2479
2480 (in-package "SB!C")
2481 ;;; FIXME
2482 #| #!+sparc-v9 |#
2483 #+nil
2484 (progn
2485 ;;; The sparc-v9 architecture has conditional move instructions that
2486 ;;; can be used.  This should be faster than using the obvious if
2487 ;;; expression since we don't have to do branches.
2488
2489 (def-source-transform min (&rest args)
2490   (case (length args)
2491     ((0 2) (values nil t))
2492     (1 `(values ,(first args)))
2493     (t (sb!c::associate-arguments 'min (first args) (rest args)))))
2494
2495 (def-source-transform max (&rest args)
2496   (case (length args)
2497     ((0 2) (values nil t))
2498     (1 `(values ,(first args)))
2499     (t (sb!c::associate-arguments 'max (first args) (rest args)))))
2500
2501 ;; Derive the types of max and min
2502 (defoptimizer (max derive-type) ((x y))
2503   (multiple-value-bind (definitely-< definitely->=)
2504       (ir1-transform-<-helper x y)
2505     (cond (definitely-<
2506               (continuation-type y))
2507           (definitely->=
2508               (continuation-type x))
2509           (t
2510            (make-canonical-union-type (list (continuation-type x)
2511                                             (continuation-type y)))))))
2512
2513 (defoptimizer (min derive-type) ((x y))
2514   (multiple-value-bind (definitely-< definitely->=)
2515       (ir1-transform-<-helper x y)
2516     (cond (definitely-<
2517               (continuation-type x))
2518           (definitely->=
2519               (continuation-type y))
2520           (t
2521            (make-canonical-union-type (list (continuation-type x)
2522                                             (continuation-type y)))))))
2523
2524 (deftransform max ((x y) (number number) * :when :both)
2525   (let ((x-type (continuation-type x))
2526         (y-type (continuation-type y))
2527         (signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
2528         (unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
2529         (d-float (specifier-type 'double-float))
2530         (s-float (specifier-type 'single-float)))
2531     ;; Use %%max if both args are good types of the same type.  As a
2532     ;; last resort, use the obvious comparison to select the desired
2533     ;; element.
2534     (cond ((and (csubtypep x-type signed)
2535                 (csubtypep y-type signed))
2536            `(%%max x y))
2537           ((and (csubtypep x-type unsigned)
2538                 (csubtypep y-type unsigned))
2539            `(%%max x y))
2540           ((and (csubtypep x-type d-float)
2541                 (csubtypep y-type d-float))
2542            `(%%max x y))
2543           ((and (csubtypep x-type s-float)
2544                 (csubtypep y-type s-float))
2545            `(%%max x y))
2546           (t
2547            (let ((arg1 (gensym))
2548                  (arg2 (gensym)))
2549              `(let ((,arg1 x)
2550                     (,arg2 y))
2551                (if (> ,arg1 ,arg2)
2552                    ,arg1 ,arg2)))))))
2553
2554 (deftransform min ((x y) (real real) * :when :both)
2555   (let ((x-type (continuation-type x))
2556         (y-type (continuation-type y))
2557         (signed (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
2558         (unsigned (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
2559         (d-float (specifier-type 'double-float))
2560         (s-float (specifier-type 'single-float)))
2561     (cond ((and (csubtypep x-type signed)
2562                 (csubtypep y-type signed))
2563            `(%%min x y))
2564           ((and (csubtypep x-type unsigned)
2565                 (csubtypep y-type unsigned))
2566            `(%%min x y))
2567           ((and (csubtypep x-type d-float)
2568                 (csubtypep y-type d-float))
2569            `(%%min x y))
2570           ((and (csubtypep x-type s-float)
2571                 (csubtypep y-type s-float))
2572            `(%%min x y))
2573           (t
2574            (let ((arg1 (gensym))
2575                  (arg2 (gensym)))
2576              `(let ((,arg1 x)
2577                     (,arg2 y))
2578                 (if (< ,arg1 ,arg2)
2579                     ,arg1 ,arg2)))))))
2580
2581 ) ; PROGN
2582