src/compiler/x86/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 (encode-value-if-immediate x)))
  18     (if (zerop val)
  19         (inst xor y y)
  20         (inst mov y val))))
  21
  22 (define-move-fun (load-number 1) (vop x y)
  23   ((immediate) (signed-reg unsigned-reg))
  24   (let ((val (tn-value x)))
  25     (if (zerop val)
  26         (inst xor y y)
  27         (inst mov y val))))
  28
  29 (define-move-fun (load-character 1) (vop x y)
  30   ((immediate) (character-reg))
  31   (inst mov y (char-code (tn-value x))))
  32
  33 (define-move-fun (load-system-area-pointer 1) (vop x y)
  34   ((immediate) (sap-reg))
  35   (inst mov y (sap-int (tn-value x))))
  36
  37 (define-move-fun (load-constant 5) (vop x y)
  38   ((constant) (descriptor-reg any-reg))
  39   (inst mov y x))
  40
  41 (define-move-fun (load-stack 5) (vop x y)
  42   ((control-stack) (any-reg descriptor-reg)
  43    (character-stack) (character-reg)
  44    (sap-stack) (sap-reg)
  45    (signed-stack) (signed-reg)
  46    (unsigned-stack) (unsigned-reg))
  47   (inst mov y x))
  48
  49 (define-move-fun (store-stack 5) (vop x y)
  50   ((any-reg descriptor-reg) (control-stack)
  51    (character-reg) (character-stack)
  52    (sap-reg) (sap-stack)
  53    (signed-reg) (signed-stack)
  54    (unsigned-reg) (unsigned-stack))
  55   (inst mov y x))
  56 \f
  57 ;;;; the MOVE VOP
  58 (define-vop (move)
  59   (:args (x :scs (any-reg descriptor-reg immediate) :target y
  60             :load-if (not (location= x y))))
  61   (:results (y :scs (any-reg descriptor-reg)
  62                :load-if
  63                (not (or (location= x y)
  64                         (and (sc-is x any-reg descriptor-reg immediate)
  65                              (sc-is y control-stack))))))
  66   (:effects)
  67   (:affected)
  68   (:generator 0
  69     (if (and (sc-is x immediate)
  70              (sc-is y any-reg descriptor-reg control-stack))
  71         (let ((val (encode-value-if-immediate x)))
  72           (if (and (zerop val) (sc-is y any-reg descriptor-reg))
  73               (inst xor y y)
  74               (inst mov y val)))
  75       (move y x))))
  76
  77 (define-move-vop move :move
  78   (any-reg descriptor-reg immediate)
  79   (any-reg descriptor-reg))
  80
  81 ;;; Make MOVE the check VOP for T so that type check generation
  82 ;;; doesn't think it is a hairy type. This also allows checking of a
  83 ;;; few of the values in a continuation to fall out.
  84 (primitive-type-vop move (:check) t)
  85
  86 ;;; The MOVE-ARG VOP is used for moving descriptor values into
  87 ;;; another frame for argument or known value passing.
  88 ;;;
  89 ;;; Note: It is not going to be possible to move a constant directly
  90 ;;; to another frame, except if the destination is a register and in
  91 ;;; this case the loading works out.
  92 (define-vop (move-arg)
  93   (:args (x :scs (any-reg descriptor-reg immediate) :target y
  94             :load-if (not (and (sc-is y any-reg descriptor-reg)
  95                                (sc-is x control-stack))))
  96          (fp :scs (any-reg)
  97              :load-if (not (sc-is y any-reg descriptor-reg))))
  98   (:results (y))
  99   (:generator 0
 100     (sc-case y
 101       ((any-reg descriptor-reg)
 102        (if (sc-is x immediate)
 103            (let ((val (encode-value-if-immediate x)))
 104              (if (zerop val)
 105                  (inst xor y y)
 106                  (inst mov y val)))
 107          (move y x)))
 108       ((control-stack)
 109        (let ((frame-offset (if (= (tn-offset fp) esp-offset)
 110                                ;; C-call
 111                                (tn-offset y)
 112                                ;; Lisp stack
 113                                (frame-word-offset (tn-offset y)))))
 114          (storew (encode-value-if-immediate x) fp frame-offset))))))
 115
 116 (define-move-vop move-arg :move-arg
 117   (any-reg descriptor-reg)
 118   (any-reg descriptor-reg))
 119 \f
 120 ;;;; ILLEGAL-MOVE
 121
 122 ;;; This VOP exists just to begin the lifetime of a TN that couldn't
 123 ;;; be written legally due to a type error. An error is signalled
 124 ;;; before this VOP is so we don't need to do anything (not that there
 125 ;;; would be anything sensible to do anyway.)
 126 (define-vop (illegal-move)
 127   (:args (x) (type))
 128   (:results (y))
 129   (:ignore y)
 130   (:vop-var vop)
 131   (:save-p :compute-only)
 132   (:generator 666
 133     (error-call vop object-not-type-error x type)))
 134 \f
 135 ;;;; moves and coercions
 136
 137 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
 138 ;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw
 139 ;;; integer to a tagged bignum or fixnum.
 140
 141 ;;; Arg is a fixnum, so just shift it. We need a type restriction
 142 ;;; because some possible arg SCs (control-stack) overlap with
 143 ;;; possible bignum arg SCs.
 144 (define-vop (move-to-word/fixnum)
 145   (:args (x :scs (any-reg descriptor-reg) :target y
 146             :load-if (not (location= x y))))
 147   (:results (y :scs (signed-reg unsigned-reg)
 148                :load-if (not (location= x y))))
 149   (:arg-types tagged-num)
 150   (:note "fixnum untagging")
 151   (:generator 1
 152     (move y x)
 153     (inst sar y 2)))
 154 (define-move-vop move-to-word/fixnum :move
 155   (any-reg descriptor-reg) (signed-reg unsigned-reg))
 156
 157 ;;; Arg is a non-immediate constant, load it.
 158 (define-vop (move-to-word-c)
 159   (:args (x :scs (constant)))
 160   (:results (y :scs (signed-reg unsigned-reg)))
 161   (:note "constant load")
 162   (:generator 1
 163     (inst mov y (tn-value x))))
 164 (define-move-vop move-to-word-c :move
 165   (constant) (signed-reg unsigned-reg))
 166
 167
 168 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
 169 (define-vop (move-to-word/integer)
 170   (:args (x :scs (descriptor-reg) :target eax))
 171   (:results (y :scs (signed-reg unsigned-reg)))
 172   (:note "integer to untagged word coercion")
 173   (:temporary (:sc unsigned-reg :offset eax-offset
 174                    :from (:argument 0) :to (:result 0) :target y) eax)
 175   (:generator 4
 176     (move eax x)
 177     (inst test al-tn 3)
 178     (inst jmp :z fixnum)
 179     (loadw y eax bignum-digits-offset other-pointer-lowtag)
 180     (inst jmp done)
 181     FIXNUM
 182     (inst sar eax 2)
 183     (move y eax)
 184     DONE))
 185 (define-move-vop move-to-word/integer :move
 186   (descriptor-reg) (signed-reg unsigned-reg))
 187
 188
 189 ;;; Result is a fixnum, so we can just shift. We need the result type
 190 ;;; restriction because of the control-stack ambiguity noted above.
 191 (define-vop (move-from-word/fixnum)
 192   (:args (x :scs (signed-reg unsigned-reg) :target y
 193             :load-if (not (location= x y))))
 194   (:results (y :scs (any-reg descriptor-reg)
 195                :load-if (not (location= x y))))
 196   (:result-types tagged-num)
 197   (:note "fixnum tagging")
 198   (:generator 1
 199     (cond ((and (sc-is x signed-reg unsigned-reg)
 200                 (not (location= x y)))
 201            ;; Uses 7 bytes, but faster on the Pentium
 202            (inst lea y (make-ea :dword :index x :scale 4)))
 203           (t
 204            ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
 205            (move y x)
 206            (inst shl y 2)))))
 207 (define-move-vop move-from-word/fixnum :move
 208   (signed-reg unsigned-reg) (any-reg descriptor-reg))
 209
 210 ;;; Result may be a bignum, so we have to check. Use a worst-case cost
 211 ;;; to make sure people know they may be number consing.
 212 ;;;
 213 ;;; KLUDGE: I assume this is suppressed in favor of the "faster inline
 214 ;;; version" below. (See also mysterious comment "we don't want a VOP
 215 ;;; on this one" on DEFINE-ASSEMBLY-ROUTINE (MOVE-FROM-SIGNED) in
 216 ;;; "src/assembly/x86/alloc.lisp".) -- WHN 19990916
 217 #+nil
 218 (define-vop (move-from-signed)
 219   (:args (x :scs (signed-reg unsigned-reg) :target eax))
 220   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
 221   (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y)
 222               ebx)
 223   (:temporary (:sc unsigned-reg :offset ecx-offset
 224                    :from (:argument 0) :to (:result 0)) ecx)
 225   (:ignore ecx)
 226   (:results (y :scs (any-reg descriptor-reg)))
 227   (:note "signed word to integer coercion")
 228   (:generator 20
 229     (move eax x)
 230     (inst call (make-fixup 'move-from-signed :assembly-routine))
 231     (move y ebx)))
 232 ;;; Faster inline version,
 233 ;;; KLUDGE: Do we really want the faster inline version? It's sorta big.
 234 ;;; It is nice that it doesn't use any temporaries, though. -- WHN 19990916
 235 (define-vop (move-from-signed)
 236   (:args (x :scs (signed-reg unsigned-reg) :to :result))
 237   (:results (y :scs (any-reg descriptor-reg) :from :argument))
 238   (:note "signed word to integer coercion")
 239   (:node-var node)
 240   (:generator 20
 241      (aver (not (location= x y)))
 242      (let ((bignum (gen-label))
 243            (done (gen-label)))
 244        (inst mov y x)
 245        (inst shl y 1)
 246        (inst jmp :o bignum)
 247        (inst shl y 1)
 248        (inst jmp :o bignum)
 249        (emit-label done)
 250        ;; KLUDGE: The sequence above leaves a DESCRIPTOR-REG Y in a
 251        ;; non-descriptor state for a while. Does that matter? Does it
 252        ;; matter in GENGC but not in GENCGC? Is this written down
 253        ;; anywhere?
 254        ;;   -- WHN 19990916
 255        ;;
 256        ;; Also, the sequence above seems rather twisty. Why not something
 257        ;; more obvious along the lines of
 258        ;;   inst move y x
 259        ;;   inst tst x #xc0000000
 260        ;;   inst jmp :nz bignum
 261        ;;   inst shl y 2
 262        ;;   emit-label done
 263
 264        (assemble (*elsewhere*)
 265           (emit-label bignum)
 266           (with-fixed-allocation
 267               (y bignum-widetag (+ bignum-digits-offset 1) node)
 268             (storew x y bignum-digits-offset other-pointer-lowtag))
 269           (inst jmp done)))))
 270 (define-move-vop move-from-signed :move
 271   (signed-reg) (descriptor-reg))
 272
 273 ;;; Check for fixnum, and possibly allocate one or two word bignum
 274 ;;; result. Use a worst-case cost to make sure people know they may be
 275 ;;; number consing.
 276 #+nil
 277 (define-vop (move-from-unsigned)
 278   (:args (x :scs (signed-reg unsigned-reg) :target eax))
 279   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
 280   (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y)
 281               ebx)
 282   (:temporary (:sc unsigned-reg :offset ecx-offset
 283                    :from (:argument 0) :to (:result 0)) ecx)
 284   (:ignore ecx)
 285   (:results (y :scs (any-reg descriptor-reg)))
 286   (:note "unsigned word to integer coercion")
 287   (:generator 20
 288     (move eax x)
 289     (inst call (make-fixup 'move-from-unsigned :assembly-routine))
 290     (move y ebx)))
 291 ;;; Faster inline version.
 292 ;;; KLUDGE: Do we really want the faster inline version? It seems awfully big..
 293 ;;; If we really want speed, most likely it's only important in the non-consing
 294 ;;; case, so how about about making the *ELSEWHERE* stuff into a subroutine? --
 295 ;;; WHN 19990916
 296 (define-vop (move-from-unsigned)
 297   (:args (x :scs (signed-reg unsigned-reg) :to :save))
 298   (:temporary (:sc unsigned-reg) alloc)
 299   (:results (y :scs (any-reg descriptor-reg)))
 300   (:node-var node)
 301   (:note "unsigned word to integer coercion")
 302   (:generator 20
 303     (aver (not (location= x y)))
 304     (aver (not (location= x alloc)))
 305     (aver (not (location= y alloc)))
 306     (let ((bignum (gen-label))
 307           (done (gen-label))
 308           (one-word-bignum (gen-label))
 309           (L1 (gen-label)))
 310       (inst test x #xe0000000)
 311       (inst jmp :nz bignum)
 312       ;; Fixnum.
 313       (inst lea y (make-ea :dword :index x :scale 4)) ; Faster but bigger.
 314       ;(inst mov y x)
 315       ;(inst shl y 2)
 316       (emit-label done)
 317
 318       (assemble (*elsewhere*)
 319          (emit-label bignum)
 320          ;; Note: As on the mips port, space for a two word bignum is
 321          ;; always allocated and the header size is set to either one
 322          ;; or two words as appropriate.
 323          (inst jmp :ns one-word-bignum)
 324          ;; two word bignum
 325          (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
 326                                   n-widetag-bits)
 327                              bignum-widetag))
 328          (inst jmp L1)
 329          (emit-label one-word-bignum)
 330          (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
 331                                   n-widetag-bits)
 332                              bignum-widetag))
 333          (emit-label L1)
 334          (pseudo-atomic
 335           (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
 336           (storew y alloc)
 337           (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag))
 338           (storew x y bignum-digits-offset other-pointer-lowtag))
 339          (inst jmp done)))))
 340 (define-move-vop move-from-unsigned :move
 341   (unsigned-reg) (descriptor-reg))
 342
 343 ;;; Move untagged numbers.
 344 (define-vop (word-move)
 345   (:args (x :scs (signed-reg unsigned-reg) :target y
 346             :load-if (not (location= x y))))
 347   (:results (y :scs (signed-reg unsigned-reg)
 348                :load-if
 349                (not (or (location= x y)
 350                         (and (sc-is x signed-reg unsigned-reg)
 351                              (sc-is y signed-stack unsigned-stack))))))
 352   (:effects)
 353   (:affected)
 354   (:note "word integer move")
 355   (:generator 0
 356     (move y x)))
 357 (define-move-vop word-move :move
 358   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
 359
 360 ;;; Move untagged number arguments/return-values.
 361 (define-vop (move-word-arg)
 362   (:args (x :scs (signed-reg unsigned-reg) :target y)
 363          (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
 364   (:results (y))
 365   (:note "word integer argument move")
 366   (:generator 0
 367     (sc-case y
 368       ((signed-reg unsigned-reg)
 369        (move y x))
 370       ((signed-stack unsigned-stack)
 371        (if (= (tn-offset fp) esp-offset)
 372            (storew x fp (tn-offset y))  ; c-call
 373            (storew x fp (frame-word-offset (tn-offset y))))))))
 374 (define-move-vop move-word-arg :move-arg
 375   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
 376
 377 ;;; Use standard MOVE-ARG and coercion to move an untagged number
 378 ;;; to a descriptor passing location.
 379 (define-move-vop move-arg :move-arg
 380   (signed-reg unsigned-reg) (any-reg descriptor-reg))