git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_mem.c

   1 /*
   2  * Copyright © 2016 Keith Packard <keithp@keithp.com>
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation, either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * General Public License for more details.
  13  */
  14
  15 #define AO_SCHEME_CONST_BITS
  16
  17 #include "ao_scheme.h"
  18 #include <stdio.h>
  19 #include <assert.h>
  20
  21 #ifdef AO_SCHEME_MAKE_CONST
  22
  23 /*
  24  * When building the constant table, it is the
  25  * pool for allocations.
  26  */
  27
  28 #include <stdlib.h>
  29 uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));
  30 #define ao_scheme_pool ao_scheme_const
  31 #undef AO_SCHEME_POOL
  32 #define AO_SCHEME_POOL AO_SCHEME_POOL_CONST
  33
  34 #else
  35
  36 uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4)));
  37
  38 #endif
  39
  40 #ifndef DBG_MEM_STATS
  41 #define DBG_MEM_STATS   DBG_MEM
  42 #endif
  43
  44 #define DBG_MEM_STACK   0
  45 #if DBG_MEM_STACK
  46 char    *mem_collect_stack;
  47 int64_t mem_collect_max_depth;
  48
  49 static void
  50 ao_scheme_check_stack(void)
  51 {
  52         char    x;
  53         int64_t depth;
  54
  55         depth = mem_collect_stack - &x;
  56         if (depth > mem_collect_max_depth)
  57                 mem_collect_max_depth = depth;
  58 }
  59
  60 static void
  61 _ao_scheme_reset_stack(char *x)
  62 {
  63         mem_collect_stack = x;
  64 //      mem_collect_max_depth = 0;
  65 }
  66 #define ao_scheme_declare_stack char x;
  67 #define ao_scheme_reset_stack() _ao_scheme_reset_stack(&x)
  68 #else
  69 #define ao_scheme_check_stack()
  70 #define ao_scheme_declare_stack
  71 #define ao_scheme_reset_stack()
  72 #endif
  73
  74 #if DBG_MEM
  75 #define DBG_MEM_RECORD  1
  76 #endif
  77
  78 #if DBG_MEM
  79 int dbg_move_depth;
  80 int dbg_mem = DBG_MEM_START;
  81 int dbg_validate = 0;
  82 #endif
  83
  84 #if DBG_MEM_RECORD
  85 struct ao_scheme_record {
  86         struct ao_scheme_record         *next;
  87         const struct ao_scheme_type     *type;
  88         void                            *addr;
  89         int                             size;
  90 };
  91
  92 static struct ao_scheme_record  *record_head, **record_tail;
  93
  94 static void
  95 ao_scheme_record_free(struct ao_scheme_record *record)
  96 {
  97         while (record) {
  98                 struct ao_scheme_record *next = record->next;
  99                 free(record);
 100                 record = next;
 101         }
 102 }
 103
 104 static void
 105 ao_scheme_record_reset(void)
 106 {
 107         ao_scheme_record_free(record_head);
 108         record_head = NULL;
 109         record_tail = &record_head;
 110 }
 111
 112 static void
 113 ao_scheme_record(const struct ao_scheme_type    *type,
 114                void                             *addr,
 115                int                              size)
 116 {
 117         struct ao_scheme_record *r = malloc(sizeof (struct ao_scheme_record));
 118
 119         r->next = NULL;
 120         r->type = type;
 121         r->addr = addr;
 122         r->size = size;
 123         *record_tail = r;
 124         record_tail = &r->next;
 125 }
 126
 127 static struct ao_scheme_record *
 128 ao_scheme_record_save(void)
 129 {
 130         struct ao_scheme_record *r = record_head;
 131
 132         record_head = NULL;
 133         record_tail = &record_head;
 134         return r;
 135 }
 136
 137 static void
 138 ao_scheme_record_compare(const char *where,
 139                          struct ao_scheme_record *a,
 140                          struct ao_scheme_record *b)
 141 {
 142         while (a && b) {
 143                 if (a->type != b->type || a->size != b->size) {
 144                         printf("%s record difers %d %s %d -> %d %s %d\n",
 145                                where,
 146                                MDBG_OFFSET(a->addr),
 147                                a->type->name,
 148                                a->size,
 149                                MDBG_OFFSET(b->addr),
 150                                b->type->name,
 151                                b->size);
 152                         ao_scheme_abort();
 153                 }
 154                 a = a->next;
 155                 b = b->next;
 156         }
 157         if (a) {
 158                 printf("%s record differs %d %s %d -> NULL\n",
 159                        where,
 160                        MDBG_OFFSET(a->addr),
 161                        a->type->name,
 162                        a->size);
 163                 ao_scheme_abort();
 164         }
 165         if (b) {
 166                 printf("%s record differs NULL -> %d %s %d\n",
 167                        where,
 168                        MDBG_OFFSET(b->addr),
 169                        b->type->name,
 170                        b->size);
 171                 ao_scheme_abort();
 172         }
 173 }
 174
 175 #else
 176 #define ao_scheme_record_reset()
 177 #define ao_scheme_record(t,a,s)
 178 #endif
 179
 180 uint8_t ao_scheme_exception;
 181
 182 struct ao_scheme_root {
 183         const struct ao_scheme_type     *type;
 184         void                            **addr;
 185 };
 186
 187 static struct ao_scheme_cons    *save_cons[2];
 188 static struct ao_scheme_string  *save_string[2];
 189 static struct ao_scheme_frame   *save_frame[1];
 190 static ao_poly                  save_poly[3];
 191
 192 static const struct ao_scheme_root      ao_scheme_root[] = {
 193         {
 194                 .type = &ao_scheme_cons_type,
 195                 .addr = (void **) &save_cons[0],
 196         },
 197         {
 198                 .type = &ao_scheme_cons_type,
 199                 .addr = (void **) &save_cons[1],
 200         },
 201         {
 202                 .type = &ao_scheme_string_type,
 203                 .addr = (void **) &save_string[0],
 204         },
 205         {
 206                 .type = &ao_scheme_string_type,
 207                 .addr = (void **) &save_string[1],
 208         },
 209         {
 210                 .type = &ao_scheme_frame_type,
 211                 .addr = (void **) &save_frame[0],
 212         },
 213         {
 214                 .type = NULL,
 215                 .addr = (void **) (void *) &save_poly[0]
 216         },
 217         {
 218                 .type = NULL,
 219                 .addr = (void **) (void *) &save_poly[1]
 220         },
 221         {
 222                 .type = NULL,
 223                 .addr = (void **) (void *) &save_poly[2]
 224         },
 225         {
 226                 .type = &ao_scheme_atom_type,
 227                 .addr = (void **) &ao_scheme_atoms
 228         },
 229         {
 230                 .type = &ao_scheme_frame_type,
 231                 .addr = (void **) &ao_scheme_frame_global,
 232         },
 233         {
 234                 .type = &ao_scheme_frame_type,
 235                 .addr = (void **) &ao_scheme_frame_current,
 236         },
 237         {
 238                 .type = &ao_scheme_stack_type,
 239                 .addr = (void **) &ao_scheme_stack,
 240         },
 241         {
 242                 .type = NULL,
 243                 .addr = (void **) (void *) &ao_scheme_v,
 244         },
 245         {
 246                 .type = &ao_scheme_cons_type,
 247                 .addr = (void **) &ao_scheme_read_cons,
 248         },
 249         {
 250                 .type = &ao_scheme_cons_type,
 251                 .addr = (void **) &ao_scheme_read_cons_tail,
 252         },
 253         {
 254                 .type = &ao_scheme_cons_type,
 255                 .addr = (void **) &ao_scheme_read_stack,
 256         },
 257 #ifdef AO_SCHEME_MAKE_CONST
 258         {
 259                 .type = &ao_scheme_bool_type,
 260                 .addr = (void **) &ao_scheme_false,
 261         },
 262         {
 263                 .type = &ao_scheme_bool_type,
 264                 .addr = (void **) &ao_scheme_true,
 265         },
 266 #endif
 267 };
 268
 269 #define AO_SCHEME_ROOT  (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0]))
 270
 271 static const void ** const ao_scheme_cache[] = {
 272         (const void **) &ao_scheme_cons_free_list,
 273         (const void **) &ao_scheme_stack_free_list,
 274         (const void **) &ao_scheme_frame_free_list[0],
 275         (const void **) &ao_scheme_frame_free_list[1],
 276         (const void **) &ao_scheme_frame_free_list[2],
 277         (const void **) &ao_scheme_frame_free_list[3],
 278         (const void **) &ao_scheme_frame_free_list[4],
 279         (const void **) &ao_scheme_frame_free_list[5],
 280 };
 281
 282 #if AO_SCHEME_FRAME_FREE != 6
 283 #error Unexpected AO_SCHEME_FRAME_FREE value
 284 #endif
 285
 286 #define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0]))
 287
 288 #define AO_SCHEME_BUSY_SIZE     ((AO_SCHEME_POOL + 31) / 32)
 289
 290 static int      ao_scheme_printing, ao_scheme_print_cleared;
 291 #if DBG_MEM
 292 static int      ao_scheme_collecting;
 293 #endif
 294 static uint8_t  ao_scheme_busy[AO_SCHEME_BUSY_SIZE];
 295 static uint8_t  ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE];
 296 static uint8_t  ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE];
 297 static uint8_t  ao_scheme_cons_noted;
 298
 299 uint16_t        ao_scheme_top;
 300
 301 struct ao_scheme_chunk {
 302         uint16_t                old_offset;
 303         union {
 304                 uint16_t        size;
 305                 uint16_t        new_offset;
 306         };
 307 };
 308
 309 #define AO_SCHEME_NCHUNK        64
 310
 311 static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK];
 312
 313 /* Offset of an address within the pool. */
 314 static inline uint16_t pool_offset(void *addr) {
 315 #if DBG_MEM
 316         if (!AO_SCHEME_IS_POOL(addr))
 317                 ao_scheme_abort();
 318 #endif
 319         return ((uint8_t *) addr) - ao_scheme_pool;
 320 }
 321
 322 static inline void mark(uint8_t *tag, int offset) {
 323         int     byte = offset >> 5;
 324         int     bit = (offset >> 2) & 7;
 325         ao_scheme_check_stack();
 326         tag[byte] |= (1 << bit);
 327 }
 328
 329 static inline void clear(uint8_t *tag, int offset) {
 330         int     byte = offset >> 5;
 331         int     bit = (offset >> 2) & 7;
 332         tag[byte] &= ~(1 << bit);
 333 }
 334
 335 static inline int busy(uint8_t *tag, int offset) {
 336         int     byte = offset >> 5;
 337         int     bit = (offset >> 2) & 7;
 338         return (tag[byte] >> bit) & 1;
 339 }
 340
 341 static inline int min(int a, int b) { return a < b ? a : b; }
 342 static inline int max(int a, int b) { return a > b ? a : b; }
 343
 344 static inline int limit(int offset) {
 345         return min(AO_SCHEME_POOL, max(offset, 0));
 346 }
 347
 348 static inline void
 349 note_cons(uint16_t offset)
 350 {
 351         MDBG_MOVE("note cons %d\n", offset);
 352         ao_scheme_cons_noted = 1;
 353         mark(ao_scheme_cons_note, offset);
 354 }
 355
 356 static uint16_t chunk_low, chunk_high;
 357 static uint16_t chunk_first, chunk_last;
 358
 359 static int
 360 find_chunk(uint16_t offset)
 361 {
 362         int l, r;
 363         /* Binary search for the location */
 364         l = chunk_first;
 365         r = chunk_last - 1;
 366         while (l <= r) {
 367                 int m = (l + r) >> 1;
 368                 if (ao_scheme_chunk[m].old_offset < offset)
 369                         l = m + 1;
 370                 else
 371                         r = m - 1;
 372         }
 373         return l;
 374 }
 375
 376 static void
 377 note_chunk(uint16_t offset, uint16_t size)
 378 {
 379         int l;
 380         int end;
 381
 382         if (offset < chunk_low || chunk_high <= offset)
 383                 return;
 384
 385         l = find_chunk(offset);
 386
 387         /*
 388          * The correct location is always in 'l', with r = l-1 being
 389          * the entry before the right one
 390          */
 391
 392 #if DBG_MEM
 393         /* Off the right side */
 394         if (l >= AO_SCHEME_NCHUNK)
 395                 ao_scheme_abort();
 396
 397         /* Off the left side */
 398         if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset)
 399                 ao_scheme_abort();
 400
 401         if (l < chunk_last && ao_scheme_chunk[l].old_offset == offset)
 402                 ao_scheme_abort();
 403 #endif
 404
 405         /* Shuffle existing entries right */
 406         end = min(AO_SCHEME_NCHUNK, chunk_last + 1);
 407
 408         memmove(&ao_scheme_chunk[l+1],
 409                 &ao_scheme_chunk[l],
 410                 (end - (l+1)) * sizeof (struct ao_scheme_chunk));
 411
 412         /* Add new entry */
 413         ao_scheme_chunk[l].old_offset = offset;
 414         ao_scheme_chunk[l].size = size;
 415
 416         /* Increment the number of elements up to the size of the array */
 417         if (chunk_last < AO_SCHEME_NCHUNK)
 418                 chunk_last++;
 419
 420         /* Set the top address if the array is full */
 421         if (chunk_last == AO_SCHEME_NCHUNK)
 422                 chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset +
 423                         ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size;
 424 }
 425
 426 static void
 427 reset_chunks(void)
 428 {
 429         chunk_high = ao_scheme_top;
 430         chunk_last = 0;
 431         chunk_first = 0;
 432 }
 433
 434 /*
 435  * Walk all referenced objects calling functions on each one
 436  */
 437
 438 static void
 439 walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr),
 440      int (*visit_poly)(ao_poly *p, uint8_t do_note_cons))
 441 {
 442         int i;
 443
 444         ao_scheme_record_reset();
 445         memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy));
 446         memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note));
 447         ao_scheme_cons_noted = 0;
 448         for (i = 0; i < (int) AO_SCHEME_ROOT; i++) {
 449                 if (ao_scheme_root[i].type) {
 450                         void **a = ao_scheme_root[i].addr, *v;
 451                         if (a && (v = *a)) {
 452                                 MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v));
 453                                 visit_addr(ao_scheme_root[i].type, a);
 454                         }
 455                 } else {
 456                         ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p;
 457                         if (a && (p = *a)) {
 458                                 MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p)));
 459                                 visit_poly(a, 0);
 460                         }
 461                 }
 462         }
 463         while (ao_scheme_cons_noted) {
 464                 memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note));
 465                 memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note));
 466                 ao_scheme_cons_noted = 0;
 467                 for (i = 0; i < AO_SCHEME_POOL; i += 4) {
 468                         if (busy(ao_scheme_cons_last, i)) {
 469                                 void *v = ao_scheme_pool + i;
 470                                 MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v));
 471                                 visit_addr(&ao_scheme_cons_type, &v);
 472                         }
 473                 }
 474         }
 475 }
 476
 477 #if MDBG_DUMP
 478 static void
 479 dump_busy(void)
 480 {
 481         int     i;
 482         printf("busy:");
 483         for (i = 0; i < ao_scheme_top; i += 4) {
 484                 if ((i & 0xff) == 0) {
 485                         printf("\n\t");
 486                 }
 487                 else if ((i & 0x1f) == 0)
 488                         printf(" ");
 489                 if (busy(ao_scheme_busy, i))
 490                         printf("*");
 491                 else
 492                         printf("-");
 493         }
 494         printf ("\n");
 495 }
 496 #define DUMP_BUSY()     dump_busy()
 497 #else
 498 #define DUMP_BUSY()
 499 #endif
 500
 501 static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = {
 502         [AO_SCHEME_CONS] = &ao_scheme_cons_type,
 503         [AO_SCHEME_INT] = NULL,
 504 #ifdef AO_SCHEME_FEATURE_BIGINT
 505         [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type,
 506 #endif
 507         [AO_SCHEME_OTHER] = (void *) 0x1,
 508         [AO_SCHEME_ATOM] = &ao_scheme_atom_type,
 509         [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type,
 510         [AO_SCHEME_FRAME] = &ao_scheme_frame_type,
 511         [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type,
 512         [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type,
 513         [AO_SCHEME_STACK] = &ao_scheme_stack_type,
 514         [AO_SCHEME_BOOL] = &ao_scheme_bool_type,
 515         [AO_SCHEME_STRING] = &ao_scheme_string_type,
 516 #ifdef AO_SCHEME_FEATURE_FLOAT
 517         [AO_SCHEME_FLOAT] = &ao_scheme_float_type,
 518 #endif
 519 #ifdef AO_SCHEME_FEATURE_VECTOR
 520         [AO_SCHEME_VECTOR] = &ao_scheme_vector_type,
 521 #endif
 522 };
 523
 524 static int
 525 ao_scheme_mark(const struct ao_scheme_type *type, void *addr);
 526
 527 static int
 528 ao_scheme_move(const struct ao_scheme_type *type, void **ref);
 529
 530 static int
 531 ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref)
 532 {
 533         return ao_scheme_mark(type, *ref);
 534 }
 535
 536 static int
 537 ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons)
 538 {
 539         return ao_scheme_poly_mark(*p, do_note_cons);
 540 }
 541
 542 #if DBG_MEM_STATS
 543 uint64_t ao_scheme_collects[2];
 544 uint64_t ao_scheme_freed[2];
 545 uint64_t ao_scheme_loops[2];
 546 #endif
 547
 548 int ao_scheme_last_top;
 549 int ao_scheme_collect_counts;
 550
 551 int
 552 ao_scheme_collect(uint8_t style)
 553 {
 554         ao_scheme_declare_stack
 555         int     i;
 556         int     top;
 557 #if DBG_MEM_STATS
 558         int     loops = 0;
 559 #endif
 560 #if DBG_MEM_RECORD
 561         struct ao_scheme_record *mark_record = NULL, *move_record = NULL;
 562 #endif
 563         MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]);
 564
 565         MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global)));
 566         MDBG_DO(++ao_scheme_collecting);
 567
 568         ao_scheme_reset_stack();
 569
 570         /* The first time through, we're doing a full collect */
 571         if (ao_scheme_last_top == 0)
 572                 style = AO_SCHEME_COLLECT_FULL;
 573
 574         /* One in a while, just do a full collect */
 575
 576         if (ao_scheme_collect_counts >= 128)
 577                 style = AO_SCHEME_COLLECT_FULL;
 578
 579         if (style == AO_SCHEME_COLLECT_FULL)
 580                 ao_scheme_collect_counts = 0;
 581
 582         /* Clear references to all caches */
 583         for (i = 0; i < (int) AO_SCHEME_CACHE; i++)
 584                 *ao_scheme_cache[i] = NULL;
 585         if (style == AO_SCHEME_COLLECT_FULL) {
 586                 chunk_low = top = 0;
 587         } else {
 588                 chunk_low = top = ao_scheme_last_top;
 589         }
 590         for (;;) {
 591                 MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top);
 592                 /* Find the sizes of the first chunk of objects to move */
 593                 reset_chunks();
 594                 walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref);
 595
 596 #if DBG_MEM_RECORD
 597                 ao_scheme_record_free(mark_record);
 598                 mark_record = ao_scheme_record_save();
 599                 if (mark_record && move_record)
 600                         ao_scheme_record_compare("mark", move_record, mark_record);
 601 #endif
 602
 603                 DUMP_BUSY();
 604
 605                 /* Find the first moving object */
 606                 for (i = 0; i < chunk_last; i++) {
 607                         uint16_t        size = ao_scheme_chunk[i].size;
 608 #if DBG_MEM
 609                         if (!size)
 610                                 ao_scheme_abort();
 611 #endif
 612
 613                         if (ao_scheme_chunk[i].old_offset > top)
 614                                 break;
 615
 616                         MDBG_MOVE("chunk %d %d not moving\n",
 617                                   ao_scheme_chunk[i].old_offset,
 618                                   ao_scheme_chunk[i].size);
 619 #if DBG_MEM
 620                         if (ao_scheme_chunk[i].old_offset != top)
 621                                 ao_scheme_abort();
 622 #endif
 623                         top += size;
 624                 }
 625
 626                 /* Short-circuit the rest of the loop when all of the
 627                  * found objects aren't moving. This isn't strictly
 628                  * necessary as the rest of the loop is structured to
 629                  * work in this case, but GCC 7.2.0 with optimization
 630                  * greater than 2 generates incorrect code for this...
 631                  */
 632                 if (i == AO_SCHEME_NCHUNK) {
 633                         chunk_low = chunk_high;
 634 #if DBG_MEM_STATS
 635                         loops++;
 636 #endif
 637                         continue;
 638                 }
 639
 640                 /*
 641                  * Limit amount of chunk array used in mapping moves
 642                  * to the active region
 643                  */
 644                 chunk_first = i;
 645                 chunk_low = ao_scheme_chunk[i].old_offset;
 646
 647                 /* Copy all of the objects */
 648                 for (; i < chunk_last; i++) {
 649                         uint16_t        size = ao_scheme_chunk[i].size;
 650
 651 #if DBG_MEM
 652                         if (!size)
 653                                 ao_scheme_abort();
 654 #endif
 655
 656                         MDBG_MOVE("chunk %d %d -> %d\n",
 657                                   ao_scheme_chunk[i].old_offset,
 658                                   size,
 659                                   top);
 660                         ao_scheme_chunk[i].new_offset = top;
 661
 662                         memmove(&ao_scheme_pool[top],
 663                                 &ao_scheme_pool[ao_scheme_chunk[i].old_offset],
 664                                 size);
 665
 666                         top += size;
 667                 }
 668
 669                 if (chunk_first < chunk_last) {
 670                         /* Relocate all references to the objects */
 671                         walk(ao_scheme_move, ao_scheme_poly_move);
 672
 673 #if DBG_MEM_RECORD
 674                         ao_scheme_record_free(move_record);
 675                         move_record = ao_scheme_record_save();
 676                         if (mark_record && move_record)
 677                                 ao_scheme_record_compare("move", mark_record, move_record);
 678 #endif
 679                 }
 680
 681 #if DBG_MEM_STATS
 682                 loops++;
 683 #endif
 684                 /* If we ran into the end of the heap, then
 685                  * there's no need to keep walking
 686                  */
 687                 if (chunk_last != AO_SCHEME_NCHUNK)
 688                         break;
 689
 690                 /* Next loop starts right above this loop */
 691                 chunk_low = chunk_high;
 692         }
 693
 694 #if DBG_MEM_STATS
 695         /* Collect stats */
 696         ++ao_scheme_collects[style];
 697         ao_scheme_freed[style] += ao_scheme_top - top;
 698         ao_scheme_loops[style] += loops;
 699 #endif
 700
 701         ao_scheme_top = top;
 702         if (style == AO_SCHEME_COLLECT_FULL)
 703                 ao_scheme_last_top = top;
 704
 705         MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk));
 706                 walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref));
 707
 708 #if DBG_MEM_STACK
 709         fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth);
 710 #endif
 711         MDBG_DO(--ao_scheme_collecting);
 712         return AO_SCHEME_POOL - ao_scheme_top;
 713 }
 714
 715 #if DBG_FREE_CONS
 716 void
 717 ao_scheme_cons_check(struct ao_scheme_cons *cons)
 718 {
 719         ao_poly cdr;
 720         int offset;
 721
 722         chunk_low = 0;
 723         reset_chunks();
 724         walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref);
 725         while (cons) {
 726                 if (!AO_SCHEME_IS_POOL(cons))
 727                         break;
 728                 offset = pool_offset(cons);
 729                 if (busy(ao_scheme_busy, offset)) {
 730                         ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons));
 731                         abort();
 732                 }
 733                 cdr = cons->cdr;
 734                 if (!ao_scheme_is_pair(cdr))
 735                         break;
 736                 cons = ao_scheme_poly_cons(cdr);
 737         }
 738 }
 739 #endif
 740
 741 /*
 742  * Mark interfaces for objects
 743  */
 744
 745
 746 /*
 747  * Note a reference to memory and collect information about a few
 748  * object sizes at a time
 749  */
 750
 751 int
 752 ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr)
 753 {
 754         int offset;
 755         if (!AO_SCHEME_IS_POOL(addr))
 756                 return 1;
 757
 758         offset = pool_offset(addr);
 759         MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr));
 760         if (busy(ao_scheme_busy, offset)) {
 761                 MDBG_MOVE("already marked\n");
 762                 return 1;
 763         }
 764         mark(ao_scheme_busy, offset);
 765         note_chunk(offset, ao_scheme_size(type, addr));
 766         return 0;
 767 }
 768
 769 /*
 770  * Mark an object and all that it refereces
 771  */
 772 static int
 773 ao_scheme_mark(const struct ao_scheme_type *type, void *addr)
 774 {
 775         int ret;
 776         MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr));
 777         MDBG_MOVE_IN();
 778         ret = ao_scheme_mark_memory(type, addr);
 779         if (!ret) {
 780                 MDBG_MOVE("mark recurse\n");
 781                 type->mark(addr);
 782         }
 783         MDBG_MOVE_OUT();
 784         return ret;
 785 }
 786
 787 /*
 788  * Mark an object, unless it is a cons cell and
 789  * do_note_cons is set. In that case, just
 790  * set a bit in the cons note array; those
 791  * will be marked in a separate pass to avoid
 792  * deep recursion in the collector
 793  */
 794 int
 795 ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons)
 796 {
 797         uint8_t type;
 798         void    *addr;
 799         int     ret;
 800
 801         type = ao_scheme_poly_base_type(p);
 802
 803         if (type == AO_SCHEME_INT)
 804                 return 1;
 805
 806         addr = ao_scheme_ref(p);
 807         if (!AO_SCHEME_IS_POOL(addr))
 808                 return 1;
 809
 810         if (type == AO_SCHEME_CONS && do_note_cons) {
 811                 note_cons(pool_offset(addr));
 812                 return 1;
 813         } else {
 814                 const struct ao_scheme_type *lisp_type;
 815
 816                 if (type == AO_SCHEME_OTHER)
 817                         type = ao_scheme_other_type(addr);
 818
 819                 lisp_type = ao_scheme_types[type];
 820 #if DBG_MEM
 821                 if (!lisp_type)
 822                         ao_scheme_abort();
 823 #endif
 824
 825                 MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr));
 826                 MDBG_MOVE_IN();
 827                 ret = ao_scheme_mark_memory(lisp_type, addr);
 828                 if (!ret) {
 829                         MDBG_MOVE("mark recurse\n");
 830                         lisp_type->mark(addr);
 831                 }
 832                 MDBG_MOVE_OUT();
 833                 return ret;
 834         }
 835 }
 836
 837 /*
 838  * Find the current location of an object
 839  * based on the original location. For unmoved
 840  * objects, this is simple. For moved objects,
 841  * go search for it
 842  */
 843
 844 static uint16_t
 845 move_map(uint16_t offset)
 846 {
 847         int             l;
 848
 849         if (offset < chunk_low || chunk_high <= offset)
 850                 return offset;
 851
 852         l = find_chunk(offset);
 853
 854 #if DBG_MEM
 855         if (ao_scheme_chunk[l].old_offset != offset)
 856                 ao_scheme_abort();
 857 #endif
 858         return ao_scheme_chunk[l].new_offset;
 859 }
 860
 861 int
 862 ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref)
 863 {
 864         void            *addr = *ref;
 865         uint16_t        offset, orig_offset;
 866
 867         if (!AO_SCHEME_IS_POOL(addr))
 868                 return 1;
 869
 870         (void) type;
 871
 872         MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr));
 873         orig_offset = pool_offset(addr);
 874         offset = move_map(orig_offset);
 875         if (offset != orig_offset) {
 876                 MDBG_MOVE("update ref %d %d -> %d\n",
 877                           AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1,
 878                           orig_offset, offset);
 879                 *ref = ao_scheme_pool + offset;
 880         }
 881         if (busy(ao_scheme_busy, offset)) {
 882                 MDBG_MOVE("already moved\n");
 883                 return 1;
 884         }
 885         mark(ao_scheme_busy, offset);
 886         ao_scheme_record(type, addr, ao_scheme_size(type, addr));
 887         return 0;
 888 }
 889
 890 static int
 891 ao_scheme_move(const struct ao_scheme_type *type, void **ref)
 892 {
 893         int ret;
 894         MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref));
 895         MDBG_MOVE_IN();
 896         ret = ao_scheme_move_memory(type, ref);
 897         if (!ret) {
 898                 MDBG_MOVE("move recurse\n");
 899                 type->move(*ref);
 900         }
 901         MDBG_MOVE_OUT();
 902         return ret;
 903 }
 904
 905 int
 906 ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons)
 907 {
 908         ao_poly         p = *ref;
 909         int             ret;
 910         void            *addr;
 911         uint16_t        offset, orig_offset;
 912
 913         if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT)
 914                 return 1;
 915
 916         addr = ao_scheme_ref(p);
 917         if (!AO_SCHEME_IS_POOL(addr))
 918                 return 1;
 919
 920         orig_offset = pool_offset(addr);
 921         offset = move_map(orig_offset);
 922
 923         if (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS && do_note_cons) {
 924                 note_cons(orig_offset);
 925                 ret = 1;
 926         } else {
 927                 uint8_t type = ao_scheme_poly_base_type(p);
 928                 const struct ao_scheme_type *lisp_type;
 929
 930                 if (type == AO_SCHEME_OTHER)
 931                         type = ao_scheme_other_type(ao_scheme_pool + offset);
 932
 933                 lisp_type = ao_scheme_types[type];
 934 #if DBG_MEM
 935                 if (!lisp_type)
 936                         ao_scheme_abort();
 937 #endif
 938                 /* inline ao_scheme_move to save stack space */
 939                 MDBG_MOVE("move object %d\n", MDBG_OFFSET(addr));
 940                 MDBG_MOVE_IN();
 941                 ret = ao_scheme_move_memory(lisp_type, &addr);
 942                 if (!ret) {
 943                         MDBG_MOVE("move recurse\n");
 944                         lisp_type->move(addr);
 945                 }
 946                 MDBG_MOVE_OUT();
 947         }
 948
 949         /* Re-write the poly value */
 950         if (offset != orig_offset) {
 951                 ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p));
 952                 MDBG_MOVE("poly %d moved %d -> %d\n",
 953                           ao_scheme_poly_type(np), orig_offset, offset);
 954                 *ref = np;
 955         }
 956         return ret;
 957 }
 958
 959 #if DBG_MEM
 960 static void
 961 ao_scheme_validate(void)
 962 {
 963         chunk_low = 0;
 964         memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk));
 965         walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref);
 966 }
 967
 968 int dbg_allocs;
 969
 970 #endif
 971
 972 void *
 973 ao_scheme_alloc(int size)
 974 {
 975         void    *addr;
 976
 977         MDBG_DO(++dbg_allocs);
 978         MDBG_DO(if (dbg_validate) ao_scheme_validate());
 979         size = ao_scheme_size_round(size);
 980         if (AO_SCHEME_POOL - ao_scheme_top < size &&
 981             ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size &&
 982             ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size)
 983         {
 984                 ao_scheme_error(AO_SCHEME_OOM, "out of memory");
 985                 return NULL;
 986         }
 987         addr = ao_scheme_pool + ao_scheme_top;
 988         ao_scheme_top += size;
 989         MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size);
 990         return addr;
 991 }
 992
 993 void
 994 ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons)
 995 {
 996         assert(save_cons[id] == 0);
 997         save_cons[id] = cons;
 998 }
 999
1000 struct ao_scheme_cons *
1001 ao_scheme_cons_fetch(int id)
1002 {
1003         struct ao_scheme_cons *cons = save_cons[id];
1004         save_cons[id] = NULL;
1005         return cons;
1006 }
1007
1008 void
1009 ao_scheme_poly_stash(int id, ao_poly poly)
1010 {
1011         assert(save_poly[id] == AO_SCHEME_NIL);
1012         save_poly[id] = poly;
1013 }
1014
1015 ao_poly
1016 ao_scheme_poly_fetch(int id)
1017 {
1018         ao_poly poly = save_poly[id];
1019         save_poly[id] = AO_SCHEME_NIL;
1020         return poly;
1021 }
1022
1023 void
1024 ao_scheme_string_stash(int id, struct ao_scheme_string *string)
1025 {
1026         assert(save_string[id] == NULL);
1027         save_string[id] = string;
1028 }
1029
1030 struct ao_scheme_string *
1031 ao_scheme_string_fetch(int id)
1032 {
1033         struct ao_scheme_string *string = save_string[id];
1034         save_string[id] = NULL;
1035         return string;
1036 }
1037
1038 void
1039 ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame)
1040 {
1041         assert(save_frame[id] == NULL);
1042         save_frame[id] = frame;
1043 }
1044
1045 struct ao_scheme_frame *
1046 ao_scheme_frame_fetch(int id)
1047 {
1048         struct ao_scheme_frame *frame = save_frame[id];
1049         save_frame[id] = NULL;
1050         return frame;
1051 }
1052
1053 int
1054 ao_scheme_print_mark_addr(void *addr)
1055 {
1056         int     offset;
1057
1058 #if DBG_MEM
1059         if (ao_scheme_collecting)
1060                 ao_scheme_abort();
1061 #endif
1062
1063         if (!AO_SCHEME_IS_POOL(addr))
1064                 return 0;
1065
1066         if (!ao_scheme_print_cleared) {
1067                 ao_scheme_print_cleared = 1;
1068                 memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy));
1069         }
1070         offset = pool_offset(addr);
1071         if (busy(ao_scheme_busy, offset))
1072                 return 1;
1073         mark(ao_scheme_busy, offset);
1074         return 0;
1075 }
1076
1077 void
1078 ao_scheme_print_clear_addr(void *addr)
1079 {
1080         int     offset;
1081
1082 #if DBG_MEM
1083         if (ao_scheme_collecting)
1084                 ao_scheme_abort();
1085 #endif
1086
1087         if (!AO_SCHEME_IS_POOL(addr))
1088                 return;
1089
1090         if (!ao_scheme_print_cleared)
1091                 return;
1092         offset = pool_offset(addr);
1093         clear(ao_scheme_busy, offset);
1094 }
1095
1096 /* Notes that printing has started */
1097 void
1098 ao_scheme_print_start(void)
1099 {
1100         ao_scheme_printing++;
1101 }
1102
1103 /* Notes that printing has ended. Returns 1 if printing is still going on */
1104 int
1105 ao_scheme_print_stop(void)
1106 {
1107         ao_scheme_printing--;
1108         if (ao_scheme_printing != 0)
1109                 return 1;
1110         ao_scheme_print_cleared = 0;
1111         return 0;
1112 }