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 #define AO_SCHEME_NUM_STASH     6
 188 static ao_poly                  stash_poly[AO_SCHEME_NUM_STASH];
 189 static int                      stash_poly_ptr;
 190
 191 static const struct ao_scheme_root      ao_scheme_root[] = {
 192         {
 193                 .type = NULL,
 194                 .addr = (void **) (void *) &stash_poly[0]
 195         },
 196         {
 197                 .type = NULL,
 198                 .addr = (void **) (void *) &stash_poly[1]
 199         },
 200         {
 201                 .type = NULL,
 202                 .addr = (void **) (void *) &stash_poly[2]
 203         },
 204         {
 205                 .type = NULL,
 206                 .addr = (void **) (void *) &stash_poly[3]
 207         },
 208         {
 209                 .type = NULL,
 210                 .addr = (void **) (void *) &stash_poly[4]
 211         },
 212         {
 213                 .type = NULL,
 214                 .addr = (void **) (void *) &stash_poly[5]
 215         },
 216         {
 217                 .type = &ao_scheme_atom_type,
 218                 .addr = (void **) &ao_scheme_atoms
 219         },
 220         {
 221                 .type = &ao_scheme_frame_type,
 222                 .addr = (void **) &ao_scheme_frame_global,
 223         },
 224         {
 225                 .type = &ao_scheme_frame_type,
 226                 .addr = (void **) &ao_scheme_frame_current,
 227         },
 228         {
 229                 .type = &ao_scheme_stack_type,
 230                 .addr = (void **) &ao_scheme_stack,
 231         },
 232         {
 233                 .type = NULL,
 234                 .addr = (void **) (void *) &ao_scheme_v,
 235         },
 236         {
 237                 .type = &ao_scheme_cons_type,
 238                 .addr = (void **) &ao_scheme_read_cons,
 239         },
 240         {
 241                 .type = &ao_scheme_cons_type,
 242                 .addr = (void **) &ao_scheme_read_cons_tail,
 243         },
 244         {
 245                 .type = &ao_scheme_cons_type,
 246                 .addr = (void **) &ao_scheme_read_stack,
 247         },
 248 #ifdef AO_SCHEME_MAKE_CONST
 249         {
 250                 .type = &ao_scheme_bool_type,
 251                 .addr = (void **) &ao_scheme_false,
 252         },
 253         {
 254                 .type = &ao_scheme_bool_type,
 255                 .addr = (void **) &ao_scheme_true,
 256         },
 257 #endif
 258 };
 259
 260 #define AO_SCHEME_ROOT  (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0]))
 261
 262 static const void ** const ao_scheme_cache[] = {
 263         (const void **) &ao_scheme_cons_free_list,
 264         (const void **) &ao_scheme_stack_free_list,
 265         (const void **) &ao_scheme_frame_free_list[0],
 266         (const void **) &ao_scheme_frame_free_list[1],
 267         (const void **) &ao_scheme_frame_free_list[2],
 268         (const void **) &ao_scheme_frame_free_list[3],
 269         (const void **) &ao_scheme_frame_free_list[4],
 270         (const void **) &ao_scheme_frame_free_list[5],
 271 };
 272
 273 #if AO_SCHEME_FRAME_FREE != 6
 274 #error Unexpected AO_SCHEME_FRAME_FREE value
 275 #endif
 276
 277 #define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0]))
 278
 279 #define AO_SCHEME_BUSY_SIZE     ((AO_SCHEME_POOL + 31) / 32)
 280
 281 static int      ao_scheme_printing, ao_scheme_print_cleared;
 282 #if DBG_MEM
 283 static int      ao_scheme_collecting;
 284 #endif
 285 static uint8_t  ao_scheme_busy[AO_SCHEME_BUSY_SIZE];
 286 static uint8_t  ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE];
 287 static uint8_t  ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE];
 288 static uint8_t  ao_scheme_cons_noted;
 289
 290 uint16_t        ao_scheme_top;
 291
 292 struct ao_scheme_chunk {
 293         uint16_t                old_offset;
 294         union {
 295                 uint16_t        size;
 296                 uint16_t        new_offset;
 297         };
 298 };
 299
 300 #define AO_SCHEME_NCHUNK        64
 301
 302 static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK];
 303
 304 /* Offset of an address within the pool. */
 305 static inline uint16_t pool_offset(void *addr) {
 306 #if DBG_MEM
 307         if (!ao_scheme_is_pool_addr(addr))
 308                 ao_scheme_abort();
 309 #endif
 310         return ((uint8_t *) addr) - ao_scheme_pool;
 311 }
 312
 313 static inline void mark(uint8_t *tag, int offset) {
 314         int     byte = offset >> 5;
 315         int     bit = (offset >> 2) & 7;
 316         ao_scheme_check_stack();
 317         tag[byte] |= (1 << bit);
 318 }
 319
 320 static inline void clear(uint8_t *tag, int offset) {
 321         int     byte = offset >> 5;
 322         int     bit = (offset >> 2) & 7;
 323         tag[byte] &= ~(1 << bit);
 324 }
 325
 326 static inline int busy(uint8_t *tag, int offset) {
 327         int     byte = offset >> 5;
 328         int     bit = (offset >> 2) & 7;
 329         return (tag[byte] >> bit) & 1;
 330 }
 331
 332 static inline int min(int a, int b) { return a < b ? a : b; }
 333 static inline int max(int a, int b) { return a > b ? a : b; }
 334
 335 static inline int limit(int offset) {
 336         return min(AO_SCHEME_POOL, max(offset, 0));
 337 }
 338
 339 static inline void
 340 note_cons(uint16_t offset)
 341 {
 342         MDBG_MOVE("note cons %d\n", offset);
 343         ao_scheme_cons_noted = 1;
 344         mark(ao_scheme_cons_note, offset);
 345 }
 346
 347 static uint16_t chunk_low, chunk_high;
 348 static uint16_t chunk_first, chunk_last;
 349
 350 static int
 351 find_chunk(uint16_t offset)
 352 {
 353         int l, r;
 354         /* Binary search for the location */
 355         l = chunk_first;
 356         r = chunk_last - 1;
 357         while (l <= r) {
 358                 int m = (l + r) >> 1;
 359                 if (ao_scheme_chunk[m].old_offset < offset)
 360                         l = m + 1;
 361                 else
 362                         r = m - 1;
 363         }
 364         return l;
 365 }
 366
 367 static void
 368 note_chunk(uint16_t offset, uint16_t size)
 369 {
 370         int l;
 371         int end;
 372
 373         if (offset < chunk_low || chunk_high <= offset)
 374                 return;
 375
 376         l = find_chunk(offset);
 377
 378         /*
 379          * The correct location is always in 'l', with r = l-1 being
 380          * the entry before the right one
 381          */
 382
 383 #if DBG_MEM
 384         /* Off the right side */
 385         if (l >= AO_SCHEME_NCHUNK)
 386                 ao_scheme_abort();
 387
 388         /* Off the left side */
 389         if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset)
 390                 ao_scheme_abort();
 391
 392         if (l < chunk_last && ao_scheme_chunk[l].old_offset == offset)
 393                 ao_scheme_abort();
 394 #endif
 395
 396         /* Shuffle existing entries right */
 397         end = min(AO_SCHEME_NCHUNK, chunk_last + 1);
 398
 399         memmove(&ao_scheme_chunk[l+1],
 400                 &ao_scheme_chunk[l],
 401                 (end - (l+1)) * sizeof (struct ao_scheme_chunk));
 402
 403         /* Add new entry */
 404         ao_scheme_chunk[l].old_offset = offset;
 405         ao_scheme_chunk[l].size = size;
 406
 407         /* Increment the number of elements up to the size of the array */
 408         if (chunk_last < AO_SCHEME_NCHUNK)
 409                 chunk_last++;
 410
 411         /* Set the top address if the array is full */
 412         if (chunk_last == AO_SCHEME_NCHUNK)
 413                 chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset +
 414                         ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size;
 415 }
 416
 417 static void
 418 reset_chunks(void)
 419 {
 420         chunk_high = ao_scheme_top;
 421         chunk_last = 0;
 422         chunk_first = 0;
 423 }
 424
 425 /*
 426  * Walk all referenced objects calling functions on each one
 427  */
 428
 429 static void
 430 walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr),
 431      int (*visit_poly)(ao_poly *p, uint8_t do_note_cons))
 432 {
 433         int i;
 434
 435         ao_scheme_record_reset();
 436         memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy));
 437         memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note));
 438         ao_scheme_cons_noted = 0;
 439         for (i = 0; i < (int) AO_SCHEME_ROOT; i++) {
 440                 if (ao_scheme_root[i].type) {
 441                         void **a = ao_scheme_root[i].addr, *v;
 442                         if (a && (v = *a)) {
 443                                 MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v));
 444                                 visit_addr(ao_scheme_root[i].type, a);
 445                         }
 446                 } else {
 447                         ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p;
 448                         if (a && (p = *a)) {
 449                                 MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p)));
 450                                 visit_poly(a, 0);
 451                         }
 452                 }
 453         }
 454         while (ao_scheme_cons_noted) {
 455                 memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note));
 456                 memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note));
 457                 ao_scheme_cons_noted = 0;
 458                 for (i = 0; i < AO_SCHEME_POOL; i += 4) {
 459                         if (busy(ao_scheme_cons_last, i)) {
 460                                 void *v = ao_scheme_pool + i;
 461                                 MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v));
 462                                 visit_addr(&ao_scheme_cons_type, &v);
 463                         }
 464                 }
 465         }
 466 }
 467
 468 #if MDBG_DUMP
 469 static void
 470 dump_busy(void)
 471 {
 472         int     i;
 473         printf("busy:");
 474         for (i = 0; i < ao_scheme_top; i += 4) {
 475                 if ((i & 0xff) == 0) {
 476                         printf("\n\t");
 477                 }
 478                 else if ((i & 0x1f) == 0)
 479                         printf(" ");
 480                 if (busy(ao_scheme_busy, i))
 481                         printf("*");
 482                 else
 483                         printf("-");
 484         }
 485         printf ("\n");
 486 }
 487 #define DUMP_BUSY()     dump_busy()
 488 #else
 489 #define DUMP_BUSY()
 490 #endif
 491
 492 static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = {
 493         [AO_SCHEME_CONS] = &ao_scheme_cons_type,
 494         [AO_SCHEME_INT] = NULL,
 495 #ifdef AO_SCHEME_FEATURE_BIGINT
 496         [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type,
 497 #endif
 498         [AO_SCHEME_OTHER] = (void *) 0x1,
 499         [AO_SCHEME_ATOM] = &ao_scheme_atom_type,
 500         [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type,
 501         [AO_SCHEME_FRAME] = &ao_scheme_frame_type,
 502         [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type,
 503         [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type,
 504         [AO_SCHEME_STACK] = &ao_scheme_stack_type,
 505         [AO_SCHEME_BOOL] = &ao_scheme_bool_type,
 506         [AO_SCHEME_STRING] = &ao_scheme_string_type,
 507 #ifdef AO_SCHEME_FEATURE_FLOAT
 508         [AO_SCHEME_FLOAT] = &ao_scheme_float_type,
 509 #endif
 510 #ifdef AO_SCHEME_FEATURE_VECTOR
 511         [AO_SCHEME_VECTOR] = &ao_scheme_vector_type,
 512 #endif
 513 };
 514
 515 static int
 516 ao_scheme_mark(const struct ao_scheme_type *type, void *addr);
 517
 518 static int
 519 ao_scheme_move(const struct ao_scheme_type *type, void **ref);
 520
 521 static int
 522 ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref)
 523 {
 524         return ao_scheme_mark(type, *ref);
 525 }
 526
 527 static int
 528 ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons)
 529 {
 530         return ao_scheme_poly_mark(*p, do_note_cons);
 531 }
 532
 533 #if DBG_MEM_STATS
 534 uint64_t ao_scheme_collects[2];
 535 uint64_t ao_scheme_freed[2];
 536 uint64_t ao_scheme_loops[2];
 537 #endif
 538
 539 int ao_scheme_last_top;
 540 int ao_scheme_collect_counts;
 541
 542 int
 543 ao_scheme_collect(uint8_t style)
 544 {
 545         ao_scheme_declare_stack
 546         int     i;
 547         int     top;
 548 #if DBG_MEM_STATS
 549         int     loops = 0;
 550 #endif
 551 #if DBG_MEM_RECORD
 552         struct ao_scheme_record *mark_record = NULL, *move_record = NULL;
 553 #endif
 554         MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]);
 555
 556         MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global)));
 557         MDBG_DO(++ao_scheme_collecting);
 558
 559         ao_scheme_reset_stack();
 560
 561         /* The first time through, we're doing a full collect */
 562         if (ao_scheme_last_top == 0)
 563                 style = AO_SCHEME_COLLECT_FULL;
 564
 565         /* One in a while, just do a full collect */
 566
 567         if (ao_scheme_collect_counts >= 128)
 568                 style = AO_SCHEME_COLLECT_FULL;
 569
 570         if (style == AO_SCHEME_COLLECT_FULL)
 571                 ao_scheme_collect_counts = 0;
 572
 573         /* Clear references to all caches */
 574         for (i = 0; i < (int) AO_SCHEME_CACHE; i++)
 575                 *ao_scheme_cache[i] = NULL;
 576         if (style == AO_SCHEME_COLLECT_FULL) {
 577                 chunk_low = top = 0;
 578         } else {
 579                 chunk_low = top = ao_scheme_last_top;
 580         }
 581         for (;;) {
 582                 MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top);
 583                 /* Find the sizes of the first chunk of objects to move */
 584                 reset_chunks();
 585                 walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref);
 586
 587 #if DBG_MEM_RECORD
 588                 ao_scheme_record_free(mark_record);
 589                 mark_record = ao_scheme_record_save();
 590                 if (mark_record && move_record)
 591                         ao_scheme_record_compare("mark", move_record, mark_record);
 592 #endif
 593
 594                 DUMP_BUSY();
 595
 596                 /* Find the first moving object */
 597                 for (i = 0; i < chunk_last; i++) {
 598                         uint16_t        size = ao_scheme_chunk[i].size;
 599 #if DBG_MEM
 600                         if (!size)
 601                                 ao_scheme_abort();
 602 #endif
 603
 604                         if (ao_scheme_chunk[i].old_offset > top)
 605                                 break;
 606
 607                         MDBG_MOVE("chunk %d %d not moving\n",
 608                                   ao_scheme_chunk[i].old_offset,
 609                                   ao_scheme_chunk[i].size);
 610 #if DBG_MEM
 611                         if (ao_scheme_chunk[i].old_offset != top)
 612                                 ao_scheme_abort();
 613 #endif
 614                         top += size;
 615                 }
 616
 617                 /* Short-circuit the rest of the loop when all of the
 618                  * found objects aren't moving. This isn't strictly
 619                  * necessary as the rest of the loop is structured to
 620                  * work in this case, but GCC 7.2.0 with optimization
 621                  * greater than 2 generates incorrect code for this...
 622                  */
 623                 if (i == AO_SCHEME_NCHUNK) {
 624                         chunk_low = chunk_high;
 625 #if DBG_MEM_STATS
 626                         loops++;
 627 #endif
 628                         continue;
 629                 }
 630
 631                 /*
 632                  * Limit amount of chunk array used in mapping moves
 633                  * to the active region
 634                  */
 635                 chunk_first = i;
 636                 chunk_low = ao_scheme_chunk[i].old_offset;
 637
 638                 /* Copy all of the objects */
 639                 for (; i < chunk_last; i++) {
 640                         uint16_t        size = ao_scheme_chunk[i].size;
 641
 642 #if DBG_MEM
 643                         if (!size)
 644                                 ao_scheme_abort();
 645 #endif
 646
 647                         MDBG_MOVE("chunk %d %d -> %d\n",
 648                                   ao_scheme_chunk[i].old_offset,
 649                                   size,
 650                                   top);
 651                         ao_scheme_chunk[i].new_offset = top;
 652
 653                         memmove(&ao_scheme_pool[top],
 654                                 &ao_scheme_pool[ao_scheme_chunk[i].old_offset],
 655                                 size);
 656
 657                         top += size;
 658                 }
 659
 660                 if (chunk_first < chunk_last) {
 661                         /* Relocate all references to the objects */
 662                         walk(ao_scheme_move, ao_scheme_poly_move);
 663
 664 #if DBG_MEM_RECORD
 665                         ao_scheme_record_free(move_record);
 666                         move_record = ao_scheme_record_save();
 667                         if (mark_record && move_record)
 668                                 ao_scheme_record_compare("move", mark_record, move_record);
 669 #endif
 670                 }
 671
 672 #if DBG_MEM_STATS
 673                 loops++;
 674 #endif
 675                 /* If we ran into the end of the heap, then
 676                  * there's no need to keep walking
 677                  */
 678                 if (chunk_last != AO_SCHEME_NCHUNK)
 679                         break;
 680
 681                 /* Next loop starts right above this loop */
 682                 chunk_low = chunk_high;
 683         }
 684
 685 #if DBG_MEM_STATS
 686         /* Collect stats */
 687         ++ao_scheme_collects[style];
 688         ao_scheme_freed[style] += ao_scheme_top - top;
 689         ao_scheme_loops[style] += loops;
 690 #endif
 691
 692         ao_scheme_top = top;
 693         if (style == AO_SCHEME_COLLECT_FULL)
 694                 ao_scheme_last_top = top;
 695
 696         MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk));
 697                 walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref));
 698
 699 #if DBG_MEM_STACK
 700         fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth);
 701 #endif
 702         MDBG_DO(--ao_scheme_collecting);
 703         return AO_SCHEME_POOL - ao_scheme_top;
 704 }
 705
 706 #if DBG_FREE_CONS
 707 void
 708 ao_scheme_cons_check(struct ao_scheme_cons *cons)
 709 {
 710         ao_poly cdr;
 711         int offset;
 712
 713         chunk_low = 0;
 714         reset_chunks();
 715         walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref);
 716         while (cons) {
 717                 if (!ao_scheme_is_pool_addr(cons))
 718                         break;
 719                 offset = pool_offset(cons);
 720                 if (busy(ao_scheme_busy, offset)) {
 721                         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));
 722                         abort();
 723                 }
 724                 cdr = cons->cdr;
 725                 if (!ao_scheme_is_pair(cdr))
 726                         break;
 727                 cons = ao_scheme_poly_cons(cdr);
 728         }
 729 }
 730 #endif
 731
 732 /*
 733  * Mark interfaces for objects
 734  */
 735
 736
 737 /*
 738  * Note a reference to memory and collect information about a few
 739  * object sizes at a time
 740  */
 741
 742 int
 743 ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr)
 744 {
 745         int offset;
 746         if (!ao_scheme_is_pool_addr(addr))
 747                 return 1;
 748
 749         offset = pool_offset(addr);
 750         MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr));
 751         if (busy(ao_scheme_busy, offset)) {
 752                 MDBG_MOVE("already marked\n");
 753                 return 1;
 754         }
 755         mark(ao_scheme_busy, offset);
 756         note_chunk(offset, ao_scheme_size(type, addr));
 757         return 0;
 758 }
 759
 760 /*
 761  * Mark an object and all that it refereces
 762  */
 763 static int
 764 ao_scheme_mark(const struct ao_scheme_type *type, void *addr)
 765 {
 766         int ret;
 767         MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr));
 768         MDBG_MOVE_IN();
 769         ret = ao_scheme_mark_memory(type, addr);
 770         if (!ret) {
 771                 MDBG_MOVE("mark recurse\n");
 772                 type->mark(addr);
 773         }
 774         MDBG_MOVE_OUT();
 775         return ret;
 776 }
 777
 778 /*
 779  * Mark an object, unless it is a cons cell and
 780  * do_note_cons is set. In that case, just
 781  * set a bit in the cons note array; those
 782  * will be marked in a separate pass to avoid
 783  * deep recursion in the collector
 784  */
 785 int
 786 ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons)
 787 {
 788         uint8_t type;
 789         void    *addr;
 790         int     ret;
 791
 792         type = ao_scheme_poly_base_type(p);
 793
 794         if (type == AO_SCHEME_INT)
 795                 return 1;
 796
 797         addr = ao_scheme_ref(p);
 798         if (!ao_scheme_is_pool_addr(addr))
 799                 return 1;
 800
 801         if (type == AO_SCHEME_CONS && do_note_cons) {
 802                 note_cons(pool_offset(addr));
 803                 return 1;
 804         } else {
 805                 const struct ao_scheme_type *lisp_type;
 806
 807                 if (type == AO_SCHEME_OTHER)
 808                         type = ao_scheme_other_type(addr);
 809
 810                 lisp_type = ao_scheme_types[type];
 811 #if DBG_MEM
 812                 if (!lisp_type)
 813                         ao_scheme_abort();
 814 #endif
 815
 816                 MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr));
 817                 MDBG_MOVE_IN();
 818                 ret = ao_scheme_mark_memory(lisp_type, addr);
 819                 if (!ret) {
 820                         MDBG_MOVE("mark recurse\n");
 821                         lisp_type->mark(addr);
 822                 }
 823                 MDBG_MOVE_OUT();
 824                 return ret;
 825         }
 826 }
 827
 828 /*
 829  * Find the current location of an object
 830  * based on the original location. For unmoved
 831  * objects, this is simple. For moved objects,
 832  * go search for it
 833  */
 834
 835 static uint16_t
 836 move_map(uint16_t offset)
 837 {
 838         int             l;
 839
 840         if (offset < chunk_low || chunk_high <= offset)
 841                 return offset;
 842
 843         l = find_chunk(offset);
 844
 845 #if DBG_MEM
 846         if (ao_scheme_chunk[l].old_offset != offset)
 847                 ao_scheme_abort();
 848 #endif
 849         return ao_scheme_chunk[l].new_offset;
 850 }
 851
 852 int
 853 ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref)
 854 {
 855         void            *addr = *ref;
 856         uint16_t        offset, orig_offset;
 857
 858         if (!ao_scheme_is_pool_addr(addr))
 859                 return 1;
 860
 861         (void) type;
 862
 863         MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr));
 864         orig_offset = pool_offset(addr);
 865         offset = move_map(orig_offset);
 866         if (offset != orig_offset) {
 867                 MDBG_MOVE("update ref %d %d -> %d\n",
 868                           ao_scheme_is_pool_addr(ref) ? MDBG_OFFSET(ref) : -1,
 869                           orig_offset, offset);
 870                 *ref = ao_scheme_pool + offset;
 871         }
 872         if (busy(ao_scheme_busy, offset)) {
 873                 MDBG_MOVE("already moved\n");
 874                 return 1;
 875         }
 876         mark(ao_scheme_busy, offset);
 877         ao_scheme_record(type, addr, ao_scheme_size(type, addr));
 878         return 0;
 879 }
 880
 881 static int
 882 ao_scheme_move(const struct ao_scheme_type *type, void **ref)
 883 {
 884         int ret;
 885         MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref));
 886         MDBG_MOVE_IN();
 887         ret = ao_scheme_move_memory(type, ref);
 888         if (!ret) {
 889                 MDBG_MOVE("move recurse\n");
 890                 type->move(*ref);
 891         }
 892         MDBG_MOVE_OUT();
 893         return ret;
 894 }
 895
 896 int
 897 ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons)
 898 {
 899         ao_poly         p = *ref;
 900         int             ret;
 901         void            *addr;
 902         uint16_t        offset, orig_offset;
 903
 904         if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT)
 905                 return 1;
 906
 907         addr = ao_scheme_ref(p);
 908         if (!ao_scheme_is_pool_addr(addr))
 909                 return 1;
 910
 911         orig_offset = pool_offset(addr);
 912         offset = move_map(orig_offset);
 913
 914         if (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS && do_note_cons) {
 915                 note_cons(orig_offset);
 916                 ret = 1;
 917         } else {
 918                 uint8_t type = ao_scheme_poly_base_type(p);
 919                 const struct ao_scheme_type *lisp_type;
 920
 921                 if (type == AO_SCHEME_OTHER)
 922                         type = ao_scheme_other_type(ao_scheme_pool + offset);
 923
 924                 lisp_type = ao_scheme_types[type];
 925 #if DBG_MEM
 926                 if (!lisp_type)
 927                         ao_scheme_abort();
 928 #endif
 929                 /* inline ao_scheme_move to save stack space */
 930                 MDBG_MOVE("move object %d\n", MDBG_OFFSET(addr));
 931                 MDBG_MOVE_IN();
 932                 ret = ao_scheme_move_memory(lisp_type, &addr);
 933                 if (!ret) {
 934                         MDBG_MOVE("move recurse\n");
 935                         lisp_type->move(addr);
 936                 }
 937                 MDBG_MOVE_OUT();
 938         }
 939
 940         /* Re-write the poly value */
 941         if (offset != orig_offset) {
 942                 ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p));
 943                 MDBG_MOVE("poly %d moved %d -> %d\n",
 944                           ao_scheme_poly_type(np), orig_offset, offset);
 945                 *ref = np;
 946         }
 947         return ret;
 948 }
 949
 950 #if DBG_MEM
 951 static void
 952 ao_scheme_validate(void)
 953 {
 954         chunk_low = 0;
 955         memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk));
 956         walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref);
 957 }
 958
 959 int dbg_allocs;
 960
 961 #endif
 962
 963 void *
 964 ao_scheme_alloc(int size)
 965 {
 966         void    *addr;
 967
 968         MDBG_DO(++dbg_allocs);
 969         MDBG_DO(if (dbg_validate) ao_scheme_validate());
 970         size = ao_scheme_size_round(size);
 971         if (AO_SCHEME_POOL - ao_scheme_top < size &&
 972             ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size &&
 973             ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size)
 974         {
 975                 ao_scheme_error(AO_SCHEME_OOM, "out of memory");
 976                 return NULL;
 977         }
 978         addr = ao_scheme_pool + ao_scheme_top;
 979         ao_scheme_top += size;
 980         MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size);
 981         return addr;
 982 }
 983
 984 void
 985 ao_scheme_poly_stash(ao_poly p)
 986 {
 987         assert(stash_poly_ptr < AO_SCHEME_NUM_STASH);
 988         stash_poly[stash_poly_ptr++] = p;
 989 }
 990
 991 ao_poly
 992 ao_scheme_poly_fetch(void)
 993 {
 994         ao_poly p;
 995
 996         assert (stash_poly_ptr > 0);
 997         p = stash_poly[--stash_poly_ptr];
 998         stash_poly[stash_poly_ptr] = AO_SCHEME_NIL;
 999         return p;
1000 }
1001
1002 int
1003 ao_scheme_print_mark_addr(void *addr)
1004 {
1005         int     offset;
1006
1007 #if DBG_MEM
1008         if (ao_scheme_collecting)
1009                 ao_scheme_abort();
1010 #endif
1011
1012         if (!ao_scheme_is_pool_addr(addr))
1013                 return 0;
1014
1015         if (!ao_scheme_print_cleared) {
1016                 ao_scheme_print_cleared = 1;
1017                 memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy));
1018         }
1019         offset = pool_offset(addr);
1020         if (busy(ao_scheme_busy, offset))
1021                 return 1;
1022         mark(ao_scheme_busy, offset);
1023         return 0;
1024 }
1025
1026 void
1027 ao_scheme_print_clear_addr(void *addr)
1028 {
1029         int     offset;
1030
1031 #if DBG_MEM
1032         if (ao_scheme_collecting)
1033                 ao_scheme_abort();
1034 #endif
1035
1036         if (!ao_scheme_is_pool_addr(addr))
1037                 return;
1038
1039         if (!ao_scheme_print_cleared)
1040                 return;
1041         offset = pool_offset(addr);
1042         clear(ao_scheme_busy, offset);
1043 }
1044
1045 /* Notes that printing has started */
1046 void
1047 ao_scheme_print_start(void)
1048 {
1049         ao_scheme_printing++;
1050 }
1051
1052 /* Notes that printing has ended. Returns 1 if printing is still going on */
1053 int
1054 ao_scheme_print_stop(void)
1055 {
1056         ao_scheme_printing--;
1057         if (ao_scheme_printing != 0)
1058                 return 1;
1059         ao_scheme_print_cleared = 0;
1060         return 0;
1061 }