source: trunk/source/compiler/PPC/PPC64/ppc64-arch.lisp @ 15093

Last change on this file since 15093 was 15093, checked in by gb, 8 years ago

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

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