Context Navigation

source: branches/working-0711/ccl/compiler/PPC/PPC64/ppc64-arch.lisp @ 7743

Visit:

Last change on this file since 7743 was 7743, checked in by gb, 13 years ago
Add lock whostate fields on PPC, too.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 36.6 KB

Line
1	;;;-- Mode: Lisp; Package: (PPC64 :use CL) --
2	;;;
3	;;; Copyright (C) 1994-2001 Digitool, Inc
4	;;; This file is part of OpenMCL.
5	;;;
6	;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7	;;; License , known as the LLGPL and distributed with OpenMCL as the
8	;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
9	;;; which is distributed with OpenMCL as the file "LGPL". Where these
10	;;; conflict, the preamble takes precedence.
11	;;;
12	;;; OpenMCL is referenced in the preamble as the "LIBRARY."
13	;;;
14	;;; The LLGPL is also available online at
15	;;; http://opensource.franz.com/preamble.html
16
17	;;; This file matches "ccl:lisp-kernel;constants64.h" &
18	;;; "ccl:lisp-kernel;constants64.s"
19
20	(defpackage "PPC64"
21	(:use "CL")
22	#+ppc64-target
23	(:nicknames "TARGET"))
24
25
26	(in-package "PPC64")
27
28	(eval-when (:compile-toplevel :load-toplevel :execute)
29	(defconstant rcontext 2) ;sigh. Could use r13+bias on Linux,
30	; but Apple hasn't invented tls yet.
31	(defconstant nbits-in-word 64)
32	(defconstant least-significant-bit 63)
33	(defconstant nbits-in-byte 8)
34	(defconstant ntagbits 4)
35	(defconstant nlisptagbits 3)
36	(defconstant nfixnumtagbits 3) ; See ?
37	(defconstant nlowtagbits 2)
38	(defconstant num-subtag-bits 8) ; tag part of header is 8 bits wide
39	(defconstant fixnumshift nfixnumtagbits)
40	(defconstant fixnum-shift fixnumshift) ; A pet name for it.
41	(defconstant fulltagmask (1- (ash 1 ntagbits))) ; Only needed by GC/very low-level code
42	(defconstant full-tag-mask fulltagmask)
43	(defconstant tagmask (1- (ash 1 nlisptagbits)))
44	(defconstant tag-mask tagmask)
45	(defconstant fixnummask (1- (ash 1 nfixnumtagbits)))
46	(defconstant fixnum-mask fixnummask)
47	(defconstant subtag-mask (1- (ash 1 num-subtag-bits)))
48	(defconstant ncharcodebits 8) ;24
49	(defconstant charcode-shift 8)
50	(defconstant word-shift 3)
51	(defconstant word-size-in-bytes 8)
52	(defconstant node-size word-size-in-bytes)
53	(defconstant dnode-size 16)
54	(defconstant dnode-align-bits 4)
55	(defconstant dnode-shift dnode-align-bits)
56	(defconstant bitmap-shift 6)
57
58	(defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits))))
59	(defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits)))))
60	(defmacro define-subtag (name tag value)
61	`(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,value ntagbits))))
62
63	;;; PPC64 stuff and tags.
64
65	;;; There are several ways to look at the 4 tag bits of any object or
66	;;; header. Looking at the low 2 bits, we can classify things as
67	;;; follows (I'm not sure if we'd ever want to do this) :
68	;;;
69	;;; #b00 a "primary" object: fixnum, cons, uvector
70	;;; #b01 an immediate
71	;;; #b10 the header on an immediate uvector
72	;;; #b11 the header on a node (pointer-containing) uvector
73	;;
74	;;; Note that the ppc64's LD and STD instructions require that the low
75	;;; two bits of the constant displacement be #b00. If we want to use constant
76	;;; offsets to access CONS and UVECTOR fields, we're pretty much obligated
77	;;; to ensure that CONS and UVECTOR have tags that also end in #b00, and
78	;;; fixnum addition and subtraction work better when fixnum tags are all 0.
79	;;; We generally have to look at all 4 tag bits before we really know what
80	;;; class of "potentially primary" object we're looking at.
81	;;; If we look at 3 tag bits, we can see:
82	;;;
83	;;; #b000 fixnum
84	;;; #b001 immediate
85	;;; #b010 immedate-header
86	;;; #b011 node-header
87	;;; #b100 CONS or UVECTOR
88	;;; #b101 immediate
89	;;; #b110 immediate-header
90	;;; #b111 node-header
91	;;;
92
93	(defconstant tag-fixnum 0)
94	(defconstant tag-imm-0 1)
95	(defconstant tag-immheader-0 2)
96	(defconstant tag-nodeheader-0 3)
97	(defconstant tag-memory 4)
98	(defconstant tag-imm-2 5)
99	(defconstant tag-immheader2 6)
100	(defconstant tag-nodeheader2 7)
101
102
103	;;; Note how we're already winding up with lots of header and immediate
104	;;; "classes". That might actually be useful.
105	;;
106	;;; When we move to 4 bits, we wind up (obviously) with 4 tags of the form
107	;;; #bxx00. There are two partitionings that make (some) sense: we can either
108	;;; use 2 of these for (even and odd) fixnums, or we can give NIL a tag
109	;;; that's congruent (mod 16) with CONS. There seem to be a lot of tradeoffs
110	;;; involved, but it ultimately seems best to be able to treat 64-bit
111	;;; aligned addresses as fixnums: we don't want the VSP to look like a
112	;;; vector. That basically requires that NIL really be a symbol (good
113	;;; bye, nilsym) and that we ensure that there are NILs where its CAR and
114	;;; CDR would be (-4, 4 bytes from the tagged pointer.) That means that
115	;;; CONS is 4 and UVECTOR is 12, and we have even more immediate/header types.
116
117	(defconstant fulltag-even-fixnum #b0000)
118	(defconstant fulltag-imm-0 #b0001)
119	(defconstant fulltag-immheader-0 #b0010)
120	(defconstant fulltag-nodeheader-0 #b0011)
121	(defconstant fulltag-cons #b0100)
122	(defconstant fulltag-imm-1 #b0101)
123	(defconstant fulltag-immheader-1 #b0110)
124	(defconstant fulltag-nodeheader-1 #b0111)
125	(defconstant fulltag-odd-fixnum #b1000)
126	(defconstant fulltag-imm-2 #b1001)
127	(defconstant fulltag-immheader-2 #b1010)
128	(defconstant fulltag-nodeheader-2 #b1011)
129	(defconstant fulltag-misc #b1100)
130	(defconstant fulltag-imm-3 #b1101)
131	(defconstant fulltag-immheader-3 #b1110)
132	(defconstant fulltag-nodeheader-3 #b1111)
133
134	(defconstant lowtagmask (1- (ash 1 nlowtagbits)))
135	(defconstant lowtag-mask lowtagmask)
136	(defconstant lowtag-primary 0)
137	(defconstant lowtag-imm 1)
138	(defconstant lowtag-immheader 2)
139	(defconstant lowtag-nodeheader 3)
140
141	;;; The general algorithm for determining the (primary) type of an
142	;;; object is something like:
143	;;; (clrldi tag node 60)
144	;;; (cmpwi tag fulltag-misc)
145	;;; (clrldi tag tag 61)
146	;;; (bne @done)
147	;;; (lbz tag misc-subtag-offset node)
148	;;; @done
149	;;
150	;;; That's good enough to identify FIXNUM, "generally immediate", cons,
151	;;; or a header tag from a UVECTOR. In some cases, we may need to hold
152	;;; on to the full 4-bit tag.
153	;;; In no specific order:
154	;;; - it's important to be able to quickly recognize fixnums; that's
155	;;; simple
156	;;; - it's important to be able to quickly recognize lists (for CAR/CDR)
157	;;; and somewhat important to be able to quickly recognize conses.
158	;;; Also simple, though we have to special-case NIL.
159	;;; - it's desirable to be able to do VECTORP, ARRAYP, and specific-array-type-
160	;;; p. We need at least 12 immediate CL vector types (SIGNED/UNSIGNED-BYTE
161	;;; 8/16/32/64, SINGLE-FLOAT, DOUBLE-FLOAT, BIT, and at least one CHARACTER;
162	;;; we need SIMPLE-ARRAY, VECTOR-HEADER, and ARRAY-HEADER as node
163	;;; array types. That's suspciciously close to 16
164	;;; - it's desirable to be able (in FUNCALL) to quickly recognize
165	;;; functions/symbols/other, and probably desirable to trap on other.
166	;;; Pretty much have to do a memory reference and at least one comparison
167	;;; here.
168	;;; - it's sometimes desirable to recognize numbers and distinct numeric
169	;;; types (other than FIXNUM) quickly.
170	;;; - The GC (especially) needs to be able to determine the size of
171	;;; ivectors (ivector elements) fairly cheaply. Most ivectors are CL
172	;;; arrays, but code-vectors are fairly common (and have 32-bit elements,
173	;;; naturally.)
174	;;; - We have a fairly large number of non-array gvector types, and it's
175	;;; always desirable to have room for expansion.
176	;;; - we basically have 8 classes of header subtags, each of which has
177	;;; 16 possible values. If we stole the high bit of the subtag to
178	;;; indicate CL-array-ness, we'd still have 6 bits to encode non-CL
179	;;; array types.
180
181	(defconstant cl-array-subtag-bit 7)
182	(defconstant cl-array-subtag-mask (ash 1 cl-array-subtag-bit))
183	(defmacro define-cl-array-subtag (name tag value)
184	`(defconstant ,(ccl::form-symbol "SUBTAG-" name)
185	(logior cl-array-subtag-mask (logior ,tag (ash ,value ntagbits)))))
186
187	(define-cl-array-subtag arrayH fulltag-nodeheader-1 0)
188	(define-cl-array-subtag vectorH fulltag-nodeheader-2 0)
189	(define-cl-array-subtag simple-vector fulltag-nodeheader-3 0)
190	(defconstant min-array-subtag subtag-arrayH)
191	(defconstant min-vector-subtag subtag-vectorH)
192
193	;;; bits: 64 32 16 8 1
194	;;; CL-array ivector types DOUBLE-FLOAT SINGLE s16 CHAR BIT
195	;;; s64 s32 u16 s8
196	;;; u64 u32 u8
197	;;; Other ivector types MACPTR CODE-VECTOR
198	;;; DEAD-MACPTR XCODE-VECTOR
199	;;; BIGNUM
200	;;; DOUBLE-FLOAT
201	;;; There might possibly be ivectors with 128-bit (VMX/AltiVec) elements
202	;;; someday, and there might be multiple character sizes (16/32 bits).
203	;;; That sort of suggests that we use the four immheader classes to
204	;;; encode the ivector size (64, 32, 8, other) and make BIT an easily-
205	;;; detected case of OTHER.
206
207	(defconstant ivector-class-64-bit fulltag-immheader-3)
208	(defconstant ivector-class-32-bit fulltag-immheader-2)
209	(defconstant ivector-class-other-bit fulltag-immheader-1)
210	(defconstant ivector-class-8-bit fulltag-immheader-0)
211
212	(define-cl-array-subtag s64-vector ivector-class-64-bit 1)
213	(define-cl-array-subtag u64-vector ivector-class-64-bit 2)
214	(define-cl-array-subtag fixnum-vector ivector-class-64-bit 3)
215	(define-cl-array-subtag double-float-vector ivector-class-64-bit 4)
216	(define-cl-array-subtag s32-vector ivector-class-32-bit 1)
217	(define-cl-array-subtag u32-vector ivector-class-32-bit 2)
218	(define-cl-array-subtag single-float-vector ivector-class-32-bit 3)
219	(define-cl-array-subtag simple-base-string ivector-class-32-bit 5)
220	(define-cl-array-subtag s16-vector ivector-class-other-bit 1)
221	(define-cl-array-subtag u16-vector ivector-class-other-bit 2)
222	(define-cl-array-subtag bit-vector ivector-class-other-bit 7)
223	(define-cl-array-subtag s8-vector ivector-class-8-bit 1)
224	(define-cl-array-subtag u8-vector ivector-class-8-bit 2)
225
226	;;; There's some room for expansion in non-array ivector space.
227	(define-subtag macptr ivector-class-64-bit 1)
228	(define-subtag dead-macptr ivector-class-64-bit 2)
229
230	(define-subtag code-vector ivector-class-32-bit 0)
231	(define-subtag xcode-vector ivector-class-32-bit 1)
232	(define-subtag bignum ivector-class-32-bit 2)
233	(define-subtag double-float ivector-class-32-bit 3)
234
235	;;; Size doesn't matter for non-CL-array gvectors; I can't think of a good
236	;;; reason to classify them in any particular way. Let's put funcallable
237	;;; things in the first slice by themselves, though it's not clear that
238	;;; that helps FUNCALL much.
239	(defconstant gvector-funcallable fulltag-nodeheader-0)
240	(define-subtag function gvector-funcallable 0)
241	(define-subtag symbol gvector-funcallable 1)
242
243	(define-subtag catch-frame fulltag-nodeheader-1 0)
244	(define-subtag basic-stream fulltag-nodeheader-1 1)
245	(define-subtag lock fulltag-nodeheader-1 2)
246	(define-subtag hash-vector fulltag-nodeheader-1 3)
247	(define-subtag pool fulltag-nodeheader-1 4)
248	(define-subtag weak fulltag-nodeheader-1 5)
249	(define-subtag package fulltag-nodeheader-1 6)
250	(define-subtag slot-vector fulltag-nodeheader-2 0)
251	(define-subtag instance fulltag-nodeheader-2 1)
252	(define-subtag struct fulltag-nodeheader-2 2)
253	(define-subtag istruct fulltag-nodeheader-2 3)
254	(define-subtag value-cell fulltag-nodeheader-2 4)
255	(define-subtag xfunction fulltag-nodeheader-2 5)
256
257	(define-subtag ratio fulltag-nodeheader-3 0)
258	(define-subtag complex fulltag-nodeheader-3 1)
259
260
261
262	(eval-when (:compile-toplevel :load-toplevel :execute)
263	(require "PPC-ARCH")
264	(defmacro define-storage-layout (name origin &rest cells)
265	`(progn
266	(ccl::defenum (:start ,origin :step 8)
267	,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
268	(defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells)
269	8))))
270
271	(defmacro define-lisp-object (name tagname &rest cells)
272	`(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
273
274
275
276	(defmacro define-fixedsized-object (name &rest non-header-cells)
277	`(progn
278	(define-lisp-object ,name fulltag-misc header ,@non-header-cells)
279	(ccl::defenum ()
280	,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
281	(defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
282
283
284
285
286
287
288
289	(defconstant misc-header-offset (- fulltag-misc))
290	(defconstant misc-subtag-offset (+ misc-header-offset 7 ))
291	(defconstant misc-data-offset (+ misc-header-offset 8))
292	(defconstant misc-dfloat-offset (+ misc-header-offset 8))
293
294
295
296	(define-subtag single-float fulltag-imm-0 0)
297
298	(define-subtag character fulltag-imm-1 0)
299
300	;;; FULLTAG-IMM-2 is unused, so the only type with lisptag (3-bit tag)
301	;;; TAG-IMM-0 should be SINGLE-FLOAT.
302
303	(define-subtag unbound fulltag-imm-3 0)
304	(defconstant unbound-marker subtag-unbound)
305	(defconstant undefined unbound-marker)
306	(define-subtag slot-unbound fulltag-imm-3 1)
307	(defconstant slot-unbound-marker subtag-slot-unbound)
308	(define-subtag illegal fulltag-imm-3 2)
309	(defconstant illegal-marker subtag-illegal)
310
311	(define-subtag no-thread-local-binding fulltag-imm-3 3)
312	(define-subtag forward-marker fulltag-imm-3 7)
313
314
315	(defconstant max-64-bit-constant-index (ash (+ #x7fff ppc64::misc-dfloat-offset) -3))
316	(defconstant max-32-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) -2))
317	(defconstant max-16-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) -1))
318	(defconstant max-8-bit-constant-index (+ #x7fff ppc64::misc-data-offset))
319	(defconstant max-1-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) 5))
320
321
322	; The objects themselves look something like this:
323
324	; Order of CAR and CDR doesn't seem to matter much - there aren't
325	; too many tricks to be played with predecrement/preincrement addressing.
326	; Keep them in the confusing MCL 3.0 order, to avoid confusion.
327	(define-lisp-object cons fulltag-cons
328	cdr
329	car)
330
331
332	(define-fixedsized-object ratio
333	numer
334	denom)
335
336	;;; It's slightly easier (for bootstrapping reasons)
337	;;; to view a DOUBLE-FLOAT as being UVECTOR with 2 32-bit elements
338	;;; (rather than 1 64-bit element).
339
340	(defconstant double-float.value misc-data-offset)
341	(defconstant double-float.value-cell 0)
342	(defconstant double-float.val-high double-float.value)
343	(defconstant double-float.val-high-cell double-float.value-cell)
344	(defconstant double-float.val-low (+ double-float.value 4))
345	(defconstant double-float.val-low-cell 1)
346	(defconstant double-float.element-count 2)
347	(defconstant double-float.size 16)
348
349	(define-fixedsized-object complex
350	realpart
351	imagpart
352	)
353
354
355	; There are two kinds of macptr; use the length field of the header if you
356	; need to distinguish between them
357	(define-fixedsized-object macptr
358	address
359	domain
360	type
361	)
362
363	(define-fixedsized-object xmacptr
364	address
365	domain
366	type
367	flags
368	link
369	)
370
371	; Catch frames go on the tstack; they point to a minimal lisp-frame
372	; on the cstack. (The catch/unwind-protect PC is on the cstack, where
373	; the GC expects to find it.)
374	(define-fixedsized-object catch-frame
375	catch-tag ; #<unbound> -> unwind-protect, else catch
376	link ; tagged pointer to next older catch frame
377	mvflag ; 0 if single-value, 1 if uwp or multiple-value
378	csp ; pointer to control stack
379	db-link ; value of dynamic-binding link on thread entry.
380	save-save7 ; saved registers
381	save-save6
382	save-save5
383	save-save4
384	save-save3
385	save-save2
386	save-save1
387	save-save0
388	xframe ; exception-frame link
389	tsp-segment ; mostly padding, for now.
390	)
391
392	(define-fixedsized-object lock
393	_value ;finalizable pointer to kernel object
394	kind ; '0 = recursive-lock, '1 = rwlock
395	writer ;tcr of owning thread or 0
396	name
397	whostate
398	whostate-2
399	)
400
401
402
403	(define-fixedsized-object symbol
404	pname
405	vcell
406	fcell
407	package-predicate
408	flags
409	plist
410	binding-index
411	)
412
413
414	(defconstant t-offset (- symbol.size))
415
416
417
418
419	(define-fixedsized-object vectorH
420	logsize ; fillpointer if it has one, physsize otherwise
421	physsize ; total size of (possibly displaced) data vector
422	data-vector ; object this header describes
423	displacement ; true displacement or 0
424	flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
425	)
426
427	(define-lisp-object arrayH fulltag-misc
428	header ; subtag = subtag-arrayH
429	rank ; NEVER 1
430	physsize ; total size of (possibly displaced) data vector
431	data-vector ; object this header describes
432	displacement ; true displacement or 0
433	flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
434	;; Dimensions follow
435	)
436
437	(defconstant arrayH.rank-cell 0)
438	(defconstant arrayH.physsize-cell 1)
439	(defconstant arrayH.data-vector-cell 2)
440	(defconstant arrayH.displacement-cell 3)
441	(defconstant arrayH.flags-cell 4)
442	(defconstant arrayH.dim0-cell 5)
443
444	(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
445	(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
446
447
448	(define-fixedsized-object value-cell
449	value)
450
451
452	;;; The kernel uses these (rather generically named) structures
453	;;; to keep track of various memory regions it (or the lisp) is
454	;;; interested in.
455
456
457	(define-storage-layout area 0
458	pred ; pointer to preceding area in DLL
459	succ ; pointer to next area in DLL
460	low ; low bound on area addresses
461	high ; high bound on area addresses.
462	active ; low limit on stacks, high limit on heaps
463	softlimit ; overflow bound
464	hardlimit ; another one
465	code ; an area-code; see below
466	markbits ; bit vector for GC
467	ndnodes ; "active" size of dynamic area or stack
468	older ; in EGC sense
469	younger ; also for EGC
470	h ; Handle or null pointer
471	softprot ; protected_area structure pointer
472	hardprot ; another one.
473	owner ; fragment (library) which "owns" the area
474	refbits ; bitvector for intergenerational refernces
475	threshold ; for egc
476	gc-count ; generational gc count.
477	static-dnodes ; for honsing. etc
478	static-used ; bitvector
479	)
480
481
482
483
484
485	(define-storage-layout protected-area 0
486	next
487	start ; first byte (page-aligned) that might be protected
488	end ; last byte (page-aligned) that could be protected
489	nprot ; Might be 0
490	protsize ; number of bytes to protect
491	why)
492
493	(defconstant tcr-bias 0)
494
495	(define-storage-layout tcr (- tcr-bias)
496	prev ; in doubly-linked list
497	next ; in doubly-linked list
498	single-float-convert ; per-thread scratch space.
499	lisp-fpscr-high
500	db-link ; special binding chain head
501	catch-top ; top catch frame
502	save-vsp ; VSP when in foreign code
503	save-tsp ; TSP when in foreign code
504	cs-area ; cstack area pointer
505	vs-area ; vstack area pointer
506	ts-area ; tstack area pointer
507	cs-limit ; cstack overflow limit
508	total-bytes-allocated-high
509	log2-allocation-quantum ; unboxed
510	interrupt-pending ; fixnum
511	xframe ; exception frame linked list
512	errno-loc ; thread-private, maybe
513	ffi-exception ; fpscr bits from ff-call.
514	osid ; OS thread id
515	valence ; odd when in foreign code
516	foreign-exception-status
517	native-thread-info
518	native-thread-id
519	last-allocptr
520	save-allocptr
521	save-allocbase
522	reset-completion
523	activate
524	suspend-count
525	suspend-context
526	pending-exception-context
527	suspend ; semaphore for suspension notify
528	resume ; sempahore for resumption notify
529	flags ; foreign, being reset, ...
530	gc-context
531	termination-semaphore
532	unwinding
533	tlb-limit
534	tlb-pointer
535	shutdown-count
536	safe-ref-address
537	)
538
539	(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
540
541	(defconstant tcr.lisp-fpscr-low (+ tcr.lisp-fpscr-high 4))
542	(defconstant tcr.total-bytes-allocated-low (+ tcr.total-bytes-allocated-high 4))
543
544	(define-storage-layout lockptr 0
545	avail
546	owner
547	count
548	signal
549	waiting
550	malloced-ptr
551	spinlock)
552
553	(define-storage-layout rwlock 0
554	spin
555	state
556	blocked-writers
557	blocked-readers
558	writer
559	reader-signal
560	writer-signal
561	malloced-ptr
562	)
563
564	;;; For the eabi port: mark this stack frame as Lisp's (since EABI
565	;;; foreign frames can be the same size as a lisp frame.)
566
567
568	(ppc64::define-storage-layout lisp-frame 0
569	backlink
570	savefn
571	savelr
572	savevsp
573	)
574
575	(ppc64::define-storage-layout c-frame 0
576	backlink
577	crsave
578	savelr
579	unused-1
580	unused-2
581	savetoc
582	param0
583	param1
584	param2
585	param3
586	param4
587	param5
588	param6
589	param7
590	)
591
592	(defconstant c-frame.minsize c-frame.size)
593
594	(defmacro define-header (name element-count subtag)
595	`(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
596
597	(define-header double-float-header double-float.element-count subtag-double-float)
598	;;; We could possibly have a one-digit bignum header when dealing
599	;;; with "small bignums" in some bignum code. Like other cases of
600	;;; non-normalized bignums, they should never escape from the lab.
601	(define-header one-digit-bignum-header 1 subtag-bignum)
602	(define-header two-digit-bignum-header 2 subtag-bignum)
603	(define-header three-digit-bignum-header 3 subtag-bignum)
604	(define-header four-digit-bignum-header 4 subtag-bignum)
605	(define-header five-digit-bignum-header 5 subtag-bignum)
606	(define-header symbol-header symbol.element-count subtag-symbol)
607	(define-header value-cell-header value-cell.element-count subtag-value-cell)
608	(define-header macptr-header macptr.element-count subtag-macptr)
609
610
611	(defconstant yield-syscall
612	#+darwinppc-target -60
613	#+linuxppc-target #$__NR_sched_yield)
614	)
615	)
616
617
618
619
620
621
622	(defun %kernel-global (sym)
623	(let* ((pos (position sym ppc::ppc-kernel-globals :test #'string=)))
624	(if pos
625	(- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
626	(error "Unknown kernel global : ~s ." sym))))
627
628	(defmacro kernel-global (sym)
629	(let* ((pos (position sym ppc::ppc-kernel-globals :test #'string=)))
630	(if pos
631	(- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
632	(error "Unknown kernel global : ~s ." sym))))
633
634	;;; The kernel imports things that are defined in various other
635	;;; libraries for us. The objects in question are generally
636	;;; fixnum-tagged; the entries in the "kernel-imports" vector are 8
637	;;; bytes apart.
638	(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step word-size-in-bytes)
639	fd-setsize-bytes
640	do-fd-set
641	do-fd-clr
642	do-fd-is-set
643	do-fd-zero
644	MakeDataExecutable
645	GetSharedLibrary
646	FindSymbol
647	malloc
648	free
649	allocate_tstack
650	allocate_vstack
651	register_cstack
652	raise-thread-interrupt
653	get-r-debug
654	restore-soft-stack-limit
655	egc-control
656	lisp-bug
657	NewThread
658	YieldToThread
659	DisposeThread
660	ThreadCurrentStackSpace
661	usage-exit
662	save-fp-context
663	restore-fp-context
664	put-altivec-registers
665	get-altivec-registers
666	new-semaphore
667	wait-on-semaphore
668	signal-semaphore
669	destroy-semaphore
670	new-recursive-lock
671	lock-recursive-lock
672	unlock-recursive-lock
673	destroy-recursive-lock
674	suspend-other-threads
675	resume-other-threads
676	suspend-tcr
677	resume-tcr
678	rwlock-new
679	rwlock-destroy
680	rwlock-rlock
681	rwlock-wlock
682	rwlock-unlock
683	recursive-lock-trylock
684	foreign-name-and-offset
685	)
686
687	(defmacro nrs-offset (name)
688	(let* ((pos (position name ppc::ppc-nilreg-relative-symbols :test #'eq)))
689	(if pos (* (1- pos) symbol.size))))
690
691	(defconstant nil-value (+ #x3000 symbol.size fulltag-misc))
692
693
694	(defconstant reservation-discharge #x2008)
695
696	(defparameter ppc64-target-uvector-subtags
697	`((:bignum . ,subtag-bignum)
698	(:ratio . ,subtag-ratio)
699	(:single-float . ,subtag-single-float)
700	(:double-float . ,subtag-double-float)
701	(:complex . ,subtag-complex )
702	(:symbol . ,subtag-symbol)
703	(:function . ,subtag-function )
704	(:code-vector . ,subtag-code-vector)
705	(:xcode-vector . ,subtag-xcode-vector)
706	(:macptr . ,subtag-macptr )
707	(:catch-frame . ,subtag-catch-frame)
708	(:struct . ,subtag-struct )
709	(:istruct . ,subtag-istruct )
710	(:pool . ,subtag-pool )
711	(:population . ,subtag-weak )
712	(:hash-vector . ,subtag-hash-vector )
713	(:package . ,subtag-package )
714	(:value-cell . ,subtag-value-cell)
715	(:instance . ,subtag-instance )
716	(:lock . ,subtag-lock )
717	(:basic-stream . ,subtag-basic-stream)
718	(:slot-vector . ,subtag-slot-vector)
719	(:simple-string . ,subtag-simple-base-string )
720	(:bit-vector . ,subtag-bit-vector )
721	(:signed-8-bit-vector . ,subtag-s8-vector )
722	(:unsigned-8-bit-vector . ,subtag-u8-vector )
723	(:signed-16-bit-vector . ,subtag-s16-vector )
724	(:unsigned-16-bit-vector . ,subtag-u16-vector )
725	(:signed-32-bit-vector . ,subtag-s32-vector )
726	(:unsigned-32-bit-vector . ,subtag-u32-vector )
727	(:fixnum-vector . ,subtag-fixnum-vector)
728	(:signed-64-bit-vector . ,subtag-s64-vector)
729	(:unsigned-64-bit-vector . ,subtag-u64-vector)
730	(:single-float-vector . ,subtag-single-float-vector)
731	(:double-float-vector . ,subtag-double-float-vector )
732	(:simple-vector . ,subtag-simple-vector )
733	(:vector-header . ,subtag-vectorH)
734	(:array-header . ,subtag-arrayH)))
735
736	;;; This should return NIL unless it's sure of how the indicated
737	;;; type would be represented (in particular, it should return
738	;;; NIL if the element type is unknown or unspecified at compile-time.
739	(defun ppc64-array-type-name-from-ctype (ctype)
740	(when (typep ctype 'ccl::array-ctype)
741	(let* ((element-type (ccl::array-ctype-element-type ctype)))
742	(typecase element-type
743	(ccl::class-ctype
744	(let* ((class (ccl::class-ctype-class element-type)))
745	(if (or (eq class ccl::character-class)
746	(eq class ccl::base-char-class)
747	(eq class ccl::standard-char-class))
748	:simple-string
749	:simple-vector)))
750	(ccl::numeric-ctype
751	(if (eq (ccl::numeric-ctype-complexp element-type) :complex)
752	:simple-vector
753	(case (ccl::numeric-ctype-class element-type)
754	(integer
755	(let* ((low (ccl::numeric-ctype-low element-type))
756	(high (ccl::numeric-ctype-high element-type)))
757	(cond ((or (null low) (null high))
758	:simple-vector)
759	((and (>= low 0) (<= high 1))
760	:bit-vector)
761	((and (>= low 0) (<= high 255))
762	:unsigned-8-bit-vector)
763	((and (>= low 0) (<= high 65535))
764	:unsigned-16-bit-vector)
765	((and (>= low 0) (<= high #xffffffff))
766	:unsigned-32-bit-vector)
767	((and (>= low 0) (<= high #xffffffffffffffff))
768	:unsigned-64-bit-vector)
769	((and (>= low -128) (<= high 127))
770	:signed-8-bit-vector)
771	((and (>= low -32768) (<= high 32767))
772	:signed-16-bit-vector)
773	((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
774	:signed-32-bit-vector)
775	((and (>= low target-most-negative-fixnum)
776	(<= high target-most-positive-fixnum))
777	:fixnum-vector)
778	((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
779	:signed-64-bit-vector)
780	(t :simple-vector))))
781	(float
782	(case (ccl::numeric-ctype-format element-type)
783	((double-float long-float) :double-float-vector)
784	((single-float short-float) :single-float-vector)
785	(t :simple-vector)))
786	(t :simple-vector))))
787	(ccl::unknown-ctype)
788	(ccl::named-ctype
789	(if (eq element-type ccl::universal-type)
790	:simple-vector))
791	(t)))))
792
793	(defun ppc64-misc-byte-count (subtag element-count)
794	(declare (fixnum subtag))
795	(if (= lowtag-nodeheader (logand subtag lowtagmask))
796	(ash element-count 3)
797	(case (logand subtag fulltagmask)
798	(#.ivector-class-64-bit (ash element-count 3))
799	(#.ivector-class-32-bit (ash element-count 2))
800	(#.ivector-class-8-bit element-count)
801	(t
802	(if (= subtag subtag-bit-vector)
803	(ash (+ 7 element-count) -3)
804	(ash element-count 1))))))
805
806	(defparameter ppc64-target-arch
807	(arch::make-target-arch :name :ppc64
808	:lisp-node-size 8
809	:nil-value nil-value
810	:fixnum-shift fixnumshift
811	:most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift))))
812	:most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift))))
813	:misc-data-offset misc-data-offset
814	:misc-dfloat-offset misc-dfloat-offset
815	:nbits-in-word 64
816	:ntagbits 4
817	:nlisptagbits 3
818	:uvector-subtags ppc64-target-uvector-subtags
819	:max-64-bit-constant-index max-64-bit-constant-index
820	:max-32-bit-constant-index max-32-bit-constant-index
821	:max-16-bit-constant-index max-16-bit-constant-index
822	:max-8-bit-constant-index max-8-bit-constant-index
823	:max-1-bit-constant-index max-1-bit-constant-index
824	:word-shift 3
825	:code-vector-prefix '(#$"CODE")
826	:gvector-types '(:ratio :complex :symbol :function
827	:catch-frame :struct :istruct
828	:pool :population :hash-vector
829	:package :value-cell :instance
830	:lock :slot-vector
831	:simple-vector)
832	:1-bit-ivector-types '(:bit-vector)
833	:8-bit-ivector-types '(:signed-8-bit-vector
834	:unsigned-8-bit-vector)
835	:16-bit-ivector-types '(:signed-16-bit-vector
836	:unsigned-16-bit-vector)
837	:32-bit-ivector-types '(:signed-32-bit-vector
838	:unsigned-32-bit-vector
839	:single-float-vector
840	:double-float
841	:bignum
842	:simple-string)
843	:64-bit-ivector-types '(:double-float-vector
844	:unsigned-64-bit-vector
845	:signed-64-bit-vector
846	:fixnum-vector)
847	:array-type-name-from-ctype-function
848	#'ppc64-array-type-name-from-ctype
849	:package-name "PPC64"
850	:t-offset t-offset
851	:array-data-size-function #'ppc64-misc-byte-count
852	:numeric-type-name-to-typecode-function
853	#'(lambda (type-name)
854	(ecase type-name
855	(fixnum tag-fixnum)
856	(bignum subtag-bignum)
857	((short-float single-float) subtag-single-float)
858	((long-float double-float) subtag-double-float)
859	(ratio subtag-ratio)
860	(complex subtag-complex)))
861	:subprims-base ppc::ppc-subprims-base
862	:subprims-shift ppc::ppc-subprims-shift
863	:subprims-table ppc::ppc-subprims
864	:primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::ppc-subprims)))
865	:unbound-marker-value unbound-marker
866	:slot-unbound-marker-value slot-unbound-marker
867	:fixnum-tag tag-fixnum
868	:single-float-tag subtag-single-float
869	:single-float-tag-is-subtag nil
870	:double-float-tag subtag-double-float
871	:cons-tag fulltag-cons
872	:null-tag subtag-symbol
873	:symbol-tag subtag-symbol
874	:symbol-tag-is-subtag t
875	:function-tag subtag-function
876	:function-tag-is-subtag t
877	:big-endian t
878	:misc-subtag-offset misc-subtag-offset
879	:car-offset cons.car
880	:cdr-offset cons.cdr
881	:subtag-char subtag-character
882	:charcode-shift charcode-shift
883	:fulltagmask fulltagmask
884	:fulltag-misc fulltag-misc
885	:char-code-limit #x110000
886	))
887
888	;;; arch macros
889	(defmacro defppc64archmacro (name lambda-list &body body)
890	`(arch::defarchmacro :ppc64 ,name ,lambda-list ,@body))
891
892	(defppc64archmacro ccl::%make-sfloat ()
893	(error "~s shouldn't be used in code targeting :PPC64" 'ccl::%make-sfloat))
894
895	(defppc64archmacro ccl::%make-dfloat ()
896	`(ccl::%alloc-misc ppc64::double-float.element-count ppc64::subtag-double-float))
897
898	(defppc64archmacro ccl::%numerator (x)
899	`(ccl::%svref ,x ppc64::ratio.numer-cell))
900
901	(defppc64archmacro ccl::%denominator (x)
902	`(ccl::%svref ,x ppc64::ratio.denom-cell))
903
904	(defppc64archmacro ccl::%realpart (x)
905	`(ccl::%svref ,x ppc64::complex.realpart-cell))
906
907	(defppc64archmacro ccl::%imagpart (x)
908	`(ccl::%svref ,x ppc64::complex.imagpart-cell))
909
910	;;;
911	(defppc64archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
912	`(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)))
913
914	(defppc64archmacro ccl::codevec-header-p (word)
915	`(eql ,word #$"CODE"))
916
917	;;;
918
919	(defppc64archmacro ccl::immediate-p-macro (thing)
920	(let* ((tag (gensym)))
921	`(let* ((,tag (ccl::lisptag ,thing)))
922	(declare (fixnum ,tag))
923	(or (= ,tag ppc64::tag-fixnum)
924	(= (logand ,tag ppc64::lowtagmask) ppc64::lowtag-imm)))))
925
926	(defppc64archmacro ccl::hashed-by-identity (thing)
927	(let* ((typecode (gensym)))
928	`(let* ((,typecode (ccl::typecode ,thing)))
929	(declare (fixnum ,typecode))
930	(or
931	(= ,typecode ppc64::tag-fixnum)
932	(= (logand ,typecode ppc64::lowtagmask) ppc64::lowtag-imm)
933	(= ,typecode ppc64::subtag-symbol)
934	(= ,typecode ppc64::subtag-instance)))))
935
936	;;;
937	(defppc64archmacro ccl::%get-kernel-global (name)
938	`(ccl::%fixnum-ref 0 (+ ppc64::nil-value
939	,(%kernel-global
940	(if (ccl::quoted-form-p name)
941	(cadr name)
942	name)))))
943
944	(defppc64archmacro ccl::%get-kernel-global-ptr (name dest)
945	`(ccl::%setf-macptr
946	,dest
947	(ccl::%fixnum-ref-macptr 0 (+ ppc64::nil-value
948	,(%kernel-global
949	(if (ccl::quoted-form-p name)
950	(cadr name)
951	name))))))
952
953	(defppc64archmacro ccl::%target-kernel-global (name)
954	`(ppc64::%kernel-global ,name))
955
956	(defppc64archmacro ccl::lfun-vector (fn)
957	fn)
958
959	(defppc64archmacro ccl::lfun-vector-lfun (lfv)
960	lfv)
961
962	(defppc64archmacro ccl::area-code ()
963	area.code)
964
965	(defppc64archmacro ccl::area-succ ()
966	area.succ)
967
968
969	(defppc64archmacro ccl::nth-immediate (f i)
970	`(ccl::%svref ,f ,i))
971
972	(defppc64archmacro ccl::set-nth-immediate (f i new)
973	`(setf (ccl::%svref ,f ,i) ,new))
974
975
976	(defppc64archmacro ccl::symptr->symvector (s)
977	s)
978
979	(defppc64archmacro ccl::symvector->symptr (s)
980	s)
981
982	(defppc64archmacro ccl::function-to-function-vector (f)
983	f)
984
985	(defppc64archmacro ccl::function-vector-to-function (v)
986	v)
987
988	(defppc64archmacro ccl::with-ffcall-results ((buf) &body body)
989	(let* ((size (+ (* 8 8) (* 13 8))))
990	`(ccl::%stack-block ((,buf ,size))
991	,@body)))
992
993
994
995	(provide "PPC64-ARCH")

Note: See TracBrowser for help on using the repository browser.

Download in other formats: