1 ;;;; miscellaneous VM definition noise for the PPC
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;; NUMBER-STACK-DISPLACEMENT
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.
20 (def!constant number-stack-displacement
25 ;;;; Define the registers
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (defvar *register-names* (make-array 32 :initial-element nil)))
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)))))
36 (defregset (name &rest regs)
37 `(eval-when (:compile-toplevel :load-toplevel :execute)
39 (list ,@(mapcar #'(lambda (name)
40 (symbolicate name "-OFFSET")) regs))))))
44 (defreg rtoc 2) ; May be "NULL" someday.
52 (defreg fdefn 10) ; was nl7
54 ;; FIXME: some kind of comment here would be nice.
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)
77 (defreg #!-sb-thread l2 #!+sb-thread thread 30)
80 (defregset non-descriptor-regs
81 nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp)
83 (defregset descriptor-regs
84 fdefn a0 a1 a2 a3 ocfp lra cname lexenv l0 l1 #!-sb-thread l2 )
87 (defregset *register-arg-offsets* a0 a1 a2 a3)
88 (defparameter register-arg-names '(a0 a1 a2 a3)))
92 ;;;; SB and SC definition:
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)
102 ;;; Handy macro so we don't have to keep changing all the numbers whenever
103 ;;; we insert a new storage class.
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
112 (list* `(define-storage-class ,sc-name ,index
114 `(def!constant ,constant-name ,index)
117 (classes classes (cdr classes)))
121 (def!constant kludge-nondeterministic-catch-block-size 6)
123 (define-storage-classes
125 ;; Non-immediate contstants in the constant pool
128 ;; ZERO and NULL are in registers.
129 (zero immediate-constant)
130 (null immediate-constant)
132 ;; Anything else that can be an immediate.
133 (immediate immediate-constant)
138 ;; The control stack. (Scanned by GC)
139 (control-stack control-stack)
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
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).
150 :locations #.(append non-descriptor-regs descriptor-regs)
151 :constant-scs (zero immediate)
153 :alternate-scs (control-stack))
155 ;; Pointer descriptor objects. Must be seen by GC.
156 (descriptor-reg registers
157 :locations #.descriptor-regs
158 :constant-scs (constant null immediate)
160 :alternate-scs (control-stack))
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)
174 ;; **** Things that can go in the integer registers.
176 ;; Non-Descriptor characters
177 (character-reg registers
178 :locations #.non-descriptor-regs
179 :constant-scs (immediate)
181 :alternate-scs (character-stack))
183 ;; Non-Descriptor SAP's (arbitrary pointers into address space)
185 :locations #.non-descriptor-regs
186 :constant-scs (immediate)
188 :alternate-scs (sap-stack))
190 ;; Non-Descriptor (signed or unsigned) numbers.
191 (signed-reg registers
192 :locations #.non-descriptor-regs
193 :constant-scs (zero immediate)
195 :alternate-scs (signed-stack))
196 (unsigned-reg registers
197 :locations #.non-descriptor-regs
198 :constant-scs (zero immediate)
200 :alternate-scs (unsigned-stack))
202 ;; Random objects that must not be seen by GC. Used only as temporaries.
203 (non-descriptor-reg registers
204 :locations #.non-descriptor-regs)
206 ;; Pointers to the interior of objects. Used only as a temporary.
207 (interior-reg registers
208 :locations (#.lip-offset))
211 ;; **** Things that can go in the floating point registers.
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.
220 :alternate-scs (single-stack))
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
229 :alternate-scs (double-stack))
231 (complex-single-reg float-registers
232 :locations #.(loop for i from 0 to 30 by 2 collect i)
236 :alternate-scs (complex-single-stack))
238 (complex-double-reg float-registers
239 :locations #.(loop for i from 0 to 30 by 2 collect i)
243 :alternate-scs (complex-double-stack))
245 ;; A catch or unwind block.
246 (catch-block control-stack
247 :element-size kludge-nondeterministic-catch-block-size))
249 ;;;; Make some random tns for important registers.
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)))))
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 (defregtn lra descriptor-reg)
265 (defregtn lexenv descriptor-reg)
267 (defregtn nargs any-reg)
268 (defregtn bsp any-reg)
269 (defregtn csp any-reg)
270 (defregtn cfp any-reg)
271 (defregtn ocfp any-reg)
272 (defregtn nsp any-reg))
274 ;;; If VALUE can be represented as an immediate constant, then return the
275 ;;; appropriate SC number, otherwise return NIL.
276 (!def-vm-support-routine immediate-constant-sc (value)
279 (sc-number-or-lose 'zero))
281 (sc-number-or-lose 'null))
282 ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
284 (sc-number-or-lose 'immediate))
286 (if (static-symbol-p value)
287 (sc-number-or-lose 'immediate)
290 ;;; A predicate to see if a character can be used as an inline
291 ;;; constant (the immediate field in the instruction used is sixteen
292 ;;; bits wide, which is not the same as any defined subtype of
294 (defun inlinable-character-constant-p (char)
295 (and (characterp char)
296 (< (char-code char) #x10000)))
298 ;;;; function call parameters
300 ;;; the SC numbers for register and stack arguments/return values
301 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
302 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
303 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
305 (eval-when (:compile-toplevel :load-toplevel :execute)
307 ;;; offsets of special stack frame locations
308 (def!constant ocfp-save-offset 0)
309 (def!constant lra-save-offset 1)
310 (def!constant nfp-save-offset 2)
312 ;;; the number of arguments/return values passed in registers
313 (def!constant register-arg-count 4)
315 ;;; names to use for the argument registers
321 ;;; A list of TN's describing the register arguments.
323 (defparameter *register-arg-tns*
324 (mapcar #'(lambda (n)
325 (make-random-tn :kind :normal
326 :sc (sc-or-lose 'descriptor-reg)
328 *register-arg-offsets*))
331 (defparameter thread-base-tn
332 (make-random-tn :kind :normal :sc (sc-or-lose 'unsigned-reg)
333 :offset thread-offset))
335 (export 'single-value-return-byte-offset)
337 ;;; This is used by the debugger.
338 (def!constant single-value-return-byte-offset 8)
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)))
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"))))
355 (!def-vm-support-routine combination-implementation-style (node)
356 (declare (type sb!c::combination node))
357 (flet ((valid-funtype (args result)
358 (sb!c::valid-fun-use node
359 (sb!c::specifier-type
360 `(function ,args ,result)))))
361 (case (sb!c::combination-fun-source-name node)
364 ((or (valid-funtype '(fixnum fixnum) '*)
365 (valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
366 (valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*))
367 (values :direct nil))
368 (t (values :default nil))))
371 ((or (valid-funtype '((constant-arg (integer 0 29)) fixnum) '*)
372 (valid-funtype '((constant-arg (integer 0 31)) (signed-byte 32)) '*)
373 (valid-funtype '((constant-arg (integer 0 31)) (unsigned-byte 32)) '*))
374 (values :transform '(lambda (index integer)
375 (%logbitp integer index))))
376 (t (values :default nil))))
377 ;; FIXME: can handle MIN and MAX here
380 ((or (valid-funtype '((constant-arg (integer 1 29))
381 (constant-arg (integer 0 29))
384 (valid-funtype '((constant-arg (integer 1 29))
385 (constant-arg (integer 0 29))
388 (valid-funtype '((constant-arg (integer 1 29))
389 (constant-arg (integer 0 29))
393 '(lambda (size posn integer)
394 (%%ldb integer size posn))))
395 (t (values :default nil))))
396 (t (values :default nil)))))
398 (defun primitive-type-indirect-cell-type (ptype)
399 (declare (ignore ptype))