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