source: branches/working-0710/ccl/compiler/PPC/PPC64/ppc64-arch.lisp @ 7386

Last change on this file since 7386 was 7386, checked in by gb, 13 years ago

Storage layout for new rwlock.

  • 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  )
398
399
400
401(define-fixedsized-object symbol
402  pname
403  vcell
404  fcell
405  package-predicate
406  flags
407  plist
408  binding-index
409)
410
411
412(defconstant t-offset (- symbol.size))
413
414
415
416
417(define-fixedsized-object vectorH
418  logsize                               ; fillpointer if it has one, physsize otherwise
419  physsize                              ; total size of (possibly displaced) data vector
420  data-vector                           ; object this header describes
421  displacement                          ; true displacement or 0
422  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
423)
424
425(define-lisp-object arrayH fulltag-misc
426  header                                ; subtag = subtag-arrayH
427  rank                                  ; NEVER 1
428  physsize                              ; total size of (possibly displaced) data vector
429  data-vector                           ; object this header describes
430  displacement                          ; true displacement or 0 
431  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
432 ;; Dimensions follow
433)
434
435(defconstant arrayH.rank-cell 0)
436(defconstant arrayH.physsize-cell 1)
437(defconstant arrayH.data-vector-cell 2)
438(defconstant arrayH.displacement-cell 3)
439(defconstant arrayH.flags-cell 4)
440(defconstant arrayH.dim0-cell 5)
441
442(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
443(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
444
445
446(define-fixedsized-object value-cell
447  value)
448
449
450;;; The kernel uses these (rather generically named) structures
451;;; to keep track of various memory regions it (or the lisp) is
452;;; interested in.
453
454
455(define-storage-layout area 0
456  pred                                  ; pointer to preceding area in DLL
457  succ                                  ; pointer to next area in DLL
458  low                                   ; low bound on area addresses
459  high                                  ; high bound on area addresses.
460  active                                ; low limit on stacks, high limit on heaps
461  softlimit                             ; overflow bound
462  hardlimit                             ; another one
463  code                                  ; an area-code; see below
464  markbits                              ; bit vector for GC
465  ndnodes                               ; "active" size of dynamic area or stack
466  older                                 ; in EGC sense
467  younger                               ; also for EGC
468  h                                     ; Handle or null pointer
469  softprot                              ; protected_area structure pointer
470  hardprot                              ; another one.
471  owner                                 ; fragment (library) which "owns" the area
472  refbits                               ; bitvector for intergenerational refernces
473  threshold                             ; for egc
474  gc-count                              ; generational gc count.
475  static-dnodes                         ; for honsing. etc
476  static-used                           ; bitvector
477)
478
479
480
481
482
483(define-storage-layout protected-area 0
484  next
485  start                                 ; first byte (page-aligned) that might be protected
486  end                                   ; last byte (page-aligned) that could be protected
487  nprot                                 ; Might be 0
488  protsize                              ; number of bytes to protect
489  why)
490
491(defconstant tcr-bias 0)
492
493(define-storage-layout tcr (- tcr-bias)
494  prev                                  ; in doubly-linked list
495  next                                  ; in doubly-linked list
496  single-float-convert                  ; per-thread scratch space.
497  lisp-fpscr-high
498  db-link                               ; special binding chain head
499  catch-top                             ; top catch frame
500  save-vsp                              ; VSP when in foreign code
501  save-tsp                              ; TSP when in foreign code
502  cs-area                               ; cstack area pointer
503  vs-area                               ; vstack area pointer
504  ts-area                               ; tstack area pointer
505  cs-limit                              ; cstack overflow limit
506  total-bytes-allocated-high
507  log2-allocation-quantum               ; unboxed
508  interrupt-pending                     ; fixnum
509  xframe                                ; exception frame linked list
510  errno-loc                             ; thread-private, maybe
511  ffi-exception                         ; fpscr bits from ff-call.
512  osid                                  ; OS thread id
513  valence                               ; odd when in foreign code
514  foreign-exception-status
515  native-thread-info
516  native-thread-id
517  last-allocptr
518  save-allocptr
519  save-allocbase
520  reset-completion
521  activate
522  suspend-count
523  suspend-context
524  pending-exception-context
525  suspend                               ; semaphore for suspension notify
526  resume                                ; sempahore for resumption notify
527  flags                                 ; foreign, being reset, ...
528  gc-context
529  termination-semaphore
530  unwinding
531  tlb-limit
532  tlb-pointer
533  shutdown-count
534  safe-ref-address
535)
536
537(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
538
539(defconstant tcr.lisp-fpscr-low (+ tcr.lisp-fpscr-high 4))
540(defconstant tcr.total-bytes-allocated-low (+ tcr.total-bytes-allocated-high 4))
541
542(define-storage-layout lockptr 0
543  avail
544  owner
545  count
546  signal
547  waiting
548  malloced-ptr
549  spinlock)
550
551(define-storage-layout rwlock 0
552  spin
553  state
554  blocked-writers
555  blocked-readers
556  writer
557  reader-signal
558  writer-signal
559  malloced-ptr
560  )
561
562;;; For the eabi port: mark this stack frame as Lisp's (since EABI
563;;; foreign frames can be the same size as a lisp frame.)
564
565
566(ppc64::define-storage-layout lisp-frame 0
567  backlink
568  savefn
569  savelr
570  savevsp
571)
572
573(ppc64::define-storage-layout c-frame 0
574  backlink
575  crsave
576  savelr
577  unused-1
578  unused-2
579  savetoc
580  param0
581  param1
582  param2
583  param3
584  param4
585  param5
586  param6
587  param7
588)
589
590(defconstant c-frame.minsize c-frame.size)
591
592(defmacro define-header (name element-count subtag)
593  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
594
595(define-header double-float-header double-float.element-count subtag-double-float)
596;;; We could possibly have a one-digit bignum header when dealing
597;;; with "small bignums" in some bignum code.  Like other cases of
598;;; non-normalized bignums, they should never escape from the lab.
599(define-header one-digit-bignum-header 1 subtag-bignum)
600(define-header two-digit-bignum-header 2 subtag-bignum)
601(define-header three-digit-bignum-header 3 subtag-bignum)
602(define-header four-digit-bignum-header 4 subtag-bignum)
603(define-header five-digit-bignum-header 5 subtag-bignum)
604(define-header symbol-header symbol.element-count subtag-symbol)
605(define-header value-cell-header value-cell.element-count subtag-value-cell)
606(define-header macptr-header macptr.element-count subtag-macptr)
607
608
609(defconstant yield-syscall
610  #+darwinppc-target -60
611  #+linuxppc-target #$__NR_sched_yield)
612)
613)
614
615
616
617
618
619
620(defun %kernel-global (sym)
621  (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
622    (if pos
623      (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
624      (error "Unknown kernel global : ~s ." sym))))
625
626(defmacro kernel-global (sym)
627  (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
628    (if pos
629      (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
630      (error "Unknown kernel global : ~s ." sym))))
631
632;;; The kernel imports things that are defined in various other
633;;; libraries for us.  The objects in question are generally
634;;; fixnum-tagged; the entries in the "kernel-imports" vector are 8
635;;; bytes apart.
636(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step word-size-in-bytes)
637  fd-setsize-bytes
638  do-fd-set
639  do-fd-clr
640  do-fd-is-set
641  do-fd-zero
642  MakeDataExecutable
643  GetSharedLibrary
644  FindSymbol
645  malloc
646  free
647  allocate_tstack
648  allocate_vstack
649  register_cstack
650  raise-thread-interrupt
651  get-r-debug
652  restore-soft-stack-limit
653  egc-control
654  lisp-bug
655  NewThread
656  YieldToThread
657  DisposeThread
658  ThreadCurrentStackSpace
659  usage-exit
660  save-fp-context
661  restore-fp-context
662  put-altivec-registers
663  get-altivec-registers
664  new-semaphore
665  wait-on-semaphore
666  signal-semaphore
667  destroy-semaphore
668  new-recursive-lock
669  lock-recursive-lock
670  unlock-recursive-lock
671  destroy-recursive-lock
672  suspend-other-threads
673  resume-other-threads
674  suspend-tcr
675  resume-tcr
676  rwlock-new
677  rwlock-destroy
678  rwlock-rlock
679  rwlock-wlock
680  rwlock-unlock
681  recursive-lock-trylock
682  foreign-name-and-offset
683)
684
685(defmacro nrs-offset (name)
686  (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq)))
687    (if pos (* (1- pos) symbol.size))))
688
689(defconstant nil-value (+ #x3000 symbol.size fulltag-misc))
690
691
692(defconstant reservation-discharge #x2008)
693
694(defparameter *ppc64-target-uvector-subtags*
695  `((:bignum . ,subtag-bignum)
696    (:ratio . ,subtag-ratio)
697    (:single-float . ,subtag-single-float)
698    (:double-float . ,subtag-double-float)
699    (:complex . ,subtag-complex  )
700    (:symbol . ,subtag-symbol)
701    (:function . ,subtag-function )
702    (:code-vector . ,subtag-code-vector)
703    (:xcode-vector . ,subtag-xcode-vector)
704    (:macptr . ,subtag-macptr )
705    (:catch-frame . ,subtag-catch-frame)
706    (:struct . ,subtag-struct )   
707    (:istruct . ,subtag-istruct )
708    (:pool . ,subtag-pool )
709    (:population . ,subtag-weak )
710    (:hash-vector . ,subtag-hash-vector )
711    (:package . ,subtag-package )
712    (:value-cell . ,subtag-value-cell)
713    (:instance . ,subtag-instance )
714    (:lock . ,subtag-lock )
715    (:basic-stream . ,subtag-basic-stream)
716    (:slot-vector . ,subtag-slot-vector)
717    (:simple-string . ,subtag-simple-base-string )
718    (:bit-vector . ,subtag-bit-vector )
719    (:signed-8-bit-vector . ,subtag-s8-vector )
720    (:unsigned-8-bit-vector . ,subtag-u8-vector )
721    (:signed-16-bit-vector . ,subtag-s16-vector )
722    (:unsigned-16-bit-vector . ,subtag-u16-vector )
723    (:signed-32-bit-vector . ,subtag-s32-vector )
724    (:unsigned-32-bit-vector . ,subtag-u32-vector )
725    (:fixnum-vector . ,subtag-fixnum-vector)
726    (:signed-64-bit-vector . ,subtag-s64-vector)
727    (:unsigned-64-bit-vector . ,subtag-u64-vector)   
728    (:single-float-vector . ,subtag-single-float-vector)
729    (:double-float-vector . ,subtag-double-float-vector )
730    (:simple-vector . ,subtag-simple-vector )
731    (:vector-header . ,subtag-vectorH)
732    (:array-header . ,subtag-arrayH)))
733
734;;; This should return NIL unless it's sure of how the indicated
735;;; type would be represented (in particular, it should return
736;;; NIL if the element type is unknown or unspecified at compile-time.
737(defun ppc64-array-type-name-from-ctype (ctype)
738  (when (typep ctype 'ccl::array-ctype)
739    (let* ((element-type (ccl::array-ctype-element-type ctype)))
740      (typecase element-type
741        (ccl::class-ctype
742         (let* ((class (ccl::class-ctype-class element-type)))
743           (if (or (eq class ccl::*character-class*)
744                   (eq class ccl::*base-char-class*)
745                   (eq class ccl::*standard-char-class*))
746             :simple-string
747             :simple-vector)))
748        (ccl::numeric-ctype
749         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
750           :simple-vector
751           (case (ccl::numeric-ctype-class element-type)
752             (integer
753              (let* ((low (ccl::numeric-ctype-low element-type))
754                     (high (ccl::numeric-ctype-high element-type)))
755                (cond ((or (null low) (null high))
756                       :simple-vector)
757                      ((and (>= low 0) (<= high 1))
758                       :bit-vector)
759                      ((and (>= low 0) (<= high 255))
760                       :unsigned-8-bit-vector)
761                      ((and (>= low 0) (<= high 65535))
762                       :unsigned-16-bit-vector)
763                      ((and (>= low 0) (<= high #xffffffff))
764                       :unsigned-32-bit-vector)
765                      ((and (>= low 0) (<= high #xffffffffffffffff))
766                       :unsigned-64-bit-vector)
767                      ((and (>= low -128) (<= high 127))
768                       :signed-8-bit-vector)
769                      ((and (>= low -32768) (<= high 32767))
770                       :signed-16-bit-vector)
771                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
772                       :signed-32-bit-vector)
773                      ((and (>= low target-most-negative-fixnum)
774                            (<= high target-most-positive-fixnum))
775                       :fixnum-vector)
776                      ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
777                       :signed-64-bit-vector)
778                      (t :simple-vector))))
779             (float
780              (case (ccl::numeric-ctype-format element-type)
781                ((double-float long-float) :double-float-vector)
782                ((single-float short-float) :single-float-vector)
783                (t :simple-vector)))
784             (t :simple-vector))))
785        (ccl::unknown-ctype)
786        (ccl::named-ctype
787         (if (eq element-type ccl::*universal-type*)
788           :simple-vector))
789        (t)))))
790
791(defun ppc64-misc-byte-count (subtag element-count)
792  (declare (fixnum subtag))
793  (if (= lowtag-nodeheader (logand subtag lowtagmask))
794    (ash element-count 3)
795    (case (logand subtag fulltagmask)
796      (#.ivector-class-64-bit (ash element-count 3))
797      (#.ivector-class-32-bit (ash element-count 2))
798      (#.ivector-class-8-bit element-count)
799      (t
800       (if (= subtag subtag-bit-vector)
801         (ash (+ 7 element-count) -3)
802         (ash element-count 1))))))
803
804(defparameter *ppc64-target-arch*
805  (arch::make-target-arch :name :ppc64
806                          :lisp-node-size 8
807                          :nil-value nil-value
808                          :fixnum-shift fixnumshift
809                          :most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift))))
810                          :most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift))))
811                          :misc-data-offset misc-data-offset
812                          :misc-dfloat-offset misc-dfloat-offset
813                          :nbits-in-word 64
814                          :ntagbits 4
815                          :nlisptagbits 3
816                          :uvector-subtags *ppc64-target-uvector-subtags*
817                          :max-64-bit-constant-index max-64-bit-constant-index
818                          :max-32-bit-constant-index max-32-bit-constant-index
819                          :max-16-bit-constant-index max-16-bit-constant-index
820                          :max-8-bit-constant-index max-8-bit-constant-index
821                          :max-1-bit-constant-index max-1-bit-constant-index
822                          :word-shift 3
823                          :code-vector-prefix '(#$"CODE")
824                          :gvector-types '(:ratio :complex :symbol :function
825                                           :catch-frame :struct :istruct
826                                           :pool :population :hash-vector
827                                           :package :value-cell :instance
828                                           :lock :slot-vector
829                                           :simple-vector)
830                          :1-bit-ivector-types '(:bit-vector)
831                          :8-bit-ivector-types '(:signed-8-bit-vector
832                                                 :unsigned-8-bit-vector)
833                          :16-bit-ivector-types '(:signed-16-bit-vector
834                                                  :unsigned-16-bit-vector)
835                          :32-bit-ivector-types '(:signed-32-bit-vector
836                                                  :unsigned-32-bit-vector
837                                                  :single-float-vector
838                                                  :double-float
839                                                  :bignum
840                                                  :simple-string)
841                          :64-bit-ivector-types '(:double-float-vector
842                                                  :unsigned-64-bit-vector
843                                                  :signed-64-bit-vector
844                                                  :fixnum-vector)
845                          :array-type-name-from-ctype-function
846                          #'ppc64-array-type-name-from-ctype
847                          :package-name "PPC64"
848                          :t-offset t-offset
849                          :array-data-size-function #'ppc64-misc-byte-count
850                          :numeric-type-name-to-typecode-function
851                          #'(lambda (type-name)
852                              (ecase type-name
853                                (fixnum tag-fixnum)
854                                (bignum subtag-bignum)
855                                ((short-float single-float) subtag-single-float)
856                                ((long-float double-float) subtag-double-float)
857                                (ratio subtag-ratio)
858                                (complex subtag-complex)))
859                                                    :subprims-base ppc::*ppc-subprims-base*
860                          :subprims-shift ppc::*ppc-subprims-shift*
861                          :subprims-table ppc::*ppc-subprims*
862                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-subprims*)))
863                          :unbound-marker-value unbound-marker
864                          :slot-unbound-marker-value slot-unbound-marker
865                          :fixnum-tag tag-fixnum
866                          :single-float-tag subtag-single-float
867                          :single-float-tag-is-subtag nil
868                          :double-float-tag subtag-double-float
869                          :cons-tag fulltag-cons
870                          :null-tag subtag-symbol
871                          :symbol-tag subtag-symbol
872                          :symbol-tag-is-subtag t
873                          :function-tag subtag-function
874                          :function-tag-is-subtag t
875                          :big-endian t
876                          :misc-subtag-offset misc-subtag-offset
877                          :car-offset cons.car
878                          :cdr-offset cons.cdr
879                          :subtag-char subtag-character
880                          :charcode-shift charcode-shift
881                          :fulltagmask fulltagmask
882                          :fulltag-misc fulltag-misc
883                          :char-code-limit #x110000
884                          ))
885
886;;; arch macros
887(defmacro defppc64archmacro (name lambda-list &body body)
888  `(arch::defarchmacro :ppc64 ,name ,lambda-list ,@body))
889
890(defppc64archmacro ccl::%make-sfloat ()
891  (error "~s shouldn't be used in code targeting :PPC64" 'ccl::%make-sfloat))
892
893(defppc64archmacro ccl::%make-dfloat ()
894  `(ccl::%alloc-misc ppc64::double-float.element-count ppc64::subtag-double-float))
895
896(defppc64archmacro ccl::%numerator (x)
897  `(ccl::%svref ,x ppc64::ratio.numer-cell))
898
899(defppc64archmacro ccl::%denominator (x)
900  `(ccl::%svref ,x ppc64::ratio.denom-cell))
901
902(defppc64archmacro ccl::%realpart (x)
903  `(ccl::%svref ,x ppc64::complex.realpart-cell))
904                   
905(defppc64archmacro ccl::%imagpart (x)
906  `(ccl::%svref ,x ppc64::complex.imagpart-cell))
907
908;;;
909(defppc64archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
910 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)))
911
912(defppc64archmacro ccl::codevec-header-p (word)
913  `(eql ,word #$"CODE"))
914
915;;;
916
917(defppc64archmacro ccl::immediate-p-macro (thing)
918  (let* ((tag (gensym)))
919    `(let* ((,tag (ccl::lisptag ,thing)))
920      (declare (fixnum ,tag))
921      (or (= ,tag ppc64::tag-fixnum)
922       (= (logand ,tag ppc64::lowtagmask) ppc64::lowtag-imm)))))
923
924(defppc64archmacro ccl::hashed-by-identity (thing)
925  (let* ((typecode (gensym)))
926    `(let* ((,typecode (ccl::typecode ,thing)))
927      (declare (fixnum ,typecode))
928      (or
929       (= ,typecode ppc64::tag-fixnum)
930       (= (logand ,typecode ppc64::lowtagmask) ppc64::lowtag-imm)
931       (= ,typecode ppc64::subtag-symbol)
932       (= ,typecode ppc64::subtag-instance)))))
933
934;;;
935(defppc64archmacro ccl::%get-kernel-global (name)
936  `(ccl::%fixnum-ref 0 (+ ppc64::nil-value
937                                 ,(%kernel-global
938                                   (if (ccl::quoted-form-p name)
939                                     (cadr name)
940                                     name)))))
941
942(defppc64archmacro ccl::%get-kernel-global-ptr (name dest)
943  `(ccl::%setf-macptr
944    ,dest
945    (ccl::%fixnum-ref-macptr 0 (+ ppc64::nil-value
946                                 ,(%kernel-global
947                                   (if (ccl::quoted-form-p name)
948                                     (cadr name)
949                                     name))))))
950
951(defppc64archmacro ccl::%target-kernel-global (name)
952  `(ppc64::%kernel-global ,name))
953
954(defppc64archmacro ccl::lfun-vector (fn)
955  fn)
956
957(defppc64archmacro ccl::lfun-vector-lfun (lfv)
958  lfv)
959
960(defppc64archmacro ccl::area-code ()
961  area.code)
962
963(defppc64archmacro ccl::area-succ ()
964  area.succ)
965
966
967(defppc64archmacro ccl::nth-immediate (f i)
968  `(ccl::%svref ,f ,i))
969
970(defppc64archmacro ccl::set-nth-immediate (f i new)
971  `(setf (ccl::%svref ,f ,i) ,new))
972
973
974(defppc64archmacro ccl::symptr->symvector (s)
975  s)
976
977(defppc64archmacro ccl::symvector->symptr (s)
978  s)
979
980(defppc64archmacro ccl::function-to-function-vector (f)
981  f)
982
983(defppc64archmacro ccl::function-vector-to-function (v)
984  v)
985
986(defppc64archmacro ccl::with-ffcall-results ((buf) &body body)
987  (let* ((size (+ (* 8 8) (* 13 8))))
988    `(ccl::%stack-block ((,buf ,size))
989      ,@body)))
990
991
992                             
993(provide "PPC64-ARCH")
Note: See TracBrowser for help on using the repository browser.