source: branches/x8664-call/ccl/compiler/PPC/PPC64/ppc64-arch.lisp @ 6450

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

%GET-KERNEL-GLOBAL-PTR: actually works ...

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 36.5 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;;; For the eabi port: mark this stack frame as Lisp's (since EABI
552;;; foreign frames can be the same size as a lisp frame.)
553
554
555(ppc64::define-storage-layout lisp-frame 0
556  backlink
557  savefn
558  savelr
559  savevsp
560)
561
562(ppc64::define-storage-layout c-frame 0
563  backlink
564  crsave
565  savelr
566  unused-1
567  unused-2
568  savetoc
569  param0
570  param1
571  param2
572  param3
573  param4
574  param5
575  param6
576  param7
577)
578
579(defconstant c-frame.minsize c-frame.size)
580
581(defmacro define-header (name element-count subtag)
582  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
583
584(define-header double-float-header double-float.element-count subtag-double-float)
585;;; We could possibly have a one-digit bignum header when dealing
586;;; with "small bignums" in some bignum code.  Like other cases of
587;;; non-normalized bignums, they should never escape from the lab.
588(define-header one-digit-bignum-header 1 subtag-bignum)
589(define-header two-digit-bignum-header 2 subtag-bignum)
590(define-header three-digit-bignum-header 3 subtag-bignum)
591(define-header four-digit-bignum-header 4 subtag-bignum)
592(define-header five-digit-bignum-header 5 subtag-bignum)
593(define-header symbol-header symbol.element-count subtag-symbol)
594(define-header value-cell-header value-cell.element-count subtag-value-cell)
595(define-header macptr-header macptr.element-count subtag-macptr)
596
597
598(defconstant yield-syscall
599  #+darwinppc-target -60
600  #+linuxppc-target #$__NR_sched_yield)
601)
602)
603
604
605
606
607
608
609(defun %kernel-global (sym)
610  (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
611    (if pos
612      (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
613      (error "Unknown kernel global : ~s ." sym))))
614
615(defmacro kernel-global (sym)
616  (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
617    (if pos
618      (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
619      (error "Unknown kernel global : ~s ." sym))))
620
621;;; The kernel imports things that are defined in various other
622;;; libraries for us.  The objects in question are generally
623;;; fixnum-tagged; the entries in the "kernel-imports" vector are 8
624;;; bytes apart.
625(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step word-size-in-bytes)
626  fd-setsize-bytes
627  do-fd-set
628  do-fd-clr
629  do-fd-is-set
630  do-fd-zero
631  MakeDataExecutable
632  GetSharedLibrary
633  FindSymbol
634  malloc
635  free
636  allocate_tstack
637  allocate_vstack
638  register_cstack
639  raise-thread-interrupt
640  get-r-debug
641  restore-soft-stack-limit
642  egc-control
643  lisp-bug
644  NewThread
645  YieldToThread
646  DisposeThread
647  ThreadCurrentStackSpace
648  usage-exit
649  save-fp-context
650  restore-fp-context
651  put-altivec-registers
652  get-altivec-registers
653  new-semaphore
654  wait-on-semaphore
655  signal-semaphore
656  destroy-semaphore
657  new-recursive-lock
658  lock-recursive-lock
659  unlock-recursive-lock
660  destroy-recursive-lock
661  suspend-other-threads
662  resume-other-threads
663  suspend-tcr
664  resume-tcr
665  rwlock-new
666  rwlock-destroy
667  rwlock-rlock
668  rwlock-wlock
669  rwlock-unlock
670  recursive-lock-trylock
671  foreign-name-and-offset
672)
673
674(defmacro nrs-offset (name)
675  (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq)))
676    (if pos (* (1- pos) symbol.size))))
677
678(defconstant nil-value (+ #x3000 symbol.size fulltag-misc))
679
680
681(defconstant reservation-discharge #x2008)
682
683(defparameter *ppc64-target-uvector-subtags*
684  `((:bignum . ,subtag-bignum)
685    (:ratio . ,subtag-ratio)
686    (:single-float . ,subtag-single-float)
687    (:double-float . ,subtag-double-float)
688    (:complex . ,subtag-complex  )
689    (:symbol . ,subtag-symbol)
690    (:function . ,subtag-function )
691    (:code-vector . ,subtag-code-vector)
692    (:xcode-vector . ,subtag-xcode-vector)
693    (:macptr . ,subtag-macptr )
694    (:catch-frame . ,subtag-catch-frame)
695    (:struct . ,subtag-struct )   
696    (:istruct . ,subtag-istruct )
697    (:pool . ,subtag-pool )
698    (:population . ,subtag-weak )
699    (:hash-vector . ,subtag-hash-vector )
700    (:package . ,subtag-package )
701    (:value-cell . ,subtag-value-cell)
702    (:instance . ,subtag-instance )
703    (:lock . ,subtag-lock )
704    (:basic-stream . ,subtag-basic-stream)
705    (:slot-vector . ,subtag-slot-vector)
706    (:simple-string . ,subtag-simple-base-string )
707    (:bit-vector . ,subtag-bit-vector )
708    (:signed-8-bit-vector . ,subtag-s8-vector )
709    (:unsigned-8-bit-vector . ,subtag-u8-vector )
710    (:signed-16-bit-vector . ,subtag-s16-vector )
711    (:unsigned-16-bit-vector . ,subtag-u16-vector )
712    (:signed-32-bit-vector . ,subtag-s32-vector )
713    (:unsigned-32-bit-vector . ,subtag-u32-vector )
714    (:fixnum-vector . ,subtag-fixnum-vector)
715    (:signed-64-bit-vector . ,subtag-s64-vector)
716    (:unsigned-64-bit-vector . ,subtag-u64-vector)   
717    (:single-float-vector . ,subtag-single-float-vector)
718    (:double-float-vector . ,subtag-double-float-vector )
719    (:simple-vector . ,subtag-simple-vector )
720    (:vector-header . ,subtag-vectorH)
721    (:array-header . ,subtag-arrayH)))
722
723;;; This should return NIL unless it's sure of how the indicated
724;;; type would be represented (in particular, it should return
725;;; NIL if the element type is unknown or unspecified at compile-time.
726(defun ppc64-array-type-name-from-ctype (ctype)
727  (when (typep ctype 'ccl::array-ctype)
728    (let* ((element-type (ccl::array-ctype-element-type ctype)))
729      (typecase element-type
730        (ccl::class-ctype
731         (let* ((class (ccl::class-ctype-class element-type)))
732           (if (or (eq class ccl::*character-class*)
733                   (eq class ccl::*base-char-class*)
734                   (eq class ccl::*standard-char-class*))
735             :simple-string
736             :simple-vector)))
737        (ccl::numeric-ctype
738         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
739           :simple-vector
740           (case (ccl::numeric-ctype-class element-type)
741             (integer
742              (let* ((low (ccl::numeric-ctype-low element-type))
743                     (high (ccl::numeric-ctype-high element-type)))
744                (cond ((or (null low) (null high))
745                       :simple-vector)
746                      ((and (>= low 0) (<= high 1))
747                       :bit-vector)
748                      ((and (>= low 0) (<= high 255))
749                       :unsigned-8-bit-vector)
750                      ((and (>= low 0) (<= high 65535))
751                       :unsigned-16-bit-vector)
752                      ((and (>= low 0) (<= high #xffffffff))
753                       :unsigned-32-bit-vector)
754                      ((and (>= low 0) (<= high #xffffffffffffffff))
755                       :unsigned-64-bit-vector)
756                      ((and (>= low -128) (<= high 127))
757                       :signed-8-bit-vector)
758                      ((and (>= low -32768) (<= high 32767))
759                       :signed-16-bit-vector)
760                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
761                       :signed-32-bit-vector)
762                      ((and (>= low target-most-negative-fixnum)
763                            (<= high target-most-positive-fixnum))
764                       :fixnum-vector)
765                      ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
766                       :signed-64-bit-vector)
767                      (t :simple-vector))))
768             (float
769              (case (ccl::numeric-ctype-format element-type)
770                ((double-float long-float) :double-float-vector)
771                ((single-float short-float) :single-float-vector)
772                (t :simple-vector)))
773             (t :simple-vector))))
774        (ccl::unknown-ctype)
775        (ccl::named-ctype
776         (if (eq element-type ccl::*universal-type*)
777           :simple-vector))
778        (t)))))
779
780(defun ppc64-misc-byte-count (subtag element-count)
781  (declare (fixnum subtag))
782  (if (= lowtag-nodeheader (logand subtag lowtagmask))
783    (ash element-count 3)
784    (case (logand subtag fulltagmask)
785      (#.ivector-class-64-bit (ash element-count 3))
786      (#.ivector-class-32-bit (ash element-count 2))
787      (#.ivector-class-8-bit element-count)
788      (t
789       (if (= subtag subtag-bit-vector)
790         (ash (+ 7 element-count) -3)
791         (ash element-count 1))))))
792
793(defparameter *ppc64-target-arch*
794  (arch::make-target-arch :name :ppc64
795                          :lisp-node-size 8
796                          :nil-value nil-value
797                          :fixnum-shift fixnumshift
798                          :most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift))))
799                          :most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift))))
800                          :misc-data-offset misc-data-offset
801                          :misc-dfloat-offset misc-dfloat-offset
802                          :nbits-in-word 64
803                          :ntagbits 4
804                          :nlisptagbits 3
805                          :uvector-subtags *ppc64-target-uvector-subtags*
806                          :max-64-bit-constant-index max-64-bit-constant-index
807                          :max-32-bit-constant-index max-32-bit-constant-index
808                          :max-16-bit-constant-index max-16-bit-constant-index
809                          :max-8-bit-constant-index max-8-bit-constant-index
810                          :max-1-bit-constant-index max-1-bit-constant-index
811                          :word-shift 3
812                          :code-vector-prefix '(#$"CODE")
813                          :gvector-types '(:ratio :complex :symbol :function
814                                           :catch-frame :struct :istruct
815                                           :pool :population :hash-vector
816                                           :package :value-cell :instance
817                                           :lock :slot-vector
818                                           :simple-vector)
819                          :1-bit-ivector-types '(:bit-vector)
820                          :8-bit-ivector-types '(:signed-8-bit-vector
821                                                 :unsigned-8-bit-vector)
822                          :16-bit-ivector-types '(:signed-16-bit-vector
823                                                  :unsigned-16-bit-vector)
824                          :32-bit-ivector-types '(:signed-32-bit-vector
825                                                  :unsigned-32-bit-vector
826                                                  :single-float-vector
827                                                  :double-float
828                                                  :bignum
829                                                  :simple-string)
830                          :64-bit-ivector-types '(:double-float-vector
831                                                  :unsigned-64-bit-vector
832                                                  :signed-64-bit-vector
833                                                  :fixnum-vector)
834                          :array-type-name-from-ctype-function
835                          #'ppc64-array-type-name-from-ctype
836                          :package-name "PPC64"
837                          :t-offset t-offset
838                          :array-data-size-function #'ppc64-misc-byte-count
839                          :numeric-type-name-to-typecode-function
840                          #'(lambda (type-name)
841                              (ecase type-name
842                                (fixnum tag-fixnum)
843                                (bignum subtag-bignum)
844                                ((short-float single-float) subtag-single-float)
845                                ((long-float double-float) subtag-double-float)
846                                (ratio subtag-ratio)
847                                (complex subtag-complex)))
848                                                    :subprims-base ppc::*ppc-subprims-base*
849                          :subprims-shift ppc::*ppc-subprims-shift*
850                          :subprims-table ppc::*ppc-subprims*
851                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-subprims*)))
852                          :unbound-marker-value unbound-marker
853                          :slot-unbound-marker-value slot-unbound-marker
854                          :fixnum-tag tag-fixnum
855                          :single-float-tag subtag-single-float
856                          :single-float-tag-is-subtag nil
857                          :double-float-tag subtag-double-float
858                          :cons-tag fulltag-cons
859                          :null-tag subtag-symbol
860                          :symbol-tag subtag-symbol
861                          :symbol-tag-is-subtag t
862                          :function-tag subtag-function
863                          :function-tag-is-subtag t
864                          :big-endian t
865                          :misc-subtag-offset misc-subtag-offset
866                          :car-offset cons.car
867                          :cdr-offset cons.cdr
868                          :subtag-char subtag-character
869                          :charcode-shift charcode-shift
870                          :fulltagmask fulltagmask
871                          :fulltag-misc fulltag-misc
872                          :char-code-limit #x110000
873                          ))
874
875;;; arch macros
876(defmacro defppc64archmacro (name lambda-list &body body)
877  `(arch::defarchmacro :ppc64 ,name ,lambda-list ,@body))
878
879(defppc64archmacro ccl::%make-sfloat ()
880  (error "~s shouldn't be used in code targeting :PPC64" 'ccl::%make-sfloat))
881
882(defppc64archmacro ccl::%make-dfloat ()
883  `(ccl::%alloc-misc ppc64::double-float.element-count ppc64::subtag-double-float))
884
885(defppc64archmacro ccl::%numerator (x)
886  `(ccl::%svref ,x ppc64::ratio.numer-cell))
887
888(defppc64archmacro ccl::%denominator (x)
889  `(ccl::%svref ,x ppc64::ratio.denom-cell))
890
891(defppc64archmacro ccl::%realpart (x)
892  `(ccl::%svref ,x ppc64::complex.realpart-cell))
893                   
894(defppc64archmacro ccl::%imagpart (x)
895  `(ccl::%svref ,x ppc64::complex.imagpart-cell))
896
897;;;
898(defppc64archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
899 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)))
900
901(defppc64archmacro ccl::codevec-header-p (word)
902  `(eql ,word #$"CODE"))
903
904;;;
905
906(defppc64archmacro ccl::immediate-p-macro (thing)
907  (let* ((tag (gensym)))
908    `(let* ((,tag (ccl::lisptag ,thing)))
909      (declare (fixnum ,tag))
910      (or (= ,tag ppc64::tag-fixnum)
911       (= (logand ,tag ppc64::lowtagmask) ppc64::lowtag-imm)))))
912
913(defppc64archmacro ccl::hashed-by-identity (thing)
914  (let* ((typecode (gensym)))
915    `(let* ((,typecode (ccl::typecode ,thing)))
916      (declare (fixnum ,typecode))
917      (or
918       (= ,typecode ppc64::tag-fixnum)
919       (= (logand ,typecode ppc64::lowtagmask) ppc64::lowtag-imm)
920       (= ,typecode ppc64::subtag-symbol)
921       (= ,typecode ppc64::subtag-instance)))))
922
923;;;
924(defppc64archmacro ccl::%get-kernel-global (name)
925  `(ccl::%fixnum-ref 0 (+ ppc64::nil-value
926                                 ,(%kernel-global
927                                   (if (ccl::quoted-form-p name)
928                                     (cadr name)
929                                     name)))))
930
931(defppc64archmacro ccl::%get-kernel-global-ptr (name dest)
932  `(ccl::%setf-macptr
933    ,dest
934    (ccl::%fixnum-ref-macptr 0 (+ ppc64::nil-value
935                                 ,(%kernel-global
936                                   (if (ccl::quoted-form-p name)
937                                     (cadr name)
938                                     name))))))
939
940(defppc64archmacro ccl::%target-kernel-global (name)
941  `(ppc64::%kernel-global ,name))
942
943(defppc64archmacro ccl::lfun-vector (fn)
944  fn)
945
946(defppc64archmacro ccl::lfun-vector-lfun (lfv)
947  lfv)
948
949(defppc64archmacro ccl::area-code ()
950  area.code)
951
952(defppc64archmacro ccl::area-succ ()
953  area.succ)
954
955
956(defppc64archmacro ccl::nth-immediate (f i)
957  `(ccl::%svref ,f ,i))
958
959(defppc64archmacro ccl::set-nth-immediate (f i new)
960  `(setf (ccl::%svref ,f ,i) ,new))
961
962
963(defppc64archmacro ccl::symptr->symvector (s)
964  s)
965
966(defppc64archmacro ccl::symvector->symptr (s)
967  s)
968
969(defppc64archmacro ccl::function-to-function-vector (f)
970  f)
971
972(defppc64archmacro ccl::function-vector-to-function (v)
973  v)
974
975(defppc64archmacro ccl::with-ffcall-results ((buf) &body body)
976  (let* ((size (+ (* 8 8) (* 13 8))))
977    `(ccl::%stack-block ((,buf ,size))
978      ,@body)))
979
980
981                             
982(provide "PPC64-ARCH")
Note: See TracBrowser for help on using the repository browser.