[025678]: src / compiler / mips / vm.lisp Maximize Restore History

Download this file

vm.lisp    370 lines (303 with data), 12.1 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 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
;;;; miscellaneous VM definition noise for MIPS
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; Registers
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *register-names* (make-array 32 :initial-element nil)))
(macrolet ((defreg (name offset)
(let ((offset-sym (symbolicate name "-OFFSET")))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(def!constant ,offset-sym ,offset)
(setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
(defregset (name &rest regs)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter ,name
(list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))))
;; Wired zero register.
(defreg zero 0) ; NULL
;; Reserved for assembler use.
(defreg nl3 1) ; untagged temporary 3
;; C return registers.
(defreg cfunc 2) ; FF function address, wastes a register
(defreg nl4 3) ; PA flag
;; C argument registers.
(defreg nl0 4) ; untagged temporary 0
(defreg nl1 5) ; untagged temporary 1
(defreg nl2 6) ; untagged temporary 2
(defreg nargs 7) ; number of function arguments
;; C unsaved temporaries.
(defreg a0 8) ; function arg 0
(defreg a1 9) ; function arg 1
(defreg a2 10) ; function arg 2
(defreg a3 11) ; function arg 3
(defreg a4 12) ; function arg 4
(defreg a5 13) ; function arg 5
(defreg fdefn 14) ; ?
(defreg lexenv 15) ; wastes a register
;; C saved registers.
(defreg nfp 16) ; non-lisp frame pointer
(defreg ocfp 17) ; caller's control frame pointer
(defreg lra 18) ; tagged Lisp return address
(defreg l0 19) ; tagged temporary 0
(defreg null 20) ; NIL
(defreg bsp 21) ; binding stack pointer
(defreg cfp 22) ; control frame pointer
(defreg csp 23) ; control stack pointer
;; More C unsaved temporaries.
(defreg l1 24) ; tagged temporary 1
(defreg alloc 25) ; ALLOC pointer
;; 26 and 27 are used by the system kernel.
;; 28 is the global pointer of our C runtime, and used for
;; jump/branch relaxation in Lisp.
(defreg nsp 29) ; number (native) stack pointer
;; C frame pointer, or additional saved register.
(defreg code 30) ; current function object
;; Return link register.
(defreg lip 31) ; Lisp interior pointer
(defregset non-descriptor-regs
nl0 nl1 nl2 nl3 nl4 cfunc nargs)
(defregset descriptor-regs
a0 a1 a2 a3 a4 a5 fdefn lexenv nfp ocfp lra l0 l1)
(defregset *register-arg-offsets*
a0 a1 a2 a3 a4 a5)
(defregset reserve-descriptor-regs
fdefn lexenv)
(defregset reserve-non-descriptor-regs
nl4 cfunc))
;;;; SB and SC definition:
(define-storage-base registers :finite :size 32)
(define-storage-base float-registers :finite :size 32)
(define-storage-base control-stack :unbounded :size 8)
(define-storage-base non-descriptor-stack :unbounded :size 0)
(define-storage-base constant :non-packed)
(define-storage-base immediate-constant :non-packed)
;;;
;;; 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)
(do ((forms (list 'progn)
(let* ((class (car classes))
(sc-name (car class))
(constant-name (intern (concatenate 'simple-string
(string sc-name)
"-SC-NUMBER"))))
(list* `(define-storage-class ,sc-name ,index
,@(cdr class))
`(defconstant ,constant-name ,index)
`(export ',constant-name)
forms)))
(index 0 (1+ index))
(classes classes (cdr classes)))
((null classes)
(nreverse forms))))
(def!constant kludge-nondeterministic-catch-block-size 7)
(!define-storage-classes
;; Non-immediate constants in the constant pool
(constant constant)
;; Immediate constant.
(null immediate-constant)
(zero immediate-constant)
(immediate immediate-constant)
;; **** The stacks.
;; The control stack. (Scanned by GC)
(control-stack control-stack)
;; The non-descriptor stacks.
(signed-stack non-descriptor-stack) ; (signed-byte 32)
(unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
(character-stack non-descriptor-stack) ; non-descriptor characters.
(sap-stack non-descriptor-stack) ; System area pointers.
(single-stack non-descriptor-stack) ; single-floats
(double-stack non-descriptor-stack :element-size 2) ; double floats.
;; complex-single-floats
(complex-single-stack non-descriptor-stack :element-size 2)
;; complex-double-floats.
(complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
;; **** Things that can go in the integer registers.
;; Immediate descriptor objects. Don't have to be seen by GC, but nothing
;; bad will happen if they are. (fixnums, characters, header values, etc).
(any-reg
registers
:locations #.(append non-descriptor-regs descriptor-regs)
:reserve-locations #.(append reserve-non-descriptor-regs
reserve-descriptor-regs)
:constant-scs (constant zero immediate)
:save-p t
:alternate-scs (control-stack))
;; Pointer descriptor objects. Must be seen by GC.
(descriptor-reg registers
:locations #.descriptor-regs
:reserve-locations #.reserve-descriptor-regs
:constant-scs (constant null immediate)
:save-p t
:alternate-scs (control-stack))
;; Non-Descriptor characters
(character-reg registers
:locations #.non-descriptor-regs
:reserve-locations #.reserve-non-descriptor-regs
:constant-scs (immediate)
:save-p t
:alternate-scs (character-stack))
;; Non-Descriptor SAP's (arbitrary pointers into address space)
(sap-reg registers
:locations #.non-descriptor-regs
:reserve-locations #.reserve-non-descriptor-regs
:constant-scs (immediate)
:save-p t
:alternate-scs (sap-stack))
;; Non-Descriptor (signed or unsigned) numbers.
(signed-reg registers
:locations #.non-descriptor-regs
:reserve-locations #.reserve-non-descriptor-regs
:constant-scs (zero immediate)
:save-p t
:alternate-scs (signed-stack))
(unsigned-reg registers
:locations #.non-descriptor-regs
:reserve-locations #.reserve-non-descriptor-regs
:constant-scs (zero immediate)
:save-p t
:alternate-scs (unsigned-stack))
;; Random objects that must not be seen by GC. Used only as temporaries.
(non-descriptor-reg registers
:locations #.non-descriptor-regs)
;; Pointers to the interior of objects. Used only as an temporary.
(interior-reg registers
:locations (#.lip-offset))
;; **** Things that can go in the floating point registers.
;; Non-Descriptor single-floats.
(single-reg float-registers
:locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
:reserve-locations (26 28 30)
:constant-scs ()
:save-p t
:alternate-scs (single-stack))
;; Non-Descriptor double-floats.
(double-reg float-registers
:locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
:reserve-locations (26 28 30)
;; Note: we don't bother with the element size, 'cause nothing can be
;; allocated in the odd fp regs anyway.
:constant-scs ()
:save-p t
:alternate-scs (double-stack))
(complex-single-reg float-registers
:locations (0 4 8 12 16 20 24 28)
:element-size 4
:reserve-locations (24 28)
:constant-scs ()
:save-p t
:alternate-scs (complex-single-stack))
(complex-double-reg float-registers
:locations (0 4 8 12 16 20 24 28)
:element-size 4
:reserve-locations (24 28)
:constant-scs ()
:save-p t
:alternate-scs (complex-double-stack))
;; A catch or unwind block.
(catch-block control-stack :element-size kludge-nondeterministic-catch-block-size)
;; floating point numbers temporarily stuck in integer registers for c-call
(single-int-carg-reg registers
:locations (4 5 6 7)
:alternate-scs ()
:constant-scs ())
(double-int-carg-reg registers
:locations (4 6)
:constant-scs ()
:alternate-scs ()
:alignment 2 ;is this needed?
:element-size 2))
;;;; Random TNs for interesting registers
(macrolet ((defregtn (name sc)
(let ((offset-sym (symbolicate name "-OFFSET"))
(tn-sym (symbolicate name "-TN")))
`(defparameter ,tn-sym
(make-random-tn :kind :normal
:sc (sc-or-lose ',sc)
:offset ,offset-sym)))))
(defregtn zero any-reg)
(defregtn nargs any-reg)
(defregtn fdefn descriptor-reg)
(defregtn lexenv descriptor-reg)
(defregtn nfp any-reg)
(defregtn ocfp any-reg)
(defregtn null descriptor-reg)
(defregtn bsp any-reg)
(defregtn cfp any-reg)
(defregtn csp any-reg)
(defregtn alloc any-reg)
(defregtn nsp any-reg)
(defregtn code descriptor-reg)
(defregtn lip interior-reg))
;;; If VALUE can be represented as an immediate constant, then return the
;;; appropriate SC number, otherwise return NIL.
(!def-vm-support-routine immediate-constant-sc (value)
(typecase value
((integer 0 0)
(sc-number-or-lose 'zero))
(null
(sc-number-or-lose 'null))
(symbol
(if (static-symbol-p value)
(sc-number-or-lose 'immediate)
nil))
((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
system-area-pointer character)
(sc-number-or-lose 'immediate))
(system-area-pointer
(sc-number-or-lose 'immediate))
(character
(sc-number-or-lose 'immediate))))
;;;; Function Call Parameters
;;; The SC numbers for register and stack arguments/return values.
;;;
(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; Offsets of special stack frame locations
(defconstant ocfp-save-offset 0)
(defconstant lra-save-offset 1)
(defconstant nfp-save-offset 2)
;;; The number of arguments/return values passed in registers.
;;;
(defconstant register-arg-count 6)
;;; The offsets within the register-arg SC that we pass values in, first
;;; value first.
;;;
;;; Names to use for the argument registers.
;;;
(defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
) ; EVAL-WHEN
;;; A list of TN's describing the register arguments.
;;;
(defparameter register-arg-tns
(mapcar #'(lambda (n)
(make-random-tn :kind :normal
:sc (sc-or-lose 'descriptor-reg)
:offset n))
*register-arg-offsets*))
;;; This is used by the debugger.
(defconstant single-value-return-byte-offset 8)
;;; 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 ((sb (sb-name (sc-sb (tn-sc tn))))
(offset (tn-offset tn)))
(ecase sb
(registers (or (svref *register-names* offset)
(format nil "R~D" offset)))
(float-registers (format nil "F~D" offset))
(control-stack (format nil "CS~D" offset))
(non-descriptor-stack (format nil "NS~D" offset))
(constant (format nil "Const~D" offset))
(immediate-constant "Immed"))))