source: trunk/ccl/compiler/arch.lisp @ 81

Last change on this file since 81 was 81, checked in by gb, 17 years ago

missed a few DEFENUM stragglers

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.7 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(defpackage "PPC32"
17  (:nicknames "ARCH32" "ARCH" "PPC")
18  (:use "CL"))
19
20(in-package "PPC32")
21
22
23(defmacro define-storage-layout (name origin &rest cells)
24  `(progn
25     (ccl::defenum (:start ,origin :step 4)
26       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
27     (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells) 4))))
28 
29(defmacro define-lisp-object (name tagname &rest cells)
30  `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
31
32(defmacro define-subtag (name tag subtag)
33  `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,subtag ntagbits))))
34
35
36(defmacro define-imm-subtag (name subtag)
37  `(define-subtag ,name fulltag-immheader ,subtag))
38
39(defmacro define-node-subtag (name subtag)
40  `(define-subtag ,name fulltag-nodeheader ,subtag))
41
42(defmacro define-fixedsized-object (name  &rest non-header-cells)
43  `(progn
44     (define-lisp-object ,name fulltag-misc header ,@non-header-cells)
45     (ccl::defenum ()
46       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
47     (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
48
49
50
51;; PPC-32 stuff and tags.
52(eval-when (:compile-toplevel :load-toplevel :execute)
53(defconstant nbits-in-word 32)
54(defconstant least-significant-bit 31)
55(defconstant nbits-in-byte 8)
56(defconstant ntagbits 3)                ; But non-header objects only use 2
57(defconstant nlisptagbits 2)
58(defconstant nfixnumtagbits 2)          ; See ?
59(defconstant num-subtag-bits 8)         ; tag part of header is 8 bits wide
60(defconstant fixnumshift nfixnumtagbits)
61(defconstant fixnum-shift fixnumshift)          ; A pet name for it.
62(defconstant fulltagmask (1- (ash 1 ntagbits)))         ; Only needed by GC/very low-level code
63(defconstant full-tag-mask fulltagmask)
64(defconstant tagmask (1- (ash 1 nlisptagbits)))
65(defconstant tag-mask tagmask)
66(defconstant fixnummask (1- (ash 1 nfixnumtagbits)))
67(defconstant fixnum-mask fixnummask)
68(defconstant subtag-mask (1- (ash 1 num-subtag-bits)))
69(defconstant ncharcodebits 16)
70(defconstant charcode-shift (- nbits-in-word ncharcodebits))
71(defconstant word-shift 2)
72
73
74;; Tags.
75;; There are two-bit tags and three-bit tags.
76;; A FULLTAG is the value of the low three bits of a tagged object.
77;; A TAG is the value of the low two bits of a tagged object.
78;; A TYPECODE is either a TAG or the value of a "tag-misc" object's header-byte.
79
80;; There are 4 primary TAG values.  Any object which lisp can "see" can be classified
81;; by its TAG.  (Some headers have FULLTAGS that are congruent modulo 4 with the
82;; TAGS of other objects, but lisp can't "see" headers.)
83(ccl::defenum ()
84  tag-fixnum                            ; All fixnums, whether odd or even
85  tag-list                              ; Conses and NIL
86  tag-misc                              ; Heap-consed objects other than lists: vectors, symbols, functions, floats ...
87  tag-imm                               ; Immediate-objects: characters, UNBOUND, other markers.
88)
89
90;; And there are 8 FULLTAG values.  Note that NIL has its own FULLTAG (congruent mod 4 to tag-list),
91;; that FULLTAG-MISC is > 4 (so that code-vector entry-points can be branched to, since the low
92;; two bits of the PC are ignored) and that both FULLTAG-MISC and FULLTAG-IMM have header fulltags
93;; that share the same TAG.
94;; Things that walk memory (and the stack) have to be careful to look at the FULLTAG of each
95;; object that they see.
96(ccl::defenum ()
97  fulltag-even-fixnum                   ; I suppose EVENP/ODDP might care; nothing else does.
98  fulltag-cons                          ; a real (non-null) cons.  Shares TAG with fulltag-nil.
99  fulltag-nodeheader                    ; Header of heap-allocated object that contains lisp-object pointers
100  fulltag-imm                           ; a "real" immediate object.  Shares TAG with fulltag-immheader.
101  fulltag-odd-fixnum                    ;
102  fulltag-nil                           ; NIL and nothing but.  (Note that there's still a hidden NILSYM.)
103  fulltag-misc                          ; Pointer "real" tag-misc object.  Shares TAG with fulltag-nodeheader.
104  fulltag-immheader                     ; Header of heap-allocated object that contains unboxed data.
105)
106
107
108
109; Order of CAR and CDR doesn't seem to matter much - there aren't
110; too many tricks to be played with predecrement/preincrement addressing.
111; Keep them in the confusing MCL 3.0 order, to avoid confusion.
112(define-lisp-object cons tag-list 
113  cdr 
114  car)
115
116
117(defconstant misc-header-offset (- fulltag-misc))
118(defconstant misc-subtag-offset (+ misc-header-offset 3))
119(defconstant misc-data-offset (+ misc-header-offset 4))
120(defconstant misc-dfloat-offset (+ misc-header-offset 8))
121
122
123
124; T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans
125; two doublewords.  The arithmetic difference between T and NIL is
126; such that the least-significant bit and exactly one other bit is
127; set in the result.
128
129(defconstant t-offset (+ 8 (- 8 fulltag-nil) fulltag-misc))
130(assert (and (logbitp 0 t-offset) (= (logcount t-offset) 2)))
131
132
133; The order in which various header values are defined is significant in several ways:
134; 1) Numeric subtags precede non-numeric ones; there are further orderings among numeric subtags.
135; 2) All subtags which denote CL arrays are preceded by those that don't,
136;    with a further ordering which requires that (< header-arrayH header-vectorH ,@all-other-CL-vector-types)
137; 3) The element-size of ivectors is determined by the ordering of ivector subtags.
138; 4) All subtags are >= fulltag-immheader .
139
140
141; Numeric subtags.
142(define-imm-subtag bignum 0)
143(defconstant min-numeric-subtag subtag-bignum)
144(define-node-subtag ratio 1)
145(defconstant max-rational-subtag subtag-ratio)
146
147(define-imm-subtag single-float 1)          ; "SINGLE" float, aka short-float in the new order.
148(define-imm-subtag double-float 2)
149(defconstant min-float-subtag subtag-single-float)
150(defconstant max-float-subtag subtag-double-float)
151(defconstant max-real-subtag subtag-double-float)
152
153(define-node-subtag complex 3)
154(defconstant max-numeric-subtag subtag-complex)
155
156; CL array types.  There are more immediate types than node types; all CL array subtags must be > than
157; all non-CL-array subtags.  So we start by defining the immediate subtags in decreasing order, starting
158; with that subtag whose element size isn't an integral number of bits and ending with those whose
159; element size - like all non-CL-array fulltag-immheader types - is 32 bits.
160(define-imm-subtag bit-vector 31)
161(define-imm-subtag double-float-vector 30)
162(define-imm-subtag s16-vector 29)
163(define-imm-subtag u16-vector 28)
164(define-imm-subtag simple-general-string 27)
165(defconstant min-16-bit-ivector-subtag subtag-simple-general-string)
166(defconstant max-16-bit-ivector-subtag subtag-s16-vector)
167(defconstant max-string-subtag subtag-simple-general-string)
168
169(define-imm-subtag simple-base-string 26)
170(define-imm-subtag s8-vector 25)
171(define-imm-subtag u8-vector 24)
172(defconstant min-8-bit-ivector-subtag subtag-u8-vector)
173(defconstant max-8-bit-ivector-subtag subtag-simple-base-string)
174(defconstant min-string-subtag subtag-simple-base-string)
175
176(define-imm-subtag s32-vector 23)
177(define-imm-subtag u32-vector 22)
178(define-imm-subtag single-float-vector 21)
179(defconstant max-32-bit-ivector-subtag subtag-s32-vector)
180(defconstant min-cl-ivector-subtag subtag-single-float-vector)
181
182(define-node-subtag vectorH 21)
183(define-node-subtag arrayH 20)
184(assert (< subtag-arrayH subtag-vectorH min-cl-ivector-subtag))
185(define-node-subtag simple-vector 22)   ; Only one such subtag
186(assert (< subtag-arrayH subtag-vectorH subtag-simple-vector))
187(defconstant min-vector-subtag subtag-vectorH)
188(defconstant min-array-subtag subtag-arrayH)
189
190; So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < min-array-subtag))
191; for various immediate/node object types.
192
193(define-imm-subtag macptr 3)
194(defconstant min-non-numeric-imm-subtag subtag-macptr)
195(assert (> min-non-numeric-imm-subtag max-numeric-subtag))
196(define-imm-subtag dead-macptr 4)
197(define-imm-subtag code-vector 5)
198(define-imm-subtag creole-object 6)
199(define-imm-subtag xcode-vector 7)  ; code-vector for cross-development
200
201(defconstant max-non-array-imm-subtag (logior (ash 19 ntagbits) fulltag-immheader))
202
203(define-node-subtag catch-frame 4)
204(defconstant min-non-numeric-node-subtag subtag-catch-frame)
205(assert (> min-non-numeric-node-subtag max-numeric-subtag))
206(define-node-subtag function 5)
207(define-node-subtag lisp-thread 6)
208(define-node-subtag symbol 7)
209(define-node-subtag lock 8)
210(define-node-subtag hash-vector 9)
211(define-node-subtag pool 10)
212(define-node-subtag weak 11)
213(define-node-subtag package 12)
214(define-node-subtag slot-vector 13)
215(define-node-subtag instance 14)
216(define-node-subtag struct 15)
217(define-node-subtag istruct 16)
218(define-node-subtag value-cell 17)
219(define-node-subtag xfunction 18)       ; Function for cross-development
220(define-node-subtag svar 19)
221(defconstant max-non-array-node-subtag (logior (ash 19 ntagbits) fulltag-nodeheader))
222
223
224; The objects themselves look something like this:
225
226(define-fixedsized-object ratio
227  numer
228  denom)
229
230(define-fixedsized-object single-float
231  value)
232
233(define-fixedsized-object double-float
234  pad
235  value
236  val-low)
237
238(define-fixedsized-object complex
239  realpart
240  imagpart
241)
242
243
244; There are two kinds of macptr; use the length field of the header if you
245; need to distinguish between them
246(define-fixedsized-object macptr
247  address
248  domain
249  type
250)
251
252(define-fixedsized-object xmacptr
253  address
254  domain
255  type
256  flags
257  link
258)
259
260; Catch frames go on the tstack; they point to a minimal lisp-frame
261; on the cstack.  (The catch/unwind-protect PC is on the cstack, where
262; the GC expects to find it.)
263(define-fixedsized-object catch-frame
264  catch-tag                             ; #<unbound> -> unwind-protect, else catch
265  link                                  ; tagged pointer to next older catch frame
266  mvflag                                ; 0 if single-value, 1 if uwp or multiple-value
267  csp                                   ; pointer to control stack
268  db-link                               ; value of dynamic-binding link on thread entry.
269  save-save7                            ; saved registers
270  save-save6
271  save-save5
272  save-save4
273  save-save3
274  save-save2
275  save-save1
276  save-save0
277  xframe                                ; exception-frame link
278  tsp-segment                           ; mostly padding, for now.
279)
280
281
282
283 
284(define-fixedsized-object lock
285  _value                                ;finalizable pointer to kernel object
286  kind                                  ; '0 = recursive-lock, '1 = rwlock
287  writer                                ;tcr of owning thread or 0
288  name
289  )
290
291(define-fixedsized-object lisp-thread
292  tcr
293  name
294  cs-size
295  vs-size
296  ts-size
297  initial-function.args
298  interrupt-functions
299  interrupt-lock
300  startup-function
301  state
302  state-change-lock
303)
304
305(define-fixedsized-object symbol
306  pname
307  vcell
308  fcell
309  package-plist
310  flags
311)
312
313
314(defconstant nilsym-offset (+ t-offset symbol.size))
315
316
317(define-fixedsized-object vectorH
318  logsize                               ; fillpointer if it has one, physsize otherwise
319  physsize                              ; total size of (possibly displaced) data vector
320  data-vector                           ; object this header describes
321  displacement                          ; true displacement or 0
322  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
323)
324
325(define-lisp-object arrayH fulltag-misc
326  header                                ; subtag = subtag-arrayH
327  rank                                  ; NEVER 1
328  physsize                              ; total size of (possibly displaced) data vector
329  data-vector                           ; object this header describes
330  displacement                          ; true displacement or 0 
331  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
332 ;; Dimensions follow
333)
334
335(defconstant arrayH.rank-cell 0)
336(defconstant arrayH.physsize-cell 1)
337(defconstant arrayH.data-vector-cell 2)
338(defconstant arrayH.displacement-cell 3)
339(defconstant arrayH.flags-cell 4)
340(defconstant arrayH.dim0-cell 5)
341
342(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
343(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
344
345
346(define-fixedsized-object value-cell
347  value)
348
349(define-fixedsized-object svar
350  symbol
351  idx)
352
353;;; The kernel uses these (rather generically named) structures
354;;; to keep track of various memory regions it (or the lisp) is
355;;; interested in.
356;;; The gc-area record definition in "ccl:interfaces;mcl-records.lisp"
357;;; matches this.
358(define-storage-layout area 0
359  pred                                  ; pointer to preceding area in DLL
360  succ                                  ; pointer to next area in DLL
361  low                                   ; low bound on area addresses
362  high                                  ; high bound on area addresses.
363  active                                ; low limit on stacks, high limit on heaps
364  softlimit                             ; overflow bound
365  hardlimit                             ; another one
366  code                                  ; an area-code; see below
367  markbits                              ; bit vector for GC
368  ndwords                               ; "active" size of dynamic area or stack
369  older                                 ; in EGC sense
370  younger                               ; also for EGC
371  h                                     ; Handle or null pointer
372  softprot                              ; protected_area structure pointer
373  hardprot                              ; another one.
374  owner                                 ; fragment (library) which "owns" the area
375  refbits                               ; bitvector for intergenerational refernces
376  threshold                             ; for egc
377  gc-count                              ; generational gc count.
378)
379
380(define-storage-layout tcr 0
381  prev                                  ; in doubly-linked list
382  next                                  ; in doubly-linked list
383  lisp-fpscr-high
384  lisp-fpscr-low
385  db-link                               ; special binding chain head
386  catch-top                             ; top catch frame
387  save-vsp                              ; VSP when in foreign code
388  save-tsp                              ; TSP when in foreign code
389  cs-area                               ; cstack area pointer
390  vs-area                               ; vstack area pointer
391  ts-area                               ; tstack area pointer
392  cs-limit                              ; cstack overflow limit
393  total-bytes-allocated-high
394  total-bytes-allocated-low
395  interrupt-level                       ; fixnum
396  interrupt-pending                     ; fixnum
397  xframe                                ; exception frame linked list
398  errno-loc                             ; thread-private, maybe
399  ffi-exception                         ; fpscr bits from ff-call.
400  osid                                  ; OS thread id
401  valence                               ; odd when in foreign code
402  foreign-exception-status
403  native-thread-info
404  native-thread-id
405  last-allocptr
406  save-allocptr
407  save-allocbase
408  reset-completion
409  activate
410  suspend-count
411  suspend-context
412  pending-exception-context
413  suspend                               ; semaphore for suspension notify
414  resume                                ; sempahore for resumption notify
415  flags                                 ; foreign, being reset, ...
416  gc-context
417  suspend-total
418  suspend-total-on-exception-entry
419  tlb-limit
420  tlb-pointer
421)
422
423(defconstant tcr-flag-bit-foreign 0)
424(defconstant tcr-flag-bit-awaiting-preset 1)
425
426(define-storage-layout lockptr 0
427  avail
428  owner
429  count
430  signal
431  waiting
432  malloced-ptr)
433
434
435
436(ccl::defenum (:prefix "AREA-")
437  void                                  ; list header
438  cstack                                ; a control stack
439  vstack                                ; a value stack
440  tstack                                ; (dynamic-extent) temp stack
441  readonly                              ; readonly section
442  staticlib                             ; static data in library
443  static                                ; static data in application
444  dynamic                               ; dynmaic (heap) data in application
445)
446
447(define-storage-layout protected-area 0
448  next
449  start                                 ; first byte (page-aligned) that might be protected
450  end                                   ; last byte (page-aligned) that could be protected
451  nprot                                 ; Might be 0
452  protsize                              ; number of bytes to protect
453  why)
454
455; areas are sorted such that (in the "succ" direction) codes are >=.
456; If you think that you're looking for a stack (instead of a heap), look
457; in the "pred" direction from the all-areas header.
458(defconstant max-stack-area-code area-tstack)
459(defconstant min-heap-area-code area-readonly)
460
461(define-subtag unbound fulltag-imm 6)
462(defconstant unbound-marker subtag-unbound)
463(defconstant undefined unbound-marker)
464
465(define-subtag character fulltag-imm 9)
466(define-subtag vsp-protect fulltag-imm 7)
467(define-subtag slot-unbound fulltag-imm 10)
468(defconstant slot-unbound-marker subtag-slot-unbound)
469(define-subtag illegal fulltag-imm 11)
470(defconstant illegal-marker subtag-illegal)
471(define-subtag go-tag fulltag-imm 12)
472(define-subtag block-tag fulltag-imm 24)
473(define-subtag no-thread-local-binding fulltag-imm 30)
474)
475
476(defmacro make-vheader (element-count subtag)
477  `(logior ,subtag (ash ,element-count 8)))
478
479(defmacro ppc-fixnum (val)
480  `(ash ,val fixnum-shift))
481
482(defmacro unbox-ppc-fixnum (f)
483  `(ash ,f (- fixnum-shift)))
484
485
486; Kernel globals are allocated "below" nil.  This list (used to map symbolic names to
487; rnil-relative offsets) must (of course) exactly match the kernel's notion of where
488; things are.
489; The order here matches "ccl:pmcl;lisp_globals.h" & the lisp_globals record
490; in "ccl:pmcl;constants.s"
491(defparameter *ppc-kernel-globals*
492  '(get-tcr                             ; callback to obtain (real) tcr
493    tcr-count
494    interrupt-signal                    ; used by PROCESS-INTERRUPT
495    kernel-imports                      ; some things we need to have imported for us.
496    tcr-lock
497    emulator-registers                  ; Where the 68K registers are kept.
498    appmain                             ; application's (c-runtime) main() function
499    subprims-base                       ; start of dynamic subprims jump table
500    ret1valaddr                         ; magic multiple-values return address.
501    tcr-key                             ; tsd key for thread's tcr
502    gc-lock                             ; serialize access to gc
503    exception-lock                      ; serialize exception handling
504    go-tag-counter                      ; counter for (immediate) go tag
505    block-tag-counter                   ; counter for (immediate) block tag
506    intflag                             ; interrupt-pending flag
507    gc-inhibit-count                    ; for gc locking
508    os-trap-call                        ; callostrapunivesalproc's descriptor
509    tb-trap-call                        ; CallUniversalProc's descriptor
510    qd-globals                          ; (untagged) pointer to QD globals.
511    fwdnum                              ; fixnum: GC "forwarder" call count.
512    gc-count                            ; fixnum: GC call count.
513    gcable-pointers                     ; linked-list of weak macptrs.
514    heap-start                          ; start of lisp heap
515    heap-end                            ; end of lisp heap
516    bad-current-cs                      ; current control-stack area
517    bad-current-vs                      ; current value-stack area
518    bad-current-ts                      ; current temp-stack area
519    bad-cs-overflow-limit               ; limit for control-stack overflow check
520    all-areas                           ; doubly-linked area list
521    lexpr-return                        ; multiple-value lexpr return address
522    lexpr-return1v                      ; single-value lexpr return address
523    in-gc                               ; non-zero when GC-ish thing active
524    metering-info                       ; kernel metering structure
525    doh-head                            ; creole
526    short-float-zero                    ; low half of 1.0d0
527    double-float-one                    ; high half of 1.0d0
528    ffi-exception                       ; ffi fpscr[fex] bit
529    exception-saved-registers           ; saved registers from exception frame
530    oldest-ephemeral                    ; doubleword address of oldest ephemeral object or 0
531    tenured-area                        ; the tenured_area.
532    errno                               ; address of C lib errno
533    argv                                ; address of C lib argv
534    host-platform                       ; 0 on MacOS, 1 on PPC Linux, 2 on VxWorks ...
535    batch-flag                          ; non-zero if --batch specified
536    fpscr-save                          ; lisp's fpscr when in FFI-land
537    fpscr-save-high                     ; high word of FP reg used to save FPSCR
538    image-name                          ; current image name
539    initial-tcr                         ; initial thread's context record
540    ))
541
542(defun %kernel-global (sym)
543  (let* ((pos (position sym *ppc-kernel-globals* :test #'string=)))
544    (if pos
545      (- (+ fulltag-nil (* (1+ pos) 4)))
546      (error "Unknown kernel global : ~s ." sym))))
547
548(defmacro kernel-global (sym)
549  (let* ((pos (position sym *ppc-kernel-globals* :test #'string=)))
550    (if pos
551      (- (+ fulltag-nil (* (1+ pos) 4)))
552      (error "Unknown kernel global : ~s ." sym))))
553
554
555; The kernel imports things that are defined in various other libraries for us.
556; The objects in question are generally fixnum-tagged; the entries in the
557; "kernel-imports" vector are 4 bytes apart.
558(ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step 4)
559  fd-setsize-bytes
560  do-fd-set
561  do-fd-clr
562  do-fd-is-set
563  do-fd-zero
564  MakeDataExecutable
565  GetSharedLibrary
566  FindSymbol
567  malloc
568  free
569  allocate_tstack
570  allocate_vstack
571  register_cstack
572  condemn-area
573  metering-control
574  restore-soft-stack-limit
575  egc-control
576  lisp-bug
577  NewThread
578  YieldToThread
579  DisposeThread
580  ThreadCurrentStackSpace
581  usage-exit
582  save-fp-context
583  restore-fp-context
584  put-altivec-registers
585  get-altivec-registers
586  new-semaphore
587  wait-on-semaphore
588  signal-semaphore
589  destroy-semaphore
590  new-recursive-lock
591  lock-recursive-lock
592  unlock-recursive-lock
593  destroy-recursive-lock
594  suspend-other-threads
595  resume-other-threads
596  suspend-tcr
597  resume-tcr
598  rwlock-new
599  rwlock-destroy
600  rwlock-rlock
601  rwlock-wlock
602  rwlock-unlock
603  recursive-lock-trylock
604  foreign-name-and-offset
605)
606
607(defmacro define-header (name element-count subtag)
608  `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
609
610(define-header single-float-header single-float.element-count subtag-single-float)
611(define-header double-float-header double-float.element-count subtag-double-float)
612(define-header one-digit-bignum-header 1 subtag-bignum)
613(define-header two-digit-bignum-header 2 subtag-bignum)
614(define-header symbol-header symbol.element-count subtag-symbol)
615(define-header value-cell-header value-cell.element-count subtag-value-cell)
616(define-header macptr-header macptr.element-count subtag-macptr)
617
618
619;; Error numbers, as used in UU0s and such.
620;; These match "ccl:pmcl;errors.h" & "ccl:pmcl;errors.s"
621
622(defconstant error-reg-regnum 0)        ; "real" error number is in RB field of UU0.
623                                        ; Currently only used for :errchk in emulated traps
624                                        ; The errchk macro should expand into a check-trap-error vinsn, too.
625(defconstant error-udf 1)               ; Undefined function (reported by symbol-function)
626(defconstant error-udf-call 2)          ; Attempt to call undefined function
627(defconstant error-throw-tag-missing 3)
628(defconstant error-alloc-failed 4)      ; can't allocate (largish) vector
629(defconstant error-stack-overflow 5)    ; some stack overflowed.
630(defconstant error-excised-function-call 6)     ; excised function was called.
631(defconstant error-too-many-values 7)   ; too many values returned
632(defconstant error-cant-take-car 8)
633(defconstant error-cant-take-cdr 9)
634(defconstant error-cant-call 17)        ; Attempt to funcall something that is not a symbol or function.
635(eval-when (:compile-toplevel :load-toplevel :execute)
636  (defconstant error-type-error 64)
637)
638
639(defconstant error-fpu-exception-double 1024)   ; FPU exception, binary double-float op
640(defconstant error-fpu-exception-single 1025)
641
642(defconstant error-memory-full 2048)
643
644;; These are now supposed to match (mod 64) the %type-error-typespecs%
645;; array that %err-disp looks at.
646(ccl::defenum (:start  error-type-error :prefix "ERROR-OBJECT-NOT-")
647  array
648  bignum
649  fixnum
650  character
651  integer
652  list
653  number
654  sequence
655  simple-string
656  simple-vector
657  string
658  symbol
659  macptr
660  real
661  cons
662  unsigned-byte
663  radix
664  float 
665  rational
666  ratio
667  short-float
668  double-float
669  complex
670  vector
671  simple-base-string
672  function
673  unsigned-byte-16
674  unsigned-byte-8
675  unsigned-byte-32
676  signed-byte-32
677  signed-byte-16
678  signed-byte-8
679  base-char
680  bit
681  unsigned-byte-24
682  )
683
684; The order here matches "ccl:pmcl;lisp_globals.h" and the nrs record
685; in "ccl:pmcl;constants.s".
686(defparameter *ppc-nilreg-relative-symbols*
687  '(t
688    nil
689    ccl::%err-disp
690    ccl::cmain
691    eval
692    ccl::apply-evaluated-function
693    error   
694    ccl::%defun
695    ccl::%defvar
696    ccl::%defconstant
697    ccl::%macro
698    ccl::%kernel-restart
699    *package*
700    ccl::*total-bytes-freed*
701    :allow-other-keys   
702    ccl::%toplevel-catch%
703    ccl::%toplevel-function%
704    ccl::%pascal-functions%   
705    ccl::*all-metered-functions*
706    ccl::*total-gc-microseconds*
707    ccl::%builtin-functions%
708    ccl::%unbound-function%
709    ccl::%init-misc
710    ccl::%macro-code%
711    ccl::%closure-code%
712    ccl::%new-gcable-ptr
713    ccl::*gc-event-status-bits*
714    ccl::*post-gc-hook*
715    ccl::%handlers%
716    ccl::%all-packages%
717    ccl::*keyword-package* 
718    ccl::%finalization-alist%
719    ccl::%foreign-thread-control
720    ))
721
722(defmacro nrs-offset (name)
723  (let* ((pos (position name *ppc-nilreg-relative-symbols* :test #'eq)))
724    (if pos (+ t-offset (* pos symbol.size)))))
725
726(defun builtin-function-name-offset (name)
727  (and name (position name ccl::%builtin-functions% :test #'eq)))
728
729(ccl::defenum ()
730  storage-class-lisp                    ; General lisp objects
731  storage-class-imm                     ; Fixnums, chars, NIL: not relocatable
732  storage-class-wordptr                 ; "Raw" (fixnum-tagged) pointers to stack,etc
733  storage-class-u8                      ; Unsigned, untagged, 8-bit objects
734  storage-class-s8                      ; Signed, untagged, 8-bit objects
735  storage-class-u16                     ; Unsigned, untagged, 16-bit objects
736  storage-class-s16                     ; Signed, untagged, 16-bit objects
737  storage-class-u32                     ; Unsigned, untagged, 8-bit objects
738  storage-class-s32                     ; Signed, untagged, 8-bit objects
739  storage-class-address                 ; "raw" (untagged) 32-bit addresses.
740  storage-class-single-float            ; 32-bit single-float objects
741  storage-class-double-float            ; 64-bit double-float objects
742  storage-class-pc                      ; pointer to/into code vector
743  storage-class-locative                ; pointer to/into node-misc object
744  storage-class-crf                     ; condition register field
745  storage-class-crbit                   ; condition register bit: 0-31
746  storage-class-crfbit                  ; bit within condition register field : 0-3
747)
748
749;; For assembly/disassembly, at least on RISC platforms.
750(defstruct opcode 
751  (name (error "Opcode name must be present") :type (or string symbol))
752  (opcode 0 :type (unsigned-byte 32))
753  (majorop 0 :type (unsigned-byte 6))
754  (mask #xffffffff :type (unsigned-byte 32))
755  (flags 0 :type (unsigned-byte 32))
756  (operands () :type list)
757  (min-args 0 :type (unsigned-byte 3))
758  (max-args 0 :type (unsigned-byte 3))
759  (op-high 0 :type (unsigned-byte 16))
760  (op-low 0 :type (unsigned-byte 16))
761  (mask-high #xffff :type (unsigned-byte 16))
762  (mask-low #xffff :type (unsigned-byte 16))
763  (vinsn-operands () :type list)
764  (min-vinsn-args 0 :type fixnum)
765  (max-vinsn-args 0 :type fixnum))
766
767(defmethod print-object ((p opcode) stream)
768  (declare (ignore depth))
769  (print-unreadable-object (p stream :type t) 
770    (format stream "~a" (string (opcode-name p)))))
771
772(defmethod make-load-form ((p opcode) &optional env)
773  (make-load-form-saving-slots p :environment env))
774
775(defstruct operand
776  (index 0 :type unsigned-byte)
777  (width 0 :type (mod 32))
778  (offset 0 :type (mod 32))
779  (insert-function nil :type (or null symbol function))
780  (extract-function 'nil :type (or symbol function))
781  (flags 0 :type fixnum))
782
783(defmethod make-load-form ((o operand) &optional env)
784  (make-load-form-saving-slots o :environment env))
785
786(defconstant operand-optional 27)
787(defconstant operand-fake 28)
788
789(defconstant reservation-discharge #x1004)
790
791(ccl::provide "ARCH")
Note: See TracBrowser for help on using the repository browser.