1 ;;;; miscellaneous VM definition noise for the ARM
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
)))))
26 (defregset (name &rest regs
)
27 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
29 (list ,@(mapcar #'(lambda (name)
30 (symbolicate name
"-OFFSET")) regs
))))))
73 (defregset system-regs
76 (defregset descriptor-regs
77 r0 r1 r2 r3 r4 r5 r6 r7 r8 r9
#!-sb-thread r10 lexenv
)
79 (defregset non-descriptor-regs
80 nl0 nl1 nl2 nl3 nl4 nl5 nl6 nl7 nl8 nl9 nargs nfp ocfp
)
82 ;; registers used to pass arguments
84 ;; the number of arguments/return values passed in registers
85 (def!constant register-arg-count
4)
86 ;; names and offsets for registers used to pass arguments
87 (defregset *register-arg-offsets
* r0 r1 r2 r3
)
88 (defparameter *register-arg-names
* '(r0 r1 r2 r3
)))
91 ;;;; SB and SC definition:
93 (define-storage-base registers
:finite
:size
32)
94 (define-storage-base control-stack
:unbounded
:size
2 :size-increment
1)
95 (define-storage-base non-descriptor-stack
:unbounded
:size
0)
96 (define-storage-base constant
:non-packed
)
97 (define-storage-base immediate-constant
:non-packed
)
98 (define-storage-base float-registers
:finite
:size
32)
101 ;;; Handy macro so we don't have to keep changing all the numbers whenever
102 ;;; we insert a new storage class.
104 (defmacro define-storage-classes
(&rest classes
)
105 (do ((forms (list 'progn
)
106 (let* ((class (car classes
))
107 (sc-name (car class
))
108 (constant-name (intern (concatenate 'simple-string
111 (list* `(define-storage-class ,sc-name
,index
113 `(def!constant
,constant-name
,index
)
116 (classes classes
(cdr classes
)))
120 (define-storage-classes
122 ;; Non-immediate contstants in the constant pool
125 ;; NULL is in a register.
126 (null 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 :constant-scs
(immediate)
149 :alternate-scs
(control-stack))
151 ;; Pointer descriptor objects. Must be seen by GC.
152 (descriptor-reg registers
153 :locations
#.descriptor-regs
154 :constant-scs
(constant null immediate
)
156 :alternate-scs
(control-stack))
158 (32-bit-reg registers
159 :locations
#.
(loop for i below
32 collect i
))
161 ;; The non-descriptor stacks.
162 (signed-stack non-descriptor-stack
) ; (signed-byte 64)
163 (unsigned-stack non-descriptor-stack
) ; (unsigned-byte 64)
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
) ; double floats.
168 (complex-single-stack non-descriptor-stack
)
169 (complex-double-stack non-descriptor-stack
:element-size
2 :alignment
2)
171 ;; **** Things that can go in the integer registers.
173 ;; Non-Descriptor characters
174 (character-reg registers
175 :locations
#.non-descriptor-regs
176 :constant-scs
(immediate)
178 :alternate-scs
(character-stack))
180 ;; Non-Descriptor SAP's (arbitrary pointers into address space)
182 :locations
#.non-descriptor-regs
183 :constant-scs
(immediate)
185 :alternate-scs
(sap-stack))
187 ;; Non-Descriptor (signed or unsigned) numbers.
188 (signed-reg registers
189 :locations
#.non-descriptor-regs
190 :constant-scs
(immediate)
192 :alternate-scs
(signed-stack))
193 (unsigned-reg registers
194 :locations
#.non-descriptor-regs
195 :constant-scs
(immediate)
197 :alternate-scs
(unsigned-stack))
199 ;; Random objects that must not be seen by GC. Used only as temporaries.
200 (non-descriptor-reg registers
201 :locations
#.non-descriptor-regs
)
203 ;; Pointers to the interior of objects. Used only as a temporary.
204 (interior-reg registers
205 :locations
(#.lr-offset
))
207 ;; **** Things that can go in the floating point registers.
209 ;; Non-Descriptor single-floats.
210 (single-reg float-registers
211 :locations
#.
(loop for i below
32 collect i
)
214 :alternate-scs
(single-stack))
216 ;; Non-Descriptor double-floats.
217 (double-reg float-registers
218 :locations
#.
(loop for i below
32 collect i
)
221 :alternate-scs
(double-stack))
223 (complex-single-reg float-registers
224 :locations
#.
(loop for i below
32 collect i
)
227 :alternate-scs
(complex-single-stack))
229 (complex-double-reg float-registers
230 :locations
#.
(loop for i below
32 collect i
)
233 :alternate-scs
(complex-double-stack))
235 (catch-block control-stack
:element-size catch-block-size
)
236 (unwind-block control-stack
:element-size unwind-block-size
))
238 ;;;; Make some random tns for important registers.
240 (macrolet ((defregtn (name sc
)
241 (let ((offset-sym (symbolicate name
"-OFFSET"))
242 (tn-sym (symbolicate name
"-TN")))
243 `(defparameter ,tn-sym
244 (make-random-tn :kind
:normal
245 :sc
(sc-or-lose ',sc
)
246 :offset
,offset-sym
)))))
248 (defregtn null descriptor-reg
)
249 (defregtn code descriptor-reg
)
250 (defregtn tmp any-reg
)
252 (defregtn nargs any-reg
)
253 (defregtn ocfp any-reg
)
254 (defregtn nsp any-reg
)
255 (defregtn zr any-reg
)
256 (defregtn cfp any-reg
)
257 (defregtn csp any-reg
)
258 (defregtn lr interior-reg
)
260 (defregtn thread interior-reg
))
262 ;;; If VALUE can be represented as an immediate constant, then return the
263 ;;; appropriate SC number, otherwise return NIL.
264 (defun immediate-constant-sc (value)
267 (sc-number-or-lose 'null
))
268 ((or (integer #.sb
!xc
:most-negative-fixnum
#.sb
!xc
:most-positive-fixnum
)
270 (sc-number-or-lose 'immediate
))
272 (if (static-symbol-p value
)
273 (sc-number-or-lose 'immediate
)
276 (defun boxed-immediate-sc-p (sc)
277 (or (eql sc
(sc-number-or-lose 'null
))
278 (eql sc
(sc-number-or-lose 'immediate
))))
280 ;;;; function call parameters
282 ;;; the SC numbers for register and stack arguments/return values
283 (def!constant immediate-arg-scn
(sc-number-or-lose 'any-reg
))
284 (def!constant control-stack-arg-scn
(sc-number-or-lose 'control-stack
))
286 ;;; offsets of special stack frame locations
287 (def!constant ocfp-save-offset
0)
288 (def!constant lra-save-offset
1)
289 (def!constant nfp-save-offset
2)
291 ;;; This is used by the debugger.
292 ;;; < nyef> Ah, right. So, SINGLE-VALUE-RETURN-BYTE-OFFSET doesn't apply to x86oids or ARM.
293 (def!constant single-value-return-byte-offset
0)
296 ;;; A list of TN's describing the register arguments.
298 (defparameter *register-arg-tns
*
299 (mapcar #'(lambda (n)
300 (make-random-tn :kind
:normal
301 :sc
(sc-or-lose 'descriptor-reg
)
303 *register-arg-offsets
*))
305 ;;; This function is called by debug output routines that want a pretty name
306 ;;; for a TN's location. It returns a thing that can be printed with PRINC.
307 (defun location-print-name (tn)
308 (declare (type tn tn
))
309 (let ((sb (sb-name (sc-sb (tn-sc tn
))))
310 (offset (tn-offset tn
)))
312 (registers (format nil
"~:[~;W~]~A"
313 (sc-is tn
32-bit-reg
)
314 (svref *register-names
* offset
)))
315 (control-stack (format nil
"CS~D" offset
))
316 (non-descriptor-stack (format nil
"NS~D" offset
))
317 (constant (format nil
"Const~D" offset
))
318 (immediate-constant "Immed")
323 ((double-reg complex-single-reg
) "D")
324 (complex-double-reg "Q"))
327 (defun combination-implementation-style (node)
328 (flet ((valid-funtype (args result
)
329 (sb!c
::valid-fun-use node
330 (sb!c
::specifier-type
331 `(function ,args
,result
)))))
332 (case (sb!c
::combination-fun-source-name node
)
334 (if (or (valid-funtype '(fixnum fixnum
) '*)
335 (valid-funtype '(signed-word signed-word
) '*)
336 (valid-funtype '(word word
) '*))
338 (values :default nil
)))
341 ((or (valid-funtype '((constant-arg (integer 0 #.
(1- n-fixnum-bits
))) fixnum
) '*)
342 (valid-funtype '((constant-arg (integer 0 #.
(1- n-word-bits
))) signed-word
) '*)
343 (valid-funtype '((constant-arg (integer 0 #.
(1- n-word-bits
))) word
) '*))
344 (values :transform
'(lambda (index integer
)
345 (%logbitp integer index
))))
346 (t (values :default nil
))))
348 (flet ((validp (type width
)
349 (and (valid-funtype `((constant-arg (mod ,width
))
350 (constant-arg (mod ,width
))
353 (destructuring-bind (size posn integer
)
354 (sb!c
::basic-combination-args node
)
355 (declare (ignore integer
))
356 (and (plusp (sb!c
::lvar-value posn
))
357 (<= (+ (sb!c
::lvar-value size
)
358 (sb!c
::lvar-value posn
))
360 (if (or (validp 'fixnum n-fixnum-bits
)
361 (validp '(signed-byte 64) 64)
362 (validp '(unsigned-byte 64) 64))
363 (values :transform
'(lambda (size posn integer
)
364 (%%ldb integer size posn
)))
365 (values :default nil
))))
367 (flet ((validp (type width
)
368 (and (valid-funtype `(,type
369 (constant-arg (mod ,width
))
370 (constant-arg (mod ,width
))
373 (destructuring-bind (newbyte size posn integer
)
374 (sb!c
::basic-combination-args node
)
375 (declare (ignore integer newbyte
))
376 (and (plusp (sb!c
::lvar-value posn
))
377 (<= (+ (sb!c
::lvar-value size
)
378 (sb!c
::lvar-value posn
))
380 (if (or (validp 'fixnum n-fixnum-bits
)
381 (validp '(signed-byte 64) 64)
382 (validp '(unsigned-byte 64) 64))
383 (values :transform
'(lambda (newbyte size posn integer
)
384 (%%dpb newbyte size posn integer
)))
385 (values :default nil
))))
386 (t (values :default nil
)))))
388 (defun primitive-type-indirect-cell-type (ptype)
389 (declare (ignore ptype
))
392 (defun 32-bit-reg (tn)
393 (make-random-tn :kind
:normal
394 :sc
(sc-or-lose '32-bit-reg
)
395 :offset
(tn-offset tn
)))