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