1.0.32.34: remove curious-hacker-cruft from constraints.lisp
[sbcl.git] / src / compiler / ppc / vm.lisp
1 ;;;; miscellaneous VM definition noise for the PPC
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 ;;; NUMBER-STACK-DISPLACEMENT
15 ;;;
16 ;;; The number of bytes reserved above the number stack pointer.  These
17 ;;; slots are required by architecture, mostly (?) to make C backtrace
18 ;;; work. This must be a power of 2 - see BYTES-REQUIRED-FOR-NUMBER-STACK.
19 ;;;
20 (def!constant number-stack-displacement
21   (* #!-darwin 2
22      #!+darwin 8
23      n-word-bytes))
24 \f
25 ;;;; Define the registers
26
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28   (defvar *register-names* (make-array 32 :initial-element nil)))
29
30 (macrolet ((defreg (name offset)
31                (let ((offset-sym (symbolicate name "-OFFSET")))
32                  `(eval-when (:compile-toplevel :load-toplevel :execute)
33                    (def!constant ,offset-sym ,offset)
34                    (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
35
36            (defregset (name &rest regs)
37                `(eval-when (:compile-toplevel :load-toplevel :execute)
38                  (defparameter ,name
39                    (list ,@(mapcar #'(lambda (name)
40                                        (symbolicate name "-OFFSET")) regs))))))
41
42   (defreg zero 0)
43   (defreg nsp 1)
44   (defreg rtoc 2)                         ; May be "NULL" someday.
45   (defreg nl0 3)
46   (defreg nl1 4)
47   (defreg nl2 5)
48   (defreg nl3 6)
49   (defreg nl4 7)
50   (defreg nl5 8)
51   (defreg nl6 9)
52   (defreg fdefn 10)                     ; was nl7
53   (defreg nargs 11)
54   ;; FIXME: some kind of comment here would be nice.
55   ;;
56   ;; FIXME II: this also reveals the need to autogenerate lispregs.h
57   #!+darwin  (defreg cfunc 12)
58   #!-darwin  (defreg nfp 12)
59   #!+darwin  (defreg nfp 13)
60   #!-darwin  (defreg cfunc 13)
61   (defreg bsp 14)
62   (defreg cfp 15)
63   (defreg csp 16)
64   (defreg alloc 17)
65   (defreg null 18)
66   (defreg code 19)
67   (defreg cname 20)
68   (defreg lexenv 21)
69   (defreg ocfp 22)
70   (defreg lra 23)
71   (defreg a0 24)
72   (defreg a1 25)
73   (defreg a2 26)
74   (defreg a3 27)
75   (defreg l0 28)
76   (defreg l1 29)
77   (defreg l2 30)
78   (defreg lip 31)
79
80   (defregset non-descriptor-regs
81       nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp)
82
83   (defregset descriptor-regs
84       fdefn a0 a1 a2 a3  ocfp lra cname lexenv l0 l1 l2 )
85
86
87  (defregset *register-arg-offsets*  a0 a1 a2 a3)
88  (defparameter register-arg-names '(a0 a1 a2 a3)))
89
90
91 \f
92 ;;;; SB and SC definition:
93
94 (define-storage-base registers :finite :size 32)
95 (define-storage-base float-registers :finite :size 32)
96 (define-storage-base control-stack :unbounded :size 8)
97 (define-storage-base non-descriptor-stack :unbounded :size 0)
98 (define-storage-base constant :non-packed)
99 (define-storage-base immediate-constant :non-packed)
100
101 ;;;
102 ;;; Handy macro so we don't have to keep changing all the numbers whenever
103 ;;; we insert a new storage class.
104 ;;;
105 (defmacro define-storage-classes (&rest classes)
106   (do ((forms (list 'progn)
107               (let* ((class (car classes))
108                      (sc-name (car class))
109                      (constant-name (intern (concatenate 'simple-string
110                                                          (string sc-name)
111                                                          "-SC-NUMBER"))))
112                 (list* `(define-storage-class ,sc-name ,index
113                           ,@(cdr class))
114                        `(def!constant ,constant-name ,index)
115                        forms)))
116        (index 0 (1+ index))
117        (classes classes (cdr classes)))
118       ((null classes)
119        (nreverse forms))))
120
121 (def!constant kludge-nondeterministic-catch-block-size 6)
122
123 (define-storage-classes
124
125   ;; Non-immediate contstants in the constant pool
126   (constant constant)
127
128   ;; ZERO and NULL are in registers.
129   (zero immediate-constant)
130   (null immediate-constant)
131
132   ;; Anything else that can be an immediate.
133   (immediate immediate-constant)
134
135
136   ;; **** The stacks.
137
138   ;; The control stack.  (Scanned by GC)
139   (control-stack control-stack)
140
141   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
142   ;; is small and therefore the error trap information is smaller.
143   ;; Moving them up here from their previous place down below saves
144   ;; ~250K in core file size.  --njf, 2006-01-27
145
146   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
147   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
148   (any-reg
149    registers
150    :locations #.(append non-descriptor-regs descriptor-regs)
151    :constant-scs (zero immediate)
152    :save-p t
153    :alternate-scs (control-stack))
154
155   ;; Pointer descriptor objects.  Must be seen by GC.
156   (descriptor-reg registers
157    :locations #.descriptor-regs
158    :constant-scs (constant null immediate)
159    :save-p t
160    :alternate-scs (control-stack))
161
162   ;; The non-descriptor stacks.
163   (signed-stack non-descriptor-stack) ; (signed-byte 32)
164   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
165   (character-stack non-descriptor-stack) ; non-descriptor characters.
166   (sap-stack non-descriptor-stack) ; System area pointers.
167   (single-stack non-descriptor-stack) ; single-floats
168   (double-stack non-descriptor-stack
169                 :element-size 2 :alignment 2) ; double floats.
170   (complex-single-stack non-descriptor-stack :element-size 2)
171   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
172
173
174   ;; **** Things that can go in the integer registers.
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 a 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 0 to 31 collect i)
216    ;; ### Note: We really should have every location listed, but then we
217    ;; would have to make load-tns work with element-sizes other than 1.
218    :constant-scs ()
219    :save-p t
220    :alternate-scs (single-stack))
221
222   ;; Non-Descriptor double-floats.
223   (double-reg float-registers
224    :locations #.(loop for i from 0 to 31 collect i)
225    ;; ### Note: load-tns don't work with an element-size other than 1.
226    ;; :element-size 2 :alignment 2
227    :constant-scs ()
228    :save-p t
229    :alternate-scs (double-stack))
230
231   (complex-single-reg float-registers
232    :locations #.(loop for i from 0 to 30 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 0 to 30 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
251 (macrolet ((defregtn (name sc)
252                (let ((offset-sym (symbolicate name "-OFFSET"))
253                      (tn-sym (symbolicate name "-TN")))
254                  `(defparameter ,tn-sym
255                    (make-random-tn :kind :normal
256                     :sc (sc-or-lose ',sc)
257                     :offset ,offset-sym)))))
258
259   (defregtn zero any-reg)
260   (defregtn lip interior-reg)
261   (defregtn null descriptor-reg)
262   (defregtn code descriptor-reg)
263   (defregtn alloc any-reg)
264
265   (defregtn nargs any-reg)
266   (defregtn bsp any-reg)
267   (defregtn csp any-reg)
268   (defregtn cfp any-reg)
269   (defregtn ocfp any-reg)
270   (defregtn nsp any-reg))
271 \f
272 ;;; If VALUE can be represented as an immediate constant, then return the
273 ;;; appropriate SC number, otherwise return NIL.
274 (!def-vm-support-routine immediate-constant-sc (value)
275   (typecase value
276     ((integer 0 0)
277      (sc-number-or-lose 'zero))
278     (null
279      (sc-number-or-lose 'null))
280     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
281          character)
282      (sc-number-or-lose 'immediate))
283     (symbol
284      (if (static-symbol-p value)
285          (sc-number-or-lose 'immediate)
286          nil))))
287 \f
288 ;;;; function call parameters
289
290 ;;; the SC numbers for register and stack arguments/return values
291 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
292 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
293 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
294
295 (eval-when (:compile-toplevel :load-toplevel :execute)
296
297 ;;; offsets of special stack frame locations
298 (def!constant ocfp-save-offset 0)
299 (def!constant lra-save-offset 1)
300 (def!constant nfp-save-offset 2)
301
302 ;;; the number of arguments/return values passed in registers
303 (def!constant register-arg-count 4)
304
305 ;;; names to use for the argument registers
306
307
308 ) ; EVAL-WHEN
309
310
311 ;;; A list of TN's describing the register arguments.
312 ;;;
313 (defparameter *register-arg-tns*
314   (mapcar #'(lambda (n)
315               (make-random-tn :kind :normal
316                               :sc (sc-or-lose 'descriptor-reg)
317                               :offset n))
318           *register-arg-offsets*))
319
320 (export 'single-value-return-byte-offset)
321
322 ;;; This is used by the debugger.
323 (def!constant single-value-return-byte-offset 8)
324 \f
325 ;;; This function is called by debug output routines that want a pretty name
326 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
327 (!def-vm-support-routine location-print-name (tn)
328   (declare (type tn tn))
329   (let ((sb (sb-name (sc-sb (tn-sc tn))))
330         (offset (tn-offset tn)))
331     (ecase sb
332       (registers (or (svref *register-names* offset)
333                      (format nil "R~D" offset)))
334       (float-registers (format nil "F~D" offset))
335       (control-stack (format nil "CS~D" offset))
336       (non-descriptor-stack (format nil "NS~D" offset))
337       (constant (format nil "Const~D" offset))
338       (immediate-constant "Immed"))))
339
340 (!def-vm-support-routine combination-implementation-style (node)
341   (declare (type sb!c::combination node))
342   (flet ((valid-funtype (args result)
343            (sb!c::valid-fun-use node
344                                 (sb!c::specifier-type
345                                  `(function ,args ,result)))))
346     (case (sb!c::combination-fun-source-name node)
347       (logtest
348        (cond
349          ((or (valid-funtype '(fixnum fixnum) '*)
350               (valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
351               (valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*))
352           (values :direct nil))
353          (t (values :default nil))))
354       (logbitp
355        (cond
356          ((or (valid-funtype '((constant-arg (integer 0 29)) fixnum) '*)
357               (valid-funtype '((constant-arg (integer 0 31)) (signed-byte 32)) '*)
358               (valid-funtype '((constant-arg (integer 0 31)) (unsigned-byte 32)) '*))
359           (values :transform '(lambda (index integer)
360                                (%logbitp integer index))))
361          (t (values :default nil))))
362       ;; FIXME: can handle MIN and MAX here
363       (sb!kernel:%ldb
364        (cond
365          ((or (valid-funtype '((constant-arg (integer 1 29))
366                                (constant-arg (integer 0 29))
367                                fixnum)
368                              'fixnum)
369               (valid-funtype '((constant-arg (integer 1 29))
370                                (constant-arg (integer 0 29))
371                                (signed-byte 32))
372                              'fixnum)
373               (valid-funtype '((constant-arg (integer 1 29))
374                                (constant-arg (integer 0 29))
375                                (unsigned-byte 32))
376                              'fixnum))
377           (values :transform
378                   '(lambda (size posn integer)
379                     (%%ldb integer size posn))))
380          (t (values :default nil))))
381       (t (values :default nil)))))