| 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 | (defconstant min-array-subtag subtag-arrayH)
|
|---|
| 192 | (defconstant min-vector-subtag subtag-vectorH)
|
|---|
| 193 |
|
|---|
| 194 | ;;; bits: 64 32 16 8 1
|
|---|
| 195 | ;;; CL-array ivector types DOUBLE-FLOAT SINGLE s16 CHAR BIT
|
|---|
| 196 | ;;; s64 s32 u16 s8
|
|---|
| 197 | ;;; u64 u32 u8
|
|---|
| 198 | ;;; Other ivector types MACPTR CODE-VECTOR
|
|---|
| 199 | ;;; DEAD-MACPTR XCODE-VECTOR
|
|---|
| 200 | ;;; BIGNUM
|
|---|
| 201 | ;;; DOUBLE-FLOAT
|
|---|
| 202 | ;;; There might possibly be ivectors with 128-bit (VMX/AltiVec) elements
|
|---|
| 203 | ;;; someday, and there might be multiple character sizes (16/32 bits).
|
|---|
| 204 | ;;; That sort of suggests that we use the four immheader classes to
|
|---|
| 205 | ;;; encode the ivector size (64, 32, 8, other) and make BIT an easily-
|
|---|
| 206 | ;;; detected case of OTHER.
|
|---|
| 207 |
|
|---|
| 208 | (defconstant ivector-class-64-bit fulltag-immheader-3)
|
|---|
| 209 | (defconstant ivector-class-32-bit fulltag-immheader-2)
|
|---|
| 210 | (defconstant ivector-class-other-bit fulltag-immheader-1)
|
|---|
| 211 | (defconstant ivector-class-8-bit fulltag-immheader-0)
|
|---|
| 212 |
|
|---|
| 213 | (define-cl-array-subtag s64-vector ivector-class-64-bit 1)
|
|---|
| 214 | (define-cl-array-subtag u64-vector ivector-class-64-bit 2)
|
|---|
| 215 | (define-cl-array-subtag fixnum-vector ivector-class-64-bit 3)
|
|---|
| 216 | (define-cl-array-subtag double-float-vector ivector-class-64-bit 4)
|
|---|
| 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 bit-vector ivector-class-other-bit 7)
|
|---|
| 224 | (define-cl-array-subtag s8-vector ivector-class-8-bit 1)
|
|---|
| 225 | (define-cl-array-subtag u8-vector ivector-class-8-bit 2)
|
|---|
| 226 |
|
|---|
| 227 | ;;; There's some room for expansion in non-array ivector space.
|
|---|
| 228 | (define-subtag macptr ivector-class-64-bit 1)
|
|---|
| 229 | (define-subtag dead-macptr ivector-class-64-bit 2)
|
|---|
| 230 |
|
|---|
| 231 | (define-subtag code-vector ivector-class-32-bit 0)
|
|---|
| 232 | (define-subtag xcode-vector ivector-class-32-bit 1)
|
|---|
| 233 | (define-subtag bignum ivector-class-32-bit 2)
|
|---|
| 234 | (define-subtag double-float ivector-class-32-bit 3)
|
|---|
| 235 |
|
|---|
| 236 | ;;; Size doesn't matter for non-CL-array gvectors; I can't think of a good
|
|---|
| 237 | ;;; reason to classify them in any particular way. Let's put funcallable
|
|---|
| 238 | ;;; things in the first slice by themselves, though it's not clear that
|
|---|
| 239 | ;;; that helps FUNCALL much.
|
|---|
| 240 | (defconstant gvector-funcallable fulltag-nodeheader-0)
|
|---|
| 241 | (define-subtag function gvector-funcallable 0)
|
|---|
| 242 | (define-subtag symbol gvector-funcallable 1)
|
|---|
| 243 |
|
|---|
| 244 | (define-subtag catch-frame fulltag-nodeheader-1 0)
|
|---|
| 245 | (define-subtag basic-stream fulltag-nodeheader-1 1)
|
|---|
| 246 | (define-subtag lock fulltag-nodeheader-1 2)
|
|---|
| 247 | (define-subtag hash-vector fulltag-nodeheader-1 3)
|
|---|
| 248 | (define-subtag pool fulltag-nodeheader-1 4)
|
|---|
| 249 | (define-subtag weak fulltag-nodeheader-1 5)
|
|---|
| 250 | (define-subtag package fulltag-nodeheader-1 6)
|
|---|
| 251 | (define-subtag slot-vector fulltag-nodeheader-2 0)
|
|---|
| 252 | (define-subtag instance fulltag-nodeheader-2 1)
|
|---|
| 253 | (define-subtag struct fulltag-nodeheader-2 2)
|
|---|
| 254 | (define-subtag istruct fulltag-nodeheader-2 3)
|
|---|
| 255 | (define-subtag value-cell fulltag-nodeheader-2 4)
|
|---|
| 256 | (define-subtag xfunction fulltag-nodeheader-2 5)
|
|---|
| 257 |
|
|---|
| 258 | (define-subtag ratio fulltag-nodeheader-3 0)
|
|---|
| 259 | (define-subtag complex fulltag-nodeheader-3 1)
|
|---|
| 260 |
|
|---|
| 261 |
|
|---|
| 262 |
|
|---|
| 263 | (eval-when (:compile-toplevel :load-toplevel :execute)
|
|---|
| 264 | (require "PPC-ARCH")
|
|---|
| 265 | (defmacro define-storage-layout (name origin &rest cells)
|
|---|
| 266 | `(progn
|
|---|
| 267 | (ccl::defenum (:start ,origin :step 8)
|
|---|
| 268 | ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell)) cells))
|
|---|
| 269 | (defconstant ,(ccl::form-symbol name ".SIZE") ,(* (length cells)
|
|---|
| 270 | 8))))
|
|---|
| 271 |
|
|---|
| 272 | (defmacro define-lisp-object (name tagname &rest cells)
|
|---|
| 273 | `(define-storage-layout ,name ,(- (symbol-value tagname)) ,@cells))
|
|---|
| 274 |
|
|---|
| 275 |
|
|---|
| 276 |
|
|---|
| 277 | (defmacro define-fixedsized-object (name &rest non-header-cells)
|
|---|
| 278 | `(progn
|
|---|
| 279 | (define-lisp-object ,name fulltag-misc header ,@non-header-cells)
|
|---|
| 280 | (ccl::defenum ()
|
|---|
| 281 | ,@(mapcar #'(lambda (cell) (ccl::form-symbol name "." cell "-CELL")) non-header-cells))
|
|---|
| 282 | (defconstant ,(ccl::form-symbol name ".ELEMENT-COUNT") ,(length non-header-cells))))
|
|---|
| 283 |
|
|---|
| 284 |
|
|---|
| 285 |
|
|---|
| 286 |
|
|---|
| 287 |
|
|---|
| 288 |
|
|---|
| 289 |
|
|---|
| 290 | (defconstant misc-header-offset (- fulltag-misc))
|
|---|
| 291 | (defconstant misc-subtag-offset (+ misc-header-offset 7 ))
|
|---|
| 292 | (defconstant misc-data-offset (+ misc-header-offset 8))
|
|---|
| 293 | (defconstant misc-dfloat-offset (+ misc-header-offset 8))
|
|---|
| 294 |
|
|---|
| 295 |
|
|---|
| 296 |
|
|---|
| 297 | (define-subtag single-float fulltag-imm-0 0)
|
|---|
| 298 |
|
|---|
| 299 | (define-subtag character fulltag-imm-1 0)
|
|---|
| 300 |
|
|---|
| 301 | ;;; FULLTAG-IMM-2 is unused, so the only type with lisptag (3-bit tag)
|
|---|
| 302 | ;;; TAG-IMM-0 should be SINGLE-FLOAT.
|
|---|
| 303 |
|
|---|
| 304 | (define-subtag unbound fulltag-imm-3 0)
|
|---|
| 305 | (defconstant unbound-marker subtag-unbound)
|
|---|
| 306 | (defconstant undefined unbound-marker)
|
|---|
| 307 | (define-subtag slot-unbound fulltag-imm-3 1)
|
|---|
| 308 | (defconstant slot-unbound-marker subtag-slot-unbound)
|
|---|
| 309 | (define-subtag illegal fulltag-imm-3 2)
|
|---|
| 310 | (defconstant illegal-marker subtag-illegal)
|
|---|
| 311 |
|
|---|
| 312 | (define-subtag no-thread-local-binding fulltag-imm-3 3)
|
|---|
| 313 | (define-subtag forward-marker fulltag-imm-3 7)
|
|---|
| 314 |
|
|---|
| 315 |
|
|---|
| 316 | (defconstant max-64-bit-constant-index (ash (+ #x7fff ppc64::misc-dfloat-offset) -3))
|
|---|
| 317 | (defconstant max-32-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) -2))
|
|---|
| 318 | (defconstant max-16-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) -1))
|
|---|
| 319 | (defconstant max-8-bit-constant-index (+ #x7fff ppc64::misc-data-offset))
|
|---|
| 320 | (defconstant max-1-bit-constant-index (ash (+ #x7fff ppc64::misc-data-offset) 5))
|
|---|
| 321 |
|
|---|
| 322 |
|
|---|
| 323 | ; The objects themselves look something like this:
|
|---|
| 324 |
|
|---|
| 325 | ; Order of CAR and CDR doesn't seem to matter much - there aren't
|
|---|
| 326 | ; too many tricks to be played with predecrement/preincrement addressing.
|
|---|
| 327 | ; Keep them in the confusing MCL 3.0 order, to avoid confusion.
|
|---|
| 328 | (define-lisp-object cons fulltag-cons
|
|---|
| 329 | cdr
|
|---|
| 330 | car)
|
|---|
| 331 |
|
|---|
| 332 |
|
|---|
| 333 | (define-fixedsized-object ratio
|
|---|
| 334 | numer
|
|---|
| 335 | denom)
|
|---|
| 336 |
|
|---|
| 337 | ;;; It's slightly easier (for bootstrapping reasons)
|
|---|
| 338 | ;;; to view a DOUBLE-FLOAT as being UVECTOR with 2 32-bit elements
|
|---|
| 339 | ;;; (rather than 1 64-bit element).
|
|---|
| 340 |
|
|---|
| 341 | (defconstant double-float.value misc-data-offset)
|
|---|
| 342 | (defconstant double-float.value-cell 0)
|
|---|
| 343 | (defconstant double-float.val-high double-float.value)
|
|---|
| 344 | (defconstant double-float.val-high-cell double-float.value-cell)
|
|---|
| 345 | (defconstant double-float.val-low (+ double-float.value 4))
|
|---|
| 346 | (defconstant double-float.val-low-cell 1)
|
|---|
| 347 | (defconstant double-float.element-count 2)
|
|---|
| 348 | (defconstant double-float.size 16)
|
|---|
| 349 |
|
|---|
| 350 | (define-fixedsized-object complex
|
|---|
| 351 | realpart
|
|---|
| 352 | imagpart
|
|---|
| 353 | )
|
|---|
| 354 |
|
|---|
| 355 |
|
|---|
| 356 | ; There are two kinds of macptr; use the length field of the header if you
|
|---|
| 357 | ; need to distinguish between them
|
|---|
| 358 | (define-fixedsized-object macptr
|
|---|
| 359 | address
|
|---|
| 360 | domain
|
|---|
| 361 | type
|
|---|
| 362 | )
|
|---|
| 363 |
|
|---|
| 364 | (define-fixedsized-object xmacptr
|
|---|
| 365 | address
|
|---|
| 366 | domain
|
|---|
| 367 | type
|
|---|
| 368 | flags
|
|---|
| 369 | link
|
|---|
| 370 | )
|
|---|
| 371 |
|
|---|
| 372 | ; Catch frames go on the tstack; they point to a minimal lisp-frame
|
|---|
| 373 | ; on the cstack. (The catch/unwind-protect PC is on the cstack, where
|
|---|
| 374 | ; the GC expects to find it.)
|
|---|
| 375 | (define-fixedsized-object catch-frame
|
|---|
| 376 | catch-tag ; #<unbound> -> unwind-protect, else catch
|
|---|
| 377 | link ; tagged pointer to next older catch frame
|
|---|
| 378 | mvflag ; 0 if single-value, 1 if uwp or multiple-value
|
|---|
| 379 | csp ; pointer to control stack
|
|---|
| 380 | db-link ; value of dynamic-binding link on thread entry.
|
|---|
| 381 | save-save7 ; saved registers
|
|---|
| 382 | save-save6
|
|---|
| 383 | save-save5
|
|---|
| 384 | save-save4
|
|---|
| 385 | save-save3
|
|---|
| 386 | save-save2
|
|---|
| 387 | save-save1
|
|---|
| 388 | save-save0
|
|---|
| 389 | xframe ; exception-frame link
|
|---|
| 390 | tsp-segment ; mostly padding, for now.
|
|---|
| 391 | )
|
|---|
| 392 |
|
|---|
| 393 | (define-fixedsized-object lock
|
|---|
| 394 | _value ;finalizable pointer to kernel object
|
|---|
| 395 | kind ; '0 = recursive-lock, '1 = rwlock
|
|---|
| 396 | writer ;tcr of owning thread or 0
|
|---|
| 397 | name
|
|---|
| 398 | whostate
|
|---|
| 399 | whostate-2
|
|---|
| 400 | )
|
|---|
| 401 |
|
|---|
| 402 |
|
|---|
| 403 |
|
|---|
| 404 | (define-fixedsized-object symbol
|
|---|
| 405 | pname
|
|---|
| 406 | vcell
|
|---|
| 407 | fcell
|
|---|
| 408 | package-predicate
|
|---|
| 409 | flags
|
|---|
| 410 | plist
|
|---|
| 411 | binding-index
|
|---|
| 412 | )
|
|---|
| 413 |
|
|---|
| 414 |
|
|---|
| 415 | (defconstant t-offset (- symbol.size))
|
|---|
| 416 |
|
|---|
| 417 |
|
|---|
| 418 |
|
|---|
| 419 |
|
|---|
| 420 | (define-fixedsized-object vectorH
|
|---|
| 421 | logsize ; fillpointer if it has one, physsize otherwise
|
|---|
| 422 | physsize ; total size of (possibly displaced) data vector
|
|---|
| 423 | data-vector ; object this header describes
|
|---|
| 424 | displacement ; true displacement or 0
|
|---|
| 425 | flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
|
|---|
| 426 | )
|
|---|
| 427 |
|
|---|
| 428 | (define-lisp-object arrayH fulltag-misc
|
|---|
| 429 | header ; subtag = subtag-arrayH
|
|---|
| 430 | rank ; NEVER 1
|
|---|
| 431 | physsize ; total size of (possibly displaced) data vector
|
|---|
| 432 | data-vector ; object this header describes
|
|---|
| 433 | displacement ; true displacement or 0
|
|---|
| 434 | flags ; has-fill-pointer,displaced-to,adjustable bits; subtype of underlying simple vector.
|
|---|
| 435 | ;; Dimensions follow
|
|---|
| 436 | )
|
|---|
| 437 |
|
|---|
| 438 | (defconstant arrayH.rank-cell 0)
|
|---|
| 439 | (defconstant arrayH.physsize-cell 1)
|
|---|
| 440 | (defconstant arrayH.data-vector-cell 2)
|
|---|
| 441 | (defconstant arrayH.displacement-cell 3)
|
|---|
| 442 | (defconstant arrayH.flags-cell 4)
|
|---|
| 443 | (defconstant arrayH.dim0-cell 5)
|
|---|
| 444 |
|
|---|
| 445 | (defconstant arrayH.flags-cell-bits-byte (byte 8 0))
|
|---|
| 446 | (defconstant arrayH.flags-cell-subtag-byte (byte 8 8))
|
|---|
| 447 |
|
|---|
| 448 |
|
|---|
| 449 | (define-fixedsized-object value-cell
|
|---|
| 450 | value)
|
|---|
| 451 |
|
|---|
| 452 |
|
|---|
| 453 | ;;; The kernel uses these (rather generically named) structures
|
|---|
| 454 | ;;; to keep track of various memory regions it (or the lisp) is
|
|---|
| 455 | ;;; interested in.
|
|---|
| 456 |
|
|---|
| 457 |
|
|---|
| 458 | (define-storage-layout area 0
|
|---|
| 459 | pred ; pointer to preceding area in DLL
|
|---|
| 460 | succ ; pointer to next area in DLL
|
|---|
| 461 | low ; low bound on area addresses
|
|---|
| 462 | high ; high bound on area addresses.
|
|---|
| 463 | active ; low limit on stacks, high limit on heaps
|
|---|
| 464 | softlimit ; overflow bound
|
|---|
| 465 | hardlimit ; another one
|
|---|
| 466 | code ; an area-code; see below
|
|---|
| 467 | markbits ; bit vector for GC
|
|---|
| 468 | ndnodes ; "active" size of dynamic area or stack
|
|---|
| 469 | older ; in EGC sense
|
|---|
| 470 | younger ; also for EGC
|
|---|
| 471 | h ; Handle or null pointer
|
|---|
| 472 | softprot ; protected_area structure pointer
|
|---|
| 473 | hardprot ; another one.
|
|---|
| 474 | owner ; fragment (library) which "owns" the area
|
|---|
| 475 | refbits ; bitvector for intergenerational refernces
|
|---|
| 476 | threshold ; for egc
|
|---|
| 477 | gc-count ; generational gc count.
|
|---|
| 478 | static-dnodes ; for honsing. etc
|
|---|
| 479 | static-used ; bitvector
|
|---|
| 480 | )
|
|---|
| 481 |
|
|---|
| 482 |
|
|---|
| 483 |
|
|---|
| 484 |
|
|---|
| 485 |
|
|---|
| 486 | (define-storage-layout protected-area 0
|
|---|
| 487 | next
|
|---|
| 488 | start ; first byte (page-aligned) that might be protected
|
|---|
| 489 | end ; last byte (page-aligned) that could be protected
|
|---|
| 490 | nprot ; Might be 0
|
|---|
| 491 | protsize ; number of bytes to protect
|
|---|
| 492 | why)
|
|---|
| 493 |
|
|---|
| 494 | (defconstant tcr-bias 0)
|
|---|
| 495 |
|
|---|
| 496 | (define-storage-layout tcr (- tcr-bias)
|
|---|
| 497 | prev ; in doubly-linked list
|
|---|
| 498 | next ; in doubly-linked list
|
|---|
| 499 | single-float-convert ; per-thread scratch space.
|
|---|
| 500 | lisp-fpscr-high
|
|---|
| 501 | db-link ; special binding chain head
|
|---|
| 502 | catch-top ; top catch frame
|
|---|
| 503 | save-vsp ; VSP when in foreign code
|
|---|
| 504 | save-tsp ; TSP when in foreign code
|
|---|
| 505 | cs-area ; cstack area pointer
|
|---|
| 506 | vs-area ; vstack area pointer
|
|---|
| 507 | ts-area ; tstack area pointer
|
|---|
| 508 | cs-limit ; cstack overflow limit
|
|---|
| 509 | total-bytes-allocated-high
|
|---|
| 510 | log2-allocation-quantum ; unboxed
|
|---|
| 511 | interrupt-pending ; fixnum
|
|---|
| 512 | xframe ; exception frame linked list
|
|---|
| 513 | errno-loc ; thread-private, maybe
|
|---|
| 514 | ffi-exception ; fpscr bits from ff-call.
|
|---|
| 515 | osid ; OS thread id
|
|---|
| 516 | valence ; odd when in foreign code
|
|---|
| 517 | foreign-exception-status
|
|---|
| 518 | native-thread-info
|
|---|
| 519 | native-thread-id
|
|---|
| 520 | last-allocptr
|
|---|
| 521 | save-allocptr
|
|---|
| 522 | save-allocbase
|
|---|
| 523 | reset-completion
|
|---|
| 524 | activate
|
|---|
| 525 | suspend-count
|
|---|
| 526 | suspend-context
|
|---|
| 527 | pending-exception-context
|
|---|
| 528 | suspend ; semaphore for suspension notify
|
|---|
| 529 | resume ; sempahore for resumption notify
|
|---|
| 530 | flags ; foreign, being reset, ...
|
|---|
| 531 | gc-context
|
|---|
| 532 | termination-semaphore
|
|---|
| 533 | unwinding
|
|---|
| 534 | tlb-limit
|
|---|
| 535 | tlb-pointer
|
|---|
| 536 | shutdown-count
|
|---|
| 537 | safe-ref-address
|
|---|
| 538 | )
|
|---|
| 539 |
|
|---|
| 540 | (defconstant interrupt-level-binding-index (ash 1 fixnumshift))
|
|---|
| 541 |
|
|---|
| 542 | (defconstant tcr.lisp-fpscr-low (+ tcr.lisp-fpscr-high 4))
|
|---|
| 543 | (defconstant tcr.total-bytes-allocated-low (+ tcr.total-bytes-allocated-high 4))
|
|---|
| 544 |
|
|---|
| 545 | (define-storage-layout lockptr 0
|
|---|
| 546 | avail
|
|---|
| 547 | owner
|
|---|
| 548 | count
|
|---|
| 549 | signal
|
|---|
| 550 | waiting
|
|---|
| 551 | malloced-ptr
|
|---|
| 552 | spinlock)
|
|---|
| 553 |
|
|---|
| 554 | (define-storage-layout rwlock 0
|
|---|
| 555 | spin
|
|---|
| 556 | state
|
|---|
| 557 | blocked-writers
|
|---|
| 558 | blocked-readers
|
|---|
| 559 | writer
|
|---|
| 560 | reader-signal
|
|---|
| 561 | writer-signal
|
|---|
| 562 | malloced-ptr
|
|---|
| 563 | )
|
|---|
| 564 |
|
|---|
| 565 | ;;; For the eabi port: mark this stack frame as Lisp's (since EABI
|
|---|
| 566 | ;;; foreign frames can be the same size as a lisp frame.)
|
|---|
| 567 |
|
|---|
| 568 |
|
|---|
| 569 | (ppc64::define-storage-layout lisp-frame 0
|
|---|
| 570 | backlink
|
|---|
| 571 | savefn
|
|---|
| 572 | savelr
|
|---|
| 573 | savevsp
|
|---|
| 574 | )
|
|---|
| 575 |
|
|---|
| 576 | (ppc64::define-storage-layout c-frame 0
|
|---|
| 577 | backlink
|
|---|
| 578 | crsave
|
|---|
| 579 | savelr
|
|---|
| 580 | unused-1
|
|---|
| 581 | unused-2
|
|---|
| 582 | savetoc
|
|---|
| 583 | param0
|
|---|
| 584 | param1
|
|---|
| 585 | param2
|
|---|
| 586 | param3
|
|---|
| 587 | param4
|
|---|
| 588 | param5
|
|---|
| 589 | param6
|
|---|
| 590 | param7
|
|---|
| 591 | )
|
|---|
| 592 |
|
|---|
| 593 | (defconstant c-frame.minsize c-frame.size)
|
|---|
| 594 |
|
|---|
| 595 | (defmacro define-header (name element-count subtag)
|
|---|
| 596 | `(defconstant ,name (logior (ash ,element-count num-subtag-bits) ,subtag)))
|
|---|
| 597 |
|
|---|
| 598 | (define-header double-float-header double-float.element-count subtag-double-float)
|
|---|
| 599 | ;;; We could possibly have a one-digit bignum header when dealing
|
|---|
| 600 | ;;; with "small bignums" in some bignum code. Like other cases of
|
|---|
| 601 | ;;; non-normalized bignums, they should never escape from the lab.
|
|---|
| 602 | (define-header one-digit-bignum-header 1 subtag-bignum)
|
|---|
| 603 | (define-header two-digit-bignum-header 2 subtag-bignum)
|
|---|
| 604 | (define-header three-digit-bignum-header 3 subtag-bignum)
|
|---|
| 605 | (define-header four-digit-bignum-header 4 subtag-bignum)
|
|---|
| 606 | (define-header five-digit-bignum-header 5 subtag-bignum)
|
|---|
| 607 | (define-header symbol-header symbol.element-count subtag-symbol)
|
|---|
| 608 | (define-header value-cell-header value-cell.element-count subtag-value-cell)
|
|---|
| 609 | (define-header macptr-header macptr.element-count subtag-macptr)
|
|---|
| 610 |
|
|---|
| 611 |
|
|---|
| 612 | (defconstant yield-syscall
|
|---|
| 613 | #+darwinppc-target -60
|
|---|
| 614 | #+linuxppc-target #$__NR_sched_yield)
|
|---|
| 615 | )
|
|---|
| 616 | )
|
|---|
| 617 |
|
|---|
| 618 |
|
|---|
| 619 |
|
|---|
| 620 |
|
|---|
| 621 |
|
|---|
| 622 |
|
|---|
| 623 | (defun %kernel-global (sym)
|
|---|
| 624 | (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
|
|---|
| 625 | (if pos
|
|---|
| 626 | (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
|
|---|
| 627 | (error "Unknown kernel global : ~s ." sym))))
|
|---|
| 628 |
|
|---|
| 629 | (defmacro kernel-global (sym)
|
|---|
| 630 | (let* ((pos (position sym ppc::*ppc-kernel-globals* :test #'string=)))
|
|---|
| 631 | (if pos
|
|---|
| 632 | (- (+ symbol.size fulltag-misc (* (1+ pos) word-size-in-bytes)))
|
|---|
| 633 | (error "Unknown kernel global : ~s ." sym))))
|
|---|
| 634 |
|
|---|
| 635 | ;;; The kernel imports things that are defined in various other
|
|---|
| 636 | ;;; libraries for us. The objects in question are generally
|
|---|
| 637 | ;;; fixnum-tagged; the entries in the "kernel-imports" vector are 8
|
|---|
| 638 | ;;; bytes apart.
|
|---|
| 639 | (ccl::defenum (:prefix "KERNEL-IMPORT-" :start 0 :step word-size-in-bytes)
|
|---|
| 640 | fd-setsize-bytes
|
|---|
| 641 | do-fd-set
|
|---|
| 642 | do-fd-clr
|
|---|
| 643 | do-fd-is-set
|
|---|
| 644 | do-fd-zero
|
|---|
| 645 | MakeDataExecutable
|
|---|
| 646 | GetSharedLibrary
|
|---|
| 647 | FindSymbol
|
|---|
| 648 | malloc
|
|---|
| 649 | free
|
|---|
| 650 | jvm-init
|
|---|
| 651 | tcr-frame-ptr
|
|---|
| 652 | register-xmacptr-dispose-function
|
|---|
| 653 | open-debug-output
|
|---|
| 654 | get-r-debug
|
|---|
| 655 | restore-soft-stack-limit
|
|---|
| 656 | egc-control
|
|---|
| 657 | lisp-bug
|
|---|
| 658 | NewThread
|
|---|
| 659 | YieldToThread
|
|---|
| 660 | DisposeThread
|
|---|
| 661 | ThreadCurrentStackSpace
|
|---|
| 662 | usage-exit
|
|---|
| 663 | save-fp-context
|
|---|
| 664 | restore-fp-context
|
|---|
| 665 | put-altivec-registers
|
|---|
| 666 | get-altivec-registers
|
|---|
| 667 | new-semaphore
|
|---|
| 668 | wait-on-semaphore
|
|---|
| 669 | signal-semaphore
|
|---|
| 670 | destroy-semaphore
|
|---|
| 671 | new-recursive-lock
|
|---|
| 672 | lock-recursive-lock
|
|---|
| 673 | unlock-recursive-lock
|
|---|
| 674 | destroy-recursive-lock
|
|---|
| 675 | suspend-other-threads
|
|---|
| 676 | resume-other-threads
|
|---|
| 677 | suspend-tcr
|
|---|
| 678 | resume-tcr
|
|---|
| 679 | rwlock-new
|
|---|
| 680 | rwlock-destroy
|
|---|
| 681 | rwlock-rlock
|
|---|
| 682 | rwlock-wlock
|
|---|
| 683 | rwlock-unlock
|
|---|
| 684 | recursive-lock-trylock
|
|---|
| 685 | foreign-name-and-offset
|
|---|
| 686 | lisp-read
|
|---|
| 687 | lisp-write
|
|---|
| 688 | lisp-open
|
|---|
| 689 | lisp-fchmod
|
|---|
| 690 | lisp-lseek
|
|---|
| 691 | lisp-close
|
|---|
| 692 | lisp-ftruncate
|
|---|
| 693 | lisp-stat
|
|---|
| 694 | lisp-fstat
|
|---|
| 695 | lisp-futex
|
|---|
| 696 | lisp-opendir
|
|---|
| 697 | lisp-readdir
|
|---|
| 698 | lisp-closedir
|
|---|
| 699 | lisp-pipe
|
|---|
| 700 | lisp-gettimeofday
|
|---|
| 701 | lisp-sigexit
|
|---|
| 702 | )
|
|---|
| 703 |
|
|---|
| 704 | (defmacro nrs-offset (name)
|
|---|
| 705 | (let* ((pos (position name ppc::*ppc-nilreg-relative-symbols* :test #'eq)))
|
|---|
| 706 | (if pos (* (1- pos) symbol.size))))
|
|---|
| 707 |
|
|---|
| 708 | (defconstant canonical-nil-value (+ #x3000 symbol.size fulltag-misc))
|
|---|
| 709 |
|
|---|
| 710 |
|
|---|
| 711 | (defconstant reservation-discharge #x2008)
|
|---|
| 712 |
|
|---|
| 713 | (defparameter *ppc64-target-uvector-subtags*
|
|---|
| 714 | `((:bignum . ,subtag-bignum)
|
|---|
| 715 | (:ratio . ,subtag-ratio)
|
|---|
| 716 | (:single-float . ,subtag-single-float)
|
|---|
| 717 | (:double-float . ,subtag-double-float)
|
|---|
| 718 | (:complex . ,subtag-complex )
|
|---|
| 719 | (:symbol . ,subtag-symbol)
|
|---|
| 720 | (:function . ,subtag-function )
|
|---|
| 721 | (:code-vector . ,subtag-code-vector)
|
|---|
| 722 | (:xcode-vector . ,subtag-xcode-vector)
|
|---|
| 723 | (:macptr . ,subtag-macptr )
|
|---|
| 724 | (:catch-frame . ,subtag-catch-frame)
|
|---|
| 725 | (:struct . ,subtag-struct )
|
|---|
| 726 | (:istruct . ,subtag-istruct )
|
|---|
| 727 | (:pool . ,subtag-pool )
|
|---|
| 728 | (:population . ,subtag-weak )
|
|---|
| 729 | (:hash-vector . ,subtag-hash-vector )
|
|---|
| 730 | (:package . ,subtag-package )
|
|---|
| 731 | (:value-cell . ,subtag-value-cell)
|
|---|
| 732 | (:instance . ,subtag-instance )
|
|---|
| 733 | (:lock . ,subtag-lock )
|
|---|
| 734 | (:basic-stream . ,subtag-basic-stream)
|
|---|
| 735 | (:slot-vector . ,subtag-slot-vector)
|
|---|
| 736 | (:simple-string . ,subtag-simple-base-string )
|
|---|
| 737 | (:bit-vector . ,subtag-bit-vector )
|
|---|
| 738 | (:signed-8-bit-vector . ,subtag-s8-vector )
|
|---|
| 739 | (:unsigned-8-bit-vector . ,subtag-u8-vector )
|
|---|
| 740 | (:signed-16-bit-vector . ,subtag-s16-vector )
|
|---|
| 741 | (:unsigned-16-bit-vector . ,subtag-u16-vector )
|
|---|
| 742 | (:signed-32-bit-vector . ,subtag-s32-vector )
|
|---|
| 743 | (:unsigned-32-bit-vector . ,subtag-u32-vector )
|
|---|
| 744 | (:fixnum-vector . ,subtag-fixnum-vector)
|
|---|
| 745 | (:signed-64-bit-vector . ,subtag-s64-vector)
|
|---|
| 746 | (:unsigned-64-bit-vector . ,subtag-u64-vector)
|
|---|
| 747 | (:single-float-vector . ,subtag-single-float-vector)
|
|---|
| 748 | (:double-float-vector . ,subtag-double-float-vector )
|
|---|
| 749 | (:simple-vector . ,subtag-simple-vector )
|
|---|
| 750 | (:vector-header . ,subtag-vectorH)
|
|---|
| 751 | (:array-header . ,subtag-arrayH)))
|
|---|
| 752 |
|
|---|
| 753 | ;;; This should return NIL unless it's sure of how the indicated
|
|---|
| 754 | ;;; type would be represented (in particular, it should return
|
|---|
| 755 | ;;; NIL if the element type is unknown or unspecified at compile-time.
|
|---|
| 756 | (defun ppc64-array-type-name-from-ctype (ctype)
|
|---|
| 757 | (when (typep ctype 'ccl::array-ctype)
|
|---|
| 758 | (let* ((element-type (ccl::array-ctype-element-type ctype)))
|
|---|
| 759 | (typecase element-type
|
|---|
| 760 | (ccl::class-ctype
|
|---|
| 761 | (let* ((class (ccl::class-ctype-class element-type)))
|
|---|
| 762 | (if (or (eq class ccl::*character-class*)
|
|---|
| 763 | (eq class ccl::*base-char-class*)
|
|---|
| 764 | (eq class ccl::*standard-char-class*))
|
|---|
| 765 | :simple-string
|
|---|
| 766 | :simple-vector)))
|
|---|
| 767 | (ccl::numeric-ctype
|
|---|
| 768 | (if (eq (ccl::numeric-ctype-complexp element-type) :complex)
|
|---|
| 769 | :simple-vector
|
|---|
| 770 | (case (ccl::numeric-ctype-class element-type)
|
|---|
| 771 | (integer
|
|---|
| 772 | (let* ((low (ccl::numeric-ctype-low element-type))
|
|---|
| 773 | (high (ccl::numeric-ctype-high element-type)))
|
|---|
| 774 | (cond ((or (null low) (null high))
|
|---|
| 775 | :simple-vector)
|
|---|
| 776 | ((and (>= low 0) (<= high 1))
|
|---|
| 777 | :bit-vector)
|
|---|
| 778 | ((and (>= low 0) (<= high 255))
|
|---|
| 779 | :unsigned-8-bit-vector)
|
|---|
| 780 | ((and (>= low 0) (<= high 65535))
|
|---|
| 781 | :unsigned-16-bit-vector)
|
|---|
| 782 | ((and (>= low 0) (<= high #xffffffff))
|
|---|
| 783 | :unsigned-32-bit-vector)
|
|---|
| 784 | ((and (>= low 0) (<= high #xffffffffffffffff))
|
|---|
| 785 | :unsigned-64-bit-vector)
|
|---|
| 786 | ((and (>= low -128) (<= high 127))
|
|---|
| 787 | :signed-8-bit-vector)
|
|---|
| 788 | ((and (>= low -32768) (<= high 32767))
|
|---|
| 789 | :signed-16-bit-vector)
|
|---|
| 790 | ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
|
|---|
| 791 | :signed-32-bit-vector)
|
|---|
| 792 | ((and (>= low target-most-negative-fixnum)
|
|---|
| 793 | (<= high target-most-positive-fixnum))
|
|---|
| 794 | :fixnum-vector)
|
|---|
| 795 | ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
|
|---|
| 796 | :signed-64-bit-vector)
|
|---|
| 797 | (t :simple-vector))))
|
|---|
| 798 | (float
|
|---|
| 799 | (case (ccl::numeric-ctype-format element-type)
|
|---|
| 800 | ((double-float long-float) :double-float-vector)
|
|---|
| 801 | ((single-float short-float) :single-float-vector)
|
|---|
| 802 | (t :simple-vector)))
|
|---|
| 803 | (t :simple-vector))))
|
|---|
| 804 | (ccl::unknown-ctype)
|
|---|
| 805 | (ccl::named-ctype
|
|---|
| 806 | (if (eq element-type ccl::*universal-type*)
|
|---|
| 807 | :simple-vector))
|
|---|
| 808 | (t)))))
|
|---|
| 809 |
|
|---|
| 810 | (defun ppc64-misc-byte-count (subtag element-count)
|
|---|
| 811 | (declare (fixnum subtag))
|
|---|
| 812 | (if (= lowtag-nodeheader (logand subtag lowtagmask))
|
|---|
| 813 | (ash element-count 3)
|
|---|
| 814 | (case (logand subtag fulltagmask)
|
|---|
| 815 | (#.ivector-class-64-bit (ash element-count 3))
|
|---|
| 816 | (#.ivector-class-32-bit (ash element-count 2))
|
|---|
| 817 | (#.ivector-class-8-bit element-count)
|
|---|
| 818 | (t
|
|---|
| 819 | (if (= subtag subtag-bit-vector)
|
|---|
| 820 | (ash (+ 7 element-count) -3)
|
|---|
| 821 | (ash element-count 1))))))
|
|---|
| 822 |
|
|---|
| 823 | (defparameter *ppc64-target-arch*
|
|---|
| 824 | (arch::make-target-arch :name :ppc64
|
|---|
| 825 | :lisp-node-size 8
|
|---|
| 826 | :nil-value canonical-nil-value
|
|---|
| 827 | :fixnum-shift fixnumshift
|
|---|
| 828 | :most-positive-fixnum (1- (ash 1 (1- (- 64 fixnumshift))))
|
|---|
| 829 | :most-negative-fixnum (- (ash 1 (1- (- 64 fixnumshift))))
|
|---|
| 830 | :misc-data-offset misc-data-offset
|
|---|
| 831 | :misc-dfloat-offset misc-dfloat-offset
|
|---|
| 832 | :nbits-in-word 64
|
|---|
| 833 | :ntagbits 4
|
|---|
| 834 | :nlisptagbits 3
|
|---|
| 835 | :uvector-subtags *ppc64-target-uvector-subtags*
|
|---|
| 836 | :max-64-bit-constant-index max-64-bit-constant-index
|
|---|
| 837 | :max-32-bit-constant-index max-32-bit-constant-index
|
|---|
| 838 | :max-16-bit-constant-index max-16-bit-constant-index
|
|---|
| 839 | :max-8-bit-constant-index max-8-bit-constant-index
|
|---|
| 840 | :max-1-bit-constant-index max-1-bit-constant-index
|
|---|
| 841 | :word-shift 3
|
|---|
| 842 | :code-vector-prefix '(#$"CODE")
|
|---|
| 843 | :gvector-types '(:ratio :complex :symbol :function
|
|---|
| 844 | :catch-frame :struct :istruct
|
|---|
| 845 | :pool :population :hash-vector
|
|---|
| 846 | :package :value-cell :instance
|
|---|
| 847 | :lock :slot-vector
|
|---|
| 848 | :simple-vector)
|
|---|
| 849 | :1-bit-ivector-types '(:bit-vector)
|
|---|
| 850 | :8-bit-ivector-types '(:signed-8-bit-vector
|
|---|
| 851 | :unsigned-8-bit-vector)
|
|---|
| 852 | :16-bit-ivector-types '(:signed-16-bit-vector
|
|---|
| 853 | :unsigned-16-bit-vector)
|
|---|
| 854 | :32-bit-ivector-types '(:signed-32-bit-vector
|
|---|
| 855 | :unsigned-32-bit-vector
|
|---|
| 856 | :single-float-vector
|
|---|
| 857 | :double-float
|
|---|
| 858 | :bignum
|
|---|
| 859 | :simple-string)
|
|---|
| 860 | :64-bit-ivector-types '(:double-float-vector
|
|---|
| 861 | :unsigned-64-bit-vector
|
|---|
| 862 | :signed-64-bit-vector
|
|---|
| 863 | :fixnum-vector)
|
|---|
| 864 | :array-type-name-from-ctype-function
|
|---|
| 865 | #'ppc64-array-type-name-from-ctype
|
|---|
| 866 | :package-name "PPC64"
|
|---|
| 867 | :t-offset t-offset
|
|---|
| 868 | :array-data-size-function #'ppc64-misc-byte-count
|
|---|
| 869 | :numeric-type-name-to-typecode-function
|
|---|
| 870 | #'(lambda (type-name)
|
|---|
| 871 | (ecase type-name
|
|---|
| 872 | (fixnum tag-fixnum)
|
|---|
| 873 | (bignum subtag-bignum)
|
|---|
| 874 | ((short-float single-float) subtag-single-float)
|
|---|
| 875 | ((long-float double-float) subtag-double-float)
|
|---|
| 876 | (ratio subtag-ratio)
|
|---|
| 877 | (complex subtag-complex)))
|
|---|
| 878 | :subprims-base ppc::*ppc-subprims-base*
|
|---|
| 879 | :subprims-shift ppc::*ppc-subprims-shift*
|
|---|
| 880 | :subprims-table ppc::*ppc-subprims*
|
|---|
| 881 | :primitive->subprims `(((0 . 23) . ,(ccl::%subprim-name->offset '.SPbuiltin-plus ppc::*ppc-subprims*)))
|
|---|
| 882 | :unbound-marker-value unbound-marker
|
|---|
| 883 | :slot-unbound-marker-value slot-unbound-marker
|
|---|
| 884 | :fixnum-tag tag-fixnum
|
|---|
| 885 | :single-float-tag subtag-single-float
|
|---|
| 886 | :single-float-tag-is-subtag nil
|
|---|
| 887 | :double-float-tag subtag-double-float
|
|---|
| 888 | :cons-tag fulltag-cons
|
|---|
| 889 | :null-tag subtag-symbol
|
|---|
| 890 | :symbol-tag subtag-symbol
|
|---|
| 891 | :symbol-tag-is-subtag t
|
|---|
| 892 | :function-tag subtag-function
|
|---|
| 893 | :function-tag-is-subtag t
|
|---|
| 894 | :big-endian t
|
|---|
| 895 | :misc-subtag-offset misc-subtag-offset
|
|---|
| 896 | :car-offset cons.car
|
|---|
| 897 | :cdr-offset cons.cdr
|
|---|
| 898 | :subtag-char subtag-character
|
|---|
| 899 | :charcode-shift charcode-shift
|
|---|
| 900 | :fulltagmask fulltagmask
|
|---|
| 901 | :fulltag-misc fulltag-misc
|
|---|
| 902 | :char-code-limit #x110000
|
|---|
| 903 | ))
|
|---|
| 904 |
|
|---|
| 905 | ;;; arch macros
|
|---|
| 906 | (defmacro defppc64archmacro (name lambda-list &body body)
|
|---|
| 907 | `(arch::defarchmacro :ppc64 ,name ,lambda-list ,@body))
|
|---|
| 908 |
|
|---|
| 909 | (defppc64archmacro ccl::%make-sfloat ()
|
|---|
| 910 | (error "~s shouldn't be used in code targeting :PPC64" 'ccl::%make-sfloat))
|
|---|
| 911 |
|
|---|
| 912 | (defppc64archmacro ccl::%make-dfloat ()
|
|---|
| 913 | `(ccl::%alloc-misc ppc64::double-float.element-count ppc64::subtag-double-float))
|
|---|
| 914 |
|
|---|
| 915 | (defppc64archmacro ccl::%numerator (x)
|
|---|
| 916 | `(ccl::%svref ,x ppc64::ratio.numer-cell))
|
|---|
| 917 |
|
|---|
| 918 | (defppc64archmacro ccl::%denominator (x)
|
|---|
| 919 | `(ccl::%svref ,x ppc64::ratio.denom-cell))
|
|---|
| 920 |
|
|---|
| 921 | (defppc64archmacro ccl::%realpart (x)
|
|---|
| 922 | `(ccl::%svref ,x ppc64::complex.realpart-cell))
|
|---|
| 923 |
|
|---|
| 924 | (defppc64archmacro ccl::%imagpart (x)
|
|---|
| 925 | `(ccl::%svref ,x ppc64::complex.imagpart-cell))
|
|---|
| 926 |
|
|---|
| 927 | ;;;
|
|---|
| 928 | (defppc64archmacro ccl::%get-single-float-from-double-ptr (ptr offset)
|
|---|
| 929 | `(ccl::%double-float->short-float (ccl::%get-double-float ,ptr ,offset)))
|
|---|
| 930 |
|
|---|
| 931 | (defppc64archmacro ccl::codevec-header-p (word)
|
|---|
| 932 | `(eql ,word #$"CODE"))
|
|---|
| 933 |
|
|---|
| 934 | ;;;
|
|---|
| 935 |
|
|---|
| 936 | (defppc64archmacro ccl::immediate-p-macro (thing)
|
|---|
| 937 | (let* ((tag (gensym)))
|
|---|
| 938 | `(let* ((,tag (ccl::lisptag ,thing)))
|
|---|
| 939 | (declare (fixnum ,tag))
|
|---|
| 940 | (or (= ,tag ppc64::tag-fixnum)
|
|---|
| 941 | (= (logand ,tag ppc64::lowtagmask) ppc64::lowtag-imm)))))
|
|---|
| 942 |
|
|---|
| 943 | (defppc64archmacro ccl::hashed-by-identity (thing)
|
|---|
| 944 | (let* ((typecode (gensym)))
|
|---|
| 945 | `(let* ((,typecode (ccl::typecode ,thing)))
|
|---|
| 946 | (declare (fixnum ,typecode))
|
|---|
| 947 | (or
|
|---|
| 948 | (= ,typecode ppc64::tag-fixnum)
|
|---|
| 949 | (= (logand ,typecode ppc64::lowtagmask) ppc64::lowtag-imm)
|
|---|
| 950 | (= ,typecode ppc64::subtag-symbol)
|
|---|
| 951 | (= ,typecode ppc64::subtag-instance)))))
|
|---|
| 952 |
|
|---|
| 953 | ;;;
|
|---|
| 954 | (defppc64archmacro ccl::%get-kernel-global (name)
|
|---|
| 955 | `(ccl::%fixnum-ref 0 (+ ,(ccl::target-nil-value)
|
|---|
| 956 | ,(%kernel-global
|
|---|
| 957 | (if (ccl::quoted-form-p name)
|
|---|
| 958 | (cadr name)
|
|---|
| 959 | name)))))
|
|---|
| 960 |
|
|---|
| 961 | (defppc64archmacro ccl::%get-kernel-global-ptr (name dest)
|
|---|
| 962 | `(ccl::%setf-macptr
|
|---|
| 963 | ,dest
|
|---|
| 964 | (ccl::%fixnum-ref-macptr 0 (+ ,(ccl::target-nil-value)
|
|---|
| 965 | ,(%kernel-global
|
|---|
| 966 | (if (ccl::quoted-form-p name)
|
|---|
| 967 | (cadr name)
|
|---|
| 968 | name))))))
|
|---|
| 969 |
|
|---|
| 970 | (defppc64archmacro ccl::%target-kernel-global (name)
|
|---|
| 971 | `(ppc64::%kernel-global ,name))
|
|---|
| 972 |
|
|---|
| 973 | (defppc64archmacro ccl::lfun-vector (fn)
|
|---|
| 974 | fn)
|
|---|
| 975 |
|
|---|
| 976 | (defppc64archmacro ccl::lfun-vector-lfun (lfv)
|
|---|
| 977 | lfv)
|
|---|
| 978 |
|
|---|
| 979 | (defppc64archmacro ccl::area-code ()
|
|---|
| 980 | area.code)
|
|---|
| 981 |
|
|---|
| 982 | (defppc64archmacro ccl::area-succ ()
|
|---|
| 983 | area.succ)
|
|---|
| 984 |
|
|---|
| 985 |
|
|---|
| 986 | (defppc64archmacro ccl::nth-immediate (f i)
|
|---|
| 987 | `(ccl::%svref ,f ,i))
|
|---|
| 988 |
|
|---|
| 989 | (defppc64archmacro ccl::set-nth-immediate (f i new)
|
|---|
| 990 | `(setf (ccl::%svref ,f ,i) ,new))
|
|---|
| 991 |
|
|---|
| 992 |
|
|---|
| 993 | (defppc64archmacro ccl::symptr->symvector (s)
|
|---|
| 994 | s)
|
|---|
| 995 |
|
|---|
| 996 | (defppc64archmacro ccl::symvector->symptr (s)
|
|---|
| 997 | s)
|
|---|
| 998 |
|
|---|
| 999 | (defppc64archmacro ccl::function-to-function-vector (f)
|
|---|
| 1000 | f)
|
|---|
| 1001 |
|
|---|
| 1002 | (defppc64archmacro ccl::function-vector-to-function (v)
|
|---|
| 1003 | v)
|
|---|
| 1004 |
|
|---|
| 1005 | (defppc64archmacro ccl::with-ffcall-results ((buf) &body body)
|
|---|
| 1006 | (let* ((size (+ (* 8 8) (* 13 8))))
|
|---|
| 1007 | `(ccl::%stack-block ((,buf ,size))
|
|---|
| 1008 | ,@body)))
|
|---|
| 1009 |
|
|---|
| 1010 | (defconstant arg-check-trap-pc-limit 8)
|
|---|
| 1011 |
|
|---|
| 1012 | (provide "PPC64-ARCH")
|
|---|
