Changeset 188

Timestamp:

Jan 3, 2004, 11:49:34 AM (21 years ago)

Author:

Gary Byers

Message:

Try to be more ppc32-specific.

File:

• trunk/ccl/compiler/PPC/PPC32/ppc32-arch.lisp (modified) (5 diffs)

trunk/ccl/compiler/PPC/PPC32/ppc32-arch.lisp

@@ -18 +18 @@
 ;; This file matches "ccl:pmcl;constants.h" & "ccl:pmcl;constants.s"
 
+(in-package "PPC32")
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (require "ARCH"))
+  (require "PPC-ARCH"))
 
 
@@ -25 +27 @@
 
 
+(defmacro define-storage-layout (name origin &rest cells)
+  `(progn
+     (ccl::defenum (:start ,origin :step (ash 1 ppc32::word-shift))
+       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
+     (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells)
+                                                       (ash 1 ppc32::word-shift)))))
+ 
+(defmacro define-lisp-object (name tagname &rest cells)
+  `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
+
+(defmacro define-subtag (name tag subtag)
+  `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,subtag ntagbits))))
+
+
+(defmacro define-imm-subtag (name subtag)
+  `(define-subtag ,name fulltag-immheader ,subtag))
+
+(defmacro define-node-subtag (name subtag)
+  `(define-subtag ,name fulltag-nodeheader ,subtag))
+
+(defmacro define-fixedsized-object (name &rest non-header-cells)
+  `(progn
+     (define-lisp-object ,name fulltag-misc header ,@non-header-cells)
+     (ccl::defenum ()
+       ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
+     (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defconstant nbits-in-word 32)
+(defconstant least-significant-bit 31)
+(defconstant nbits-in-byte 8)
+(defconstant ntagbits 3)                ; But non-header objects only use 2
+(defconstant nlisptagbits 2)
+(defconstant nfixnumtagbits 2)          ; See ?
+(defconstant num-subtag-bits 8)         ; tag part of header is 8 bits wide
+(defconstant fixnumshift nfixnumtagbits)
+(defconstant fixnum-shift fixnumshift)          ; A pet name for it.
+(defconstant fulltagmask (1- (ash 1 ntagbits)))         ; Only needed by GC/very low-level code
+(defconstant full-tag-mask fulltagmask)
+(defconstant tagmask (1- (ash 1 nlisptagbits)))
+(defconstant tag-mask tagmask)
+(defconstant fixnummask (1- (ash 1 nfixnumtagbits)))
+(defconstant fixnum-mask fixnummask)
+(defconstant subtag-mask (1- (ash 1 num-subtag-bits)))
+(defconstant ncharcodebits 16)
+(defconstant charcode-shift (- nbits-in-word ncharcodebits))
+(defconstant word-shift 2)
+
 
 ;; PPC-32 stuff and tags.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-
-;;; Lisp registers.
-(eval-when (:compile-toplevel :execute)
-  (defmacro defregs (&body regs)
-    `(progn
-       (ccl::defenum () ,@regs)
-       (defparameter *gpr-register-names* ,(coerce (mapcar #'string regs) 'vector))))
-  (defmacro deffpregs (&body regs)
-    `(progn
-       (ccl::defenum () ,@regs)
-       (defparameter *fpr-register-names* ,(coerce (mapcar #'string regs) 'vector))))
-  (defmacro defvregs (&body regs)
-    `(progn
-      (ccl::defenum () ,@regs)
-      (defparameter *vector-register-names* ,(coerce (mapcar #'string regs) 'vector))
-      )))
-
-(defregs
-    rzero                               ; Always contains 0; not as handy as it sounds.
-    sp                                  ; The control stack.  Aligned on 16-byte boundary.
-  rcontext                              ; thread context
-  imm0                                  ; Unboxed, volatile registers.
-  imm1 
-  imm2 
-  imm3 
-  imm4
-  imm5
-  allocptr
-  allocbase
-  nargs                                 ; Volatile.  SHOULDN'T be used for tag extraction. (TWI handler confusion.)
-  tsp                                   ; Temp-stack pointer.
-  vsp                                   ; Value stack pointer; grows towards 0.
-  loc-pc                                ; for return PC only.
-  fn                                    ; Current function (constants vector).
-  temp4                                 ; Boxed, volatile registers.  Some
-                                        ; may be defined on function entry.
-  temp3
-  temp2 
-  temp1 
-  temp0 
-  arg_x                                 ; Next-to-next-to-last function arg.
-  arg_y                                 ; Next-to-last function argument.
-  arg_z                                 ; Last function argument.
-  save7                                 ; Boxed, nonvolatile registers.
-  save6
-  save5
-  save4 
-  save3 
-  save2 
-  save1 
-  save0
-  )
+
+;; Tags.
+;; There are two-bit tags and three-bit tags.
+;; A FULLTAG is the value of the low three bits of a tagged object.
+;; A TAG is the value of the low two bits of a tagged object.
+;; A TYPECODE is either a TAG or the value of a "tag-misc" object's header-byte.
+
+;; There are 4 primary TAG values.  Any object which lisp can "see" can be classified 
+;; by its TAG.  (Some headers have FULLTAGS that are congruent modulo 4 with the
+;; TAGS of other objects, but lisp can't "see" headers.)
+(ccl::defenum ()
+  tag-fixnum                            ; All fixnums, whether odd or even
+  tag-list                              ; Conses and NIL
+  tag-misc                              ; Heap-consed objects other than lists: vectors, symbols, functions, floats ...
+  tag-imm                               ; Immediate-objects: characters, UNBOUND, other markers.
+)
+
+;; And there are 8 FULLTAG values.  Note that NIL has its own FULLTAG (congruent mod 4 to tag-list),
+;; that FULLTAG-MISC is > 4 (so that code-vector entry-points can be branched to, since the low
+;; two bits of the PC are ignored) and that both FULLTAG-MISC and FULLTAG-IMM have header fulltags
+;; that share the same TAG.
+;; Things that walk memory (and the stack) have to be careful to look at the FULLTAG of each
+;; object that they see.
+(ccl::defenum ()
+  fulltag-even-fixnum                   ; I suppose EVENP/ODDP might care; nothing else does.
+  fulltag-cons                          ; a real (non-null) cons.  Shares TAG with fulltag-nil.
+  fulltag-nodeheader                    ; Header of heap-allocated object that contains lisp-object pointers
+  fulltag-imm                           ; a "real" immediate object.  Shares TAG with fulltag-immheader.
+  fulltag-odd-fixnum                    ; 
+  fulltag-nil                           ; NIL and nothing but.  (Note that there's still a hidden NILSYM.)
+  fulltag-misc                          ; Pointer "real" tag-misc object.  Shares TAG with fulltag-nodeheader.
+  fulltag-immheader                     ; Header of heap-allocated object that contains unboxed data.
+)
+
+(defconstant misc-header-offset (- fulltag-misc))
+(defconstant misc-subtag-offset (+ misc-header-offset 3))
+(defconstant misc-data-offset (+ misc-header-offset 4))
+(defconstant misc-dfloat-offset (+ misc-header-offset 8))
+
+
+
+
+
 
 (defconstant nil-value #x00002015)
-
-(deffpregs 
-  fp0
-  fp1
-  fp2
-  fp3
-  fp4
-  fp5
-  fp6
-  fp7
-  fp8
-  fp9
-  fp10
-  fp11
-  fp12
-  fp13
-  fp14
-  fp15
-  fp16
-  fp17
-  fp18
-  fp19
-  fp20
-  fp21
-  fp22
-  fp23
-  fp24
-  fp25
-  fp26
-  fp27
-  fp28
-  fp29
-  fp30
-  fp31)
-
-(defvregs
-  vr0                                   ; General temp vector register
-  vr1                                   ; Most-significant quadword when word-aligning
-  vr2                                   ; Least-significant quadword when word-aligning
-  vr3                                   ; Operand A resulting from word-aligning
-  vr4                                   ; Operand B resulting from word-aligning
-  vr5                                   ; Result from operations on A and B
-  vr6
-  vr7
-  vr8
-  vr9
-  vr10
-  vr11
-  vr12
-  vr13
-  vr14
-  vr15
-  vr16
-  vr17
-  vr18
-  vr19
-  ;;By convention, registers after this point are considered non-volatile. Callee should save.
-  vr20
-  vr21
-  vr22
-  vr23
-  vr24
-  vr25
-  vr26
-  vr27                                  ; Permutation control register A for loads
-  vr28                                  ; Permutation control register B for stores
-  vr29                                  ; mask register
-  vr30                                  ; All zeros
-  vr31                                  ; All ones
-  )
-
-
-(defconstant fname temp3)
-
-;;; Calling sequence may pass additional arguments in temp registers.
-;;; "nfn" (new function) is always passed; it's the new value of "fn".
-(defconstant nfn temp2)
-
-;;; CLOS may pass the context for, e.g.., CALL-NEXT-METHOD in 
-;;;; the "next-method-context" register.
-(defconstant next-method-context temp1)
-
-
-;;; It's handy to have 0.0 in an fpr.
-(defconstant fp-zero fp31)
-
-; Also handy to have #x4330000080000000 in an fpr, for s32->float conversion.
-(defconstant fp-s32conv fp30)
-
-
+; T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans
+; two doublewords.  The arithmetic difference between T and NIL is
+; such that the least-significant bit and exactly one other bit is
+; set in the result.
+
+(defconstant t-offset (+ 8 (- 8 fulltag-nil) fulltag-misc))
+(assert (and (logbitp 0 t-offset) (= (logcount t-offset) 2)))
+
+; The order in which various header values are defined is significant in several ways:
+; 1) Numeric subtags precede non-numeric ones; there are further orderings among numeric subtags.
+; 2) All subtags which denote CL arrays are preceded by those that don't,
+;    with a further ordering which requires that (< header-arrayH header-vectorH ,@all-other-CL-vector-types)
+; 3) The element-size of ivectors is determined by the ordering of ivector subtags.
+; 4) All subtags are >= fulltag-immheader .
+
+
+; Numeric subtags.
+(define-imm-subtag bignum 0)
+(defconstant min-numeric-subtag subtag-bignum)
+(define-node-subtag ratio 1)
+(defconstant max-rational-subtag subtag-ratio)
+
+(define-imm-subtag single-float 1)          ; "SINGLE" float, aka short-float in the new order.
+(define-imm-subtag double-float 2)
+(defconstant min-float-subtag subtag-single-float)
+(defconstant max-float-subtag subtag-double-float)
+(defconstant max-real-subtag subtag-double-float)
+
+(define-node-subtag complex 3)
+(defconstant max-numeric-subtag subtag-complex)
+
+; CL array types.  There are more immediate types than node types; all CL array subtags must be > than
+; all non-CL-array subtags.  So we start by defining the immediate subtags in decreasing order, starting
+; with that subtag whose element size isn't an integral number of bits and ending with those whose
+; element size - like all non-CL-array fulltag-immheader types - is 32 bits.
+(define-imm-subtag bit-vector 31)
+(define-imm-subtag double-float-vector 30)
+(define-imm-subtag s16-vector 29)
+(define-imm-subtag u16-vector 28)
+(define-imm-subtag simple-general-string 27)
+(defconstant min-16-bit-ivector-subtag subtag-simple-general-string)
+(defconstant max-16-bit-ivector-subtag subtag-s16-vector)
+(defconstant max-string-subtag subtag-simple-general-string)
+
+(define-imm-subtag simple-base-string 26)
+(define-imm-subtag s8-vector 25)
+(define-imm-subtag u8-vector 24)
+(defconstant min-8-bit-ivector-subtag subtag-u8-vector)
+(defconstant max-8-bit-ivector-subtag subtag-simple-base-string)
+(defconstant min-string-subtag subtag-simple-base-string)
+
+(define-imm-subtag s32-vector 23)
+(define-imm-subtag u32-vector 22)
+(define-imm-subtag single-float-vector 21)
+(defconstant max-32-bit-ivector-subtag subtag-s32-vector)
+(defconstant min-cl-ivector-subtag subtag-single-float-vector)
+
+(define-node-subtag vectorH 21)
+(define-node-subtag arrayH 20)
+(assert (< subtag-arrayH subtag-vectorH min-cl-ivector-subtag))
+(define-node-subtag simple-vector 22)   ; Only one such subtag
+(assert (< subtag-arrayH subtag-vectorH subtag-simple-vector))
+(defconstant min-vector-subtag subtag-vectorH)
+(defconstant min-array-subtag subtag-arrayH)
+
+; So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < min-array-subtag))
+; for various immediate/node object types.
+
+(define-imm-subtag macptr 3)
+(defconstant min-non-numeric-imm-subtag subtag-macptr)
+(assert (> min-non-numeric-imm-subtag max-numeric-subtag))
+(define-imm-subtag dead-macptr 4)
+(define-imm-subtag code-vector 5)
+(define-imm-subtag creole-object 6)
+(define-imm-subtag xcode-vector 7)  ; code-vector for cross-development
+
+(defconstant max-non-array-imm-subtag (logior (ash 19 ntagbits) fulltag-immheader))
+
+(define-node-subtag catch-frame 4)
+(defconstant min-non-numeric-node-subtag subtag-catch-frame)
+(assert (> min-non-numeric-node-subtag max-numeric-subtag))
+(define-node-subtag function 5)
+(define-node-subtag lisp-thread 6)
+(define-node-subtag symbol 7)
+(define-node-subtag lock 8)
+(define-node-subtag hash-vector 9)
+(define-node-subtag pool 10)
+(define-node-subtag weak 11)
+(define-node-subtag package 12)
+(define-node-subtag slot-vector 13)
+(define-node-subtag instance 14)
+(define-node-subtag struct 15)
+(define-node-subtag istruct 16)
+(define-node-subtag value-cell 17)
+(define-node-subtag xfunction 18)       ; Function for cross-development
+(define-node-subtag svar 19)
+(defconstant max-non-array-node-subtag (logior (ash 19 ntagbits) fulltag-nodeheader))
+
+(define-subtag character fulltag-imm 9)
+(define-subtag vsp-protect fulltag-imm 7)
+(define-subtag slot-unbound fulltag-imm 10)
+(defconstant slot-unbound-marker subtag-slot-unbound)
+(define-subtag illegal fulltag-imm 11)
+(defconstant illegal-marker subtag-illegal)
+(define-subtag go-tag fulltag-imm 12)
+(define-subtag block-tag fulltag-imm 24)
+(define-subtag no-thread-local-binding fulltag-imm 30)
+(define-subtag unbound fulltag-imm 6)
+(defconstant unbound-marker subtag-unbound)
+(defconstant undefined unbound-marker)
 
 
@@ -184 +244 @@
 ; The objects themselves look something like this:
 
+; Order of CAR and CDR doesn't seem to matter much - there aren't
+; too many tricks to be played with predecrement/preincrement addressing.
+; Keep them in the confusing MCL 3.0 order, to avoid confusion.
+(define-lisp-object cons tag-list 
+  cdr 
+  car)
+
+
+(define-fixedsized-object ratio
+  numer
+  denom)
+
+(define-fixedsized-object single-float
+  value)
+
+(define-fixedsized-object double-float
+  pad
+  value
+  val-low)
+
+(define-fixedsized-object complex
+  realpart
+  imagpart
+)
+
+
+; There are two kinds of macptr; use the length field of the header if you
+; need to distinguish between them
+(define-fixedsized-object macptr
+  address
+  domain
+  type
+)
+
+(define-fixedsized-object xmacptr
+  address
+  domain
+  type
+  flags
+  link
+)
+
+; Catch frames go on the tstack; they point to a minimal lisp-frame
+; on the cstack.  (The catch/unwind-protect PC is on the cstack, where
+; the GC expects to find it.)
+(define-fixedsized-object catch-frame
+  catch-tag                             ; #<unbound> -> unwind-protect, else catch
+  link                                  ; tagged pointer to next older catch frame
+  mvflag                                ; 0 if single-value, 1 if uwp or multiple-value
+  csp                                   ; pointer to control stack
+  db-link                               ; value of dynamic-binding link on thread entry.
+  save-save7                            ; saved registers
+  save-save6
+  save-save5
+  save-save4
+  save-save3
+  save-save2
+  save-save1
+  save-save0
+  xframe                                ; exception-frame link
+  tsp-segment                           ; mostly padding, for now.
+)
+
+(define-fixedsized-object lock
+  _value                                ;finalizable pointer to kernel object
+  kind                                  ; '0 = recursive-lock, '1 = rwlock
+  writer                                ;tcr of owning thread or 0
+  name
+  )
+
+(define-fixedsized-object lisp-thread
+  tcr
+  name
+  cs-size
+  vs-size
+  ts-size
+  initial-function.args
+  interrupt-functions
+  interrupt-lock
+  startup-function
+  state
+  state-change-lock
+)
+
+(define-fixedsized-object symbol
+  pname
+  vcell
+  fcell
+  package-plist
+  flags
+)
+
+
+(defconstant nilsym-offset (+ t-offset symbol.size))
+
+
+(define-fixedsized-object vectorH
+  logsize                               ; fillpointer if it has one, physsize otherwise
+  physsize                              ; total size of (possibly displaced) data vector
+  data-vector                           ; object this header describes
+  displacement                          ; true displacement or 0
+  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
+)
+
+(define-lisp-object arrayH fulltag-misc
+  header                                ; subtag = subtag-arrayH
+  rank                                  ; NEVER 1
+  physsize                              ; total size of (possibly displaced) data vector
+  data-vector                           ; object this header describes
+  displacement                          ; true displacement or 0  
+  flags                                 ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
+ ;; Dimensions follow
+)
+
+(defconstant arrayH.rank-cell 0)
+(defconstant arrayH.physsize-cell 1)
+(defconstant arrayH.data-vector-cell 2)
+(defconstant arrayH.displacement-cell 3)
+(defconstant arrayH.flags-cell 4)
+(defconstant arrayH.dim0-cell 5)
+
+(defconstant arrayH.flags-cell-bits-byte (byte 8 0))
+(defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
+
+
+(define-fixedsized-object value-cell
+  value)
+
+(define-fixedsized-object svar
+  symbol
+  idx)
+
+;;; The kernel uses these (rather generically named) structures
+;;; to keep track of various memory regions it (or the lisp) is
+;;; interested in.
+;;; The gc-area record definition in "ccl:interfaces;mcl-records.lisp"
+;;; matches this.
+
+(define-storage-layout area 0
+  pred                                  ; pointer to preceding area in DLL
+  succ                                  ; pointer to next area in DLL
+  low                                   ; low bound on area addresses
+  high                                  ; high bound on area addresses.
+  active                                ; low limit on stacks, high limit on heaps
+  softlimit                             ; overflow bound
+  hardlimit                             ; another one
+  code                                  ; an area-code; see below
+  markbits                              ; bit vector for GC
+  ndwords                               ; "active" size of dynamic area or stack
+  older                                 ; in EGC sense
+  younger                               ; also for EGC
+  h                                     ; Handle or null pointer
+  softprot                              ; protected_area structure pointer
+  hardprot                              ; another one.
+  owner                                 ; fragment (library) which "owns" the area
+  refbits                               ; bitvector for intergenerational refernces
+  threshold                             ; for egc
+  gc-count                              ; generational gc count.
+)
+
+(ccl::defenum (:prefix "AREA-")
+  void                                  ; list header
+  cstack                                ; a control stack
+  vstack                                ; a value stack
+  tstack                                ; (dynamic-extent) temp stack
+  readonly                              ; readonly section
+  staticlib                             ; static data in library
+  static                                ; static data in application
+  dynamic                               ; dynmaic (heap) data in application
+)
+
+
+; areas are sorted such that (in the "succ" direction) codes are >=.
+; If you think that you're looking for a stack (instead of a heap), look
+; in the "pred" direction from the all-areas header.
+(defconstant max-stack-area-code area-tstack)
+(defconstant min-heap-area-code area-readonly)
+
+
+(define-storage-layout protected-area 0
+  next
+  start                                 ; first byte (page-aligned) that might be protected
+  end                                   ; last byte (page-aligned) that could be protected
+  nprot                                 ; Might be 0
+  protsize                              ; number of bytes to protect
+  why)
+
+(define-storage-layout tcr 0
+  prev                                  ; in doubly-linked list 
+  next                                  ; in doubly-linked list 
+  lisp-fpscr-high
+  lisp-fpscr-low
+  db-link                               ; special binding chain head 
+  catch-top                             ; top catch frame 
+  save-vsp                              ; VSP when in foreign code 
+  save-tsp                              ; TSP when in foreign code 
+  cs-area                               ; cstack area pointer 
+  vs-area                               ; vstack area pointer 
+  ts-area                               ; tstack area pointer 
+  cs-limit                              ; cstack overflow limit
+  total-bytes-allocated-high
+  total-bytes-allocated-low
+  interrupt-level                       ; fixnum
+  interrupt-pending                     ; fixnum
+  xframe                                ; exception frame linked list
+  errno-loc                             ; thread-private, maybe
+  ffi-exception                         ; fpscr bits from ff-call.
+  osid                                  ; OS thread id 
+  valence                               ; odd when in foreign code 
+  foreign-exception-status
+  native-thread-info
+  native-thread-id
+  last-allocptr
+  save-allocptr
+  save-allocbase
+  reset-completion
+  activate
+  suspend-count
+  suspend-context
+  pending-exception-context
+  suspend                               ; semaphore for suspension notify 
+  resume                                ; sempahore for resumption notify
+  flags                                 ; foreign, being reset, ...
+  gc-context
+  suspend-total
+  suspend-total-on-exception-entry
+  tlb-limit
+  tlb-pointer
+)
+
+(define-storage-layout lockptr 0
+  avail
+  owner
+  count
+  signal
+  waiting
+  malloced-ptr)
 
 ;; For the eabi port: mark this stack frame as Lisp's (since EABI
@@ -233 +530 @@
 
 
-
-
-
-(ccl::defenum (:prefix "PPC-" :suffix "-BIT")
-  lt
-  gt
-  eq
-  so
-)
-
-
-(ccl::defenum (:prefix "FPSCR-" :suffix "-BIT")
-  fx
-  fex
-  vx
-  ox
-  ux
-  zx
-  xx
-  vxsnan
-  vxisi
-  vxidi
-  vxzdz
-  vximz
-  vxvc
-  fr
-  fi
-  fprfc
-  fl
-  fg
-  fe
-  fu
-  nil
-  vxsoft
-  vxsqrt
-  vxcvi
-  ve
-  oe
-  ue
-  ze
-  xe
-  ni
-  rn0
-  rn1
-)
-
 (defconstant yield-syscall
   #+darwinppc-target -60
@@ -284 +535 @@
 )
 
+
 (provide "PPC32-ARCH")