| 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 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 | )
|
|---|
| 326 |
|
|---|
| 327 |
|
|---|
| 328 |
|
|---|
| 329 | (define-fixedsized-object symbol
|
|---|
| 330 | pname
|
|---|
| 331 | vcell
|
|---|
| 332 | fcell
|
|---|
| 333 | package-predicate
|
|---|
| 334 | flags
|
|---|
| 335 | plist
|
|---|
| 336 | binding-index
|
|---|
| 337 | )
|
|---|
| 338 |
|
|---|
| 339 |
|
|---|
| 340 |
|
|---|
| 341 | (defconstant nilsym-offset (+ t-offset symbol.size))
|
|---|
| 342 |
|
|---|
| 343 |
|
|---|
| 344 | (define-fixedsized-object vectorH
|
|---|
| 345 | logsize ; fillpointer if it has one, physsize otherwise
|
|---|
| 346 | physsize ; total size of (possibly displaced) data vector
|
|---|
| 347 | data-vector ; object this header describes
|
|---|
| 348 | displacement ; true displacement or 0
|
|---|
| 349 | flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
|
|---|
| 350 | )
|
|---|
| 351 |
|
|---|
| 352 | (define-lisp-object arrayH fulltag-misc
|
|---|
| 353 | header ; subtag = subtag-arrayH
|
|---|
| 354 | rank ; NEVER 1
|
|---|
| 355 | physsize ; total size of (possibly displaced) data vector
|
|---|
| 356 | data-vector ; object this header describes
|
|---|
| 357 | displacement ; true displacement or 0
|
|---|
| 358 | flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
|
|---|
| 359 | ;; Dimensions follow
|
|---|
| 360 | )
|
|---|
| 361 |
|
|---|
| 362 | (defconstant arrayH.rank-cell 0)
|
|---|
| 363 | (defconstant arrayH.physsize-cell 1)
|
|---|
| 364 | (defconstant arrayH.data-vector-cell 2)
|
|---|
| 365 | (defconstant arrayH.displacement-cell 3)
|
|---|
| 366 | (defconstant arrayH.flags-cell 4)
|
|---|
| 367 | (defconstant arrayH.dim0-cell 5)
|
|---|
| 368 |
|
|---|
| 369 | (defconstant arrayH.flags-cell-bits-byte (byte 8 0))
|
|---|
| 370 | (defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
|
|---|
| 371 |
|
|---|
| 372 |
|
|---|
| 373 | (define-fixedsized-object value-cell
|
|---|
| 374 | value)
|
|---|
| 375 |
|
|---|
| 376 | ;;; The kernel uses these (rather generically named) structures
|
|---|
| 377 | ;;; to keep track of various memory regions it (or the lisp) is
|
|---|
| 378 | ;;; interested in.
|
|---|
| 379 | ;;; The gc-area record definition in "ccl:interfaces;mcl-records.lisp"
|
|---|
| 380 | ;;; matches this.
|
|---|
| 381 |
|
|---|
| 382 | (define-storage-layout area 0
|
|---|
| 383 | pred ; pointer to preceding area in DLL
|
|---|
| 384 | succ ; pointer to next area in DLL
|
|---|
| 385 | low ; low bound on area addresses
|
|---|
| 386 | high ; high bound on area addresses.
|
|---|
| 387 | active ; low limit on stacks, high limit on heaps
|
|---|
| 388 | softlimit ; overflow bound
|
|---|
| 389 | hardlimit ; another one
|
|---|
| 390 | code ; an area-code; see below
|
|---|
| 391 | markbits ; bit vector for GC
|
|---|
| 392 | ndnodes ; "active" size of dynamic area or stack
|
|---|
| 393 | older ; in EGC sense
|
|---|
| 394 | younger ; also for EGC
|
|---|
| 395 | h ; Handle or null pointer
|
|---|
| 396 | softprot ; protected_area structure pointer
|
|---|
| 397 | hardprot ; another one.
|
|---|
| 398 | owner ; fragment (library) which "owns" the area
|
|---|
| 399 | refbits ; bitvector for intergenerational refernces
|
|---|
| 400 | threshold ; for egc
|
|---|
| 401 | gc-count ; generational gc count.
|
|---|
| 402 | static-dnodes ; for honsing, etc.
|
|---|
| 403 | static-used ; bitvector
|
|---|
| 404 | )
|
|---|
| 405 |
|
|---|
| 406 |
|
|---|
| 407 | (define-storage-layout protected-area 0
|
|---|
| 408 | next
|
|---|
| 409 | start ; first byte (page-aligned) that might be protected
|
|---|
| 410 | end ; last byte (page-aligned) that could be protected
|
|---|
| 411 | nprot ; Might be 0
|
|---|
| 412 | protsize ; number of bytes to protect
|
|---|
| 413 | why)
|
|---|
| 414 |
|
|---|
| 415 | (defconstant tcr-bias 0)
|
|---|
| 416 |
|
|---|
| 417 | (define-storage-layout tcr (- tcr-bias)
|
|---|
| 418 | prev ; in doubly-linked list
|
|---|
| 419 | next ; in doubly-linked list
|
|---|
| 420 | lisp-fpscr-high
|
|---|
| 421 | lisp-fpscr-low
|
|---|
| 422 | db-link ; special binding chain head
|
|---|
| 423 | catch-top ; top catch frame
|
|---|
| 424 | save-vsp ; VSP when in foreign code
|
|---|
| 425 | save-tsp ; TSP when in foreign code
|
|---|
| 426 | cs-area ; cstack area pointer
|
|---|
| 427 | vs-area ; vstack area pointer
|
|---|
| 428 | ts-area ; tstack area pointer
|
|---|
| 429 | cs-limit ; cstack overflow limit
|
|---|
| 430 | total-bytes-allocated-high
|
|---|
| 431 | total-bytes-allocated-low
|
|---|
| 432 | log2-allocation-quantum ; unboxed
|
|---|
| 433 | interrupt-pending ; fixnum
|
|---|
| 434 | xframe ; exception frame linked list
|
|---|
| 435 | errno-loc ; thread-private, maybe
|
|---|
| 436 | ffi-exception ; fpscr bits from ff-call.
|
|---|
| 437 | osid ; OS thread id
|
|---|
| 438 | valence ; odd when in foreign code
|
|---|
| 439 | foreign-exception-status
|
|---|
| 440 | native-thread-info
|
|---|
| 441 | native-thread-id
|
|---|
| 442 | last-allocptr
|
|---|
| 443 | save-allocptr
|
|---|
| 444 | save-allocbase
|
|---|
| 445 | reset-completion
|
|---|
| 446 | activate
|
|---|
| 447 | suspend-count
|
|---|
| 448 | suspend-context
|
|---|
| 449 | pending-exception-context
|
|---|
| 450 | suspend ; semaphore for suspension notify
|
|---|
| 451 | resume ; sempahore for resumption notify
|
|---|
| 452 | flags ; foreign, being reset, ...
|
|---|
| 453 | gc-context
|
|---|
| 454 | termination-semaphore
|
|---|
| 455 | unwinding
|
|---|
| 456 | tlb-limit
|
|---|
| 457 | tlb-pointer
|
|---|
| 458 | shutdown-count
|
|---|
| 459 | safe-ref-address
|
|---|
| 460 | )
|
|---|
| 461 |
|
|---|
| 462 | (defconstant interrupt-level-binding-index (ash 1 fixnumshift))
|
|---|
| 463 |
|
|---|
| 464 | (define-storage-layout lockptr 0
|
|---|
| 465 | avail
|
|---|
| 466 | owner
|
|---|
| 467 | count
|
|---|
| 468 | signal
|
|---|
| 469 | waiting
|
|---|
| 470 | malloced-ptr
|
|---|
| 471 | spinlock)
|
|---|
| 472 |
|
|---|
| 473 | ;;; For the eabi port: mark this stack frame as Lisp's (since EABI
|
|---|
| 474 | ;;; foreign frames can be the same size as a lisp frame.)
|
|---|
| 475 |
|
|---|
| 476 |
|
|---|
| 477 | (ppc32::define-storage-layout lisp-frame 0
|
|---|
| 478 | backlink
|
|---|
| 479 | savefn
|
|---|
| 480 | savelr
|
|---|
| 481 | savevsp
|
|---|
| 482 | )
|
|---|
| 483 |
|
|---|
| 484 | (ppc32::define-storage-layout c-frame 0
|
|---|
| 485 | backlink
|
|---|
| 486 | crsave
|
|---|
| 487 | savelr
|
|---|
| 488 | unused-1
|
|---|
| 489 | unused-2
|
|---|
| 490 | savetoc
|
|---|
| 491 | param0
|
|---|
| 492 | param1
|
|---|
| 493 | param2
|
|---|
| 494 | param3
|
|---|
| 495 | param4
|
|---|
| 496 | param5
|
|---|
| 497 | param6
|
|---|
| 498 | param7
|
|---|
| 499 | )
|
|---|
| 500 |
|
|---|
| 501 | (defconstant c-frame.minsize c-frame.size)
|
|---|
| 502 |
|
|---|
| 503 | ;;; .SPeabi-ff-call "shrinks" this frame after loading the GPRs.
|
|---|
| 504 | (ppc32::define-storage-layout eabi-c-frame 0
|
|---|
| 505 | backlink
|
|---|
| 506 | savelr
|
|---|
| 507 | param0
|
|---|
| 508 | param1
|
|---|
| 509 | param2
|
|---|
| 510 | param3
|
|---|
| 511 | param4
|
|---|
| 512 | param5
|
|---|
| 513 | param6
|
|---|
| 514 | param7
|
|---|
| 515 | )
|
|---|
| 516 |
|
|---|
| 517 | (defconstant eabi-c-frame.minsize eabi-c-frame.size)
|
|---|
| 518 |
|
|---|
| 519 | (defmacro define-header (name element-count subtag)
|
|---|
| 520 | `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
|
|---|
| 521 |
|
|---|
| 522 | (define-header single-float-header single-float.element-count subtag-single-float)
|
|---|
| 523 | (define-header double-float-header double-float.element-count subtag-double-float)
|
|---|
| 524 | (define-header one-digit-bignum-header 1 subtag-bignum)
|
|---|
| 525 | (define-header two-digit-bignum-header 2 subtag-bignum)
|
|---|
| 526 | (define-header three-digit-bignum-header 3 subtag-bignum)
|
|---|
| 527 | (define-header symbol-header symbol.element-count subtag-symbol)
|
|---|
| 528 | (define-header value-cell-header value-cell.element-count subtag-value-cell)
|
|---|
| 529 | (define-header macptr-header macptr.element-count subtag-macptr)
|
|---|
| 530 |
|
|---|
| 531 | (defconstant yield-syscall
|
|---|
| 532 | #+darwinppc-target -60
|
|---|
| 533 | #+linuxppc-target #$__NR_sched_yield)
|
|---|
| 534 | )
|
|---|
| 535 |
|
|---|
| 536 |
|
|---|
| 537 |
|
|---|
| 538 |
|
|---|
| 539 | (defun %kernel-global (sym)
|
|---|
| 540 | (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
|
|---|
| 541 | (if pos
|
|---|
| 542 | (- (+ fulltag-nil (* (1+ pos) 4)))
|
|---|
| 543 | (error "Unknown kernel global : ~s ." sym))))
|
|---|
| 544 |
|
|---|
| 545 | (defmacro kernel-global (sym)
|
|---|
| 546 | (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
|
|---|
| 547 | (if pos
|
|---|
| 548 | (- (+ fulltag-nil (* (1+ pos) 4)))
|
|---|
| 549 | (error "Unknown kernel global : ~s ." sym))))
|
|---|
| 550 |
|
|---|
| 551 | ;;; The kernel imports things that are defined in various other
|
|---|
| 552 | ;;; libraries for us. The objects in question are generally
|
|---|
| 553 | ;;; fixnum-tagged; the entries in the "kernel-imports" vector are 4
|
|---|
| 554 | ;;; bytes apart.
|
|---|
| 555 | (ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step 4)
|
|---|
| 556 | fd-setsize-bytes
|
|---|
| 557 | do-fd-set
|
|---|
| 558 | do-fd-clr
|
|---|
| 559 | do-fd-is-set
|
|---|
| 560 | do-fd-zero
|
|---|
| 561 | MakeDataExecutable
|
|---|
| 562 | GetSharedLibrary
|
|---|
| 563 | FindSymbol
|
|---|
| 564 | malloc
|
|---|
| 565 | free
|
|---|
| 566 | allocate_tstack
|
|---|
| 567 | allocate_vstack
|
|---|
| 568 | register_cstack
|
|---|
| 569 | raise-thread-interrupt
|
|---|
| 570 | get-r-debug
|
|---|
| 571 | restore-soft-stack-limit
|
|---|
| 572 | egc-control
|
|---|
| 573 | lisp-bug
|
|---|
| 574 | NewThread
|
|---|
| 575 | YieldToThread
|
|---|
| 576 | DisposeThread
|
|---|
| 577 | ThreadCurrentStackSpace
|
|---|
| 578 | usage-exit
|
|---|
| 579 | save-fp-context
|
|---|
| 580 | restore-fp-context
|
|---|
| 581 | put-altivec-registers
|
|---|
| 582 | get-altivec-registers
|
|---|
| 583 | new-semaphore
|
|---|
| 584 | wait-on-semaphore
|
|---|
| 585 | signal-semaphore
|
|---|
| 586 | destroy-semaphore
|
|---|
| 587 | new-recursive-lock
|
|---|
| 588 | lock-recursive-lock
|
|---|
| 589 | unlock-recursive-lock
|
|---|
| 590 | destroy-recursive-lock
|
|---|
| 591 | suspend-other-threads
|
|---|
| 592 | resume-other-threads
|
|---|
| 593 | suspend-tcr
|
|---|
| 594 | resume-tcr
|
|---|
| 595 | rwlock-new
|
|---|
| 596 | rwlock-destroy
|
|---|
| 597 | rwlock-rlock
|
|---|
| 598 | rwlock-wlock
|
|---|
| 599 | rwlock-unlock
|
|---|
| 600 | recursive-lock-trylock
|
|---|
| 601 | foreign-name-and-offset
|
|---|
| 602 | )
|
|---|
| 603 |
|
|---|
| 604 | (defmacro nrs-offset (name)
|
|---|
| 605 | (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq)))
|
|---|
| 606 | (if pos (+ t-offset (* pos symbol.size)))))
|
|---|
| 607 |
|
|---|
| 608 |
|
|---|
| 609 | (defconstant reservation-discharge #x2004)
|
|---|
| 610 |
|
|---|
| 611 |
|
|---|
| 612 |
|
|---|
| 613 | (defmacro with-stack-short-floats (specs &body body)
|
|---|
| 614 | (ccl::collect ((binds)
|
|---|
| 615 | (inits)
|
|---|
| 616 | (names))
|
|---|
| 617 | (dolist (spec specs)
|
|---|
| 618 | (let ((name (first spec)))
|
|---|
| 619 | (binds `(,name (ccl::%make-sfloat)))
|
|---|
| 620 | (names name)
|
|---|
| 621 | (let ((init (second spec)))
|
|---|
| 622 | (when init
|
|---|
| 623 | (inits `(ccl::%short-float ,init ,name))))))
|
|---|
| 624 | `(let* ,(binds)
|
|---|
| 625 | (declare (dynamic-extent ,@(names))
|
|---|
| 626 | (short-float ,@(names)))
|
|---|
| 627 | ,@(inits)
|
|---|
| 628 | ,@body)))
|
|---|
| 629 |
|
|---|
| 630 | (defparameter *ppc32-target-uvector-subtags*
|
|---|
| 631 | `((:bignum . ,subtag-bignum)
|
|---|
| 632 | (:ratio . ,subtag-ratio)
|
|---|
| 633 | (:single-float . ,subtag-single-float)
|
|---|
| 634 | (:double-float . ,subtag-double-float)
|
|---|
| 635 | (:complex . ,subtag-complex )
|
|---|
| 636 | (:symbol . ,subtag-symbol)
|
|---|
| 637 | (:function . ,subtag-function )
|
|---|
| 638 | (:code-vector . ,subtag-code-vector)
|
|---|
| 639 | (:xcode-vector . ,subtag-xcode-vector)
|
|---|
| 640 | (:macptr . ,subtag-macptr )
|
|---|
| 641 | (:catch-frame . ,subtag-catch-frame)
|
|---|
| 642 | (:struct . ,subtag-struct )
|
|---|
| 643 | (:istruct . ,subtag-istruct )
|
|---|
| 644 | (:pool . ,subtag-pool )
|
|---|
| 645 | (:population . ,subtag-weak )
|
|---|
| 646 | (:hash-vector . ,subtag-hash-vector )
|
|---|
| 647 | (:package . ,subtag-package )
|
|---|
| 648 | (:value-cell . ,subtag-value-cell)
|
|---|
| 649 | (:instance . ,subtag-instance )
|
|---|
| 650 | (:lock . ,subtag-lock )
|
|---|
| 651 | (:slot-vector . ,subtag-slot-vector)
|
|---|
| 652 | (:basic-stream . ,subtag-basic-stream)
|
|---|
| 653 | (:simple-string . ,subtag-simple-base-string )
|
|---|
| 654 | (:bit-vector . ,subtag-bit-vector )
|
|---|
| 655 | (:signed-8-bit-vector . ,subtag-s8-vector )
|
|---|
| 656 | (:unsigned-8-bit-vector . ,subtag-u8-vector )
|
|---|
| 657 | (:signed-16-bit-vector . ,subtag-s16-vector )
|
|---|
| 658 | (:unsigned-16-bit-vector . ,subtag-u16-vector )
|
|---|
| 659 | (:signed-32-bit-vector . ,subtag-s32-vector )
|
|---|
| 660 | (:fixnum-vector . ,subtag-fixnum-vector)
|
|---|
| 661 | (:unsigned-32-bit-vector . ,subtag-u32-vector )
|
|---|
| 662 | (:single-float-vector . ,subtag-single-float-vector)
|
|---|
| 663 | (:double-float-vector . ,subtag-double-float-vector )
|
|---|
| 664 | (:simple-vector . ,subtag-simple-vector )
|
|---|
| 665 | (:vector-header . ,subtag-vectorH)
|
|---|
| 666 | (:array-header . ,subtag-arrayH)))
|
|---|
| 667 |
|
|---|
| 668 |
|
|---|
| 669 | ;;; This should return NIL unless it's sure of how the indicated
|
|---|
| 670 | ;;; type would be represented (in particular, it should return
|
|---|
| 671 | ;;; NIL if the element type is unknown or unspecified at compile-time.
|
|---|
| 672 | (defun ppc32-array-type-name-from-ctype (ctype)
|
|---|
| 673 | (when (typep ctype 'ccl::array-ctype)
|
|---|
| 674 | (let* ((element-type (ccl::array-ctype-element-type ctype)))
|
|---|
| 675 | (typecase element-type
|
|---|
| 676 | (ccl::class-ctype
|
|---|
| 677 | (let* ((class (ccl::class-ctype-class element-type)))
|
|---|
| 678 | (if (or (eq class ccl::*character-class*)
|
|---|
| 679 | (eq class ccl::*base-char-class*)
|
|---|
| 680 | (eq class ccl::*standard-char-class*))
|
|---|
| 681 | :simple-string
|
|---|
| 682 | :simple-vector)))
|
|---|
| 683 | (ccl::numeric-ctype
|
|---|
| 684 | (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
|
|---|
| 685 | :simple-vector
|
|---|
| 686 | (case (ccl::numeric-ctype-class element-type)
|
|---|
| 687 | (integer
|
|---|
| 688 | (let* ((low (ccl::numeric-ctype-low element-type))
|
|---|
| 689 | (high (ccl::numeric-ctype-high element-type)))
|
|---|
| 690 | (cond ((or (null low) (null high)) :simple-vector)
|
|---|
| 691 | ((and (>= low 0) (<= high 1) :bit-vector))
|
|---|
| 692 | ((and (>= low 0) (<= high 255)) :unsigned-8-bit-vector)
|
|---|
| 693 | ((and (>= low 0) (<= high 65535)) :unsigned-16-bit-vector)
|
|---|
| 694 | ((and (>= low 0) (<= high #xffffffff) :unsigned-32-bit-vector))
|
|---|
| 695 | ((and (>= low -128) (<= high 127)) :signed-8-bit-vector)
|
|---|
| 696 | ((and (>= low -32768) (<= high 32767) :signed-16-bit-vector))
|
|---|
| 697 | ((and (>= low target-most-negative-fixnum)
|
|---|
| 698 | (<= high target-most-positive-fixnum))
|
|---|
| 699 | :fixnum-vector)
|
|---|
| 700 | ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
|
|---|
| 701 | :signed-32-bit-vector)
|
|---|
| 702 | (t :simple-vector))))
|
|---|
| 703 | (float
|
|---|
| 704 | (case (ccl::numeric-ctype-format element-type)
|
|---|
| 705 | ((double-float long-float) :double-float-vector)
|
|---|
| 706 | ((single-float short-float) :single-float-vector)
|
|---|
| 707 | (t :simple-vector)))
|
|---|
| 708 | (t :simple-vector))))
|
|---|
| 709 | (ccl::unknown-ctype)
|
|---|
| 710 | (ccl::named-ctype
|
|---|
| 711 | (if (eq element-type ccl::*universal-type*)
|
|---|
| 712 | :simple-vector))
|
|---|
| 713 | (t nil)))))
|
|---|
| 714 |
|
|---|
| 715 | (defun ppc32-misc-byte-count (subtag element-count)
|
|---|
| 716 | (declare (fixnum subtag))
|
|---|
| 717 | (if (or (= fulltag-nodeheader (logand subtag fulltagmask))
|
|---|
| 718 | (<= subtag max-32-bit-ivector-subtag))
|
|---|
| 719 | (ash element-count 2)
|
|---|
| 720 | (if (<= subtag max-8-bit-ivector-subtag)
|
|---|
| 721 | element-count
|
|---|
| 722 | (if (<= subtag max-16-bit-ivector-subtag)
|
|---|
| 723 | (ash element-count 1)
|
|---|
| 724 | (if (= subtag subtag-bit-vector)
|
|---|
| 725 | (ash (+ element-count 7) -3)
|
|---|
| 726 | (+ 4 (ash element-count 3)))))))
|
|---|
| 727 |
|
|---|
| 728 | (defparameter *ppc32-target-arch*
|
|---|
| 729 | (arch::make-target-arch :name :ppc32
|
|---|
| 730 | :lisp-node-size 4
|
|---|
| 731 | :nil-value nil-value
|
|---|
| 732 | :fixnum-shift fixnumshift
|
|---|
| 733 | :most-positive-fixnum (1- (ash 1 (1- (- 32 fixnumshift))))
|
|---|
| 734 | :most-negative-fixnum (- (ash 1 (1- (- 32 fixnumshift))))
|
|---|
| 735 | :misc-data-offset misc-data-offset
|
|---|
| 736 | :misc-dfloat-offset misc-dfloat-offset
|
|---|
| 737 | :nbits-in-word 32
|
|---|
| 738 | :ntagbits 3
|
|---|
| 739 | :nlisptagbits 2
|
|---|
| 740 | :uvector-subtags *ppc32-target-uvector-subtags*
|
|---|
| 741 | :max-64-bit-constant-index max-64-bit-constant-index
|
|---|
| 742 | :max-32-bit-constant-index max-32-bit-constant-index
|
|---|
| 743 | :max-16-bit-constant-index max-16-bit-constant-index
|
|---|
| 744 | :max-8-bit-constant-index max-8-bit-constant-index
|
|---|
| 745 | :max-1-bit-constant-index max-1-bit-constant-index
|
|---|
| 746 | :word-shift 2
|
|---|
| 747 | :code-vector-prefix ()
|
|---|
| 748 | :gvector-types '(:ratio :complex :symbol :function
|
|---|
| 749 | :catch-frame :struct :istruct
|
|---|
| 750 | :pool :population :hash-vector
|
|---|
| 751 | :package :value-cell :instance
|
|---|
| 752 | :lock :slot-vector
|
|---|
| 753 | :simple-vector)
|
|---|
| 754 | :1-bit-ivector-types '(:bit-vector)
|
|---|
| 755 | :8-bit-ivector-types '(:signed-8-bit-vector
|
|---|
| 756 | :unsigned-8-bit-vector)
|
|---|
| 757 | :16-bit-ivector-types '(:signed-16-bit-vector
|
|---|
| 758 | :unsigned-16-bit-vector)
|
|---|
| 759 | :32-bit-ivector-types '(:signed-32-bit-vector
|
|---|
| 760 | :unsigned-32-bit-vector
|
|---|
| 761 | :single-float-vector
|
|---|
| 762 | :fixnum-vector
|
|---|
| 763 | :single-float
|
|---|
| 764 | :double-float
|
|---|
| 765 | :bignum
|
|---|
| 766 | :simple-string)
|
|---|
| 767 | :64-bit-ivector-types '(:double-float-vector)
|
|---|
| 768 | :array-type-name-from-ctype-function
|
|---|
| 769 | #'ppc32-array-type-name-from-ctype
|
|---|
| 770 | :package-name "PPC32"
|
|---|
| 771 | :t-offset t-offset
|
|---|
| 772 | :array-data-size-function #'ppc32-misc-byte-count
|
|---|
| 773 | :numeric-type-name-to-typecode-function
|
|---|
| 774 | #'(lambda (type-name)
|
|---|
| 775 | (ecase type-name
|
|---|
| 776 | (fixnum tag-fixnum)
|
|---|
| 777 | (bignum subtag-bignum)
|
|---|
| 778 | ((short-float single-float) subtag-single-float)
|
|---|
| 779 | ((long-float double-float) subtag-double-float)
|
|---|
| 780 | (ratio subtag-ratio)
|
|---|
| 781 | (complex subtag-complex)))
|
|---|
| 782 | :subprims-base ppc::*ppc-subprims-base*
|
|---|
| 783 | :subprims-shift ppc::*ppc-subprims-shift*
|
|---|
| 784 | :subprims-table ppc::*ppc-subprims*
|
|---|
| 785 | :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-subprims*)))
|
|---|
| 786 | :unbound-marker-value unbound-marker
|
|---|
| 787 | :slot-unbound-marker-value slot-unbound-marker
|
|---|
| 788 | :fixnum-tag tag-fixnum
|
|---|
| 789 | :single-float-tag subtag-single-float
|
|---|
| 790 | :single-float-tag-is-subtag t
|
|---|
| 791 | :double-float-tag subtag-double-float
|
|---|
| 792 | :cons-tag fulltag-cons
|
|---|
| 793 | :null-tag fulltag-nil
|
|---|
| 794 | :symbol-tag subtag-symbol
|
|---|
| 795 | :symbol-tag-is-subtag t
|
|---|
| 796 | :function-tag subtag-function
|
|---|
| 797 | :function-tag-is-subtag t
|
|---|
| 798 | :big-endian t
|
|---|
| 799 | :misc-subtag-offset misc-subtag-offset
|
|---|
| 800 | :car-offset cons.car
|
|---|
| 801 | :cdr-offset cons.cdr
|
|---|
| 802 | :subtag-char subtag-character
|
|---|
| 803 | :charcode-shift charcode-shift
|
|---|
| 804 | :fulltagmask fulltagmask
|
|---|
| 805 | :fulltag-misc fulltag-misc
|
|---|
| 806 | :char-code-limit #x110000
|
|---|
| 807 | ))
|
|---|
| 808 |
|
|---|
| 809 | ;;; arch macros
|
|---|
| 810 | (defmacro defppc32archmacro (name lambda-list &body body)
|
|---|
| 811 | `(arch::defarchmacro :ppc32 ,name ,lambda-list ,@body))
|
|---|
| 812 |
|
|---|
| 813 | (defppc32archmacro ccl::%make-sfloat ()
|
|---|
| 814 | `(ccl::%alloc-misc ppc32::single-float.element-count ppc32::subtag-single-float))
|
|---|
| 815 |
|
|---|
| 816 | (defppc32archmacro ccl::%make-dfloat ()
|
|---|
| 817 | `(ccl::%alloc-misc ppc32::double-float.element-count ppc32::subtag-double-float))
|
|---|
| 818 |
|
|---|
| 819 | (defppc32archmacro ccl::%numerator (x)
|
|---|
| 820 | `(ccl::%svref ,x ppc32::ratio.numer-cell))
|
|---|
| 821 |
|
|---|
| 822 | (defppc32archmacro ccl::%denominator (x)
|
|---|
| 823 | `(ccl::%svref ,x ppc32::ratio.denom-cell))
|
|---|
| 824 |
|
|---|
| 825 | (defppc32archmacro ccl::%realpart (x)
|
|---|
| 826 | `(ccl::%svref ,x ppc32::complex.realpart-cell))
|
|---|
| 827 |
|
|---|
| 828 | (defppc32archmacro ccl::%imagpart (x)
|
|---|
| 829 | `(ccl::%svref ,x ppc32::complex.imagpart-cell))
|
|---|
| 830 |
|
|---|
| 831 | ;;;
|
|---|
| 832 | (defppc32archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
|
|---|
| 833 | `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)
|
|---|
| 834 | (ccl::%alloc-misc 1 ppc32::subtag-single-float)))
|
|---|
| 835 |
|
|---|
| 836 | (defppc32archmacro ccl::codevec-header-p (word)
|
|---|
| 837 | `(eql ppc32::subtag-code-vector
|
|---|
| 838 | (logand ,word ppc32::subtag-mask)))
|
|---|
| 839 |
|
|---|
| 840 | (defppc32archmacro ccl::immediate-p-macro (thing)
|
|---|
| 841 | (let* ((tag (gensym)))
|
|---|
| 842 | `(let* ((,tag (ccl::lisptag ,thing)))
|
|---|
| 843 | (declare (fixnum ,tag))
|
|---|
| 844 | (or (= ,tag ppc32::tag-fixnum)
|
|---|
| 845 | (= ,tag ppc32::tag-imm)))))
|
|---|
| 846 |
|
|---|
| 847 | (defppc32archmacro ccl::hashed-by-identity (thing)
|
|---|
| 848 | (let* ((typecode (gensym)))
|
|---|
| 849 | `(let* ((,typecode (ccl::typecode ,thing)))
|
|---|
| 850 | (declare (fixnum ,typecode))
|
|---|
| 851 | (or
|
|---|
| 852 | (= ,typecode ppc32::tag-fixnum)
|
|---|
| 853 | (= ,typecode ppc32::tag-imm)
|
|---|
| 854 | (= ,typecode ppc32::subtag-symbol)
|
|---|
| 855 | (= ,typecode ppc32::subtag-instance)))))
|
|---|
| 856 |
|
|---|
| 857 | ;;;
|
|---|
| 858 | (defppc32archmacro ccl::%get-kernel-global (name)
|
|---|
| 859 | `(ccl::%fixnum-ref 0 (+ ppc32::nil-value
|
|---|
| 860 | ,(%kernel-global
|
|---|
| 861 | (if (ccl::quoted-form-p name)
|
|---|
| 862 | (cadr name)
|
|---|
| 863 | name)))))
|
|---|
| 864 |
|
|---|
| 865 | (defppc32archmacro ccl::%get-kernel-global-ptr (name dest)
|
|---|
| 866 | `(ccl::%setf-macptr
|
|---|
| 867 | ,dest
|
|---|
| 868 | (ccl::%fixnum-ref-macptr 0 (+ ppc32::nil-value
|
|---|
| 869 | ,(%kernel-global
|
|---|
| 870 | (if (ccl::quoted-form-p name)
|
|---|
| 871 | (cadr name)
|
|---|
| 872 | name))))))
|
|---|
| 873 |
|
|---|
| 874 | (defppc32archmacro ccl::%target-kernel-global (name)
|
|---|
| 875 | `(ppc32::%kernel-global ,name))
|
|---|
| 876 |
|
|---|
| 877 | (defppc32archmacro ccl::lfun-vector (fn)
|
|---|
| 878 | fn)
|
|---|
| 879 |
|
|---|
| 880 | (defppc32archmacro ccl::lfun-vector-lfun (lfv)
|
|---|
| 881 | lfv)
|
|---|
| 882 |
|
|---|
| 883 | (defppc32archmacro ccl::area-code ()
|
|---|
| 884 | area.code)
|
|---|
| 885 |
|
|---|
| 886 | (defppc32archmacro ccl::area-succ ()
|
|---|
| 887 | area.succ)
|
|---|
| 888 |
|
|---|
| 889 | (defppc32archmacro ccl::nth-immediate (f i)
|
|---|
| 890 | `(ccl::%svref ,f ,i))
|
|---|
| 891 |
|
|---|
| 892 | (defppc32archmacro ccl::set-nth-immediate (f i new)
|
|---|
| 893 | `(setf (ccl::%svref ,f ,i) ,new))
|
|---|
| 894 |
|
|---|
| 895 | (defppc32archmacro ccl::symptr->symvector (s)
|
|---|
| 896 | s)
|
|---|
| 897 |
|
|---|
| 898 | (defppc32archmacro ccl::symvector->symptr (s)
|
|---|
| 899 | s)
|
|---|
| 900 |
|
|---|
| 901 | (defppc32archmacro ccl::function-to-function-vector (f)
|
|---|
| 902 | f)
|
|---|
| 903 |
|
|---|
| 904 | (defppc32archmacro ccl::function-vector-to-function (v)
|
|---|
| 905 | v)
|
|---|
| 906 |
|
|---|
| 907 | (defppc32archmacro ccl::with-ffcall-results ((buf) &body body)
|
|---|
| 908 | (let* ((size (+ (* 8 4) (* 31 8))))
|
|---|
| 909 | `(%stack-block ((,buf ,size))
|
|---|
| 910 | ,@body)))
|
|---|
| 911 |
|
|---|
| 912 | (provide "PPC32-ARCH")
|
|---|
