Newer
Older
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
cwang
committed
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/amd64/move.lisp,v 1.4 2004/07/14 20:59:48 cwang Rel $")
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
;;;
;;; **********************************************************************
;;;
;;; This file contains the AMD64 VM definition of operand loading/saving and
;;; the Move VOP.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
;;;
(in-package :amd64)
(define-move-function (load-immediate 1) (vop x y)
((immediate)
(any-reg descriptor-reg))
(let ((val (tn-value x)))
(etypecase val
(integer
(if (zerop val)
(inst xor y y)
(inst mov y (fixnumize val))))
(symbol
(load-symbol y val))
(character
(inst mov y (logior (ash (char-code val) type-bits)
base-char-type))))))
(define-move-function (load-number 1) (vop x y)
((immediate) (signed-reg unsigned-reg))
(inst mov y (tn-value x)))
(define-move-function (load-base-char 1) (vop x y)
((immediate) (base-char-reg))
(inst mov y (char-code (tn-value x))))
(define-move-function (load-system-area-pointer 1) (vop x y)
((immediate) (sap-reg))
(inst mov y (sap-int (tn-value x))))
(define-move-function (load-constant 5) (vop x y)
((constant) (descriptor-reg any-reg))
(inst mov-imm y (make-fixup nil
:code-object
(- (* (tn-offset x) word-bytes)
other-pointer-type)))
(inst mov y (make-ea :qword :base y)))
(define-move-function (load-stack 5) (vop x y)
((control-stack) (any-reg descriptor-reg)
(base-char-stack) (base-char-reg)
(sap-stack) (sap-reg)
(signed-stack) (signed-reg)
(unsigned-stack) (unsigned-reg))
(inst mov y x))
(define-move-function (store-stack 5) (vop x y)
((any-reg descriptor-reg) (control-stack)
(base-char-reg) (base-char-stack)
(sap-reg) (sap-stack)
(signed-reg) (signed-stack)
(unsigned-reg) (unsigned-stack))
(inst mov y x))
;;;; The Move VOP:
;;;
(define-vop (move)
(:args (x :scs (any-reg descriptor-reg immediate) :target y
:load-if (not (location= x y))))
(:results (y :scs (any-reg descriptor-reg)
:load-if
(not (or (location= x y)
(and (sc-is x any-reg descriptor-reg immediate)
(sc-is y control-stack))))))
(:temporary (:sc any-reg) temp)
(:effects)
(:affected)
(:generator 0
(if (and (sc-is x immediate)
(sc-is y any-reg descriptor-reg control-stack))
(let ((val (tn-value x)))
(etypecase val
(integer
(if (and (zerop val) (sc-is y any-reg descriptor-reg))
(inst xor y y)
(if (sc-is y control-stack)
(progn
;; we can't have 64-bit immediates here
(inst mov temp (fixnumize val))
(inst mov y temp))
(inst mov y (fixnumize val)))))
(symbol
(inst mov y (+ nil-value (static-symbol-offset val))))
(character
(inst mov y (logior (ash (char-code val) type-bits)
base-char-type)))))
(define-move-vop move :move
(any-reg descriptor-reg immediate)
(any-reg descriptor-reg))
;;; Make Move the check VOP for T so that type check generation doesn't think
;;; it is a hairy type. This also allows checking of a few of the values in a
;;; continuation to fall out.
;;;
(primitive-type-vop move (:check) t)
;;; The Move-Argument VOP is used for moving descriptor values into another
;;; frame for argument or known value passing.
;;;
;;; Note: It is not going to be possible to move a constant directly
;;; to another frame, except if the destination is a register and in
;;; this case the loading works out.
(define-vop (move-argument)
(:args (x :scs (any-reg descriptor-reg immediate) :target y
:load-if (not (and (sc-is y any-reg descriptor-reg)
(sc-is x control-stack))))
(fp :scs (any-reg)
:load-if (not (sc-is y any-reg descriptor-reg))))
(:temporary (:sc any-reg) temp)
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
(:results (y))
(:generator 0
(sc-case y
((any-reg descriptor-reg)
(if (sc-is x immediate)
(let ((val (tn-value x)))
(etypecase val
(integer
(if (zerop val)
(inst xor y y)
(inst mov y (fixnumize val))))
(symbol
(load-symbol y val))
(character
(inst mov y (logior (ash (char-code val) type-bits)
base-char-type)))))
(move y x)))
((control-stack)
(if (sc-is x immediate)
(let ((val (tn-value x)))
(if (= (tn-offset fp) rsp-offset)
;; C-call
(etypecase val
(integer
(storew (fixnumize val) fp (tn-offset y)))
(symbol
(storew (+ nil-value (static-symbol-offset val))
fp (tn-offset y)))
(character
(storew (logior (ash (char-code val) type-bits)
base-char-type)
fp (tn-offset y))))
;; Lisp stack
(etypecase val
(integer
;; we can't have 64-bit immediates here
(inst mov temp (fixnumize val))
(storew temp fp (- (1+ (tn-offset y)))))
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
(symbol
(storew (+ nil-value (static-symbol-offset val))
fp (- (1+ (tn-offset y)))))
(character
(storew (logior (ash (char-code val) type-bits)
base-char-type)
fp (- (1+ (tn-offset y))))))))
(if (= (tn-offset fp) rsp-offset)
;; C-call
(storew x fp (tn-offset y))
;; Lisp stack
(storew x fp (- (1+ (tn-offset y))))))))))
;;;
(define-move-vop move-argument :move-argument
(any-reg descriptor-reg)
(any-reg descriptor-reg))
;;;; ILLEGAL-MOVE
;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
;;; legally due to a type error. An error is signalled before this VOP is
;;; so we don't need to do anything (not that there would be anything sensible
;;; to do anyway.)
;;;
(define-vop (illegal-move)
(:args (x) (type))
(:results (y))
(:ignore y)
(:vop-var vop)
(:save-p :compute-only)
(:generator 666
(error-call vop object-not-type-error x type)))
;;;; Moves and coercions:
;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
;;; to a tagged bignum or fixnum.
;;; Arg is a fixnum, so just shift it. We need a type restriction because some
;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
;;;
(define-vop (move-to-word/fixnum)
(:args (x :scs (any-reg descriptor-reg) :target y
:load-if (not (location= x y))))
(:results (y :scs (signed-reg unsigned-reg)
:load-if (not (location= x y))))
(:arg-types tagged-num)
(:note "fixnum untagging")
(:generator 1
(move y x)
(inst sar y 2)))
;;;
(define-move-vop move-to-word/fixnum :move
(any-reg descriptor-reg) (signed-reg unsigned-reg))
;;; Arg is a non-immediate constant, load it.
(define-vop (move-to-word-c)
(:args (x :scs (constant)))
(:results (y :scs (signed-reg unsigned-reg)))
(:note "constant load")
(:generator 1
(inst mov y (tn-value x))))
;;;
(define-move-vop move-to-word-c :move
(constant) (signed-reg unsigned-reg))
;;; Arg is a fixnum or bignum, figure out which and load if necessary.
(define-vop (move-to-word/integer)
(:args (x :scs (descriptor-reg) :target rax))
(:results (y :scs (signed-reg unsigned-reg)))
(:note "integer to untagged word coercion")
(:temporary (:sc unsigned-reg :offset rax-offset
:from (:argument 0) :to (:result 0) :target y) rax)
(:generator 4
(move rax x)
(inst test al-tn 3)
(inst jmp :z fixnum)
(loadw y rax bignum-digits-offset other-pointer-type)
(inst jmp done)
FIXNUM
(inst sar rax 2)
(move y rax)
DONE))
;;;
(define-move-vop move-to-word/integer :move
(descriptor-reg) (signed-reg unsigned-reg))
;;; Result is a fixnum, so we can just shift. We need the result type
;;; restriction because of the control-stack ambiguity noted above.
;;;
(define-vop (move-from-word/fixnum)
(:args (x :scs (signed-reg unsigned-reg) :target y
:load-if (not (location= x y))))
(:results (y :scs (any-reg descriptor-reg)
:load-if (not (location= x y))))
(:result-types tagged-num)
(:note "fixnum tagging")
(:generator 1
(cond ((and (sc-is x signed-reg unsigned-reg)
(not (location= x y)))
;; Uses 7 bytes, but faster on the Pentium
(inst lea y (make-ea :qword :index x :scale 4)))
(t
;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
(move y x)
(inst shl y 2)))))
;;;
(define-move-vop move-from-word/fixnum :move
(signed-reg unsigned-reg) (any-reg descriptor-reg))
;;; Result may be a bignum, so we have to check. Use a worst-case cost to make
;;; sure people know they may be number consing.
;;; Faster inline version,
(define-vop (move-from-signed)
(:args (x :scs (signed-reg unsigned-reg) :to :result))
(:results (y :scs (any-reg descriptor-reg) :from :argument))
cwang
committed
(:temporary (:sc any-reg :offset r11-offset) temp)
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
(:note "signed word to integer coercion")
(:node-var node)
(:generator 20
(assert (not (location= x y)))
(let ((bignum (gen-label))
(done (gen-label)))
(inst mov y x)
(inst shl y 1)
(inst jmp :o bignum)
(inst shl y 1)
(inst jmp :o bignum)
(emit-label done)
(assemble (*elsewhere*)
(emit-label bignum)
(with-fixed-allocation
(y bignum-type (+ bignum-digits-offset 1) temp node)
(storew x y bignum-digits-offset other-pointer-type))
(inst jmp done)))))
;;;
(define-move-vop move-from-signed :move
(signed-reg) (descriptor-reg))
;;; Check for fixnum, and possibly allocate one or two word bignum result. Use
;;; a worst-case cost to make sure people know they may be number consing.
;;; Faster inline version.
(define-vop (move-from-unsigned)
(:args (x :scs (signed-reg unsigned-reg) :to :save))
(:temporary (:sc unsigned-reg) alloc)
cwang
committed
(:temporary (:sc any-reg :offset r11-offset) temp)
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
(:results (y :scs (any-reg descriptor-reg)))
(:node-var node)
(:note "unsigned word to integer coercion")
(:generator 20
(assert (not (location= x y)))
(assert (not (location= x alloc)))
(assert (not (location= y alloc)))
(let ((bignum (gen-label))
(done (gen-label))
(one-word-bignum (gen-label))
(l1 (gen-label)))
(inst mov alloc #xe000000000000000) ; 111000.....
(inst test x alloc)
(inst jmp :nz bignum)
;; Fixnum.
(inst lea y (make-ea :qword :index x :scale 4)) ; Faster but bigger.
(emit-label done)
(assemble (*elsewhere*)
(emit-label bignum)
;; Note: As on the mips port, space for a two word bignum is
;; always allocated and the header size is set to either one
;; or two words as appropriate.
(inst jmp :ns one-word-bignum)
;; Two word bignum.
(inst mov y (logior (ash (1- (+ bignum-digits-offset 2)) vm:type-bits)
bignum-type))
(inst jmp l1)
(emit-label one-word-bignum)
(inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) vm:type-bits)
bignum-type))
(emit-label l1)
(pseudo-atomic
cwang
committed
(allocation alloc (pad-data-block (+ bignum-digits-offset 2)) temp node)
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
(storew y alloc)
(inst lea y (make-ea :byte :base alloc :disp other-pointer-type))
(storew x y bignum-digits-offset other-pointer-type))
(inst jmp done)))))
;;;
(define-move-vop move-from-unsigned :move
(unsigned-reg) (descriptor-reg))
;;; Move untagged numbers.
;;;
(define-vop (word-move)
(:args (x :scs (signed-reg unsigned-reg) :target y
:load-if (not (location= x y))))
(:results (y :scs (signed-reg unsigned-reg)
:load-if
(not (or (location= x y)
(and (sc-is x signed-reg unsigned-reg)
(sc-is y signed-stack unsigned-stack))))))
(:effects)
(:affected)
(:note "word integer move")
(:generator 0
(move y x)))
;;;
(define-move-vop word-move :move
(signed-reg unsigned-reg) (signed-reg unsigned-reg))
;;; Move untagged number arguments/return-values.
;;;
(define-vop (move-word-argument)
(:args (x :scs (signed-reg unsigned-reg) :target y)
(fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
(:results (y))
(:note "word integer argument move")
(:generator 0
(sc-case y
((signed-reg unsigned-reg)
(move y x))
((signed-stack unsigned-stack)
(if (= (tn-offset fp) rsp-offset)
(storew x fp (tn-offset y)) ; c-call
(storew x fp (- (1+ (tn-offset y)))))))))
;;;
(define-move-vop move-word-argument :move-argument
(descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
;;; descriptor passing location.
;;;
(define-move-vop move-argument :move-argument
(signed-reg unsigned-reg) (any-reg descriptor-reg))