src/compiler/mips/float.lisp

   1 ;;;; the MIPS VM definition of floating point operations
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 \f
  15 ;;;; Move functions:
  16 (define-move-fun (load-single 1) (vop x y)
  17   ((single-stack) (single-reg))
  18   (inst lwc1 y (current-nfp-tn vop) (* (tn-offset x) n-word-bytes))
  19   (inst nop))
  20
  21 (define-move-fun (store-single 1) (vop x y)
  22   ((single-reg) (single-stack))
  23   (inst swc1 x (current-nfp-tn vop) (* (tn-offset y) n-word-bytes)))
  24
  25 (defun ld-double (r base offset)
  26   (ecase *backend-byte-order*
  27     (:big-endian
  28      (inst lwc1 r base (+ offset n-word-bytes))
  29      (inst lwc1-odd r base offset))
  30     (:little-endian
  31      (inst lwc1 r base offset)
  32      (inst lwc1-odd r base (+ offset n-word-bytes)))))
  33
  34 (define-move-fun (load-double 2) (vop x y)
  35   ((double-stack) (double-reg))
  36   (let ((nfp (current-nfp-tn vop))
  37         (offset (* (tn-offset x) n-word-bytes)))
  38     (ld-double y nfp offset))
  39   (inst nop))
  40
  41 (defun str-double (x base offset)
  42   (ecase *backend-byte-order*
  43     (:big-endian
  44      (inst swc1 x base (+ offset n-word-bytes))
  45      (inst swc1-odd x base offset))
  46     (:little-endian
  47      (inst swc1 x base offset)
  48      (inst swc1-odd x base (+ offset n-word-bytes)))))
  49
  50 (define-move-fun (store-double 2) (vop x y)
  51   ((double-reg) (double-stack))
  52   (let ((nfp (current-nfp-tn vop))
  53         (offset (* (tn-offset y) n-word-bytes)))
  54     (str-double x nfp offset)))
  55 \f
  56 ;;;; Move VOPs:
  57 (macrolet ((frob (vop sc format)
  58              `(progn
  59                 (define-vop (,vop)
  60                   (:args (x :scs (,sc)
  61                             :target y
  62                             :load-if (not (location= x y))))
  63                   (:results (y :scs (,sc)
  64                                :load-if (not (location= x y))))
  65                   (:note "float move")
  66                   (:generator 0
  67                     (unless (location= y x)
  68                       (inst fmove ,format y x))))
  69                 (define-move-vop ,vop :move (,sc) (,sc)))))
  70   (frob single-move single-reg :single)
  71   (frob double-move double-reg :double))
  72
  73 (define-vop (move-from-float)
  74   (:args (x :to :save))
  75   (:results (y))
  76   (:temporary (:scs (non-descriptor-reg)) ndescr)
  77   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
  78   (:variant-vars double-p size type data)
  79   (:note "float to pointer coercion")
  80   (:generator 13
  81     (with-fixed-allocation (y pa-flag ndescr type size nil)
  82       (if double-p
  83           (str-double x y (- (* data n-word-bytes) other-pointer-lowtag))
  84           (inst swc1 x y (- (* data n-word-bytes) other-pointer-lowtag))))))
  85
  86 (macrolet ((frob (name sc &rest args)
  87              `(progn
  88                 (define-vop (,name move-from-float)
  89                   (:args (x :scs (,sc) :to :save))
  90                   (:results (y :scs (descriptor-reg)))
  91                   (:variant ,@args))
  92                 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
  93   (frob move-from-single single-reg
  94     nil single-float-size single-float-widetag single-float-value-slot)
  95   (frob move-from-double double-reg
  96     t double-float-size double-float-widetag double-float-value-slot))
  97
  98 (macrolet ((frob (name sc double-p value)
  99              `(progn
 100                 (define-vop (,name)
 101                   (:args (x :scs (descriptor-reg)))
 102                   (:results (y :scs (,sc)))
 103                   (:note "pointer to float coercion")
 104                   (:generator 2
 105                     ,@(ecase *backend-byte-order*
 106                         (:big-endian
 107                          (cond
 108                           (double-p
 109                            `((inst lwc1 y x (- (* (1+ ,value) n-word-bytes)
 110                                                other-pointer-lowtag))
 111                              (inst lwc1-odd y x (- (* ,value n-word-bytes)
 112                                                    other-pointer-lowtag))))
 113                           (t
 114                            `((inst lwc1 y x (- (* ,value n-word-bytes)
 115                                                other-pointer-lowtag))))))
 116                         (:little-endian
 117                          `((inst lwc1 y x (- (* ,value n-word-bytes)
 118                                              other-pointer-lowtag))
 119                            ,@(when double-p
 120                                `((inst lwc1-odd y x
 121                                        (- (* (1+ ,value) n-word-bytes)
 122                                           other-pointer-lowtag)))))))
 123                     (inst nop)))
 124                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
 125   (frob move-to-single single-reg nil single-float-value-slot)
 126   (frob move-to-double double-reg t double-float-value-slot))
 127
 128 (macrolet ((frob (name sc stack-sc format double-p)
 129              `(progn
 130                 (define-vop (,name)
 131                   (:args (x :scs (,sc) :target y)
 132                          (nfp :scs (any-reg)
 133                               :load-if (not (sc-is y ,sc))))
 134                   (:results (y))
 135                   (:note "float argument move")
 136                   (:generator ,(if double-p 2 1)
 137                     (sc-case y
 138                       (,sc
 139                        (unless (location= x y)
 140                          (inst fmove ,format y x)))
 141                       (,stack-sc
 142                        (let ((offset (* (tn-offset y) n-word-bytes)))
 143                          ,@(ecase *backend-byte-order*
 144                              (:big-endian
 145                               (cond
 146                                (double-p
 147                                 '((inst swc1 x nfp (+ offset n-word-bytes))
 148                                   (inst swc1-odd x nfp offset)))
 149                                (t
 150                                 '((inst swc1 x nfp offset)))))
 151                              (:little-endian
 152                               `((inst swc1 x nfp offset)
 153                                 ,@(when double-p
 154                                     '((inst swc1-odd x nfp
 155                                             (+ offset n-word-bytes))))))))))))
 156                 (define-move-vop ,name :move-arg
 157                   (,sc descriptor-reg) (,sc)))))
 158   (frob move-single-float-arg single-reg single-stack :single nil)
 159   (frob move-double-float-arg double-reg double-stack :double t))
 160 \f
 161 ;;;; Complex float move functions
 162
 163 (defun complex-single-reg-real-tn (x)
 164   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 165                   :offset (tn-offset x)))
 166 (defun complex-single-reg-imag-tn (x)
 167   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 168                   :offset (+ (tn-offset x) 2)))
 169
 170 (defun complex-double-reg-real-tn (x)
 171   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 172                   :offset (tn-offset x)))
 173 (defun complex-double-reg-imag-tn (x)
 174   (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
 175                   :offset (+ (tn-offset x) 2)))
 176
 177 (define-move-fun (load-complex-single 2) (vop x y)
 178   ((complex-single-stack) (complex-single-reg))
 179   (let ((nfp (current-nfp-tn vop))
 180         (offset (* (tn-offset x) n-word-bytes)))
 181     (let ((real-tn (complex-single-reg-real-tn y)))
 182       (inst lwc1 real-tn nfp offset))
 183     (let ((imag-tn (complex-single-reg-imag-tn y)))
 184       (inst lwc1 imag-tn nfp (+ offset n-word-bytes))))
 185   (inst nop))
 186
 187 (define-move-fun (store-complex-single 2) (vop x y)
 188   ((complex-single-reg) (complex-single-stack))
 189   (let ((nfp (current-nfp-tn vop))
 190         (offset (* (tn-offset y) n-word-bytes)))
 191     (let ((real-tn (complex-single-reg-real-tn x)))
 192       (inst swc1 real-tn nfp offset))
 193     (let ((imag-tn (complex-single-reg-imag-tn x)))
 194       (inst swc1 imag-tn nfp (+ offset n-word-bytes)))))
 195
 196 (define-move-fun (load-complex-double 4) (vop x y)
 197   ((complex-double-stack) (complex-double-reg))
 198   (let ((nfp (current-nfp-tn vop))
 199         (offset (* (tn-offset x) n-word-bytes)))
 200     (let ((real-tn (complex-double-reg-real-tn y)))
 201       (ld-double real-tn nfp offset))
 202     (let ((imag-tn (complex-double-reg-imag-tn y)))
 203       (ld-double imag-tn nfp (+ offset (* 2 n-word-bytes))))
 204     (inst nop)))
 205
 206 (define-move-fun (store-complex-double 4) (vop x y)
 207   ((complex-double-reg) (complex-double-stack))
 208   (let ((nfp (current-nfp-tn vop))
 209         (offset (* (tn-offset y) n-word-bytes)))
 210     (let ((real-tn (complex-double-reg-real-tn x)))
 211       (str-double real-tn nfp offset))
 212     (let ((imag-tn (complex-double-reg-imag-tn x)))
 213       (str-double imag-tn nfp (+ offset (* 2 n-word-bytes))))))
 214
 215 ;;; Complex float register to register moves.
 216 (define-vop (complex-single-move)
 217   (:args (x :scs (complex-single-reg) :target y
 218             :load-if (not (location= x y))))
 219   (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
 220   (:note "complex single float move")
 221   (:generator 0
 222      (unless (location= x y)
 223        ;; Note the complex-float-regs are aligned to every second
 224        ;; float register so there is not need to worry about overlap.
 225        (let ((x-real (complex-single-reg-real-tn x))
 226              (y-real (complex-single-reg-real-tn y)))
 227          (inst fmove :single y-real x-real))
 228        (let ((x-imag (complex-single-reg-imag-tn x))
 229              (y-imag (complex-single-reg-imag-tn y)))
 230          (inst fmove :single y-imag x-imag)))))
 231 (define-move-vop complex-single-move :move
 232   (complex-single-reg) (complex-single-reg))
 233
 234 (define-vop (complex-double-move)
 235   (:args (x :scs (complex-double-reg)
 236             :target y :load-if (not (location= x y))))
 237   (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
 238   (:note "complex double float move")
 239   (:generator 0
 240      (unless (location= x y)
 241        ;; Note the complex-float-regs are aligned to every second
 242        ;; float register so there is not need to worry about overlap.
 243        (let ((x-real (complex-double-reg-real-tn x))
 244              (y-real (complex-double-reg-real-tn y)))
 245          (inst fmove :double y-real x-real))
 246        (let ((x-imag (complex-double-reg-imag-tn x))
 247              (y-imag (complex-double-reg-imag-tn y)))
 248          (inst fmove :double y-imag x-imag)))))
 249 (define-move-vop complex-double-move :move
 250   (complex-double-reg) (complex-double-reg))
 251
 252 ;;; Move from a complex float to a descriptor register allocating a
 253 ;;; new complex float object in the process.
 254 (define-vop (move-from-complex-single)
 255   (:args (x :scs (complex-single-reg) :to :save))
 256   (:results (y :scs (descriptor-reg)))
 257   (:temporary (:scs (non-descriptor-reg)) ndescr)
 258   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
 259   (:note "complex single float to pointer coercion")
 260   (:generator 13
 261     (with-fixed-allocation (y pa-flag ndescr complex-single-float-widetag
 262                               complex-single-float-size nil)
 263       (let ((real-tn (complex-single-reg-real-tn x)))
 264         (inst swc1 real-tn y (- (* complex-single-float-real-slot
 265                                    n-word-bytes)
 266                                 other-pointer-lowtag)))
 267       (let ((imag-tn (complex-single-reg-imag-tn x)))
 268         (inst swc1 imag-tn y (- (* complex-single-float-imag-slot
 269                                    n-word-bytes)
 270                                 other-pointer-lowtag))))))
 271 (define-move-vop move-from-complex-single :move
 272   (complex-single-reg) (descriptor-reg))
 273
 274 (define-vop (move-from-complex-double)
 275   (:args (x :scs (complex-double-reg) :to :save))
 276   (:results (y :scs (descriptor-reg)))
 277   (:temporary (:scs (non-descriptor-reg)) ndescr)
 278   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
 279   (:note "complex double float to pointer coercion")
 280   (:generator 13
 281     (with-fixed-allocation (y pa-flag ndescr complex-double-float-widetag
 282                               complex-double-float-size nil)
 283       (let ((real-tn (complex-double-reg-real-tn x)))
 284         (str-double real-tn y (- (* complex-double-float-real-slot
 285                                     n-word-bytes)
 286                                  other-pointer-lowtag)))
 287       (let ((imag-tn (complex-double-reg-imag-tn x)))
 288         (str-double imag-tn y (- (* complex-double-float-imag-slot
 289                                     n-word-bytes)
 290                                  other-pointer-lowtag))))))
 291 (define-move-vop move-from-complex-double :move
 292   (complex-double-reg) (descriptor-reg))
 293
 294 ;;; Move from a descriptor to a complex float register
 295 (define-vop (move-to-complex-single)
 296   (:args (x :scs (descriptor-reg)))
 297   (:results (y :scs (complex-single-reg)))
 298   (:note "pointer to complex float coercion")
 299   (:generator 2
 300     (let ((real-tn (complex-single-reg-real-tn y)))
 301       (inst lwc1 real-tn x (- (* complex-single-float-real-slot n-word-bytes)
 302                               other-pointer-lowtag)))
 303     (let ((imag-tn (complex-single-reg-imag-tn y)))
 304       (inst lwc1 imag-tn x (- (* complex-single-float-imag-slot n-word-bytes)
 305                               other-pointer-lowtag)))
 306     (inst nop)))
 307 (define-move-vop move-to-complex-single :move
 308   (descriptor-reg) (complex-single-reg))
 309
 310 (define-vop (move-to-complex-double)
 311   (:args (x :scs (descriptor-reg)))
 312   (:results (y :scs (complex-double-reg)))
 313   (:note "pointer to complex float coercion")
 314   (:generator 2
 315     (let ((real-tn (complex-double-reg-real-tn y)))
 316       (ld-double real-tn x (- (* complex-double-float-real-slot n-word-bytes)
 317                               other-pointer-lowtag)))
 318     (let ((imag-tn (complex-double-reg-imag-tn y)))
 319       (ld-double imag-tn x (- (* complex-double-float-imag-slot n-word-bytes)
 320                               other-pointer-lowtag)))
 321     (inst nop)))
 322 (define-move-vop move-to-complex-double :move
 323   (descriptor-reg) (complex-double-reg))
 324
 325 ;;; complex float MOVE-ARG VOP
 326 (define-vop (move-complex-single-float-arg)
 327   (:args (x :scs (complex-single-reg) :target y)
 328          (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
 329   (:results (y))
 330   (:note "complex single-float argument move")
 331   (:generator 1
 332     (sc-case y
 333       (complex-single-reg
 334        (unless (location= x y)
 335          (let ((x-real (complex-single-reg-real-tn x))
 336                (y-real (complex-single-reg-real-tn y)))
 337            (inst fmove :single y-real x-real))
 338          (let ((x-imag (complex-single-reg-imag-tn x))
 339                (y-imag (complex-single-reg-imag-tn y)))
 340            (inst fmove :single y-imag x-imag))))
 341       (complex-single-stack
 342        (let ((offset (* (tn-offset y) n-word-bytes)))
 343          (let ((real-tn (complex-single-reg-real-tn x)))
 344            (inst swc1 real-tn nfp offset))
 345          (let ((imag-tn (complex-single-reg-imag-tn x)))
 346            (inst swc1 imag-tn nfp (+ offset n-word-bytes))))))))
 347 (define-move-vop move-complex-single-float-arg :move-arg
 348   (complex-single-reg descriptor-reg) (complex-single-reg))
 349
 350 (define-vop (move-complex-double-float-arg)
 351   (:args (x :scs (complex-double-reg) :target y)
 352          (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
 353   (:results (y))
 354   (:note "complex double-float argument move")
 355   (:generator 2
 356     (sc-case y
 357       (complex-double-reg
 358        (unless (location= x y)
 359          (let ((x-real (complex-double-reg-real-tn x))
 360                (y-real (complex-double-reg-real-tn y)))
 361            (inst fmove :double y-real x-real))
 362          (let ((x-imag (complex-double-reg-imag-tn x))
 363                (y-imag (complex-double-reg-imag-tn y)))
 364            (inst fmove :double y-imag x-imag))))
 365       (complex-double-stack
 366        (let ((offset (* (tn-offset y) n-word-bytes)))
 367          (let ((real-tn (complex-double-reg-real-tn x)))
 368            (str-double real-tn nfp offset))
 369          (let ((imag-tn (complex-double-reg-imag-tn x)))
 370            (str-double imag-tn nfp (+ offset (* 2 n-word-bytes)))))))))
 371 (define-move-vop move-complex-double-float-arg :move-arg
 372   (complex-double-reg descriptor-reg) (complex-double-reg))
 373
 374 (define-move-vop move-arg :move-arg
 375   (single-reg double-reg complex-single-reg complex-double-reg)
 376   (descriptor-reg))
 377
 378 \f
 379 ;;;; stuff for c-call float-in-int-register arguments
 380 (define-vop (move-to-single-int-reg)
 381   (:args (x :scs (single-reg descriptor-reg)))
 382   (:results (y :scs (single-int-carg-reg) :load-if nil))
 383   (:note "pointer to float-in-int coercion")
 384   (:generator 1
 385     (sc-case x
 386       (single-reg
 387        (inst mfc1 y x))
 388       (descriptor-reg
 389        (inst lw y x (- (* single-float-value-slot n-word-bytes)
 390                        other-pointer-lowtag))))
 391     (inst nop)))                        ;nop needed here?
 392 (define-move-vop move-to-single-int-reg
 393     :move (single-reg descriptor-reg) (single-int-carg-reg))
 394
 395 (define-vop (move-single-int-reg)
 396   (:args (x :target y :scs (single-int-carg-reg) :load-if nil)
 397          (fp :scs (any-reg) :load-if (not (sc-is y single-int-carg-reg))))
 398   (:results (y :scs (single-int-carg-reg) :load-if nil))
 399   (:generator 1
 400     (unless (location= x y)
 401       (error "Huh? why did it do that?"))))
 402 (define-move-vop move-single-int-reg :move-arg
 403   (single-int-carg-reg) (single-int-carg-reg))
 404
 405 (define-vop (move-to-double-int-reg)
 406   (:args (x :scs (double-reg descriptor-reg)))
 407   (:results (y :scs (double-int-carg-reg) :load-if nil))
 408   (:note "pointer to float-in-int coercion")
 409   (:generator 2
 410     (sc-case x
 411       (double-reg
 412        (ecase *backend-byte-order*
 413          (:big-endian
 414           (inst mfc1-odd2 y x)
 415           (inst mfc1-odd y x))
 416          (:little-endian
 417           (inst mfc1 y x)
 418           (inst mfc1-odd3 y x))))
 419       (descriptor-reg
 420        (inst lw y x (- (* double-float-value-slot n-word-bytes)
 421                        other-pointer-lowtag))
 422        (inst lw-odd y x (- (* (1+ double-float-value-slot) n-word-bytes)
 423                            other-pointer-lowtag))))
 424     (inst nop)))                        ;nop needed here?
 425 (define-move-vop move-to-double-int-reg
 426     :move (double-reg descriptor-reg) (double-int-carg-reg))
 427
 428 (define-vop (move-double-int-reg)
 429   (:args (x :target y :scs (double-int-carg-reg) :load-if nil)
 430          (fp :scs (any-reg) :load-if (not (sc-is y double-int-carg-reg))))
 431   (:results (y :scs (double-int-carg-reg) :load-if nil))
 432   (:generator 2
 433     (unless (location= x y)
 434       (error "Huh? why did it do that?"))))
 435 (define-move-vop move-double-int-reg :move-arg
 436   (double-int-carg-reg) (double-int-carg-reg))
 437
 438 \f
 439 ;;;; Arithmetic VOPs:
 440
 441 (define-vop (float-op)
 442   (:args (x) (y))
 443   (:results (r))
 444   (:variant-vars format operation)
 445   (:policy :fast-safe)
 446   (:note "inline float arithmetic")
 447   (:vop-var vop)
 448   (:save-p :compute-only)
 449   (:generator 0
 450     (note-this-location vop :internal-error)
 451     (inst float-op operation format r x y)))
 452
 453 (macrolet ((frob (name sc ptype)
 454              `(define-vop (,name float-op)
 455                 (:args (x :scs (,sc))
 456                        (y :scs (,sc)))
 457                 (:results (r :scs (,sc)))
 458                 (:arg-types ,ptype ,ptype)
 459                 (:result-types ,ptype))))
 460   (frob single-float-op single-reg single-float)
 461   (frob double-float-op double-reg double-float))
 462
 463 (macrolet ((frob (op sname scost dname dcost)
 464              `(progn
 465                 (define-vop (,sname single-float-op)
 466                   (:translate ,op)
 467                   (:variant :single ',op)
 468                   (:variant-cost ,scost))
 469                 (define-vop (,dname double-float-op)
 470                   (:translate ,op)
 471                   (:variant :double ',op)
 472                   (:variant-cost ,dcost)))))
 473   (frob + +/single-float 2 +/double-float 2)
 474   (frob - -/single-float 2 -/double-float 2)
 475   (frob * */single-float 4 */double-float 5)
 476   (frob / //single-float 12 //double-float 19))
 477
 478 (macrolet ((frob (name inst translate format sc type)
 479              `(define-vop (,name)
 480                 (:args (x :scs (,sc)))
 481                 (:results (y :scs (,sc)))
 482                 (:translate ,translate)
 483                 (:policy :fast-safe)
 484                 (:arg-types ,type)
 485                 (:result-types ,type)
 486                 (:note "inline float arithmetic")
 487                 (:vop-var vop)
 488                 (:save-p :compute-only)
 489                 (:generator 1
 490                   (note-this-location vop :internal-error)
 491                   (inst ,inst ,format y x)))))
 492   (frob abs/single-float fabs abs :single single-reg single-float)
 493   (frob abs/double-float fabs abs :double double-reg double-float)
 494   (frob %negate/single-float fneg %negate :single single-reg single-float)
 495   (frob %negate/double-float fneg %negate :double double-reg double-float))
 496
 497 \f
 498 ;;;; Comparison:
 499
 500 (define-vop (float-compare)
 501   (:args (x) (y))
 502   (:conditional)
 503   (:info target not-p)
 504   (:variant-vars format operation complement)
 505   (:policy :fast-safe)
 506   (:note "inline float comparison")
 507   (:vop-var vop)
 508   (:save-p :compute-only)
 509   (:generator 3
 510     (note-this-location vop :internal-error)
 511     (inst fcmp operation format x y)
 512     (inst nop)
 513     (if (if complement (not not-p) not-p)
 514         (inst bc1f target)
 515         (inst bc1t target))
 516     (inst nop)))
 517
 518 (macrolet ((frob (name sc ptype)
 519              `(define-vop (,name float-compare)
 520                 (:args (x :scs (,sc))
 521                        (y :scs (,sc)))
 522                 (:arg-types ,ptype ,ptype))))
 523   (frob single-float-compare single-reg single-float)
 524   (frob double-float-compare double-reg double-float))
 525
 526 (macrolet ((frob (translate op complement sname dname)
 527              `(progn
 528                 (define-vop (,sname single-float-compare)
 529                   (:translate ,translate)
 530                   (:variant :single ,op ,complement))
 531                 (define-vop (,dname double-float-compare)
 532                   (:translate ,translate)
 533                   (:variant :double ,op ,complement)))))
 534   (frob < :lt nil </single-float </double-float)
 535   (frob > :ngt t >/single-float >/double-float)
 536   (frob = :seq nil =/single-float =/double-float))
 537
 538 \f
 539 ;;;; Conversion:
 540
 541 (macrolet ((frob (name translate
 542                        from-sc from-type from-format
 543                        to-sc to-type to-format)
 544              (let ((word-p (eq from-format :word)))
 545                `(define-vop (,name)
 546                   (:args (x :scs (,from-sc)))
 547                   (:results (y :scs (,to-sc)))
 548                   (:arg-types ,from-type)
 549                   (:result-types ,to-type)
 550                   (:policy :fast-safe)
 551                   (:note "inline float coercion")
 552                   (:translate ,translate)
 553                   (:vop-var vop)
 554                   (:save-p :compute-only)
 555                   (:generator ,(if word-p 3 2)
 556                     ,@(if word-p
 557                           `((inst mtc1 y x)
 558                             (inst nop)
 559                             (note-this-location vop :internal-error)
 560                             (inst fcvt ,to-format :word y y))
 561                           `((note-this-location vop :internal-error)
 562                             (inst fcvt ,to-format ,from-format y x))))))))
 563   (frob %single-float/signed %single-float
 564     signed-reg signed-num :word
 565     single-reg single-float :single)
 566   (frob %double-float/signed %double-float
 567     signed-reg signed-num :word
 568     double-reg double-float :double)
 569   (frob %single-float/double-float %single-float
 570     double-reg double-float :double
 571     single-reg single-float :single)
 572   (frob %double-float/single-float %double-float
 573     single-reg single-float :single
 574     double-reg double-float :double))
 575
 576
 577 (macrolet ((frob (name from-sc from-type from-format)
 578              `(define-vop (,name)
 579                 (:args (x :scs (,from-sc)))
 580                 (:results (y :scs (signed-reg)))
 581                 (:temporary (:from (:argument 0) :sc ,from-sc) temp)
 582                 (:arg-types ,from-type)
 583                 (:result-types signed-num)
 584                 (:translate %unary-round)
 585                 (:policy :fast-safe)
 586                 (:note "inline float round")
 587                 (:vop-var vop)
 588                 (:save-p :compute-only)
 589                 (:generator 3
 590                   (note-this-location vop :internal-error)
 591                   (inst fcvt :word ,from-format temp x)
 592                   (inst mfc1 y temp)
 593                   (inst nop)))))
 594   (frob %unary-round/single-float single-reg single-float :single)
 595   (frob %unary-round/double-float double-reg double-float :double))
 596
 597
 598 ;;; These VOPs have to uninterruptibly frob the rounding mode in order to get
 599 ;;; the desired round-to-zero behavior.
 600 ;;;
 601 (macrolet ((frob (name from-sc from-type from-format)
 602              `(define-vop (,name)
 603                 (:args (x :scs (,from-sc)))
 604                 (:results (y :scs (signed-reg)))
 605                 (:temporary (:from (:argument 0) :sc ,from-sc) temp)
 606                 (:temporary (:sc non-descriptor-reg) status-save new-status)
 607                 (:temporary (:sc non-descriptor-reg :offset nl4-offset)
 608                             pa-flag)
 609                 (:arg-types ,from-type)
 610                 (:result-types signed-num)
 611                 (:translate %unary-truncate)
 612                 (:policy :fast-safe)
 613                 (:note "inline float truncate")
 614                 (:vop-var vop)
 615                 (:save-p :compute-only)
 616                 (:generator 16
 617                   (pseudo-atomic (pa-flag)
 618                     (inst cfc1 status-save 31)
 619                     (inst li new-status (lognot 3))
 620                     (inst and new-status status-save)
 621                     (inst or new-status float-round-to-zero)
 622                     (inst ctc1 new-status 31)
 623
 624                     ;; These instructions seem to be necessary to ensure that
 625                     ;; the new modes affect the fcvt instruction.
 626                     (inst nop)
 627                     (inst cfc1 new-status 31)
 628
 629                     (note-this-location vop :internal-error)
 630                     (inst fcvt :word ,from-format temp x)
 631                     (inst mfc1 y temp)
 632                     (inst nop)
 633                     (inst ctc1 status-save 31))))))
 634   (frob %unary-truncate/single-float single-reg single-float :single)
 635   (frob %unary-truncate/double-float double-reg double-float :double))
 636
 637
 638 (define-vop (make-single-float)
 639   (:args (bits :scs (signed-reg)))
 640   (:results (res :scs (single-reg)))
 641   (:arg-types signed-num)
 642   (:result-types single-float)
 643   (:translate make-single-float)
 644   (:policy :fast-safe)
 645   (:generator 2
 646     (inst mtc1 res bits)
 647     (inst nop)))
 648
 649 (define-vop (make-double-float)
 650   (:args (hi-bits :scs (signed-reg))
 651          (lo-bits :scs (unsigned-reg)))
 652   (:results (res :scs (double-reg)))
 653   (:arg-types signed-num unsigned-num)
 654   (:result-types double-float)
 655   (:translate make-double-float)
 656   (:policy :fast-safe)
 657   (:generator 2
 658     (inst mtc1 res lo-bits)
 659     (inst mtc1-odd res hi-bits)
 660     (inst nop)))
 661
 662 (define-vop (single-float-bits)
 663   (:args (float :scs (single-reg)))
 664   (:results (bits :scs (signed-reg)))
 665   (:arg-types single-float)
 666   (:result-types signed-num)
 667   (:translate single-float-bits)
 668   (:policy :fast-safe)
 669   (:generator 2
 670     (inst mfc1 bits float)
 671     (inst nop)))
 672
 673 (define-vop (double-float-high-bits)
 674   (:args (float :scs (double-reg)))
 675   (:results (hi-bits :scs (signed-reg)))
 676   (:arg-types double-float)
 677   (:result-types signed-num)
 678   (:translate double-float-high-bits)
 679   (:policy :fast-safe)
 680   (:generator 2
 681     (inst mfc1-odd hi-bits float)
 682     (inst nop)))
 683
 684 (define-vop (double-float-low-bits)
 685   (:args (float :scs (double-reg)))
 686   (:results (lo-bits :scs (unsigned-reg)))
 687   (:arg-types double-float)
 688   (:result-types unsigned-num)
 689   (:translate double-float-low-bits)
 690   (:policy :fast-safe)
 691   (:generator 2
 692     (inst mfc1 lo-bits float)
 693     (inst nop)))
 694
 695 \f
 696 ;;;; Complex float VOPs
 697
 698 (define-vop (make-complex-single-float)
 699   (:translate complex)
 700   (:args (real :scs (single-reg) :target r)
 701          (imag :scs (single-reg) :to :save))
 702   (:arg-types single-float single-float)
 703   (:results (r :scs (complex-single-reg) :from (:argument 0)
 704                :load-if (not (sc-is r complex-single-stack))))
 705   (:result-types complex-single-float)
 706   (:note "inline complex single-float creation")
 707   (:policy :fast-safe)
 708   (:vop-var vop)
 709   (:generator 5
 710     (sc-case r
 711       (complex-single-reg
 712        (let ((r-real (complex-single-reg-real-tn r)))
 713          (unless (location= real r-real)
 714            (inst fmove :single r-real real)))
 715        (let ((r-imag (complex-single-reg-imag-tn r)))
 716          (unless (location= imag r-imag)
 717            (inst fmove :single r-imag imag))))
 718       (complex-single-stack
 719        (let ((nfp (current-nfp-tn vop))
 720              (offset (* (tn-offset r) n-word-bytes)))
 721          (inst swc1 real nfp offset)
 722          (inst swc1 imag nfp (+ offset n-word-bytes)))))))
 723
 724 (define-vop (make-complex-double-float)
 725   (:translate complex)
 726   (:args (real :scs (double-reg) :target r)
 727          (imag :scs (double-reg) :to :save))
 728   (:arg-types double-float double-float)
 729   (:results (r :scs (complex-double-reg) :from (:argument 0)
 730                :load-if (not (sc-is r complex-double-stack))))
 731   (:result-types complex-double-float)
 732   (:note "inline complex double-float creation")
 733   (:policy :fast-safe)
 734   (:vop-var vop)
 735   (:generator 5
 736     (sc-case r
 737       (complex-double-reg
 738        (let ((r-real (complex-double-reg-real-tn r)))
 739          (unless (location= real r-real)
 740            (inst fmove :double r-real real)))
 741        (let ((r-imag (complex-double-reg-imag-tn r)))
 742          (unless (location= imag r-imag)
 743            (inst fmove :double r-imag imag))))
 744       (complex-double-stack
 745        (let ((nfp (current-nfp-tn vop))
 746              (offset (* (tn-offset r) n-word-bytes)))
 747          (str-double real nfp offset)
 748          (str-double imag nfp (+ offset (* 2 n-word-bytes))))))))
 749
 750
 751 (define-vop (complex-single-float-value)
 752   (:args (x :scs (complex-single-reg) :target r
 753             :load-if (not (sc-is x complex-single-stack))))
 754   (:arg-types complex-single-float)
 755   (:results (r :scs (single-reg)))
 756   (:result-types single-float)
 757   (:variant-vars slot)
 758   (:policy :fast-safe)
 759   (:vop-var vop)
 760   (:generator 3
 761     (sc-case x
 762       (complex-single-reg
 763        (let ((value-tn (ecase slot
 764                          (:real (complex-single-reg-real-tn x))
 765                          (:imag (complex-single-reg-imag-tn x)))))
 766          (unless (location= value-tn r)
 767            (inst fmove :single r value-tn))))
 768       (complex-single-stack
 769        (inst lwc1 r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 1))
 770                                                (tn-offset x))
 771                                             n-word-bytes))
 772        (inst nop)))))
 773
 774 (define-vop (realpart/complex-single-float complex-single-float-value)
 775   (:translate realpart)
 776   (:note "complex single float realpart")
 777   (:variant :real))
 778
 779 (define-vop (imagpart/complex-single-float complex-single-float-value)
 780   (:translate imagpart)
 781   (:note "complex single float imagpart")
 782   (:variant :imag))
 783
 784 (define-vop (complex-double-float-value)
 785   (:args (x :scs (complex-double-reg) :target r
 786             :load-if (not (sc-is x complex-double-stack))))
 787   (:arg-types complex-double-float)
 788   (:results (r :scs (double-reg)))
 789   (:result-types double-float)
 790   (:variant-vars slot)
 791   (:policy :fast-safe)
 792   (:vop-var vop)
 793   (:generator 3
 794     (sc-case x
 795       (complex-double-reg
 796        (let ((value-tn (ecase slot
 797                          (:real (complex-double-reg-real-tn x))
 798                          (:imag (complex-double-reg-imag-tn x)))))
 799          (unless (location= value-tn r)
 800            (inst fmove :double r value-tn))))
 801       (complex-double-stack
 802        (ld-double r (current-nfp-tn vop) (* (+ (ecase slot (:real 0) (:imag 2))
 803                                                (tn-offset x))
 804                                             n-word-bytes))
 805        (inst nop)))))
 806
 807 (define-vop (realpart/complex-double-float complex-double-float-value)
 808   (:translate realpart)
 809   (:note "complex double float realpart")
 810   (:variant :real))
 811
 812 (define-vop (imagpart/complex-double-float complex-double-float-value)
 813   (:translate imagpart)
 814   (:note "complex double float imagpart")
 815   (:variant :imag))