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