src/compiler/alpha/move.lisp

   1 ;;; -*- Package: ALPHA -*-
   2 ;;;
   3 ;;; **********************************************************************
   4 ;;; This code was written as part of the CMU Common Lisp project at
   5 ;;; Carnegie Mellon University, and has been placed in the public domain.
   6 ;;;
   7
   8 ;;;
   9 ;;; **********************************************************************
  10 ;;;
  11 ;;;    This file contains the MIPS VM definition of operand loading/saving and
  12 ;;; the Move VOP.
  13 ;;;
  14 ;;; Written by Rob MacLachlan.
  15 ;;; Conversion by Sean Hallgren.
  16 ;;;
  17 (in-package "SB!VM")
  18
  19
  20
  21 (define-move-function (load-immediate 1) (vop x y)
  22   ((null zero immediate)
  23    (any-reg descriptor-reg))
  24   (let ((val (tn-value x)))
  25     (etypecase val
  26       (integer
  27        (inst li (fixnumize val) y))
  28       (null
  29        (move null-tn y))
  30       (symbol
  31        (load-symbol y val))
  32       (character
  33        (inst li (logior (ash (char-code val) type-bits) base-char-type)
  34              y)))))
  35
  36 (define-move-function (load-number 1) (vop x y)
  37   ((zero immediate)
  38    (signed-reg unsigned-reg))
  39   (inst li (tn-value x) y))
  40
  41 (define-move-function (load-base-char 1) (vop x y)
  42   ((immediate) (base-char-reg))
  43   (inst li (char-code (tn-value x)) y))
  44
  45 (define-move-function (load-system-area-pointer 1) (vop x y)
  46   ((immediate) (sap-reg))
  47   (inst li (sap-int (tn-value x)) y))
  48
  49 (define-move-function (load-constant 5) (vop x y)
  50   ((constant) (descriptor-reg any-reg))
  51   (loadw y code-tn (tn-offset x) other-pointer-type))
  52
  53 (define-move-function (load-stack 5) (vop x y)
  54   ((control-stack) (any-reg descriptor-reg))
  55   (load-stack-tn y x))
  56
  57 (define-move-function (load-number-stack 5) (vop x y)
  58   ((base-char-stack) (base-char-reg))
  59   (let ((nfp (current-nfp-tn vop)))
  60     (loadw y nfp (tn-offset x))))
  61
  62 (define-move-function (load-number-stack-64 5) (vop x y)
  63   ((sap-stack) (sap-reg)
  64    (signed-stack) (signed-reg)
  65    (unsigned-stack) (unsigned-reg))
  66   (let ((nfp (current-nfp-tn vop)))
  67     (loadq y nfp (tn-offset x))))
  68
  69 (define-move-function (store-stack 5) (vop x y)
  70   ((any-reg descriptor-reg null zero) (control-stack))
  71   (store-stack-tn y x))
  72
  73 (define-move-function (store-number-stack 5) (vop x y)
  74   ((base-char-reg) (base-char-stack))
  75   (let ((nfp (current-nfp-tn vop)))
  76     (storew x nfp (tn-offset y))))
  77
  78 (define-move-function (store-number-stack-64 5) (vop x y)
  79   ((sap-reg) (sap-stack)
  80    (signed-reg) (signed-stack)
  81    (unsigned-reg) (unsigned-stack))
  82   (let ((nfp (current-nfp-tn vop)))
  83     (storeq x nfp (tn-offset y))))
  84
  85 \f
  86 ;;;; The Move VOP:
  87 ;;;
  88 (define-vop (move)
  89   (:args (x :target y
  90             :scs (any-reg descriptor-reg zero null)
  91             :load-if (not (location= x y))))
  92   (:results (y :scs (any-reg descriptor-reg control-stack)
  93                :load-if (not (location= x y))))
  94   (:effects)
  95   (:affected)
  96   (:generator 0
  97     (unless (location= x y)
  98       (sc-case y
  99         ((any-reg descriptor-reg)
 100          (inst move x y))
 101         (control-stack
 102          (store-stack-tn y x))))))
 103
 104 (define-move-vop move :move
 105   (any-reg descriptor-reg zero null)
 106   (any-reg descriptor-reg))
 107
 108 ;;; Make Move the check VOP for T so that type check generation doesn't think
 109 ;;; it is a hairy type.  This also allows checking of a few of the values in a
 110 ;;; continuation to fall out.
 111 ;;;
 112 (primitive-type-vop move (:check) t)
 113
 114 ;;;    The Move-Argument VOP is used for moving descriptor values into another
 115 ;;; frame for argument or known value passing.
 116 ;;;
 117 (define-vop (move-argument)
 118   (:args (x :target y
 119             :scs (any-reg descriptor-reg null zero))
 120          (fp :scs (any-reg)
 121              :load-if (not (sc-is y any-reg descriptor-reg))))
 122   (:results (y))
 123   (:generator 0
 124     (sc-case y
 125       ((any-reg descriptor-reg)
 126        (move x y))
 127       (control-stack
 128        (storew x fp (tn-offset y))))))
 129 ;;;
 130 (define-move-vop move-argument :move-argument
 131   (any-reg descriptor-reg null zero)
 132   (any-reg descriptor-reg))
 133
 134
 135 \f
 136 ;;;; ILLEGAL-MOVE
 137
 138 ;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
 139 ;;; legally due to a type error.  An error is signalled before this VOP is
 140 ;;; so we don't need to do anything (not that there would be anything sensible
 141 ;;; to do anyway.)
 142 ;;;
 143 (define-vop (illegal-move)
 144   (:args (x) (type))
 145   (:results (y))
 146   (:ignore y)
 147   (:vop-var vop)
 148   (:save-p :compute-only)
 149   (:generator 666
 150     (error-call vop object-not-type-error x type)))
 151
 152
 153 \f
 154 ;;;; Moves and coercions:
 155
 156 ;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
 157 ;;; representation.  Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
 158 ;;; to a tagged bignum or fixnum.
 159
 160 ;;; Arg is a fixnum, so just shift it.  We need a type restriction because some
 161 ;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
 162 ;;;
 163 (define-vop (move-to-word/fixnum)
 164   (:args (x :scs (any-reg descriptor-reg)))
 165   (:results (y :scs (signed-reg unsigned-reg)))
 166   (:arg-types tagged-num)
 167   (:note "fixnum untagging")
 168   (:generator 1
 169     (inst sra x 2 y)))
 170 ;;;
 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   (:note "constant load")
 179   (:generator 1
 180     (inst li (tn-value x) y)))
 181 ;;;
 182 (define-move-vop move-to-word-c :move
 183   (constant) (signed-reg unsigned-reg))
 184
 185 ;;; Arg is a fixnum or bignum, figure out which and load if necessary.
 186 (define-vop (move-to-word/integer)
 187   (:args (x :scs (descriptor-reg)))
 188   (:results (y :scs (signed-reg unsigned-reg)))
 189   (:note "integer to untagged word coercion")
 190   (:temporary (:sc non-descriptor-reg) header)
 191   (:temporary (:scs (non-descriptor-reg)) temp)
 192   (:generator 3
 193     (inst and x 3 temp)
 194     (inst sra x 2 y)
 195     (inst beq temp done)
 196
 197     (loadw header x 0 other-pointer-type)
 198     (inst srl header (1+ type-bits) header)
 199     (loadw y x bignum-digits-offset other-pointer-type)
 200     (inst beq header one)
 201
 202     (loadw header x (1+ bignum-digits-offset) other-pointer-type)
 203     (inst sll header 32 header)
 204     (inst mskll y 4 y)
 205     (inst bis header y y)
 206     (inst br zero-tn done)
 207     ONE
 208     (when (sc-is y unsigned-reg)
 209       (inst mskll y 4 y))
 210     DONE))
 211 ;;;
 212 (define-move-vop move-to-word/integer :move
 213   (descriptor-reg) (signed-reg unsigned-reg))
 214
 215
 216 ;;; Result is a fixnum, so we can just shift.  We need the result type
 217 ;;; restriction because of the control-stack ambiguity noted above.
 218 ;;;
 219 (define-vop (move-from-word/fixnum)
 220   (:args (x :scs (signed-reg unsigned-reg)))
 221   (:results (y :scs (any-reg descriptor-reg)))
 222   (:result-types tagged-num)
 223   (:note "fixnum tagging")
 224   (:generator 1
 225     (inst sll x 2 y)))
 226 ;;;
 227 (define-move-vop move-from-word/fixnum :move
 228   (signed-reg unsigned-reg) (any-reg descriptor-reg))
 229
 230 ;;; Result may be a bignum, so we have to check.  Use a worst-case cost to make
 231 ;;; sure people know they may be number consing.
 232 ;;;
 233 (define-vop (move-from-signed)
 234   (:args (arg :scs (signed-reg unsigned-reg) :target x))
 235   (:results (y :scs (any-reg descriptor-reg)))
 236   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
 237   (:temporary (:sc non-descriptor-reg) header)
 238   (:note "signed word to integer coercion")
 239   (:generator 18
 240     (move arg x)
 241     (inst sra x 29 temp)
 242     (inst sll x 2 y)
 243     (inst beq temp done)
 244     (inst not temp temp)
 245     (inst beq temp done)
 246
 247     (inst li 2 header)
 248     (inst sra x 31 temp)
 249     (inst cmoveq temp 1 header)
 250     (inst not temp temp)
 251     (inst cmoveq temp 1 header)
 252     (inst sll header type-bits header)
 253     (inst bis header bignum-type header)
 254
 255     (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
 256       (inst bis alloc-tn other-pointer-type y)
 257       (storew header y 0 other-pointer-type)
 258       (storew x y bignum-digits-offset other-pointer-type)
 259       (inst srl x 32 temp)
 260       (storew temp y (1+ bignum-digits-offset) other-pointer-type))
 261     DONE))
 262
 263 ;;;
 264 (define-move-vop move-from-signed :move
 265   (signed-reg) (descriptor-reg))
 266
 267
 268 ;;; Check for fixnum, and possibly allocate one or two word bignum result.  Use
 269 ;;; a worst-case cost to make sure people know they may be number consing.
 270 ;;;
 271 (define-vop (move-from-unsigned)
 272   (:args (arg :scs (signed-reg unsigned-reg) :target x))
 273   (:results (y :scs (any-reg descriptor-reg)))
 274   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
 275   (:temporary (:sc non-descriptor-reg) temp1)
 276   (:note "unsigned word to integer coercion")
 277   (:generator 20
 278     (move arg x)
 279     (inst srl x 29 temp)
 280     (inst sll x 2 y)
 281     (inst beq temp done)
 282
 283     (inst li 3 temp)
 284     (inst cmovge x 2 temp)
 285     (inst srl x 31 temp1)
 286     (inst cmoveq temp1 1 temp)
 287     (inst sll temp type-bits temp)
 288     (inst bis temp bignum-type temp)
 289
 290     (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
 291       (inst bis alloc-tn other-pointer-type y)
 292       (storew temp y 0 other-pointer-type)
 293       (storew x y bignum-digits-offset other-pointer-type)
 294       (inst srl x 32 temp)
 295       (storew temp y (1+ bignum-digits-offset) other-pointer-type))
 296     DONE))
 297
 298 ;;;
 299 (define-move-vop move-from-unsigned :move
 300   (unsigned-reg) (descriptor-reg))
 301
 302
 303 ;;; Move untagged numbers.
 304 ;;;
 305 (define-vop (word-move)
 306   (:args (x :target y
 307             :scs (signed-reg unsigned-reg)
 308             :load-if (not (location= x y))))
 309   (:results (y :scs (signed-reg unsigned-reg)
 310                :load-if (not (location= x y))))
 311   (:effects)
 312   (:affected)
 313   (:note "word integer move")
 314   (:generator 0
 315     (move x y)))
 316 ;;;
 317 (define-move-vop word-move :move
 318   (signed-reg unsigned-reg) (signed-reg unsigned-reg))
 319
 320
 321 ;;; Move untagged number arguments/return-values.
 322 ;;;
 323 (define-vop (move-word-argument)
 324   (:args (x :target y
 325             :scs (signed-reg unsigned-reg))
 326          (fp :scs (any-reg)
 327              :load-if (not (sc-is y sap-reg))))
 328   (:results (y))
 329   (:note "word integer argument move")
 330   (:generator 0
 331     (sc-case y
 332       ((signed-reg unsigned-reg)
 333        (move x y))
 334       ((signed-stack unsigned-stack)
 335        (storeq x fp (tn-offset y))))))
 336 ;;;
 337 (define-move-vop move-word-argument :move-argument
 338   (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
 339
 340
 341 ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
 342 ;;; descriptor passing location.
 343 ;;;
 344 (define-move-vop move-argument :move-argument
 345   (signed-reg unsigned-reg) (any-reg descriptor-reg))