0.8.3.35:
[sbcl.git] / src / compiler / mips / vm.lisp
1 (in-package "SB!VM")
2
3 \f
4 ;;;; Registers
5
6 (eval-when (:compile-toplevel :load-toplevel :execute)
7   (defvar *register-names* (make-array 32 :initial-element nil)))
8
9 (macrolet ((defreg (name offset)
10                (let ((offset-sym (symbolicate name "-OFFSET")))
11                  `(eval-when (:compile-toplevel :load-toplevel :execute)
12                    (defconstant ,offset-sym ,offset)
13                    (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
14
15            (defregset (name &rest regs)
16                `(eval-when (:compile-toplevel :load-toplevel :execute)
17                  (defparameter ,name
18                    (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))))
19   (defreg zero 0)
20   (defreg nl3 1)
21   (defreg cfunc 2)
22   (defreg nl4 3)
23   (defreg nl0 4) ; First C argument reg.
24   (defreg nl1 5)
25   (defreg nl2 6)
26   (defreg nargs 7)
27   (defreg a0 8)
28   (defreg a1 9)
29   (defreg a2 10)
30   (defreg a3 11)
31   (defreg a4 12)
32   (defreg a5 13)
33   (defreg fdefn 14)
34   (defreg lexenv 15)
35   ;; First saved reg
36   (defreg nfp 16)
37   (defreg ocfp 17)
38   (defreg lra 18)
39   (defreg l0 19)
40   (defreg null 20)
41   (defreg bsp 21)
42   (defreg cfp 22)
43   (defreg csp 23)
44   (defreg l1 24)
45   (defreg alloc 25)
46   (defreg nsp 29)
47   (defreg code 30)
48   (defreg lip 31)
49
50   (defregset non-descriptor-regs
51       nl0 nl1 nl2 nl3 nl4 cfunc nargs)
52
53   (defregset descriptor-regs
54       a0 a1 a2 a3 a4 a5 fdefn lexenv nfp ocfp lra l0 l1)
55
56   (defregset *register-arg-offsets*
57       a0 a1 a2 a3 a4 a5)
58
59   (defregset reserve-descriptor-regs
60       fdefn lexenv)
61
62   (defregset reserve-non-descriptor-regs
63       nl4 cfunc))
64
65 \f
66 ;;;; SB and SC definition:
67
68 (define-storage-base registers :finite :size 32)
69 (define-storage-base float-registers :finite :size 32)
70 (define-storage-base control-stack :unbounded :size 8)
71 (define-storage-base non-descriptor-stack :unbounded :size 0)
72 (define-storage-base constant :non-packed)
73 (define-storage-base immediate-constant :non-packed)
74
75 ;;;
76 ;;; Handy macro so we don't have to keep changing all the numbers whenever
77 ;;; we insert a new storage class.
78 ;;; 
79 (defmacro !define-storage-classes (&rest classes)
80   (do ((forms (list 'progn)
81               (let* ((class (car classes))
82                      (sc-name (car class))
83                      (constant-name (intern (concatenate 'simple-string
84                                                          (string sc-name)
85                                                          "-SC-NUMBER"))))
86                 (list* `(define-storage-class ,sc-name ,index
87                           ,@(cdr class))
88                        `(defconstant ,constant-name ,index)
89                        `(export ',constant-name)
90                        forms)))
91        (index 0 (1+ index))
92        (classes classes (cdr classes)))
93       ((null classes)
94        (nreverse forms))))
95
96 (def!constant sb!vm::kludge-nondeterministic-catch-block-size 7)
97
98 (!define-storage-classes
99
100   ;; Non-immediate constants in the constant pool
101   (constant constant)
102
103   ;; Immediate constant.
104   (null immediate-constant)
105   (zero immediate-constant)
106   (immediate immediate-constant)
107
108   ;; **** The stacks.
109
110   ;; The control stack.  (Scanned by GC)
111   (control-stack control-stack)
112
113   ;; The non-descriptor stacks.
114   (signed-stack non-descriptor-stack) ; (signed-byte 32)
115   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
116   (base-char-stack non-descriptor-stack) ; non-descriptor characters.
117   (sap-stack non-descriptor-stack) ; System area pointers.
118   (single-stack non-descriptor-stack) ; single-floats
119   (double-stack non-descriptor-stack :element-size 2) ; double floats.
120   ;; complex-single-floats
121   (complex-single-stack non-descriptor-stack :element-size 2)
122   ;; complex-double-floats.
123   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
124
125
126   ;; **** Things that can go in the integer registers.
127
128   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
129   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
130   (any-reg
131    registers
132    :locations #.(append non-descriptor-regs descriptor-regs)
133    :reserve-locations #.(append reserve-non-descriptor-regs
134                                 reserve-descriptor-regs)
135    :constant-scs (constant zero immediate)
136    :save-p t
137    :alternate-scs (control-stack))
138
139   ;; Pointer descriptor objects.  Must be seen by GC.
140   (descriptor-reg registers
141    :locations #.descriptor-regs
142    :reserve-locations #.reserve-descriptor-regs
143    :constant-scs (constant null immediate)
144    :save-p t
145    :alternate-scs (control-stack))
146
147   ;; Non-Descriptor characters
148   (base-char-reg registers
149    :locations #.non-descriptor-regs
150    :reserve-locations #.reserve-non-descriptor-regs
151    :constant-scs (immediate)
152    :save-p t
153    :alternate-scs (base-char-stack))
154
155   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
156   (sap-reg registers
157    :locations #.non-descriptor-regs
158    :reserve-locations #.reserve-non-descriptor-regs
159    :constant-scs (immediate)
160    :save-p t
161    :alternate-scs (sap-stack))
162
163   ;; Non-Descriptor (signed or unsigned) numbers.
164   (signed-reg registers
165    :locations #.non-descriptor-regs
166    :reserve-locations #.reserve-non-descriptor-regs
167    :constant-scs (zero immediate)
168    :save-p t
169    :alternate-scs (signed-stack))
170   (unsigned-reg registers
171    :locations #.non-descriptor-regs
172    :reserve-locations #.reserve-non-descriptor-regs
173    :constant-scs (zero immediate)
174    :save-p t
175    :alternate-scs (unsigned-stack))
176
177   ;; Random objects that must not be seen by GC.  Used only as temporaries.
178   (non-descriptor-reg registers
179    :locations #.non-descriptor-regs)
180
181   ;; Pointers to the interior of objects.  Used only as an temporary.
182   (interior-reg registers
183    :locations (#.lip-offset))
184
185
186   ;; **** Things that can go in the floating point registers.
187
188   ;; Non-Descriptor single-floats.
189   (single-reg float-registers
190    :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
191    :reserve-locations (26 28 30)
192    :constant-scs ()
193    :save-p t
194    :alternate-scs (single-stack))
195
196   ;; Non-Descriptor double-floats.
197   (double-reg float-registers
198    :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
199    :reserve-locations (26 28 30)
200    ;; Note: we don't bother with the element size, 'cause nothing can be
201    ;; allocated in the odd fp regs anyway.
202    :constant-scs ()
203    :save-p t
204    :alternate-scs (double-stack))
205
206   (complex-single-reg float-registers
207    :locations (0 4 8 12 16 20 24 28)
208    :element-size 4
209    :reserve-locations (24 28)
210    :constant-scs ()
211    :save-p t
212    :alternate-scs (complex-single-stack))
213
214   (complex-double-reg float-registers
215    :locations (0 4 8 12 16 20 24 28)
216    :element-size 4
217    :reserve-locations (24 28)
218    :constant-scs ()
219    :save-p t
220    :alternate-scs (complex-double-stack))
221
222   ;; A catch or unwind block.
223   (catch-block control-stack :element-size sb!vm::kludge-nondeterministic-catch-block-size)
224
225   ;; floating point numbers temporarily stuck in integer registers for c-call
226   (single-int-carg-reg registers
227                   :locations (4 5 6 7)
228                   :alternate-scs ()
229                   :constant-scs ())
230   (double-int-carg-reg registers
231                   :locations (4 6)
232                   :constant-scs ()
233                   :alternate-scs ()
234                   :alignment 2          ;is this needed?
235                   :element-size 2))
236
237
238
239 \f
240 ;;;; Random TNs for interesting registers
241
242 (macrolet ((defregtn (name sc)
243                (let ((offset-sym (symbolicate name "-OFFSET"))
244                      (tn-sym (symbolicate name "-TN")))
245                  `(defparameter ,tn-sym
246                    (make-random-tn :kind :normal
247                     :sc (sc-or-lose ',sc)
248                     :offset ,offset-sym)))))
249   (defregtn zero any-reg)
250   (defregtn lip interior-reg)
251   (defregtn code descriptor-reg)
252   (defregtn alloc any-reg)
253   (defregtn null descriptor-reg)
254
255   (defregtn nargs any-reg)
256   (defregtn fdefn descriptor-reg)
257   (defregtn lexenv descriptor-reg)
258
259   (defregtn bsp any-reg)
260   (defregtn csp any-reg)
261   (defregtn cfp any-reg)
262   (defregtn ocfp any-reg)
263   (defregtn nsp any-reg)
264   (defregtn nfp any-reg))
265 \f
266 ;;; If VALUE can be represented as an immediate constant, then return the
267 ;;; appropriate SC number, otherwise return NIL.
268 (!def-vm-support-routine immediate-constant-sc (value)
269   (typecase value
270     ((integer 0 0)
271      (sc-number-or-lose 'zero))
272     (null
273      (sc-number-or-lose 'null))
274     (symbol
275      (if (static-symbol-p value)
276          (sc-number-or-lose 'immediate)
277          nil))
278     ((signed-byte 30)
279      (sc-number-or-lose 'immediate))
280     (system-area-pointer
281      (sc-number-or-lose 'immediate))
282     (character
283      (sc-number-or-lose 'immediate))))
284
285 \f
286 ;;;; Function Call Parameters
287
288 ;;; The SC numbers for register and stack arguments/return values.
289 ;;;
290 (defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
291 (defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
292 (defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
293
294 (eval-when (:compile-toplevel :load-toplevel :execute)
295
296 ;;; Offsets of special stack frame locations
297 (defconstant ocfp-save-offset 0)
298 (defconstant lra-save-offset 1)
299 (defconstant nfp-save-offset 2)
300
301 ;;; The number of arguments/return values passed in registers.
302 ;;;
303 (defconstant register-arg-count 6)
304
305 ;;; The offsets within the register-arg SC that we pass values in, first
306 ;;; value first.
307 ;;;
308
309 ;;; Names to use for the argument registers.
310 ;;; 
311 (defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
312
313 ) ; EVAL-WHEN
314
315
316 ;;; A list of TN's describing the register arguments.
317 ;;;
318 (defparameter register-arg-tns
319   (mapcar #'(lambda (n)
320               (make-random-tn :kind :normal
321                               :sc (sc-or-lose 'descriptor-reg)
322                               :offset n))
323           *register-arg-offsets*))
324
325 ;;; This is used by the debugger.
326 (defconstant single-value-return-byte-offset 8)
327 \f
328 ;;; This function is called by debug output routines that want a pretty name
329 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
330 (!def-vm-support-routine location-print-name (tn)
331   (declare (type tn tn))
332   (let ((sb (sb-name (sc-sb (tn-sc tn))))
333         (offset (tn-offset tn)))
334     (ecase sb
335       (registers (or (svref *register-names* offset)
336                      (format nil "R~D" offset)))
337       (float-registers (format nil "F~D" offset))
338       (control-stack (format nil "CS~D" offset))
339       (non-descriptor-stack (format nil "NS~D" offset))
340       (constant (format nil "Const~D" offset))
341       (immediate-constant "Immed"))))
342
343 (defun extern-alien-name (name)
344   (declare (type simple-base-string name))
345   name)