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