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

Last change on this file since 15191 was 15191, checked in by gb, 7 years ago

Use a cast in the code that sets up errno_loc in the TCR.
Revive jvm_init(), since Apple's JVM still/again clobbers Mach exception
ports.

Add kernel-import info for jvm-init for all architectures. (The kernel
import table isn't architecture-specific, though some entries effectively
are.)

Tweak jni.lisp a bit; still needs lots of work.

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