close Warning: Can't use blame annotator: 
No changeset 1586 in the repository

source: release/1.4/source/compiler/PPC/PPC32/ppc32-arch.lisp

Last change on this file was 13075, checked in by R. Matthew Emerson, 15 years ago

Merge trunk changes r13066 through r13067.
(copyright notices)
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 33.6 KB
RevLine 
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 jvm-init
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(provide "PPC32-ARCH")
Note: See TracBrowser for help on using the repository browser.