← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty

« back to all changes in this revision

Viewing changes to src/compiler/machines/x86-64/insutl.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2010-03-10 02:00:45 UTC
  • mfrom: (1.1.7 upstream) (3.1.6 sid)
  • Revision ID: james.westby@ubuntu.com-20100310020045-4np1y3ro6sk2oz92
Tags: 9.0.1-1
* New upstream.
* debian/watch: Fix, previous version was broken.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/compiler/machines/x86-64/insutl.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
 
4
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
 
5
    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
 
6
 
 
7
This file is part of MIT/GNU Scheme.
 
8
 
 
9
MIT/GNU Scheme is free software; you can redistribute it and/or modify
 
10
it under the terms of the GNU General Public License as published by
 
11
the Free Software Foundation; either version 2 of the License, or (at
 
12
your option) any later version.
 
13
 
 
14
MIT/GNU Scheme is distributed in the hope that it will be useful, but
 
15
WITHOUT ANY WARRANTY; without even the implied warranty of
 
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
17
General Public License for more details.
 
18
 
 
19
You should have received a copy of the GNU General Public License
 
20
along with MIT/GNU Scheme; if not, write to the Free Software
 
21
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
 
22
USA.
 
23
 
 
24
|#
 
25
 
 
26
;;;; Intel 386 Instruction Set, utilities
 
27
 
 
28
(declare (usual-integrations))
 
29
 
 
30
;;;; Addressing modes
 
31
 
 
32
;; r/m part of ModR/M byte and SIB byte.
 
33
;; These are valid only for 64-bit addressing.
 
34
 
 
35
(define-ea-database
 
36
 
 
37
;;;; Register
 
38
 
 
39
  ((R (? r))
 
40
   (CATEGORIES REGISTER)
 
41
   (REX (B r))
 
42
   (MODE #b11)
 
43
   (R/M (register-bits r)))
 
44
 
 
45
  ((XMM (? r))
 
46
   (CATEGORIES XMM)
 
47
   (REX (B r))
 
48
   (MODE #b11)
 
49
   (R/M (register-bits r)))
 
50
 
 
51
;;;; Register-indirect
 
52
 
 
53
  ((@R (? r indirect-reg))
 
54
   (CATEGORIES MEMORY)
 
55
   (REX (B r))
 
56
   (MODE #b00)
 
57
   (R/M (register-bits r)))
 
58
 
 
59
  ;; Mode #b00, r/m 4 means SIB, so put the register in a SIB base and
 
60
  ;; use no index (i.e. index of 4).
 
61
 
 
62
  ((@R (? r indirect-reg=4mod8))
 
63
   (CATEGORIES MEMORY)
 
64
   (REX (B r))
 
65
   (MODE #b00)
 
66
   (R/M 4)
 
67
   (BITS (3 4)
 
68
         (3 4)
 
69
         (2 0)))
 
70
 
 
71
  ;; Mode #b00, r/m 5 means RIP-relative 32-bit offset, so use mode
 
72
  ;; #b01, r/m 5, which means the register plus 8-bit offset, and
 
73
  ;; specify a zero offset.
 
74
 
 
75
  ((@R (? r indirect-reg=5mod8))
 
76
   (CATEGORIES MEMORY)
 
77
   (REX (B r))
 
78
   (MODE #b01)
 
79
   (R/M 5)
 
80
   (BITS (8 0)))
 
81
 
 
82
;;;; Register-indirect with 8-bit offset
 
83
 
 
84
  ((@RO (? r offset-indirect-reg) (? offset sign-extended-byte))
 
85
   (CATEGORIES MEMORY)
 
86
   (REX (B r))
 
87
   (MODE #b01)
 
88
   (R/M (register-bits r))
 
89
   (BITS (8 offset SIGNED)))
 
90
 
 
91
  ;; Mode #b01, r/m 4 means SIB plus 8-bit offset, so use the SIB base
 
92
  ;; for the register with no index (i.e. index of 4).
 
93
 
 
94
  ((@RO (? r offset-indirect-reg=4mod8) (? offset sign-extended-byte))
 
95
   (CATEGORIES MEMORY)
 
96
   (REX (B r))
 
97
   (MODE #b01)
 
98
   (R/M 4)
 
99
   (BITS (3 4)
 
100
         (3 4)
 
101
         (2 0)
 
102
         (8 offset SIGNED)))
 
103
 
 
104
;;;; Register-indirect with 32-bit offset
 
105
 
 
106
  ((@RO (? r offset-indirect-reg) (? offset sign-extended-long))
 
107
   (CATEGORIES MEMORY)
 
108
   (REX (B r))
 
109
   (MODE #b10)
 
110
   (R/M (register-bits r))
 
111
   (BITS (32 offset SIGNED)))
 
112
 
 
113
  ;; Same special case as above, but with 32-bit offsets.
 
114
 
 
115
  ((@RO (? r offset-indirect-reg=4mod8) (? offset sign-extended-long))
 
116
   (CATEGORIES MEMORY)
 
117
   (REX (B r))
 
118
   (MODE #b10)
 
119
   (R/M 4)
 
120
   (BITS (3 4)
 
121
         (3 4)
 
122
         (2 0)
 
123
         (32 offset SIGNED)))
 
124
 
 
125
;;;; Register-indirect with index
 
126
 
 
127
  ((@RI (? b base-reg) (? i index-reg) (? s index-scale))
 
128
   (CATEGORIES MEMORY)
 
129
   (REX (B b) (X i))
 
130
   (MODE #b00)
 
131
   (R/M 4)
 
132
   (BITS (3 (register-bits b))
 
133
         (3 (register-bits i))
 
134
         (2 s)))
 
135
 
 
136
  ;; Mode 0, r/m 4, SIB base 5 mean the register plus 32-bit offset,
 
137
  ;; so specify a zero offset.
 
138
 
 
139
  ((@RI (? b base-reg=5mod8) (? i index-reg) (? s index-scale))
 
140
   (CATEGORIES MEMORY)
 
141
   (REX (B b) (X i))
 
142
   (MODE #b01)
 
143
   (R/M 4)
 
144
   (BITS (3 5)
 
145
         (3 (register-bits i))
 
146
         (2 s)
 
147
         (8 0)))
 
148
 
 
149
;;;; Register-indirect with offset and scaled index
 
150
 
 
151
  ;; No more special cases -- except that rsp can't be the index
 
152
  ;; register at all here.
 
153
 
 
154
  ((@ROI (? b) (? offset sign-extended-byte) (? i index-reg) (? s index-scale))
 
155
   (CATEGORIES MEMORY)
 
156
   (REX (B b) (X i))
 
157
   (MODE #b01)
 
158
   (R/M 4)
 
159
   (BITS (3 (register-bits b))
 
160
         (3 (register-bits i))
 
161
         (2 s)
 
162
         (8 offset SIGNED)))
 
163
 
 
164
  ((@ROI (? b) (? offset sign-extended-long) (? i index-reg) (? s index-scale))
 
165
   (CATEGORIES MEMORY)
 
166
   (REX (B b) (X i))
 
167
   (MODE #b10)
 
168
   (R/M 4)
 
169
   (BITS (3 (register-bits b))
 
170
         (3 (register-bits i))
 
171
         (2 s)
 
172
         (32 offset SIGNED)))
 
173
 
 
174
;;;; RIP-relative (PC-relative)
 
175
 
 
176
  ((@PCR (? label))
 
177
   (CATEGORIES MEMORY)
 
178
   (REX)
 
179
   (MODE #b00)
 
180
   (R/M 5)
 
181
   (BITS (32 `(- ,label (+ *PC* 4)) SIGNED)))
 
182
 
 
183
  ((@PCO (? offset signed-long))
 
184
   (CATEGORIES MEMORY)
 
185
   (REX)
 
186
   (MODE #b00)
 
187
   (R/M 5)
 
188
   (BITS (32 offset SIGNED))))
 
189
 
 
190
(define-ea-transformer r-ea REGISTER)
 
191
(define-ea-transformer xmm-ea XMM)
 
192
(define-ea-transformer m-ea MEMORY)
 
193
(define-ea-transformer r/m-ea REGISTER MEMORY)
 
194
(define-ea-transformer xmm/m-ea XMM MEMORY)
 
195
 
 
196
(define-structure (effective-address
 
197
                   (conc-name ea/)
 
198
                   (constructor make-effective-address))
 
199
  (keyword #f read-only #t)
 
200
  (categories #f read-only #t)
 
201
  (rex-prefix #f read-only #t)
 
202
  (mode #f read-only #t)
 
203
  (register #f read-only #t)
 
204
  (extra '() read-only #t))
 
205
 
 
206
(declare (integrate-operator register-rex))
 
207
(define-integrable (register-rex register rex)
 
208
  (declare (integrate register))
 
209
  (if (>= register 8)
 
210
      rex
 
211
      0))
 
212
 
 
213
(define (cons-ModR/M digit ea tail)
 
214
  (cons-syntax (ea/register ea)
 
215
    (cons-syntax digit
 
216
      (cons-syntax (ea/mode ea)
 
217
        (append-syntax! (ea/extra ea) tail)))))
 
218
 
 
219
(declare (integrate-operator opcode-register))
 
220
(define (opcode-register opcode register)
 
221
  (declare (integrate opcode))
 
222
  (+ opcode (if (>= register 8) (- register 8) register)))
 
223
 
 
224
(declare (integrate-operator float-comparator))
 
225
(define (float-comparator comparator)
 
226
  (case comparator
 
227
    ((=) 0)
 
228
    ((<) 1)
 
229
    ((<=) 2)
 
230
    ((UNORDERED) 3)
 
231
    ((/=) 4)
 
232
    ((>=) 5)
 
233
    ((>) 6)
 
234
    ((ORDERED) 7)
 
235
    (else (error "Bad float comparator:" comparator))))
 
236
 
 
237
(declare (integrate-operator operand-size))
 
238
(define (operand-size s)
 
239
  ;; B must be handled separately in general.
 
240
  (case s
 
241
    ((W L Q) s)
 
242
    (else #f)))
 
243
 
 
244
(declare (integrate-operator float-packed/scalar))
 
245
(define (float-packed/scalar s)
 
246
  (case s
 
247
    ((S P) s)
 
248
    (else #f)))
 
249
 
 
250
(declare (integrate-operator float-precision))
 
251
(define (float-precision s)
 
252
  (case s
 
253
    ((D S) s)
 
254
    (else #f)))
 
255
 
 
256
;;; The REX prefix must come last, just before the `actual' opcode.
 
257
 
 
258
(define (cons-prefix operand-size register ea tail)
 
259
  ((lambda (tail)
 
260
     (if (eq? operand-size 'W)
 
261
         (cons-syntax (syntax-evaluation #x66 coerce-8-bit-unsigned)
 
262
                      tail)
 
263
         tail))
 
264
   ((lambda (rex-prefix)
 
265
      (if (zero? rex-prefix)
 
266
          tail
 
267
          (cons-syntax (syntax-evaluation rex-prefix coerce-8-bit-unsigned)
 
268
                       tail)))
 
269
    (fix:or
 
270
     (case operand-size
 
271
       ;; B must be handled separately; there is no prefix for it.
 
272
       ;; W is handled with a #x66 prefix.
 
273
       ;; L is the default.
 
274
       ((#F W L) 0)
 
275
       ((Q) #x48)
 
276
       (else (error "Invalid operand size:" operand-size)))
 
277
     (let ((extended-register?
 
278
            (or (eqv? register #t)
 
279
                (and register (>= register 8)))))
 
280
       (if ea
 
281
           (fix:or (if extended-register? #x44 0) (ea/rex-prefix ea))
 
282
           (if extended-register? #x41 0)))))))
 
283
 
 
284
(define (cons-float-prefix register ea packed/scalar precision tail)
 
285
  ((lambda (tail)
 
286
     (let ((float (list packed/scalar precision)))
 
287
       (if (equal? float '(P S))
 
288
           tail
 
289
           (cons-syntax (syntax-evaluation
 
290
                         (cond ((equal? float '(P D)) #x66)
 
291
                               ((equal? float '(S D)) #xF2)
 
292
                               ((equal? float '(S S)) #xF3)
 
293
                               (else (error "Bad float type:" float)))
 
294
                         coerce-8-bit-unsigned)
 
295
                        tail))))
 
296
   (let ((rex-prefix
 
297
          (let ((extended-register?
 
298
                 (or (eqv? register #t)
 
299
                     (and register (>= register 8)))))
 
300
            (if ea
 
301
                (fix:or (if extended-register? #x44 0) (ea/rex-prefix ea))
 
302
                (if extended-register? #x41 0)))))
 
303
     (if (zero? rex-prefix)
 
304
         tail
 
305
         (cons-syntax (syntax-evaluation rex-prefix coerce-8-bit-unsigned)
 
306
                      tail)))))
 
307
 
 
308
(define-integrable (register-bits r)
 
309
  (fix:and r #b111))
 
310
 
 
311
(declare (integrate-operator indirect-reg))
 
312
(define (indirect-reg r)
 
313
  (and (not (let ((bits (register-bits r)))
 
314
              (or (= bits 4)
 
315
                  (= bits 5))))
 
316
       r))
 
317
 
 
318
(declare (integrate-operator indirect-reg=4mod8))
 
319
(define (indirect-reg=4mod8 r)
 
320
  (and (= (register-bits r) 4)
 
321
       r))
 
322
 
 
323
(declare (integrate-operator indirect-reg=5mod8))
 
324
(define (indirect-reg=5mod8 r)
 
325
  (and (= (register-bits r) 5)
 
326
       r))
 
327
 
 
328
(declare (integrate-operator offset-indirect-reg))
 
329
(define (offset-indirect-reg r)
 
330
  (and (not (= (register-bits r) 4))
 
331
       r))
 
332
 
 
333
(declare (integrate-operator offset-indirect-reg=4mod8))
 
334
(define (offset-indirect-reg=4mod8 r)
 
335
  (and (= (register-bits r) 4)
 
336
       r))
 
337
 
 
338
(declare (integrate-operator base-reg))
 
339
(define (base-reg r)
 
340
  (and (not (= (register-bits r) 5))
 
341
       r))
 
342
 
 
343
(declare (integrate-operator base-reg=5mod8))
 
344
(define (base-reg=5mod8 r)
 
345
  (and (= (register-bits r) 5)
 
346
       r))
 
347
 
 
348
(declare (integrate-operator index-reg))
 
349
(define (index-reg r)
 
350
  (and (not (= r 4))
 
351
       r))
 
352
 
 
353
(define-integrable (index-scale scale-value)
 
354
  (case scale-value
 
355
    ((1) #b00)
 
356
    ((2) #b01)
 
357
    ((4) #b10)
 
358
    ((8) #b11)
 
359
    (else false)))
 
360
 
 
361
(declare (integrate-operator unsigned-2bit))
 
362
(define (unsigned-2bit value)
 
363
  (and (<= 0 value #b11) value))
 
364
 
 
365
(declare (integrate-operator unsigned-3bit))
 
366
(define (unsigned-3bit value)
 
367
  (and (<= 0 value #b111) value))
 
368
 
 
369
(declare (integrate-operator unsigned-5bit))
 
370
(define (unsigned-5bit value)
 
371
  (and (<= 0 value #b11111) value))
 
372
 
 
373
(define (signed-byte value)
 
374
  (and (fits-in-signed-byte? value)
 
375
       value))
 
376
 
 
377
(define (unsigned-byte value)
 
378
  (and (fits-in-unsigned-byte? value)
 
379
       value))
 
380
 
 
381
(define (signed-word value)
 
382
  (and (fits-in-signed-word? value)
 
383
       value))
 
384
 
 
385
(define (unsigned-word value)
 
386
  (and (fits-in-unsigned-word? value)
 
387
       value))
 
388
 
 
389
(define (signed-long value)
 
390
  (and (fits-in-signed-long? value)
 
391
       value))
 
392
 
 
393
(define (unsigned-long value)
 
394
  (and (fits-in-unsigned-long? value)
 
395
       value))
 
396
 
 
397
(define (signed-quad value)
 
398
  (and (fits-in-signed-quad? value)
 
399
       value))
 
400
 
 
401
(define (unsigned-quad value)
 
402
  (and (fits-in-unsigned-quad? value)
 
403
       value))
 
404
 
 
405
(define (sign-extended-byte value)
 
406
  (and (fits-in-signed-byte? value)
 
407
       value))
 
408
 
 
409
(define (zero-extended-byte value)
 
410
  (and (not (negative? value))
 
411
       (fits-in-signed-byte? value)
 
412
       value))
 
413
 
 
414
(define (sign-extended-word value)
 
415
  (and (fits-in-signed-word? value)
 
416
       value))
 
417
 
 
418
(define (zero-extended-word value)
 
419
  (and (not (negative? value))
 
420
       (fits-in-signed-word? value)
 
421
       value))
 
422
 
 
423
(define (sign-extended-long value)
 
424
  (and (fits-in-signed-long? value)
 
425
       value))
 
426
 
 
427
(define (zero-extended-long value)
 
428
  (and (not (negative? value))
 
429
       (fits-in-signed-long? value)
 
430
       value))
 
431
 
 
432
(define (sign-extended-quad value)
 
433
  (and (fits-in-signed-quad? value)
 
434
       value))
 
435
 
 
436
(define (zero-extended-quad value)
 
437
  (and (not (negative? value))
 
438
       (fits-in-signed-quad? value)
 
439
       value))
 
 
b'\\ No newline at end of file'