src/compiler/arm/float.lisp

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