Newer
Older
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: python-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
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/vm.lisp,v 1.3 1997/07/26 17:05:10 dtc Exp $")
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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
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
169
170
171
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
296
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
327
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
361
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
416
417
418
419
;;;
;;; **********************************************************************
;;;
;;; This file contains the VM defintion noise for the x86.
;;;
;;; Written by William Lott
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;;
(in-package :x86)
;;;; Register specs
(eval-when (compile eval)
(defmacro defreg (name offset size)
(let ((offset-sym (symbolicate name "-OFFSET"))
(names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
`(progn
(eval-when (compile eval load)
(defconstant ,offset-sym ,offset))
(setf (svref ,names-vector ,offset-sym) ,(symbol-name name)))))
(defmacro defregset (name &rest regs)
`(eval-when (compile eval load)
(defconstant ,name
(list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
); eval-when
;;; Byte registers.
;;;
;;; Note: the encoding here is different then that used by the chip. We
;;; use this encoding so that the compiler thinks that AX (and EAX) overlap
;;; AL and AH instead of AL and CL.
;;;
(eval-when (compile load eval)
(defvar *byte-register-names* (make-array 8 :initial-element nil)))
;;;
(defreg al 0 :byte)
(defreg ah 1 :byte)
(defreg cl 2 :byte)
(defreg ch 3 :byte)
(defreg dl 4 :byte)
(defreg dh 5 :byte)
(defreg bl 6 :byte)
(defreg bh 7 :byte)
;;;
(defregset byte-regs al ah cl ch dl dh bl bh)
;;; Word registers.
;;;
(eval-when (compile load eval)
(defvar *word-register-names* (make-array 16 :initial-element nil)))
;;;
(defreg ax 0 :word)
(defreg cx 2 :word)
(defreg dx 4 :word)
(defreg bx 6 :word)
(defreg sp 8 :word)
(defreg bp 10 :word)
(defreg si 12 :word)
(defreg di 14 :word)
;;;
(defregset word-regs ax cx dx bx si di)
;;; Double Word registers.
;;;
(eval-when (compile load eval)
(defvar *dword-register-names* (make-array 16 :initial-element nil)))
;;;
(defreg eax 0 :dword)
(defreg ecx 2 :dword)
(defreg edx 4 :dword)
(defreg ebx 6 :dword)
(defreg esp 8 :dword)
(defreg ebp 10 :dword)
(defreg esi 12 :dword)
(defreg edi 14 :dword)
;;;
(defregset dword-regs eax ecx edx ebx esi edi)
;;; added by jrd
(eval-when (compile load eval)
(defvar *float-register-names* (make-array 8 :initial-element nil)))
(defreg fr0 0 :float)
(defreg fr1 1 :float)
(defreg fr2 2 :float)
(defreg fr3 3 :float)
(defreg fr4 4 :float)
(defreg fr5 5 :float)
(defreg fr6 6 :float)
(defreg fr7 7 :float)
(defregset float-regs fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
;(defvar *double-float-register-names* (make-array 8 :initial-element nil))
;(defreg dfr0 0 :double-float)
;(defreg dfr1 1 :double-float)
;(defreg dfr2 2 :double-float)
;(defreg dfr3 3 :double-float)
;(defreg dfr4 4 :double-float)
;(defreg dfr5 5 :double-float)
;(defreg dfr6 6 :double-float)
;(defreg dfr7 7 :double-float)
;(defregset double-float-regs dfr0 dfr1 dfr2 dfr3 dfr4 dfr5 dfr6 dfr7)
;;;; SB definitions.
;;; Despite the fact that there are only 8 different registers, we consider
;;; them 16 in order to describe the overlap of byte registers. The only
;;; thing we need to represent is what registers overlap. Therefore, we
;;; consider bytes to take one unit, and words or dwords to take two. We
;;; don't need to tell the difference between words and dwords, because
;;; you can't put two words in a dword.
(define-storage-base registers :finite :size 16)
;;;
;;; jrd changed this from size 1 to size 8. it doesn't seem to make much
;;; sense to use the 387's idea of a stack. 8 separate registers is easier
;;; to deal with.
;;; (define-storage-base float-registers :finite :size 1)
(define-storage-base float-registers :finite :size 8)
(define-storage-base stack :unbounded :size 8)
(define-storage-base constant :non-packed)
(define-storage-base immediate-constant :non-packed)
(define-storage-base noise :unbounded :size 2)
;;;; SC definitions.
;;;
;;; Handy macro so we don't have to keep changing all the numbers whenever
;;; we insert a new storage class.
;;;
(defmacro define-storage-classes (&rest classes)
(collect ((forms))
(let ((index 0))
(dolist (class classes)
(let* ((sc-name (car class))
(constant-name (symbolicate sc-name "-SC-NUMBER")))
(forms `(define-storage-class ,sc-name ,index
,@(cdr class)))
(forms `(defconstant ,constant-name ,index))
(forms `(export ',constant-name))
(incf index))))
`(progn
,@(forms))))
(define-storage-classes
;; Non-immediate contstants in the constant pool
(constant constant)
;; Some FP constants can be generated in the i387 silicon.
(fp-single-constant immediate-constant)
(fp-double-constant immediate-constant)
(immediate immediate-constant)
;; **** The stacks.
;; The control stack.
(descriptor-stack stack) ; may be pointers, scanned by GC
(immediate-stack stack) ; isn't pointers, ignored by GC
;; The non-descriptor stacks.
(signed-stack stack) ; (signed-byte 32)
(unsigned-stack stack) ; (unsigned-byte 32)
(base-char-stack stack) ; non-descriptor characters.
(sap-stack stack) ; System area pointers.
(single-stack stack) ; single-floats
(double-stack stack :element-size 2) ; double floats.
;; **** Magic SCs.
(ignore-me noise)
;; **** Things that can go in the integer registers.
;; We don't have to distinguish between descriptor and non-descriptor
;; registers, because we dump explicit information about what descriptor
;; values are live at any potential GC point. Therefore, we only different
;; scs to distinguish between descriptor and non-descriptor values and
;; to specify size.
(any-reg registers
:locations #.dword-regs
:element-size 2
:reserve-locations (#.eax-offset)
:constant-scs (immediate)
:save-p t
:alternate-scs (immediate-stack))
;; Pointer descriptor objects. Must be seen by GC.
(descriptor-reg registers
:locations #.dword-regs
:element-size 2
:reserve-locations (#.eax-offset)
:constant-scs
(constant immediate
;; zzz jrd added IMMEDIATE-STACK here.
;; it seems right, and references elsewhere
;; in the code suggest that we expect to be
;; able to do this. see
;; DEFINE-MOVE-VOP MOVE :MOVE in MOVE.LISP
;; zzz this may not be right after all
;; immediate-stack
)
:save-p t
:alternate-scs (descriptor-stack))
;; Non-Descriptor characters
(base-char-reg registers
:locations #.byte-regs
:reserve-locations (#.ah-offset #.al-offset)
:constant-scs (immediate)
:save-p t
:alternate-scs (base-char-stack))
;; Non-Descriptor SAP's (arbitrary pointers into address space)
(sap-reg registers
:locations #.dword-regs
:element-size 2
:reserve-locations (#.eax-offset)
:constant-scs (immediate)
:save-p t
:alternate-scs (sap-stack))
;; Non-Descriptor (signed or unsigned) numbers.
(signed-reg registers
:locations #.dword-regs
:element-size 2
:reserve-locations (#.eax-offset)
:constant-scs (immediate)
:save-p t
:alternate-scs (signed-stack))
(unsigned-reg registers
:locations #.dword-regs
:element-size 2
:reserve-locations (#.eax-offset)
:constant-scs (immediate)
:save-p t
:alternate-scs (unsigned-stack))
;; Random objects that must not be seen by GC. Used only as temporaries.
(dword-reg registers
:locations #.dword-regs
:element-size 2
:reserve-locations (#.eax-offset))
(word-reg registers
:locations #.word-regs
:element-size 2
:reserve-locations (#.ax-offset))
(byte-reg registers
:locations #.byte-regs
:reserve-locations (#.al-offset #.ah-offset))
;; **** Things that can go in the floating point registers.
;; Non-Descriptor single-floats.
(single-reg float-registers
:locations (0 1 2 3 4 5 6 7)
:constant-scs (fp-single-constant)
:save-p t
:alternate-scs (single-stack))
;; Non-Descriptor double-floats.
(double-reg float-registers
:locations (0 1 2 3 4 5 6 7)
:constant-scs (fp-double-constant)
:save-p t
:alternate-scs (double-stack))
;; A catch or unwind block.
(catch-block stack :element-size vm:catch-block-size)
;; added by jrd. need to define non-descriptor-reg-sc-number for the
;; debug code, among others. this doesn't actually get used in any code.
(non-descriptor-reg registers
:locations #.dword-regs
:element-size 2
:reserve-locations ())
;; this one too
(interior-reg registers
:locations #.dword-regs
:element-size 2
:reserve-locations ())
)
;;; zzz added by jrd; has somebody been changing names of these things on me?
(export 'control-stack-sc-number)
(defconstant control-stack-sc-number descriptor-stack-sc-number)
(eval-when (compile load eval)
(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack))
(defconstant word-sc-names '(word-reg))
(defconstant dword-sc-names
'(any-reg descriptor-reg sap-reg signed-reg unsigned-reg dword-reg
descriptor-stack immediate-stack signed-stack unsigned-stack
sap-stack single-stack constant))
;;;
;;; added by jrd. I guess the right thing to do is to treat floats
;;; as a separate size...
;;;
;;; These are used to (at least) determine operand size.
(defconstant float-sc-names '(single-reg))
(defconstant double-sc-names '(double-reg double-stack))
)
;;;; Random TNs for the various registers.
(eval-when (compile eval)
(defmacro def-random-reg-tns (sc-name &rest reg-names)
(collect ((forms))
(dolist (reg-name reg-names)
(let ((reg-tn-name (symbolicate reg-name "-TN"))
(reg-offset-name (symbolicate reg-name "-OFFSET")))
;;(forms `(export ',reg-tn-name))
(forms `(defparameter ,reg-tn-name
(make-random-tn :kind :normal
:sc (sc-or-lose ',sc-name)
:offset ,reg-offset-name)))))
`(progn ,@(forms)))))
(def-random-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi)
(def-random-reg-tns word-reg ax bx cx dx bp sp di si)
(def-random-reg-tns byte-reg al ah bl bh cl ch dl dh)
;; added by jrd
(def-random-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
;; Added by pw.
(defparameter fp-single-constant-tn
(make-random-tn :kind :normal
:sc (sc-or-lose 'fp-single-constant)
:offset 31)) ; Offset doesn't get used.
(defparameter fp-double-constant-tn
(make-random-tn :kind :normal
:sc (sc-or-lose 'fp-single-constant)
:offset 31))
;;; Immediate-Constant-SC
;;;
;;; Basically, if it's easier to represent the value as an immediate in
;;; some instruction instead of in the constants pool, then return
;;; the immediate SC.
;;;
#+nil ;; pw-- the way it was.
(def-vm-support-routine immediate-constant-sc (value)
(if (or (and (symbolp value) (static-symbol-p value))
#-cross-compiler
(typep value 'fixnum)
#+cross-compiler
(and (typep value 'integer)
(>= value (info variable constant-value 'most-negative-fixnum))
(<= value (info variable constant-value 'most-positive-fixnum)))
#-cross-compiler
(typep value 'system-area-pointer)
(typep value
#+lispworks3 'lisp::base-character
#-lispworks3 'base-char))
(sc-number-or-lose 'immediate *backend*)
nil))
;;; I probably should use double-from-bits here
;;; to avoid any compilation errors, but lets see
;;; what happens. These should be part of lisp like PI?
(defconstant i387-lg2 3.010299956639811952137389d0)
(defconstant i387-ln2 0.6931471805599453094172321d0)
(defconstant i387-l10 2.3025850929940456840179915d0)
(defconstant i387-l2e (/ i387-ln2))
(defconstant i387-l2t (/ i387-l10 i387-ln2))
(export '(i387-lg2 i387-ln2 i387-l10 i387-l2e i387-l2t))
;;; pw-- A good try and it works, but it also results in
;;; extra consing when the constant is an argument to
;;; some function. The descriptor from the constants vector
;;; would normally be passed instead. DTC processes zero and
;;; one in move-from-single|double as static symbols to
;;; save on CV space for these common values.
(def-vm-support-routine immediate-constant-sc (value)
(typecase value
((or fixnum system-area-pointer character)
(sc-number-or-lose 'immediate *backend*))
(symbol
(if (static-symbol-p value)
(sc-number-or-lose 'immediate *backend*)
nil))
(single-float
(when (or (eql value 0f0) (eql value 1f0))
(sc-number-or-lose 'fp-single-constant *backend*)))
(double-float
(when (or (eql value 0d0) (eql value 1d0))
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
(sc-number-or-lose 'fp-double-constant *backend*)))))
;;;; Function Call Parameters
;;; Offsets of special stack frame locations
(defconstant old-fp-save-offset 0)
(defconstant return-pc-save-offset 1)
(defconstant code-save-offset 2)
;;; names of these things seem to have changed. these aliases by jrd
(defconstant ocfp-save-offset old-fp-save-offset)
(defconstant lra-save-offset return-pc-save-offset)
(defconstant cfp-offset ebp-offset) ; pfw - needed by stuff in /code
; related to sigcontext stuff
;;; The number of arguments/return values passed in registers.
;;;
(defconstant register-arg-count 3)
;;; Names, Offsets, and TNs to use for the argument registers.
;;;
(defconstant register-arg-names '(edx edi esi))
(defregset register-arg-offsets edx edi esi)
(defparameter register-arg-tns (list edx-tn edi-tn esi-tn))
;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
;;;
;;; This is used by the debugger.
;;;
(export 'single-value-return-byte-offset)
(defconstant single-value-return-byte-offset 2)
;;; LOCATION-PRINT-NAME -- Interface
;;;
;;; This function is called by debug output routines that want a pretty name
;;; for a TN's location. It returns a thing that can be printed with PRINC.
;;;
(def-vm-support-routine location-print-name (tn)
(declare (type tn tn))
(let* ((sc (tn-sc tn))
(sb (sb-name (sc-sb sc)))
(offset (tn-offset tn)))
(ecase sb
(registers
(let* ((sc-name (sc-name sc))
(name-vec (cond ((member sc-name byte-sc-names)
*byte-register-names*)
((member sc-name word-sc-names)
*word-register-names*)
((member sc-name dword-sc-names)
*dword-register-names*))))
(or (and name-vec
(< -1 offset (length name-vec))
(svref name-vec offset))
(format nil "<Unknown Reg: off=~D, sc=~A>" offset sc-name))))
;; (float-registers "FloatStackTop")
(float-registers (format nil "FR~D" offset))
(stack (format nil "S~D" offset))
(constant (format nil "Const~D" offset))
(immediate-constant "Immed")
(noise (symbol-name (sc-name sc))))))