1 ;;;; miscellaneous VM definition noise for HPPA
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.
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18 (defvar *register-names* (make-array 32 :initial-element nil)))
20 (macrolet ((defreg (name offset)
21 (let ((offset-sym (symbolicate name "-OFFSET")))
22 `(eval-when (:compile-toplevel :load-toplevel :execute)
23 (def!constant ,offset-sym ,offset)
24 (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
25 (defregset (name &rest regs)
26 `(eval-when (:compile-toplevel :load-toplevel :execute)
28 (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))))
31 ;; This gets trashed by the C call convention.
32 (defreg nfp 1) ;; and saved by lisp before calling C
34 ;; These are the callee saves, so these registers are stay live over
52 ;; This is where the caller-saves registers start, but we don't
53 ;; really care because we need to clear the above after call-out to
54 ;; make sure no pointers into oldspace are kept around.
59 ;; These are the 4 C argument registers.
64 ;; The global Data Pointer. We just leave it alone, because we
67 ;; These two are use for C return values.
73 (defregset non-descriptor-regs
74 nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp)
76 (defregset descriptor-regs
77 a0 a1 a2 a3 a4 a5 fdefn lexenv ocfp lra l0 l1 l2)
79 (defregset *register-arg-offsets*
82 (defregset reserve-descriptor-regs
85 (defregset reserve-non-descriptor-regs
88 (define-storage-base registers :finite :size 32)
89 (define-storage-base float-registers :finite :size 64)
90 (define-storage-base control-stack :unbounded :size 8)
91 (define-storage-base non-descriptor-stack :unbounded :size 0)
92 (define-storage-base constant :non-packed)
93 (define-storage-base immediate-constant :non-packed)
96 ;;; Handy macro so we don't have to keep changing all the numbers whenever
97 ;;; we insert a new storage class.
98 ;;; FIXME-lav: move this into arch-generic-helpers.lisp and rip out from arches
99 (defmacro !define-storage-classes (&rest classes)
100 (do ((forms (list 'progn)
101 (let* ((class (car classes))
102 (sc-name (car class))
103 (constant-name (intern (concatenate 'simple-string
106 (list* `(define-storage-class ,sc-name ,index
108 `(def!constant ,constant-name ,index)
111 (classes classes (cdr classes)))
115 (def!constant kludge-nondeterministic-catch-block-size 6)
117 (!define-storage-classes
119 ;; Non-immediate constants in the constant pool
122 ;; ZERO and NULL are in registers.
123 (zero immediate-constant)
124 (null immediate-constant)
125 (fp-single-zero immediate-constant)
126 (fp-double-zero immediate-constant)
128 ;; Anything else that can be an immediate.
129 (immediate immediate-constant)
134 ;; The control stack. (Scanned by GC)
135 (control-stack control-stack)
137 ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
138 ;; is small and therefore the error trap information is smaller.
139 ;; Moving them up here from their previous place down below saves
140 ;; ~250K in core file size. --njf, 2006-01-27
142 ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing
143 ;; bad will happen if they are. (fixnums, characters, header values, etc).
146 :locations #.(append non-descriptor-regs descriptor-regs)
147 :reserve-locations #.(append reserve-non-descriptor-regs
148 reserve-descriptor-regs)
149 :constant-scs (constant zero immediate)
151 :alternate-scs (control-stack))
153 ;; Pointer descriptor objects. Must be seen by GC.
154 (descriptor-reg registers
155 :locations #.descriptor-regs
156 :reserve-locations #.reserve-descriptor-regs
157 :constant-scs (constant null immediate)
159 :alternate-scs (control-stack))
161 ;; The non-descriptor stacks.
162 (signed-stack non-descriptor-stack) ; (signed-byte 32)
163 (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
164 (character-stack non-descriptor-stack) ; non-descriptor characters.
165 (sap-stack non-descriptor-stack) ; System area pointers.
166 (single-stack non-descriptor-stack) ; single-floats
167 (double-stack non-descriptor-stack
168 :element-size 2 :alignment 2) ; double floats.
169 (complex-single-stack non-descriptor-stack :element-size 2)
170 (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
172 ;; **** Things that can go in the integer registers.
174 ;; Non-Descriptor characters
175 (character-reg registers
176 :locations #.non-descriptor-regs
177 :reserve-locations #.reserve-non-descriptor-regs
178 :constant-scs (immediate)
180 :alternate-scs (character-stack))
182 ;; Non-Descriptor SAP's (arbitrary pointers into address space)
184 :locations #.non-descriptor-regs
185 :reserve-locations #.reserve-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 :reserve-locations #.reserve-non-descriptor-regs
194 :constant-scs (zero immediate)
196 :alternate-scs (signed-stack))
197 (unsigned-reg registers
198 :locations #.non-descriptor-regs
199 :reserve-locations #.reserve-non-descriptor-regs
200 :constant-scs (zero immediate)
202 :alternate-scs (unsigned-stack))
204 ;; Random objects that must not be seen by GC. Used only as temporaries.
205 (non-descriptor-reg registers
206 :locations #.non-descriptor-regs)
208 ;; Pointers to the interior of objects. Used only as an temporary.
209 (interior-reg registers
210 :locations (#.lip-offset))
213 ;; **** Things that can go in the floating point registers.
215 ;; Non-Descriptor single-floats.
216 (single-reg float-registers
217 :locations #.(loop for i from 4 to 31 collect i)
218 :constant-scs (fp-single-zero)
220 :alternate-scs (single-stack))
222 ;; Non-Descriptor double-floats.
223 (double-reg float-registers
224 :locations #.(loop for i from 4 to 31 collect i)
225 :constant-scs (fp-double-zero)
227 :alternate-scs (double-stack))
229 (complex-single-reg float-registers
230 :locations #.(loop for i from 4 to 30 by 2 collect i)
234 :alternate-scs (complex-single-stack))
236 (complex-double-reg float-registers
237 :locations #.(loop for i from 4 to 30 by 2 collect i)
241 :alternate-scs (complex-double-stack))
243 ;; A catch or unwind block.
244 (catch-block control-stack :element-size kludge-nondeterministic-catch-block-size)
247 ;; floating point numbers temporarily stuck in integer registers for c-call
248 (single-int-carg-reg registers
249 :locations (26 25 24 23)
252 (double-int-carg-reg registers
256 ; :alignment 2 ;is this needed?
261 ;;;; Make some random tns for important registers.
263 ;;; how can we address reg L0 through L0-offset when it is not
264 ;;; defined here ? do all registers have an -offset and this is
267 ;;; FIXME-lav: move this into arch-generic-helpers
268 (macrolet ((defregtn (name sc)
269 (let ((offset-sym (symbolicate name "-OFFSET"))
270 (tn-sym (symbolicate name "-TN")))
271 `(defparameter ,tn-sym
272 (make-random-tn :kind :normal
273 :sc (sc-or-lose ',sc)
274 :offset ,offset-sym)))))
276 ;; These, we access by foo-TN only
278 (defregtn zero any-reg)
279 (defregtn nargs any-reg)
280 ;; FIXME-lav: 20080820: not a fix, but fdefn and lexenv is used in assembly-rtns
281 (defregtn fdefn descriptor-reg) ; FIXME-lav, not used
282 (defregtn lexenv descriptor-reg) ; FIXME-lav, not used
284 (defregtn nfp descriptor-reg) ; why not descriptor-reg ?
285 (defregtn ocfp any-reg) ; why not descriptor-reg ?
287 (defregtn null descriptor-reg)
289 (defregtn bsp any-reg)
290 (defregtn cfp any-reg)
291 (defregtn csp any-reg)
292 (defregtn alloc any-reg)
293 (defregtn nsp any-reg)
295 (defregtn code descriptor-reg)
296 (defregtn lip interior-reg))
298 ;; And some floating point values.
299 (defparameter fp-single-zero-tn
300 (make-random-tn :kind :normal
301 :sc (sc-or-lose 'single-reg)
303 (defparameter fp-double-zero-tn
304 (make-random-tn :kind :normal
305 :sc (sc-or-lose 'double-reg)
309 ;;; If VALUE can be represented as an immediate constant, then return
310 ;;; the appropriate SC number, otherwise return NIL.
311 (!def-vm-support-routine immediate-constant-sc (value)
314 (sc-number-or-lose 'zero))
316 (sc-number-or-lose 'null))
317 ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
318 system-area-pointer character)
319 (sc-number-or-lose 'immediate))
321 (if (static-symbol-p value)
322 (sc-number-or-lose 'immediate)
326 (sc-number-or-lose 'fp-single-zero)
330 (sc-number-or-lose 'fp-double-zero)
334 ;;;; Function Call Parameters
336 ;;; The SC numbers for register and stack arguments/return values.
338 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
339 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
340 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
342 (eval-when (:compile-toplevel :load-toplevel :execute)
344 ;;; Offsets of special stack frame locations
345 (def!constant ocfp-save-offset 0)
346 (def!constant lra-save-offset 1)
347 (def!constant nfp-save-offset 2)
349 ;;; The number of arguments/return values passed in registers.
351 (def!constant register-arg-count 6)
353 ;;; Names to use for the argument registers.
355 (defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
360 ;;; A list of TN's describing the register arguments.
362 (defparameter *register-arg-tns*
364 (make-random-tn :kind :normal
365 :sc (sc-or-lose 'descriptor-reg)
367 *register-arg-offsets*))
369 ;;; This is used by the debugger.
370 (def!constant single-value-return-byte-offset 4)
372 ;;; This function is called by debug output routines that want a pretty name
373 ;;; for a TN's location. It returns a thing that can be printed with PRINC.
374 (!def-vm-support-routine location-print-name (tn)
375 (declare (type tn tn))
376 (let ((sb (sb-name (sc-sb (tn-sc tn))))
377 (offset (tn-offset tn)))
379 (registers (or (svref *register-names* offset)
380 (format nil "R~D" offset)))
381 (float-registers (format nil "F~D" offset))
382 (control-stack (format nil "CS~D" offset))
383 (non-descriptor-stack (format nil "NS~D" offset))
384 (constant (format nil "Const~D" offset))
385 (immediate-constant "Immed"))))
387 (!def-vm-support-routine combination-implementation-style (node)
388 (declare (type sb!c::combination node) (ignore node))
389 (values :default nil))
391 (defun primitive-type-indirect-cell-type (ptype)
392 (declare (ignore ptype))