src/compiler/hppa/float.lisp

   1 ;;;; the HPPA 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 \f
  14 ;;;; Move functions.
  15 (define-move-fun (load-fp-zero 1) (vop x y)
  16   ((fp-single-zero) (single-reg)
  17    (fp-double-zero) (double-reg))
  18   (inst funop :copy x y))
  19
  20 (defun ld-float (offset base r)
  21   (cond ((< offset (ash 1 4))
  22          (inst flds offset base r))
  23         ((and (< offset (ash 1 13))
  24               (> offset 0))
  25          (inst ldo offset zero-tn lip-tn)
  26          (inst fldx lip-tn base r))
  27         (t
  28           (error "ld-float: bad offset: ~s~%" offset))))
  29
  30 (define-move-fun (load-float 1) (vop x y)
  31   ((single-stack) (single-reg)
  32    (double-stack) (double-reg))
  33   (let ((offset (* (tn-offset x) n-word-bytes)))
  34     (ld-float offset (current-nfp-tn vop) y)))
  35
  36 (defun str-float (x offset base)
  37   (cond ((< offset (ash 1 4))
  38          ;(note-next-instruction vop :internal-error)
  39          (inst fsts x offset base))
  40         ((and (< offset (ash 1 13))
  41               (> offset 0))
  42          ;; FIXME-lav, ok with GC to use lip-tn for arbitrary offsets ?
  43          (inst ldo offset zero-tn lip-tn)
  44          ;(note-next-instruction vop :internal-error)
  45          (inst fstx x lip-tn base))
  46         (t
  47           (error "str-float: bad offset: ~s~%" offset))))
  48
  49 (define-move-fun (store-float 1) (vop x y)
  50   ((single-reg) (single-stack)
  51    (double-reg) (double-stack))
  52   (let ((offset (* (tn-offset y) n-word-bytes)))
  53     (str-float x offset (current-nfp-tn vop))))
  54 \f
  55 ;;;; Move VOPs
  56 (define-vop (move-float)
  57   (:args (x :scs (single-reg double-reg)
  58             :target y
  59             :load-if (not (location= x y))))
  60   (:results (y :scs (single-reg double-reg)
  61                :load-if (not (location= x y))))
  62   (:note "float move")
  63   (:generator 0
  64     (unless (location= y x)
  65       (inst funop :copy x y))))
  66 (define-move-vop move-float :move (single-reg) (single-reg))
  67 (define-move-vop move-float :move (double-reg) (double-reg))
  68
  69 (define-vop (move-from-float)
  70   (:args (x :to :save))
  71   (:results (y :scs (descriptor-reg)))
  72   (:temporary (:scs (non-descriptor-reg)) ndescr)
  73   (:variant-vars size type data)
  74   (:note "float to pointer coercion")
  75   (:generator 13
  76     (with-fixed-allocation (y nil ndescr type size nil)
  77       nil)
  78     (inst fsts x (- (* data n-word-bytes) other-pointer-lowtag) y)))
  79
  80 (macrolet ((frob (name sc &rest args)
  81              `(progn
  82                 (define-vop (,name move-from-float)
  83                   (:args (x :scs (,sc) :to :save))
  84                   (:variant ,@args))
  85                 (define-move-vop ,name :move (,sc) (descriptor-reg)))))
  86   (frob move-from-single single-reg
  87     single-float-size single-float-widetag single-float-value-slot)
  88   (frob move-from-double double-reg
  89     double-float-size double-float-widetag double-float-value-slot))
  90
  91 (define-vop (move-to-float)
  92   (:args (x :scs (descriptor-reg)))
  93   (:results (y))
  94   (:variant-vars offset)
  95   (:note "pointer to float coercion")
  96   (:generator 2
  97     (inst flds (- (* offset n-word-bytes) other-pointer-lowtag) x y)))
  98
  99 (macrolet ((frob (name sc offset)
 100              `(progn
 101                 (define-vop (,name move-to-float)
 102                   (:results (y :scs (,sc)))
 103                   (:variant ,offset))
 104                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
 105   (frob move-to-single single-reg single-float-value-slot)
 106   (frob move-to-double double-reg double-float-value-slot))
 107
 108 (define-vop (move-float-arg)
 109   (:args (x :scs (single-reg double-reg) :target y)
 110          (nfp :scs (any-reg)
 111               :load-if (not (sc-is y single-reg double-reg))))
 112   (:results (y))
 113   (:note "float argument move")
 114   (:generator 1
 115     (sc-case y
 116       ((single-reg double-reg)
 117        (unless (location= x y)
 118          (inst funop :copy x y)))
 119       ((single-stack double-stack)
 120        (let ((offset (* (tn-offset y) n-word-bytes)))
 121          (str-float x offset nfp))))))
 122 (define-move-vop move-float-arg :move-arg
 123   (single-reg descriptor-reg) (single-reg))
 124 (define-move-vop move-float-arg :move-arg
 125   (double-reg descriptor-reg) (double-reg))
 126 \f
 127 ;;;; Complex float move functions
 128 (defun complex-single-reg-real-tn (x)
 129   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 130                   :offset (tn-offset x)))
 131 (defun complex-single-reg-imag-tn (x)
 132   (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
 133                   :offset (1+ (tn-offset x))))
 134
 135 (defun complex-double-reg-real-tn (x)
 136   (make-random-tn :kind :normal :sc (sc-or-lose 'complex-double-reg)
 137                   :offset (tn-offset x)))
 138 (defun complex-double-reg-imag-tn (x)
 139   (make-random-tn :kind :normal :sc (sc-or-lose 'complex-double-reg)
 140                   :offset (1+ (tn-offset x))))
 141
 142 (macrolet
 143   ((def-move-fun (dir type size from to)
 144      `(define-move-fun (,(symbolicate dir "-" type) ,size) (vop x y)
 145         ((,(symbolicate type "-" from)) (,(symbolicate type "-" to)))
 146         (let ((nfp (current-nfp-tn vop))
 147               (offset (* (tn-offset ,(if (eq dir 'load) 'x 'y)) n-word-bytes)))
 148           ,@(if (eq dir 'load)
 149               `((let ((real-tn (,(symbolicate type "-REG-REAL-TN") y)))
 150                   (ld-float offset nfp real-tn))
 151                 (let ((imag-tn (,(symbolicate type "-REG-IMAG-TN") y)))
 152                   (ld-float (+ offset (* ,(/ size 2) n-word-bytes)) nfp imag-tn)))
 153               `((let ((real-tn (,(symbolicate type "-REG-REAL-TN") x)))
 154                   (str-float real-tn offset nfp))
 155                 (let ((imag-tn (,(symbolicate type "-REG-IMAG-TN") x)))
 156                   (str-float imag-tn
 157                              (+ offset (* ,(/ size 2) n-word-bytes))
 158                              nfp))))))))
 159   (def-move-fun load  complex-single 2 stack reg)
 160   (def-move-fun store complex-single 2 reg stack)
 161   (def-move-fun load  complex-double 4 stack reg)
 162   (def-move-fun store complex-double 4 reg stack))
 163
 164 ;;; Complex float register to register moves.
 165 (define-vop (complex-single-move)
 166   (:args (x :scs (complex-single-reg) :target y
 167             :load-if (not (location= x y))))
 168   (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
 169   (:note "complex single float move")
 170   (:generator 0
 171      (unless (location= x y)
 172        ;; Note the complex-float-regs are aligned to every second
 173        ;; float register so there is not need to worry about overlap.
 174        (let ((x-real (complex-single-reg-real-tn x))
 175              (y-real (complex-single-reg-real-tn y)))
 176          (inst funop :copy x-real y-real))
 177        (let ((x-imag (complex-single-reg-imag-tn x))
 178              (y-imag (complex-single-reg-imag-tn y)))
 179          (inst funop :copy x-imag y-imag)))))
 180 (define-move-vop complex-single-move :move
 181   (complex-single-reg) (complex-single-reg))
 182
 183 (define-vop (complex-double-move)
 184   (:args (x :scs (complex-double-reg)
 185             :target y :load-if (not (location= x y))))
 186   (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
 187   (:note "complex double float move")
 188   (:generator 0
 189      (unless (location= x y)
 190        ;; Note the complex-float-regs are aligned to every second
 191        ;; float register so there is not need to worry about overlap.
 192        (let ((x-real (complex-double-reg-real-tn x))
 193              (y-real (complex-double-reg-real-tn y)))
 194          (inst funop :copy x-real y-real))
 195        (let ((x-imag (complex-double-reg-imag-tn x))
 196              (y-imag (complex-double-reg-imag-tn y)))
 197          (inst funop :copy x-imag y-imag)))))
 198 (define-move-vop complex-double-move :move
 199   (complex-double-reg) (complex-double-reg))
 200
 201 ;;; Move from a complex float to a descriptor register allocating a
 202 ;;; new complex float object in the process.
 203 (define-vop (move-from-complex-single)
 204   (:args (x :scs (complex-single-reg) :to :save))
 205   (:results (y :scs (descriptor-reg)))
 206   (:temporary (:scs (non-descriptor-reg)) ndescr)
 207   (:note "complex single float to pointer coercion")
 208   (:generator 13
 209      (with-fixed-allocation (y nil ndescr complex-single-float-widetag
 210                                complex-single-float-size nil)
 211        nil)
 212      (let ((real-tn (complex-single-reg-real-tn x)))
 213        (inst fsts real-tn (- (* complex-single-float-real-slot n-word-bytes)
 214                              other-pointer-lowtag) y))
 215      (let ((imag-tn (complex-single-reg-imag-tn x)))
 216        (inst fsts imag-tn (- (* complex-single-float-imag-slot n-word-bytes)
 217                              other-pointer-lowtag) y))))
 218 (define-move-vop move-from-complex-single :move
 219   (complex-single-reg) (descriptor-reg))
 220
 221 (define-vop (move-from-complex-double)
 222   (:args (x :scs (complex-double-reg) :to :save))
 223   (:results (y :scs (descriptor-reg)))
 224   (:temporary (:scs (non-descriptor-reg)) ndescr)
 225   (:note "complex double float to pointer coercion")
 226   (:generator 13
 227      (with-fixed-allocation (y nil ndescr complex-double-float-widetag
 228                                complex-double-float-size nil)
 229        nil)
 230      (let ((real-tn (complex-double-reg-real-tn x)))
 231        (inst fsts real-tn (- (* complex-double-float-real-slot n-word-bytes)
 232                              other-pointer-lowtag) y))
 233      (let ((imag-tn (complex-double-reg-imag-tn x)))
 234        (inst fsts imag-tn (- (* complex-double-float-imag-slot n-word-bytes)
 235                              other-pointer-lowtag) y))))
 236 (define-move-vop move-from-complex-double :move
 237   (complex-double-reg) (descriptor-reg))
 238
 239 ;;; Move from a descriptor to a complex float register
 240 (define-vop (move-to-complex-single)
 241   (:args (x :scs (descriptor-reg)))
 242   (:results (y :scs (complex-single-reg)))
 243   (:note "pointer to complex float coercion")
 244   (:generator 2
 245     (let ((real-tn (complex-single-reg-real-tn y)))
 246       (inst flds (- (* complex-single-float-real-slot n-word-bytes)
 247                     other-pointer-lowtag)
 248                  x real-tn))
 249     (let ((imag-tn (complex-single-reg-imag-tn y)))
 250       (inst flds (- (* complex-single-float-imag-slot n-word-bytes)
 251                     other-pointer-lowtag)
 252                  x imag-tn))))
 253 (define-move-vop move-to-complex-single :move
 254   (descriptor-reg) (complex-single-reg))
 255
 256 (define-vop (move-to-complex-double)
 257   (:args (x :scs (descriptor-reg)))
 258   (:results (y :scs (complex-double-reg)))
 259   (:note "pointer to complex float coercion")
 260   (:generator 2
 261     (let ((real-tn (complex-double-reg-real-tn y)))
 262       (inst flds (- (* complex-double-float-real-slot n-word-bytes)
 263                     other-pointer-lowtag)
 264             x real-tn))
 265     (let ((imag-tn (complex-double-reg-imag-tn y)))
 266       (inst flds (- (* complex-double-float-imag-slot n-word-bytes)
 267                     other-pointer-lowtag)
 268             x imag-tn))))
 269 (define-move-vop move-to-complex-double :move
 270   (descriptor-reg) (complex-double-reg))
 271
 272 ;;; Complex float move-arg vop
 273 (define-vop (move-complex-single-float-arg)
 274   (:args (x :scs (complex-single-reg) :target y)
 275          (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
 276   (:results (y))
 277   (:note "float argument move")
 278   (:generator 1
 279     (sc-case y
 280       (complex-single-reg
 281        (unless (location= x y)
 282          (let ((x-real (complex-single-reg-real-tn x))
 283                (y-real (complex-single-reg-real-tn y)))
 284            (inst funop :copy x-real y-real))
 285          (let ((x-imag (complex-single-reg-imag-tn x))
 286                (y-imag (complex-single-reg-imag-tn y)))
 287            (inst funop :copy x-imag y-imag))))
 288       (complex-single-stack
 289        (let ((offset (* (tn-offset y) n-word-bytes)))
 290          (let ((real-tn (complex-single-reg-real-tn x)))
 291            (str-float real-tn offset nfp))
 292          (let ((imag-tn (complex-single-reg-imag-tn x)))
 293            (str-float imag-tn (+ offset n-word-bytes) nfp)))))))
 294 (define-move-vop move-complex-single-float-arg :move-arg
 295   (complex-single-reg descriptor-reg) (complex-single-reg))
 296
 297 (define-vop (move-complex-double-float-arg)
 298   (:args (x :scs (complex-double-reg) :target y)
 299          (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
 300   (:results (y))
 301   (:note "float argument move")
 302   (:generator 1
 303     (sc-case y
 304       (complex-double-reg
 305        (unless (location= x y)
 306          (let ((x-real (complex-double-reg-real-tn x))
 307                (y-real (complex-double-reg-real-tn y)))
 308            (inst funop :copy x-real y-real))
 309          (let ((x-imag (complex-double-reg-imag-tn x))
 310                (y-imag (complex-double-reg-imag-tn y)))
 311            (inst funop :copy x-imag y-imag))))
 312       (complex-double-stack
 313        (let ((offset (* (tn-offset y) n-word-bytes)))
 314          (let ((real-tn (complex-double-reg-real-tn x)))
 315            (str-float real-tn offset nfp))
 316          (let ((imag-tn (complex-double-reg-imag-tn x)))
 317            (str-float imag-tn (+ offset (* 2 n-word-bytes)) nfp)))))))
 318 (define-move-vop move-complex-double-float-arg :move-arg
 319   (complex-double-reg descriptor-reg) (complex-double-reg))
 320
 321 (define-move-vop move-arg :move-arg
 322   (single-reg double-reg complex-single-reg complex-double-reg)
 323   (descriptor-reg))
 324 \f
 325 ;;;; stuff for c-call float-in-int-register arguments
 326 (define-vop (move-to-single-int-reg)
 327   (:note "pointer to float-in-int coercion")
 328   (:args (x :scs (single-reg descriptor-reg)))
 329   (:results (y :scs (single-int-carg-reg) :load-if nil))
 330   (:generator 1
 331     (sc-case x
 332       (single-reg
 333         (inst funop :copy x y))
 334       (descriptor-reg
 335         (inst ldw (- (* single-float-value-slot n-word-bytes)
 336                      other-pointer-lowtag) x y)))))
 337 (define-move-vop move-to-single-int-reg
 338   :move (single-reg descriptor-reg) (single-int-carg-reg))
 339
 340 (define-vop (move-single-int-reg)
 341   (:args (x :target y :scs (single-int-carg-reg) :load-if nil)
 342          (fp :scs (any-reg) :load-if (not (sc-is y single-int-carg-reg))))
 343   (:results (y :scs (single-int-carg-reg) :load-if nil))
 344   (:generator 1
 345     (unless (location= x y)
 346       (error "Huh? why did it do that?"))))
 347 (define-move-vop move-single-int-reg :move-arg
 348   (single-int-carg-reg) (single-int-carg-reg))
 349
 350 ; move contents of float register x to register y
 351 (define-vop (move-to-double-int-reg)
 352   (:note "pointer to float-in-int coercion")
 353   (:args (x :scs (double-reg descriptor-reg)))
 354   (:results (y :scs (double-int-carg-reg) :load-if nil))
 355   (:temporary (:scs (signed-stack) :to (:result 0)) temp)
 356   (:temporary (:scs (signed-reg) :to (:result 0) :target y) old1)
 357   (:temporary (:scs (signed-reg) :to (:result 0) :target y) old2)
 358   (:vop-var vop)
 359   (:save-p :compute-only)
 360   (:generator 2
 361     (sc-case x
 362       (double-reg
 363         (let* ((nfp (current-nfp-tn vop))
 364                (stack-tn (sc-case y
 365                            (double-stack y)
 366                            (double-int-carg-reg temp)))
 367                (offset (* (tn-offset stack-tn) n-word-bytes)))
 368           ;; save 8 bytes of stack to two register,
 369           ;; write down float in stack and load it back
 370           ;; into result register. Notice the result hack,
 371           ;; we are writing to one extra register.
 372           ;; Double float argument convention uses two registers,
 373           ;; but we only know about one (thanks to c-call).
 374           (inst ldw offset nfp old1)
 375           (inst ldw (+ offset n-word-bytes) nfp old2)
 376           (str-float x offset nfp) ; writes 8 bytes
 377           (inst ldw offset nfp y)
 378           (inst ldw (+ offset n-word-bytes) nfp
 379                 (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
 380                                (sc-number-or-lose 'unsigned-reg)
 381                                (+ 1 (tn-offset y))))
 382           (inst stw old1 offset nfp)
 383           (inst stw old2 (+ offset n-word-bytes) nfp)))
 384       (descriptor-reg
 385         (inst ldw (- (* double-float-value-slot n-word-bytes)
 386                      other-pointer-lowtag) x y)
 387         (inst ldw (- (* (1+ double-float-value-slot) n-word-bytes)
 388                      other-pointer-lowtag) x
 389                   (make-wired-tn (primitive-type-or-lose 'unsigned-byte-32)
 390                                  (sc-number-or-lose 'unsigned-reg)
 391                                  (+ 1 (tn-offset y))))))))
 392 (define-move-vop move-to-double-int-reg
 393   :move (double-reg descriptor-reg) (double-int-carg-reg))
 394
 395 (define-vop (move-double-int-reg)
 396   (:args (x :target y :scs (double-int-carg-reg) :load-if nil)
 397          (fp :scs (any-reg) :load-if (not (sc-is y double-int-carg-reg))))
 398   (:results (y :scs (double-int-carg-reg) :load-if nil))
 399   (:generator 2
 400     (unless (location= x y)
 401       (error "Huh? why did it do that?"))))
 402 (define-move-vop move-double-int-reg :move-arg
 403   (double-int-carg-reg) (double-int-carg-reg))
 404
 405 ;;;; Arithmetic VOPs.
 406
 407 (define-vop (float-op)
 408   (:args (x) (y))
 409   (:results (r))
 410   (:variant-vars operation)
 411   (:policy :fast-safe)
 412   (:note "inline float arithmetic")
 413   (:vop-var vop)
 414   (:save-p :compute-only)
 415   (:generator 0
 416     (note-this-location vop :internal-error)
 417     (inst fbinop operation x y r)))
 418
 419 (macrolet ((frob (name sc zero-sc ptype)
 420              `(define-vop (,name float-op)
 421                 (:args (x :scs (,sc ,zero-sc))
 422                        (y :scs (,sc ,zero-sc)))
 423                 (:results (r :scs (,sc)))
 424                 (:arg-types ,ptype ,ptype)
 425                 (:result-types ,ptype))))
 426   (frob single-float-op single-reg fp-single-zero single-float)
 427   (frob double-float-op double-reg fp-double-zero double-float))
 428
 429 (macrolet ((frob (translate op sname scost dname dcost)
 430              `(progn
 431                 (define-vop (,sname single-float-op)
 432                   (:translate ,translate)
 433                   (:variant ,op)
 434                   (:variant-cost ,scost))
 435                 (define-vop (,dname double-float-op)
 436                   (:translate ,translate)
 437                   (:variant ,op)
 438                   (:variant-cost ,dcost)))))
 439   (frob + :add +/single-float 2 +/double-float 2)
 440   (frob - :sub -/single-float 2 -/double-float 2)
 441   (frob * :mpy */single-float 4 */double-float 5)
 442   (frob / :div //single-float 12 //double-float 19))
 443
 444 (macrolet ((frob (name translate sc type inst)
 445              `(define-vop (,name)
 446                 (:args (x :scs (,sc)))
 447                 (:results (y :scs (,sc)))
 448                 (:translate ,translate)
 449                 (:policy :fast-safe)
 450                 (:arg-types ,type)
 451                 (:result-types ,type)
 452                 (:note "inline float arithmetic")
 453                 (:vop-var vop)
 454                 (:save-p :compute-only)
 455                 (:generator 1
 456                   (note-this-location vop :internal-error)
 457                   ,inst))))
 458   (frob abs/single-float abs single-reg single-float
 459     (inst funop :abs x y))
 460   (frob abs/double-float abs double-reg double-float
 461     (inst funop :abs x y)))
 462
 463 (macrolet ((frob (name translate sc type zero-tn)
 464              `(define-vop (,name)
 465                 (:args (x :scs (,sc)))
 466                 (:results (y :scs (,sc)))
 467                 (:temporary (:scs (,sc)) float-temp)
 468                 (:temporary (:scs (signed-reg)) reg-temp)
 469                 (:temporary (:scs (signed-stack)) stack-temp)
 470                 (:translate ,translate)
 471                 (:policy :fast-safe)
 472                 (:arg-types ,type)
 473                 (:result-types ,type)
 474                 (:note "inline float arithmetic")
 475                 (:vop-var vop)
 476                 (:save-p :compute-only)
 477                 (:generator 1
 478                   (note-this-location vop :internal-error)
 479                   ;; KLUDGE: Subtracting the input from zero fails to
 480                   ;; produce negative zero from positive zero.
 481                   ;; Multiplying by -1 causes overflow conditions on
 482                   ;; some inputs.  The FNEG instruction is available
 483                   ;; in PA-RISC 2.0 only, and we're supposed to be
 484                   ;; PA-RISC 1.1 compatible.  To do the negation as an
 485                   ;; integer operation requires writing out the value
 486                   ;; (or its high bits) to memory, reading them up
 487                   ;; into a non-descriptor-reg, flipping the sign bit
 488                   ;; (most likely requiring another unsigned-reg to
 489                   ;; hold a constant to XOR with), then getting the
 490                   ;; result back to the FPU via memory again.  So
 491                   ;; instead we test for zeroness explicitly and
 492                   ;; decide which of the two FPU-based strategies to
 493                   ;; use.  I feel unclean for having implemented this,
 494                   ;; but it seems to be the least dreadful option.
 495                   ;; Help?  -- AB, 2015-11-26
 496                   (inst fcmp #b00111 x ,zero-tn)
 497                   (inst ftest)
 498                   (inst b SUBTRACT-FROM-ZERO :nullify t)
 499
 500                   MULTIPLY-BY-NEGATIVE-ONE
 501                   (let ((nfp (current-nfp-tn vop))
 502                         (short-float-temp (make-random-tn :kind :normal
 503                                                           :sc (sc-or-lose 'single-reg)
 504                                                           :offset (tn-offset reg-temp))))
 505                     (inst li -1 reg-temp)
 506                     (storew reg-temp nfp (tn-offset stack-temp))
 507                     (ld-float (* (tn-offset stack-temp) n-word-bytes) nfp short-float-temp)
 508                     (inst fcnvxf short-float-temp float-temp)
 509                     (inst fbinop :mpy x float-temp y))
 510                   (inst b DONE :nullify t)
 511
 512                   SUBTRACT-FROM-ZERO
 513                   (inst fbinop :sub ,zero-tn x y)
 514
 515                   DONE))))
 516   (frob %negate/single-float %negate single-reg single-float fp-single-zero-tn)
 517   (frob %negate/double-float %negate double-reg double-float fp-double-zero-tn))
 518 \f
 519 ;;;; Comparison:
 520
 521 (define-vop (float-compare)
 522   (:args (x) (y))
 523   (:conditional)
 524   (:info target not-p)
 525   (:variant-vars condition complement)
 526   (:policy :fast-safe)
 527   (:note "inline float comparison")
 528   (:vop-var vop)
 529   (:save-p :compute-only)
 530   (:generator 3
 531     (note-this-location vop :internal-error)
 532     ;; This is the condition to nullify the branch, so it is inverted.
 533     (inst fcmp (if not-p condition complement) x y)
 534     (inst ftest)
 535     (inst b target :nullify t)))
 536
 537 (macrolet ((frob (name sc zero-sc ptype)
 538              `(define-vop (,name float-compare)
 539                 (:args (x :scs (,sc ,zero-sc))
 540                        (y :scs (,sc ,zero-sc)))
 541                 (:arg-types ,ptype ,ptype))))
 542   (frob single-float-compare single-reg fp-single-zero single-float)
 543   (frob double-float-compare double-reg fp-double-zero double-float))
 544
 545 (macrolet ((frob (translate condition complement sname dname)
 546              `(progn
 547                 (define-vop (,sname single-float-compare)
 548                   (:translate ,translate)
 549                   (:variant ,condition ,complement))
 550                 (define-vop (,dname double-float-compare)
 551                   (:translate ,translate)
 552                   (:variant ,condition ,complement)))))
 553   ;; FIXME-lav: let 'inst cmp' translate keywords into raw binary instead of giving it here
 554   (frob < #b01001 #b10101 </single-float </double-float)
 555   (frob > #b10001 #b01101 >/single-float >/double-float)
 556   (frob = #b00101 #b11001 eql/single-float eql/double-float))
 557
 558 \f
 559 ;;;; Conversion:
 560
 561 (macrolet ((frob (name translate from-sc from-type to-sc to-type)
 562              `(define-vop (,name)
 563                 (:args (x :scs (,from-sc)))
 564                 (:results (y :scs (,to-sc)))
 565                 (:arg-types ,from-type)
 566                 (:result-types ,to-type)
 567                 (:policy :fast-safe)
 568                 (:note "inline float coercion")
 569                 (:translate ,translate)
 570                 (:vop-var vop)
 571                 (:save-p :compute-only)
 572                 (:generator 2
 573                   (note-this-location vop :internal-error)
 574                   (inst fcnvff x y)))))
 575   (frob %single-float/double-float %single-float
 576     double-reg double-float
 577     single-reg single-float)
 578   (frob %double-float/single-float %double-float
 579     single-reg single-float
 580     double-reg double-float))
 581
 582 ; convert register-integer to registersingle/double by
 583 ; putting it on single-float-stack and then float-loading it into
 584 ; an float register, and finally convert the float-register and
 585 ; storing the result into y
 586 (macrolet ((frob (name translate to-sc to-type)
 587              `(define-vop (,name)
 588                 (:args (x :scs (signed-reg)
 589                           :load-if (not (sc-is x signed-stack))
 590                           :target stack-temp))
 591                 (:arg-types signed-num)
 592                 (:results (y :scs (,to-sc)))
 593                 (:result-types ,to-type)
 594                 (:policy :fast-safe)
 595                 (:note "inline float coercion")
 596                 (:translate ,translate)
 597                 (:vop-var vop)
 598                 (:save-p :compute-only)
 599                 (:temporary (:scs (signed-stack) :from (:argument 0))
 600                             stack-temp)
 601                 (:temporary (:scs (single-reg) :to (:result 0) :target y)
 602                             fp-temp)
 603                 (:temporary (:scs (any-reg) :from (:argument 0)
 604                                   :to (:result 0)) index)
 605                 (:generator 5
 606                   (let* ((nfp (current-nfp-tn vop))
 607                          (stack-tn
 608                           (sc-case x
 609                             (signed-stack
 610                              x)
 611                             (signed-reg
 612                              (storew x nfp (tn-offset stack-temp))
 613                              stack-temp)))
 614                          (offset (* (tn-offset stack-tn) n-word-bytes)))
 615                     (cond ((< offset (ash 1 4))
 616                            (inst flds offset nfp fp-temp))
 617                           ((and (< offset (ash 1 13))
 618                                 (> offset 0))
 619                            (inst ldo offset zero-tn index)
 620                            (inst fldx index nfp fp-temp))
 621                           (t
 622                            (error "in vop ~s offset ~s is out-of-range" ',name offset)))
 623                     (note-this-location vop :internal-error)
 624                     (inst fcnvxf fp-temp y))))))
 625   (frob %single-float/signed %single-float
 626     single-reg single-float)
 627   (frob %double-float/signed %double-float
 628     double-reg double-float))
 629
 630 (macrolet ((frob (trans from-sc from-type inst note)
 631              `(define-vop (,(symbolicate trans "/" from-type))
 632                 (:args (x :scs (,from-sc)
 633                           :target fp-temp))
 634                 (:results (y :scs (signed-reg)
 635                              :load-if (not (sc-is y signed-stack))))
 636                 (:arg-types ,from-type)
 637                 (:result-types signed-num)
 638                 (:translate ,trans)
 639                 (:policy :fast-safe)
 640                 (:note ,note)
 641                 (:vop-var vop)
 642                 (:save-p :compute-only)
 643                 (:temporary (:scs (single-reg) :from (:argument 0)) fp-temp)
 644                 (:temporary (:scs (signed-stack) :to (:result 0) :target y)
 645                             stack-temp)
 646                 (:temporary (:scs (any-reg) :from (:argument 0)
 647                                   :to (:result 0)) index)
 648                 (:generator 3
 649                   (let* ((nfp (current-nfp-tn vop))
 650                          (stack-tn
 651                           (sc-case y
 652                             (signed-stack y)
 653                             (signed-reg stack-temp)))
 654                          (offset (* (tn-offset stack-tn) n-word-bytes)))
 655                     (inst ,inst x fp-temp)
 656                     (cond ((< offset (ash 1 4))
 657                            (note-next-instruction vop :internal-error)
 658                            (inst fsts fp-temp offset nfp))
 659                           ((and (< offset (ash 1 13))
 660                                 (> offset 0))
 661                            (inst ldo offset zero-tn index)
 662                            (note-next-instruction vop :internal-error)
 663                            (inst fstx fp-temp index nfp))
 664                           (t
 665                            (error "unary error, ldo offset too high")))
 666                     (unless (eq y stack-tn)
 667                       (loadw y nfp (tn-offset stack-tn))))))))
 668   (frob %unary-round single-reg single-float fcnvfx "inline float round")
 669   (frob %unary-round double-reg double-float fcnvfx "inline float round")
 670   (frob %unary-truncate/single-float single-reg single-float fcnvfxt
 671     "inline float truncate")
 672   (frob %unary-truncate/double-float double-reg double-float fcnvfxt
 673     "inline float truncate"))
 674
 675 (define-vop (make-single-float)
 676   (:args (bits :scs (signed-reg)
 677                :load-if (or (not (sc-is bits signed-stack))
 678                             (sc-is res single-stack))
 679                :target res))
 680   (:results (res :scs (single-reg)
 681                  :load-if (not (sc-is bits single-stack))))
 682   (:arg-types signed-num)
 683   (:result-types single-float)
 684   (:translate make-single-float)
 685   (:policy :fast-safe)
 686   (:vop-var vop)
 687   (:temporary (:scs (single-stack) :from (:argument 0) :to (:result 0)) temp)
 688   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
 689   (:generator 2
 690     (let ((nfp (current-nfp-tn vop)))
 691       (sc-case bits
 692         (signed-reg
 693          (sc-case res
 694            (single-reg
 695             (let ((offset (* (tn-offset temp) n-word-bytes)))
 696               (inst stw bits offset nfp)
 697               (cond ((< offset (ash 1 4))
 698                      (inst flds offset nfp res))
 699                     ((and (< offset (ash 1 13))
 700                           (> offset 0))
 701                      (inst ldo offset zero-tn index)
 702                      (inst fldx index nfp res))
 703                     (t
 704                      (error "make-single-float error, ldo offset too large")))))
 705            (single-stack
 706             (inst stw bits (* (tn-offset res) n-word-bytes) nfp))))
 707         (signed-stack
 708          (sc-case res
 709            (single-reg
 710             (let ((offset (* (tn-offset bits) n-word-bytes)))
 711               (cond ((< offset (ash 1 4))
 712                      (inst flds offset nfp res))
 713                     ((and (< offset (ash 1 13))
 714                           (> offset 0))
 715                      (inst ldo offset zero-tn index)
 716                      (inst fldx index nfp res))
 717                     (t
 718                      (error "make-single-float error, ldo offset too large")))))))))))
 719
 720 (define-vop (make-double-float)
 721   (:args (hi-bits :scs (signed-reg))
 722          (lo-bits :scs (unsigned-reg)))
 723   (:results (res :scs (double-reg)
 724                  :load-if (not (sc-is res double-stack))))
 725   (:arg-types signed-num unsigned-num)
 726   (:result-types double-float)
 727   (:translate make-double-float)
 728   (:policy :fast-safe)
 729   (:temporary (:scs (double-stack) :to (:result 0)) temp)
 730   (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
 731   (:vop-var vop)
 732   (:generator 2
 733     (let* ((nfp (current-nfp-tn vop))
 734            (stack-tn (sc-case res
 735                        (double-stack res)
 736                        (double-reg temp)))
 737            (offset (* (tn-offset stack-tn) n-word-bytes)))
 738       (inst stw hi-bits offset nfp)
 739       (inst stw lo-bits (+ offset n-word-bytes) nfp)
 740       (cond ((eq stack-tn res))
 741             ((< offset (ash 1 4))
 742              (inst flds offset nfp res))
 743             ((and (< offset (ash 1 13))
 744                   (> offset 0))
 745              (inst ldo offset zero-tn index)
 746              (inst fldx index nfp res))
 747             (t
 748              (error "make-single-float error, ldo offset too large"))))))
 749
 750 (macrolet
 751   ((float-bits (name reg rreg stack rstack atype anum side offset)
 752    `(define-vop (,name)
 753     (:args (float :scs (,reg)
 754                   :load-if (not (sc-is float ,stack))))
 755     (:results (bits :scs (,rreg)
 756                     :load-if (or (not (sc-is bits ,rstack))
 757                                  (sc-is float ,stack))))
 758     (:arg-types ,atype)
 759     (:result-types ,anum)
 760     (:translate ,name)
 761     (:policy :fast-safe)
 762     (:vop-var vop)
 763     (:temporary (:scs (signed-stack) :from (:argument 0) :to (:result 0)) temp)
 764     (:temporary (:scs (any-reg) :from (:argument 0) :to (:result 0)) index)
 765     (:generator 2
 766       (let ((nfp (current-nfp-tn vop)))
 767         (sc-case float
 768           (,reg
 769            (sc-case bits
 770              (,rreg
 771               (let ((offset (* (tn-offset temp) n-word-bytes)))
 772                 (cond ((< offset (ash 1 4))
 773                        ,@(if side
 774                            `((inst fsts float offset nfp :side ,side))
 775                            `((inst fsts float offset nfp))))
 776                       ((and (< offset (ash 1 13))
 777                             (> offset 0))
 778                        (inst ldo offset zero-tn index)
 779                        ,@(if side
 780                          `((inst fstx float index nfp :side ,side))
 781                          `((inst fstx float index nfp))))
 782                       (t
 783                        (error ,(format nil "~s,~s: inst-LDO offset too large"
 784                                        name rreg))))
 785                 (inst ldw offset nfp bits)))
 786              (,rstack
 787               (let ((offset (* (tn-offset bits) n-word-bytes)))
 788                 (cond ((< offset (ash 1 4))
 789                        ,@(if side
 790                          `((inst fsts float offset nfp :side ,side))
 791                          `((inst fsts float offset nfp))))
 792                       ((and (< offset (ash 1 13))
 793                             (> offset 0))
 794                        (inst ldo offset zero-tn index)
 795                        ,@(if side
 796                            `((inst fstx float index nfp :side ,side))
 797                            `((inst fstx float index nfp))))
 798                       (t
 799                        (error ,(format nil "~s,~s: inst-LDO offset too large"
 800                                        name rstack))))))))
 801           (,stack
 802            (sc-case bits
 803              (,rreg
 804               (inst ldw (* (+ (tn-offset float) ,offset) n-word-bytes)
 805                     nfp bits))))))))))
 806   (float-bits single-float-bits single-reg signed-reg single-stack
 807               signed-stack single-float signed-num nil 0)
 808   (float-bits double-float-high-bits double-reg signed-reg
 809               double-stack signed-stack double-float signed-num 0 0)
 810   (float-bits double-float-low-bits double-reg unsigned-reg
 811               double-stack unsigned-stack double-float unsigned-num 1 1))
 812
 813 ;;;; Float mode hackery:
 814
 815 (sb!xc:deftype float-modes () '(unsigned-byte 32))
 816 (defknown floating-point-modes () float-modes (flushable))
 817 (defknown ((setf floating-point-modes)) (float-modes)
 818             float-modes)
 819
 820 (define-vop (floating-point-modes)
 821             (:results (res :scs (unsigned-reg)))
 822             (:result-types unsigned-num)
 823             (:translate floating-point-modes)
 824             (:policy :fast-safe)
 825             (:temporary (:scs (double-stack)) temp)
 826             (:temporary (:scs (any-reg) :to (:result 0)) index)
 827             (:vop-var vop)
 828   (:generator 3
 829               (let* ((nfp (current-nfp-tn vop))
 830                      (stack-tn (sc-case res
 831                                         (unsigned-stack res)
 832                                         (unsigned-reg temp)))
 833                      (offset (* (tn-offset stack-tn) n-word-bytes)))
 834                 (cond ((< offset (ash 1 4))
 835                        (inst fsts fp-double-zero-tn offset nfp))
 836                       ((and (< offset (ash 1 13))
 837                             (> offset 0))
 838                        (inst ldo offset zero-tn index)
 839                        (inst fstx fp-double-zero-tn index nfp))
 840                       (t
 841                        (error "floating-point-modes error, ldo offset too large")))
 842                 (ecase *backend-byte-order*
 843                   (:big-endian
 844                    (inst ldw offset nfp res))
 845                   (:little-endian
 846                    (inst ldw (+ offset 4) nfp res))))))
 847
 848 (define-vop (set-floating-point-modes)
 849             (:args (new :scs (unsigned-reg) :target res))
 850             (:results (res :scs (unsigned-reg)))
 851             (:arg-types unsigned-num)
 852             (:result-types unsigned-num)
 853             (:translate (setf floating-point-modes))
 854             (:policy :fast-safe)
 855             (:temporary (:scs (double-stack)) stack-tn)
 856             (:temporary (:scs (any-reg)) index)
 857             (:vop-var vop)
 858   (:generator 3
 859               (let* ((nfp (current-nfp-tn vop))
 860                      (offset (* (tn-offset stack-tn) n-word-bytes)))
 861                 (ecase *backend-byte-order*
 862                   (:big-endian
 863                    (inst stw new offset nfp)
 864                    (inst stw zero-tn (+ offset 4) nfp))
 865                   (:little-endian
 866                    (inst stw zero-tn offset nfp)
 867                    (inst stw new (+ offset 4) nfp)))
 868                 (cond ((< offset (ash 1 4))
 869                        (inst flds offset nfp fp-double-zero-tn))
 870                       ((and (< offset (ash 1 13))
 871                             (> offset 0))
 872                        (inst ldo offset zero-tn index)
 873                        (inst fldx index nfp fp-double-zero-tn))
 874                       (t
 875                        (error "set-floating-point-modes error, ldo offset too large")))
 876                 (move new res))))
 877 \f
 878 ;;;; Complex float VOPs
 879
 880 (define-vop (make-complex-single-float)
 881   (:translate complex)
 882   (:args (real :scs (single-reg) :target r)
 883          (imag :scs (single-reg) :to :save))
 884   (:arg-types single-float single-float)
 885   (:results (r :scs (complex-single-reg) :from (:argument 0)
 886                :load-if (not (sc-is r complex-single-stack))))
 887   (:result-types complex-single-float)
 888   (:note "inline complex single-float creation")
 889   (:policy :fast-safe)
 890   (:vop-var vop)
 891   (:generator 5
 892     (sc-case r
 893       (complex-single-reg
 894        (let ((r-real (complex-single-reg-real-tn r)))
 895          (unless (location= real r-real)
 896            (inst funop :copy real r-real)))
 897        (let ((r-imag (complex-single-reg-imag-tn r)))
 898          (unless (location= imag r-imag)
 899            (inst funop :copy imag r-imag))))
 900       (complex-single-stack
 901        (let ((nfp (current-nfp-tn vop))
 902              (offset (* (tn-offset r) n-word-bytes)))
 903          (str-float real offset nfp)
 904          (str-float imag (+ offset n-word-bytes) nfp))))))
 905
 906 (define-vop (make-complex-double-float)
 907   (:translate complex)
 908   (:args (real :scs (double-reg) :target r)
 909          (imag :scs (double-reg) :to :save))
 910   (:arg-types double-float double-float)
 911   (:results (r :scs (complex-double-reg) :from (:argument 0)
 912                :load-if (not (sc-is r complex-double-stack))))
 913   (:result-types complex-double-float)
 914   (:note "inline complex double-float creation")
 915   (:policy :fast-safe)
 916   (:vop-var vop)
 917   (:generator 5
 918     (sc-case r
 919       (complex-double-reg
 920        (let ((r-real (complex-double-reg-real-tn r)))
 921          (unless (location= real r-real)
 922            (inst funop :copy real r-real)))
 923        (let ((r-imag (complex-double-reg-imag-tn r)))
 924          (unless (location= imag r-imag)
 925            (inst funop :copy imag r-imag))))
 926       (complex-double-stack
 927        (let ((nfp (current-nfp-tn vop))
 928              (offset (* (tn-offset r) n-word-bytes)))
 929          (str-float real offset nfp)
 930          (str-float imag (+ offset (* 2 n-word-bytes)) nfp))))))
 931
 932 (define-vop (complex-single-float-value)
 933   (:args (x :scs (complex-single-reg) :target r
 934             :load-if (not (sc-is x complex-single-stack))))
 935   (:arg-types complex-single-float)
 936   (:results (r :scs (single-reg)))
 937   (:result-types single-float)
 938   (:variant-vars slot)
 939   (:policy :fast-safe)
 940   (:vop-var vop)
 941   (:generator 3
 942     (sc-case x
 943       (complex-single-reg
 944        (let ((value-tn (ecase slot
 945                          (:real (complex-single-reg-real-tn x))
 946                          (:imag (complex-single-reg-imag-tn x)))))
 947          (unless (location= value-tn r)
 948            (inst funop :copy value-tn r))))
 949       (complex-single-stack
 950        (ld-float (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
 951                     n-word-bytes)
 952                  (current-nfp-tn vop) r)))))
 953
 954 (define-vop (realpart/complex-single-float complex-single-float-value)
 955   (:translate realpart)
 956   (:note "complex single float realpart")
 957   (:variant :real))
 958
 959 (define-vop (imagpart/complex-single-float complex-single-float-value)
 960   (:translate imagpart)
 961   (:note "complex single float imagpart")
 962   (:variant :imag))
 963
 964 (define-vop (complex-double-float-value)
 965   (:args (x :scs (complex-double-reg) :target r
 966             :load-if (not (sc-is x complex-double-stack))))
 967   (:arg-types complex-double-float)
 968   (:results (r :scs (double-reg)))
 969   (:result-types double-float)
 970   (:variant-vars slot)
 971   (:policy :fast-safe)
 972   (:vop-var vop)
 973   (:generator 3
 974     (sc-case x
 975       (complex-double-reg
 976        (let ((value-tn (ecase slot
 977                          (:real (complex-double-reg-real-tn x))
 978                          (:imag (complex-double-reg-imag-tn x)))))
 979          (unless (location= value-tn r)
 980            (inst funop :copy value-tn r))))
 981       (complex-double-stack
 982        (ld-float (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
 983                     n-word-bytes)
 984                  (current-nfp-tn vop) r)))))
 985
 986 (define-vop (realpart/complex-double-float complex-double-float-value)
 987   (:translate realpart)
 988   (:note "complex double float realpart")
 989   (:variant :real))
 990
 991 (define-vop (imagpart/complex-double-float complex-double-float-value)
 992   (:translate imagpart)
 993   (:note "complex double float imagpart")
 994   (:variant :imag))