0.8.17.17:
[sbcl.git] / src / compiler / alpha / vm.lisp
1 ;;;; miscellaneous VM definition noise for the Alpha
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 \f
14 ;;;; defining the registers
15
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17   (defvar *register-names* (make-array 32 :initial-element nil)))
18
19 (macrolet ((defreg (name offset)
20              (let ((offset-sym (symbolicate name "-OFFSET")))
21                `(eval-when (:compile-toplevel :load-toplevel :execute)
22                   (def!constant ,offset-sym ,offset)
23                   (setf (svref *register-names* ,offset-sym)
24                         ,(symbol-name name)))))
25            (defregset (name &rest regs)
26              `(eval-when  (:compile-toplevel :load-toplevel :execute)
27                 (defparameter ,name
28                   (list ,@(mapcar (lambda (name)
29                                     (symbolicate name "-OFFSET"))
30                                   regs))))))
31   ;; c.f. src/runtime/alpha-lispregs.h
32   
33   ;; Ra
34   (defreg lip 0)
35   ;; Caller saved 0-7
36   (defreg a0 1)
37   (defreg a1 2)
38   (defreg a2 3)
39   (defreg a3 4)
40   (defreg a4 5)
41   (defreg a5 6)
42   (defreg l0 7)
43   (defreg nargs 8)
44   ;; Callee saved 0-6
45   (defreg csp 9)
46   (defreg cfp 10)
47   (defreg ocfp 11)
48   (defreg bsp 12)
49   (defreg lexenv 13)
50   (defreg code 14)
51   (defreg null 15)
52   ;; Arg 0-5
53   (defreg nl0 16)
54   (defreg nl1 17)
55   (defreg nl2 18)
56   (defreg nl3 19)
57   (defreg nl4 20)
58   (defreg nl5 21)
59   ;; Caller saved 8-11
60   (defreg alloc 22)
61   (defreg fdefn 23)
62   (defreg cfunc 24)
63   (defreg nfp 25)
64   ;; Ra
65   (defreg lra 26)
66   ;; Caller saved 12
67   (defreg l1 27)
68   ;; Assembler temp (at)
69   (defreg l2 28)
70   ;; Global pointer (gp)
71   (defreg gp 29)
72   ;; Stack pointer
73   (defreg nsp 30)
74   ;; Wired zero
75   (defreg zero 31)
76   
77   (defregset non-descriptor-regs
78     nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
79   
80   (defregset descriptor-regs
81     fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
82   
83   (defregset *register-arg-offsets*
84     a0 a1 a2 a3 a4 a5)
85   (defparameter register-arg-names '(a0 a1 a2 a3 a4 a5)))
86
87 (define-storage-base registers :finite :size 32)
88 (define-storage-base float-registers :finite :size 64)
89 (define-storage-base control-stack :unbounded :size 8)
90 (define-storage-base non-descriptor-stack :unbounded :size 0)
91 (define-storage-base constant :non-packed)
92 (define-storage-base immediate-constant :non-packed)
93
94 ;;; a handy macro so we don't have to keep changing all the numbers
95 ;;; whenever we insert a new storage class.
96
97 (defmacro !define-storage-classes (&rest classes)
98   (do ((forms (list 'progn)
99               (let* ((class (car classes))
100                      (sc-name (car class))
101                      (constant-name (intern (concatenate 'simple-string
102                                                          (string sc-name)
103                                                          "-SC-NUMBER"))))
104                 (list* `(define-storage-class ,sc-name ,index
105                           ,@(cdr class))
106                        `(def!constant ,constant-name ,index)
107                        ;; (The CMU CL version of this macro did
108                        ;;   `(EXPORT ',CONSTANT-NAME)
109                        ;; here, but in SBCL we try to have package
110                        ;; structure described statically in one
111                        ;; master source file, instead of building it
112                        ;; dynamically by letting all the system code
113                        ;; modify it as the system boots.)
114                        forms)))
115        (index 0 (1+ index))
116        (classes classes (cdr classes)))
117       ((null classes)
118        (nreverse forms))))
119
120 (def!constant kludge-nondeterministic-catch-block-size 7)
121
122 (!define-storage-classes
123
124   ;; non-immediate constants in the constant pool
125   (constant constant)
126
127   ;; ZERO and NULL are in registers.
128   (zero immediate-constant)
129   (null immediate-constant)
130   (fp-single-zero immediate-constant)
131   (fp-double-zero immediate-constant)
132
133   ;; Anything else that can be an immediate.
134   (immediate immediate-constant)
135
136
137   ;; **** The stacks.
138
139   ;; The control stack.  (Scanned by GC)
140   (control-stack control-stack)
141
142   ;; The non-descriptor stacks.
143   (signed-stack non-descriptor-stack
144                 :element-size 2 :alignment 2) ; (signed-byte 64)
145   (unsigned-stack non-descriptor-stack
146                   :element-size 2 :alignment 2) ; (unsigned-byte 64)
147   (character-stack non-descriptor-stack) ; non-descriptor characters.
148   (sap-stack non-descriptor-stack
149              :element-size 2 :alignment 2) ; System area pointers.
150   (single-stack non-descriptor-stack) ; single-floats
151   (double-stack non-descriptor-stack
152                 :element-size 2 :alignment 2) ; double floats.
153   (complex-single-stack non-descriptor-stack :element-size 2)
154   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
155
156
157   ;; **** Things that can go in the integer registers.
158
159   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
160   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
161   (any-reg
162    registers
163    :locations #.(append non-descriptor-regs descriptor-regs)
164 ;   :locations #.non-descriptor-regs
165    :constant-scs (zero immediate)
166    :save-p t
167    :alternate-scs (control-stack))
168
169   ;; Pointer descriptor objects.  Must be seen by GC.
170   (descriptor-reg registers
171                   :locations #.descriptor-regs
172                   :constant-scs (constant null immediate)
173                   :save-p t
174                   :alternate-scs (control-stack))
175
176   ;; Non-Descriptor characters
177   (character-reg registers
178                  :locations #.non-descriptor-regs
179    :constant-scs (immediate)
180    :save-p t
181    :alternate-scs (character-stack))
182
183   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
184   (sap-reg registers
185    :locations #.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    :constant-scs (zero immediate)
194    :save-p t
195    :alternate-scs (signed-stack))
196   (unsigned-reg registers
197    :locations #.non-descriptor-regs
198    :constant-scs (zero immediate)
199    :save-p t
200    :alternate-scs (unsigned-stack))
201
202   ;; Random objects that must not be seen by GC.  Used only as temporaries.
203   (non-descriptor-reg registers
204    :locations #.non-descriptor-regs)
205
206   ;; Pointers to the interior of objects.  Used only as an temporary.
207   (interior-reg registers
208    :locations (#.lip-offset))
209
210
211   ;; **** Things that can go in the floating point registers.
212
213   ;; Non-Descriptor single-floats.
214   (single-reg float-registers
215    :locations #.(loop for i from 4 to 30 collect i)
216    :constant-scs (fp-single-zero)
217    :save-p t
218    :alternate-scs (single-stack))
219
220   ;; Non-Descriptor double-floats.
221   (double-reg float-registers
222    :locations #.(loop for i from 4 to 30 collect i)
223    :constant-scs (fp-double-zero)
224    :save-p t
225    :alternate-scs (double-stack))
226
227   (complex-single-reg float-registers
228    :locations #.(loop for i from 4 to 28 by 2 collect i)
229    :element-size 2
230    :constant-scs ()
231    :save-p t
232    :alternate-scs (complex-single-stack))
233
234   (complex-double-reg float-registers
235    :locations #.(loop for i from 4 to 28 by 2 collect i)
236    :element-size 2
237    :constant-scs ()
238    :save-p t
239    :alternate-scs (complex-double-stack))
240
241   ;; A catch or unwind block.
242   (catch-block control-stack
243                :element-size kludge-nondeterministic-catch-block-size))
244 \f
245 ;;; Make some random tns for important registers.
246 (macrolet ((defregtn (name sc)
247              (let ((offset-sym (symbolicate name "-OFFSET"))
248                    (tn-sym (symbolicate name "-TN")))
249                `(defparameter ,tn-sym
250                   (make-random-tn :kind :normal
251                        :sc (sc-or-lose ',sc)
252                        :offset ,offset-sym)))))
253
254   ;; These, we access by foo-TN only
255
256   (defregtn zero any-reg)
257   (defregtn null descriptor-reg)
258   (defregtn code descriptor-reg)
259   (defregtn alloc any-reg)
260   (defregtn bsp any-reg)
261   (defregtn csp any-reg)
262   (defregtn cfp any-reg)
263   (defregtn nsp any-reg)
264
265   ;; These alias regular locations, so we have to make sure we don't bypass
266   ;; the register allocator when using them.
267   (defregtn nargs any-reg)
268   (defregtn ocfp any-reg)
269   (defregtn lip interior-reg))
270
271 ;; and some floating point values..
272 (defparameter fp-single-zero-tn
273   (make-random-tn :kind :normal
274                   :sc (sc-or-lose 'single-reg)
275                   :offset 31))
276 (defparameter fp-double-zero-tn
277   (make-random-tn :kind :normal
278                   :sc (sc-or-lose 'double-reg)
279                   :offset 31))
280 \f
281 ;;; If value can be represented as an immediate constant, then return
282 ;;; the appropriate SC number, otherwise return NIL.
283 (!def-vm-support-routine immediate-constant-sc (value)
284   (typecase value
285     ((integer 0 0)
286      (sc-number-or-lose 'zero))
287     (null
288      (sc-number-or-lose 'null ))
289     ((or fixnum system-area-pointer character)
290      (sc-number-or-lose 'immediate ))
291     (symbol
292      (if (static-symbol-p value)
293          (sc-number-or-lose 'immediate )
294          nil))
295     (single-float
296      (if (eql value 0f0)
297          (sc-number-or-lose 'fp-single-zero )
298          nil))
299     (double-float
300      (if (eql value 0d0)
301          (sc-number-or-lose 'fp-double-zero )
302          nil))))
303 \f
304 ;;;; function call parameters
305
306 ;;; the SC numbers for register and stack arguments/return values
307 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
308 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
309 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
310
311 (eval-when  (:compile-toplevel :load-toplevel :execute)
312
313 ;;; offsets of special stack frame locations
314 (def!constant ocfp-save-offset 0)
315 (def!constant lra-save-offset 1)
316 (def!constant nfp-save-offset 2)
317
318 ;;; the number of arguments/return values passed in registers
319 (def!constant register-arg-count 6)
320
321 ;;; (Names to use for the argument registers would go here, but there
322 ;;; are none.)
323
324 ); EVAL-WHEN
325
326 ;;; a list of TN's describing the register arguments
327 (defparameter *register-arg-tns*
328   (mapcar (lambda (n)
329             (make-random-tn :kind :normal
330                             :sc (sc-or-lose 'descriptor-reg)
331                             :offset n))
332           *register-arg-offsets*))
333
334 ;;; This is used by the debugger.
335 (def!constant single-value-return-byte-offset 4)
336 \f
337 ;;; This function is called by debug output routines that want a
338 ;;; pretty name for a TN's location. It returns a thing that can be
339 ;;; printed with PRINC.
340 (!def-vm-support-routine location-print-name (tn)
341 ;  (declare (type tn tn))
342   (let ((sb (sb-name (sc-sb (tn-sc tn))))
343         (offset (tn-offset tn)))
344     (ecase sb
345       (registers (or (svref *register-names* offset)
346                      (format nil "R~D" offset)))
347       (float-registers (format nil "F~D" offset))
348       (control-stack (format nil "CS~D" offset))
349       (non-descriptor-stack (format nil "NS~D" offset))
350       (constant (format nil "Const~D" offset))
351       (immediate-constant "Immed"))))
352 \f
353 ;;; The loader uses this to convert alien names to the form they
354 ;;; occure in the symbol table (for example, prepending an
355 ;;; underscore). 
356 (defun extern-alien-name (name)
357   (declare (type string name))
358   ;; ELF ports currently don't need any prefix
359   (typecase name
360     (simple-base-string name)
361     (base-string (coerce name 'simple-base-string))
362     (t (handler-case (coerce name 'simple-base-string)
363          (type-error () (error "invalid external alien name: ~S" name))))))