src/compiler/x86-64/move.lisp

   1 ;;;; the x86 VM definition of operand loading/saving and the MOVE vop
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 (define-move-fun (load-immediate 1) (vop x y)
  15   ((immediate)
  16    (any-reg descriptor-reg))
  17   (let ((val (tn-value x)))
  18     (etypecase val
  19       (integer
  20        (if (zerop val)
  21            (inst xor y y)
  22          (inst mov y (fixnumize val))))
  23       (symbol
  24        (load-symbol y val))
  25       (character
  26        (inst mov y (logior (ash (char-code val) n-widetag-bits)
  27                            character-widetag))))))
  28
  29 (define-move-fun (load-number 1) (vop x y)
  30   ((immediate) (signed-reg unsigned-reg))
  31   (inst mov y (tn-value x)))
  32
  33 (define-move-fun (load-character 1) (vop x y)
  34   ((immediate) (character-reg))
  35   (inst mov y (char-code (tn-value x))))
  36
  37 (define-move-fun (load-system-area-pointer 1) (vop x y)
  38   ((immediate) (sap-reg))
  39   (inst mov y (sap-int (tn-value x))))
  40
  41 (define-move-fun (load-constant 5) (vop x y)
  42   ((constant) (descriptor-reg any-reg))
  43   (inst mov y x))
  44
  45 (define-move-fun (load-stack 5) (vop x y)
  46   ((control-stack) (any-reg descriptor-reg)
  47    (character-stack) (character-reg)
  48    (sap-stack) (sap-reg)
  49    (signed-stack) (signed-reg)
  50    (unsigned-stack) (unsigned-reg))
  51   (inst mov y x))
  52
  53 (define-move-fun (store-stack 5) (vop x y)
  54   ((any-reg descriptor-reg) (control-stack)
  55    (character-reg) (character-stack)
  56    (sap-reg) (sap-stack)
  57    (signed-reg) (signed-stack)
  58    (unsigned-reg) (unsigned-stack))
  59   (inst mov y x))
  60 \f
  61 ;;;; the MOVE VOP
  62 (define-vop (move)
  63   (:args (x :scs (any-reg descriptor-reg immediate) :target y
  64             :load-if (not (location= x y))))
  65   (:results (y :scs (any-reg descriptor-reg)
  66                :load-if
  67                (not (or (location= x y)
  68                         (and (sc-is x any-reg descriptor-reg immediate)
  69                              (sc-is y control-stack))))))
  70   (:temporary (:sc unsigned-reg) temp)
  71   (:effects)
  72   (:affected)
  73   (:generator 0
  74     (if (and (sc-is x immediate)
  75              (sc-is y any-reg descriptor-reg control-stack))
  76         (let ((val (tn-value x)))
  77           (etypecase val
  78             (integer
  79              (if (and (zerop val) (sc-is y any-reg descriptor-reg))
  80                  (inst xor y y)
  81                  (move-immediate y (fixnumize val) temp)))
  82             (symbol
  83              (inst mov y (+ nil-value (static-symbol-offset val))))
  84             (character
  85              (inst mov y (logior (ash (char-code val) n-widetag-bits)
  86                                  character-widetag)))))
  87         (move y x))))
  88
  89 (define-move-vop move :move
  90   (any-reg descriptor-reg immediate)
  91   (any-reg descriptor-reg))
  92
  93 ;;; Make MOVE the check VOP for T so that type check generation
  94 ;;; doesn't think it is a hairy type. This also allows checking of a
  95 ;;; few of the values in a continuation to fall out.
  96 (primitive-type-vop move (:check) t)
  97
  98 (defun move-immediate (target val &optional tmp-tn)
  99   (cond
 100     ;; If target is a register, we can just mov it there directly
 101     ((and (tn-p target)
 102           (sc-is target signed-reg unsigned-reg descriptor-reg any-reg))
 103      (inst mov target val))
 104     ;; Likewise if the value is small enough.
 105     ((typep val '(signed-byte 31))
 106      (inst mov target val))
 107     ;; Otherwise go through the temporary register
 108     (tmp-tn
 109      (inst mov tmp-tn val)
 110      (inst mov target tmp-tn))
 111     (t
 112      (error "~A is not a register, no temporary given, and immediate ~A too large" target val))))
 113
 114 ;;; The MOVE-ARG VOP is used for moving descriptor values into
 115 ;;; another frame for argument or known value passing.
 116 ;;;
 117 ;;; Note: It is not going to be possible to move a constant directly
 118 ;;; to another frame, except if the destination is a register and in
 119 ;;; this case the loading works out.
 120 (define-vop (move-arg)
 121   (:args (x :scs (any-reg descriptor-reg immediate) :target y
 122             :load-if (not (and (sc-is y any-reg descriptor-reg)
 123                                (sc-is x control-stack))))
 124          (fp :scs (any-reg)
 125              :load-if (not (sc-is y any-reg descriptor-reg))))
 126   (:results (y))
 127   (:generator 0
 128     (sc-case y
 129       ((any-reg descriptor-reg)
 130        (if (sc-is x immediate)
 131            (let ((val (tn-value x)))
 132              (etypecase val
 133                ((integer 0 0)
 134                 (inst xor y y))
 135                ((or (signed-byte 29) (unsigned-byte 29))
 136                 (inst mov y (fixnumize val)))
 137                (integer
 138                 (move-immediate y (fixnumize val)))
 139                (symbol
 140                 (load-symbol y val))
 141                (character
 142                 (inst mov y (logior (ash (char-code val) n-widetag-bits)
 143                                     character-widetag)))))
 144            (move y x)))
 145       ((control-stack)
 146        (if (sc-is x immediate)
 147            (let ((val (tn-value x)))
 148              (if (= (tn-offset fp) esp-offset)
 149                  ;; C-call
 150                  (etypecase val
 151                    (integer
 152                     (storew (fixnumize val) fp (tn-offset y)))
 153                    (symbol
 154                     (storew (+ nil-value (static-symbol-offset val))
 155                             fp (tn-offset y)))
 156                    (character
 157                     (storew (logior (ash (char-code val) n-widetag-bits)
 158                                     character-widetag)
 159                             fp (tn-offset y))))
 160                ;; Lisp stack
 161                (etypecase val
 162                  (integer
 163                   (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
 164                  (symbol
 165                   (storew (+ nil-value (static-symbol-offset val))
 166                           fp (- (1+ (tn-offset y)))))
 167                  (character
 168                   (storew (logior (ash (char-code val) n-widetag-bits)
 169                                   character-widetag)
 170                           fp (- (1+ (tn-offset y))))))))
 171          (if (= (tn-offset fp) esp-offset)
 172              ;; C-call
 173              (storew x fp (tn-offset y))
 174            ;; Lisp stack
 175            (storew x fp (- (1+ (tn-offset y))))))))))
 176
 177 (define-move-vop move-arg :move-arg
 178   (any-reg descriptor-reg)
 179   (any-reg descriptor-reg))
 180 \f
 181 ;;;; ILLEGAL-MOVE
 182
 183 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
 184 ;;; be written legally due to a type error. An error is signalled
 185 ;;; before this VOP is so we don't need to do anything (not that there
 186 ;;; would be anything sensible to do anyway.)
 187 (define-vop (illegal-move)
 188   (:args (x) (type))
 189   (:results (y))
 190   (:ignore y)
 191   (:vop-var vop)
 192   (:save-p :compute-only)
 193   (:generator 666
 194     (error-call vop object-not-type-error x type)))
 195 \f
 196 ;;;; moves and coercions
 197
 198 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
 199 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw
 200 ;;; integer to a tagged bignum or fixnum.
 201
 202 ;;; Arg is a fixnum, so just shift it. We need a type restriction
 203 ;;; because some possible arg SCs (control-stack) overlap with
 204 ;;; possible bignum arg SCs.
 205 (define-vop (move-to-word/fixnum)
 206   (:args (x :scs (any-reg descriptor-reg) :target y
 207             :load-if (not (location= x y))))
 208   (:results (y :scs (signed-reg unsigned-reg)
 209                :load-if (not (location= x y))))
 210   (:arg-types tagged-num)
 211   (:note "fixnum untagging")
 212   (:generator 1
 213     (move y x)
 214     (inst sar y  (1- n-lowtag-bits))))
 215 (define-move-vop move-to-word/fixnum :move
 216   (any-reg descriptor-reg) (signed-reg unsigned-reg))
 217
 218 ;;; Arg is a non-immediate constant, load it.
 219 (define-vop (move-to-word-c)
 220   (:args (x :scs (constant)))
 221   (:results (y :scs (signed-reg unsigned-reg)))
 222   (:note "constant load")
 223   (:generator 1
 224     (inst mov y (tn-value x))))
 225 (define-move-vop move-to-word-c :move
 226   (constant) (signed-reg unsigned-reg))
 227
 228
 229 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
 230 (define-vop (move-to-word/integer)
 231   (:args (x :scs (descriptor-reg) :target eax))
 232   (:results (y :scs (signed-reg unsigned-reg)))
 233   (:note "integer to untagged word coercion")
 234   (:temporary (:sc unsigned-reg :offset eax-offset
 235                    :from (:argument 0) :to (:result 0) :target y) eax)
 236   (:generator 4
 237     (move eax x)
 238     (inst test al-tn 7)                 ; a symbolic constant for this
 239     (inst jmp :z FIXNUM)                ; would be nice
 240     (loadw y eax bignum-digits-offset other-pointer-lowtag)
 241     (inst jmp DONE)
 242     FIXNUM
 243     (inst sar eax (1- n-lowtag-bits))
 244     (move y eax)
 245     DONE))
 246 (define-move-vop move-to-word/integer :move
 247   (descriptor-reg) (signed-reg unsigned-reg))
 248
 249
 250 ;;; Result is a fixnum, so we can just shift. We need the result type
 251 ;;; restriction because of the control-stack ambiguity noted above.
 252 (define-vop (move-from-word/fixnum)
 253   (:args (x :scs (signed-reg unsigned-reg) :target y
 254             :load-if (not (location= x y))))
 255   (:results (y :scs (any-reg descriptor-reg)
 256                :load-if (not (location= x y))))
 257   (:result-types tagged-num)
 258   (:note "fixnum tagging")
 259   (:generator 1
 260     (cond ((and (sc-is x signed-reg unsigned-reg)
 261                 (not (location= x y)))
 262            ;; Uses 7 bytes, but faster on the Pentium
 263            (inst lea y (make-ea :qword :index x :scale 8)))
 264           (t
 265            ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
 266            (move y x)
 267            (inst shl y (1- n-lowtag-bits))))))
 268 (define-move-vop move-from-word/fixnum :move
 269   (signed-reg unsigned-reg) (any-reg descriptor-reg))
 270
 271 ;;; Result may be a bignum, so we have to check. Use a worst-case cost
 272 ;;; to make sure people know they may be number consing.
 273 (define-vop (move-from-signed)
 274   (:args (x :scs (signed-reg unsigned-reg) :to :result))
 275   (:results (y :scs (any-reg descriptor-reg) :from :argument))
 276   (:note "signed word to integer coercion")
 277   (:node-var node)
 278   (:generator 20
 279      (aver (not (location= x y)))
 280      (let ((bignum (gen-label))
 281            (done (gen-label)))
 282        (inst mov y x)
 283        ;; We can't do the overflow check with SHL Y, 3, since the
 284        ;; state of the overflow flag is only reliably set when
 285        ;; shifting by 1. There used to be code here for doing "shift
 286        ;; by one, check whether it overflowed" three times. But on all
 287        ;; x86-64 processors IMUL is a reasonably fast instruction, so
 288        ;; we can just do a straight multiply instead of trying to
 289        ;; optimize it to a shift. This is both faster and smaller.
 290        ;; -- JES, 2006-07-08
 291        (inst imul y 8)
 292        (inst jmp :o bignum)
 293        (emit-label done)
 294
 295        (assemble (*elsewhere*)
 296           (emit-label bignum)
 297           (with-fixed-allocation
 298               (y bignum-widetag (+ bignum-digits-offset 1) node)
 299             (storew x y bignum-digits-offset other-pointer-lowtag))
 300           (inst jmp done)))))
 301 (define-move-vop move-from-signed :move
 302   (signed-reg) (descriptor-reg))
 303
 304 ;;; Check for fixnum, and possibly allocate one or two word bignum
 305 ;;; result. Use a worst-case cost to make sure people know they may be
 306 ;;; number consing.
 307
 308 (define-vop (move-from-unsigned)
 309   (:args (x :scs (signed-reg unsigned-reg) :to :save))
 310   (:temporary (:sc unsigned-reg) alloc)
 311   (:results (y :scs (any-reg descriptor-reg)))
 312   (:node-var node)
 313   (:note "unsigned word to integer coercion")
 314   (:generator 20
 315     (aver (not (location= x y)))
 316     (aver (not (location= x alloc)))
 317     (aver (not (location= y alloc)))
 318     (let ((bignum (gen-label))
 319           (done (gen-label))
 320           (one-word-bignum (gen-label))
 321           (L1 (gen-label)))
 322       (inst bsr y x)                    ;find msb
 323       (inst cmov :z y x)
 324       (inst cmp y 60)
 325       (inst jmp :ae bignum)
 326       (inst lea y (make-ea :qword :index x :scale 8))
 327       (emit-label done)
 328       (assemble (*elsewhere*)
 329          (emit-label bignum)
 330          ;; Note: As on the mips port, space for a two word bignum is
 331          ;; always allocated and the header size is set to either one
 332          ;; or two words as appropriate.
 333          (inst cmp y 63)
 334          (inst jmp :l one-word-bignum)
 335          ;; two word bignum
 336          (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
 337                                   n-widetag-bits)
 338                              bignum-widetag))
 339          (inst jmp L1)
 340          (emit-label one-word-bignum)
 341          (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
 342                                   n-widetag-bits)
 343                              bignum-widetag))
 344          (emit-label L1)
 345          (pseudo-atomic
 346           (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
 347           (storew y alloc)
 348           (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
 349           (storew x y bignum-digits-offset other-pointer-lowtag))
 350          (inst jmp done)))))
 351 (define-move-vop move-from-unsigned :move
 352   (unsigned-reg) (descriptor-reg))
 353
 354 ;;; Move untagged numbers.
 355 (define-vop (word-move)
 356   (:args (x :scs (signed-reg unsigned-reg) :target y
 357             :load-if (not (location= x y))))
 358   (:results (y :scs (signed-reg unsigned-reg)
 359                :load-if
 360                (not (or (location= x y)
 361                         (and (sc-is x signed-reg unsigned-reg)
 362                              (sc-is y signed-stack unsigned-stack))))))
 363   (:effects)
 364   (:affected)
 365   (:note "word integer move")
 366   (:generator 0
 367     (move y x)))
 368 (define-move-vop word-move :move
 369   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
 370
 371 ;;; Move untagged number arguments/return-values.
 372 (define-vop (move-word-arg)
 373   (:args (x :scs (signed-reg unsigned-reg) :target y)
 374          (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
 375   (:results (y))
 376   (:note "word integer argument move")
 377   (:generator 0
 378     (sc-case y
 379       ((signed-reg unsigned-reg)
 380        (move y x))
 381       ((signed-stack unsigned-stack)
 382        (if (= (tn-offset fp) esp-offset)
 383            (storew x fp (tn-offset y))  ; c-call
 384            (storew x fp (- (1+ (tn-offset y)))))))))
 385 (define-move-vop move-word-arg :move-arg
 386   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
 387
 388 ;;; Use standard MOVE-ARG and coercion to move an untagged number
 389 ;;; to a descriptor passing location.
 390 (define-move-vop move-arg :move-arg
 391   (signed-reg unsigned-reg) (any-reg descriptor-reg))