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

Last change on this file since 11676 was 11676, checked in by gb, 11 years ago

Lisp-side of user-defined GCable-pointer dispose-functions support:
arch-specific imports table entries, simple wrapper
REGISTER-XMACPTR-DISPOSE-FUNCTION.

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