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