Port to x86-64 versions of Windows
[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 6)
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   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
143   ;; is small and therefore the error trap information is smaller.
144   ;; Moving them up here from their previous place down below saves
145   ;; ~250K in core file size.  --njf, 2006-01-27
146
147   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
148   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
149   (any-reg
150    registers
151    :locations #.(append non-descriptor-regs descriptor-regs)
152    :constant-scs (zero immediate)
153    :save-p t
154    :alternate-scs (control-stack))
155
156   ;; Pointer descriptor objects.  Must be seen by GC.
157   (descriptor-reg registers
158    :locations #.descriptor-regs
159    :constant-scs (constant null immediate)
160    :save-p t
161    :alternate-scs (control-stack))
162
163   ;; The non-descriptor stacks.
164   (signed-stack non-descriptor-stack
165                 :element-size 2 :alignment 2) ; (signed-byte 64)
166   (unsigned-stack non-descriptor-stack
167                   :element-size 2 :alignment 2) ; (unsigned-byte 64)
168   (character-stack non-descriptor-stack) ; non-descriptor characters.
169   (sap-stack non-descriptor-stack
170              :element-size 2 :alignment 2) ; System area pointers.
171   (single-stack non-descriptor-stack) ; single-floats
172   (double-stack non-descriptor-stack
173                 :element-size 2 :alignment 2) ; double floats.
174   (complex-single-stack non-descriptor-stack :element-size 2)
175   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
176
177
178   ;; **** Things that can go in the integer registers.
179
180   ;; Non-Descriptor characters
181   (character-reg registers
182                  :locations #.non-descriptor-regs
183    :constant-scs (immediate)
184    :save-p t
185    :alternate-scs (character-stack))
186
187   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
188   (sap-reg registers
189    :locations #.non-descriptor-regs
190    :constant-scs (immediate)
191    :save-p t
192    :alternate-scs (sap-stack))
193
194   ;; Non-Descriptor (signed or unsigned) numbers.
195   (signed-reg registers
196    :locations #.non-descriptor-regs
197    :constant-scs (zero immediate)
198    :save-p t
199    :alternate-scs (signed-stack))
200   (unsigned-reg registers
201    :locations #.non-descriptor-regs
202    :constant-scs (zero immediate)
203    :save-p t
204    :alternate-scs (unsigned-stack))
205
206   ;; Random objects that must not be seen by GC.  Used only as temporaries.
207   (non-descriptor-reg registers
208    :locations #.non-descriptor-regs)
209
210   ;; Pointers to the interior of objects.  Used only as an temporary.
211   (interior-reg registers
212    :locations (#.lip-offset))
213
214
215   ;; **** Things that can go in the floating point registers.
216
217   ;; Non-Descriptor single-floats.
218   (single-reg float-registers
219    :locations #.(loop for i from 4 to 30 collect i)
220    :constant-scs (fp-single-zero)
221    :save-p t
222    :alternate-scs (single-stack))
223
224   ;; Non-Descriptor double-floats.
225   (double-reg float-registers
226    :locations #.(loop for i from 4 to 30 collect i)
227    :constant-scs (fp-double-zero)
228    :save-p t
229    :alternate-scs (double-stack))
230
231   (complex-single-reg float-registers
232    :locations #.(loop for i from 4 to 28 by 2 collect i)
233    :element-size 2
234    :constant-scs ()
235    :save-p t
236    :alternate-scs (complex-single-stack))
237
238   (complex-double-reg float-registers
239    :locations #.(loop for i from 4 to 28 by 2 collect i)
240    :element-size 2
241    :constant-scs ()
242    :save-p t
243    :alternate-scs (complex-double-stack))
244
245   ;; A catch or unwind block.
246   (catch-block control-stack
247                :element-size kludge-nondeterministic-catch-block-size))
248 \f
249 ;;; Make some random tns for important registers.
250 (macrolet ((defregtn (name sc)
251              (let ((offset-sym (symbolicate name "-OFFSET"))
252                    (tn-sym (symbolicate name "-TN")))
253                `(defparameter ,tn-sym
254                   (make-random-tn :kind :normal
255                        :sc (sc-or-lose ',sc)
256                        :offset ,offset-sym)))))
257
258   ;; These, we access by foo-TN only
259
260   (defregtn zero any-reg)
261   (defregtn null descriptor-reg)
262   (defregtn code descriptor-reg)
263   (defregtn alloc any-reg)
264   (defregtn bsp any-reg)
265   (defregtn csp any-reg)
266   (defregtn cfp any-reg)
267   (defregtn nsp any-reg)
268
269   ;; These alias regular locations, so we have to make sure we don't bypass
270   ;; the register allocator when using them.
271   (defregtn nargs any-reg)
272   (defregtn ocfp any-reg)
273   (defregtn lip interior-reg))
274
275 ;; and some floating point values..
276 (defparameter fp-single-zero-tn
277   (make-random-tn :kind :normal
278                   :sc (sc-or-lose 'single-reg)
279                   :offset 31))
280 (defparameter fp-double-zero-tn
281   (make-random-tn :kind :normal
282                   :sc (sc-or-lose 'double-reg)
283                   :offset 31))
284 \f
285 ;;; If value can be represented as an immediate constant, then return
286 ;;; the appropriate SC number, otherwise return NIL.
287 (!def-vm-support-routine immediate-constant-sc (value)
288   (typecase value
289     ((integer 0 0)
290      (sc-number-or-lose 'zero))
291     (null
292      (sc-number-or-lose 'null ))
293     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
294          character)
295      (sc-number-or-lose 'immediate ))
296     (symbol
297      (if (static-symbol-p value)
298          (sc-number-or-lose 'immediate )
299          nil))
300     (single-float
301      (if (eql value 0f0)
302          (sc-number-or-lose 'fp-single-zero )
303          nil))
304     (double-float
305      (if (eql value 0d0)
306          (sc-number-or-lose 'fp-double-zero )
307          nil))))
308
309 (!def-vm-support-routine boxed-immediate-sc-p (sc)
310   (or (eql sc (sc-number-or-lose 'zero))
311       (eql sc (sc-number-or-lose 'null))
312       (eql sc (sc-number-or-lose 'immediate))))
313 \f
314 ;;;; function call parameters
315
316 ;;; the SC numbers for register and stack arguments/return values
317 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
318 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
319 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
320
321 (eval-when  (:compile-toplevel :load-toplevel :execute)
322
323 ;;; offsets of special stack frame locations
324 (def!constant ocfp-save-offset 0)
325 (def!constant lra-save-offset 1)
326 (def!constant nfp-save-offset 2)
327
328 ;;; the number of arguments/return values passed in registers
329 (def!constant register-arg-count 6)
330
331 ;;; (Names to use for the argument registers would go here, but there
332 ;;; are none.)
333
334 ); EVAL-WHEN
335
336 ;;; a list of TN's describing the register arguments
337 (defparameter *register-arg-tns*
338   (mapcar (lambda (n)
339             (make-random-tn :kind :normal
340                             :sc (sc-or-lose 'descriptor-reg)
341                             :offset n))
342           *register-arg-offsets*))
343
344 ;;; This is used by the debugger.
345 (def!constant single-value-return-byte-offset 4)
346 \f
347 ;;; This function is called by debug output routines that want a
348 ;;; pretty name for a TN's location. It returns a thing that can be
349 ;;; printed with PRINC.
350 (!def-vm-support-routine location-print-name (tn)
351 ;  (declare (type tn tn))
352   (let ((sb (sb-name (sc-sb (tn-sc tn))))
353         (offset (tn-offset tn)))
354     (ecase sb
355       (registers (or (svref *register-names* offset)
356                      (format nil "R~D" offset)))
357       (float-registers (format nil "F~D" offset))
358       (control-stack (format nil "CS~D" offset))
359       (non-descriptor-stack (format nil "NS~D" offset))
360       (constant (format nil "Const~D" offset))
361       (immediate-constant "Immed"))))
362
363 (!def-vm-support-routine combination-implementation-style (node)
364   (declare (type sb!c::combination node) (ignore node))
365   (values :default nil))
366
367 (defun primitive-type-indirect-cell-type (ptype)
368   (declare (ignore ptype))
369   nil)