source: trunk/source/compiler/PPC/PPC32/ppc32-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: 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  jvm-init
633)
634
635(defmacro nrs-offset (name)
636  (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq)))
637    (if pos (+ t-offset (* pos symbol.size)))))
638
639
640(defconstant reservation-discharge #x2004)
641
642
643
644(defmacro with-stack-short-floats (specs &body body)
645  (ccl::collect ((binds)
646                 (inits)
647                 (names))
648                (dolist (spec specs)
649                  (let ((name (first spec)))
650                    (binds `(,name (ccl::%make-sfloat)))
651                    (names name)
652                    (let ((init (second spec)))
653                      (when init
654                        (inits `(ccl::%short-float ,init ,name))))))
655                `(let* ,(binds)
656                  (declare (dynamic-extent ,@(names))
657                           (short-float ,@(names)))
658                  ,@(inits)
659                  ,@body)))
660
661(defparameter *ppc32-target-uvector-subtags*
662  `((:bignum . ,subtag-bignum)
663    (:ratio . ,subtag-ratio)
664    (:single-float . ,subtag-single-float)
665    (:double-float . ,subtag-double-float)
666    (:complex . ,subtag-complex  )
667    (:symbol . ,subtag-symbol)
668    (:function . ,subtag-function )
669    (:code-vector . ,subtag-code-vector)
670    (:xcode-vector . ,subtag-xcode-vector)
671    (:macptr . ,subtag-macptr )
672    (:catch-frame . ,subtag-catch-frame)
673    (:struct . ,subtag-struct )   
674    (:istruct . ,subtag-istruct )
675    (:pool . ,subtag-pool )
676    (:population . ,subtag-weak )
677    (:hash-vector . ,subtag-hash-vector )
678    (:package . ,subtag-package )
679    (:value-cell . ,subtag-value-cell)
680    (:instance . ,subtag-instance )
681    (:lock . ,subtag-lock )
682    (:slot-vector . ,subtag-slot-vector)
683    (:basic-stream . ,subtag-basic-stream)
684    (:simple-string . ,subtag-simple-base-string )
685    (:bit-vector . ,subtag-bit-vector )
686    (:signed-8-bit-vector . ,subtag-s8-vector )
687    (:unsigned-8-bit-vector . ,subtag-u8-vector )
688    (:signed-16-bit-vector . ,subtag-s16-vector )
689    (:unsigned-16-bit-vector . ,subtag-u16-vector )
690    (:signed-32-bit-vector . ,subtag-s32-vector )
691    (:fixnum-vector . ,subtag-fixnum-vector)
692    (:unsigned-32-bit-vector . ,subtag-u32-vector )
693    (:single-float-vector . ,subtag-single-float-vector)
694    (:double-float-vector . ,subtag-double-float-vector )
695    (:simple-vector . ,subtag-simple-vector )
696    (:vector-header . ,subtag-vectorH)
697    (:array-header . ,subtag-arrayH)))
698
699
700;;; This should return NIL unless it's sure of how the indicated
701;;; type would be represented (in particular, it should return
702;;; NIL if the element type is unknown or unspecified at compile-time.
703(defun ppc32-array-type-name-from-ctype (ctype)
704  (when (typep ctype 'ccl::array-ctype)
705    (let* ((element-type (ccl::array-ctype-element-type ctype)))
706      (typecase element-type
707        (ccl::class-ctype
708         (let* ((class (ccl::class-ctype-class element-type)))
709           (if (or (eq class ccl::*character-class*)
710                   (eq class ccl::*base-char-class*)
711                   (eq class ccl::*standard-char-class*))
712             :simple-string
713             :simple-vector)))
714        (ccl::numeric-ctype
715         (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
716           :simple-vector
717           (case (ccl::numeric-ctype-class element-type)
718             (integer
719              (let* ((low (ccl::numeric-ctype-low element-type))
720                     (high (ccl::numeric-ctype-high element-type)))
721                (cond ((or (null low) (null high)) :simple-vector)
722                      ((and (>= low 0) (<= high 1) :bit-vector))
723                      ((and (>= low 0) (<= high 255)) :unsigned-8-bit-vector)
724                      ((and (>= low 0) (<= high 65535)) :unsigned-16-bit-vector)
725                      ((and (>= low 0) (<= high #xffffffff) :unsigned-32-bit-vector))
726                      ((and (>= low -128) (<= high 127)) :signed-8-bit-vector)
727                      ((and (>= low -32768) (<= high 32767) :signed-16-bit-vector))
728                      ((and (>= low target-most-negative-fixnum)
729                            (<= high target-most-positive-fixnum))
730                       :fixnum-vector)
731                      ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
732                       :signed-32-bit-vector)
733                      (t :simple-vector))))
734             (float
735              (case (ccl::numeric-ctype-format element-type)
736                ((double-float long-float) :double-float-vector)
737                ((single-float short-float) :single-float-vector)
738                (t :simple-vector)))
739             (t :simple-vector))))
740        (ccl::unknown-ctype)
741        (ccl::named-ctype
742         (if (eq element-type ccl::*universal-type*)
743           :simple-vector))
744        (t nil)))))
745       
746(defun ppc32-misc-byte-count (subtag element-count)
747  (declare (fixnum subtag))
748  (if (or (= fulltag-nodeheader (logand subtag fulltagmask))
749          (<= subtag max-32-bit-ivector-subtag))
750    (ash element-count 2)
751    (if (<= subtag max-8-bit-ivector-subtag)
752      element-count
753      (if (<= subtag max-16-bit-ivector-subtag)
754        (ash element-count 1)
755        (if (= subtag subtag-bit-vector)
756          (ash (+ element-count 7) -3)
757          (+ 4 (ash element-count 3)))))))
758
759(defparameter *ppc32-target-arch*
760  (arch::make-target-arch :name :ppc32
761                          :lisp-node-size 4
762                          :nil-value canonical-nil-value
763                          :fixnum-shift fixnumshift
764                          :most-positive-fixnum (1- (ash 1 (1- (- 32 fixnumshift))))
765                          :most-negative-fixnum (- (ash 1 (1- (- 32 fixnumshift))))
766                          :misc-data-offset misc-data-offset
767                          :misc-dfloat-offset misc-dfloat-offset
768                          :nbits-in-word 32
769                          :ntagbits 3
770                          :nlisptagbits 2
771                          :uvector-subtags *ppc32-target-uvector-subtags*
772                          :max-64-bit-constant-index max-64-bit-constant-index
773                          :max-32-bit-constant-index max-32-bit-constant-index
774                          :max-16-bit-constant-index max-16-bit-constant-index
775                          :max-8-bit-constant-index max-8-bit-constant-index
776                          :max-1-bit-constant-index max-1-bit-constant-index
777                          :word-shift 2
778                          :code-vector-prefix ()
779                          :gvector-types '(:ratio :complex :symbol :function
780                                           :catch-frame :struct :istruct
781                                           :pool :population :hash-vector
782                                           :package :value-cell :instance
783                                           :lock :slot-vector
784                                           :simple-vector)
785                          :1-bit-ivector-types '(:bit-vector)
786                          :8-bit-ivector-types '(:signed-8-bit-vector
787                                                 :unsigned-8-bit-vector)
788                          :16-bit-ivector-types '(:signed-16-bit-vector
789                                                  :unsigned-16-bit-vector)
790                          :32-bit-ivector-types '(:signed-32-bit-vector
791                                                  :unsigned-32-bit-vector
792                                                  :single-float-vector
793                                                  :fixnum-vector
794                                                  :single-float
795                                                  :double-float
796                                                  :bignum
797                                                  :simple-string)
798                          :64-bit-ivector-types '(:double-float-vector)
799                          :array-type-name-from-ctype-function
800                          #'ppc32-array-type-name-from-ctype
801                          :package-name "PPC32"
802                          :t-offset t-offset
803                          :array-data-size-function #'ppc32-misc-byte-count
804                          :numeric-type-name-to-typecode-function
805                          #'(lambda (type-name)
806                              (ecase type-name
807                                (fixnum tag-fixnum)
808                                (bignum subtag-bignum)
809                                ((short-float single-float) subtag-single-float)
810                                ((long-float double-float) subtag-double-float)
811                                (ratio subtag-ratio)
812                                (complex subtag-complex)))
813                          :subprims-base ppc::*ppc-subprims-base*
814                          :subprims-shift ppc::*ppc-subprims-shift*
815                          :subprims-table ppc::*ppc-subprims*
816                          :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-subprims*)))
817                          :unbound-marker-value unbound-marker
818                          :slot-unbound-marker-value slot-unbound-marker
819                          :fixnum-tag tag-fixnum
820                          :single-float-tag subtag-single-float
821                          :single-float-tag-is-subtag t
822                          :double-float-tag subtag-double-float
823                          :cons-tag fulltag-cons
824                          :null-tag fulltag-nil
825                          :symbol-tag subtag-symbol
826                          :symbol-tag-is-subtag t
827                          :function-tag subtag-function
828                          :function-tag-is-subtag t
829                          :big-endian t
830                          :misc-subtag-offset misc-subtag-offset
831                          :car-offset cons.car
832                          :cdr-offset cons.cdr
833                          :subtag-char subtag-character
834                          :charcode-shift charcode-shift
835                          :fulltagmask fulltagmask
836                          :fulltag-misc fulltag-misc
837                          :char-code-limit #x110000
838                          ))
839
840;;; arch macros
841(defmacro defppc32archmacro (name lambda-list &body body)
842  `(arch::defarchmacro :ppc32 ,name ,lambda-list ,@body))
843
844(defppc32archmacro ccl::%make-sfloat ()
845  `(ccl::%alloc-misc ppc32::single-float.element-count ppc32::subtag-single-float))
846
847(defppc32archmacro ccl::%make-dfloat ()
848  `(ccl::%alloc-misc ppc32::double-float.element-count ppc32::subtag-double-float))
849
850(defppc32archmacro ccl::%numerator (x)
851  `(ccl::%svref ,x ppc32::ratio.numer-cell))
852
853(defppc32archmacro ccl::%denominator (x)
854  `(ccl::%svref ,x ppc32::ratio.denom-cell))
855
856(defppc32archmacro ccl::%realpart (x)
857  `(ccl::%svref ,x ppc32::complex.realpart-cell))
858                   
859(defppc32archmacro ccl::%imagpart (x)
860  `(ccl::%svref ,x ppc32::complex.imagpart-cell))
861
862;;;
863(defppc32archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
864 `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)
865   (ccl::%alloc-misc 1 ppc32::subtag-single-float)))
866
867(defppc32archmacro ccl::codevec-header-p (word)
868  `(eql ppc32::subtag-code-vector
869    (logand ,word ppc32::subtag-mask)))
870
871(defppc32archmacro ccl::immediate-p-macro (thing)
872  (let* ((tag (gensym)))
873    `(let* ((,tag (ccl::lisptag ,thing)))
874      (declare (fixnum ,tag))
875      (or (= ,tag ppc32::tag-fixnum)
876       (= ,tag ppc32::tag-imm)))))
877
878(defppc32archmacro ccl::hashed-by-identity (thing)
879  (let* ((typecode (gensym)))
880    `(let* ((,typecode (ccl::typecode ,thing)))
881      (declare (fixnum ,typecode))
882      (or
883       (= ,typecode ppc32::tag-fixnum)
884       (= ,typecode ppc32::tag-imm)
885       (= ,typecode ppc32::subtag-symbol)
886       (= ,typecode ppc32::subtag-instance)))))
887
888;;;
889(defppc32archmacro ccl::%get-kernel-global (name)
890  `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
891                        ,(%kernel-global
892                          (if (ccl::quoted-form-p name)
893                            (cadr name)
894                            name)))))
895
896(defppc32archmacro ccl::%get-kernel-global-ptr (name dest)
897  `(ccl::%setf-macptr
898    ,dest
899    (ccl::%fixnum-ref-macptr 0 (+ ,(ccl::target-nil-value)
900                                ,(%kernel-global
901                                  (if (ccl::quoted-form-p name)
902                                    (cadr name)
903                                    name))))))
904
905(defppc32archmacro ccl::%target-kernel-global (name)
906  `(ppc32::%kernel-global ,name))
907
908(defppc32archmacro ccl::lfun-vector (fn)
909  fn)
910
911(defppc32archmacro ccl::lfun-vector-lfun (lfv)
912  lfv)
913
914(defppc32archmacro ccl::area-code ()
915  area.code)
916
917(defppc32archmacro ccl::area-succ ()
918  area.succ)
919
920(defppc32archmacro ccl::nth-immediate (f i)
921  `(ccl::%svref ,f ,i))
922
923(defppc32archmacro ccl::set-nth-immediate (f i new)
924  `(setf (ccl::%svref ,f ,i) ,new))
925
926(defppc32archmacro ccl::symptr->symvector (s)
927  s)
928
929(defppc32archmacro ccl::symvector->symptr (s)
930  s)
931
932(defppc32archmacro ccl::function-to-function-vector (f)
933  f)
934
935(defppc32archmacro ccl::function-vector-to-function (v)
936  v)
937
938(defppc32archmacro ccl::with-ffcall-results ((buf) &body body)
939  (let* ((size (+ (* 8 4) (* 31 8))))
940    `(%stack-block ((,buf ,size))
941      ,@body)))
942
943(defconstant arg-check-trap-pc-limit 8)
944
945(defconstant fasl-version #x5f)
946(defconstant fasl-max-version #x5f)
947(defconstant fasl-min-version #x5e)
948(defparameter *image-abi-version* 1037)
949
950(provide "PPC32-ARCH")
Note: See TracBrowser for help on using the repository browser.