source: trunk/source/compiler/PPC/PPC32/ppc32-arch.lisp @ 15093

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

New Linux ARM binaries.

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

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

Most of the changes are ARM-specific.

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

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

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

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

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

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

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

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

Fix ticket:894

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

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

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 33.8 KB
Line 
1;;;-*- Mode: Lisp; Package: (PPC32 :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
19;; This file matches "ccl:pmcl;constants.h" & "ccl:pmcl;constants.s"
20
21(defpackage "PPC32"
22  (:use "CL")
23  #+ppc32-target
24  (:nicknames "TARGET"))
25
26(in-package "PPC32")
27
28(eval-when (:compile-toplevel :load-toplevel :execute)
29  (require "PPC-ARCH")
30
31 
32(defmacro define-storage-layout (name origin &rest cells)
33  `(progn
34     (ccl::defenum (:start ,origin :step 4)
35       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
36     (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells) 4))))
37 
38(defmacro define-lisp-object (name tagname &rest cells)
39  `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
40
41(defmacro define-subtag (name tag subtag)
42  `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,subtag ntagbits))))
43
44
45(defmacro define-imm-subtag (name subtag)
46  `(define-subtag ,name fulltag-immheader ,subtag))
47
48(defmacro define-node-subtag (name subtag)
49  `(define-subtag ,name fulltag-nodeheader ,subtag))
50
51(defmacro define-fixedsized-object (name &rest non-header-cells)
52  `(progn
53     (define-lisp-object ,name fulltag-misc header ,@non-header-cells)
54     (ccl::defenum ()
55       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
56     (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
57
58 
59)
60
61(eval-when (:compile-toplevel :load-toplevel :execute)
62(defconstant rcontext 13) 
63(defconstant nbits-in-word 32)
64(defconstant least-significant-bit 31)
65(defconstant nbits-in-byte 8)
66(defconstant ntagbits 3)                ; But non-header objects only use 2
67(defconstant nlisptagbits 2)
68(defconstant nfixnumtagbits 2)          ; See ?
69(defconstant num-subtag-bits 8)         ; tag part of header is 8 bits wide
70(defconstant fixnumshift nfixnumtagbits)
71(defconstant fixnum-shift fixnumshift)          ; A pet name for it.
72(defconstant fulltagmask (1- (ash 1 ntagbits)))         ; Only needed by GC/very low-level code
73(defconstant full-tag-mask fulltagmask)
74(defconstant tagmask (1- (ash 1 nlisptagbits)))
75(defconstant tag-mask tagmask)
76(defconstant fixnummask (1- (ash 1 nfixnumtagbits)))
77(defconstant fixnum-mask fixnummask)
78(defconstant subtag-mask (1- (ash 1 num-subtag-bits)))
79(defconstant ncharcodebits 24)          ; only the low 8 bits are used, currently
80(defconstant charcode-shift (- nbits-in-word ncharcodebits))
81(defconstant word-shift 2)
82(defconstant word-size-in-bytes 4)
83(defconstant node-size 4)
84(defconstant dnode-size 8)
85(defconstant dnode-align-bits 3)
86(defconstant dnode-shift dnode-align-bits)
87(defconstant bitmap-shift 5)
88
89(defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits))))
90(defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits)))))
91
92;; PPC-32 stuff and tags.
93
94;; Tags.
95;; There are two-bit tags and three-bit tags.
96;; A FULLTAG is the value of the low three bits of a tagged object.
97;; A TAG is the value of the low two bits of a tagged object.
98;; A TYPECODE is either a TAG or the value of a "tag-misc" object's header-byte.
99
100;; There are 4 primary TAG values.  Any object which lisp can "see" can be classified
101;; by its TAG.  (Some headers have FULLTAGS that are congruent modulo 4 with the
102;; TAGS of other objects, but lisp can't "see" headers.)
103(ccl::defenum ()
104  tag-fixnum                            ; All fixnums, whether odd or even
105  tag-list                              ; Conses and NIL
106  tag-misc                              ; Heap-consed objects other than lists: vectors, symbols, functions, floats ...
107  tag-imm                               ; Immediate-objects: characters, UNBOUND, other markers.
108)
109
110;;; And there are 8 FULLTAG values.  Note that NIL has its own FULLTAG (congruent mod 4 to tag-list),
111;;; that FULLTAG-MISC is > 4 (so that code-vector entry-points can be branched to, since the low
112;;; two bits of the PC are ignored) and that both FULLTAG-MISC and FULLTAG-IMM have header fulltags
113;;; that share the same TAG.
114;;; Things that walk memory (and the stack) have to be careful to look at the FULLTAG of each
115;;; object that they see.
116(ccl::defenum ()
117  fulltag-even-fixnum                   ; I suppose EVENP/ODDP might care; nothing else does.
118  fulltag-cons                          ; a real (non-null) cons.  Shares TAG with fulltag-nil.
119  fulltag-nodeheader                    ; Header of heap-allocated object that contains lisp-object pointers
120  fulltag-imm                           ; a "real" immediate object.  Shares TAG with fulltag-immheader.
121  fulltag-odd-fixnum                    ;
122  fulltag-nil                           ; NIL and nothing but.  (Note that there's still a hidden NILSYM.)
123  fulltag-misc                          ; Pointer "real" tag-misc object.  Shares TAG with fulltag-nodeheader.
124  fulltag-immheader                     ; Header of heap-allocated object that contains unboxed data.
125)
126
127(defconstant misc-header-offset (- fulltag-misc))
128(defconstant misc-subtag-offset (+ misc-header-offset 3))
129(defconstant misc-data-offset (+ misc-header-offset 4))
130(defconstant misc-dfloat-offset (+ misc-header-offset 8))
131
132
133
134
135
136
137(defconstant canonical-nil-value #x00003015)
138;;; T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans
139;;; two doublewords.  The arithmetic difference between T and NIL is
140;;; such that the least-significant bit and exactly one other bit is
141;;; set in the result.
142
143(defconstant t-offset (+ 8 (- 8 fulltag-nil) fulltag-misc))
144(assert (and (logbitp 0 t-offset) (= (logcount t-offset) 2)))
145
146;;; The order in which various header values are defined is significant in several ways:
147;;; 1) Numeric subtags precede non-numeric ones; there are further orderings among numeric subtags.
148;;; 2) All subtags which denote CL arrays are preceded by those that don't,
149;;;    with a further ordering which requires that (< header-arrayH header-vectorH ,@all-other-CL-vector-types)
150;;; 3) The element-size of ivectors is determined by the ordering of ivector subtags.
151;;; 4) All subtags are >= fulltag-immheader .
152
153
154;;; Numeric subtags.
155(define-imm-subtag bignum 0)
156(defconstant min-numeric-subtag subtag-bignum)
157(define-node-subtag ratio 1)
158(defconstant max-rational-subtag subtag-ratio)
159
160(define-imm-subtag single-float 1)          ; "SINGLE" float, aka short-float in the new order.
161(define-imm-subtag double-float 2)
162(defconstant min-float-subtag subtag-single-float)
163(defconstant max-float-subtag subtag-double-float)
164(defconstant max-real-subtag subtag-double-float)
165
166(define-node-subtag complex 3)
167(defconstant max-numeric-subtag subtag-complex)
168
169;;; CL array types.  There are more immediate types than node types; all CL array subtags must be > than
170;;; all non-CL-array subtags.  So we start by defining the immediate subtags in decreasing order, starting
171;;; with that subtag whose element size isn't an integral number of bits and ending with those whose
172;;; element size - like all non-CL-array fulltag-immheader types - is 32 bits.
173(define-imm-subtag bit-vector 31)
174(define-imm-subtag double-float-vector 30)
175(define-imm-subtag s16-vector 29)
176(define-imm-subtag u16-vector 28)
177(defconstant min-16-bit-ivector-subtag subtag-u16-vector)
178(defconstant max-16-bit-ivector-subtag subtag-s16-vector)
179
180
181;;(define-imm-subtag simple-base-string 27)
182(define-imm-subtag s8-vector 26)
183(define-imm-subtag u8-vector 25)
184(defconstant min-8-bit-ivector-subtag subtag-u8-vector)
185(defconstant max-8-bit-ivector-subtag (logior fulltag-immheader (ash 27 ntagbits)))
186
187(define-imm-subtag simple-base-string 24)
188(define-imm-subtag fixnum-vector 23)
189(define-imm-subtag s32-vector 22)
190(define-imm-subtag u32-vector 21)
191(define-imm-subtag single-float-vector 20)
192(defconstant max-32-bit-ivector-subtag (logior fulltag-immheader (ash 24 ntagbits)))
193(defconstant min-cl-ivector-subtag subtag-single-float-vector)
194
195(define-node-subtag vectorH 20)
196(define-node-subtag arrayH 19)
197(assert (< subtag-arrayH subtag-vectorH min-cl-ivector-subtag))
198(define-node-subtag simple-vector 21)   ; Only one such subtag
199(assert (< subtag-arrayH subtag-vectorH subtag-simple-vector))
200(defconstant min-vector-subtag subtag-vectorH)
201(defconstant min-array-subtag subtag-arrayH)
202
203;;; So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < min-array-subtag))
204;;; for various immediate/node object types.
205
206(define-imm-subtag macptr 3)
207(defconstant min-non-numeric-imm-subtag subtag-macptr)
208(assert (> min-non-numeric-imm-subtag max-numeric-subtag))
209(define-imm-subtag dead-macptr 4)
210(define-imm-subtag code-vector 5)
211(define-imm-subtag creole-object 6)
212(define-imm-subtag xcode-vector 7)  ; code-vector for cross-development
213
214(defconstant max-non-array-imm-subtag (logior (ash 19 ntagbits) fulltag-immheader))
215
216(define-node-subtag catch-frame 4)
217(defconstant min-non-numeric-node-subtag subtag-catch-frame)
218(assert (> min-non-numeric-node-subtag max-numeric-subtag))
219(define-node-subtag function 5)
220(define-node-subtag basic-stream 6)
221(define-node-subtag symbol 7)
222(define-node-subtag lock 8)
223(define-node-subtag hash-vector 9)
224(define-node-subtag pool 10)
225(define-node-subtag weak 11)
226(define-node-subtag package 12)
227(define-node-subtag slot-vector 13)
228(define-node-subtag instance 14)
229(define-node-subtag struct 15)
230(define-node-subtag istruct 16)
231(define-node-subtag value-cell 17)
232(define-node-subtag xfunction 18)       ; Function for cross-development
233(defconstant max-non-array-node-subtag (logior (ash 18 ntagbits) fulltag-nodeheader))
234
235(define-subtag character fulltag-imm 9)
236(define-subtag vsp-protect fulltag-imm 7)
237(define-subtag slot-unbound fulltag-imm 10)
238(defconstant slot-unbound-marker subtag-slot-unbound)
239(define-subtag illegal fulltag-imm 11)
240(defconstant illegal-marker subtag-illegal)
241(define-subtag go-tag fulltag-imm 12)
242(define-subtag block-tag fulltag-imm 24)
243(define-subtag no-thread-local-binding fulltag-imm 30)
244(define-subtag unbound fulltag-imm 6)
245(defconstant unbound-marker subtag-unbound)
246(defconstant undefined unbound-marker)
247
248
249(defconstant max-64-bit-constant-index (ash (+ #x7fff ppc32::misc-dfloat-offset) -3))
250(defconstant max-32-bit-constant-index (ash (+ #x7fff ppc32::misc-data-offset) -2))
251(defconstant max-16-bit-constant-index (ash (+ #x7fff ppc32::misc-data-offset) -1))
252(defconstant max-8-bit-constant-index (+ #x7fff ppc32::misc-data-offset))
253(defconstant max-1-bit-constant-index (ash (+ #x7fff ppc32::misc-data-offset) 5))
254
255
256;;; The objects themselves look something like this:
257
258;;; Order of CAR and CDR doesn't seem to matter much - there aren't
259;;; too many tricks to be played with predecrement/preincrement addressing.
260;;; Keep them in the confusing MCL 3.0 order, to avoid confusion.
261(define-lisp-object cons tag-list 
262  cdr 
263  car)
264
265
266(define-fixedsized-object ratio
267  numer
268  denom)
269
270(define-fixedsized-object single-float
271  value)
272
273(define-fixedsized-object double-float
274  pad
275  value
276  val-low)
277
278(define-fixedsized-object complex
279  realpart
280  imagpart
281)
282
283
284;;; There are two kinds of macptr; use the length field of the header if you
285;;; need to distinguish between them
286(define-fixedsized-object macptr
287  address
288  domain
289  type
290)
291
292(define-fixedsized-object xmacptr
293  address
294  domain
295  type
296  flags
297  link
298)
299
300;;; Catch frames go on the tstack; they point to a minimal lisp-frame
301;;; on the cstack.  (The catch/unwind-protect PC is on the cstack, where
302;;; the GC expects to find it.)
303(define-fixedsized-object catch-frame
304  catch-tag                             ; #<unbound> -> unwind-protect, else catch
305  link                                  ; tagged pointer to next older catch frame
306  mvflag                                ; 0 if single-value, 1 if uwp or multiple-value
307  csp                                   ; pointer to control stack
308  db-link                               ; value of dynamic-binding link on thread entry.
309  save-save7                            ; saved registers
310  save-save6
311  save-save5
312  save-save4
313  save-save3
314  save-save2
315  save-save1
316  save-save0
317  xframe                                ; exception-frame link
318  tsp-segment                           ; mostly padding, for now.
319)
320
321(define-fixedsized-object lock
322  _value                                ;finalizable pointer to kernel object
323  kind                                  ; '0 = recursive-lock, '1 = rwlock
324  writer                                ;tcr of owning thread or 0
325  name
326  whostate
327  whostate-2
328  )
329
330
331
332(define-fixedsized-object symbol
333  pname
334  vcell
335  fcell
336  package-predicate
337  flags
338  plist
339  binding-index
340)
341
342
343
344(defconstant nilsym-offset (+ t-offset symbol.size))
345
346
347(define-fixedsized-object vectorH
348  logsize                               ; fillpointer if it has one, physsize otherwise
349  physsize                              ; total size of (possibly displaced) data vector
350  data-vector                           ; object this header describes
351  displacement                          ; true displacement or 0
352  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
353)
354
355(define-lisp-object arrayH fulltag-misc
356  header                                ; subtag = subtag-arrayH
357  rank                                  ; NEVER 1
358  physsize                              ; total size of (possibly displaced) data vector
359  data-vector                           ; object this header describes
360  displacement                          ; true displacement or 0 
361  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
362 ;; Dimensions follow
363)
364
365(defconstant arrayH.rank-cell 0)
366(defconstant arrayH.physsize-cell 1)
367(defconstant arrayH.data-vector-cell 2)
368(defconstant arrayH.displacement-cell 3)
369(defconstant arrayH.flags-cell 4)
370(defconstant arrayH.dim0-cell 5)
371
372(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
373(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
374
375
376(define-fixedsized-object value-cell
377  value)
378
379;;; The kernel uses these (rather generically named) structures
380;;; to keep track of various memory regions it (or the lisp) is
381;;; interested in.
382;;; The gc-area record definition in "ccl:interfaces;mcl-records.lisp"
383;;; matches this.
384
385(define-storage-layout area 0
386  pred                                  ; pointer to preceding area in DLL
387  succ                                  ; pointer to next area in DLL
388  low                                   ; low bound on area addresses
389  high                                  ; high bound on area addresses.
390  active                                ; low limit on stacks, high limit on heaps
391  softlimit                             ; overflow bound
392  hardlimit                             ; another one
393  code                                  ; an area-code; see below
394  markbits                              ; bit vector for GC
395  ndnodes                               ; "active" size of dynamic area or stack
396  older                                 ; in EGC sense
397  younger                               ; also for EGC
398  h                                     ; Handle or null pointer
399  softprot                              ; protected_area structure pointer
400  hardprot                              ; another one.
401  owner                                 ; fragment (library) which "owns" the area
402  refbits                               ; bitvector for intergenerational refernces
403  threshold                             ; for egc
404  gc-count                              ; generational gc count.
405  static-dnodes                         ; for honsing, etc.
406  static-used                           ; bitvector
407)
408
409
410(define-storage-layout protected-area 0
411  next
412  start                                 ; first byte (page-aligned) that might be protected
413  end                                   ; last byte (page-aligned) that could be protected
414  nprot                                 ; Might be 0
415  protsize                              ; number of bytes to protect
416  why)
417
418(defconstant tcr-bias 0)
419
420(define-storage-layout tcr (- tcr-bias)
421  prev                                  ; in doubly-linked list
422  next                                  ; in doubly-linked list
423  lisp-fpscr-high
424  lisp-fpscr-low
425  db-link                               ; special binding chain head
426  catch-top                             ; top catch frame
427  save-vsp                              ; VSP when in foreign code
428  save-tsp                              ; TSP when in foreign code
429  cs-area                               ; cstack area pointer
430  vs-area                               ; vstack area pointer
431  ts-area                               ; tstack area pointer
432  cs-limit                              ; cstack overflow limit
433  total-bytes-allocated-high
434  total-bytes-allocated-low
435  log2-allocation-quantum               ; unboxed
436  interrupt-pending                     ; fixnum
437  xframe                                ; exception frame linked list
438  errno-loc                             ; thread-private, maybe
439  ffi-exception                         ; fpscr bits from ff-call.
440  osid                                  ; OS thread id
441  valence                               ; odd when in foreign code
442  foreign-exception-status
443  native-thread-info
444  native-thread-id
445  last-allocptr
446  save-allocptr
447  save-allocbase
448  reset-completion
449  activate
450  suspend-count
451  suspend-context
452  pending-exception-context
453  suspend                               ; semaphore for suspension notify
454  resume                                ; sempahore for resumption notify
455  flags                                 ; foreign, being reset, ...
456  gc-context
457  termination-semaphore
458  unwinding
459  tlb-limit
460  tlb-pointer
461  shutdown-count
462  safe-ref-address
463)
464
465(defconstant interrupt-level-binding-index (ash 1 fixnumshift))
466
467(define-storage-layout lockptr 0
468  avail
469  owner
470  count
471  signal
472  waiting
473  malloced-ptr
474  spinlock)
475
476(define-storage-layout rwlock 0
477  spin
478  state
479  blocked-writers
480  blocked-readers
481  writer
482  reader-signal
483  writer-signal
484  malloced-ptr
485  )
486
487;;; For the eabi port: mark this stack frame as Lisp's (since EABI
488;;; foreign frames can be the same size as a lisp frame.)
489
490
491(ppc32::define-storage-layout lisp-frame 0
492  backlink
493  savefn
494  savelr
495  savevsp
496)
497
498(ppc32::define-storage-layout c-frame 0
499  backlink
500  crsave
501  savelr
502  unused-1
503  unused-2
504  savetoc
505  param0
506  param1
507  param2
508  param3
509  param4
510  param5
511  param6
512  param7
513)
514
515(defconstant c-frame.minsize c-frame.size)
516
517;;; .SPeabi-ff-call "shrinks" this frame after loading the GPRs.
518(ppc32::define-storage-layout eabi-c-frame 0
519  backlink
520  savelr
521  param0
522  param1
523  param2
524  param3
525  param4
526  param5
527  param6
528  param7
529)
530
531(defconstant eabi-c-frame.minsize eabi-c-frame.size)
532
533(defmacro define-header (name element-count subtag)
534  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
535
536(define-header single-float-header single-float.element-count subtag-single-float)
537(define-header double-float-header double-float.element-count subtag-double-float)
538(define-header one-digit-bignum-header 1 subtag-bignum)
539(define-header two-digit-bignum-header 2 subtag-bignum)
540(define-header three-digit-bignum-header 3 subtag-bignum)
541(define-header symbol-header symbol.element-count subtag-symbol)
542(define-header value-cell-header value-cell.element-count subtag-value-cell)
543(define-header macptr-header macptr.element-count subtag-macptr)
544
545(defconstant yield-syscall
546  #+darwinppc-target -60
547  #+linuxppc-target #$__NR_sched_yield)
548)
549
550
551
552
553(defun %kernel-global (sym)
554  (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
555    (if pos
556      (- (+ fulltag-nil (* (1+ pos) 4)))
557      (error "Unknown kernel global : ~s ." sym))))
558
559(defmacro kernel-global (sym)
560  (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
561    (if pos
562      (- (+ fulltag-nil (* (1+ pos) 4)))
563      (error "Unknown kernel global : ~s ." sym))))
564
565;;; The kernel imports things that are defined in various other
566;;; libraries for us.  The objects in question are generally
567;;; fixnum-tagged; the entries in the "kernel-imports" vector are 4
568;;; bytes apart.
569(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step 4)
570  fd-setsize-bytes
571  do-fd-set
572  do-fd-clr
573  do-fd-is-set
574  do-fd-zero
575  MakeDataExecutable
576  GetSharedLibrary
577  FindSymbol
578  malloc
579  free
580  wait-for-signal
581  tcr-frame-ptr
582  register-xmacptr-dispose-function
583  open-debug-output
584  get-r-debug
585  restore-soft-stack-limit
586  egc-control
587  lisp-bug
588  NewThread
589  YieldToThread
590  DisposeThread
591  ThreadCurrentStackSpace
592  usage-exit
593  save-fp-context
594  restore-fp-context
595  put-altivec-registers
596  get-altivec-registers
597  new-semaphore
598  wait-on-semaphore
599  signal-semaphore
600  destroy-semaphore
601  new-recursive-lock
602  lock-recursive-lock
603  unlock-recursive-lock
604  destroy-recursive-lock
605  suspend-other-threads
606  resume-other-threads
607  suspend-tcr
608  resume-tcr
609  rwlock-new
610  rwlock-destroy
611  rwlock-rlock
612  rwlock-wlock
613  rwlock-unlock
614  recursive-lock-trylock
615  foreign-name-and-offset
616  lisp-read
617  lisp-write
618  lisp-open
619  lisp-fchmod
620  lisp-lseek
621  lisp-close
622  lisp-ftruncate
623  lisp-stat
624  lisp-fstat
625  lisp-futex
626  lisp-opendir
627  lisp-readdir
628  lisp-closedir
629  lisp-pipe
630  lisp-gettimeofday
631  lisp-sigexit
632)
633
634(defmacro nrs-offset (name)
635  (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq)))
636    (if pos (+ t-offset (* pos symbol.size)))))
637
638
639(defconstant reservation-discharge #x2004)
640
641
642
643(defmacro with-stack-short-floats (specs &body body)
644  (ccl::collect ((binds)
645                 (inits)
646                 (names))
647                (dolist (spec specs)
648                  (let ((name (first spec)))
649                    (binds `(,name (ccl::%make-sfloat)))
650                    (names name)
651                    (let ((init (second spec)))
652                      (when init
653                        (inits `(ccl::%short-float ,init ,name))))))
654                `(let* ,(binds)
655                  (declare (dynamic-extent ,@(names))
656                           (short-float ,@(names)))
657                  ,@(inits)
658                  ,@body)))
659
660(defparameter *ppc32-target-uvector-subtags*
661  `((:bignum . ,subtag-bignum)
662    (:ratio . ,subtag-ratio)
663    (:single-float . ,subtag-single-float)
664    (:double-float . ,subtag-double-float)
665    (:complex . ,subtag-complex  )
666    (:symbol . ,subtag-symbol)
667    (:function . ,subtag-function )
668    (:code-vector . ,subtag-code-vector)
669    (:xcode-vector . ,subtag-xcode-vector)
670    (:macptr . ,subtag-macptr )
671    (:catch-frame . ,subtag-catch-frame)
672    (:struct . ,subtag-struct )   
673    (:istruct . ,subtag-istruct )
674    (:pool . ,subtag-pool )
675    (:population . ,subtag-weak )
676    (:hash-vector . ,subtag-hash-vector )
677    (:package . ,subtag-package )
678    (:value-cell . ,subtag-value-cell)
679    (:instance . ,subtag-instance )
680    (:lock . ,subtag-lock )
681    (:slot-vector . ,subtag-slot-vector)
682    (:basic-stream . ,subtag-basic-stream)
683    (:simple-string . ,subtag-simple-base-string )
684    (:bit-vector . ,subtag-bit-vector )
685    (:signed-8-bit-vector . ,subtag-s8-vector )
686    (:unsigned-8-bit-vector . ,subtag-u8-vector )
687    (:signed-16-bit-vector . ,subtag-s16-vector )
688    (:unsigned-16-bit-vector . ,subtag-u16-vector )
689    (:signed-32-bit-vector . ,subtag-s32-vector )
690    (:fixnum-vector . ,subtag-fixnum-vector)
691    (:unsigned-32-bit-vector . ,subtag-u32-vector )
692    (:single-float-vector . ,subtag-single-float-vector)
693    (:double-float-vector . ,subtag-double-float-vector )
694    (:simple-vector . ,subtag-simple-vector )
695    (:vector-header . ,subtag-vectorH)
696    (:array-header . ,subtag-arrayH)))
697
698
699;;; This should return NIL unless it's sure of how the indicated
700;;; type would be represented (in particular, it should return
701;;; NIL if the element type is unknown or unspecified at compile-time.
702(defun ppc32-array-type-name-from-ctype (ctype)
703  (when (typep ctype 'ccl::array-ctype)
704    (let* ((element-type (ccl::array-ctype-element-type ctype)))
705      (typecase element-type
706        (ccl::class-ctype
707         (let* ((class (ccl::class-ctype-class element-type)))
708           (if (or (eq class ccl::*character-class*)
709                   (eq class ccl::*base-char-class*)
710                   (eq class ccl::*standard-char-class*))
711             :simple-string
712             :simple-vector)))
713        (ccl::numeric-ctype
714         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
715           :simple-vector
716           (case (ccl::numeric-ctype-class element-type)
717             (integer
718              (let* ((low (ccl::numeric-ctype-low element-type))
719                     (high (ccl::numeric-ctype-high element-type)))
720                (cond ((or (null low) (null high)) :simple-vector)
721                      ((and (>= low 0) (<= high 1) :bit-vector))
722                      ((and (>= low 0) (<= high 255)) :unsigned-8-bit-vector)
723                      ((and (>= low 0) (<= high 65535)) :unsigned-16-bit-vector)
724                      ((and (>= low 0) (<= high #xffffffff) :unsigned-32-bit-vector))
725                      ((and (>= low -128) (<= high 127)) :signed-8-bit-vector)
726                      ((and (>= low -32768) (<= high 32767) :signed-16-bit-vector))
727                      ((and (>= low target-most-negative-fixnum)
728                            (<= high target-most-positive-fixnum))
729                       :fixnum-vector)
730                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
731                       :signed-32-bit-vector)
732                      (t :simple-vector))))
733             (float
734              (case (ccl::numeric-ctype-format element-type)
735                ((double-float long-float) :double-float-vector)
736                ((single-float short-float) :single-float-vector)
737                (t :simple-vector)))
738             (t :simple-vector))))
739        (ccl::unknown-ctype)
740        (ccl::named-ctype
741         (if (eq element-type ccl::*universal-type*)
742           :simple-vector))
743        (t nil)))))
744       
745(defun ppc32-misc-byte-count (subtag element-count)
746  (declare (fixnum subtag))
747  (if (or (= fulltag-nodeheader (logand subtag fulltagmask))
748          (<= subtag max-32-bit-ivector-subtag))
749    (ash element-count 2)
750    (if (<= subtag max-8-bit-ivector-subtag)
751      element-count
752      (if (<= subtag max-16-bit-ivector-subtag)
753        (ash element-count 1)
754        (if (= subtag subtag-bit-vector)
755          (ash (+ element-count 7) -3)
756          (+ 4 (ash element-count 3)))))))
757
758(defparameter *ppc32-target-arch*
759  (arch::make-target-arch :name :ppc32
760                          :lisp-node-size 4
761                          :nil-value canonical-nil-value
762                          :fixnum-shift fixnumshift
763                          :most-positive-fixnum (1- (ash 1 (1- (- 32 fixnumshift))))
764                          :most-negative-fixnum (- (ash 1 (1- (- 32 fixnumshift))))
765                          :misc-data-offset misc-data-offset
766                          :misc-dfloat-offset misc-dfloat-offset
767                          :nbits-in-word 32
768                          :ntagbits 3
769                          :nlisptagbits 2
770                          :uvector-subtags *ppc32-target-uvector-subtags*
771                          :max-64-bit-constant-index max-64-bit-constant-index
772                          :max-32-bit-constant-index max-32-bit-constant-index
773                          :max-16-bit-constant-index max-16-bit-constant-index
774                          :max-8-bit-constant-index max-8-bit-constant-index
775                          :max-1-bit-constant-index max-1-bit-constant-index
776                          :word-shift 2
777                          :code-vector-prefix ()
778                          :gvector-types '(:ratio :complex :symbol :function
779                                           :catch-frame :struct :istruct
780                                           :pool :population :hash-vector
781                                           :package :value-cell :instance
782                                           :lock :slot-vector
783                                           :simple-vector)
784                          :1-bit-ivector-types '(:bit-vector)
785                          :8-bit-ivector-types '(:signed-8-bit-vector
786                                                 :unsigned-8-bit-vector)
787                          :16-bit-ivector-types '(:signed-16-bit-vector
788                                                  :unsigned-16-bit-vector)
789                          :32-bit-ivector-types '(:signed-32-bit-vector
790                                                  :unsigned-32-bit-vector
791                                                  :single-float-vector
792                                                  :fixnum-vector
793                                                  :single-float
794                                                  :double-float
795                                                  :bignum
796                                                  :simple-string)
797                          :64-bit-ivector-types '(:double-float-vector)
798                          :array-type-name-from-ctype-function
799                          #'ppc32-array-type-name-from-ctype
800                          :package-name "PPC32"
801                          :t-offset t-offset
802                          :array-data-size-function #'ppc32-misc-byte-count
803                          :numeric-type-name-to-typecode-function
804                          #'(lambda (type-name)
805                              (ecase type-name
806                                (fixnum tag-fixnum)
807                                (bignum subtag-bignum)
808                                ((short-float single-float) subtag-single-float)
809                                ((long-float double-float) subtag-double-float)
810                                (ratio subtag-ratio)
811                                (complex subtag-complex)))
812                          :subprims-base ppc::*ppc-subprims-base*
813                          :subprims-shift ppc::*ppc-subprims-shift*
814                          :subprims-table ppc::*ppc-subprims*
815                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-subprims*)))
816                          :unbound-marker-value unbound-marker
817                          :slot-unbound-marker-value slot-unbound-marker
818                          :fixnum-tag tag-fixnum
819                          :single-float-tag subtag-single-float
820                          :single-float-tag-is-subtag t
821                          :double-float-tag subtag-double-float
822                          :cons-tag fulltag-cons
823                          :null-tag fulltag-nil
824                          :symbol-tag subtag-symbol
825                          :symbol-tag-is-subtag t
826                          :function-tag subtag-function
827                          :function-tag-is-subtag t
828                          :big-endian t
829                          :misc-subtag-offset misc-subtag-offset
830                          :car-offset cons.car
831                          :cdr-offset cons.cdr
832                          :subtag-char subtag-character
833                          :charcode-shift charcode-shift
834                          :fulltagmask fulltagmask
835                          :fulltag-misc fulltag-misc
836                          :char-code-limit #x110000
837                          ))
838
839;;; arch macros
840(defmacro defppc32archmacro (name lambda-list &body body)
841  `(arch::defarchmacro :ppc32 ,name ,lambda-list ,@body))
842
843(defppc32archmacro ccl::%make-sfloat ()
844  `(ccl::%alloc-misc ppc32::single-float.element-count ppc32::subtag-single-float))
845
846(defppc32archmacro ccl::%make-dfloat ()
847  `(ccl::%alloc-misc ppc32::double-float.element-count ppc32::subtag-double-float))
848
849(defppc32archmacro ccl::%numerator (x)
850  `(ccl::%svref ,x ppc32::ratio.numer-cell))
851
852(defppc32archmacro ccl::%denominator (x)
853  `(ccl::%svref ,x ppc32::ratio.denom-cell))
854
855(defppc32archmacro ccl::%realpart (x)
856  `(ccl::%svref ,x ppc32::complex.realpart-cell))
857                   
858(defppc32archmacro ccl::%imagpart (x)
859  `(ccl::%svref ,x ppc32::complex.imagpart-cell))
860
861;;;
862(defppc32archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
863 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)
864   (ccl::%alloc-misc 1 ppc32::subtag-single-float)))
865
866(defppc32archmacro ccl::codevec-header-p (word)
867  `(eql ppc32::subtag-code-vector
868    (logand ,word ppc32::subtag-mask)))
869
870(defppc32archmacro ccl::immediate-p-macro (thing)
871  (let* ((tag (gensym)))
872    `(let* ((,tag (ccl::lisptag ,thing)))
873      (declare (fixnum ,tag))
874      (or (= ,tag ppc32::tag-fixnum)
875       (= ,tag ppc32::tag-imm)))))
876
877(defppc32archmacro ccl::hashed-by-identity (thing)
878  (let* ((typecode (gensym)))
879    `(let* ((,typecode (ccl::typecode ,thing)))
880      (declare (fixnum ,typecode))
881      (or
882       (= ,typecode ppc32::tag-fixnum)
883       (= ,typecode ppc32::tag-imm)
884       (= ,typecode ppc32::subtag-symbol)
885       (= ,typecode ppc32::subtag-instance)))))
886
887;;;
888(defppc32archmacro ccl::%get-kernel-global (name)
889  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
890                        ,(%kernel-global
891                          (if (ccl::quoted-form-p name)
892                            (cadr name)
893                            name)))))
894
895(defppc32archmacro ccl::%get-kernel-global-ptr (name dest)
896  `(ccl::%setf-macptr
897    ,dest
898    (ccl::%fixnum-ref-macptr 0 (+ ,(ccl::target-nil-value)
899                                ,(%kernel-global
900                                  (if (ccl::quoted-form-p name)
901                                    (cadr name)
902                                    name))))))
903
904(defppc32archmacro ccl::%target-kernel-global (name)
905  `(ppc32::%kernel-global ,name))
906
907(defppc32archmacro ccl::lfun-vector (fn)
908  fn)
909
910(defppc32archmacro ccl::lfun-vector-lfun (lfv)
911  lfv)
912
913(defppc32archmacro ccl::area-code ()
914  area.code)
915
916(defppc32archmacro ccl::area-succ ()
917  area.succ)
918
919(defppc32archmacro ccl::nth-immediate (f i)
920  `(ccl::%svref ,f ,i))
921
922(defppc32archmacro ccl::set-nth-immediate (f i new)
923  `(setf (ccl::%svref ,f ,i) ,new))
924
925(defppc32archmacro ccl::symptr->symvector (s)
926  s)
927
928(defppc32archmacro ccl::symvector->symptr (s)
929  s)
930
931(defppc32archmacro ccl::function-to-function-vector (f)
932  f)
933
934(defppc32archmacro ccl::function-vector-to-function (v)
935  v)
936
937(defppc32archmacro ccl::with-ffcall-results ((buf) &body body)
938  (let* ((size (+ (* 8 4) (* 31 8))))
939    `(%stack-block ((,buf ,size))
940      ,@body)))
941
942(defconstant arg-check-trap-pc-limit 8)
943
944(defconstant fasl-version #x5f)
945(defconstant fasl-max-version #x5f)
946(defconstant fasl-min-version #x5e)
947(defparameter *image-abi-version* 1037)
948
949(provide "PPC32-ARCH")
Note: See TracBrowser for help on using the repository browser.