src/compiler/arm/move.lisp

   1 ;;;; the ARM 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 (defun lowest-set-bit-index (integer-value)
  15   (max 0 (1- (integer-length (logand integer-value (- integer-value))))))
  16
  17 (defun repeating-pattern-p (val)
  18   (declare (type (unsigned-byte 32) val))
  19   (and (= (ldb (byte 16 0) val)
  20           (ldb (byte 16 16) val))
  21        (not (encodable-immediate (ldb (byte 16 16) val)))))
  22
  23 ;;; This should be put into composite-immediate-instruction, but that
  24 ;;; macro is too scary.
  25 (defun load-repeating-pattern (dest val)
  26   (declare (type (signed-byte 32) val))
  27   (inst mov dest (ldb (byte 8 0) val))
  28   (inst orr dest dest (mask-field (byte 8 8) val))
  29   (inst orr dest dest (lsl dest 16)))
  30
  31 (defun load-immediate-word (y val)
  32   (cond ((let ((unsigned (ldb (byte 32 0) val)))
  33            (when (encodable-immediate unsigned)
  34              (inst mov y unsigned)
  35              t)))
  36         ((let ((inverted (ldb (byte 32 0) (lognot val))))
  37            (when (encodable-immediate inverted)
  38              (inst mvn y inverted)
  39              t)))
  40         ((< val 0)
  41          (composite-immediate-instruction bic y y val :first-op mvn :first-no-source t :invert-y t))
  42         ((repeating-pattern-p val)
  43          (load-repeating-pattern y val))
  44         (t
  45          (composite-immediate-instruction orr y y val :first-op mov :first-no-source t))))
  46
  47 (define-move-fun (load-immediate 1) (vop x y)
  48   ((null immediate)
  49    (any-reg descriptor-reg))
  50   (let ((val (tn-value x)))
  51     (etypecase val
  52       (integer
  53        ;; This is a FIXNUM, as IMMEDIATE-CONSTANT-SC only
  54        ;; accepts integers if they are FIXNUMs.
  55        (load-immediate-word y (fixnumize val)))
  56       (character
  57        (let* ((codepoint (char-code val))
  58               (encoded-character (dpb codepoint (byte 24 8) character-widetag)))
  59          (load-immediate-word y encoded-character)))
  60       (null
  61        (move y null-tn))
  62       (symbol
  63        (load-symbol y val)))))
  64
  65 (define-move-fun (load-number 1) (vop x y)
  66   ((immediate)
  67    (signed-reg unsigned-reg))
  68   (load-immediate-word y (tn-value x)))
  69
  70 (define-move-fun (load-character 1) (vop x y)
  71   ((immediate) (character-reg))
  72   (load-immediate-word y (char-code (tn-value x))))
  73
  74 (define-move-fun (load-system-area-pointer 1) (vop x y)
  75   ((immediate) (sap-reg))
  76   (let ((immediate-label (gen-label)))
  77     (assemble (*elsewhere*)
  78       (emit-label immediate-label)
  79       (inst word (sap-int (tn-value x))))
  80     (inst ldr y (@ immediate-label))))
  81
  82 (define-move-fun (load-constant 5) (vop x y)
  83   ((constant) (descriptor-reg))
  84   (let ((offset (- (ash (tn-offset x) 2) other-pointer-lowtag)))
  85     (typecase offset
  86       ((unsigned-byte 12)
  87        (inst ldr y (@ code-tn offset)))
  88       (t
  89        ;; Y is a descriptor-reg, make sure offset is a fixnum.
  90        (load-immediate-word y (ash offset n-fixnum-tag-bits))
  91        (inst ldr y (@ code-tn (lsr y n-fixnum-tag-bits)))))))
  92
  93 (define-move-fun (load-stack 5) (vop x y)
  94   ((control-stack) (any-reg descriptor-reg))
  95   (load-stack-tn y x))
  96
  97 (define-move-fun (load-number-stack 5) (vop x y)
  98   ((character-stack) (character-reg)
  99    (sap-stack) (sap-reg)
 100    (signed-stack) (signed-reg)
 101    (unsigned-stack) (unsigned-reg))
 102   (load-stack-offset y (current-nfp-tn vop) x))
 103
 104 (define-move-fun (store-stack 5) (vop x y)
 105   ((any-reg descriptor-reg) (control-stack))
 106   (store-stack-tn y x))
 107
 108 (define-move-fun (store-number-stack 5) (vop x y)
 109   ((character-reg) (character-stack)
 110    (sap-reg) (sap-stack)
 111    (signed-reg) (signed-stack)
 112    (unsigned-reg) (unsigned-stack))
 113   (store-stack-offset x (current-nfp-tn vop) y))
 114
 115 \f
 116 ;;;; The Move VOP:
 117 (define-vop (move)
 118   (:args (x :target y
 119             :scs (any-reg descriptor-reg null)
 120             :load-if (not (location= x y))))
 121   (:results (y :scs (any-reg descriptor-reg)
 122                :load-if (not (location= x y))))
 123   (:effects)
 124   (:affected)
 125   (:generator 0
 126     (move y x)))
 127
 128 (define-move-vop move :move
 129   (any-reg descriptor-reg)
 130   (any-reg descriptor-reg))
 131
 132 ;;; Make MOVE the check VOP for T so that type check generation
 133 ;;; doesn't think it is a hairy type.  This also allows checking of a
 134 ;;; few of the values in a continuation to fall out.
 135 (primitive-type-vop move (:check) t)
 136
 137 ;;; The MOVE-ARG VOP is used for moving descriptor values into another
 138 ;;; frame for argument or known value passing.
 139 (define-vop (move-arg)
 140   (:args (x :target y
 141             :scs (any-reg descriptor-reg null))
 142          (fp :scs (any-reg)
 143              :load-if (not (sc-is y any-reg descriptor-reg))))
 144   (:results (y))
 145   (:generator 0
 146     (sc-case y
 147       ((any-reg descriptor-reg)
 148        (move y x))
 149       (control-stack
 150        (store-stack-offset x fp y)))))
 151 ;;;
 152 (define-move-vop move-arg :move-arg
 153   (any-reg descriptor-reg)
 154   (any-reg descriptor-reg))
 155 \f
 156 ;;;; Moves and coercions:
 157
 158 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
 159 ;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
 160 ;;; to a tagged bignum or fixnum.
 161
 162 ;;; ARG is a fixnum, so just shift it.  We need a type restriction because some
 163 ;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
 164 (define-vop (move-to-word/fixnum)
 165   (:args (x :scs (any-reg descriptor-reg)))
 166   (:results (y :scs (signed-reg unsigned-reg)))
 167   (:arg-types tagged-num)
 168   (:note "fixnum untagging")
 169   (:generator 1
 170     (inst mov y (asr x n-fixnum-tag-bits))))
 171 (define-move-vop move-to-word/fixnum :move
 172   (any-reg descriptor-reg) (signed-reg unsigned-reg))
 173
 174 ;;; ARG is a non-immediate constant; load it.
 175 (define-vop (move-to-word-c)
 176   (:args (x :scs (constant)))
 177   (:results (y :scs (signed-reg unsigned-reg)))
 178   (:vop-var vop)
 179   (:note "constant load")
 180   (:generator 1
 181     (cond ((sb!c::tn-leaf x)
 182            (load-immediate-word y (tn-value x)))
 183           (t
 184            (load-constant vop x y)
 185            (inst mov y (asr y n-fixnum-tag-bits))))))
 186 (define-move-vop move-to-word-c :move
 187   (constant) (signed-reg unsigned-reg))
 188
 189 ;;; ARG is a fixnum or bignum; figure out which and load if necessary.
 190 (define-vop (move-to-word/integer)
 191   (:args (x :scs (descriptor-reg)))
 192   (:results (y :scs (signed-reg unsigned-reg)))
 193   (:note "integer to untagged word coercion")
 194   (:generator 4
 195     (inst tst x fixnum-tag-mask)
 196     (sc-case y
 197       (signed-reg
 198        (inst mov :eq y (asr x n-fixnum-tag-bits)))
 199       (unsigned-reg
 200        (inst mov :eq y (lsr x n-fixnum-tag-bits))))
 201     (loadw y x bignum-digits-offset other-pointer-lowtag :ne)))
 202
 203 (define-move-vop move-to-word/integer :move
 204   (descriptor-reg) (signed-reg unsigned-reg))
 205
 206 ;;; RESULT is a fixnum, so we can just shift.  We need the result type
 207 ;;; restriction because of the control-stack ambiguity noted above.
 208 (define-vop (move-from-word/fixnum)
 209   (:args (x :scs (signed-reg unsigned-reg)))
 210   (:results (y :scs (any-reg descriptor-reg)))
 211   (:result-types tagged-num)
 212   (:note "fixnum tagging")
 213   (:generator 1
 214     (inst mov y (lsl x n-fixnum-tag-bits))))
 215 (define-move-vop move-from-word/fixnum :move
 216   (signed-reg unsigned-reg) (any-reg descriptor-reg))
 217
 218
 219 ;;; RESULT may be a bignum, so we have to check.  Use a worst-case
 220 ;;; cost to make sure people know they may be number consing.
 221 (define-vop (move-from-signed)
 222   (:args (arg :scs (signed-reg unsigned-reg) :target x))
 223   (:results (y :scs (any-reg descriptor-reg)))
 224   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x)
 225   (:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
 226   (:note "signed word to integer coercion")
 227   (:generator 20
 228     (move x arg)
 229     (inst adds pa-flag x x)
 230     (inst adds :vc y pa-flag pa-flag)
 231     (inst b :vc DONE)
 232
 233     (with-fixed-allocation (y pa-flag bignum-widetag (1+ bignum-digits-offset))
 234       (storew x y bignum-digits-offset other-pointer-lowtag))
 235     DONE))
 236 (define-move-vop move-from-signed :move
 237   (signed-reg) (descriptor-reg))
 238
 239 ;;; Check for fixnum, and possibly allocate one or two word bignum
 240 ;;; result.  Use a worst-case cost to make sure people know they may
 241 ;;; be number consing.
 242 (define-vop (move-from-unsigned)
 243   (:args (arg :scs (signed-reg unsigned-reg) :target x))
 244   (:results (y :scs (any-reg descriptor-reg)))
 245   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x)
 246   (:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag)
 247   (:note "unsigned word to integer coercion")
 248   (:generator 20
 249     (move x arg)
 250     (inst tst x (ash (1- (ash 1 (- n-word-bits
 251                                    n-positive-fixnum-bits)))
 252                      n-positive-fixnum-bits))
 253     (inst mov y (lsl x n-fixnum-tag-bits))
 254     (inst b :eq DONE)
 255
 256     (with-fixed-allocation
 257         (y pa-flag bignum-widetag (+ 2 bignum-digits-offset))
 258       ;; WITH-FIXED-ALLOCATION, when using a supplied type-code,
 259       ;; leaves PA-FLAG containing the computed header value.  In our
 260       ;; case, configured for a 2-word bignum.  If the sign bit in the
 261       ;; value we're boxing is CLEAR, we need to shrink the bignum by
 262       ;; one word, hence the following:
 263       (inst orrs x x 0)
 264       (inst sub :pl pa-flag pa-flag #x100)
 265       (storew pa-flag y 0 other-pointer-lowtag :pl)
 266       (storew x y bignum-digits-offset other-pointer-lowtag))
 267     DONE))
 268 (define-move-vop move-from-unsigned :move
 269   (unsigned-reg) (descriptor-reg))
 270
 271
 272 ;;; Move untagged numbers.
 273 (define-vop (word-move)
 274   (:args (x :target y
 275             :scs (signed-reg unsigned-reg)
 276             :load-if (not (location= x y))))
 277   (:results (y :scs (signed-reg unsigned-reg)
 278                :load-if (not (location= x y))))
 279   (:effects)
 280   (:affected)
 281   (:note "word integer move")
 282   (:generator 0
 283     (move y x)))
 284 (define-move-vop word-move :move
 285   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
 286
 287
 288 ;;; Move untagged number arguments/return-values.
 289 (define-vop (move-word-arg)
 290   (:args (x :target y
 291             :scs (signed-reg unsigned-reg))
 292          (fp :scs (any-reg)
 293              :load-if (not (sc-is y signed-reg unsigned-reg))))
 294   (:results (y))
 295   (:note "word integer argument move")
 296   (:generator 0
 297     (sc-case y
 298       ((signed-reg unsigned-reg)
 299        (move y x))
 300       ((signed-stack unsigned-stack)
 301        (store-stack-offset x fp y)))))
 302 (define-move-vop move-word-arg :move-arg
 303   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
 304
 305 ;;; Use standard MOVE-ARG + coercion to move an untagged number to a
 306 ;;; descriptor passing location.
 307 (define-move-vop move-arg :move-arg
 308   (signed-reg unsigned-reg) (any-reg descriptor-reg))