| 1 | ;;;-*- Mode: Lisp; Package: (PPC64 :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 | ;;; This file matches "ccl:lisp-kernel;constants64.h" &
|
|---|
| 18 | ;;; "ccl:lisp-kernel;constants64.s"
|
|---|
| 19 |
|
|---|
| 20 | (defpackage "PPC64"
|
|---|
| 21 | (:use "CL")
|
|---|
| 22 | #+ppc64-target
|
|---|
| 23 | (:nicknames "TARGET"))
|
|---|
| 24 |
|
|---|
| 25 |
|
|---|
| 26 | (in-package "PPC64")
|
|---|
| 27 |
|
|---|
| 28 | (eval-when (:compile-toplevel :load-toplevel :execute)
|
|---|
| 29 | (defconstant rcontext 2) ;sigh. Could use r13+bias on Linux,
|
|---|
| 30 | ; but Apple hasn't invented tls yet.
|
|---|
| 31 | (defconstant nbits-in-word 64)
|
|---|
| 32 | (defconstant least-significant-bit 63)
|
|---|
| 33 | (defconstant nbits-in-byte 8)
|
|---|
| 34 | (defconstant ntagbits 4)
|
|---|
| 35 | (defconstant nlisptagbits 3)
|
|---|
| 36 | (defconstant nfixnumtagbits 3) ; See ?
|
|---|
| 37 | (defconstant nlowtagbits 2)
|
|---|
| 38 | (defconstant num-subtag-bits 8) ; tag part of header is 8 bits wide
|
|---|
| 39 | (defconstant fixnumshift nfixnumtagbits)
|
|---|
| 40 | (defconstant fixnum-shift fixnumshift) ; A pet name for it.
|
|---|
| 41 | (defconstant fulltagmask (1- (ash 1 ntagbits))) ; Only needed by GC/very low-level code
|
|---|
| 42 | (defconstant full-tag-mask fulltagmask)
|
|---|
| 43 | (defconstant tagmask (1- (ash 1 nlisptagbits)))
|
|---|
| 44 | (defconstant tag-mask tagmask)
|
|---|
| 45 | (defconstant fixnummask (1- (ash 1 nfixnumtagbits)))
|
|---|
| 46 | (defconstant fixnum-mask fixnummask)
|
|---|
| 47 | (defconstant subtag-mask (1- (ash 1 num-subtag-bits)))
|
|---|
| 48 | (defconstant ncharcodebits 8) ;24
|
|---|
| 49 | (defconstant charcode-shift 8)
|
|---|
| 50 | (defconstant word-shift 3)
|
|---|
| 51 | (defconstant word-size-in-bytes 8)
|
|---|
| 52 | (defconstant node-size word-size-in-bytes)
|
|---|
| 53 | (defconstant dnode-size 16)
|
|---|
| 54 | (defconstant dnode-align-bits 4)
|
|---|
| 55 | (defconstant dnode-shift dnode-align-bits)
|
|---|
| 56 | (defconstant bitmap-shift 6)
|
|---|
| 57 |
|
|---|
| 58 | (defconstant target-most-negative-fixnum (ash -1 (1- (- nbits-in-word nfixnumtagbits))))
|
|---|
| 59 | (defconstant target-most-positive-fixnum (1- (ash 1 (1- (- nbits-in-word nfixnumtagbits)))))
|
|---|
| 60 | (defmacro define-subtag (name tag value)
|
|---|
| 61 | `(defconstant ,(ccl::form-symbol "SUBTAG-" name) (logior ,tag (ash ,value ntagbits))))
|
|---|
| 62 |
|
|---|
| 63 | ;;; PPC64 stuff and tags.
|
|---|
| 64 |
|
|---|
| 65 | ;;; There are several ways to look at the 4 tag bits of any object or
|
|---|
| 66 | ;;; header. Looking at the low 2 bits, we can classify things as
|
|---|
| 67 | ;;; follows (I'm not sure if we'd ever want to do this) :
|
|---|
| 68 | ;;;
|
|---|
| 69 | ;;; #b00 a "primary" object: fixnum, cons, uvector
|
|---|
| 70 | ;;; #b01 an immediate
|
|---|
| 71 | ;;; #b10 the header on an immediate uvector
|
|---|
| 72 | ;;; #b11 the header on a node (pointer-containing) uvector
|
|---|
| 73 | ;;
|
|---|
| 74 | ;;; Note that the ppc64's LD and STD instructions require that the low
|
|---|
| 75 | ;;; two bits of the constant displacement be #b00. If we want to use constant
|
|---|
| 76 | ;;; offsets to access CONS and UVECTOR fields, we're pretty much obligated
|
|---|
| 77 | ;;; to ensure that CONS and UVECTOR have tags that also end in #b00, and
|
|---|
| 78 | ;;; fixnum addition and subtraction work better when fixnum tags are all 0.
|
|---|
| 79 | ;;; We generally have to look at all 4 tag bits before we really know what
|
|---|
| 80 | ;;; class of "potentially primary" object we're looking at.
|
|---|
| 81 | ;;; If we look at 3 tag bits, we can see:
|
|---|
| 82 | ;;;
|
|---|
| 83 | ;;; #b000 fixnum
|
|---|
| 84 | ;;; #b001 immediate
|
|---|
| 85 | ;;; #b010 immedate-header
|
|---|
| 86 | ;;; #b011 node-header
|
|---|
| 87 | ;;; #b100 CONS or UVECTOR
|
|---|
| 88 | ;;; #b101 immediate
|
|---|
| 89 | ;;; #b110 immediate-header
|
|---|
| 90 | ;;; #b111 node-header
|
|---|
| 91 | ;;;
|
|---|
| 92 |
|
|---|
| 93 | (defconstant tag-fixnum 0)
|
|---|
| 94 | (defconstant tag-imm-0 1)
|
|---|
| 95 | (defconstant tag-immheader-0 2)
|
|---|
| 96 | (defconstant tag-nodeheader-0 3)
|
|---|
| 97 | (defconstant tag-memory 4)
|
|---|
| 98 | (defconstant tag-imm-2 5)
|
|---|
| 99 | (defconstant tag-immheader2 6)
|
|---|
| 100 | (defconstant tag-nodeheader2 7)
|
|---|
| 101 |
|
|---|
| 102 |
|
|---|
| 103 | ;;; Note how we're already winding up with lots of header and immediate
|
|---|
| 104 | ;;; "classes". That might actually be useful.
|
|---|
| 105 | ;;
|
|---|
| 106 | ;;; When we move to 4 bits, we wind up (obviously) with 4 tags of the form
|
|---|
| 107 | ;;; #bxx00. There are two partitionings that make (some) sense: we can either
|
|---|
| 108 | ;;; use 2 of these for (even and odd) fixnums, or we can give NIL a tag
|
|---|
| 109 | ;;; that's congruent (mod 16) with CONS. There seem to be a lot of tradeoffs
|
|---|
| 110 | ;;; involved, but it ultimately seems best to be able to treat 64-bit
|
|---|
| 111 | ;;; aligned addresses as fixnums: we don't want the VSP to look like a
|
|---|
| 112 | ;;; vector. That basically requires that NIL really be a symbol (good
|
|---|
| 113 | ;;; bye, nilsym) and that we ensure that there are NILs where its CAR and
|
|---|
| 114 | ;;; CDR would be (-4, 4 bytes from the tagged pointer.) That means that
|
|---|
| 115 | ;;; CONS is 4 and UVECTOR is 12, and we have even more immediate/header types.
|
|---|
| 116 |
|
|---|
| 117 | (defconstant fulltag-even-fixnum #b0000)
|
|---|
| 118 | (defconstant fulltag-imm-0 #b0001)
|
|---|
| 119 | (defconstant fulltag-immheader-0 #b0010)
|
|---|
| 120 | (defconstant fulltag-nodeheader-0 #b0011)
|
|---|
| 121 | (defconstant fulltag-cons #b0100)
|
|---|
| 122 | (defconstant fulltag-imm-1 #b0101)
|
|---|
| 123 | (defconstant fulltag-immheader-1 #b0110)
|
|---|
| 124 | (defconstant fulltag-nodeheader-1 #b0111)
|
|---|
| 125 | (defconstant fulltag-odd-fixnum #b1000)
|
|---|
| 126 | (defconstant fulltag-imm-2 #b1001)
|
|---|
| 127 | (defconstant fulltag-immheader-2 #b1010)
|
|---|
| 128 | (defconstant fulltag-nodeheader-2 #b1011)
|
|---|
| 129 | (defconstant fulltag-misc #b1100)
|
|---|
| 130 | (defconstant fulltag-imm-3 #b1101)
|
|---|
| 131 | (defconstant fulltag-immheader-3 #b1110)
|
|---|
| 132 | (defconstant fulltag-nodeheader-3 #b1111)
|
|---|
| 133 |
|
|---|
| 134 | (defconstant lowtagmask (1- (ash 1 nlowtagbits)))
|
|---|
| 135 | (defconstant lowtag-mask lowtagmask)
|
|---|
| 136 | (defconstant lowtag-primary 0)
|
|---|
| 137 | (defconstant lowtag-imm 1)
|
|---|
| 138 | (defconstant lowtag-immheader 2)
|
|---|
| 139 | (defconstant lowtag-nodeheader 3)
|
|---|
| 140 |
|
|---|
| 141 | ;;; The general algorithm for determining the (primary) type of an
|
|---|
| 142 | ;;; object is something like:
|
|---|
| 143 | ;;; (clrldi tag node 60)
|
|---|
| 144 | ;;; (cmpwi tag fulltag-misc)
|
|---|
| 145 | ;;; (clrldi tag tag 61)
|
|---|
| 146 | ;;; (bne @done)
|
|---|
| 147 | ;;; (lbz tag misc-subtag-offset node)
|
|---|
| 148 | ;;; @done
|
|---|
| 149 | ;;
|
|---|
| 150 | ;;; That's good enough to identify FIXNUM, "generally immediate", cons,
|
|---|
| 151 | ;;; or a header tag from a UVECTOR. In some cases, we may need to hold
|
|---|
| 152 | ;;; on to the full 4-bit tag.
|
|---|
| 153 | ;;; In no specific order:
|
|---|
| 154 | ;;; - it's important to be able to quickly recognize fixnums; that's
|
|---|
| 155 | ;;; simple
|
|---|
| 156 | ;;; - it's important to be able to quickly recognize lists (for CAR/CDR)
|
|---|
| 157 | ;;; and somewhat important to be able to quickly recognize conses.
|
|---|
| 158 | ;;; Also simple, though we have to special-case NIL.
|
|---|
| 159 | ;;; - it's desirable to be able to do VECTORP, ARRAYP, and specific-array-type-
|
|---|
| 160 | ;;; p. We need at least 12 immediate CL vector types (SIGNED/UNSIGNED-BYTE
|
|---|
| 161 | ;;; 8/16/32/64, SINGLE-FLOAT, DOUBLE-FLOAT, BIT, and at least one CHARACTER;
|
|---|
| 162 | ;;; we need SIMPLE-ARRAY, VECTOR-HEADER, and ARRAY-HEADER as node
|
|---|
| 163 | ;;; array types. That's suspciciously close to 16
|
|---|
| 164 | ;;; - it's desirable to be able (in FUNCALL) to quickly recognize
|
|---|
| 165 | ;;; functions/symbols/other, and probably desirable to trap on other.
|
|---|
| 166 | ;;; Pretty much have to do a memory reference and at least one comparison
|
|---|
| 167 | ;;; here.
|
|---|
| 168 | ;;; - it's sometimes desirable to recognize numbers and distinct numeric
|
|---|
| 169 | ;;; types (other than FIXNUM) quickly.
|
|---|
| 170 | ;;; - The GC (especially) needs to be able to determine the size of
|
|---|
| 171 | ;;; ivectors (ivector elements) fairly cheaply. Most ivectors are CL
|
|---|
| 172 | ;;; arrays, but code-vectors are fairly common (and have 32-bit elements,
|
|---|
| 173 | ;;; naturally.)
|
|---|
| 174 | ;;; - We have a fairly large number of non-array gvector types, and it's
|
|---|
| 175 | ;;; always desirable to have room for expansion.
|
|---|
| 176 | ;;; - we basically have 8 classes of header subtags, each of which has
|
|---|
| 177 | ;;; 16 possible values. If we stole the high bit of the subtag to
|
|---|
| 178 | ;;; indicate CL-array-ness, we'd still have 6 bits to encode non-CL
|
|---|
| 179 | ;;; array types.
|
|---|
| 180 |
|
|---|
| 181 | (defconstant cl-array-subtag-bit 7)
|
|---|
| 182 | (defconstant cl-array-subtag-mask (ash 1 cl-array-subtag-bit))
|
|---|
| 183 | (defmacro define-cl-array-subtag (name tag value)
|
|---|
| 184 | `(defconstant ,(ccl::form-symbol "SUBTAG-" name)
|
|---|
| 185 | (logior cl-array-subtag-mask (logior ,tag (ash ,value ntagbits)))))
|
|---|
| 186 |
|
|---|
| 187 | (define-cl-array-subtag arrayH fulltag-nodeheader-1 0)
|
|---|
| 188 | (define-cl-array-subtag vectorH fulltag-nodeheader-2 0)
|
|---|
| 189 | (define-cl-array-subtag simple-vector fulltag-nodeheader-3 0)
|
|---|
| 190 | (defconstant min-array-subtag subtag-arrayH)
|
|---|
| 191 | (defconstant min-vector-subtag subtag-vectorH)
|
|---|
| 192 |
|
|---|
| 193 | ;;; bits: 64 32 16 8 1
|
|---|
| 194 | ;;; CL-array ivector types DOUBLE-FLOAT SINGLE s16 CHAR BIT
|
|---|
| 195 | ;;; s64 s32 u16 s8
|
|---|
| 196 | ;;; u64 u32 u8
|
|---|
| 197 | ;;; Other ivector types MACPTR CODE-VECTOR
|
|---|
| 198 | ;;; DEAD-MACPTR XCODE-VECTOR
|
|---|
| 199 | ;;; BIGNUM
|
|---|
| 200 | ;;; DOUBLE-FLOAT
|
|---|
| 201 | ;;; There might possibly be ivectors with 128-bit (VMX/AltiVec) elements
|
|---|
| 202 | ;;; someday, and there might be multiple character sizes (16/32 bits).
|
|---|
| 203 | ;;; That sort of suggests that we use the four immheader classes to
|
|---|
| 204 | ;;; encode the ivector size (64, 32, 8, other) and make BIT an easily-
|
|---|
| 205 | ;;; detected case of OTHER.
|
|---|
| 206 |
|
|---|
| 207 | (defconstant ivector-class-64-bit fulltag-immheader-3)
|
|---|
| 208 | (defconstant ivector-class-32-bit fulltag-immheader-2)
|
|---|
| 209 | (defconstant ivector-class-other-bit fulltag-immheader-1)
|
|---|
| 210 | (defconstant ivector-class-8-bit fulltag-immheader-0)
|
|---|
| 211 |
|
|---|
| 212 | (define-cl-array-subtag s64-vector ivector-class-64-bit 1)
|
|---|
| 213 | (define-cl-array-subtag u64-vector ivector-class-64-bit 2)
|
|---|
| 214 | (define-cl-array-subtag fixnum-vector ivector-class-64-bit 3)
|
|---|
| 215 | (define-cl-array-subtag double-float-vector ivector-class-64-bit 4)
|
|---|
| 216 | (define-cl-array-subtag s32-vector ivector-class-32-bit 1)
|
|---|
| 217 | (define-cl-array-subtag u32-vector ivector-class-32-bit 2)
|
|---|
| 218 | (define-cl-array-subtag single-float-vector ivector-class-32-bit 3)
|
|---|
| 219 | (define-cl-array-subtag simple-base-string ivector-class-32-bit 5)
|
|---|
| 220 | (define-cl-array-subtag s16-vector ivector-class-other-bit 1)
|
|---|
| 221 | (define-cl-array-subtag u16-vector ivector-class-other-bit 2)
|
|---|
| 222 | (define-cl-array-subtag bit-vector ivector-class-other-bit 7)
|
|---|
| 223 | (define-cl-array-subtag s8-vector ivector-class-8-bit 1)
|
|---|
| 224 | (define-cl-array-subtag u8-vector ivector-class-8-bit 2)
|
|---|
| 225 |
|
|---|
| 226 | ;;; There's some room for expansion in non-array ivector space.
|
|---|
| 227 | (define-subtag macptr ivector-class-64-bit 1)
|
|---|
| 228 | (define-subtag dead-macptr ivector-class-64-bit 2)
|
|---|
| 229 |
|
|---|
| 230 | (define-subtag code-vector ivector-class-32-bit 0)
|
|---|
| 231 | (define-subtag xcode-vector ivector-class-32-bit 1)
|
|---|
| 232 | (define-subtag bignum ivector-class-32-bit 2)
|
|---|
| 233 | (define-subtag double-float ivector-class-32-bit 3)
|
|---|
| 234 |
|
|---|
| 235 | ;;; Size doesn't matter for non-CL-array gvectors; I can't think of a good
|
|---|
| 236 | ;;; reason to classify them in any particular way. Let's put funcallable
|
|---|
| 237 | ;;; things in the first slice by themselves, though it's not clear that
|
|---|
| 238 | ;;; that helps FUNCALL much.
|
|---|
| 239 | (defconstant gvector-funcallable fulltag-nodeheader-0)
|
|---|
| 240 | (define-subtag function gvector-funcallable 0)
|
|---|
| 241 | (define-subtag symbol gvector-funcallable 1)
|
|---|
| 242 |
|
|---|
| 243 | (define-subtag catch-frame fulltag-nodeheader-1 0)
|
|---|
| 244 | (define-subtag basic-stream fulltag-nodeheader-1 1)
|
|---|
| 245 | (define-subtag lock fulltag-nodeheader-1 2)
|
|---|
| 246 | (define-subtag hash-vector fulltag-nodeheader-1 3)
|
|---|
| 247 | (define-subtag pool fulltag-nodeheader-1 4)
|
|---|
| 248 | (define-subtag weak fulltag-nodeheader-1 5)
|
|---|
| 249 | (define-subtag package fulltag-nodeheader-1 6)
|
|---|
| 250 | (define-subtag slot-vector fulltag-nodeheader-2 0)
|
|---|
| 251 | (define-subtag instance fulltag-nodeheader-2 1)
|
|---|
| 252 | (define-subtag struct fulltag-nodeheader-2 2)
|
|---|
| 253 | (define-subtag istruct fulltag-nodeheader-2 3)
|
|---|
| 254 | (define-subtag value-cell fulltag-nodeheader-2 4)
|
|---|
| 255 | (define-subtag xfunction fulltag-nodeheader-2 5)
|
|---|
| 256 |
|
|---|
| 257 | (define-subtag ratio fulltag-nodeheader-3 0)
|
|---|
| 258 | (define-subtag complex fulltag-nodeheader-3 1)
|
|---|
| 259 |
|
|---|
| 260 |
|
|---|
| 261 |
|
|---|
| 262 | (eval-when (:compile-toplevel :load-toplevel :execute)
|
|---|
| 263 | (require "PPC-ARCH")
|
|---|
| 264 | (defmacro define-storage-layout (name origin &rest cells)
|
|---|
| 265 | `(progn
|
|---|
| 266 | (ccl::defenum (:start ,origin :step 8)
|
|---|
| 267 | ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
|
|---|
| 268 | (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells)
|
|---|
| 269 | 8))))
|
|---|
| 270 |
|
|---|
| 271 | (defmacro define-lisp-object (name tagname &rest cells)
|
|---|
| 272 | `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
|
|---|
| 273 |
|
|---|
| 274 |
|
|---|
| 275 |
|
|---|
| 276 | (defmacro define-fixedsized-object (name &rest non-header-cells)
|
|---|
| 277 | `(progn
|
|---|
| 278 | (define-lisp-object ,name fulltag-misc header ,@non-header-cells)
|
|---|
| 279 | (ccl::defenum ()
|
|---|
| 280 | ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
|
|---|
| 281 | (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
|
|---|
| 282 |
|
|---|
| 283 |
|
|---|
| 284 |
|
|---|
| 285 |
|
|---|
| 286 |
|
|---|
| 287 |
|
|---|
| 288 |
|
|---|
| 289 | (defconstant misc-header-offset (- fulltag-misc))
|
|---|
| 290 | (defconstant misc-subtag-offset (+ misc-header-offset 7 ))
|
|---|
| 291 | (defconstant misc-data-offset (+ misc-header-offset 8))
|
|---|
| 292 | (defconstant misc-dfloat-offset (+ misc-header-offset 8))
|
|---|
| 293 |
|
|---|
| 294 |
|
|---|
| 295 |
|
|---|
| 296 | (define-subtag single-float fulltag-imm-0 0)
|
|---|
| 297 |
|
|---|
| 298 | (define-subtag character fulltag-imm-1 0)
|
|---|
| 299 |
|
|---|
| 300 | ;;; FULLTAG-IMM-2 is unused, so the only type with lisptag (3-bit tag)
|
|---|
| 301 | ;;; TAG-IMM-0 should be SINGLE-FLOAT.
|
|---|
| 302 |
|
|---|
| 303 | (define-subtag unbound fulltag-imm-3 0)
|
|---|
| 304 | (defconstant unbound-marker subtag-unbound)
|
|---|
| 305 | (defconstant undefined unbound-marker)
|
|---|
| 306 | (define-subtag slot-unbound fulltag-imm-3 1)
|
|---|
| 307 | (defconstant slot-unbound-marker subtag-slot-unbound)
|
|---|
| 308 | (define-subtag illegal fulltag-imm-3 2)
|
|---|
| 309 | (defconstant illegal-marker subtag-illegal)
|
|---|
| 310 |
|
|---|
| 311 | (define-subtag no-thread-local-binding fulltag-imm-3 3)
|
|---|
| 312 | (define-subtag forward-marker fulltag-imm-3 7)
|
|---|
| 313 |
|
|---|
| 314 |
|
|---|
| 315 | (defconstant max-64-bit-constant-index (ash (+ #x7fff ppc64::misc-dfloat-offset) -3))
|
|---|
| 316 | (defconstant max-32-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) -2))
|
|---|
| 317 | (defconstant max-16-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) -1))
|
|---|
| 318 | (defconstant max-8-bit-constant-index (+ #x7fff ppc64::misc-data-offset))
|
|---|
| 319 | (defconstant max-1-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) 5))
|
|---|
| 320 |
|
|---|
| 321 |
|
|---|
| 322 | ; The objects themselves look something like this:
|
|---|
| 323 |
|
|---|
| 324 | ; Order of CAR and CDR doesn't seem to matter much - there aren't
|
|---|
| 325 | ; too many tricks to be played with predecrement/preincrement addressing.
|
|---|
| 326 | ; Keep them in the confusing MCL 3.0 order, to avoid confusion.
|
|---|
| 327 | (define-lisp-object cons fulltag-cons
|
|---|
| 328 | cdr
|
|---|
| 329 | car)
|
|---|
| 330 |
|
|---|
| 331 |
|
|---|
| 332 | (define-fixedsized-object ratio
|
|---|
| 333 | numer
|
|---|
| 334 | denom)
|
|---|
| 335 |
|
|---|
| 336 | ;;; It's slightly easier (for bootstrapping reasons)
|
|---|
| 337 | ;;; to view a DOUBLE-FLOAT as being UVECTOR with 2 32-bit elements
|
|---|
| 338 | ;;; (rather than 1 64-bit element).
|
|---|
| 339 |
|
|---|
| 340 | (defconstant double-float.value misc-data-offset)
|
|---|
| 341 | (defconstant double-float.value-cell 0)
|
|---|
| 342 | (defconstant double-float.val-high double-float.value)
|
|---|
| 343 | (defconstant double-float.val-high-cell double-float.value-cell)
|
|---|
| 344 | (defconstant double-float.val-low (+ double-float.value 4))
|
|---|
| 345 | (defconstant double-float.val-low-cell 1)
|
|---|
| 346 | (defconstant double-float.element-count 2)
|
|---|
| 347 | (defconstant double-float.size 16)
|
|---|
| 348 |
|
|---|
| 349 | (define-fixedsized-object complex
|
|---|
| 350 | realpart
|
|---|
| 351 | imagpart
|
|---|
| 352 | )
|
|---|
| 353 |
|
|---|
| 354 |
|
|---|
| 355 | ; There are two kinds of macptr; use the length field of the header if you
|
|---|
| 356 | ; need to distinguish between them
|
|---|
| 357 | (define-fixedsized-object macptr
|
|---|
| 358 | address
|
|---|
| 359 | domain
|
|---|
| 360 | type
|
|---|
| 361 | )
|
|---|
| 362 |
|
|---|
| 363 | (define-fixedsized-object xmacptr
|
|---|
| 364 | address
|
|---|
| 365 | domain
|
|---|
| 366 | type
|
|---|
| 367 | flags
|
|---|
| 368 | link
|
|---|
| 369 | )
|
|---|
| 370 |
|
|---|
| 371 | ; Catch frames go on the tstack; they point to a minimal lisp-frame
|
|---|
| 372 | ; on the cstack. (The catch/unwind-protect PC is on the cstack, where
|
|---|
| 373 | ; the GC expects to find it.)
|
|---|
| 374 | (define-fixedsized-object catch-frame
|
|---|
| 375 | catch-tag ; #<unbound> -> unwind-protect, else catch
|
|---|
| 376 | link ; tagged pointer to next older catch frame
|
|---|
| 377 | mvflag ; 0 if single-value, 1 if uwp or multiple-value
|
|---|
| 378 | csp ; pointer to control stack
|
|---|
| 379 | db-link ; value of dynamic-binding link on thread entry.
|
|---|
| 380 | save-save7 ; saved registers
|
|---|
| 381 | save-save6
|
|---|
| 382 | save-save5
|
|---|
| 383 | save-save4
|
|---|
| 384 | save-save3
|
|---|
| 385 | save-save2
|
|---|
| 386 | save-save1
|
|---|
| 387 | save-save0
|
|---|
| 388 | xframe ; exception-frame link
|
|---|
| 389 | tsp-segment ; mostly padding, for now.
|
|---|
| 390 | )
|
|---|
| 391 |
|
|---|
| 392 | (define-fixedsized-object lock
|
|---|
| 393 | _value ;finalizable pointer to kernel object
|
|---|
| 394 | kind ; '0 = recursive-lock, '1 = rwlock
|
|---|
| 395 | writer ;tcr of owning thread or 0
|
|---|
| 396 | name
|
|---|
| 397 | )
|
|---|
| 398 |
|
|---|
| 399 |
|
|---|
| 400 |
|
|---|
| 401 | (define-fixedsized-object symbol
|
|---|
| 402 | pname
|
|---|
| 403 | vcell
|
|---|
| 404 | fcell
|
|---|
| 405 | package-predicate
|
|---|
| 406 | flags
|
|---|
| 407 | plist
|
|---|
| 408 | binding-index
|
|---|
| 409 | )
|
|---|
| 410 |
|
|---|
| 411 |
|
|---|
| 412 | (defconstant t-offset (- symbol.size))
|
|---|
| 413 |
|
|---|
| 414 |
|
|---|
| 415 |
|
|---|
| 416 |
|
|---|
| 417 | (define-fixedsized-object vectorH
|
|---|
| 418 | logsize ; fillpointer if it has one, physsize otherwise
|
|---|
| 419 | physsize ; total size of (possibly displaced) data vector
|
|---|
| 420 | data-vector ; object this header describes
|
|---|
| 421 | displacement ; true displacement or 0
|
|---|
| 422 | flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
|
|---|
| 423 | )
|
|---|
| 424 |
|
|---|
| 425 | (define-lisp-object arrayH fulltag-misc
|
|---|
| 426 | header ; subtag = subtag-arrayH
|
|---|
| 427 | rank ; NEVER 1
|
|---|
| 428 | physsize ; total size of (possibly displaced) data vector
|
|---|
| 429 | data-vector ; object this header describes
|
|---|
| 430 | displacement ; true displacement or 0
|
|---|
| 431 | flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
|
|---|
| 432 | ;; Dimensions follow
|
|---|
| 433 | )
|
|---|
| 434 |
|
|---|
| 435 | (defconstant arrayH.rank-cell 0)
|
|---|
| 436 | (defconstant arrayH.physsize-cell 1)
|
|---|
| 437 | (defconstant arrayH.data-vector-cell 2)
|
|---|
| 438 | (defconstant arrayH.displacement-cell 3)
|
|---|
| 439 | (defconstant arrayH.flags-cell 4)
|
|---|
| 440 | (defconstant arrayH.dim0-cell 5)
|
|---|
| 441 |
|
|---|
| 442 | (defconstant arrayH.flags-cell-bits-byte (byte 8 0))
|
|---|
| 443 | (defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
|
|---|
| 444 |
|
|---|
| 445 |
|
|---|
| 446 | (define-fixedsized-object value-cell
|
|---|
| 447 | value)
|
|---|
| 448 |
|
|---|
| 449 |
|
|---|
| 450 | ;;; The kernel uses these (rather generically named) structures
|
|---|
| 451 | ;;; to keep track of various memory regions it (or the lisp) is
|
|---|
| 452 | ;;; interested in.
|
|---|
| 453 |
|
|---|
| 454 |
|
|---|
| 455 | (define-storage-layout area 0
|
|---|
| 456 | pred ; pointer to preceding area in DLL
|
|---|
| 457 | succ ; pointer to next area in DLL
|
|---|
| 458 | low ; low bound on area addresses
|
|---|
| 459 | high ; high bound on area addresses.
|
|---|
| 460 | active ; low limit on stacks, high limit on heaps
|
|---|
| 461 | softlimit ; overflow bound
|
|---|
| 462 | hardlimit ; another one
|
|---|
| 463 | code ; an area-code; see below
|
|---|
| 464 | markbits ; bit vector for GC
|
|---|
| 465 | ndnodes ; "active" size of dynamic area or stack
|
|---|
| 466 | older ; in EGC sense
|
|---|
| 467 | younger ; also for EGC
|
|---|
| 468 | h ; Handle or null pointer
|
|---|
| 469 | softprot ; protected_area structure pointer
|
|---|
| 470 | hardprot ; another one.
|
|---|
| 471 | owner ; fragment (library) which "owns" the area
|
|---|
| 472 | refbits ; bitvector for intergenerational refernces
|
|---|
| 473 | threshold ; for egc
|
|---|
| 474 | gc-count ; generational gc count.
|
|---|
| 475 | static-dnodes ; for honsing. etc
|
|---|
| 476 | static-used ; bitvector
|
|---|
| 477 | )
|
|---|
| 478 |
|
|---|
| 479 |
|
|---|
| 480 |
|
|---|
| 481 |
|
|---|
| 482 |
|
|---|
| 483 | (define-storage-layout protected-area 0
|
|---|
| 484 | next
|
|---|
| 485 | start ; first byte (page-aligned) that might be protected
|
|---|
| 486 | end ; last byte (page-aligned) that could be protected
|
|---|
| 487 | nprot ; Might be 0
|
|---|
| 488 | protsize ; number of bytes to protect
|
|---|
| 489 | why)
|
|---|
| 490 |
|
|---|
| 491 | (defconstant tcr-bias 0)
|
|---|
| 492 |
|
|---|
| 493 | (define-storage-layout tcr (- tcr-bias)
|
|---|
| 494 | prev ; in doubly-linked list
|
|---|
| 495 | next ; in doubly-linked list
|
|---|
| 496 | single-float-convert ; per-thread scratch space.
|
|---|
| 497 | lisp-fpscr-high
|
|---|
| 498 | db-link ; special binding chain head
|
|---|
| 499 | catch-top ; top catch frame
|
|---|
| 500 | save-vsp ; VSP when in foreign code
|
|---|
| 501 | save-tsp ; TSP when in foreign code
|
|---|
| 502 | cs-area ; cstack area pointer
|
|---|
| 503 | vs-area ; vstack area pointer
|
|---|
| 504 | ts-area ; tstack area pointer
|
|---|
| 505 | cs-limit ; cstack overflow limit
|
|---|
| 506 | total-bytes-allocated-high
|
|---|
| 507 | log2-allocation-quantum ; unboxed
|
|---|
| 508 | interrupt-pending ; fixnum
|
|---|
| 509 | xframe ; exception frame linked list
|
|---|
| 510 | errno-loc ; thread-private, maybe
|
|---|
| 511 | ffi-exception ; fpscr bits from ff-call.
|
|---|
| 512 | osid ; OS thread id
|
|---|
| 513 | valence ; odd when in foreign code
|
|---|
| 514 | foreign-exception-status
|
|---|
| 515 | native-thread-info
|
|---|
| 516 | native-thread-id
|
|---|
| 517 | last-allocptr
|
|---|
| 518 | save-allocptr
|
|---|
| 519 | save-allocbase
|
|---|
| 520 | reset-completion
|
|---|
| 521 | activate
|
|---|
| 522 | suspend-count
|
|---|
| 523 | suspend-context
|
|---|
| 524 | pending-exception-context
|
|---|
| 525 | suspend ; semaphore for suspension notify
|
|---|
| 526 | resume ; sempahore for resumption notify
|
|---|
| 527 | flags ; foreign, being reset, ...
|
|---|
| 528 | gc-context
|
|---|
| 529 | termination-semaphore
|
|---|
| 530 | unwinding
|
|---|
| 531 | tlb-limit
|
|---|
| 532 | tlb-pointer
|
|---|
| 533 | shutdown-count
|
|---|
| 534 | safe-ref-address
|
|---|
| 535 | )
|
|---|
| 536 |
|
|---|
| 537 | (defconstant interrupt-level-binding-index (ash 1 fixnumshift))
|
|---|
| 538 |
|
|---|
| 539 | (defconstant tcr.lisp-fpscr-low (+ tcr.lisp-fpscr-high 4))
|
|---|
| 540 | (defconstant tcr.total-bytes-allocated-low (+ tcr.total-bytes-allocated-high 4))
|
|---|
| 541 |
|
|---|
| 542 | (define-storage-layout lockptr 0
|
|---|
| 543 | avail
|
|---|
| 544 | owner
|
|---|
| 545 | count
|
|---|
| 546 | signal
|
|---|
| 547 | waiting
|
|---|
| 548 | malloced-ptr
|
|---|
| 549 | spinlock)
|
|---|
| 550 |
|
|---|
| 551 | ;;; For the eabi port: mark this stack frame as Lisp's (since EABI
|
|---|
| 552 | ;;; foreign frames can be the same size as a lisp frame.)
|
|---|
| 553 |
|
|---|
| 554 |
|
|---|
| 555 | (ppc64::define-storage-layout lisp-frame 0
|
|---|
| 556 | backlink
|
|---|
| 557 | savefn
|
|---|
| 558 | savelr
|
|---|
| 559 | savevsp
|
|---|
| 560 | )
|
|---|
| 561 |
|
|---|
| 562 | (ppc64::define-storage-layout c-frame 0
|
|---|
| 563 | backlink
|
|---|
| 564 | crsave
|
|---|
| 565 | savelr
|
|---|
| 566 | unused-1
|
|---|
| 567 | unused-2
|
|---|
| 568 | savetoc
|
|---|
| 569 | param0
|
|---|
| 570 | param1
|
|---|
| 571 | param2
|
|---|
| 572 | param3
|
|---|
| 573 | param4
|
|---|
| 574 | param5
|
|---|
| 575 | param6
|
|---|
| 576 | param7
|
|---|
| 577 | )
|
|---|
| 578 |
|
|---|
| 579 | (defconstant c-frame.minsize c-frame.size)
|
|---|
| 580 |
|
|---|
| 581 | (defmacro define-header (name element-count subtag)
|
|---|
| 582 | `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
|
|---|
| 583 |
|
|---|
| 584 | (define-header double-float-header double-float.element-count subtag-double-float)
|
|---|
| 585 | ;;; We could possibly have a one-digit bignum header when dealing
|
|---|
| 586 | ;;; with "small bignums" in some bignum code. Like other cases of
|
|---|
| 587 | ;;; non-normalized bignums, they should never escape from the lab.
|
|---|
| 588 | (define-header one-digit-bignum-header 1 subtag-bignum)
|
|---|
| 589 | (define-header two-digit-bignum-header 2 subtag-bignum)
|
|---|
| 590 | (define-header three-digit-bignum-header 3 subtag-bignum)
|
|---|
| 591 | (define-header four-digit-bignum-header 4 subtag-bignum)
|
|---|
| 592 | (define-header five-digit-bignum-header 5 subtag-bignum)
|
|---|
| 593 | (define-header symbol-header symbol.element-count subtag-symbol)
|
|---|
| 594 | (define-header value-cell-header value-cell.element-count subtag-value-cell)
|
|---|
| 595 | (define-header macptr-header macptr.element-count subtag-macptr)
|
|---|
| 596 |
|
|---|
| 597 |
|
|---|
| 598 | (defconstant yield-syscall
|
|---|
| 599 | #+darwinppc-target -60
|
|---|
| 600 | #+linuxppc-target #$__NR_sched_yield)
|
|---|
| 601 | )
|
|---|
| 602 | )
|
|---|
| 603 |
|
|---|
| 604 |
|
|---|
| 605 |
|
|---|
| 606 |
|
|---|
| 607 |
|
|---|
| 608 |
|
|---|
| 609 | (defun %kernel-global (sym)
|
|---|
| 610 | (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
|
|---|
| 611 | (if pos
|
|---|
| 612 | (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
|
|---|
| 613 | (error "Unknown kernel global : ~s ." sym))))
|
|---|
| 614 |
|
|---|
| 615 | (defmacro kernel-global (sym)
|
|---|
| 616 | (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
|
|---|
| 617 | (if pos
|
|---|
| 618 | (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
|
|---|
| 619 | (error "Unknown kernel global : ~s ." sym))))
|
|---|
| 620 |
|
|---|
| 621 | ;;; The kernel imports things that are defined in various other
|
|---|
| 622 | ;;; libraries for us. The objects in question are generally
|
|---|
| 623 | ;;; fixnum-tagged; the entries in the "kernel-imports" vector are 8
|
|---|
| 624 | ;;; bytes apart.
|
|---|
| 625 | (ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step word-size-in-bytes)
|
|---|
| 626 | fd-setsize-bytes
|
|---|
| 627 | do-fd-set
|
|---|
| 628 | do-fd-clr
|
|---|
| 629 | do-fd-is-set
|
|---|
| 630 | do-fd-zero
|
|---|
| 631 | MakeDataExecutable
|
|---|
| 632 | GetSharedLibrary
|
|---|
| 633 | FindSymbol
|
|---|
| 634 | malloc
|
|---|
| 635 | free
|
|---|
| 636 | allocate_tstack
|
|---|
| 637 | allocate_vstack
|
|---|
| 638 | register_cstack
|
|---|
| 639 | raise-thread-interrupt
|
|---|
| 640 | get-r-debug
|
|---|
| 641 | restore-soft-stack-limit
|
|---|
| 642 | egc-control
|
|---|
| 643 | lisp-bug
|
|---|
| 644 | NewThread
|
|---|
| 645 | YieldToThread
|
|---|
| 646 | DisposeThread
|
|---|
| 647 | ThreadCurrentStackSpace
|
|---|
| 648 | usage-exit
|
|---|
| 649 | save-fp-context
|
|---|
| 650 | restore-fp-context
|
|---|
| 651 | put-altivec-registers
|
|---|
| 652 | get-altivec-registers
|
|---|
| 653 | new-semaphore
|
|---|
| 654 | wait-on-semaphore
|
|---|
| 655 | signal-semaphore
|
|---|
| 656 | destroy-semaphore
|
|---|
| 657 | new-recursive-lock
|
|---|
| 658 | lock-recursive-lock
|
|---|
| 659 | unlock-recursive-lock
|
|---|
| 660 | destroy-recursive-lock
|
|---|
| 661 | suspend-other-threads
|
|---|
| 662 | resume-other-threads
|
|---|
| 663 | suspend-tcr
|
|---|
| 664 | resume-tcr
|
|---|
| 665 | rwlock-new
|
|---|
| 666 | rwlock-destroy
|
|---|
| 667 | rwlock-rlock
|
|---|
| 668 | rwlock-wlock
|
|---|
| 669 | rwlock-unlock
|
|---|
| 670 | recursive-lock-trylock
|
|---|
| 671 | foreign-name-and-offset
|
|---|
| 672 | )
|
|---|
| 673 |
|
|---|
| 674 | (defmacro nrs-offset (name)
|
|---|
| 675 | (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq)))
|
|---|
| 676 | (if pos (* (1- pos) symbol.size))))
|
|---|
| 677 |
|
|---|
| 678 | (defconstant nil-value (+ #x3000 symbol.size fulltag-misc))
|
|---|
| 679 |
|
|---|
| 680 |
|
|---|
| 681 | (defconstant reservation-discharge #x2008)
|
|---|
| 682 |
|
|---|
| 683 | (defparameter *ppc64-target-uvector-subtags*
|
|---|
| 684 | `((:bignum . ,subtag-bignum)
|
|---|
| 685 | (:ratio . ,subtag-ratio)
|
|---|
| 686 | (:single-float . ,subtag-single-float)
|
|---|
| 687 | (:double-float . ,subtag-double-float)
|
|---|
| 688 | (:complex . ,subtag-complex )
|
|---|
| 689 | (:symbol . ,subtag-symbol)
|
|---|
| 690 | (:function . ,subtag-function )
|
|---|
| 691 | (:code-vector . ,subtag-code-vector)
|
|---|
| 692 | (:xcode-vector . ,subtag-xcode-vector)
|
|---|
| 693 | (:macptr . ,subtag-macptr )
|
|---|
| 694 | (:catch-frame . ,subtag-catch-frame)
|
|---|
| 695 | (:struct . ,subtag-struct )
|
|---|
| 696 | (:istruct . ,subtag-istruct )
|
|---|
| 697 | (:pool . ,subtag-pool )
|
|---|
| 698 | (:population . ,subtag-weak )
|
|---|
| 699 | (:hash-vector . ,subtag-hash-vector )
|
|---|
| 700 | (:package . ,subtag-package )
|
|---|
| 701 | (:value-cell . ,subtag-value-cell)
|
|---|
| 702 | (:instance . ,subtag-instance )
|
|---|
| 703 | (:lock . ,subtag-lock )
|
|---|
| 704 | (:basic-stream . ,subtag-basic-stream)
|
|---|
| 705 | (:slot-vector . ,subtag-slot-vector)
|
|---|
| 706 | (:simple-string . ,subtag-simple-base-string )
|
|---|
| 707 | (:bit-vector . ,subtag-bit-vector )
|
|---|
| 708 | (:signed-8-bit-vector . ,subtag-s8-vector )
|
|---|
| 709 | (:unsigned-8-bit-vector . ,subtag-u8-vector )
|
|---|
| 710 | (:signed-16-bit-vector . ,subtag-s16-vector )
|
|---|
| 711 | (:unsigned-16-bit-vector . ,subtag-u16-vector )
|
|---|
| 712 | (:signed-32-bit-vector . ,subtag-s32-vector )
|
|---|
| 713 | (:unsigned-32-bit-vector . ,subtag-u32-vector )
|
|---|
| 714 | (:fixnum-vector . ,subtag-fixnum-vector)
|
|---|
| 715 | (:signed-64-bit-vector . ,subtag-s64-vector)
|
|---|
| 716 | (:unsigned-64-bit-vector . ,subtag-u64-vector)
|
|---|
| 717 | (:single-float-vector . ,subtag-single-float-vector)
|
|---|
| 718 | (:double-float-vector . ,subtag-double-float-vector )
|
|---|
| 719 | (:simple-vector . ,subtag-simple-vector )
|
|---|
| 720 | (:vector-header . ,subtag-vectorH)
|
|---|
| 721 | (:array-header . ,subtag-arrayH)))
|
|---|
| 722 |
|
|---|
| 723 | ;;; This should return NIL unless it's sure of how the indicated
|
|---|
| 724 | ;;; type would be represented (in particular, it should return
|
|---|
| 725 | ;;; NIL if the element type is unknown or unspecified at compile-time.
|
|---|
| 726 | (defun ppc64-array-type-name-from-ctype (ctype)
|
|---|
| 727 | (when (typep ctype 'ccl::array-ctype)
|
|---|
| 728 | (let* ((element-type (ccl::array-ctype-element-type ctype)))
|
|---|
| 729 | (typecase element-type
|
|---|
| 730 | (ccl::class-ctype
|
|---|
| 731 | (let* ((class (ccl::class-ctype-class element-type)))
|
|---|
| 732 | (if (or (eq class ccl::*character-class*)
|
|---|
| 733 | (eq class ccl::*base-char-class*)
|
|---|
| 734 | (eq class ccl::*standard-char-class*))
|
|---|
| 735 | :simple-string
|
|---|
| 736 | :simple-vector)))
|
|---|
| 737 | (ccl::numeric-ctype
|
|---|
| 738 | (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
|
|---|
| 739 | :simple-vector
|
|---|
| 740 | (case (ccl::numeric-ctype-class element-type)
|
|---|
| 741 | (integer
|
|---|
| 742 | (let* ((low (ccl::numeric-ctype-low element-type))
|
|---|
| 743 | (high (ccl::numeric-ctype-high element-type)))
|
|---|
| 744 | (cond ((or (null low) (null high))
|
|---|
| 745 | :simple-vector)
|
|---|
| 746 | ((and (>= low 0) (<= high 1))
|
|---|
| 747 | :bit-vector)
|
|---|
| 748 | ((and (>= low 0) (<= high 255))
|
|---|
| 749 | :unsigned-8-bit-vector)
|
|---|
| 750 | ((and (>= low 0) (<= high 65535))
|
|---|
| 751 | :unsigned-16-bit-vector)
|
|---|
| 752 | ((and (>= low 0) (<= high #xffffffff))
|
|---|
| 753 | :unsigned-32-bit-vector)
|
|---|
| 754 | ((and (>= low 0) (<= high #xffffffffffffffff))
|
|---|
| 755 | :unsigned-64-bit-vector)
|
|---|
| 756 | ((and (>= low -128) (<= high 127))
|
|---|
| 757 | :signed-8-bit-vector)
|
|---|
| 758 | ((and (>= low -32768) (<= high 32767))
|
|---|
| 759 | :signed-16-bit-vector)
|
|---|
| 760 | ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
|
|---|
| 761 | :signed-32-bit-vector)
|
|---|
| 762 | ((and (>= low target-most-negative-fixnum)
|
|---|
| 763 | (<= high target-most-positive-fixnum))
|
|---|
| 764 | :fixnum-vector)
|
|---|
| 765 | ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
|
|---|
| 766 | :signed-64-bit-vector)
|
|---|
| 767 | (t :simple-vector))))
|
|---|
| 768 | (float
|
|---|
| 769 | (case (ccl::numeric-ctype-format element-type)
|
|---|
| 770 | ((double-float long-float) :double-float-vector)
|
|---|
| 771 | ((single-float short-float) :single-float-vector)
|
|---|
| 772 | (t :simple-vector)))
|
|---|
| 773 | (t :simple-vector))))
|
|---|
| 774 | (ccl::unknown-ctype)
|
|---|
| 775 | (ccl::named-ctype
|
|---|
| 776 | (if (eq element-type ccl::*universal-type*)
|
|---|
| 777 | :simple-vector))
|
|---|
| 778 | (t)))))
|
|---|
| 779 |
|
|---|
| 780 | (defun ppc64-misc-byte-count (subtag element-count)
|
|---|
| 781 | (declare (fixnum subtag))
|
|---|
| 782 | (if (= lowtag-nodeheader (logand subtag lowtagmask))
|
|---|
| 783 | (ash element-count 3)
|
|---|
| 784 | (case (logand subtag fulltagmask)
|
|---|
| 785 | (#.ivector-class-64-bit (ash element-count 3))
|
|---|
| 786 | (#.ivector-class-32-bit (ash element-count 2))
|
|---|
| 787 | (#.ivector-class-8-bit element-count)
|
|---|
| 788 | (t
|
|---|
| 789 | (if (= subtag subtag-bit-vector)
|
|---|
| 790 | (ash (+ 7 element-count) -3)
|
|---|
| 791 | (ash element-count 1))))))
|
|---|
| 792 |
|
|---|
| 793 | (defparameter *ppc64-target-arch*
|
|---|
| 794 | (arch::make-target-arch :name :ppc64
|
|---|
| 795 | :lisp-node-size 8
|
|---|
| 796 | :nil-value nil-value
|
|---|
| 797 | :fixnum-shift fixnumshift
|
|---|
| 798 | :most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift))))
|
|---|
| 799 | :most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift))))
|
|---|
| 800 | :misc-data-offset misc-data-offset
|
|---|
| 801 | :misc-dfloat-offset misc-dfloat-offset
|
|---|
| 802 | :nbits-in-word 64
|
|---|
| 803 | :ntagbits 4
|
|---|
| 804 | :nlisptagbits 3
|
|---|
| 805 | :uvector-subtags *ppc64-target-uvector-subtags*
|
|---|
| 806 | :max-64-bit-constant-index max-64-bit-constant-index
|
|---|
| 807 | :max-32-bit-constant-index max-32-bit-constant-index
|
|---|
| 808 | :max-16-bit-constant-index max-16-bit-constant-index
|
|---|
| 809 | :max-8-bit-constant-index max-8-bit-constant-index
|
|---|
| 810 | :max-1-bit-constant-index max-1-bit-constant-index
|
|---|
| 811 | :word-shift 3
|
|---|
| 812 | :code-vector-prefix '(#$"CODE")
|
|---|
| 813 | :gvector-types '(:ratio :complex :symbol :function
|
|---|
| 814 | :catch-frame :struct :istruct
|
|---|
| 815 | :pool :population :hash-vector
|
|---|
| 816 | :package :value-cell :instance
|
|---|
| 817 | :lock :slot-vector
|
|---|
| 818 | :simple-vector)
|
|---|
| 819 | :1-bit-ivector-types '(:bit-vector)
|
|---|
| 820 | :8-bit-ivector-types '(:signed-8-bit-vector
|
|---|
| 821 | :unsigned-8-bit-vector)
|
|---|
| 822 | :16-bit-ivector-types '(:signed-16-bit-vector
|
|---|
| 823 | :unsigned-16-bit-vector)
|
|---|
| 824 | :32-bit-ivector-types '(:signed-32-bit-vector
|
|---|
| 825 | :unsigned-32-bit-vector
|
|---|
| 826 | :single-float-vector
|
|---|
| 827 | :double-float
|
|---|
| 828 | :bignum
|
|---|
| 829 | :simple-string)
|
|---|
| 830 | :64-bit-ivector-types '(:double-float-vector
|
|---|
| 831 | :unsigned-64-bit-vector
|
|---|
| 832 | :signed-64-bit-vector
|
|---|
| 833 | :fixnum-vector)
|
|---|
| 834 | :array-type-name-from-ctype-function
|
|---|
| 835 | #'ppc64-array-type-name-from-ctype
|
|---|
| 836 | :package-name "PPC64"
|
|---|
| 837 | :t-offset t-offset
|
|---|
| 838 | :array-data-size-function #'ppc64-misc-byte-count
|
|---|
| 839 | :numeric-type-name-to-typecode-function
|
|---|
| 840 | #'(lambda (type-name)
|
|---|
| 841 | (ecase type-name
|
|---|
| 842 | (fixnum tag-fixnum)
|
|---|
| 843 | (bignum subtag-bignum)
|
|---|
| 844 | ((short-float single-float) subtag-single-float)
|
|---|
| 845 | ((long-float double-float) subtag-double-float)
|
|---|
| 846 | (ratio subtag-ratio)
|
|---|
| 847 | (complex subtag-complex)))
|
|---|
| 848 | :subprims-base ppc::*ppc-subprims-base*
|
|---|
| 849 | :subprims-shift ppc::*ppc-subprims-shift*
|
|---|
| 850 | :subprims-table ppc::*ppc-subprims*
|
|---|
| 851 | :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-subprims*)))
|
|---|
| 852 | :unbound-marker-value unbound-marker
|
|---|
| 853 | :slot-unbound-marker-value slot-unbound-marker
|
|---|
| 854 | :fixnum-tag tag-fixnum
|
|---|
| 855 | :single-float-tag subtag-single-float
|
|---|
| 856 | :single-float-tag-is-subtag nil
|
|---|
| 857 | :double-float-tag subtag-double-float
|
|---|
| 858 | :cons-tag fulltag-cons
|
|---|
| 859 | :null-tag subtag-symbol
|
|---|
| 860 | :symbol-tag subtag-symbol
|
|---|
| 861 | :symbol-tag-is-subtag t
|
|---|
| 862 | :function-tag subtag-function
|
|---|
| 863 | :function-tag-is-subtag t
|
|---|
| 864 | :big-endian t
|
|---|
| 865 | :misc-subtag-offset misc-subtag-offset
|
|---|
| 866 | :car-offset cons.car
|
|---|
| 867 | :cdr-offset cons.cdr
|
|---|
| 868 | :subtag-char subtag-character
|
|---|
| 869 | :charcode-shift charcode-shift
|
|---|
| 870 | :fulltagmask fulltagmask
|
|---|
| 871 | :fulltag-misc fulltag-misc
|
|---|
| 872 | :char-code-limit #x110000
|
|---|
| 873 | ))
|
|---|
| 874 |
|
|---|
| 875 | ;;; arch macros
|
|---|
| 876 | (defmacro defppc64archmacro (name lambda-list &body body)
|
|---|
| 877 | `(arch::defarchmacro :ppc64 ,name ,lambda-list ,@body))
|
|---|
| 878 |
|
|---|
| 879 | (defppc64archmacro ccl::%make-sfloat ()
|
|---|
| 880 | (error "~s shouldn't be used in code targeting :PPC64" 'ccl::%make-sfloat))
|
|---|
| 881 |
|
|---|
| 882 | (defppc64archmacro ccl::%make-dfloat ()
|
|---|
| 883 | `(ccl::%alloc-misc ppc64::double-float.element-count ppc64::subtag-double-float))
|
|---|
| 884 |
|
|---|
| 885 | (defppc64archmacro ccl::%numerator (x)
|
|---|
| 886 | `(ccl::%svref ,x ppc64::ratio.numer-cell))
|
|---|
| 887 |
|
|---|
| 888 | (defppc64archmacro ccl::%denominator (x)
|
|---|
| 889 | `(ccl::%svref ,x ppc64::ratio.denom-cell))
|
|---|
| 890 |
|
|---|
| 891 | (defppc64archmacro ccl::%realpart (x)
|
|---|
| 892 | `(ccl::%svref ,x ppc64::complex.realpart-cell))
|
|---|
| 893 |
|
|---|
| 894 | (defppc64archmacro ccl::%imagpart (x)
|
|---|
| 895 | `(ccl::%svref ,x ppc64::complex.imagpart-cell))
|
|---|
| 896 |
|
|---|
| 897 | ;;;
|
|---|
| 898 | (defppc64archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
|
|---|
| 899 | `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)))
|
|---|
| 900 |
|
|---|
| 901 | (defppc64archmacro ccl::codevec-header-p (word)
|
|---|
| 902 | `(eql ,word #$"CODE"))
|
|---|
| 903 |
|
|---|
| 904 | ;;;
|
|---|
| 905 |
|
|---|
| 906 | (defppc64archmacro ccl::immediate-p-macro (thing)
|
|---|
| 907 | (let* ((tag (gensym)))
|
|---|
| 908 | `(let* ((,tag (ccl::lisptag ,thing)))
|
|---|
| 909 | (declare (fixnum ,tag))
|
|---|
| 910 | (or (= ,tag ppc64::tag-fixnum)
|
|---|
| 911 | (= (logand ,tag ppc64::lowtagmask) ppc64::lowtag-imm)))))
|
|---|
| 912 |
|
|---|
| 913 | (defppc64archmacro ccl::hashed-by-identity (thing)
|
|---|
| 914 | (let* ((typecode (gensym)))
|
|---|
| 915 | `(let* ((,typecode (ccl::typecode ,thing)))
|
|---|
| 916 | (declare (fixnum ,typecode))
|
|---|
| 917 | (or
|
|---|
| 918 | (= ,typecode ppc64::tag-fixnum)
|
|---|
| 919 | (= (logand ,typecode ppc64::lowtagmask) ppc64::lowtag-imm)
|
|---|
| 920 | (= ,typecode ppc64::subtag-symbol)
|
|---|
| 921 | (= ,typecode ppc64::subtag-instance)))))
|
|---|
| 922 |
|
|---|
| 923 | ;;;
|
|---|
| 924 | (defppc64archmacro ccl::%get-kernel-global (name)
|
|---|
| 925 | `(ccl::%fixnum-ref 0 (+ ppc64::nil-value
|
|---|
| 926 | ,(%kernel-global
|
|---|
| 927 | (if (ccl::quoted-form-p name)
|
|---|
| 928 | (cadr name)
|
|---|
| 929 | name)))))
|
|---|
| 930 |
|
|---|
| 931 | (defppc64archmacro ccl::%get-kernel-global-ptr (name dest)
|
|---|
| 932 | `(ccl::%setf-macptr
|
|---|
| 933 | ,dest
|
|---|
| 934 | (ccl::%fixnum-ref-macptr 0 (+ ppc64::nil-value
|
|---|
| 935 | ,(%kernel-global
|
|---|
| 936 | (if (ccl::quoted-form-p name)
|
|---|
| 937 | (cadr name)
|
|---|
| 938 | name))))))
|
|---|
| 939 |
|
|---|
| 940 | (defppc64archmacro ccl::%target-kernel-global (name)
|
|---|
| 941 | `(ppc64::%kernel-global ,name))
|
|---|
| 942 |
|
|---|
| 943 | (defppc64archmacro ccl::lfun-vector (fn)
|
|---|
| 944 | fn)
|
|---|
| 945 |
|
|---|
| 946 | (defppc64archmacro ccl::lfun-vector-lfun (lfv)
|
|---|
| 947 | lfv)
|
|---|
| 948 |
|
|---|
| 949 | (defppc64archmacro ccl::area-code ()
|
|---|
| 950 | area.code)
|
|---|
| 951 |
|
|---|
| 952 | (defppc64archmacro ccl::area-succ ()
|
|---|
| 953 | area.succ)
|
|---|
| 954 |
|
|---|
| 955 |
|
|---|
| 956 | (defppc64archmacro ccl::nth-immediate (f i)
|
|---|
| 957 | `(ccl::%svref ,f ,i))
|
|---|
| 958 |
|
|---|
| 959 | (defppc64archmacro ccl::set-nth-immediate (f i new)
|
|---|
| 960 | `(setf (ccl::%svref ,f ,i) ,new))
|
|---|
| 961 |
|
|---|
| 962 |
|
|---|
| 963 | (defppc64archmacro ccl::symptr->symvector (s)
|
|---|
| 964 | s)
|
|---|
| 965 |
|
|---|
| 966 | (defppc64archmacro ccl::symvector->symptr (s)
|
|---|
| 967 | s)
|
|---|
| 968 |
|
|---|
| 969 | (defppc64archmacro ccl::function-to-function-vector (f)
|
|---|
| 970 | f)
|
|---|
| 971 |
|
|---|
| 972 | (defppc64archmacro ccl::function-vector-to-function (v)
|
|---|
| 973 | v)
|
|---|
| 974 |
|
|---|
| 975 | (defppc64archmacro ccl::with-ffcall-results ((buf) &body body)
|
|---|
| 976 | (let* ((size (+ (* 8 8) (* 13 8))))
|
|---|
| 977 | `(ccl::%stack-block ((,buf ,size))
|
|---|
| 978 | ,@body)))
|
|---|
| 979 |
|
|---|
| 980 |
|
|---|
| 981 |
|
|---|
| 982 | (provide "PPC64-ARCH")
|
|---|
