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                 /*
 627                  * Limit amount of chunk array used in mapping moves
 628                  * to the active region
 629                  */
 630                 chunk_first = i;
 631                 chunk_low = ao_scheme_chunk[i].old_offset;
 632
 633                 /* Copy all of the objects */
 634                 for (; i < chunk_last; i++) {
 635                         uint16_t        size = ao_scheme_chunk[i].size;
 636
 637 #if DBG_MEM
 638                         if (!size)
 639                                 ao_scheme_abort();
 640 #endif
 641
 642                         MDBG_MOVE("chunk %d %d -> %d\n",
 643                                   ao_scheme_chunk[i].old_offset,
 644                                   size,
 645                                   top);
 646                         ao_scheme_chunk[i].new_offset = top;
 647
 648                         memmove(&ao_scheme_pool[top],
 649                                 &ao_scheme_pool[ao_scheme_chunk[i].old_offset],
 650                                 size);
 651
 652                         top += size;
 653                 }
 654
 655                 if (chunk_first < chunk_last) {
 656                         /* Relocate all references to the objects */
 657                         walk(ao_scheme_move, ao_scheme_poly_move);
 658
 659 #if DBG_MEM_RECORD
 660                         ao_scheme_record_free(move_record);
 661                         move_record = ao_scheme_record_save();
 662                         if (mark_record && move_record)
 663                                 ao_scheme_record_compare("move", mark_record, move_record);
 664 #endif
 665                 }
 666
 667 #if DBG_MEM_STATS
 668                 loops++;
 669 #endif
 670                 /* If we ran into the end of the heap, then
 671                  * there's no need to keep walking
 672                  */
 673                 if (chunk_last != AO_SCHEME_NCHUNK)
 674                         break;
 675
 676                 /* Next loop starts right above this loop */
 677                 chunk_low = chunk_high;
 678         }
 679
 680 #if DBG_MEM_STATS
 681         /* Collect stats */
 682         ++ao_scheme_collects[style];
 683         ao_scheme_freed[style] += ao_scheme_top - top;
 684         ao_scheme_loops[style] += loops;
 685 #endif
 686
 687         ao_scheme_top = top;
 688         if (style == AO_SCHEME_COLLECT_FULL)
 689                 ao_scheme_last_top = top;
 690
 691         MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk));
 692                 walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref));
 693
 694 #if DBG_MEM_STACK
 695         fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth);
 696 #endif
 697         MDBG_DO(--ao_scheme_collecting);
 698         return AO_SCHEME_POOL - ao_scheme_top;
 699 }
 700
 701 #if DBG_FREE_CONS
 702 void
 703 ao_scheme_cons_check(struct ao_scheme_cons *cons)
 704 {
 705         ao_poly cdr;
 706         int offset;
 707
 708         chunk_low = 0;
 709         reset_chunks();
 710         walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref);
 711         while (cons) {
 712                 if (!AO_SCHEME_IS_POOL(cons))
 713                         break;
 714                 offset = pool_offset(cons);
 715                 if (busy(ao_scheme_busy, offset)) {
 716                         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));
 717                         abort();
 718                 }
 719                 cdr = cons->cdr;
 720                 if (!ao_scheme_is_pair(cdr))
 721                         break;
 722                 cons = ao_scheme_poly_cons(cdr);
 723         }
 724 }
 725 #endif
 726
 727 /*
 728  * Mark interfaces for objects
 729  */
 730
 731
 732 /*
 733  * Note a reference to memory and collect information about a few
 734  * object sizes at a time
 735  */
 736
 737 int
 738 ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr)
 739 {
 740         int offset;
 741         if (!AO_SCHEME_IS_POOL(addr))
 742                 return 1;
 743
 744         offset = pool_offset(addr);
 745         MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr));
 746         if (busy(ao_scheme_busy, offset)) {
 747                 MDBG_MOVE("already marked\n");
 748                 return 1;
 749         }
 750         mark(ao_scheme_busy, offset);
 751         note_chunk(offset, ao_scheme_size(type, addr));
 752         return 0;
 753 }
 754
 755 /*
 756  * Mark an object and all that it refereces
 757  */
 758 static int
 759 ao_scheme_mark(const struct ao_scheme_type *type, void *addr)
 760 {
 761         int ret;
 762         MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr));
 763         MDBG_MOVE_IN();
 764         ret = ao_scheme_mark_memory(type, addr);
 765         if (!ret) {
 766                 MDBG_MOVE("mark recurse\n");
 767                 type->mark(addr);
 768         }
 769         MDBG_MOVE_OUT();
 770         return ret;
 771 }
 772
 773 /*
 774  * Mark an object, unless it is a cons cell and
 775  * do_note_cons is set. In that case, just
 776  * set a bit in the cons note array; those
 777  * will be marked in a separate pass to avoid
 778  * deep recursion in the collector
 779  */
 780 int
 781 ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons)
 782 {
 783         uint8_t type;
 784         void    *addr;
 785         int     ret;
 786
 787         type = ao_scheme_poly_base_type(p);
 788
 789         if (type == AO_SCHEME_INT)
 790                 return 1;
 791
 792         addr = ao_scheme_ref(p);
 793         if (!AO_SCHEME_IS_POOL(addr))
 794                 return 1;
 795
 796         if (type == AO_SCHEME_CONS && do_note_cons) {
 797                 note_cons(pool_offset(addr));
 798                 return 1;
 799         } else {
 800                 const struct ao_scheme_type *lisp_type;
 801
 802                 if (type == AO_SCHEME_OTHER)
 803                         type = ao_scheme_other_type(addr);
 804
 805                 lisp_type = ao_scheme_types[type];
 806 #if DBG_MEM
 807                 if (!lisp_type)
 808                         ao_scheme_abort();
 809 #endif
 810
 811                 MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr));
 812                 MDBG_MOVE_IN();
 813                 ret = ao_scheme_mark_memory(lisp_type, addr);
 814                 if (!ret) {
 815                         MDBG_MOVE("mark recurse\n");
 816                         lisp_type->mark(addr);
 817                 }
 818                 MDBG_MOVE_OUT();
 819                 return ret;
 820         }
 821 }
 822
 823 /*
 824  * Find the current location of an object
 825  * based on the original location. For unmoved
 826  * objects, this is simple. For moved objects,
 827  * go search for it
 828  */
 829
 830 static uint16_t
 831 move_map(uint16_t offset)
 832 {
 833         int             l;
 834
 835         if (offset < chunk_low || chunk_high <= offset)
 836                 return offset;
 837
 838         l = find_chunk(offset);
 839
 840 #if DBG_MEM
 841         if (ao_scheme_chunk[l].old_offset != offset)
 842                 ao_scheme_abort();
 843 #endif
 844         return ao_scheme_chunk[l].new_offset;
 845 }
 846
 847 int
 848 ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref)
 849 {
 850         void            *addr = *ref;
 851         uint16_t        offset, orig_offset;
 852
 853         if (!AO_SCHEME_IS_POOL(addr))
 854                 return 1;
 855
 856         (void) type;
 857
 858         MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr));
 859         orig_offset = pool_offset(addr);
 860         offset = move_map(orig_offset);
 861         if (offset != orig_offset) {
 862                 MDBG_MOVE("update ref %d %d -> %d\n",
 863                           AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1,
 864                           orig_offset, offset);
 865                 *ref = ao_scheme_pool + offset;
 866         }
 867         if (busy(ao_scheme_busy, offset)) {
 868                 MDBG_MOVE("already moved\n");
 869                 return 1;
 870         }
 871         mark(ao_scheme_busy, offset);
 872         ao_scheme_record(type, addr, ao_scheme_size(type, addr));
 873         return 0;
 874 }
 875
 876 static int
 877 ao_scheme_move(const struct ao_scheme_type *type, void **ref)
 878 {
 879         int ret;
 880         MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref));
 881         MDBG_MOVE_IN();
 882         ret = ao_scheme_move_memory(type, ref);
 883         if (!ret) {
 884                 MDBG_MOVE("move recurse\n");
 885                 type->move(*ref);
 886         }
 887         MDBG_MOVE_OUT();
 888         return ret;
 889 }
 890
 891 int
 892 ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons)
 893 {
 894         ao_poly         p = *ref;
 895         int             ret;
 896         void            *addr;
 897         uint16_t        offset, orig_offset;
 898
 899         if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT)
 900                 return 1;
 901
 902         addr = ao_scheme_ref(p);
 903         if (!AO_SCHEME_IS_POOL(addr))
 904                 return 1;
 905
 906         orig_offset = pool_offset(addr);
 907         offset = move_map(orig_offset);
 908
 909         if (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS && do_note_cons) {
 910                 note_cons(orig_offset);
 911                 ret = 1;
 912         } else {
 913                 uint8_t type = ao_scheme_poly_base_type(p);
 914                 const struct ao_scheme_type *lisp_type;
 915
 916                 if (type == AO_SCHEME_OTHER)
 917                         type = ao_scheme_other_type(ao_scheme_pool + offset);
 918
 919                 lisp_type = ao_scheme_types[type];
 920 #if DBG_MEM
 921                 if (!lisp_type)
 922                         ao_scheme_abort();
 923 #endif
 924                 /* inline ao_scheme_move to save stack space */
 925                 MDBG_MOVE("move object %d\n", MDBG_OFFSET(addr));
 926                 MDBG_MOVE_IN();
 927                 ret = ao_scheme_move_memory(lisp_type, &addr);
 928                 if (!ret) {
 929                         MDBG_MOVE("move recurse\n");
 930                         lisp_type->move(addr);
 931                 }
 932                 MDBG_MOVE_OUT();
 933         }
 934
 935         /* Re-write the poly value */
 936         if (offset != orig_offset) {
 937                 ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p));
 938                 MDBG_MOVE("poly %d moved %d -> %d\n",
 939                           ao_scheme_poly_type(np), orig_offset, offset);
 940                 *ref = np;
 941         }
 942         return ret;
 943 }
 944
 945 #if DBG_MEM
 946 static void
 947 ao_scheme_validate(void)
 948 {
 949         chunk_low = 0;
 950         memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk));
 951         walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref);
 952 }
 953
 954 int dbg_allocs;
 955
 956 #endif
 957
 958 void *
 959 ao_scheme_alloc(int size)
 960 {
 961         void    *addr;
 962
 963         MDBG_DO(++dbg_allocs);
 964         MDBG_DO(if (dbg_validate) ao_scheme_validate());
 965         size = ao_scheme_size_round(size);
 966         if (AO_SCHEME_POOL - ao_scheme_top < size &&
 967             ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size &&
 968             ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size)
 969         {
 970                 ao_scheme_error(AO_SCHEME_OOM, "out of memory");
 971                 return NULL;
 972         }
 973         addr = ao_scheme_pool + ao_scheme_top;
 974         ao_scheme_top += size;
 975         MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size);
 976         return addr;
 977 }
 978
 979 void
 980 ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons)
 981 {
 982         assert(save_cons[id] == 0);
 983         save_cons[id] = cons;
 984 }
 985
 986 struct ao_scheme_cons *
 987 ao_scheme_cons_fetch(int id)
 988 {
 989         struct ao_scheme_cons *cons = save_cons[id];
 990         save_cons[id] = NULL;
 991         return cons;
 992 }
 993
 994 void
 995 ao_scheme_poly_stash(int id, ao_poly poly)
 996 {
 997         assert(save_poly[id] == AO_SCHEME_NIL);
 998         save_poly[id] = poly;
 999 }
1000
1001 ao_poly
1002 ao_scheme_poly_fetch(int id)
1003 {
1004         ao_poly poly = save_poly[id];
1005         save_poly[id] = AO_SCHEME_NIL;
1006         return poly;
1007 }
1008
1009 void
1010 ao_scheme_string_stash(int id, struct ao_scheme_string *string)
1011 {
1012         assert(save_string[id] == NULL);
1013         save_string[id] = string;
1014 }
1015
1016 struct ao_scheme_string *
1017 ao_scheme_string_fetch(int id)
1018 {
1019         struct ao_scheme_string *string = save_string[id];
1020         save_string[id] = NULL;
1021         return string;
1022 }
1023
1024 void
1025 ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame)
1026 {
1027         assert(save_frame[id] == NULL);
1028         save_frame[id] = frame;
1029 }
1030
1031 struct ao_scheme_frame *
1032 ao_scheme_frame_fetch(int id)
1033 {
1034         struct ao_scheme_frame *frame = save_frame[id];
1035         save_frame[id] = NULL;
1036         return frame;
1037 }
1038
1039 int
1040 ao_scheme_print_mark_addr(void *addr)
1041 {
1042         int     offset;
1043
1044 #if DBG_MEM
1045         if (ao_scheme_collecting)
1046                 ao_scheme_abort();
1047 #endif
1048
1049         if (!AO_SCHEME_IS_POOL(addr))
1050                 return 1;
1051
1052         if (!ao_scheme_print_cleared) {
1053                 ao_scheme_print_cleared = 1;
1054                 memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy));
1055         }
1056         offset = pool_offset(addr);
1057         if (busy(ao_scheme_busy, offset))
1058                 return 1;
1059         mark(ao_scheme_busy, offset);
1060         return 0;
1061 }
1062
1063 int
1064 ao_scheme_print_mark_poly(ao_poly p)
1065 {
1066         uint8_t type = ao_scheme_poly_base_type(p);
1067
1068         if (type == AO_SCHEME_INT)
1069                 return 1;
1070         return ao_scheme_print_mark_addr(ao_scheme_ref(p));
1071 }
1072
1073 /* Notes that printing has started */
1074 void
1075 ao_scheme_print_start(void)
1076 {
1077         ao_scheme_printing++;
1078 }
1079
1080 /* Notes that printing has ended */
1081 void
1082 ao_scheme_print_stop(void)
1083 {
1084         ao_scheme_printing--;
1085         if (ao_scheme_printing == 0)
1086                 ao_scheme_print_cleared = 0;
1087 }