src/compiler/hppa/float.lisp

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