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

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

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

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