1 // tags.h Copyright (C) Codemist 1990-2021
2
3 //
4 // Data-structure and tag bit definitions, also common C macros
5 // for Lisp implementation.
6 //
7 //
8
9 /**************************************************************************
10 * Copyright (C) 2021, Codemist. A C Norman *
11 * *
12 * Redistribution and use in source and binary forms, with or without *
13 * modification, are permitted provided that the following conditions are *
14 * met: *
15 * *
16 * * Redistributions of source code must retain the relevant *
17 * copyright notice, this list of conditions and the following *
18 * disclaimer. *
19 * * Redistributions in binary form must reproduce the above *
20 * copyright notice, this list of conditions and the following *
21 * disclaimer in the documentation and/or other materials provided *
22 * with the distribution. *
23 * *
24 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
25 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
26 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
27 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
28 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
29 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
30 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
31 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
32 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
33 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
34 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
35 * DAMAGE. *
36 *************************************************************************/
37
38 // $Id: tags.h 5742 2021-03-18 22:45:13Z arthurcnorman $
39
40
41 #ifndef header_tags_h
42 #define header_tags_h 1
43
44 //
45 // General objects in Lisp are represented as pointer-sized integers
46 // and the type LispObject reflects this representation and
47 // not the elaborate tagged union that at some other level exists.
48 // If I could use "void *" for this type that might give me a bit more
49 // security since not much can be done with a "void *" object - in particular
50 // it can not participate in arithmetic. But when I do that I run into
51 // trouble in protected mode on a PC if I have items of type LispObject
52 // that are not valid pointers. I suspect that the same used to be
53 // the case on a Motorola 68000 with address and data registers.
54 //
55 //
56 // Sometimes the pointer-sized integer will be 64-bits wide, and will be the
57 // data type for the type LispObject. A result will be that anywhere in
58 // the code where I am sloppy about putting such an object into an int32_t
59 // I will have trouble, and anywhere that I use absolute numeric offsets
60 // instead of multiples of sizeof(LispObject) there can be pain.
61
62 typedef intptr_t LispObject;
63
64 // Perhaps the most important value here is nil!
65 extern LispObject nil;
66
67 #define SIXTY_FOUR_BIT (sizeof(intptr_t) == 8)
68
69 // I manage memory in CSL_PAGE_SIZE chunks.
70 //
71 // My default at present is to use PAGE_BITS=23, which leads to 8 Mbyte
72 // pages. I use that size on both 32 and 64-bit machines.
73
74 #ifndef PAGE_BITS
75 # define PAGE_BITS 23
76 #endif // PAGE_BITS
77
78 #define PAGE_POWER_OF_TWO (((size_t)1) << PAGE_BITS)
79 #define CSL_PAGE_SIZE (PAGE_POWER_OF_TWO)
80
81 //
82 // On 64-bit systems I will limit myself to 2 Terabytes, while on 32-bit
83 // ones the limit is around 2 Gbyte and in reality will usually be
84 // rather less than that. Note that this limit is expected to be a power
85 // of 2.
86 //
87 #ifndef MAX_HEAPSIZE
88 #define MAX_HEAPBITS (SIXTY_FOUR_BIT ? 41 : 31)
89 // The number here is measured in megabytes so it is always reasonably small.
90 #define MAX_HEAPSIZE (((size_t)1) << (MAX_HEAPBITS-20))
91 #endif // MAX_HEAPSIZE
92
93 #define MEGABYTE ((size_t)0x100000)
94
95 #ifndef INITIAL_HEAPSIZE
96 #define INITIAL_HEAPSIZE ((SIXTY_FOUR_BIT ? 768 : 128) * MEGABYTE)
97 #endif // MAX_HEAPSIZE
98
99 #if PAGE_BITS >= 20
100 #define MAX_PAGES (MAX_HEAPSIZE >> (PAGE_BITS-20))
101 #else
102 #define MAX_PAGES (MAX_HEAPSIZE << (20-PAGE_BITS))
103 #endif
104
105 // Windows seems to say it can use file names up to 260 chars, Unix and
106 // the like may not even have that limit, but I will assume something here.
107 // There must be a number of cases of potential buffer overflow throughout
108 // my code caused by this fixed limit. Note that the Windows limit there is
109 // just when using 8-bit characters in the path-name, and it is 256 plus
110 // space for "x:\" at the start to specify a drive and a "\0" at the end to
111 // terminate the string. However if you use the Unicode version of the
112 // Windows API you can have names with length up to 32K. Well it is messier
113 // even that that. Since about mid 2016 Windows 10 allows users to opt out
114 // of there being a path length restriction by setting a registry key and
115 // perhaps by also putting extra stuff an an "application manifest".
116 // I rather wonder how many people exploit that option!
117
118 #define LONGEST_LEGAL_FILENAME 1024
119
120 // This class is provided just so I can allocate things so as to be
121 // (at least) 8-byte aligned.
122
123 class alignas(8) Align8
124 {
125 public:
126 char data[8];
127 };
128
129 // The macro CELL had better have either the value 4 or 8. It is the
130 // size of the basic unit of memory within which CSL works.
131
132 #define CELL ((size_t)sizeof(LispObject))
133
134 // LispObject is a datatype where the low 3 bits are used as tags -
135 // this idea works provided all memory addresses needed can be kept
136 // doubleword aligned. The main tag allocation is documented here.
137
138 static const uintptr_t TAG_BITS = 0x7;
139 static const uintptr_t XTAG_BITS = 0xf;
140
141 // For almost all types I just use TAG_BITS and masking with that leaves
142 // an integer in the range 0-7. But the code 7 there is used both for small
143 // integers and for short floats and in that case the next bit up is used
144 // to discriminate, so there I may want to use XTAG_BITS which picks out
145 // the low 4 bits rather than just the low 3.
146
147 static const int TAG_CONS = 0; // Cons cells 01
148 static const int TAG_VECTOR = 1; // Regular Lisp vectors 02
149 static const int TAG_HDR_IMMED = 2; // Char constants, vechdrs etc 04
150 static const int TAG_FORWARD = 3; // For the Garbage Collector 08
151 static const int TAG_SYMBOL = 4; // Symbols 10
152 // Note that tags from 5 up are all
153 // for numeric date
154 static const int TAG_NUMBERS = 5; // Bignum, Rational, Complex 20
155 static const int TAG_BOXFLOAT = 6; // Boxed floats 40
156 static const int TAG_FIXNUM = 7; // 28/60-bit integers 80
157 static const int TAG_XBIT = 8; // extra bit!
158 static const int XTAG_SFLOAT = 15; // Short float, 28+ bits of immediate data 80
159
160 // On a 32-bit machine I can pack a 28-bit float (implemented as a 32-bit
161 // one with the low 4 bits crudely masked off) by putting XTAG_FLOAT as the
162 // bottom 4 bits. On a 64-bit system I have 64-bit immediate data so if I
163 // I have XTAG_FLOAT as the low 4 bits then bit 5 select as between
164 // a 28 or a 32-bit value and the high 28 or 32-bits can be that value.
165 // Thus on a 64-bit machine single floats as well as short floats have
166 // an immediate representation.
167 static const int XTAG_FLOAT32 = 16;
168
is_forward(LispObject p)169 inline bool is_forward(LispObject p)
170 { return (p & TAG_BITS) == TAG_FORWARD;
171 }
172
is_number(LispObject p)173 inline bool is_number(LispObject p)
174 { return (p & TAG_BITS) >= TAG_NUMBERS;
175 }
176
is_float(LispObject p)177 inline bool is_float(LispObject p)
178 { return ((0xc040 >> (p & XTAG_BITS)) & 1) != 0;
179 }
180
is_pointer_type(LispObject p)181 inline bool is_pointer_type(LispObject p)
182 { return ((0x73 >> (p & TAG_BITS)) & 1) != 0;
183 }
184
is_immed_or_cons(LispObject p)185 inline bool is_immed_or_cons(LispObject p)
186 { return ((0x85 >> (p & TAG_BITS)) & 1) != 0;
187 }
188
is_immediate(LispObject p)189 inline bool is_immediate(LispObject p)
190 { return ((0x84 >> (p & TAG_BITS)) & 1) != 0;
191 }
192
is_immed_cons_sym(LispObject p)193 inline bool is_immed_cons_sym(LispObject p)
194 { return ((0x95 >> (p & TAG_BITS)) & 1) != 0;
195 }
196
need_more_than_eq(LispObject p)197 inline bool need_more_than_eq(LispObject p)
198 { return ((0x63 >> (p & TAG_BITS)) & 1) != 0;
199 }
200
201 //
202 // For each of the above tag classes I have a bunch of low-level
203 // operations that need support - including type identification
204 // predicates and conversions to and from native C formats.
205 //
206
207 // fixnums now use the whole of an intptr_t, so they have 28 useful bits on
208 // a 32-bit machine and 60-bits on a 64-bit machine. By doing the left shift
209 // on an unsigned value I steer clear of C++ undefined behaviour, but then
210 // when I cast back to a signed value I am in "implementation defined"
211 // territory.
212
fixnum_of_int(intptr_t x)213 inline constexpr LispObject fixnum_of_int(intptr_t x)
214 { return static_cast<LispObject>(
215 (static_cast<uintptr_t>(x)<<4) + TAG_FIXNUM);
216 }
217
218 // There are places where I want to use this as a case-constant and then I
219 // may not use the inline procedure...
220 // Well maybe these days I could make it constexpr and that would do the
221 // trick?
222
223 #define FIXNUM_OF_INT(n) (16*(n)+TAG_FIXNUM)
224
225 // The code here manages to get compiled as a simple arithmetic right shift
226 // on enough architectures that I will not worry about writing it as a
227 // division. My intent here is (x>>4) with the shift being arithmetic in that
228 // it should replicate the top bit of the word as it shifts. Masking off
229 // low bits and then doing a signed division should achieve this affect in a
230 // portable manner.
231
int_of_fixnum(LispObject x)232 inline constexpr intptr_t int_of_fixnum(LispObject x)
233 { return (static_cast<intptr_t>(x) &
234 ~static_cast<intptr_t>(15)) / 16;
235 }
236
237 // The following test will see if an intptr_t value can be reduced to
238 // a Lisp fixnum without loss. I think that the logic is pretty clearly
239 // expressed here, but I want the code to run fast. Well I observe that
240 // using g++ on the computers that most matter to me this compiles
241 // rather as if it has been ((x<<4)>>4 == x), i.e. as two shifts followed
242 // by a comparison. This probably does well compared with some previous
243 // code I had that things like (x < 0x08000000 && x >= -0x08000000)
244 // which involves referring to two literal values and performing two
245 // comparisons. Of perhaps { t = (x & fix_mask); if (t==0 | t == fix_mask) ..}
246 // which is comparable. If you had a compiler that was less clever the
247 // resulting code here could be horrible!
248
249 // I need to overload these to cover various integer widths.
250
valid_as_fixnum(int32_t x)251 inline bool valid_as_fixnum(int32_t x)
252 { if (SIXTY_FOUR_BIT) return true;
253 else return int_of_fixnum(fixnum_of_int(x)) == x;
254 }
255
valid_as_fixnum(int64_t x)256 inline bool valid_as_fixnum(int64_t x)
257 { return int_of_fixnum(fixnum_of_int(x)) == x;
258 }
259
valid_as_fixnum(int128_t x)260 inline bool valid_as_fixnum(int128_t x)
261 { return int_of_fixnum(fixnum_of_int(static_cast<int64_t>(x))) == x;
262 }
263
264 // The following has given me some pain wrt the overloading where gcc and
265 // clang disagree about validity. Until I have read the C++ standard carefully
266 // enough I use this non-overloaded version in a few places. This issue is
267 // that intptr_t is liable to be either similar to int32_t or similar to
268 // int64_t. So if I try to provide overloads that accept all of int32_t,
269 // intptr_t and int64_t there is scope for confusion between the 3 versions.
270
intptr_valid_as_fixnum(intptr_t x)271 inline bool intptr_valid_as_fixnum(intptr_t x)
272 { return int_of_fixnum(fixnum_of_int(x)) == x;
273 }
274
valid_as_fixnum(uint32_t x)275 inline bool valid_as_fixnum(uint32_t x)
276 { if (SIXTY_FOUR_BIT) return true;
277 else return x < ((static_cast<uintptr_t>(1)) << 28);
278 }
279
valid_as_fixnum(uint64_t x)280 inline bool valid_as_fixnum(uint64_t x)
281 { return x < ((static_cast<uintptr_t>(1)) << (SIXTY_FOUR_BIT ? 60 :
282 28));
283 }
284
uint128_valid_as_fixnum(uint128_t x)285 inline bool uint128_valid_as_fixnum(uint128_t x)
286 { return x < ((static_cast<uintptr_t>(1)) << (SIXTY_FOUR_BIT ? 60 :
287 28));
288 }
289
290 #define MOST_POSITIVE_FIXVAL ((static_cast<intptr_t>(1) << (8*sizeof(LispObject)-5)) - 1)
291 #define MOST_NEGATIVE_FIXVAL (-(static_cast<intptr_t>(1) << (8*sizeof(LispObject)-5)))
292
293 #define MOST_POSITIVE_FIXNUM fixnum_of_int(MOST_POSITIVE_FIXVAL)
294 #define MOST_NEGATIVE_FIXNUM fixnum_of_int(MOST_NEGATIVE_FIXVAL)
295
is_cons(LispObject p)296 inline bool is_cons(LispObject p)
297 { return (((static_cast<int>(p)) & TAG_BITS) == TAG_CONS);
298 }
299
is_fixnum(LispObject p)300 inline bool is_fixnum(LispObject p)
301 { return (((static_cast<int>(p)) & XTAG_BITS) == TAG_FIXNUM);
302 }
303
is_immediate_num(LispObject p)304 inline bool is_immediate_num(LispObject p)
305 { return (((static_cast<int>(p)) & TAG_BITS) == TAG_FIXNUM);
306 }
307
is_odds(LispObject p)308 inline bool is_odds(LispObject p)
309 { return (((static_cast<int>(p)) & TAG_BITS) ==
310 TAG_HDR_IMMED); // many subcases
311 }
312
is_sfloat(LispObject p)313 inline bool is_sfloat(LispObject p)
314 { return (((static_cast<int>(p)) & XTAG_BITS) == XTAG_SFLOAT);
315 }
316
is_symbol(LispObject p)317 inline bool is_symbol(LispObject p)
318 { return (((static_cast<int>(p)) & TAG_BITS) == TAG_SYMBOL);
319 }
320
is_numbers(LispObject p)321 inline bool is_numbers(LispObject p)
322 { return (((static_cast<int>(p)) & TAG_BITS) == TAG_NUMBERS);
323 }
324
is_vector(LispObject p)325 inline bool is_vector(LispObject p)
326 { return (((static_cast<int>(p)) & TAG_BITS) == TAG_VECTOR);
327 }
328
is_bfloat(LispObject p)329 inline bool is_bfloat(LispObject p)
330 { return (((static_cast<int>(p)) & TAG_BITS) == TAG_BOXFLOAT);
331 }
332
consp(LispObject p)333 inline bool consp(LispObject p)
334 { return is_cons(p);
335 }
symbolp(LispObject p)336 inline bool symbolp(LispObject p)
337 { return is_symbol(p);
338 }
339
340 // For Common Lisp it would be necessary to detect and trap any attempt
341 // to take CAR or CDR of NIL and do something special.
342
car_legal(LispObject p)343 inline bool car_legal(LispObject p)
344 { return is_cons(p);
345 }
346
347 // I have many uses of atomic<T> here. The intent of these is to
348 // arrange that the heap is treated as made up of atomic data - certainly as
349 // far as all the LispObject and other sharable or mutable values in it are
350 // concerned.
351
352 // The C++ type atomic<T> has two aspects. The first is that even in
353 // an extreme case where the compiler/computer performs all memory references
354 // byte at a time both reads and writes will process whole values. This
355 // is strongly desirable in any multi-thread world, but apart from the
356 // special case of float128_t it will happen anyway on all reasonable
357 // computers.
358 // The second involves potential re-ordering of memory reads and writes
359 // either by software or by hardware. There are a range of options with
360 // "relaxed" essentially not applying any constraints. For lock-free multi-
361 // thread work the issues there really matter, but are "delicate". I am
362 // looking ahead to a multi-processing world, but trying to delay working
363 // out exactly what I need to do until later!
364 //
365 // What I do is I store LispObject values in the heap in the form
366 // atomic<LispObject> and provide pairs of accessor/mutator functions,
367 // eg CAR and SETCAR. These both have optional extra arguments that can
368 // specify a memory ordering requirement. I make the default setting
369 // std::memory_order_relaxed, which I believe does not apply any extra
370 // constraints, and so where that is used I will need mutexes or memory fences
371 // when multiple threads access the same value.
372
373 // Note that going beyond "relaxed" can sometimes have substantial cost
374 // implications (more so than I had been expecting!).
375
376 // I will protect the CAR and CDR field of every CONS cell this way,
377 // the header word of every symbol or vector-like object, and the
378 // value, env, pname, plist, fastgets and count fields with symbols.
379 // I do NOT protect the function-pointers within symbols.
380 // For vectors that contain pointers to other lisp objects I use
381 // atomic<T>, while for binary data (floating point numbers, character
382 // strings and so on) I do not.
383
384 // The reasoning here is that there will be times when multiple threads
385 // might all access the same list, vector or symbol and potentially update
386 // it. In particular I hope in due course to use several threads for
387 // garbage collection and that will involve some lock-free traversal
388 // of data. But binary data within Lisp objects will (generally) be read-
389 // only once it has been created, and so the worst issues of inter-thread
390 // synchronization will not arise.
391
392 // There are some uglinesses here. So for instance a comparison between
393 // a atomic<int> and an int (using ++ or !=) is liable to be reported
394 // as ambigious, and so in a dozen cases where that (or addition) happens
395 // I have put in explicit casts to unpack from the atomic value.
396
397 typedef struct Cons_Cell_
398 { atomic<LispObject> car;
399 atomic<LispObject> cdr;
400 } Cons_Cell;
401
402
403 extern bool valid_address(void *pointer);
404 [[noreturn]] extern void my_abort();
405 [[noreturn]] extern void my_abort(const char *msg);
406
407 // Going forward I may want to be able to control where I have memory
408 // fences and what sort get used, so these access functions have (optional)
409 // arguments relating to that. The default relaxed behaviour should be best
410 // for performance if not multi-thread consistency.
411
412 inline LispObject car(LispObject p,
413 std::memory_order mo=std::memory_order_relaxed)
414 { //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid car");
415 return (reinterpret_cast<Cons_Cell *>(p))->car.load(mo);
416 }
417
418 inline LispObject cdr(LispObject p,
419 std::memory_order mo=std::memory_order_relaxed)
420 { //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid cdr");
421 return (reinterpret_cast<Cons_Cell *>(p))->cdr.load(mo);
422 }
423
424 inline void setcar(LispObject p, LispObject q,
425 std::memory_order mo=std::memory_order_relaxed)
426 { //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid setcar");
427 (reinterpret_cast<Cons_Cell *>(p))->car.store(q, mo);
428 }
429
430 inline void setcdr(LispObject p, LispObject q,
431 std::memory_order mo=std::memory_order_relaxed)
432 { //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid setcdr");
433 (reinterpret_cast<Cons_Cell *>(p))->cdr.store(q, mo);
434 }
435
caraddr(LispObject p)436 inline atomic<LispObject> *caraddr(LispObject p)
437 { //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid caraddr");
438 return &((reinterpret_cast<Cons_Cell *>(p))->car);
439 }
440
cdraddr(LispObject p)441 inline atomic<LispObject> *cdraddr(LispObject p)
442 { //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid cdraddr");
443 return &((reinterpret_cast<Cons_Cell *>(p))->cdr);
444 }
445
446 // At present (boo hiss) the serialization code and the garbage collector
447 // both expect to run with no other thread active, and they are coded using
448 // simple non-atomic data. These two return addressed on the car and cdr
449 // fields in a cons cell expecting atomic and non-atomic layouts to match.
450
vcaraddr(LispObject p)451 inline LispObject *vcaraddr(LispObject p)
452 { //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid vcaraddr");
453 return reinterpret_cast<LispObject *>(
454 &(reinterpret_cast<Cons_Cell *>(p)->car));
455 }
456
vcdraddr(LispObject p)457 inline LispObject *vcdraddr(LispObject p)
458 { //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid "vcdraddr");
459 return reinterpret_cast<LispObject *>(
460 &(reinterpret_cast<Cons_Cell *>(p)->cdr));
461 }
462
463 typedef LispObject Special_Form(LispObject, LispObject);
464
465 // The original CSL uses entries for 1, 2 and n arguments, where the general
466 // case has an argument count and uses va_args.
467 // A newer scheme will have entries for 0, 1, 2, 3 and more than that. For
468 // 4 or more arguments a count is passed. For exactly four arguments the
469 // final argument is passed directly.
470 // (F 4 a1 a2 a3 a4)
471 // For the 5 up case arguments 4, 5, ...
472 // are passed as a list much as if the call had been
473 // (F n a1 a2 a3 (list a4 a5 a6 ... an))
474
475 typedef LispObject no_args(LispObject);
476 typedef LispObject one_arg(LispObject, LispObject);
477 typedef LispObject two_args(LispObject, LispObject, LispObject);
478 typedef LispObject three_args(LispObject, LispObject, LispObject,
479 LispObject);
480 typedef LispObject fourup_args(LispObject, LispObject, LispObject,
481 LispObject, LispObject);
482
483 // Headers are also LispObjects, but I give them a separate typedef
484 // name to help me keep their identity separate. There is only any
485 // chance of headers and other objects getting confused during
486 // garbage collection, and the code there has to be rather on the
487 // careful side. By making Headers unsigned I help the length
488 // calculation on them.
489
490 typedef uintptr_t Header;
491
492 // Objects will have a header word with the following format:
493 // xxxx:xxxx:xxxx:xxxx:xxxx:xx yy:yyy z:z 010
494 // 22-bits 5-bits 2 3
495 // The low 3 bits are always TAG_HDR_IMMED.
496 //
497 // I will use a shift by Tw to cope with the width of 010 with
498 // Tw=3 so that the offset to where yyyy/zz starts is kept just a little
499 // bit abstract.
500
501 #define Tw (3)
502
503 // The zz bits are
504 // 00 symbol header, character literal, special identifier (Spid)
505 // 01 vector containing Lisp pointers
506 // 10 bit-vectors
507 // 11 vector containing binary data
508 //
509 // The bits yyyyy are used to indicate which case within each above category
510 // applies. For class "00" only the two low bits are used, so there are then
511 // 25 bits of payload available.
512 // For the other cases the field xx(22)xx gives the number of (4-byte) words
513 // of data used in the object. Note that this count does not include the
514 // size of the header itself. Because this is in 32-bit words rather than bytes
515 // this allows the largest object to be 16 Mbytes if your word length is 32
516 // bits. That limit larger than the previous CSL tagging scheme permitted, but
517 // note that the size of objects is syill also limited by the csl "page" size,
518 // which is now 8 Mbytes.
519 //
520 // For vectors of bits, bytes and halfwords the high bits of yyyyy indicate the
521 // number of bits used in the final 32-bit word that is indicated by xxx.
522 // Consider the case for bytes (as used for strings). If there are n characters
523 // in a string then xxx must show ((n + 3) & ~3) [suitably shifted]. The two
524 // bits in yy will be ((n + 3) & 3) so that 0 indicates just one character in
525 // the final word and 3 denotes the final word being full.
526 // Now given w = xxxxxyy (the packed length) just subtracting 3 should
527 // recover the length n.
528
529 // It took me some while to get my head around the full consequences here!
530 // Because the length code is the length of active data (from 0 upwards)
531 // lengths can be from 0 to 0xffffff. A byte-vector can then have a length
532 // stored as up to 0xffffff:3 which stands for a length 0x3ffffc. This is a
533 // string that fills all the words of the vector. [these are described as for
534 // a 32-bit machine]. Note that if one includes the header word the total size
535 // of the object becomes 0x1000000.
536
537 // I have considered making the length code just the length of DATA not
538 // including the size of the header. In some respects that would be tidier,
539 // but at present I do not believe that the widespread code changes needed to
540 // move to it would be cost-effective and the risk introduced by a change
541 // that widestream could be large.
542
543 #define header_mask (0x7f<<Tw)
544
545 //
546 // Bit, byte and halfword-vectors need extra information held here so that
547 // their exact can be determined. Generally headers hold length information
548 // measured in words, so a few more bits are required here.
549 // Bitvectors will now supported even in Standard Lisp mode.
550 //
551
552 #define TYPE_BITVEC_1 ( 0x02 <<Tw) // subtypes encode length mod 32
553 #define TYPE_BITVEC_2 ( 0x06 <<Tw) // BITVEC_n has n bits in use in its...
554 #define TYPE_BITVEC_3 ( 0x0a <<Tw) // ... final 32-bit word.
555 #define TYPE_BITVEC_4 ( 0x0c <<Tw) //
556 #define TYPE_BITVEC_5 ( 0x12 <<Tw) //
557 #define TYPE_BITVEC_6 ( 0x16 <<Tw) //
558 #define TYPE_BITVEC_7 ( 0x1a <<Tw) //
559 #define TYPE_BITVEC_8 ( 0x1c <<Tw) //
560 #define TYPE_BITVEC_9 ( 0x22 <<Tw) //
561 #define TYPE_BITVEC_10 ( 0x26 <<Tw) //
562 #define TYPE_BITVEC_11 ( 0x2a <<Tw) //
563 #define TYPE_BITVEC_12 ( 0x2c <<Tw) //
564 #define TYPE_BITVEC_13 ( 0x32 <<Tw) //
565 #define TYPE_BITVEC_14 ( 0x36 <<Tw) //
566 #define TYPE_BITVEC_15 ( 0x3a <<Tw) //
567 #define TYPE_BITVEC_16 ( 0x3c <<Tw) //
568 #define TYPE_BITVEC_17 ( 0x42 <<Tw) //
569 #define TYPE_BITVEC_18 ( 0x46 <<Tw) //
570 #define TYPE_BITVEC_19 ( 0x4a <<Tw) //
571 #define TYPE_BITVEC_20 ( 0x4c <<Tw) //
572 #define TYPE_BITVEC_21 ( 0x52 <<Tw) //
573 #define TYPE_BITVEC_22 ( 0x56 <<Tw) //
574 #define TYPE_BITVEC_23 ( 0x5a <<Tw) //
575 #define TYPE_BITVEC_24 ( 0x5c <<Tw) //
576 #define TYPE_BITVEC_25 ( 0x62 <<Tw) //
577 #define TYPE_BITVEC_26 ( 0x66 <<Tw) //
578 #define TYPE_BITVEC_27 ( 0x6a <<Tw) //
579 #define TYPE_BITVEC_28 ( 0x6c <<Tw) //
580 #define TYPE_BITVEC_29 ( 0x72 <<Tw) //
581 #define TYPE_BITVEC_30 ( 0x76 <<Tw) //
582 #define TYPE_BITVEC_31 ( 0x7a <<Tw) //
583 #define TYPE_BITVEC_32 ( 0x7c <<Tw) //
584
585 // A string is not really a vector of characters since it is in utf-8 so
586 // access to the nth characters or updating characters within it is
587 // hard. You should use a vector of 32-bit codepoints if you want
588 // a genuine vector of characters, but then you will not have a string!
589
590 #define TYPE_STRING_1 ( 0x07 <<Tw) // simple (narrow) character vector
591 #define TYPE_STRING_2 ( 0x27 <<Tw) // Strings are in UTF8
592 #define TYPE_STRING_3 ( 0x47 <<Tw) //
593 #define TYPE_STRING_4 ( 0x67 <<Tw) //
594
595 #define TYPE_VEC8_1 ( 0x03 <<Tw) // vector of 8 bit values
596 #define TYPE_VEC8_2 ( 0x23 <<Tw) //
597 #define TYPE_VEC8_3 ( 0x43 <<Tw) //
598 #define TYPE_VEC8_4 ( 0x63 <<Tw) //
599
600 #define TYPE_BPS_1 ( 0x0b <<Tw) // Bytecodes
601 #define TYPE_BPS_2 ( 0x2b <<Tw) //
602 #define TYPE_BPS_3 ( 0x4b <<Tw) //
603 #define TYPE_BPS_4 ( 0x6b <<Tw) //
604
605 // #define TYPE_NATIVECODE ( 0x6f <<Tw) // (not implemented)
606
607 #define TYPE_VEC16_1 ( 0x0f <<Tw) // vector of 16 bit values
608 #define TYPE_VEC16_2 ( 0x4f <<Tw) //
609
610 #if 0
611 #define TYPE_MAPLEREF ( 0x2f <<Tw) // hook for interface to Maple ...
612 // ... note this was an EXPERIMENT
613 #endif
614
615 #define TYPE_FOREIGN ( 0x33 <<Tw) // entrypoint to foreign function
616 #define TYPE_SP ( 0x37 <<Tw) // Encapsulated stack ptr
617 #define TYPE_ENCAPSULATE ( 0x3b <<Tw) // Encapsulated address
618
619 #define TYPE_PADDER ( 0x7b <<Tw) // a padder vector
620
621
vector_holds_binary(Header h)622 inline bool vector_holds_binary(Header h)
623 { return ((h) & (0x2<<Tw)) != 0;
624 }
625
626 #define TYPE_SIMPLE_VEC ( 0x01 <<Tw) // simple general vector
627 #define TYPE_INDEXVEC ( 0x11 <<Tw) // used for huge vectors
628 #define TYPE_HASH ( 0x15 <<Tw) // new style hash table
629 #define TYPE_HASHX ( 0x19 <<Tw) // new hash table in need of re-hashing
630 //#define TYPE_OLDHASH ( 0x21 <<Tw) // old style hash table.
631 #define TYPE_ARRAY ( 0x05 <<Tw) // header record for general array
632 #define TYPE_STRUCTURE ( 0x09 <<Tw) // .. includes packages etc possibly
633 #define TYPE_OBJECT ( 0x0d <<Tw) // .. and "object"
634
635 #define TYPE_VEC32 ( 0x13 <<Tw) // contains 32-bit integers
636 #define TYPE_VEC64 ( 0x17 <<Tw) // contains 32-bit integers
637 #define TYPE_VEC128 ( 0x1b <<Tw) // contains 32-bit integers
638 #define TYPE_VECFLOAT32 ( 0x53 <<Tw) // contains single-precision floats
639 #define TYPE_VECFLOAT64 ( 0x57 <<Tw) // contains double-precision floats
640 #define TYPE_VECFLOAT128 ( 0x5b <<Tw) // contains long double floats
641
642 // The next items live amongst the vectors that hold Lisp pointers, but only
643 // the first three items are pointers - the rest of the stuff is binary
644 // data. This arrangements was required for streams, and the three other
645 // "mixed" cases are just in case anybody finds them useful.
646 #define is_mixed_header(h) (((h) & (0x73<<Tw)) == TYPE_MIXED1)
647
648 #define TYPE_MIXED1 ( 0x41 <<Tw) // general, but limited to 3 pointers
649 #define TYPE_MIXED2 ( 0x45 <<Tw) // general, but limited to 3 pointers
650 #define TYPE_MIXED3 ( 0x49 <<Tw) // only 3 pointers
651 #define TYPE_STREAM ( 0x4d <<Tw) // 3 pointers then binary data
652
653 #define VIRTUAL_TYPE_CONS ( 0x7d <<Tw) // what a header for a CONS would be!
654 #define VIRTUAL_TYPE_REF ( 0x17d <<Tw)// Used by sxhash.
655 #define VIRTUAL_TYPE_NIL ( 0x27d <<Tw)// Used in hashing.
656
657 #define HDR_IMMED_MASK (( 0xf <<Tw) | TAG_BITS)
658 #define TAG_CHAR (( 0x4 <<Tw) | TAG_HDR_IMMED) // 25 bits payload
659 #define TAG_SPID (( 0xc <<Tw) | TAG_HDR_IMMED) // Internal flag values
660
661 #define SPID_NIL (TAG_SPID+(0x00<<(Tw+4))) // NIL in checkpoint file
662 #define SPID_FBIND (TAG_SPID+(0x01<<(Tw+4))) // Fluid binding on stack
663 #define SPID_CATCH (TAG_SPID+(0x02<<(Tw+4))) // CATCH frame on stack
664 #define SPID_PROTECT (TAG_SPID+(0x03<<(Tw+4))) // UNWIND_PROTECT on stack
665 #define SPID_HASHEMPTY (TAG_SPID+(0x04<<(Tw+4))) // Empty hash slot
666 #define SPID_HASHTOMB (TAG_SPID+(0x05<<(Tw+4))) // Deleted hash item (tombstone)
667 #define SPID_GCMARK (TAG_SPID+(0x06<<(Tw+4))) // Used by GC as sentinel
668 #define SPID_NOINPUT (TAG_SPID+(0x07<<(Tw+4))) // Used by (read) in #X()
669 #define SPID_ERROR (TAG_SPID+(0x08<<(Tw+4))) // Used to indicate error
670 #define SPID_PVBIND (TAG_SPID+(0x09<<(Tw+4))) // PROGV binding on stack
671 #define SPID_NOARG (TAG_SPID+(0x0a<<(Tw+4))) // Missing &OPTIONAL arg
672 #define SPID_NOPROP (TAG_SPID+(0x0b<<(Tw+4))) // fastget entry is empty
673 #define SPID_LIBRARY (TAG_SPID+(0x0c<<(Tw+4))) // + 0xnnn00000 offset
674
675 inline Header vechdr(LispObject v,
676 std::memory_order mo=std::memory_order_relaxed)
677 { return (reinterpret_cast<atomic<Header> *>
678 (reinterpret_cast<char *>(v) - TAG_VECTOR))->load(mo);
679 }
680
681 inline void setvechdr(LispObject v, Header h,
682 std::memory_order mo=std::memory_order_relaxed)
683 { (reinterpret_cast<atomic<Header> *>(reinterpret_cast<char *>
684 (v) - TAG_VECTOR))->store(h, mo);
685 }
686
type_of_header(Header h)687 inline unsigned int type_of_header(Header h)
688 { return (static_cast<unsigned int>(h)) & header_mask;
689 }
690
691 // length_of_header returns the length of a word or doubleword oriented
692 // object in bytes. NOT in words.
693
length_of_header(Header h)694 inline size_t length_of_header(Header h)
695 { return ((static_cast<size_t>(h)) >> (Tw+7)) << 2;
696 }
697
698 // length_of_bitheader returns a length in bits.
length_of_bitheader(Header h)699 inline size_t length_of_bitheader(Header h)
700 { return ((static_cast<size_t>(h)) >> (Tw+2)) - 31;
701 }
702
703 // length_of_byteheader returns a length in bytes, and so compatible with what
704 // length_of_header used to do on byte arrays (and hence strings)
705
706
length_of_byteheader(Header h)707 inline size_t length_of_byteheader(Header h)
708 { return ((static_cast<size_t>(h)) >> (Tw+5)) - 3;
709 }
710
711 // length_of_hwordheader gives the number of halfwords used.
length_of_hwordheader(Header h)712 inline size_t length_of_hwordheader(Header h)
713 { return ((static_cast<size_t>(h)) >> (Tw+6)) - 1;
714 }
715
bitvechdr_(size_t n)716 inline Header bitvechdr_(size_t n)
717 { return TYPE_BITVEC_1 + (((n+31)&31)<<(Tw+2));
718 }
719
720 // Values for the type field in a header
721
722 //
723 // Symbols are so important that they have 25+ bits used to sub-classify them.
724 // These are used by the interpreter to identify special variables, special
725 // forms, and those symbols which are defined as macros. The bits live where
726 // other items would store a length, but since all symbol headers are the
727 // same size an explicit length field is not necessary - but missing one out
728 // means that I have to do a special check for the SYMBOL case whenever I
729 // scan the vector heap, which is a bit messy. Well when I say "25 bits" what
730 // I mean is that even on a 32-bit machine there are 25 bits available. On a
731 // 64-bit system there are an extra 32 (which at present I do not use).
732 //
733
734 #define TYPE_SYMBOL 0x00000000
735 #define SYM_SPECIAL_VAR 0x00000080 // (fluid '(xxx))
736 #define SYM_FLUID_VAR 0x00000080 // (fluid '(xxx))
737 #define SYM_GLOBAL_VAR 0x00000100 // (global '(xxx))
738 // I will set both SPECIAL and GLOBAL for "keywords" and those will be
739 // initialised to have themselves as their value and then neither be
740 // bindable or settable.
741 #define SYM_KEYWORD_VAR 0x00000180 // (keyword '(xxx))
742 #define SYM_SPECIAL_FORM 0x00000200 // eg. COND, QUOTE
743 #define SYM_MACRO 0x00000400 // (putd 'xxx 'macro ...)
744 #define SYM_C_DEF 0x00000800 // has definition from C kernel
745 #define SYM_CODEPTR 0x00001000 // just carries code pointer
746 #define SYM_ANY_GENSYM 0x00002000 // gensym, printed or not
747 #define SYM_TRACED 0x00004000 // function is traced.
748 #define SYM_TRACESET 0x00008000 // traceset support
749 #define SYM_TAGGED 0x00010000 // used for special versions
750 #define SYM_FASTGET_MASK 0x007e0000 // used to support "fast" gets
751 #define SYM_FASTGET_SHIFT 17
752 //
753 //
754 #ifdef COMMON
755 // In Common Lisp mode I use the rest of the header to help speed up
756 // test for the availability of a symbol in a package (while I am printing).
757 // Note that on a 32-bit machine I have just 8 bits for that. I think that
758 // will help with the first 8 packages I come across (or many more on a
759 // 64-bit machine). If I ever enable package support!
760 #define SYM_EXTERN_IN_HOME 0x00800000 // external in its home package
761 #define SYM_IN_PACKAGE 0xff000000U // availability in 8 packages
762 #define SYM_IN_PKG_SHIFT 24
763 #define SYM_IN_PKG_COUNT 8
764 #else // COMMON
765 // In Standard Lisp mode I only allocate a print-name to a gensym when I
766 // first print it, so I have a bit that tells me when a gensym is still
767 // not printed.
768 #define SYM_UNPRINTED_GENSYM 0x00800000 // not-yet-printed gensym
769 // Here in Standard Lisp mode I have 8 bits left in a symbol header even
770 // on a 32-bit system.
771 #endif // COMMON
772
773 #define symhdr_length (doubleword_align_up(sizeof(Symbol_Head)))
774
is_symbol_header(Header h)775 inline bool is_symbol_header(Header h)
776 { return (static_cast<int>(h) & (0xf<<Tw)) == TYPE_SYMBOL;
777 }
778
is_symbol_header_full_test(Header h)779 inline bool is_symbol_header_full_test(Header h)
780 { return (static_cast<int>(h) & ((0xf<<Tw) + TAG_BITS)) ==
781 (TYPE_SYMBOL + TAG_HDR_IMMED);
782 }
783
header_fastget(Header h)784 inline int header_fastget(Header h)
785 { return (h >> SYM_FASTGET_SHIFT) & 0x3f;
786 }
787
is_number_header_full_test(Header h)788 inline bool is_number_header_full_test(Header h)
789 { return (static_cast<int>(h) & ((0x1d<<Tw) + TAG_BITS)) == ((
790 0x1d<<Tw) + TAG_HDR_IMMED);
791 }
792
793 // The "vector" case here includes vector-like number cases
is_vector_header_full_test(Header h)794 inline bool is_vector_header_full_test(Header h)
795 { return is_odds(h) && ((static_cast<int>(h) & (0x3<<Tw)) != 0);
796 }
797
is_array_header(Header h)798 inline bool is_array_header(Header h)
799 { return type_of_header(h) == TYPE_ARRAY;
800 }
801
802 // The codes for yyyyy are as follows:
803
804 // xx:x00 0:0 010 symbol header
805 // xx:x01 0:0 010 character
806 // xx:x10 0:0 010 handle for bytecode. Why do I do it this way?
807 // xx:x11 0:0 010 special marker identifier (Spid) for internal use
808 //
809 // 00:000 0:1 010 simple vector
810 // 00:001 0:1 010 array
811 // 00:010 0:1 010 structure
812 // 00:011 0:1 010 object
813 // 00:100 0:1 010 indexvec (used to implement huge vectors)
814 // 00:101 0:1 010 new style hash table
815 // 00:110 0:1 010 new hash table with rehash pending
816 // 00:111 0:1 010 index vector for huge bignum *
817 // 01:000 0:1 010 old style hash table
818 // 01:0xx 0:1 010 (spare: 4 codes)
819 // 01:111 0:1 010 rational number *
820 // 10:0xx 0:1 010 stream and mixed1, 2 and 3
821 // 10:111 0:1 010 complex number *
822 // 11:111 0:1 010 (spare, but classifies as a number)
823 // 1x:xxx 0:1 010 (spare: 14 codes)
824 // 11:111 0:1 010 used when calculating hash codes as if it was the
825 // header for a CONS cell.
826
827 // yyy:yy 10 010 bit-vector with yyyyy (1 to 32) bits in final word.
828
829 // The final column here explains what size units of storage fit within
830 // the object. For (eg) "encapsulated general pointer" I have made it
831 // 64 and I should pad 32-bit cases to that width - but I do not expect
832 // those sorts of data to survive serialization, so I annotate them here
833 // as "64?".
834
835 // 00:000 1:1 010 vec8-1 8
836 // 00:001 1:1 010 string-1 8
837 // 00:010 1:1 010 bytecode-1 8
838 // 00:011 1:1 010 vec16-1 16
839 // 00:100 1:1 010 vec32 32
840 // 00:101 1:1 010 vec64 64
841 // 00:110 1:1 010 vec128 128
842 // 00:111 1:1 010 bignum * 32
843 // 01:000 1:1 010 vec8-2 8
844 // 01:001 1:1 010 string-2 8
845 // 01:010 1:1 010 bytecode-2 8
846 // 01:011 1:1 010 maple-ref 64?
847 // 01:100 1:1 010 foreign 64?
848 // 01:101 1:1 010 encapsulated-sp 64?
849 // 01:110 1:1 010 encapsulated general pointer 64?
850 // 01:111 1:1 010 float32 * F32
851 // 10:000 1:1 010 vec8-2 8
852 // 10:001 1:1 010 string-3 8
853 // 10:010 1:1 010 bytecode-3 8
854 // 10:011 1:1 010 vec16-2 16
855 // 10:100 1:1 010 vecflt32 F32
856 // 10:101 1:1 010 vecflt64 F64
857 // 10:110 1:1 010 vecflt128 F128
858 // 10:111 1:1 010 float64 * F64
859 // 11:000 1:1 010 vec8-3 8
860 // 11:001 1:1 010 string-4 8
861 // 11:010 1:1 010 bytecode-4 8
862 // [[11:011 1:1 010 nativecode 8]] NOT USED
863 // 11:100 1:1 010 (spare: 1 code) X
864 // 11:101 1:1 010 (spare: 1 code) X
865 // 11:110 1:1 010 padder vector X
866 // 11:111 1:1 010 float128 * F128
867
868 // I have tests that let me discern the size of storage units within a
869 // vector. This matters for serialization and deserialization because the
870 // source and target machines may use different ordering for bytes within
871 // words etc.
872
873 // I use a bitmap scheme for all of these because that gives me uniformity
874 // and because I do not believe that special treatment of any of the
875 // case would do much better. I expect that strings and bignums will be
876 // the most common cases.
877
is_basic_vector(LispObject v)878 inline bool is_basic_vector(LispObject v)
879 { return is_vector(v) && type_of_header(vechdr(v)) != TYPE_INDEXVEC;
880 }
881
vector_i8(Header h)882 inline bool vector_i8(Header h)
883 { return ((0x7f070707u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
884 }
885
vector_i16(Header h)886 inline bool vector_i16(Header h)
887 { return ((0x00080008u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
888 }
889
vector_i32(Header h)890 inline bool vector_i32(Header h)
891 { return ((0x00000090u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
892 }
893
vector_i64(Header h)894 inline bool vector_i64(Header h)
895 { return ((0x00007820u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
896 }
897
vector_i128(Header h)898 inline bool vector_i128(Header h)
899 { return ((0x00000040u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
900 }
901
vector_f32(Header h)902 inline bool vector_f32(Header h)
903 { return ((0x00108000u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
904 }
905
vector_f64(Header h)906 inline bool vector_f64(Header h)
907 { return ((0x00a00000u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
908 }
909
vector_f128(Header h)910 inline bool vector_f128(Header h)
911 { return ((0x80400000u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
912 }
913
basic_elt(LispObject v,size_t n)914 inline atomic<LispObject>& basic_elt(LispObject v, size_t n)
915 { return *reinterpret_cast<atomic<LispObject> *>
916 (reinterpret_cast<char *>(v) +
917 (CELL-TAG_VECTOR) +
918 (n*sizeof(LispObject)));
919 }
920
vector_i8(LispObject n)921 inline bool vector_i8(LispObject n)
922 { if (!is_vector(n)) return false;
923 else if (is_basic_vector(n)) return vector_i8(vechdr(n));
924 else return vector_i8(vechdr(basic_elt(n, 0)));
925 }
926
vector_i16(LispObject n)927 inline bool vector_i16(LispObject n)
928 { if (!is_vector(n)) return false;
929 else if (is_basic_vector(n)) return vector_i16(vechdr(n));
930 else return vector_i16(vechdr(basic_elt(n, 0)));
931 }
932
vector_i32(LispObject n)933 inline bool vector_i32(LispObject n)
934 { if (!is_vector(n)) return false;
935 else if (is_basic_vector(n)) return vector_i32(vechdr(n));
936 else return vector_i32(vechdr(basic_elt(n, 0)));
937 }
938
vector_i64(LispObject n)939 inline bool vector_i64(LispObject n)
940 { if (!is_vector(n)) return false;
941 else if (is_basic_vector(n)) return vector_i64(vechdr(n));
942 else return vector_i64(vechdr(basic_elt(n, 0)));
943 }
944
vector_i128(LispObject n)945 inline bool vector_i128(LispObject n)
946 { if (!is_vector(n)) return false;
947 else if (is_basic_vector(n)) return vector_i128(vechdr(n));
948 else return vector_i128(vechdr(basic_elt(n, 0)));
949 }
950
vector_f32(LispObject n)951 inline bool vector_f32(LispObject n)
952 { if (!is_vector(n)) return false;
953 else if (is_basic_vector(n)) return vector_f32(vechdr(n));
954 else return vector_f32(vechdr(basic_elt(n, 0)));
955 }
956
vector_f64(LispObject n)957 inline bool vector_f64(LispObject n)
958 { if (!is_vector(n)) return false;
959 else if (is_basic_vector(n)) return vector_f64(vechdr(n));
960 else return vector_f64(vechdr(basic_elt(n, 0)));
961 }
962
vector_f128(LispObject n)963 inline bool vector_f128(LispObject n)
964 { if (!is_vector(n)) return false;
965 else if (is_basic_vector(n)) return vector_f128(vechdr(n));
966 else return vector_f128(vechdr(basic_elt(n, 0)));
967 }
968
969 // I have made the allocation so that any header of the form xx1:11x1:010
970 // is the header of a number. And the ...:..x.:... bit indicates whether
971 // the number is stored as binary or Lisp data. Thus rational and complex
972 // numbers are (pairs of) Lisp objects, while bignums and boxed floats have
973 // binary data. The case BIGNUMINDEX is for bignums that need more than
974 // 4 Mbytes of memory and is an index vector containing a number of lower-
975 // level vectors of binary information. That case is not supported yet, and
976 // there is a real prospect that I will rearrange storage layout strategies
977 // so it never is!
978
979 #define TYPE_BIGNUMINDEX ( 0x1d <<Tw)
980 #define TYPE_BIGNUM ( 0x1f <<Tw)
981 #define TYPE_RATNUM ( 0x3d <<Tw)
982 #define TYPE_SINGLE_FLOAT ( 0x3f <<Tw)
983 #define TYPE_COMPLEX_NUM ( 0x5d <<Tw)
984 #define TYPE_DOUBLE_FLOAT ( 0x5f <<Tw)
985 // unused ( 0x7d <<Tw)
986 // While gradually working on a new implementation of big-numbers I will
987 // have a "TYPE_NEW_BIGNUM" for big integers represented using 64-bit
988 // digits. These well not be fully integrated with everything else!
989 #define TYPE_NEW_BIGNUM ( 0x7d <<Tw) // Temporary provision!
990 #define TYPE_LONG_FLOAT ( 0x7f <<Tw)
991
992 inline Header numhdr(LispObject v,
993 std::memory_order mo = std::memory_order_relaxed)
994 { return (reinterpret_cast<atomic<Header> *>
995 (reinterpret_cast<char *>(v) - TAG_NUMBERS))->load(mo);
996 }
997
998 inline Header flthdr(LispObject v,
999 std::memory_order mo = std::memory_order_relaxed)
1000 { return (reinterpret_cast<atomic<Header> *>
1001 (reinterpret_cast<char *>(v) - TAG_BOXFLOAT))->load(mo);
1002 }
1003
1004 inline void setnumhdr(LispObject v, Header h,
1005 std::memory_order mo = std::memory_order_relaxed)
1006 { (reinterpret_cast<atomic<Header> *>(reinterpret_cast<char *>
1007 (v) - TAG_NUMBERS))->store(h, mo);
1008 }
1009
1010 inline void setflthdr(LispObject v, Header h,
1011 std::memory_order mo = std::memory_order_relaxed)
1012 { (reinterpret_cast<atomic<Header> *>(reinterpret_cast<char *>
1013 (v) - TAG_BOXFLOAT))->store(h, mo);
1014 }
1015
is_short_float(LispObject v)1016 inline bool is_short_float(LispObject v)
1017 { if (!is_sfloat(v)) return false;
1018 if (SIXTY_FOUR_BIT && (v & XTAG_FLOAT32) != 0) return false;
1019 return true;
1020 }
1021
is_single_float(LispObject v)1022 inline bool is_single_float(LispObject v)
1023 { if (SIXTY_FOUR_BIT && is_sfloat(v) &&
1024 (v & XTAG_FLOAT32) != 0) return true;
1025 return is_bfloat(v) && type_of_header(flthdr(v)) == TYPE_SINGLE_FLOAT;
1026 }
1027
is_double_float(LispObject v)1028 inline bool is_double_float(LispObject v)
1029 { return is_bfloat(v) &&
1030 type_of_header(flthdr(v)) == TYPE_DOUBLE_FLOAT;
1031 }
1032
is_long_float(LispObject v)1033 inline bool is_long_float(LispObject v)
1034 { return is_bfloat(v) &&
1035 type_of_header(flthdr(v)) == TYPE_LONG_FLOAT;
1036 }
1037
is_ratio(LispObject n)1038 inline bool is_ratio(LispObject n)
1039 { return is_numbers(n) && type_of_header(numhdr(n)) == TYPE_RATNUM;
1040 }
1041
is_complex(LispObject n)1042 inline bool is_complex(LispObject n)
1043 { return is_numbers(n) && type_of_header(numhdr(n)) == TYPE_COMPLEX_NUM;
1044 }
1045
is_bignum_header(Header h)1046 inline bool is_bignum_header(Header h)
1047 { return type_of_header(h) == TYPE_BIGNUM;
1048 }
1049
is_bignum(LispObject n)1050 inline bool is_bignum(LispObject n)
1051 { return is_numbers(n) && is_bignum_header(numhdr(n));
1052 }
1053
is_new_bignum_header(Header h)1054 inline bool is_new_bignum_header(Header h)
1055 { return type_of_header(h) == TYPE_NEW_BIGNUM;
1056 }
1057
is_new_bignum(LispObject n)1058 inline bool is_new_bignum(LispObject n)
1059 { return is_numbers(n) && is_new_bignum_header(numhdr(n));
1060 }
1061
is_string_header(Header h)1062 inline bool is_string_header(Header h)
1063 { return (type_of_header(h) & (0x1f<<Tw)) == TYPE_STRING_1;
1064 }
1065
is_string(LispObject n)1066 inline bool is_string(LispObject n)
1067 { if (!is_vector(n)) return false;
1068 else if (is_basic_vector(n)) return is_string_header(vechdr(n));
1069 else return is_string_header(vechdr(basic_elt(n, 0)));
1070 }
1071
is_vec8_header(Header h)1072 inline bool is_vec8_header(Header h)
1073 { return (type_of_header(h) & (0x1f<<Tw)) == TYPE_VEC8_1;
1074 }
1075
is_vec8(LispObject n)1076 inline bool is_vec8(LispObject n)
1077 { if (!is_vector(n)) return false;
1078 else if (is_basic_vector(n)) return is_vec8_header(vechdr(n));
1079 else return is_vec8_header(vechdr(basic_elt(n, 0)));
1080 }
1081
is_bps_header(Header h)1082 inline bool is_bps_header(Header h)
1083 { return (type_of_header(h) & (0x1f<<Tw)) == TYPE_BPS_1;
1084 }
1085
is_bps(LispObject n)1086 inline bool is_bps(LispObject n)
1087 { return is_vector(n) && is_bps_header(vechdr(n));
1088 }
1089
is_vec16_header(Header h)1090 inline bool is_vec16_header(Header h)
1091 { return (type_of_header(h) & (0x3f<<Tw)) == TYPE_VEC16_1;
1092 }
1093
is_vec16(LispObject n)1094 inline bool is_vec16(LispObject n)
1095 { if (!is_vector(n)) return false;
1096 else if (is_basic_vector(n)) return is_vec16_header(vechdr(n));
1097 else return is_vec16_header(vechdr(basic_elt(n, 0)));
1098 }
1099
is_bitvec_header(Header h)1100 inline bool is_bitvec_header(Header h)
1101 { return (type_of_header(h) & (0x03<<Tw)) == TYPE_BITVEC_1;
1102 }
1103
is_bitvec(LispObject n)1104 inline bool is_bitvec(LispObject n)
1105 { if (!is_vector(n)) return false;
1106 else if (is_basic_vector(n)) return is_bitvec_header(vechdr(n));
1107 else return is_bitvec_header(vechdr(basic_elt(n, 0)));
1108 }
1109
basic_celt(LispObject v,size_t n)1110 inline char& basic_celt(LispObject v, size_t n)
1111 { return *(reinterpret_cast<char *>(v) + (CELL-TAG_VECTOR) + n);
1112 }
1113
basic_ucelt(LispObject v,size_t n)1114 inline unsigned char& basic_ucelt(LispObject v, size_t n)
1115 { return *(reinterpret_cast<unsigned char *>(v) +
1116 (CELL-TAG_VECTOR) + n);
1117 }
1118
basic_scelt(LispObject v,size_t n)1119 inline signed char& basic_scelt(LispObject v, size_t n)
1120 { return *(reinterpret_cast<signed char *>(v) +
1121 (CELL-TAG_VECTOR) + n);
1122 }
1123
1124 #define BPS_DATA_OFFSET (CELL-TAG_VECTOR)
1125
data_of_bps(LispObject v)1126 inline unsigned char* data_of_bps(LispObject v)
1127 { return reinterpret_cast<unsigned char *>(v) + BPS_DATA_OFFSET;
1128 }
1129
1130
1131 // In the serialization code I want to access the fields in a symbol as
1132 // if that symbol was a vector and the fields were indexed as follows:
1133 // vselt(p, -1) : qheader(p)
1134 // vselt(p, 1) : qenv(p)
1135 // vselt(p, 2) : qplist(p)
1136 // vselt(p, 3) : qfastgets(p)
1137 // vselt(p, 4) : qpackage(p)
1138 // vselt(p, 5) : qpname(p)
1139 // and I want vselt to apply to vectors too and do just what elt does in
1140 // that case. I will also use vselt on things tagged as numbers (specifically
1141 // RATIO and COMPLEX. But note that the serialization code is handling
1142 // structures in terms of their raw representation and so any issues of
1143 // large vs basic vectors does not apply.
1144
vselt(LispObject v,size_t n)1145 inline LispObject& vselt(LispObject v, size_t n)
1146 { return *reinterpret_cast<LispObject *>(
1147 (static_cast<intptr_t>(v) &
1148 ~(static_cast<intptr_t>(TAG_BITS))) +
1149 ((1 + n)*sizeof(LispObject)));
1150 }
1151
1152 //
1153 // The next are for 16-bit & 32 bit values and single-float & double-float
1154 // access. Note that halfwords are signed.
1155 //
1156 //
1157 // In days of ancient history some systems did not support 16-bit values.
1158 // Specifically the DEC Alpha compilers did not have a 16-bit data type and
1159 // ARM did not support 16-bit usage at all well. However these days I intend
1160 // to expect that int16_t will exist and will be something I can rely on.
1161 //
basic_helt(LispObject v,size_t n)1162 inline int16_t& basic_helt(LispObject v, size_t n)
1163 { return *reinterpret_cast<int16_t *>(reinterpret_cast<char *>
1164 (v) +
1165 (CELL-TAG_VECTOR) +
1166 n*sizeof(int16_t));
1167 }
1168
basic_ielt(LispObject v,size_t n)1169 inline intptr_t& basic_ielt(LispObject v, size_t n)
1170 { return *reinterpret_cast<intptr_t *>(reinterpret_cast<char *>
1171 (v) +
1172 (CELL-TAG_VECTOR) +
1173 n*sizeof(intptr_t));
1174 }
1175
1176 //
1177 // Even on a 64-bit machine I will support packed arrays of 32-bit
1178 // ints or short-floats.
1179 //
basic_ielt32(LispObject v,size_t n)1180 inline int32_t& basic_ielt32(LispObject v, size_t n)
1181 { return *reinterpret_cast<int32_t *>(reinterpret_cast<char *>(v) +
1182 (CELL-TAG_VECTOR) +
1183 n*sizeof(int32_t));
1184 }
1185
basic_felt(LispObject v,size_t n)1186 inline float& basic_felt(LispObject v, size_t n)
1187 { return *reinterpret_cast<float *>(reinterpret_cast<char *>(v) +
1188 (CELL-TAG_VECTOR) +
1189 n*sizeof(float));
1190 }
1191
basic_delt(LispObject v,size_t n)1192 inline double& basic_delt(LispObject v, size_t n)
1193 { return *reinterpret_cast<double *>(reinterpret_cast<char *>(v) +
1194 (8-TAG_VECTOR) +
1195 n*sizeof(double));
1196 }
1197
1198 // The above provide support for "basic" vectors, which have a limitation
1199 // that they can only be up to around 4 Mbytes in size - which on a 64-bit
1200 // system means that a normal Lisp vector can only have up to around half
1201 // a million elements. Using a two-level structure with TYPE_INDEXVEC for
1202 // the upper one allows vectors to get MUCH MUCH bigger.
1203
1204 #define LOG2_VECTOR_CHUNK_BYTES (PAGE_BITS-2)
1205 #define VECTOR_CHUNK_BYTES ((size_t)(((size_t)1)<<LOG2_VECTOR_CHUNK_BYTES))
1206
1207 // With the above large vectors are represented in chunks each of which is
1208 // 1 Megabyte in size. That is smaller than the storage allocation chunk size
1209 // so that I do not lose TOO much space to fragmentation there. Well I
1210 // may lose 25%. Like this the largest 2-level structure on a 64-bit
1211 // machine will have around 0.5 million sub-vectors, each of size a megabyte.
1212 // that is 2^39 bytes, and so if this is used to store LispObjects there can
1213 // be up to 2^36 of them. That is 64G cells, consuming 512GBytes of memory.
1214 // At present (2019) that seems an acceptable limit. If at some stage (!) it
1215 // became essential to go yet further the natural thing would be to increase
1216 // the basic memory allocation block size from 4 Mbytes upwards, and each
1217 // doubling of that could allow me to increase the largest vector size by
1218 // a factor of 4. Note that the above limit is on the size of a single
1219 // individual vector, and so mmy current limit is really unlikely to become
1220 // and issue until people are using computers with several terabytes of
1221 // main memory.
1222
is_power_of_two(uint64_t n)1223 inline bool is_power_of_two(uint64_t n)
1224 { return (n == (n & (-n)));
1225 }
1226
intlog2(uint64_t n)1227 inline int intlog2(uint64_t n)
1228 {
1229 // This fragment takes a 64-bit number that is a power of 2 and
1230 // finds its logarithm, ie the number of bits that 1 needs to be shifted
1231 // left to yield it. The function will return garbage if its input is
1232 // not a power of 2.
1233 //
1234 // This table works because it is of length 67 and that is a prime, so
1235 // the sequence 2^i mod 67 cycles through 1 .. 66 as I runs from 0 to 65,
1236 // and 2^66 = 2^0 (mod 67). To help show this I have annotated the items at
1237 // offsets 1, 2, 4, 8, 16, 32 and 64.
1238 static const unsigned char intlog2_table[] =
1239 { 0, 0,/*1*/ 1,/*2*/ 39, 2,/*4*/ 15, 40, 23,
1240 3,/*8*/ 12, 16, 59, 41, 19, 24, 54,
1241 4,/*16*/0, 13, 10, 17, 62, 60, 28,
1242 42, 30, 20, 51, 25, 44, 55, 47,
1243 5,/*32*/32, 0, 38, 14, 22, 11, 58,
1244 18, 53, 63, 9, 61, 27, 29, 50,
1245 43, 46, 31, 37, 21, 57, 52, 8,
1246 26, 49, 45, 36, 56, 7, 48, 35,
1247 6,/*64*/34, 33
1248 };
1249 return intlog2_table[n % (sizeof(intlog2_table)/sizeof(
1250 intlog2_table[0]))];
1251 }
1252
1253 // In the past when something is tagged TAG_VECTOR I have used
1254 // type_of_header(vechdr(v)) to detect its type. In the future
1255 // I should in general use type_of_vector(cv) because that can cope
1256 // with "large" as well as basic vector. Doing so somewhat relies on
1257 // a "sufficiently clever compiler" inlining the functions and then
1258 // observing that vechdr(v) is a value common to several of the paths,
1259 // and even that type_of_header(vechdr(v)) is something where repeated
1260 // evaluation can be avoided.
1261
type_of_vector(LispObject v)1262 inline int type_of_vector(LispObject v)
1263 { if (is_basic_vector(v)) return type_of_header(vechdr(v));
1264 else return type_of_header(vechdr(basic_elt(v, 0)));
1265 }
1266
1267 // In the past I have tended to use length_of_header() to get the size
1268 // of vectors. I now intend to move towards use of this function -
1269 // bytes_in_vector will find the size in bytes of active data excluding
1270 // and header words, and cells_in_vector() will get the number of
1271 // LispObjects that can be stored.
1272
bytes_in_bytevector(LispObject v)1273 inline size_t bytes_in_bytevector(LispObject v)
1274 { if (is_basic_vector(v)) return length_of_byteheader(vechdr(v)) - CELL;
1275 size_t n = (length_of_header(vechdr(v))-CELL)/CELL;
1276 // Observe that the final chunk has its length treated individually. This
1277 // adds to the cost, but the extra cost only arises when the vector is
1278 // rather large to start with, and so I am not going to worry.
1279 return VECTOR_CHUNK_BYTES*(n-1) +
1280 length_of_byteheader(vechdr(basic_elt(v, n-1))) - CELL;
1281 }
1282
hwords_in_hwordvector(LispObject v)1283 inline size_t hwords_in_hwordvector(LispObject v)
1284 { if (is_basic_vector(v)) return length_of_hwordheader(vechdr(v)) - (CELL/2);
1285 size_t n = (length_of_header(vechdr(v))-CELL)/CELL;
1286 // Observe that the final chunk has its length treated individually. This
1287 // adds to the cost, but the extra cost only arises when the vector is
1288 // rather large to start with, and so I am not going to worry.
1289 return (VECTOR_CHUNK_BYTES/2)*(n-1) +
1290 length_of_hwordheader(vechdr(basic_elt(v, n-1))) - (CELL/2);
1291 }
1292
bits_in_bitvector(LispObject v)1293 inline size_t bits_in_bitvector(LispObject v)
1294 { if (is_basic_vector(v)) return length_of_bitheader(vechdr(v)) - 8*CELL;
1295 size_t n = (length_of_header(vechdr(v))-CELL)/CELL;
1296 // Observe that the final chunk has its length treated individually. This
1297 // adds to the cost, but the extra cost only arises when the vector is
1298 // rather large to start with, and so I am not going to worry.
1299 return (8*VECTOR_CHUNK_BYTES)*(n-1) +
1300 length_of_bitheader(vechdr(basic_elt(v, n-1))) - 8*CELL;
1301 }
1302
1303 // This is the general one, and it is applicable to any sort of
1304 // vector with elements of size at least 4 bytes.
1305
bytes_in_vector(LispObject v)1306 inline size_t bytes_in_vector(LispObject v)
1307 { if (is_basic_vector(v)) return length_of_header(vechdr(v)) - CELL;
1308 size_t n = (length_of_header(vechdr(v))-CELL)/CELL;
1309 // Observe that the final chunk has its length treated individually. This
1310 // adds to the cost, but the extra cost only arises when the vector is
1311 // rather large to start with, and so I am not going to worry.
1312 return VECTOR_CHUNK_BYTES*(n-1) +
1313 length_of_header(vechdr(basic_elt(v, n-1))) - CELL;
1314 }
1315
cells_in_vector(LispObject v)1316 inline size_t cells_in_vector(LispObject v)
1317 { return bytes_in_vector(v)/CELL;
1318 }
1319
vector_holds_binary(LispObject v)1320 inline bool vector_holds_binary(LispObject v)
1321 { if (is_basic_vector(v)) return vector_holds_binary(vechdr(v));
1322 else return vector_holds_binary(vechdr(basic_elt(v, 0)));
1323 }
1324
1325 // the table of free vectors is not saved across checkpoint/restore operations,
1326 // and so issues of 64- vs 32-bit sizing in that context do not arise.
1327
1328 extern LispObject free_vectors[LOG2_VECTOR_CHUNK_BYTES+1];
1329
discard_basic_vector(LispObject v)1330 inline void discard_basic_vector(LispObject v)
1331 { size_t size = length_of_header(vechdr(v));
1332 // I should never try to discard a vector that has a size that is not
1333 // a multiple of CELL. If I did then the division on the next line could
1334 // truncate to potential bad effect.
1335 size_t n = size/CELL - 1;
1336 if (is_power_of_two(n)) // save if this has byte-count 2^i
1337 { int i = intlog2(n); // identify what power of 2 we have
1338 if (i <= LOG2_VECTOR_CHUNK_BYTES)
1339 { basic_elt(v, 0) = free_vectors[i];
1340 // I put the discarded vector in the free-chain as a "simple vector"
1341 // regardless of what it used to be. If it has contained binary information
1342 // its contents will not be GC safe - but the GC should never encounter it
1343 // so that should not matter.
1344 setvechdr(v,TYPE_SIMPLE_VEC +
1345 (size << (Tw+5)) +
1346 TAG_HDR_IMMED);
1347 v = (v & ~reinterpret_cast<uintptr_t>(TAG_BITS)) | TAG_VECTOR;
1348 free_vectors[i] = v;
1349 }
1350 }
1351 }
1352
discard_vector(LispObject v)1353 inline void discard_vector(LispObject v)
1354 { if (is_basic_vector(v)) discard_basic_vector(v);
1355 else
1356 { size_t n1 = length_of_header(vechdr(v))/CELL - 1;
1357 for (size_t i=0; i<n1; i++)
1358 discard_basic_vector(basic_elt(v, i));
1359 discard_basic_vector(v);
1360 }
1361 }
1362
1363 // elt() and friends will now work on large or basic vectors.
1364 // I should probably consider using a template to generate the code
1365 // here.
1366
elt(LispObject v,size_t n)1367 inline atomic<LispObject>& elt(LispObject v, size_t n)
1368 { if (is_basic_vector(v)) return basic_elt(v, n);
1369 return basic_elt(basic_elt(v, n/(VECTOR_CHUNK_BYTES/CELL)),
1370 n%(VECTOR_CHUNK_BYTES/CELL));
1371 }
1372
celt(LispObject v,size_t n)1373 inline char& celt(LispObject v, size_t n)
1374 { if (is_basic_vector(v)) return basic_celt(v, n);
1375 return basic_celt(basic_elt(v, n/VECTOR_CHUNK_BYTES),
1376 n%VECTOR_CHUNK_BYTES);
1377 }
1378
ucelt(LispObject v,size_t n)1379 inline unsigned char& ucelt(LispObject v, size_t n)
1380 { if (is_basic_vector(v)) return basic_ucelt(v, n);
1381 return basic_ucelt(basic_elt(v, n/VECTOR_CHUNK_BYTES),
1382 n%VECTOR_CHUNK_BYTES);
1383 }
1384
scelt(LispObject v,size_t n)1385 inline signed char& scelt(LispObject v, size_t n)
1386 { if (is_basic_vector(v)) return basic_scelt(v, n);
1387 return basic_scelt(basic_elt(v, n/VECTOR_CHUNK_BYTES),
1388 n%VECTOR_CHUNK_BYTES);
1389 }
1390
helt(LispObject v,size_t n)1391 inline int16_t& helt(LispObject v, size_t n)
1392 { if (is_basic_vector(v)) return basic_helt(v, n);
1393 return basic_helt(elt(v, n/(VECTOR_CHUNK_BYTES/sizeof(int16_t))),
1394 n%(VECTOR_CHUNK_BYTES/sizeof(int16_t)));
1395 }
1396
ielt(LispObject v,size_t n)1397 inline intptr_t& ielt(LispObject v, size_t n)
1398 { if (is_basic_vector(v)) return basic_ielt(v, n);
1399 return basic_ielt(
1400 elt(v, n/(VECTOR_CHUNK_BYTES/sizeof(intptr_t))),
1401 n%(VECTOR_CHUNK_BYTES/sizeof(intptr_t)));
1402 }
1403
ielt32(LispObject v,size_t n)1404 inline int32_t& ielt32(LispObject v, size_t n)
1405 { if (is_basic_vector(v)) return basic_ielt32(v, n);
1406 return basic_ielt32(elt(v, n/(VECTOR_CHUNK_BYTES/sizeof(int32_t))),
1407 n%(VECTOR_CHUNK_BYTES/sizeof(int32_t)));
1408 }
1409
felt(LispObject v,size_t n)1410 inline float& felt(LispObject v, size_t n)
1411 { if (is_basic_vector(v)) return basic_felt(v, n);
1412 return basic_felt(elt(v, n/(VECTOR_CHUNK_BYTES/sizeof(float))),
1413 n%(VECTOR_CHUNK_BYTES/sizeof(float)));
1414 }
1415
delt(LispObject v,size_t n)1416 inline double& delt(LispObject v, size_t n)
1417 { if (is_basic_vector(v)) return basic_delt(v, n);
1418 return basic_delt(elt(v, n/(VECTOR_CHUNK_BYTES/sizeof(double))),
1419 n%(VECTOR_CHUNK_BYTES/sizeof(double)));
1420 }
1421
is_header(LispObject x)1422 inline bool is_header(LispObject x)
1423 { return (static_cast<int>(x) & (0x3<<Tw)) != 0; // valid if TAG_HDR_IMMED
1424 }
1425
is_char(LispObject x)1426 inline bool is_char(LispObject x)
1427 { return (static_cast<int>(x) & HDR_IMMED_MASK) == TAG_CHAR;
1428 }
1429
is_spid(LispObject x)1430 inline bool is_spid(LispObject x)
1431 { return (static_cast<int>(x) & HDR_IMMED_MASK) == TAG_SPID;
1432 }
1433
is_library(LispObject x)1434 inline bool is_library(LispObject x)
1435 { return (static_cast<int>(x) & 0xfffff) == SPID_LIBRARY;
1436 }
1437
is_exception(LispObject x)1438 inline bool is_exception(LispObject x)
1439 { return (static_cast<int>(x) & 0xfffff) == SPID_ERROR;
1440 }
1441
library_number(LispObject x)1442 inline unsigned int library_number(LispObject x)
1443 { return (x >> 20) & 0xfff;
1444 }
1445
exception_type(LispObject x)1446 inline int exception_type(LispObject x)
1447 { return (x >> 20) & 0xfff;
1448 }
1449
1450 //
1451 // I will now support the full range of Unicode from U+0000 to U+10FFFF.
1452 //
1453 // Note that pack_char now takes a 21-bit code but only values up to
1454 // 0x0010ffff are valid for Unicode. Internally I will generally pack
1455 // things using utf-8 encoded strings.
1456 //
1457
1458 // The absolute shift values here reflect the fact that I have (at least)
1459 // 25 bits of payload in a CHAR object. It is not at all obvious to me that
1460 // the Common Lisp "font" component of characters was a good idea to start
1461 // with or that it has any respectable purpose today, and I only support
1462 // 16 distinct "Font" codes when I am on 32-bit hardware.
1463
font_of_char(LispObject n)1464 inline int font_of_char(LispObject n)
1465 { return (static_cast<int32_t>(n) >> (21+4+Tw)) & 0xf;
1466 }
1467
1468 // The Common Lisp "bits" part of a character object no longer makes any sense!
bits_of_char(LispObject n)1469 inline int bits_of_char(LispObject n)
1470 { return 0;
1471 }
1472
code_of_char(LispObject n)1473 inline unsigned int code_of_char(LispObject n)
1474 { return (static_cast<uint32_t>(n) >> (4+Tw)) & 0x001fffff;
1475 }
1476
pack_char(int font,unsigned int code)1477 inline LispObject pack_char(int font, unsigned int code)
1478 { return static_cast<LispObject>(
1479 ((static_cast<uint32_t>(font)) << (21+4+Tw)) |
1480 ((static_cast<uint32_t>(code)) << (4+Tw)) | TAG_CHAR);
1481 }
1482
1483 //
1484 // For internal purposes here I will use a pseudo-character with code
1485 // 0x0010ffff to stand for an end of file marker. This can be packed as
1486 // 4 bytes in utf-8 (f4/8f/bf/bf) and it is the last codepoint in the
1487 // Unicode range and is reserved in Unicode as not being a valid
1488 // character.
1489 //
1490 #define CHAR_EOF pack_char(0, 0x0010ffff)
1491
1492 typedef struct Symbol_Head_
1493 { std::atomic<Header> header; // Header as for other vector-like types
1494 std::atomic<LispObject> value; // Global or special value cell
1495 std::atomic<LispObject> env; // Extra stuff to help function cell
1496 std::atomic<LispObject> plist; // A list
1497 std::atomic<LispObject> fastgets; // to speed up flagp and get
1498 std::atomic<LispObject> package; // Home package - a package object
1499 std::atomic<LispObject> pname; // A string (always)
1500 std::atomic<uint32_t> countLow; // for statistics
1501 std::atomic<uint32_t> countHigh; // for statistics
1502 no_args *function0; // Executable code always (no arguments)
1503 one_arg *function1; // Executable code always (just 1 arg)
1504 two_args *function2; // Executable code always (just 2 args)
1505 three_args *function3; // Executable code always (just 3 args)
1506 fourup_args *function4up;// Executable code always (3 args + list of rest)
1507 } Symbol_Head;
1508
1509 #define MAX_FASTGET_SIZE 63
1510 // I have up to 63 "fast" tags for PUT/GET/FLAG/FLAGP
1511
1512 inline Header qheader(LispObject p,
1513 std::memory_order mo=std::memory_order_relaxed)
1514 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->header.load(mo);
1515 }
1516
1517 inline LispObject qvalue(LispObject p,
1518 std::memory_order mo=std::memory_order_relaxed)
1519 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->value.load(mo);
1520 }
1521
1522 inline LispObject qenv(LispObject p,
1523 std::memory_order mo=std::memory_order_relaxed)
1524 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->env.load(mo);
1525 }
1526
1527 inline LispObject qplist(LispObject p,
1528 std::memory_order mo=std::memory_order_relaxed)
1529 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->plist.load(mo);
1530 }
1531
1532 inline LispObject qfastgets(LispObject p,
1533 std::memory_order mo=std::memory_order_relaxed)
1534 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->fastgets.load(mo);
1535 }
1536
1537 inline LispObject qpackage(LispObject p,
1538 std::memory_order mo=std::memory_order_relaxed)
1539 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->package.load(mo);
1540 }
1541
1542 inline LispObject qpname(LispObject p,
1543 std::memory_order mo=std::memory_order_relaxed)
1544 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->pname.load(mo);
1545 }
1546
valueaddr(LispObject p)1547 inline atomic<LispObject> *valueaddr(LispObject p)
1548 { return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->value);
1549 }
1550
envaddr(LispObject p)1551 inline atomic<LispObject> *envaddr(LispObject p)
1552 { return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->env);
1553 }
1554
plistaddr(LispObject p)1555 inline atomic<LispObject> *plistaddr(LispObject p)
1556 { return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->plist);
1557 }
1558
fastgetsaddr(LispObject p)1559 inline atomic<LispObject> *fastgetsaddr(LispObject p)
1560 { return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->fastgets);
1561 }
1562
packageaddr(LispObject p)1563 inline atomic<LispObject> *packageaddr(LispObject p)
1564 { return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->package);
1565 }
1566
pnameaddr(LispObject p)1567 inline atomic<LispObject> *pnameaddr(LispObject p)
1568 { return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->pname);
1569 }
1570
1571 inline void setheader(LispObject p, Header h,
1572 std::memory_order mo=std::memory_order_relaxed)
1573 { reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->header.store(h, mo);
1574 }
1575
1576 inline void setvalue(LispObject p, LispObject q,
1577 std::memory_order mo=std::memory_order_relaxed)
1578 { reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->value.store(q, mo);
1579 }
1580
1581 inline void setenv(LispObject p, LispObject q,
1582 std::memory_order mo=std::memory_order_relaxed)
1583 { reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->env.store(q, mo);
1584 }
1585
1586 inline void setplist(LispObject p, LispObject q,
1587 std::memory_order mo=std::memory_order_relaxed)
1588 { reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->plist.store(q, mo);
1589 }
1590
1591 inline void setfastgets(LispObject p, LispObject q,
1592 std::memory_order mo=std::memory_order_relaxed)
1593 { reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->fastgets.store(q, mo);
1594 }
1595
1596 inline void setpackage(LispObject p, LispObject q,
1597 std::memory_order mo=std::memory_order_relaxed)
1598 { reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->package.store(q, mo);
1599 }
1600
1601 inline void setpname(LispObject p, LispObject q,
1602 std::memory_order mo=std::memory_order_relaxed)
1603 { reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->pname.store(q, mo);
1604 }
1605
qfn0(LispObject p)1606 inline no_args*& qfn0(LispObject p)
1607 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->function0;
1608 }
1609
qfn1(LispObject p)1610 inline one_arg*& qfn1(LispObject p)
1611 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->function1;
1612 }
1613
qfn2(LispObject p)1614 inline two_args*& qfn2(LispObject p)
1615 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->function2;
1616 }
1617
qfn3(LispObject p)1618 inline three_args*& qfn3(LispObject p)
1619 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->function3;
1620 }
1621
qfn4up(LispObject p)1622 inline fourup_args*& qfn4up(LispObject p)
1623 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->function4up;
1624 }
1625
1626 extern LispObject aerror1(const char *s, LispObject a);
1627
1628 // When I have functions with 4 or more args I may need to
1629 // extract them..
1630
arg4(const char * name,LispObject a4up)1631 inline LispObject arg4(const char *name, LispObject a4up)
1632 { if (cdr(a4up) != nil) return aerror1(name, a4up);
1633 // Too many args provided
1634 return car(a4up);
1635 }
1636
a4a5(const char * name,LispObject a4up,LispObject & a4,LispObject & a5)1637 inline bool a4a5(const char *name, LispObject a4up,
1638 LispObject& a4, LispObject& a5)
1639 { a4 = car(a4up);
1640 a4up = cdr(a4up);
1641 if (a4up==nil ||
1642 cdr(a4up) != nil)
1643 { aerror1(name, a4up); // wrong number
1644 return true;
1645 }
1646 a5 = car(a4up);
1647 return false;
1648 }
1649
a4a5a6(const char * name,LispObject a4up,LispObject & a4,LispObject & a5,LispObject & a6)1650 inline bool a4a5a6(const char *name, LispObject a4up,
1651 LispObject& a4, LispObject& a5, LispObject& a6)
1652 { a4 = car(a4up);
1653 a4up = cdr(a4up);
1654 if (a4up == nil)
1655 { aerror1(name, a4up); // not enough args
1656 return true;
1657 }
1658 a5 = car(a4up);
1659 a4up = cdr(a4up);
1660 if (a4up==nil ||
1661 cdr(a4up) != nil)
1662 { aerror1(name, a4up); // wrong number
1663 return true;
1664 }
1665 a6 = car(a4up);
1666 return false;
1667 }
1668
1669 // I store qcount as an unsigned 64-bit integer, but because on some
1670 // 32-bit machines one needs to take extra stape to get support for
1671 // 64-bit atomic values I will keep it as two 32-bit parts. This is
1672 // clearly clumsy and will slow things down, but I only access the count
1673 // field when I am in the bootstrap process not in production code and
1674 // so I will not worry a lot.
1675
qcountLow(LispObject p)1676 inline atomic<uint32_t>& qcountLow(LispObject p)
1677 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->countLow;
1678 }
1679
qcountHigh(LispObject p)1680 inline atomic<uint32_t>& qcountHigh(LispObject p)
1681 { return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->countHigh;
1682 }
1683
qcount(LispObject p)1684 inline uint64_t qcount(LispObject p)
1685 { Symbol_Head *pp = reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL);
1686 return static_cast<uint64_t>(pp->countHigh)<<32 | pp->countLow;
1687 }
1688
1689 inline void incCount(LispObject p, int m=1)
1690 { Symbol_Head *pp = reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL);
1691 uint32_t low = pp->countLow.fetch_add(m);
1692 if ((low+m) < low) pp->countHigh.fetch_add(1);
1693 }
1694
1695 #ifndef HAVE_SOFTFLOAT
1696 typedef struct _float32_t
1697 { uint32_t v;
1698 } float32_t;
1699
1700 typedef struct _float64_t
1701 { uint64_t v;
1702 } float64_t;
1703 #endif
1704
1705 typedef union _Float_union
1706 { float f;
1707 uint32_t i;
1708 float32_t f32;
1709 } Float_union;
1710
1711 // The following macro clears any bits in a LispObject above the
1712 // bottom 32.
1713
low32(LispObject a)1714 inline LispObject low32(LispObject a)
1715 { return static_cast<LispObject>(static_cast<uint32_t>(a));
1716 }
1717
1718 typedef struct Big_Number_
1719 {
1720 // see "arith.h" for a description of bignum formats
1721 Header h;
1722 //
1723 // EVEN when I have 64-bit addresses I will represent
1724 // big-numbers as arrays of 32-bit values. So I will still have to
1725 // ensure that I end up with a rounded number of digits - but in the
1726 // 64-bit case it will need to be an even number because the
1727 // header word at the front of a bignum becomes 64-bits long.
1728 //
1729 uint32_t d[1]; // generally more digits than this
1730 } Big_Number;
1731
bignum_length(LispObject b)1732 inline size_t bignum_length(LispObject b)
1733 { return length_of_header(numhdr(b));
1734 }
1735
bignum_digits(LispObject b)1736 inline uint32_t* bignum_digits(LispObject b)
1737 { return reinterpret_cast<uint32_t *>(
1738 reinterpret_cast<char *>(b) + (CELL-TAG_NUMBERS));
1739 }
1740
vbignum_digits(LispObject b)1741 inline uint32_t* vbignum_digits(LispObject b)
1742 { return reinterpret_cast<uint32_t *>(
1743 reinterpret_cast<char *>(b) + (CELL-TAG_NUMBERS));
1744 }
1745
1746 // For work on bignums when I have a 64-bit machine I frequently need the
1747 // top word of a bignum as a 64-bit (signed) value...
bignum_digits64(LispObject b,size_t n)1748 inline int64_t bignum_digits64(LispObject b, size_t n)
1749 { return static_cast<int64_t>(
1750 reinterpret_cast<int32_t *>(
1751 reinterpret_cast<char *>(b)+(CELL-TAG_NUMBERS))[n]);
1752 }
1753
1754
1755 // make_bighdr takes an argument measured in 32-bit units, including space
1756 // for the header word. This is the natural space unit used in the tagging
1757 // scheme so I just need to shift the count to where it has to live.
make_bighdr(size_t n)1758 inline Header make_bighdr(size_t n)
1759 { return TAG_HDR_IMMED+TYPE_BIGNUM+(n<<(Tw+7));
1760 }
1761
1762 // New bignums come in 64-bit units.
1763
make_new_bighdr(size_t n)1764 inline Header make_new_bighdr(size_t n)
1765 { return TAG_HDR_IMMED+TYPE_NEW_BIGNUM+(n<<(Tw+8));
1766 }
1767
new_bignum_digits(LispObject b)1768 inline uint64_t* new_bignum_digits(LispObject b)
1769 { return reinterpret_cast<uint64_t *>(
1770 reinterpret_cast<char *>(b) + (8-TAG_NUMBERS));
1771 }
1772
1773 // pack_hdrlength takes a length in 32-bit words (including the size of
1774 // the header). NOTE VERY WELL that although the other header length packers
1775 // take a count of items this one takes a length in 32-bit words!
1776 #define pack_hdrlength(n) (static_cast<intptr_t>(n)<<(Tw+7))
1777
1778 // pack_hdrlengthbytes takes a number of 32-bit words as an argument and
1779 // adjusts it to go in a header.
1780
1781 //@#define pack_hdrlengthbits(n) ((31+static_cast<intptr_t>(n))<<(Tw+2))
1782 //@#define pack_hdrlengthbytes(n) ((3+static_cast<intptr_t>(n))<<(Tw+5))
1783 //@#define pack_hdrlengthhwords(n) ((1+static_cast<intptr_t>(n))<<(Tw+4))
1784
1785 typedef struct Rational_Number_
1786 { atomic<Header> header;
1787 atomic<LispObject> num;
1788 atomic<LispObject> den;
1789 } Rational_Number;
1790
1791 inline LispObject numerator(LispObject r,
1792 std::memory_order mo=std::memory_order_relaxed)
1793 { return ((Rational_Number *)(reinterpret_cast<char *>
1794 (r)-TAG_NUMBERS))->num.load(mo);
1795 }
1796
1797 inline LispObject denominator(LispObject r,
1798 std::memory_order mo=std::memory_order_relaxed)
1799 { return ((Rational_Number *)(reinterpret_cast<char *>
1800 (r)-TAG_NUMBERS))->den.load(mo);
1801 }
1802
1803 inline void setnumerator(LispObject r, LispObject v,
1804 std::memory_order mo=std::memory_order_relaxed)
1805 { ((Rational_Number *)(reinterpret_cast<char *>
1806 (r)-TAG_NUMBERS))->num.store(v, mo);
1807 }
1808
1809 inline void setdenominator(LispObject r, LispObject v,
1810 std::memory_order mo=std::memory_order_relaxed)
1811 { return ((Rational_Number *)(reinterpret_cast<char *>
1812 (r)-TAG_NUMBERS))->den.store(v, mo);
1813 }
1814
1815 typedef struct Complex_Number_
1816 { atomic<Header> header;
1817 atomic<LispObject> real;
1818 atomic<LispObject> imag;
1819 } Complex_Number;
1820
1821 inline LispObject real_part(LispObject r,
1822 std::memory_order mo=std::memory_order_relaxed)
1823 { return ((Complex_Number *)(reinterpret_cast<char *>
1824 (r)-TAG_NUMBERS))->real.load(mo);
1825 }
1826
1827 inline LispObject imag_part(LispObject r,
1828 std::memory_order mo=std::memory_order_relaxed)
1829 { return ((Complex_Number *)(reinterpret_cast<char *>
1830 (r)-TAG_NUMBERS))->imag.load(mo);
1831 }
1832
1833 inline void setreal_part(LispObject r, LispObject v,
1834 std::memory_order mo=std::memory_order_relaxed)
1835 { return ((Complex_Number *)(reinterpret_cast<char *>
1836 (r)-TAG_NUMBERS))->real.store(v, mo);
1837 }
1838
1839 inline void setimag_part(LispObject r, LispObject v,
1840 std::memory_order mo=std::memory_order_relaxed)
1841 { return ((Complex_Number *)(reinterpret_cast<char *>
1842 (r)-TAG_NUMBERS))->imag.store(v, mo);
1843 }
1844
1845 typedef struct Single_Float_
1846 { atomic<Header> header;
1847 union float_or_int
1848 { float f;
1849 float32_t f32;
1850 int32_t i;
1851 } f;
1852 } Single_Float;
1853
single_float_val(LispObject v)1854 inline float& single_float_val(LispObject v)
1855 { return ((Single_Float *)(reinterpret_cast<char *>
1856 (v)-TAG_BOXFLOAT))->f.f;
1857 }
1858
float32_t_val(LispObject v)1859 inline float32_t& float32_t_val(LispObject v)
1860 { return ((Single_Float *)(reinterpret_cast<char *>
1861 (v)-TAG_BOXFLOAT))->f.f32;
1862 }
1863
intfloat32_t_val(LispObject v)1864 inline int32_t& intfloat32_t_val(LispObject v)
1865 { return ((Single_Float *)(reinterpret_cast<char *>
1866 (v)-TAG_BOXFLOAT))->f.i;
1867 }
1868
1869 //
1870 // The structures here are not actually used - because I can not get
1871 // as strong control of alignment as I would like. So I use macros that
1872 // do address arithmetic explicitly for me...
1873 //
1874 // typedef struct Double_Float_
1875 // {
1876 // Header header;
1877 // // I want the data to
1878 // alignas (8) union double_or_ints {
1879 // double f;
1880 // float64_t f64;
1881 // int32_t i[2];
1882 // int64_t ii;
1883 // } f;
1884 // } Double_Float;
1885 //
1886
1887 typedef union _Double_union
1888 { double f;
1889 uint32_t i[2];
1890 uint64_t i64;
1891 float64_t f64;
1892
1893 } Double_union;
1894
1895 #define SIZEOF_DOUBLE_FLOAT 16
double_float_addr(LispObject v)1896 inline double *double_float_addr(LispObject v)
1897 { return reinterpret_cast<double *>(reinterpret_cast<char *>(v) +
1898 (8-TAG_BOXFLOAT));
1899 }
1900
1901 // on 32-bit machines there has to be a padding work in a double_float,
1902 // and this lets me clear it out.
double_float_pad(LispObject v)1903 inline int32_t& double_float_pad(LispObject v)
1904 { return *reinterpret_cast<int32_t *>(reinterpret_cast<char *>
1905 (v) + (4-TAG_BOXFLOAT));
1906 }
1907
double_float_val(LispObject v)1908 inline double& double_float_val(LispObject v)
1909 { return *reinterpret_cast<double *>(reinterpret_cast<char *>(v) +
1910 (8-TAG_BOXFLOAT));
1911 }
1912
float64_t_val(LispObject v)1913 inline float64_t& float64_t_val(LispObject v)
1914 { return *reinterpret_cast<float64_t *>(reinterpret_cast<char *>
1915 (v) + (8-TAG_BOXFLOAT));
1916 }
1917
intfloat64_t_val(LispObject v)1918 inline int64_t& intfloat64_t_val(LispObject v)
1919 { return *reinterpret_cast<int64_t *>(reinterpret_cast<char *>
1920 (v) + (8-TAG_BOXFLOAT));
1921 }
1922
intfloat64_t_val_hi(LispObject v)1923 inline int32_t& intfloat64_t_val_hi(LispObject v)
1924 { return *reinterpret_cast<int32_t *>(reinterpret_cast<char *>
1925 (v) + (8-TAG_BOXFLOAT));
1926 }
1927
intfloat64_t_val_lo(LispObject v)1928 inline int32_t& intfloat64_t_val_lo(LispObject v)
1929 { return *reinterpret_cast<int32_t *>(
1930 reinterpret_cast<char *>(v) + (12-TAG_BOXFLOAT));
1931 }
1932
1933 //
1934 // Again I do not actually introduce the struct...
1935 //
1936 // For "long double" I use float128_t as implemented in the SoftFloat_3a
1937 // library. This represents each float with 16-bits of exponent and 113
1938 // bits of mantissa (including the hidden bit). Basic arithmetic is
1939 // supported, but not the elementary functions. I am going to ASSUME that
1940 // everything can be aligned at 8-byte boundaries.
1941 //
1942 // typedef struct Long_Float_
1943 // {
1944 // Header header;
1945 // What follows ALWAYS starts exactly 8 bytes on from the start
1946 // of the object, ie (8-TAG_BOXFLOAT) bytes on from the tagged pointer
1947 // that identifies it.
1948 // alignas (8) union long_or_ints {
1949 // float128_t f128;
1950 // int32_t i[4];
1951 // int64_t ii[2];
1952 // } f;
1953 // } Long_Float;
1954 //
1955
1956 #ifdef HAVE_SOFTFLOAT
1957 #define SIZEOF_LONG_FLOAT 24
long_float_addr(LispObject v)1958 inline float128_t *long_float_addr(LispObject v)
1959 { return (float128_t *)(reinterpret_cast<char *>(v) +
1960 (8-TAG_BOXFLOAT));
1961 }
1962
long_float_pad(LispObject v)1963 inline int32_t& long_float_pad(LispObject v)
1964 { return *reinterpret_cast<int32_t *>(reinterpret_cast<char *>
1965 (v) + (4-TAG_BOXFLOAT));
1966 }
1967
long_float_val(LispObject v)1968 inline float128_t& long_float_val(LispObject v)
1969 { return *reinterpret_cast<float128_t *>(reinterpret_cast<char *>
1970 (v) + (8-TAG_BOXFLOAT));
1971 }
1972
float128_t_val(LispObject v)1973 inline float128_t& float128_t_val(LispObject v)
1974 { return *reinterpret_cast<float128_t *>(reinterpret_cast<char *>
1975 (v) + (8-TAG_BOXFLOAT));
1976 }
1977
intfloat128_t_val0(LispObject v)1978 inline int64_t& intfloat128_t_val0(LispObject v)
1979 { return *reinterpret_cast<int64_t *>(
1980 reinterpret_cast<char *>(
1981 v) + (8-TAG_BOXFLOAT));
1982 }
1983
intfloat128_t_val1(LispObject v)1984 inline int64_t& intfloat128_t_val1(LispObject v)
1985 { return *reinterpret_cast<int64_t *>(
1986 reinterpret_cast<char *>(
1987 v) + (16-TAG_BOXFLOAT));
1988 }
1989
intfloat128_t_val32_0(LispObject v)1990 inline int32_t& intfloat128_t_val32_0(LispObject v)
1991 { return *reinterpret_cast<int32_t *>(
1992 reinterpret_cast<char *>(v) + (8-TAG_BOXFLOAT));
1993 }
1994
intfloat128_t_val32_1(LispObject v)1995 inline int32_t& intfloat128_t_val32_1(LispObject v)
1996 { return *reinterpret_cast<int32_t *>(
1997 reinterpret_cast<char *>(v) + (12-TAG_BOXFLOAT));
1998 }
1999
intfloat128_t_val32_2(LispObject v)2000 inline int32_t& intfloat128_t_val32_2(LispObject v)
2001 { return *reinterpret_cast<int32_t *>(
2002 reinterpret_cast<char *>(
2003 v) + (16-TAG_BOXFLOAT));
2004 }
2005
intfloat128_t_val32_3(LispObject v)2006 inline int32_t& intfloat128_t_val32_3(LispObject v)
2007 { return *reinterpret_cast<int32_t *>(
2008 reinterpret_cast<char *>(v) + (20-TAG_BOXFLOAT));
2009 }
2010 #endif // HAVE_SOFTFLOAT
2011
word_align_up(uintptr_t n)2012 inline uintptr_t word_align_up(uintptr_t n)
2013 { return static_cast<LispObject>((n + 3) & (-static_cast<uintptr_t>
2014 (4U)));
2015 }
2016
doubleword_align_up(uintptr_t n)2017 inline uintptr_t doubleword_align_up(uintptr_t n)
2018 { return static_cast<uintptr_t>(
2019 (n + 7) & (-static_cast<uintptr_t>(8U)));
2020 }
2021
doubleword_align_up(LispObject n)2022 inline LispObject doubleword_align_up(LispObject n)
2023 { return static_cast<LispObject>(
2024 (static_cast<uintptr_t>(n) + 7) &
2025 (-static_cast<uintptr_t>(8U)));
2026 }
2027
doubleword_align_down(uintptr_t n)2028 inline uintptr_t doubleword_align_down(uintptr_t n)
2029 { return static_cast<uintptr_t>(
2030 static_cast<intptr_t>(n) & (-static_cast<uintptr_t>(8U)));
2031 }
2032
object_align_up(uintptr_t n)2033 inline uintptr_t object_align_up(uintptr_t n)
2034 { return static_cast<uintptr_t>((n + sizeof(LispObject) - 1) &
2035 (-static_cast<uintptr_t>(sizeof(LispObject))));
2036 }
2037
object_2_align_up(uintptr_t n)2038 inline uintptr_t object_2_align_up(uintptr_t n)
2039 { return static_cast<uintptr_t>(
2040 (n + 2*sizeof(LispObject) - 1) &
2041 (-static_cast<uintptr_t>(
2042 2)*sizeof(LispObject)));
2043 }
2044
2045 //inline uintptr_t quadword_align_up(uintptr_t n)
2046 //{ return static_cast<uintptr_t>((n + 15) & (-static_cast<uintptr_t>(16U)));
2047 //}
2048
2049 // values to go in exit_reason at times when exceptions are being thrown.
2050
2051 #define UNWIND_NULL 0x0 // no error or action at all
2052 #define UNWIND_GO 0x1 // GO, to support non-local case
2053 #define UNWIND_RETURN 0x2 // RETURN, to support non-local
2054 #define UNWIND_THROW 0x3 // THROW is obvious
2055 #define UNWIND_RESTART 0x4 // (restart!-csl ...)
2056 #define UNWIND_RESOURCE 0x5 // used with (resource!-limit ...)
2057 //#define UNWIND_SIGINT 0x6 // SIGINT
2058
2059 #define UNWIND_FNAME 0x100 // at least short backtrace is needed
2060 #define UNWIND_ARGS 0x200 // produce long form backtrace
2061 #define UNWIND_ERROR (UNWIND_FNAME|UNWIND_ARGS)
2062 #define UNWIND_UNWIND 0x400 // no backtrace, still an error
2063
2064 #define SHOW_FNAME ((exit_reason & UNWIND_FNAME) != 0)
2065 #define SHOW_ARGS ((exit_reason & UNWIND_ARGS) != 0)
2066
2067 // Styles or flavours of hash table.
2068
2069 #define HASH_AS_EQ 0
2070 #define HASH_AS_EQL 1
2071 #define HASH_AS_CL_EQUAL 2
2072 #define HASH_AS_EQUAL 3
2073 #define HASH_AS_EQUALP 4
2074 #define HASH_AS_SYMBOL 5
2075 #define HASH_AS_SXHASH 6
2076
2077 #endif // header_tags_h
2078
2079 // end of tags.h
2080