src/compiler/x86-64/float.lisp

   1 ;;;; floating point support for the x86
   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 (macrolet ((ea-for-xf-desc (tn slot)
  15              `(make-ea
  16                :qword :base ,tn
  17                :disp (- (* ,slot n-word-bytes)
  18                         other-pointer-lowtag))))
  19   (defun ea-for-df-desc (tn)
  20     (ea-for-xf-desc tn double-float-value-slot))
  21   ;; complex floats
  22   (defun ea-for-csf-data-desc (tn)
  23     (ea-for-xf-desc tn complex-single-float-data-slot))
  24   (defun ea-for-csf-real-desc (tn)
  25     (ea-for-xf-desc tn complex-single-float-data-slot))
  26   (defun ea-for-csf-imag-desc (tn)
  27     (ea-for-xf-desc tn (+ complex-single-float-data-slot 1/2)))
  28
  29   (defun ea-for-cdf-data-desc (tn)
  30     (ea-for-xf-desc tn complex-double-float-real-slot))
  31   (defun ea-for-cdf-real-desc (tn)
  32     (ea-for-xf-desc tn complex-double-float-real-slot))
  33   (defun ea-for-cdf-imag-desc (tn)
  34     (ea-for-xf-desc tn complex-double-float-imag-slot)))
  35
  36 (macrolet ((ea-for-xf-stack (tn kind)
  37              (declare (ignore kind))
  38              `(make-ea
  39                :qword :base rbp-tn
  40                :disp (frame-byte-offset (tn-offset ,tn)))))
  41   (defun ea-for-sf-stack (tn)
  42     (ea-for-xf-stack tn :single))
  43   (defun ea-for-df-stack (tn)
  44     (ea-for-xf-stack tn :double)))
  45
  46 ;;; complex float stack EAs
  47 (macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
  48              `(make-ea
  49                :qword :base ,base
  50                :disp (frame-byte-offset
  51                       (+ (tn-offset ,tn)
  52                        (cond ((= (tn-offset ,base) rsp-offset)
  53                               sp->fp-offset)
  54                              ((= (tn-offset ,base) rbp-offset)
  55                               0)
  56                              (t (error "Unexpected offset.")))
  57                        (ecase ,kind
  58                          (:single
  59                             (ecase ,slot
  60                               (:real 0)
  61                               (:imag -1/2)))
  62                          (:double
  63                             (ecase ,slot
  64                               (:real 1)
  65                               (:imag 0)))))))))
  66   (defun ea-for-csf-data-stack (tn &optional (base rbp-tn))
  67     (ea-for-cxf-stack tn :single :real base))
  68   (defun ea-for-csf-real-stack (tn &optional (base rbp-tn))
  69     (ea-for-cxf-stack tn :single :real base))
  70   (defun ea-for-csf-imag-stack (tn &optional (base rbp-tn))
  71     (ea-for-cxf-stack tn :single :imag base))
  72
  73   (defun ea-for-cdf-data-stack (tn &optional (base rbp-tn))
  74     (ea-for-cxf-stack tn :double :real base))
  75   (defun ea-for-cdf-real-stack (tn &optional (base rbp-tn))
  76     (ea-for-cxf-stack tn :double :real base))
  77   (defun ea-for-cdf-imag-stack (tn &optional (base rbp-tn))
  78     (ea-for-cxf-stack tn :double :imag base)))
  79 \f
  80 ;;;; move functions
  81
  82 ;;; X is source, Y is destination.
  83
  84 (define-move-fun (load-fp-zero 1) (vop x y)
  85   ((fp-single-zero) (single-reg)
  86    (fp-double-zero) (double-reg)
  87    (fp-complex-single-zero) (complex-single-reg)
  88    (fp-complex-double-zero) (complex-double-reg))
  89   (identity x)
  90   (sc-case y
  91     ((single-reg complex-single-reg) (inst xorps y y))
  92     ((double-reg complex-double-reg) (inst xorpd y y))))
  93
  94 (define-move-fun (load-fp-immediate 1) (vop x y)
  95   ((fp-single-immediate) (single-reg)
  96    (fp-double-immediate) (double-reg)
  97    (fp-complex-single-immediate) (complex-single-reg)
  98    (fp-complex-double-immediate) (complex-double-reg))
  99   (let ((x (register-inline-constant (tn-value x))))
 100     (sc-case y
 101       (single-reg (inst movss y x))
 102       (double-reg (inst movsd y x))
 103       (complex-single-reg (inst movq y x))
 104       (complex-double-reg (inst movapd y x)))))
 105
 106 (define-move-fun (load-single 2) (vop x y)
 107   ((single-stack) (single-reg))
 108   (inst movss y (ea-for-sf-stack x)))
 109
 110 (define-move-fun (store-single 2) (vop x y)
 111   ((single-reg) (single-stack))
 112   (inst movss (ea-for-sf-stack y) x))
 113
 114 (define-move-fun (load-double 2) (vop x y)
 115   ((double-stack) (double-reg))
 116   (inst movsd y (ea-for-df-stack x)))
 117
 118 (define-move-fun (store-double 2) (vop x y)
 119   ((double-reg) (double-stack))
 120   (inst movsd  (ea-for-df-stack y) x))
 121
 122 (eval-when (:compile-toplevel :execute)
 123   (setf *read-default-float-format* 'single-float))
 124 \f
 125 ;;;; complex float move functions
 126
 127 ;;; X is source, Y is destination.
 128 (define-move-fun (load-complex-single 2) (vop x y)
 129   ((complex-single-stack) (complex-single-reg))
 130   (inst movq y (ea-for-csf-data-stack x)))
 131
 132 (define-move-fun (store-complex-single 2) (vop x y)
 133   ((complex-single-reg) (complex-single-stack))
 134   (inst movq (ea-for-csf-data-stack y) x))
 135
 136 (define-move-fun (load-complex-double 2) (vop x y)
 137   ((complex-double-stack) (complex-double-reg))
 138   (inst movupd y (ea-for-cdf-data-stack x)))
 139
 140 (define-move-fun (store-complex-double 2) (vop x y)
 141   ((complex-double-reg) (complex-double-stack))
 142   (inst movupd (ea-for-cdf-data-stack y) x))
 143 \f
 144 ;;;; move VOPs
 145
 146 ;;; float register to register moves
 147 (macrolet ((frob (vop sc)
 148              `(progn
 149                 (define-vop (,vop)
 150                   (:args (x :scs (,sc)
 151                             :target y
 152                             :load-if (not (location= x y))))
 153                   (:results (y :scs (,sc)
 154                                :load-if (not (location= x y))))
 155                   (:note "float move")
 156                   (:generator 0
 157                     (move y x)))
 158                 (define-move-vop ,vop :move (,sc) (,sc)))))
 159   (frob single-move single-reg)
 160   (frob double-move double-reg)
 161   (frob complex-single-move complex-single-reg)
 162   (frob complex-double-move complex-double-reg))
 163
 164 \f
 165 ;;; Move from float to a descriptor reg. allocating a new float
 166 ;;; object in the process.
 167 (define-vop (move-from-single)
 168   (:args (x :scs (single-reg) :to :save))
 169   (:results (y :scs (descriptor-reg)))
 170   (:note "float to pointer coercion")
 171   (:generator 4
 172     (inst movd y x)
 173     (inst shl y 32)
 174     (inst or y single-float-widetag)))
 175
 176 (define-move-vop move-from-single :move
 177   (single-reg) (descriptor-reg))
 178
 179 (define-vop (move-from-double)
 180   (:args (x :scs (double-reg) :to :save))
 181   (:results (y :scs (descriptor-reg)))
 182   (:node-var node)
 183   (:note "float to pointer coercion")
 184   (:generator 13
 185      (with-fixed-allocation (y
 186                              double-float-widetag
 187                              double-float-size
 188                              node)
 189        (inst movsd (ea-for-df-desc y) x))))
 190 (define-move-vop move-from-double :move
 191   (double-reg) (descriptor-reg))
 192
 193 ;;; Move from a descriptor to a float register.
 194 (define-vop (move-to-single)
 195   (:args (x :scs (descriptor-reg) :target tmp))
 196   (:temporary (:sc unsigned-reg) tmp)
 197   (:results (y :scs (single-reg single-stack)))
 198   (:note "pointer to float coercion")
 199   (:generator 2
 200     (move tmp x)
 201     (inst shr tmp 32)
 202     (sc-case y
 203       (single-reg
 204        (inst movd y tmp))
 205       (single-stack
 206        (let ((slot (make-ea :dword :base rbp-tn
 207                             :disp (frame-byte-offset (tn-offset y)))))
 208          (inst mov slot (reg-in-size tmp :dword)))))))
 209
 210 (define-move-vop move-to-single :move (descriptor-reg) (single-reg single-stack))
 211
 212 (define-vop (move-to-double)
 213   (:args (x :scs (descriptor-reg)))
 214   (:results (y :scs (double-reg)))
 215   (:note "pointer to float coercion")
 216   (:generator 2
 217     (inst movsd y (ea-for-df-desc x))))
 218 (define-move-vop move-to-double :move (descriptor-reg) (double-reg))
 219
 220 \f
 221 ;;; Move from complex float to a descriptor reg. allocating a new
 222 ;;; complex float object in the process.
 223 (define-vop (move-from-complex-single)
 224   (:args (x :scs (complex-single-reg) :to :save))
 225   (:results (y :scs (descriptor-reg)))
 226   (:node-var node)
 227   (:note "complex float to pointer coercion")
 228   (:generator 13
 229      (with-fixed-allocation (y
 230                              complex-single-float-widetag
 231                              complex-single-float-size
 232                              node)
 233        (inst movq (ea-for-csf-data-desc y) x))))
 234 (define-move-vop move-from-complex-single :move
 235   (complex-single-reg) (descriptor-reg))
 236
 237 (define-vop (move-from-complex-double)
 238   (:args (x :scs (complex-double-reg) :to :save))
 239   (:results (y :scs (descriptor-reg)))
 240   (:node-var node)
 241   (:note "complex float to pointer coercion")
 242   (:generator 13
 243      (with-fixed-allocation (y
 244                              complex-double-float-widetag
 245                              complex-double-float-size
 246                              node)
 247        (inst movapd (ea-for-cdf-data-desc y) x))))
 248 (define-move-vop move-from-complex-double :move
 249   (complex-double-reg) (descriptor-reg))
 250
 251 ;;; Move from a descriptor to a complex float register.
 252 (macrolet ((frob (name sc format)
 253              `(progn
 254                 (define-vop (,name)
 255                   (:args (x :scs (descriptor-reg)))
 256                   (:results (y :scs (,sc)))
 257                   (:note "pointer to complex float coercion")
 258                   (:generator 2
 259                     ,(ecase format
 260                       (:single
 261                          '(inst movq y (ea-for-csf-data-desc x)))
 262                       (:double
 263                          '(inst movapd y (ea-for-cdf-data-desc x))))))
 264                 (define-move-vop ,name :move (descriptor-reg) (,sc)))))
 265   (frob move-to-complex-single complex-single-reg :single)
 266   (frob move-to-complex-double complex-double-reg :double))
 267 \f
 268 ;;;; the move argument vops
 269 ;;;;
 270 ;;;; Note these are also used to stuff fp numbers onto the c-call
 271 ;;;; stack so the order is different than the lisp-stack.
 272
 273 ;;; the general MOVE-ARG VOP
 274 (macrolet ((frob (name sc stack-sc format)
 275              `(progn
 276                 (define-vop (,name)
 277                   (:args (x :scs (,sc) :target y)
 278                          (fp :scs (any-reg)
 279                              :load-if (not (sc-is y ,sc))))
 280                   (:results (y))
 281                   (:note "float argument move")
 282                   (:generator ,(case format (:single 2) (:double 3) )
 283                     (sc-case y
 284                       (,sc
 285                        (move y x))
 286                       (,stack-sc
 287                        (if (= (tn-offset fp) esp-offset)
 288                            (let* ((offset (* (tn-offset y) n-word-bytes))
 289                                   (ea (make-ea :dword :base fp :disp offset)))
 290                              ,@(ecase format
 291                                       (:single '((inst movss ea x)))
 292                                       (:double '((inst movsd ea x)))))
 293                            (let ((ea (make-ea
 294                                       :dword :base fp
 295                                       :disp (frame-byte-offset (tn-offset y)))))
 296                              ,@(ecase format
 297                                  (:single '((inst movss ea x)))
 298                                  (:double '((inst movsd ea x))))))))))
 299                 (define-move-vop ,name :move-arg
 300                   (,sc descriptor-reg) (,sc)))))
 301   (frob move-single-float-arg single-reg single-stack :single)
 302   (frob move-double-float-arg double-reg double-stack :double))
 303
 304 ;;;; complex float MOVE-ARG VOP
 305 (macrolet ((frob (name sc stack-sc format)
 306              `(progn
 307                 (define-vop (,name)
 308                   (:args (x :scs (,sc) :target y)
 309                          (fp :scs (any-reg)
 310                              :load-if (not (sc-is y ,sc))))
 311                   (:results (y))
 312                   (:note "complex float argument move")
 313                   (:generator ,(ecase format (:single 2) (:double 3))
 314                     (sc-case y
 315                       (,sc
 316                        (move y x))
 317                       (,stack-sc
 318                        ,(ecase format
 319                           (:single
 320                              '(inst movq (ea-for-csf-data-stack y fp) x))
 321                           (:double
 322                              '(inst movupd (ea-for-cdf-data-stack y fp) x)))))))
 323                 (define-move-vop ,name :move-arg
 324                   (,sc descriptor-reg) (,sc)))))
 325   (frob move-complex-single-float-arg
 326         complex-single-reg complex-single-stack :single)
 327   (frob move-complex-double-float-arg
 328         complex-double-reg complex-double-stack :double))
 329
 330 (define-move-vop move-arg :move-arg
 331   (single-reg double-reg
 332    complex-single-reg complex-double-reg)
 333   (descriptor-reg))
 334
 335 \f
 336 ;;;; arithmetic VOPs
 337
 338 (define-vop (float-op)
 339   (:args (x) (y))
 340   (:results (r))
 341   (:policy :fast-safe)
 342   (:note "inline float arithmetic")
 343   (:vop-var vop)
 344   (:save-p :compute-only))
 345
 346 (macrolet ((frob (name comm-name sc constant-sc ptype)
 347              `(progn
 348                 (define-vop (,name float-op)
 349                   (:args (x :scs (,sc ,constant-sc)
 350                             :target r
 351                             :load-if (not (sc-is x ,constant-sc)))
 352                          (y :scs (,sc ,constant-sc)
 353                             :load-if (not (sc-is y ,constant-sc))))
 354                   (:results (r :scs (,sc)))
 355                   (:arg-types ,ptype ,ptype)
 356                   (:result-types ,ptype))
 357                 (define-vop (,comm-name float-op)
 358                   (:args (x :scs (,sc ,constant-sc)
 359                             :target r
 360                             :load-if (not (sc-is x ,constant-sc)))
 361                          (y :scs (,sc ,constant-sc)
 362                             :target r
 363                             :load-if (not (sc-is y ,constant-sc))))
 364                   (:results (r :scs (,sc)))
 365                   (:arg-types ,ptype ,ptype)
 366                   (:result-types ,ptype)))))
 367   (frob single-float-op single-float-comm-op
 368         single-reg fp-single-immediate single-float)
 369   (frob double-float-op double-float-comm-op
 370         double-reg fp-double-immediate double-float)
 371   (frob complex-single-float-op complex-single-float-comm-op
 372         complex-single-reg fp-complex-single-immediate
 373         complex-single-float)
 374   (frob complex-double-float-op complex-double-float-comm-op
 375         complex-double-reg fp-complex-double-immediate
 376         complex-double-float))
 377
 378 (macrolet ((generate (opinst commutative constant-sc load-inst)
 379              `(flet ((get-constant (tn)
 380                        (register-inline-constant
 381                         ,@(and (eq constant-sc 'fp-single-immediate)
 382                                '(:aligned))
 383                         (tn-value tn))))
 384                 (declare (ignorable #'get-constant))
 385                 (cond
 386                   ((location= x r)
 387                    (when (sc-is y ,constant-sc)
 388                      (setf y (get-constant y)))
 389                    (inst ,opinst x y))
 390                   ((and ,commutative (location= y r))
 391                    (when (sc-is x ,constant-sc)
 392                      (setf x (get-constant x)))
 393                    (inst ,opinst y x))
 394                   ((not (location= r y))
 395                    (if (sc-is x ,constant-sc)
 396                        (inst ,load-inst r (get-constant x))
 397                        (move r x))
 398                    (when (sc-is y ,constant-sc)
 399                      (setf y (get-constant y)))
 400                    (inst ,opinst r y))
 401                   (t
 402                    (if (sc-is x ,constant-sc)
 403                        (inst ,load-inst tmp (get-constant x))
 404                        (move tmp x))
 405                    (inst ,opinst tmp y)
 406                    (move r tmp)))))
 407            (frob (op sinst sname scost dinst dname dcost commutative
 408                      &optional csinst csname cscost cdinst cdname cdcost)
 409              `(progn
 410                 (define-vop (,sname ,(if commutative
 411                                          'single-float-comm-op
 412                                          'single-float-op))
 413                   (:translate ,op)
 414                   (:temporary (:sc single-reg) tmp)
 415                   (:generator ,scost
 416                     (generate ,sinst ,commutative fp-single-immediate movss)))
 417                 (define-vop (,dname ,(if commutative
 418                                          'double-float-comm-op
 419                                          'double-float-op))
 420                   (:translate ,op)
 421                   (:temporary (:sc double-reg) tmp)
 422                   (:generator ,dcost
 423                     (generate ,dinst ,commutative fp-double-immediate movsd)))
 424                 ,(when csinst
 425                    `(define-vop (,csname
 426                                  ,(if commutative
 427                                       'complex-single-float-comm-op
 428                                       'complex-single-float-op))
 429                       (:translate ,op)
 430                       (:temporary (:sc complex-single-reg) tmp)
 431                       (:generator ,cscost
 432                         (generate ,csinst ,commutative
 433                                   fp-complex-single-immediate movq))))
 434                 ,(when cdinst
 435                    `(define-vop (,cdname
 436                                  ,(if commutative
 437                                       'complex-double-float-comm-op
 438                                       'complex-double-float-op))
 439                       (:translate ,op)
 440                       (:temporary (:sc complex-double-reg) tmp)
 441                       (:generator ,cdcost
 442                         (generate ,cdinst ,commutative
 443                                   fp-complex-double-immediate movapd)))))))
 444   (frob + addss +/single-float 2 addsd +/double-float 2 t
 445         addps +/complex-single-float 3 addpd +/complex-double-float 3)
 446   (frob - subss -/single-float 2 subsd -/double-float 2 nil
 447         subps -/complex-single-float 3 subpd -/complex-double-float 3)
 448   (frob * mulss */single-float 4 mulsd */double-float 5 t)
 449   (frob / divss //single-float 12 divsd //double-float 19 nil))
 450
 451 (macrolet ((frob (op cost commutativep
 452                      duplicate-inst op-inst real-move-inst complex-move-inst
 453                      real-sc real-constant-sc real-type
 454                      complex-sc complex-constant-sc complex-type
 455                      real-complex-name complex-real-name)
 456              (cond ((not duplicate-inst) ; simple case
 457                     `(flet ((load-into (r x)
 458                               (sc-case x
 459                                 (,real-constant-sc
 460                                  (inst ,real-move-inst r
 461                                        (register-inline-constant (tn-value x))))
 462                                 (,complex-constant-sc
 463                                  (inst ,complex-move-inst r
 464                                        (register-inline-constant (tn-value x))))
 465                                 (t (move r x)))))
 466                        ,(when real-complex-name
 467                           `(define-vop (,real-complex-name float-op)
 468                              (:translate ,op)
 469                              (:args (x :scs (,real-sc ,real-constant-sc)
 470                                        :target r
 471                                        :load-if (not (sc-is x ,real-constant-sc)))
 472                                     (y :scs (,complex-sc ,complex-constant-sc)
 473                                        ,@(when commutativep '(:target r))
 474                                        :load-if (not (sc-is y ,complex-constant-sc))))
 475                              (:arg-types ,real-type ,complex-type)
 476                              (:results (r :scs (,complex-sc)
 477                                           ,@(unless commutativep '(:from (:argument 0)))))
 478                              (:result-types ,complex-type)
 479                              (:generator ,cost
 480                                ,(when commutativep
 481                                   `(when (location= y r)
 482                                      (rotatef x y)))
 483                                (load-into r x)
 484                                (when (sc-is y ,real-constant-sc ,complex-constant-sc)
 485                                  (setf y (register-inline-constant
 486                                           :aligned (tn-value y))))
 487                                (inst ,op-inst r y))))
 488
 489                        ,(when complex-real-name
 490                           `(define-vop (,complex-real-name float-op)
 491                              (:translate ,op)
 492                              (:args (x :scs (,complex-sc ,complex-constant-sc)
 493                                        :target r
 494                                        :load-if (not (sc-is x ,complex-constant-sc)))
 495                                     (y :scs (,real-sc ,real-constant-sc)
 496                                        ,@(when commutativep '(:target r))
 497                                        :load-if (not (sc-is y ,real-constant-sc))))
 498                              (:arg-types ,complex-type ,real-type)
 499                              (:results (r :scs (,complex-sc)
 500                                           ,@(unless commutativep '(:from (:argument 0)))))
 501                              (:result-types ,complex-type)
 502                              (:generator ,cost
 503                                ,(when commutativep
 504                                   `(when (location= y r)
 505                                      (rotatef x y)))
 506                                (load-into r x)
 507                                (when (sc-is y ,real-constant-sc ,complex-constant-sc)
 508                                  (setf y (register-inline-constant
 509                                           :aligned (tn-value y))))
 510                                (inst ,op-inst r y))))))
 511                    (commutativep ; must duplicate, but commutative
 512                     `(progn
 513                        ,(when real-complex-name
 514                           `(define-vop (,real-complex-name float-op)
 515                              (:translate ,op)
 516                              (:args (x :scs (,real-sc ,real-constant-sc)
 517                                        :target dup
 518                                        :load-if (not (sc-is x ,real-constant-sc)))
 519                                     (y :scs (,complex-sc ,complex-constant-sc)
 520                                        :target r
 521                                        :to  :result
 522                                        :load-if (not (sc-is y ,complex-constant-sc))))
 523                              (:arg-types ,real-type ,complex-type)
 524                              (:temporary (:sc ,complex-sc :target r
 525                                           :from (:argument 0)
 526                                           :to   :result)
 527                                          dup)
 528                              (:results (r :scs (,complex-sc)))
 529                              (:result-types ,complex-type)
 530                              (:generator ,cost
 531                                (if (sc-is x ,real-constant-sc)
 532                                    (inst ,complex-move-inst dup
 533                                          (register-inline-constant
 534                                           (complex (tn-value x) (tn-value x))))
 535                                    (let ((real x))
 536                                      ,duplicate-inst))
 537                                 ;; safe: dup /= y
 538                                 (when (location= dup r)
 539                                   (rotatef dup y))
 540                                 (if (sc-is y ,complex-constant-sc)
 541                                     (inst ,complex-move-inst r
 542                                           (register-inline-constant (tn-value y)))
 543                                     (move r y))
 544                                 (when (sc-is dup ,complex-constant-sc)
 545                                   (setf dup (register-inline-constant
 546                                              :aligned (tn-value dup))))
 547                                 (inst ,op-inst r dup))))
 548
 549                        ,(when complex-real-name
 550                           `(define-vop (,complex-real-name float-op)
 551                              (:translate ,op)
 552                              (:args (x :scs (,complex-sc ,complex-constant-sc)
 553                                        :target r
 554                                        :to  :result
 555                                        :load-if (not (sc-is x ,complex-constant-sc)))
 556                                     (y :scs (,real-sc ,real-constant-sc)
 557                                        :target dup
 558                                        :load-if (not (sc-is y ,real-constant-sc))))
 559                              (:arg-types ,complex-type ,real-type)
 560                              (:temporary (:sc ,complex-sc :target r
 561                                           :from (:argument 1)
 562                                           :to :result)
 563                                          dup)
 564                              (:results (r :scs (,complex-sc)))
 565                              (:result-types ,complex-type)
 566                              (:generator ,cost
 567                                (if (sc-is y ,real-constant-sc)
 568                                    (inst ,complex-move-inst dup
 569                                          (register-inline-constant
 570                                           (complex (tn-value y) (tn-value y))))
 571                                    (let ((real y))
 572                                      ,duplicate-inst))
 573                                 (when (location= dup r)
 574                                   (rotatef x dup))
 575                                 (if (sc-is x ,complex-constant-sc)
 576                                     (inst ,complex-move-inst r
 577                                           (register-inline-constant (tn-value x)))
 578                                     (move r x))
 579                                 (when (sc-is dup ,complex-constant-sc)
 580                                   (setf dup (register-inline-constant
 581                                              :aligned (tn-value dup))))
 582                                 (inst ,op-inst r dup))))))
 583                    (t ; duplicate, not commutative
 584                     `(progn
 585                        ,(when real-complex-name
 586                           `(define-vop (,real-complex-name float-op)
 587                              (:translate ,op)
 588                              (:args (x :scs (,real-sc ,real-constant-sc)
 589                                        :target r
 590                                        :load-if (not (sc-is x ,real-constant-sc)))
 591                                     (y :scs (,complex-sc ,complex-constant-sc)
 592                                        :to :result
 593                                        :load-if (not (sc-is y ,complex-constant-sc))))
 594                              (:arg-types ,real-type ,complex-type)
 595                              (:results (r :scs (,complex-sc) :from (:argument 0)))
 596                              (:result-types ,complex-type)
 597                              (:generator ,cost
 598                                (if (sc-is x ,real-constant-sc)
 599                                    (inst ,complex-move-inst dup
 600                                          (register-inline-constant
 601                                           (complex (tn-value x) (tn-value x))))
 602                                    (let ((real x)
 603                                          (dup  r))
 604                                      ,duplicate-inst))
 605                                (when (sc-is y ,complex-constant-sc)
 606                                  (setf y (register-inline-constant
 607                                           :aligned (tn-value y))))
 608                                (inst ,op-inst r y))))
 609
 610                        ,(when complex-real-name
 611                           `(define-vop (,complex-real-name float-op)
 612                              (:translate ,op)
 613                              (:args (x :scs (,complex-sc)
 614                                        :target r
 615                                        :to :eval)
 616                                     (y :scs (,real-sc ,real-constant-sc)
 617                                        :target dup
 618                                        :load-if (not (sc-is y ,complex-constant-sc))))
 619                              (:arg-types ,complex-type ,real-type)
 620                              (:temporary (:sc ,complex-sc :from (:argument 1))
 621                                          dup)
 622                              (:results (r :scs (,complex-sc) :from :eval))
 623                              (:result-types ,complex-type)
 624                              (:generator ,cost
 625                                (if (sc-is y ,real-constant-sc)
 626                                    (setf dup (register-inline-constant
 627                                               :aligned (complex (tn-value y)
 628                                                                 (tn-value y))))
 629                                    (let ((real y))
 630                                      ,duplicate-inst))
 631                                (move r x)
 632                                (inst ,op-inst r dup))))))))
 633            (def-real-complex-op (op commutativep duplicatep
 634                                     single-inst single-real-complex-name single-complex-real-name single-cost
 635                                     double-inst double-real-complex-name double-complex-real-name double-cost)
 636                `(progn
 637                   (frob ,op ,single-cost ,commutativep
 638                         ,(and duplicatep
 639                               `(progn
 640                                  (move dup real)
 641                                  (inst unpcklps dup dup)))
 642                         ,single-inst movss movq
 643                         single-reg fp-single-immediate single-float
 644                         complex-single-reg fp-complex-single-immediate complex-single-float
 645                         ,single-real-complex-name ,single-complex-real-name)
 646                   (frob ,op ,double-cost ,commutativep
 647                         ,(and duplicatep
 648                               `(progn
 649                                  (move dup real)
 650                                  (inst unpcklpd dup dup)))
 651                         ,double-inst movsd movapd
 652                         double-reg fp-double-immediate double-float
 653                         complex-double-reg fp-complex-double-immediate complex-double-float
 654                         ,double-real-complex-name ,double-complex-real-name))))
 655   (def-real-complex-op + t nil
 656     addps +/real-complex-single-float +/complex-real-single-float 3
 657     addpd +/real-complex-double-float +/complex-real-double-float 4)
 658   (def-real-complex-op - nil nil
 659     subps -/real-complex-single-float -/complex-real-single-float 3
 660     subpd -/real-complex-double-float -/complex-real-double-float 4)
 661   (def-real-complex-op * t t
 662     mulps */real-complex-single-float */complex-real-single-float 4
 663     mulpd */real-complex-double-float */complex-real-double-float 5)
 664   (def-real-complex-op / nil t
 665     nil nil nil nil
 666     divpd nil //complex-real-double-float 19))
 667
 668 (define-vop (//complex-real-single-float float-op)
 669   (:translate /)
 670   (:args (x :scs (complex-single-reg fp-complex-single-immediate fp-complex-single-zero)
 671             :to (:result 0)
 672             :target r
 673             :load-if (not (sc-is x fp-complex-single-immediate fp-complex-single-zero)))
 674          (y :scs (single-reg fp-single-immediate fp-single-zero)
 675             :target dup
 676             :load-if (not (sc-is y fp-single-immediate fp-single-zero))))
 677   (:arg-types complex-single-float single-float)
 678   (:temporary (:sc complex-single-reg :from (:argument 1)) dup)
 679   (:results (r :scs (complex-single-reg)))
 680   (:result-types complex-single-float)
 681   (:generator 12
 682     (flet ((duplicate (x)
 683              (let ((word (ldb (byte 64 0)
 684                               (logior (ash (single-float-bits (imagpart x)) 32)
 685                                       (ldb (byte 32 0)
 686                                            (single-float-bits (realpart x)))))))
 687                (register-inline-constant :oword (logior (ash word 64) word)))))
 688       (sc-case y
 689         (fp-single-immediate
 690          (setf dup (duplicate (complex (tn-value y) (tn-value y)))))
 691         (fp-single-zero
 692          (inst xorps dup dup))
 693         (t (move dup y)
 694            (inst shufps dup dup #b00000000)))
 695       (sc-case x
 696         (fp-complex-single-immediate
 697          (inst movaps r (duplicate (tn-value x))))
 698         (fp-complex-single-zero
 699          (inst xorps r r))
 700         (t
 701          (move r x)
 702          (inst unpcklpd r r)))
 703       (inst divps r dup)
 704       (inst movq r r))))
 705
 706 ;; Complex multiplication
 707 ;; r := rx * ry - ix * iy
 708 ;; i := rx * iy + ix * ry
 709 ;;
 710 ;; Transpose for SIMDness
 711 ;;  rx*ry    rx*iy
 712 ;; -ix*iy   +ix*ry
 713 ;;
 714 ;;  [rx rx] * [ry iy]
 715 ;;+ [ix ix] * [-iy ry]
 716 ;;       [r i]
 717
 718 (macrolet ((define-complex-* (name cost type sc tmp-p &body body)
 719                `(define-vop (,name float-op)
 720                   (:translate *)
 721                   (:args (x :scs (,sc) :target r)
 722                          (y :scs (,sc) :target copy-y))
 723                   (:arg-types ,type ,type)
 724                   (:temporary (:sc ,sc) imag)
 725                   (:temporary (:sc ,sc :from :eval) copy-y)
 726                   ,@(when tmp-p
 727                       `((:temporary (:sc ,sc) xmm)))
 728                   (:results (r :scs (,sc) :from :eval))
 729                   (:result-types ,type)
 730                   (:generator ,cost
 731                     (when (or (location= x copy-y)
 732                               (location= y r))
 733                       (rotatef x y))
 734                     ,@body))))
 735   (define-complex-* */complex-single-float 20
 736     complex-single-float complex-single-reg t
 737     (inst xorps xmm xmm)
 738     (move r x)
 739     (inst unpcklps r r)
 740     (move imag r)
 741     (inst unpckhpd imag xmm)
 742     (inst unpcklpd r    xmm)
 743     (move copy-y y)  ; y == r only if y == x == r
 744     (setf y copy-y)
 745
 746     (inst mulps r y)
 747
 748     (inst shufps y y #b11110001)
 749     (inst xorps y (register-inline-constant :oword (ash 1 31)))
 750
 751     (inst mulps imag y)
 752     (inst addps r imag))
 753   (define-complex-* */complex-double-float 25
 754     complex-double-float complex-double-reg nil
 755     (move imag x)
 756     (move r x)
 757     (move copy-y y)
 758     (setf y copy-y)
 759     (inst unpcklpd r r)
 760     (inst unpckhpd imag imag)
 761
 762     (inst mulpd r y)
 763
 764     (inst shufpd y y #b01)
 765     (inst xorpd y (register-inline-constant :oword (ash 1 63)))
 766
 767     (inst mulpd imag y)
 768     (inst addpd r imag)))
 769
 770 (define-vop (fsqrt)
 771   (:args (x :scs (double-reg)))
 772   (:results (y :scs (double-reg)))
 773   (:translate %sqrt)
 774   (:policy :fast-safe)
 775   (:arg-types double-float)
 776   (:result-types double-float)
 777   (:note "inline float arithmetic")
 778   (:vop-var vop)
 779   (:save-p :compute-only)
 780   (:generator 1
 781      (note-this-location vop :internal-error)
 782      (inst sqrtsd y x)))
 783 \f
 784 (macrolet ((frob ((name translate sc type) &body body)
 785              `(define-vop (,name)
 786                   (:args (x :scs (,sc) :target y))
 787                 (:results (y :scs (,sc)))
 788                 (:translate ,translate)
 789                 (:policy :fast-safe)
 790                 (:arg-types ,type)
 791                 (:result-types ,type)
 792                 (:note "inline float arithmetic")
 793                 (:vop-var vop)
 794                 (:save-p :compute-only)
 795                 (:generator 1
 796                             (note-this-location vop :internal-error)
 797                             ;; we should be able to do this better.  what we
 798                             ;; really would like to do is use the target as the
 799                             ;; temp whenever it's not also the source
 800                             (move y x)
 801                             ,@body))))
 802   (frob (%negate/double-float %negate double-reg double-float)
 803         (inst xorpd y (register-inline-constant :oword (ash 1 63))))
 804   (frob (%negate/complex-double-float %negate complex-double-reg complex-double-float)
 805         (inst xorpd y (register-inline-constant
 806                        :oword (logior (ash 1 127) (ash 1 63)))))
 807   (frob (conjugate/complex-double-float conjugate complex-double-reg complex-double-float)
 808         (inst xorpd y (register-inline-constant :oword (ash 1 127))))
 809   (frob (%negate/single-float %negate single-reg single-float)
 810         (inst xorps y (register-inline-constant :oword (ash 1 31))))
 811   (frob (%negate/complex-single-float %negate complex-single-reg complex-single-float)
 812         (inst xorps y (register-inline-constant
 813                        :oword (logior (ash 1 31) (ash 1 63)))))
 814   (frob (conjugate/complex-single-float conjugate complex-single-reg complex-single-float)
 815         (inst xorpd y (register-inline-constant :oword (ash 1 63))))
 816   (frob (abs/double-float abs  double-reg double-float)
 817         (inst andpd y (register-inline-constant :oword (ldb (byte 63 0) -1))))
 818   (frob (abs/single-float abs  single-reg single-float)
 819         (inst andps y (register-inline-constant :oword (ldb (byte 31 0) -1)))))
 820
 821 \f
 822 ;;;; comparison
 823
 824 (define-vop (float-compare)
 825   (:policy :fast-safe)
 826   (:vop-var vop)
 827   (:save-p :compute-only)
 828   (:note "inline float comparison"))
 829
 830 ;;; EQL
 831 (macrolet ((define-float-eql (name cost sc constant-sc type)
 832                `(define-vop (,name float-compare)
 833                   (:translate eql)
 834                   (:args (x :scs (,sc ,constant-sc)
 835                             :target mask
 836                             :load-if (not (sc-is x ,constant-sc)))
 837                          (y :scs (,sc ,constant-sc)
 838                             :target mask
 839                             :load-if (not (sc-is y ,constant-sc))))
 840                   (:arg-types ,type ,type)
 841                   (:temporary (:sc ,sc :from :eval) mask)
 842                   (:temporary (:sc any-reg) bits)
 843                   (:conditional :e)
 844                   (:generator ,cost
 845                     (when (or (location= y mask)
 846                               (not (xmm-register-p x)))
 847                       (rotatef x y))
 848                     (aver (xmm-register-p x))
 849                     (move mask x)
 850                     (when (sc-is y ,constant-sc)
 851                       (setf y (register-inline-constant :aligned (tn-value y))))
 852                     (inst pcmpeqd mask y)
 853                     (inst movmskps bits mask)
 854                     (inst cmp bits #b1111)))))
 855   (define-float-eql eql/single-float 4
 856     single-reg fp-single-immediate single-float)
 857   (define-float-eql eql/double-float 4
 858     double-reg fp-double-immediate double-float)
 859   (define-float-eql eql/complex-single-float 5
 860     complex-single-reg fp-complex-single-immediate complex-single-float)
 861   (define-float-eql eql/complex-double-float 5
 862     complex-double-reg fp-complex-double-immediate complex-double-float))
 863
 864 ;;; comiss and comisd can cope with one or other arg in memory: we
 865 ;;; could (should, indeed) extend these to cope with descriptor args
 866 ;;; and stack args
 867
 868 (define-vop (single-float-compare float-compare)
 869   (:args (x :scs (single-reg))
 870          (y :scs (single-reg single-stack fp-single-immediate)
 871             :load-if (not (sc-is y single-stack fp-single-immediate))))
 872   (:arg-types single-float single-float))
 873 (define-vop (double-float-compare float-compare)
 874   (:args (x :scs (double-reg))
 875          (y :scs (double-reg double-stack descriptor-reg fp-double-immediate)
 876             :load-if (not (sc-is y double-stack descriptor-reg fp-double-immediate))))
 877   (:arg-types double-float double-float))
 878
 879 (define-vop (=/single-float single-float-compare)
 880   (:translate =)
 881   (:args (x :scs (single-reg single-stack fp-single-immediate)
 882             :target xmm
 883             :load-if (not (sc-is x single-stack fp-single-immediate)))
 884          (y :scs (single-reg single-stack fp-single-immediate)
 885             :target xmm
 886             :load-if (not (sc-is y single-stack fp-single-immediate))))
 887   (:temporary (:sc single-reg :from :eval) xmm)
 888   (:info)
 889   (:conditional not :p :ne)
 890   (:vop-var vop)
 891   (:generator 3
 892     (when (or (location= y xmm)
 893               (and (not (xmm-register-p x))
 894                    (xmm-register-p y)))
 895       (rotatef x y))
 896     (sc-case x
 897       (single-reg (setf xmm x))
 898       (single-stack (inst movss xmm (ea-for-sf-stack x)))
 899       (fp-single-immediate
 900        (inst movss xmm (register-inline-constant (tn-value x)))))
 901     (sc-case y
 902       (single-stack
 903        (setf y (ea-for-sf-stack y)))
 904       (fp-single-immediate
 905        (setf y (register-inline-constant (tn-value y))))
 906       (t))
 907     (note-this-location vop :internal-error)
 908     (inst comiss xmm y)
 909     ;; if PF&CF, there was a NaN involved => not equal
 910     ;; otherwise, ZF => equal
 911     ))
 912
 913 (define-vop (=/double-float double-float-compare)
 914   (:translate =)
 915   (:args (x :scs (double-reg double-stack fp-double-immediate descriptor-reg)
 916             :target xmm
 917             :load-if (not (sc-is x double-stack fp-double-immediate descriptor-reg)))
 918          (y :scs (double-reg double-stack fp-double-immediate descriptor-reg)
 919             :target xmm
 920             :load-if (not (sc-is y double-stack fp-double-immediate descriptor-reg))))
 921   (:temporary (:sc double-reg :from :eval) xmm)
 922   (:info)
 923   (:conditional not :p :ne)
 924   (:vop-var vop)
 925   (:generator 3
 926     (when (or (location= y xmm)
 927               (and (not (xmm-register-p x))
 928                    (xmm-register-p y)))
 929       (rotatef x y))
 930     (sc-case x
 931       (double-reg
 932        (setf xmm x))
 933       (double-stack
 934        (inst movsd xmm (ea-for-df-stack x)))
 935       (fp-double-immediate
 936        (inst movsd xmm (register-inline-constant (tn-value x))))
 937       (descriptor-reg
 938        (inst movsd xmm (ea-for-df-desc x))))
 939     (sc-case y
 940       (double-stack
 941        (setf y (ea-for-df-stack y)))
 942       (fp-double-immediate
 943        (setf y (register-inline-constant (tn-value y))))
 944       (descriptor-reg
 945        (setf y (ea-for-df-desc y)))
 946       (t))
 947     (note-this-location vop :internal-error)
 948     (inst comisd xmm y)))
 949
 950 (macrolet ((define-complex-float-= (complex-complex-name complex-real-name real-complex-name
 951                                     real-sc real-constant-sc real-type
 952                                     complex-sc complex-constant-sc complex-type
 953                                     real-move-inst complex-move-inst
 954                                     cmp-inst mask-inst mask)
 955                `(progn
 956                   (define-vop (,complex-complex-name float-compare)
 957                     (:translate =)
 958                     (:args (x :scs (,complex-sc ,complex-constant-sc)
 959                               :target cmp
 960                               :load-if (not (sc-is x ,complex-constant-sc)))
 961                            (y :scs (,complex-sc ,complex-constant-sc)
 962                               :target cmp
 963                               :load-if (not (sc-is y ,complex-constant-sc))))
 964                     (:arg-types ,complex-type ,complex-type)
 965                     (:temporary (:sc ,complex-sc :from :eval) cmp)
 966                     (:temporary (:sc unsigned-reg) bits)
 967                     (:info)
 968                     (:conditional :e)
 969                     (:generator 3
 970                       (when (location= y cmp)
 971                         (rotatef x y))
 972                       (sc-case x
 973                         (,real-constant-sc
 974                          (inst ,real-move-inst cmp (register-inline-constant
 975                                                     (tn-value x))))
 976                         (,complex-constant-sc
 977                          (inst ,complex-move-inst cmp (register-inline-constant
 978                                                        (tn-value x))))
 979                         (t
 980                          (move cmp x)))
 981                       (when (sc-is y ,real-constant-sc ,complex-constant-sc)
 982                         (setf y (register-inline-constant :aligned (tn-value y))))
 983                       (note-this-location vop :internal-error)
 984                       (inst ,cmp-inst :eq cmp y)
 985                       (inst ,mask-inst bits cmp)
 986                       (inst cmp bits ,mask)))
 987                   (define-vop (,complex-real-name ,complex-complex-name)
 988                     (:args (x :scs (,complex-sc ,complex-constant-sc)
 989                               :target cmp
 990                               :load-if (not (sc-is x ,complex-constant-sc)))
 991                            (y :scs (,real-sc ,real-constant-sc)
 992                               :target cmp
 993                               :load-if (not (sc-is y ,real-constant-sc))))
 994                     (:arg-types ,complex-type ,real-type))
 995                   (define-vop (,real-complex-name ,complex-complex-name)
 996                     (:args (x :scs (,real-sc ,real-constant-sc)
 997                               :target cmp
 998                               :load-if (not (sc-is x ,real-constant-sc)))
 999                            (y :scs (,complex-sc ,complex-constant-sc)
1000                               :target cmp
1001                               :load-if (not (sc-is y ,complex-constant-sc))))
1002                     (:arg-types ,real-type ,complex-type)))))
1003   (define-complex-float-= =/complex-single-float =/complex-real-single-float =/real-complex-single-float
1004     single-reg fp-single-immediate single-float
1005     complex-single-reg fp-complex-single-immediate complex-single-float
1006     movss movq cmpps movmskps #b1111)
1007   (define-complex-float-= =/complex-double-float =/complex-real-double-float =/real-complex-double-float
1008     double-reg fp-double-immediate double-float
1009     complex-double-reg fp-complex-double-immediate complex-double-float
1010     movsd movapd cmppd movmskpd #b11))
1011
1012 (macrolet ((define-</> (op single-name double-name &rest flags)
1013                `(progn
1014                   (define-vop (,double-name double-float-compare)
1015                     (:translate ,op)
1016                     (:info)
1017                     (:conditional ,@flags)
1018                     (:generator 3
1019                       (sc-case y
1020                         (double-stack
1021                          (setf y (ea-for-df-stack y)))
1022                         (descriptor-reg
1023                          (setf y (ea-for-df-desc y)))
1024                         (fp-double-immediate
1025                          (setf y (register-inline-constant (tn-value y))))
1026                         (t))
1027                       (inst comisd x y)))
1028                   (define-vop (,single-name single-float-compare)
1029                     (:translate ,op)
1030                     (:info)
1031                     (:conditional ,@flags)
1032                     (:generator 3
1033                       (sc-case y
1034                         (single-stack
1035                          (setf y (ea-for-sf-stack y)))
1036                         (fp-single-immediate
1037                          (setf y (register-inline-constant (tn-value y))))
1038                         (t))
1039                       (inst comiss x y))))))
1040   (define-</> < <single-float <double-float not :p :nc)
1041   (define-</> > >single-float >double-float not :p :na))
1042
1043 \f
1044 ;;;; conversion
1045
1046 (macrolet ((frob (name translate inst to-sc to-type)
1047              `(define-vop (,name)
1048                 (:args (x :scs (signed-stack signed-reg)))
1049                 (:results (y :scs (,to-sc)))
1050                 (:arg-types signed-num)
1051                 (:result-types ,to-type)
1052                 (:policy :fast-safe)
1053                 (:note "inline float coercion")
1054                 (:translate ,translate)
1055                 (:vop-var vop)
1056                 (:save-p :compute-only)
1057                 (:generator 5
1058                   (note-this-location vop :internal-error)
1059                   (inst ,inst y x)))))
1060   (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
1061   (frob %double-float/signed %double-float cvtsi2sd double-reg double-float))
1062
1063 (macrolet ((frob (name translate inst from-scs from-type ea-func to-sc to-type)
1064              `(define-vop (,name)
1065                (:args (x :scs ,from-scs :target y))
1066                (:results (y :scs (,to-sc)))
1067                (:arg-types ,from-type)
1068                (:result-types ,to-type)
1069                (:policy :fast-safe)
1070                (:note "inline float coercion")
1071                (:translate ,translate)
1072                (:vop-var vop)
1073                (:save-p :compute-only)
1074                (:generator 2
1075                 (note-this-location vop :internal-error)
1076                 (inst ,inst y (sc-case x
1077                                 (,(first from-scs) x)
1078                                 (,(second from-scs) (,ea-func x))))))))
1079   (frob %single-float/double-float %single-float cvtsd2ss
1080         (double-reg double-stack) double-float ea-for-df-stack
1081         single-reg single-float)
1082
1083   (frob %double-float/single-float %double-float cvtss2sd
1084         (single-reg single-stack) single-float ea-for-sf-stack
1085         double-reg double-float))
1086
1087 (macrolet ((frob (trans inst from-scs from-type ea-func)
1088              `(define-vop (,(symbolicate trans "/" from-type))
1089                (:args (x :scs ,from-scs))
1090                (:results (y :scs (signed-reg)))
1091                (:arg-types ,from-type)
1092                (:result-types signed-num)
1093                (:translate ,trans)
1094                (:policy :fast-safe)
1095                (:note "inline float truncate")
1096                (:vop-var vop)
1097                (:save-p :compute-only)
1098                (:generator 5
1099                  (inst ,inst y (sc-case x
1100                                  (,(first from-scs) x)
1101                                  (,(second from-scs) (,ea-func x))))))))
1102   (frob %unary-truncate/single-float cvttss2si
1103         (single-reg single-stack) single-float ea-for-sf-stack)
1104   (frob %unary-truncate/double-float cvttsd2si
1105         (double-reg double-stack) double-float ea-for-df-stack)
1106
1107   (frob %unary-round cvtss2si
1108         (single-reg single-stack) single-float ea-for-sf-stack)
1109   (frob %unary-round cvtsd2si
1110         (double-reg double-stack) double-float ea-for-df-stack))
1111
1112 (define-vop (make-single-float)
1113   (:args (bits :scs (signed-reg) :target res
1114                :load-if (not (or (and (sc-is bits signed-stack)
1115                                       (sc-is res single-reg))
1116                                  (and (sc-is bits signed-stack)
1117                                       (sc-is res single-stack)
1118                                       (location= bits res))))))
1119   (:results (res :scs (single-reg single-stack)))
1120   (:arg-types signed-num)
1121   (:result-types single-float)
1122   (:translate make-single-float)
1123   (:policy :fast-safe)
1124   (:vop-var vop)
1125   (:generator 4
1126     (sc-case res
1127        (single-stack
1128         (sc-case bits
1129           (signed-reg
1130            (inst mov res bits))
1131           (signed-stack
1132            (aver (location= bits res)))))
1133        (single-reg
1134         (sc-case bits
1135           (signed-reg
1136            (inst movd res bits))
1137           (signed-stack
1138            (inst movd res bits)))))))
1139
1140 (define-vop (make-double-float)
1141   (:args (hi-bits :scs (signed-reg))
1142          (lo-bits :scs (unsigned-reg)))
1143   (:results (res :scs (double-reg)))
1144   (:temporary (:sc unsigned-reg) temp)
1145   (:arg-types signed-num unsigned-num)
1146   (:result-types double-float)
1147   (:translate make-double-float)
1148   (:policy :fast-safe)
1149   (:vop-var vop)
1150   (:generator 2
1151     (move temp hi-bits)
1152     (inst shl temp 32)
1153     (inst or temp lo-bits)
1154     (inst movd res temp)))
1155
1156 (define-vop (single-float-bits)
1157   (:args (float :scs (single-reg descriptor-reg)
1158                 :load-if (not (sc-is float single-stack))))
1159   (:results (bits :scs (signed-reg)))
1160   (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
1161   (:arg-types single-float)
1162   (:result-types signed-num)
1163   (:translate single-float-bits)
1164   (:policy :fast-safe)
1165   (:vop-var vop)
1166   (:generator 4
1167     (sc-case bits
1168       (signed-reg
1169        (sc-case float
1170          (single-reg
1171           (inst movss stack-temp float)
1172           (move bits stack-temp))
1173          (single-stack
1174           (move bits float))
1175          (descriptor-reg
1176           (move bits float)
1177           (inst shr bits 32))))
1178       (signed-stack
1179        (sc-case float
1180          (single-reg
1181           (inst movss bits float)))))
1182     ;; Sign-extend
1183     (inst shl bits 32)
1184     (inst sar bits 32)))
1185
1186 (define-vop (double-float-high-bits)
1187   (:args (float :scs (double-reg descriptor-reg)
1188                 :load-if (not (sc-is float double-stack))))
1189   (:results (hi-bits :scs (signed-reg)))
1190   (:temporary (:sc signed-stack :from :argument :to :result) temp)
1191   (:arg-types double-float)
1192   (:result-types signed-num)
1193   (:translate double-float-high-bits)
1194   (:policy :fast-safe)
1195   (:vop-var vop)
1196   (:generator 5
1197      (sc-case float
1198        (double-reg
1199         (inst movsd temp float)
1200         (move hi-bits temp))
1201        (double-stack
1202         (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float))))
1203        (descriptor-reg
1204         (loadw hi-bits float double-float-value-slot
1205                other-pointer-lowtag)))
1206      (inst sar hi-bits 32)))
1207
1208 (define-vop (double-float-low-bits)
1209   (:args (float :scs (double-reg descriptor-reg)
1210                 :load-if (not (sc-is float double-stack))))
1211   (:results (lo-bits :scs (unsigned-reg)))
1212   (:temporary (:sc signed-stack :from :argument :to :result) temp)
1213   (:arg-types double-float)
1214   (:result-types unsigned-num)
1215   (:translate double-float-low-bits)
1216   (:policy :fast-safe)
1217   (:vop-var vop)
1218   (:generator 5
1219      (sc-case float
1220        (double-reg
1221         (inst movsd temp float)
1222         (move lo-bits temp))
1223        (double-stack
1224         (loadw lo-bits ebp-tn (frame-word-offset (tn-offset float))))
1225        (descriptor-reg
1226         (loadw lo-bits float double-float-value-slot
1227                other-pointer-lowtag)))
1228      (inst shl lo-bits 32)
1229      (inst shr lo-bits 32)))
1230
1231 \f
1232
1233 ;;;; complex float VOPs
1234
1235 (define-vop (make-complex-single-float)
1236   (:translate complex)
1237   (:args (real :scs (single-reg fp-single-zero)
1238                :target r
1239                :load-if (not (sc-is real fp-single-zero)))
1240          (imag :scs (single-reg fp-single-zero)
1241                :load-if (not (sc-is imag fp-single-zero))))
1242   (:arg-types single-float single-float)
1243   (:results (r :scs (complex-single-reg) :from (:argument 0)))
1244   (:result-types complex-single-float)
1245   (:note "inline complex single-float creation")
1246   (:policy :fast-safe)
1247   (:generator 5
1248     (cond ((sc-is real fp-single-zero)
1249            (inst xorps r r)
1250            (unless (sc-is imag fp-single-zero)
1251              (inst unpcklps r imag)))
1252           ((location= real imag)
1253            (move r real)
1254            (inst unpcklps r r))
1255           (t
1256            (move r real)
1257            (unless (sc-is imag fp-single-zero)
1258              (inst unpcklps r imag))))))
1259
1260 (define-vop (make-complex-double-float)
1261   (:translate complex)
1262   (:args (real :scs (double-reg fp-double-zero)
1263                :target r
1264                :load-if (not (sc-is real fp-double-zero)))
1265          (imag :scs (double-reg fp-double-zero)
1266                :load-if (not (sc-is imag fp-double-zero))))
1267   (:arg-types double-float double-float)
1268   (:results (r :scs (complex-double-reg) :from (:argument 0)))
1269   (:result-types complex-double-float)
1270   (:note "inline complex double-float creation")
1271   (:policy :fast-safe)
1272   (:generator 5
1273     (cond ((sc-is real fp-double-zero)
1274            (inst xorpd r r)
1275            (unless (sc-is imag fp-double-zero)
1276              (inst unpcklpd r imag)))
1277           ((location= real imag)
1278            (move r real)
1279            (inst unpcklpd r r))
1280           (t
1281            (move r real)
1282            (unless (sc-is imag fp-double-zero)
1283              (inst unpcklpd r imag))))))
1284
1285 (define-vop (complex-float-value)
1286   (:args (x :target r))
1287   (:temporary (:sc complex-double-reg) zero)
1288   (:results (r))
1289   (:variant-vars offset)
1290   (:policy :fast-safe)
1291   (:generator 3
1292     (cond ((sc-is x complex-double-reg)
1293            (move r x)
1294            (inst xorpd zero zero)
1295            (ecase offset
1296              (0 (inst unpcklpd r zero))
1297              (1 (inst unpckhpd r zero))))
1298           ((sc-is x complex-single-reg)
1299            (move r x)
1300            (ecase offset
1301              (0 (inst shufps r r #b11111100))
1302              (1 (inst shufps r r #b11111101))))
1303           ((sc-is r single-reg)
1304            (let ((ea (sc-case x
1305                        (complex-single-stack
1306                         (ecase offset
1307                           (0 (ea-for-csf-real-stack x))
1308                           (1 (ea-for-csf-imag-stack x))))
1309                        (descriptor-reg
1310                         (ecase offset
1311                           (0 (ea-for-csf-real-desc x))
1312                           (1 (ea-for-csf-imag-desc x)))))))
1313              (inst movss r ea)))
1314           ((sc-is r double-reg)
1315            (let ((ea (sc-case x
1316                        (complex-double-stack
1317                         (ecase offset
1318                           (0 (ea-for-cdf-real-stack x))
1319                           (1 (ea-for-cdf-imag-stack x))))
1320                        (descriptor-reg
1321                         (ecase offset
1322                           (0 (ea-for-cdf-real-desc x))
1323                           (1 (ea-for-cdf-imag-desc x)))))))
1324              (inst movsd r ea)))
1325           (t (error "COMPLEX-FLOAT-VALUE VOP failure")))))
1326
1327 (define-vop (realpart/complex-single-float complex-float-value)
1328   (:translate realpart)
1329   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
1330             :target r))
1331   (:arg-types complex-single-float)
1332   (:results (r :scs (single-reg)))
1333   (:result-types single-float)
1334   (:note "complex float realpart")
1335   (:variant 0))
1336
1337 (define-vop (realpart/complex-double-float complex-float-value)
1338   (:translate realpart)
1339   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
1340             :target r))
1341   (:arg-types complex-double-float)
1342   (:results (r :scs (double-reg)))
1343   (:result-types double-float)
1344   (:note "complex float realpart")
1345   (:variant 0))
1346
1347 (define-vop (imagpart/complex-single-float complex-float-value)
1348   (:translate imagpart)
1349   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
1350             :target r))
1351   (:arg-types complex-single-float)
1352   (:results (r :scs (single-reg)))
1353   (:result-types single-float)
1354   (:note "complex float imagpart")
1355   (:variant 1))
1356
1357 (define-vop (imagpart/complex-double-float complex-float-value)
1358   (:translate imagpart)
1359   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
1360             :target r))
1361   (:arg-types complex-double-float)
1362   (:results (r :scs (double-reg)))
1363   (:result-types double-float)
1364   (:note "complex float imagpart")
1365   (:variant 1))
1366
1367 \f
1368 ;;; hack dummy VOPs to bias the representation selection of their
1369 ;;; arguments towards a FP register, which can help avoid consing at
1370 ;;; inappropriate locations
1371 (defknown double-float-reg-bias (double-float) (values))
1372 (define-vop (double-float-reg-bias)
1373   (:translate double-float-reg-bias)
1374   (:args (x :scs (double-reg double-stack) :load-if nil))
1375   (:arg-types double-float)
1376   (:policy :fast-safe)
1377   (:note "inline dummy FP register bias")
1378   (:ignore x)
1379   (:generator 0))
1380 (defknown single-float-reg-bias (single-float) (values))
1381 (define-vop (single-float-reg-bias)
1382   (:translate single-float-reg-bias)
1383   (:args (x :scs (single-reg single-stack) :load-if nil))
1384   (:arg-types single-float)
1385   (:policy :fast-safe)
1386   (:note "inline dummy FP register bias")
1387   (:ignore x)
1388   (:generator 0))
1389
1390 (defknown swap-complex ((complex float)) (complex float)
1391     (foldable flushable movable always-translatable))
1392 (defoptimizer (swap-complex derive-type) ((x))
1393   (sb!c::lvar-type x))
1394 (defun swap-complex (x)
1395   (complex (imagpart x) (realpart x)))
1396 (define-vop (swap-complex-single-float)
1397   (:translate swap-complex)
1398   (:policy :fast-safe)
1399   (:args (x :scs (complex-single-reg) :target r))
1400   (:arg-types complex-single-float)
1401   (:results (r :scs (complex-single-reg)))
1402   (:result-types complex-single-float)
1403   (:generator 2
1404      (move r x)
1405      (inst shufps r r #b11110001)))
1406 (define-vop (swap-complex-double-float)
1407   (:translate swap-complex)
1408   (:policy :fast-safe)
1409   (:args (x :scs (complex-double-reg) :target r))
1410   (:arg-types complex-double-float)
1411   (:results (r :scs (complex-double-reg)))
1412   (:result-types complex-double-float)
1413   (:generator 2
1414      (move r x)
1415      (inst shufpd r r #b01)))