src/runtime/gc.c

   1 /*
   2  * Stop and Copy GC based on Cheney's algorithm.
   3  *
   4  * $Header$
   5  *
   6  * Written by Christopher Hoover.
   7  */
   8
   9
  10 #include <stdio.h>
  11 #include <sys/time.h>
  12 #include <sys/resource.h>
  13 #include <signal.h>
  14 #include "runtime.h"
  15 #include "sbcl.h"
  16 #include "os.h"
  17 #include "gc.h"
  18 #include "globals.h"
  19 #include "interrupt.h"
  20 #include "validate.h"
  21 #include "lispregs.h"
  22 #include "interr.h"
  23 #if 0
  24 #define PRINTNOISE
  25 #define DEBUG_SPACE_PREDICATES
  26 #define DEBUG_SCAVENGE_VERBOSE
  27 #define DEBUG_COPY_VERBOSE
  28 #define DEBUG_CODE_GC
  29 #endif
  30
  31 static lispobj *from_space;
  32 static lispobj *from_space_free_pointer;
  33
  34 static lispobj *new_space;
  35 static lispobj *new_space_free_pointer;
  36
  37 static int (*scavtab[256])(lispobj *where, lispobj object);
  38 static lispobj (*transother[256])(lispobj object);
  39 static int (*sizetab[256])(lispobj *where);
  40
  41 static struct weak_pointer *weak_pointers;
  42
  43 static void scavenge(lispobj *start, u32 nwords);
  44 static void scavenge_newspace(void);
  45 static void scavenge_interrupt_contexts(void);
  46 static void scan_weak_pointers(void);
  47 static int scav_lose(lispobj *where, lispobj object);
  48
  49 #define gc_abort() lose("GC invariant lost!  File \"%s\", line %d\n", \
  50                         __FILE__, __LINE__)
  51
  52 #if 1
  53 #define gc_assert(ex) do { \
  54         if (!(ex)) gc_abort(); \
  55 } while (0)
  56 #else
  57 #define gc_assert(ex)
  58 #endif
  59
  60 #define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
  61
  62 \f
  63 /* Predicates */
  64
  65 #if defined(DEBUG_SPACE_PREDICATES)
  66
  67 boolean from_space_p(lispobj object)
  68 {
  69         lispobj *ptr;
  70
  71         /* this can be called for untagged pointers as well as for
  72            descriptors, so this assertion's not applicable
  73            gc_assert(Pointerp(object));
  74         */
  75         ptr = (lispobj *) PTR(object);
  76
  77         return ((from_space <= ptr) &&
  78                 (ptr < from_space_free_pointer));
  79 }
  80
  81 boolean new_space_p(lispobj object)
  82 {
  83         lispobj *ptr;
  84
  85         gc_assert(Pointerp(object));
  86
  87         ptr = (lispobj *) PTR(object);
  88
  89         return ((new_space <= ptr) &&
  90                 (ptr < new_space_free_pointer));
  91 }
  92
  93 #else
  94
  95 #define from_space_p(ptr) \
  96         ((from_space <= ((lispobj *) ptr)) && \
  97          (((lispobj *) ptr) < from_space_free_pointer))
  98
  99 #define new_space_p(ptr) \
 100         ((new_space <= ((lispobj *) ptr)) && \
 101          (((lispobj *) ptr) < new_space_free_pointer))
 102
 103 #endif
 104
 105 \f
 106 /* Copying Objects */
 107
 108 static lispobj
 109 copy_object(lispobj object, int nwords)
 110 {
 111         int tag;
 112         lispobj *new;
 113         lispobj *source, *dest;
 114
 115         gc_assert(Pointerp(object));
 116         gc_assert(from_space_p(object));
 117         gc_assert((nwords & 0x01) == 0);
 118
 119         /* get tag of object */
 120         tag = LowtagOf(object);
 121
 122         /* allocate space */
 123         new = new_space_free_pointer;
 124         new_space_free_pointer += nwords;
 125
 126         dest = new;
 127         source = (lispobj *) PTR(object);
 128
 129 #ifdef DEBUG_COPY_VERBOSE
 130         fprintf(stderr,"Copying %d words from %p to %p\n", nwords,source,new);
 131 #endif
 132
 133         /* copy the object */
 134         while (nwords > 0) {
 135             dest[0] = source[0];
 136             dest[1] = source[1];
 137             dest += 2;
 138             source += 2;
 139             nwords -= 2;
 140         }
 141         /* return lisp pointer of new object */
 142         return (lispobj)(LOW_WORD(new) | tag);
 143 }
 144
 145 \f
 146 /* Collect Garbage */
 147
 148 #ifdef PRINTNOISE
 149 static double tv_diff(struct timeval *x, struct timeval *y)
 150 {
 151     return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
 152             ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
 153 }
 154 #endif
 155
 156 #define BYTES_ZERO_BEFORE_END (1<<12)
 157
 158 #ifdef alpha
 159 #define U32 u32
 160 #else
 161 #define U32 unsigned long
 162 #endif
 163 static void zero_stack(void)
 164 {
 165     U32 *ptr = (U32 *)current_control_stack_pointer;
 166  search:
 167     do {
 168         if (*ptr)
 169             goto fill;
 170         ptr++;
 171     } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
 172     return;
 173  fill:
 174     do {
 175         *ptr++ = 0;
 176     } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
 177
 178     goto search;
 179 }
 180 #undef U32
 181
 182
 183 /* this is not generational.  It's called with a last_gen arg, which we shun.
 184  */
 185
 186 void collect_garbage(unsigned ignore)
 187 {
 188 #ifdef PRINTNOISE
 189 struct timeval start_tv, stop_tv;
 190         struct rusage start_rusage, stop_rusage;
 191         double real_time, system_time, user_time;
 192         double percent_retained, gc_rate;
 193         unsigned long size_discarded;
 194         unsigned long size_retained;
 195 #endif
 196         lispobj *current_static_space_free_pointer;
 197         unsigned long static_space_size;
 198         unsigned long control_stack_size, binding_stack_size;
 199         sigset_t tmp, old;
 200
 201 #ifdef PRINTNOISE
 202         printf("[Collecting garbage ... \n");
 203
 204         getrusage(RUSAGE_SELF, &start_rusage);
 205         gettimeofday(&start_tv, (struct timezone *) 0);
 206 #endif
 207
 208         sigemptyset(&tmp);
 209         sigaddset_blockable(&tmp);
 210         sigprocmask(SIG_BLOCK, &tmp, &old);
 211
 212         current_static_space_free_pointer =
 213             (lispobj *) ((unsigned long)
 214                          SymbolValue(STATIC_SPACE_FREE_POINTER));
 215
 216
 217         /* Set up from space and new space pointers. */
 218
 219         from_space = current_dynamic_space;
 220 #ifndef ibmrt
 221         from_space_free_pointer = dynamic_space_free_pointer;
 222 #else
 223         from_space_free_pointer = (lispobj *)SymbolValue(ALLOCATION_POINTER);
 224 #endif
 225
 226         fprintf(stderr,"from_space = %lx\n",
 227                 (unsigned long) current_dynamic_space);
 228         if (current_dynamic_space == (lispobj *) DYNAMIC_0_SPACE_START)
 229             new_space = (lispobj *)DYNAMIC_1_SPACE_START;
 230         else if (current_dynamic_space == (lispobj *) DYNAMIC_1_SPACE_START)
 231             new_space = (lispobj *) DYNAMIC_0_SPACE_START;
 232         else {
 233             lose("GC lossage.  Current dynamic space is bogus!\n");
 234         }
 235         new_space_free_pointer = new_space;
 236
 237
 238         /* Initialize the weak pointer list. */
 239         weak_pointers = (struct weak_pointer *) NULL;
 240
 241
 242         /* Scavenge all of the roots. */
 243 #ifdef PRINTNOISE
 244         printf("Scavenging interrupt contexts ...\n");
 245 #endif
 246         scavenge_interrupt_contexts();
 247
 248 #ifdef PRINTNOISE
 249         printf("Scavenging interrupt handlers (%d bytes) ...\n",
 250                (int)sizeof(interrupt_handlers));
 251 #endif
 252         scavenge((lispobj *) interrupt_handlers,
 253                  sizeof(interrupt_handlers) / sizeof(lispobj));
 254
 255         /* _size quantities are in units of sizeof(lispobj) - i.e. 4 */
 256         control_stack_size =
 257             current_control_stack_pointer-
 258             (lispobj *)CONTROL_STACK_START;
 259 #ifdef PRINTNOISE
 260         printf("Scavenging the control stack at %p (%ld words) ...\n",
 261                ((lispobj *)CONTROL_STACK_START),
 262                control_stack_size);
 263 #endif
 264         scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size);
 265
 266
 267 #ifdef ibmrt
 268         binding_stack_size =
 269             (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack;
 270 #else
 271         binding_stack_size =
 272           current_binding_stack_pointer -
 273             (lispobj *)BINDING_STACK_START;
 274 #endif
 275 #ifdef PRINTNOISE
 276         printf("Scavenging the binding stack %x - %x (%d words) ...\n",
 277                BINDING_STACK_START,current_binding_stack_pointer,
 278                (int)(binding_stack_size));
 279 #endif
 280         scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size);
 281
 282         static_space_size =
 283             current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START;
 284 #ifdef PRINTNOISE
 285         printf("Scavenging static space %x - %x (%d words) ...\n",
 286                STATIC_SPACE_START,current_static_space_free_pointer,
 287                (int)(static_space_size));
 288 #endif
 289         scavenge(((lispobj *)STATIC_SPACE_START), static_space_size);
 290
 291         /* Scavenge newspace. */
 292 #ifdef PRINTNOISE
 293         printf("Scavenging new space (%d bytes) ...\n",
 294                (int)((new_space_free_pointer - new_space) * sizeof(lispobj)));
 295 #endif
 296         scavenge_newspace();
 297
 298
 299 #if defined(DEBUG_PRINT_GARBAGE)
 300         print_garbage(from_space, from_space_free_pointer);
 301 #endif
 302
 303         /* Scan the weak pointers. */
 304 #ifdef PRINTNOISE
 305         printf("Scanning weak pointers ...\n");
 306 #endif
 307         scan_weak_pointers();
 308
 309
 310         /* Flip spaces. */
 311 #ifdef PRINTNOISE
 312         printf("Flipping spaces ...\n");
 313 #endif
 314
 315         os_zero((os_vm_address_t) current_dynamic_space,
 316                 (os_vm_size_t) DYNAMIC_SPACE_SIZE);
 317
 318         current_dynamic_space = new_space;
 319 #ifndef ibmrt
 320         dynamic_space_free_pointer = new_space_free_pointer;
 321 #else
 322         SetSymbolValue(ALLOCATION_POINTER, (lispobj)new_space_free_pointer);
 323 #endif
 324
 325 #ifdef PRINTNOISE
 326         size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
 327         size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
 328 #endif
 329
 330         /* Zero stack. */
 331 #ifdef PRINTNOISE
 332         printf("Zeroing empty part of control stack ...\n");
 333 #endif
 334         zero_stack();
 335
 336         sigprocmask(SIG_SETMASK, &old, 0);
 337
 338
 339 #ifdef PRINTNOISE
 340         gettimeofday(&stop_tv, (struct timezone *) 0);
 341         getrusage(RUSAGE_SELF, &stop_rusage);
 342
 343         printf("done.]\n");
 344
 345         percent_retained = (((float) size_retained) /
 346                              ((float) size_discarded)) * 100.0;
 347
 348         printf("Total of %ld bytes out of %ld bytes retained (%3.2f%%).\n",
 349                size_retained, size_discarded, percent_retained);
 350
 351         real_time = tv_diff(&stop_tv, &start_tv);
 352         user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
 353         system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
 354
 355 #if 0
 356         printf("Statistics:\n");
 357         printf("%10.2f sec of real time\n", real_time);
 358         printf("%10.2f sec of user time,\n", user_time);
 359         printf("%10.2f sec of system time.\n", system_time);
 360 #else
 361         printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
 362                real_time, user_time, system_time);
 363 #endif
 364
 365         gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
 366
 367         printf("%10.2f M bytes/sec collected.\n", gc_rate);
 368 #endif
 369 }
 370
 371 \f
 372 /* Scavenging */
 373
 374 #define DIRECT_SCAV 0
 375
 376 static void
 377 scavenge(lispobj *start, u32 nwords)
 378 {
 379         while (nwords > 0) {
 380                 lispobj object;
 381                 int type, words_scavenged;
 382
 383                 object = *start;
 384                 type = TypeOf(object);
 385
 386 #if defined(DEBUG_SCAVENGE_VERBOSE)
 387                 fprintf(stderr,"Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
 388                        (unsigned long) start, (unsigned long) object, type);
 389 #endif
 390
 391 #if DIRECT_SCAV
 392                 words_scavenged = (scavtab[type])(start, object);
 393 #else
 394                 if (Pointerp(object)) {
 395                     /* It be a pointer. */
 396                     if (from_space_p(object)) {
 397                         /* It currently points to old space.  Check for a */
 398                         /* forwarding pointer. */
 399                         lispobj first_word;
 400
 401                         first_word = *((lispobj *)PTR(object));
 402                         if (Pointerp(first_word) && new_space_p(first_word)) {
 403                             /* Yep, there be a forwarding pointer. */
 404                             *start = first_word;
 405                             words_scavenged = 1;
 406                         }
 407                         else {
 408                             /* Scavenge that pointer. */
 409                             words_scavenged = (scavtab[type])(start, object);
 410                         }
 411                     }
 412                     else {
 413                         /* It points somewhere other than oldspace.  Leave */
 414                         /* it alone. */
 415                         words_scavenged = 1;
 416                     }
 417                 }
 418                 else if(nwords==1) {
 419                     /* there are some situations where an
 420                        other-immediate may end up in a descriptor
 421                        register.  I'm not sure whether this is
 422                        supposed to happen, but if it does then we
 423                        don't want to (a) barf or (b) scavenge over the
 424                        data-block, because there isn't one.  So, if
 425                        we're checking a single word and it's anything
 426                        other than a pointer, just hush it up */
 427
 428                     words_scavenged=1;
 429                     if((scavtab[type]==scav_lose) ||
 430                        (((scavtab[type])(start,object))>1)) {
 431                         fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p.  If you can\nreproduce this warning, send a test case to sbcl-devel@lists.sourceforge.net\n",
 432                                 object,start);
 433                     }
 434                 }
 435                 else if ((object & 3) == 0) {
 436                     /* It's a fixnum.  Real easy. */
 437                     words_scavenged = 1;
 438                 }
 439                 else {
 440                     /* It's some random header object. */
 441                     words_scavenged = (scavtab[type])(start, object);
 442
 443                 }
 444 #endif
 445                 start += words_scavenged;
 446                 nwords -= words_scavenged;
 447         }
 448         gc_assert(nwords == 0);
 449 }
 450
 451 static void scavenge_newspace(void)
 452 {
 453     lispobj *here, *next;
 454
 455     here = new_space;
 456     while (here < new_space_free_pointer) {
 457         /*      printf("here=%lx, new_space_free_pointer=%lx\n",
 458                 here,new_space_free_pointer); */
 459         next = new_space_free_pointer;
 460         scavenge(here, next - here);
 461         here = next;
 462     }
 463     /* printf("done with newspace\n"); */
 464 }
 465
 466 \f
 467 /* Scavenging Interrupt Contexts */
 468
 469 static int boxed_registers[] = BOXED_REGISTERS;
 470
 471 static void scavenge_interrupt_context(os_context_t *context)
 472 {
 473         int i;
 474 #ifdef reg_LIP
 475         unsigned long lip;
 476         unsigned long lip_offset;
 477         int lip_register_pair;
 478 #endif
 479         unsigned long pc_code_offset;
 480 #ifdef SC_NPC
 481         unsigned long npc_code_offset;
 482 #endif
 483
 484         /* Find the LIP's register pair and calculate its offset */
 485         /* before we scavenge the context. */
 486 #ifdef reg_LIP
 487         lip = *os_context_register_addr(context, reg_LIP);
 488         /*  0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */
 489         lip_offset = 0x7FFFFFFF;
 490         lip_register_pair = -1;
 491         for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
 492                 unsigned long reg;
 493                 long offset;
 494                 int index;
 495
 496                 index = boxed_registers[i];
 497                 reg = *os_context_register_addr(context, index);
 498                 /* would be using PTR if not for integer length issues */
 499                 if ((reg & ~((1L<<lowtag_Bits)-1)) <= lip) {
 500                         offset = lip - reg;
 501                         if (offset < lip_offset) {
 502                                 lip_offset = offset;
 503                                 lip_register_pair = index;
 504                         }
 505                 }
 506         }
 507 #endif reg_LIP
 508
 509         /* Compute the PC's offset from the start of the CODE */
 510         /* register. */
 511         pc_code_offset = *os_context_pc_addr(context) -
 512             *os_context_register_addr(context, reg_CODE);
 513 #ifdef SC_NPC
 514         npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
 515 #endif SC_NPC
 516
 517         /* Scanvenge all boxed registers in the context. */
 518         for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
 519                 int index;
 520                 lispobj foo;
 521
 522                 index = boxed_registers[i];
 523                 foo = *os_context_register_addr(context,index);
 524                 scavenge((lispobj *) &foo, 1);
 525                 *os_context_register_addr(context,index) = foo;
 526
 527                 /* this is unlikely to work as intended on bigendian
 528                  * 64 bit platforms */
 529
 530                 scavenge((lispobj *)
 531                          os_context_register_addr(context, index), 1);
 532         }
 533
 534 #ifdef reg_LIP
 535         /* Fix the LIP */
 536         *os_context_register_addr(context, reg_LIP) =
 537             *os_context_register_addr(context, lip_register_pair) + lip_offset;
 538 #endif reg_LIP
 539
 540         /* Fix the PC if it was in from space */
 541         if (from_space_p(*os_context_pc_addr(context)))
 542             *os_context_pc_addr(context) =
 543                 *os_context_register_addr(context, reg_CODE) + pc_code_offset;
 544 #ifdef SC_NPC
 545         if (from_space_p(SC_NPC(context)))
 546                 SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
 547 #endif SC_NPC
 548 }
 549
 550 void scavenge_interrupt_contexts(void)
 551 {
 552         int i, index;
 553         os_context_t *context;
 554
 555         index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
 556         printf("Number of active contexts: %d\n", index);
 557
 558         for (i = 0; i < index; i++) {
 559                 context = lisp_interrupt_contexts[i];
 560                 scavenge_interrupt_context(context);
 561         }
 562 }
 563
 564 \f
 565 /* Debugging Code */
 566
 567 void print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
 568 {
 569         lispobj *start;
 570         int total_words_not_copied;
 571
 572         printf("Scanning from space ...\n");
 573
 574         total_words_not_copied = 0;
 575         start = from_space;
 576         while (start < from_space_free_pointer) {
 577                 lispobj object;
 578                 int forwardp, type, nwords;
 579                 lispobj header;
 580
 581                 object = *start;
 582                 forwardp = Pointerp(object) && new_space_p(object);
 583
 584                 if (forwardp) {
 585                         int tag;
 586                         lispobj *pointer;
 587
 588                         tag = LowtagOf(object);
 589
 590                         switch (tag) {
 591                         case type_ListPointer:
 592                                 nwords = 2;
 593                                 break;
 594                         case type_InstancePointer:
 595                                 printf("Don't know about instances yet!\n");
 596                                 nwords = 1;
 597                                 break;
 598                         case type_FunctionPointer:
 599                                 nwords = 1;
 600                                 break;
 601                         case type_OtherPointer:
 602                                 pointer = (lispobj *) PTR(object);
 603                                 header = *pointer;
 604                                 type = TypeOf(header);
 605                                 nwords = (sizetab[type])(pointer);
 606                         }
 607                 } else {
 608                         type = TypeOf(object);
 609                         nwords = (sizetab[type])(start);
 610                         total_words_not_copied += nwords;
 611                         printf("%4d words not copied at 0x%16lx; ",
 612                                nwords, (unsigned long) start);
 613                         printf("Header word is 0x%08x\n",
 614                                (unsigned int) object);
 615                 }
 616                 start += nwords;
 617         }
 618         printf("%d total words not copied.\n", total_words_not_copied);
 619 }
 620
 621 \f
 622 /* Code and Code-Related Objects */
 623
 624 #define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
 625
 626 static lispobj trans_function_header(lispobj object);
 627 static lispobj trans_boxed(lispobj object);
 628
 629 #if DIRECT_SCAV
 630 static int
 631 scav_function_pointer(lispobj *where, lispobj object)
 632 {
 633         gc_assert(Pointerp(object));
 634
 635         if (from_space_p(object)) {
 636                 lispobj first, *first_pointer;
 637
 638                 /* object is a pointer into from space.  check to see */
 639                 /* if it has been forwarded */
 640                 first_pointer = (lispobj *) PTR(object);
 641                 first = *first_pointer;
 642
 643                 if (!(Pointerp(first) && new_space_p(first))) {
 644                         int type;
 645                         lispobj copy;
 646
 647                         /* must transport object -- object may point */
 648                         /* to either a function header, a closure */
 649                         /* function header, or to a closure header. */
 650
 651                         type = TypeOf(first);
 652                         switch (type) {
 653                           case type_FunctionHeader:
 654                           case type_ClosureFunctionHeader:
 655                             copy = trans_function_header(object);
 656                             break;
 657                           default:
 658                             copy = trans_boxed(object);
 659                             break;
 660                         }
 661
 662                         first = *first_pointer = copy;
 663                 }
 664
 665                 gc_assert(Pointerp(first));
 666                 gc_assert(!from_space_p(first));
 667
 668                 *where = first;
 669         }
 670         return 1;
 671 }
 672 #else
 673 static int
 674 scav_function_pointer(lispobj *where, lispobj object)
 675 {
 676   lispobj  *first_pointer;
 677   lispobj copy;
 678   lispobj first;
 679   int type;
 680
 681   gc_assert(Pointerp(object));
 682
 683   /* object is a pointer into from space. Not a FP */
 684   first_pointer = (lispobj *) PTR(object);
 685   first = *first_pointer;
 686
 687   /* must transport object -- object may point */
 688   /* to either a function header, a closure */
 689   /* function header, or to a closure header. */
 690
 691   type = TypeOf(first);
 692   switch (type) {
 693   case type_FunctionHeader:
 694   case type_ClosureFunctionHeader:
 695     copy = trans_function_header(object);
 696     break;
 697   default:
 698     copy = trans_boxed(object);
 699     break;
 700   }
 701
 702   first = *first_pointer = copy;
 703
 704   gc_assert(Pointerp(first));
 705   gc_assert(!from_space_p(first));
 706
 707   *where = first;
 708   return 1;
 709 }
 710 #endif
 711
 712 static struct code *
 713 trans_code(struct code *code)
 714 {
 715         struct code *new_code;
 716         lispobj first, l_code, l_new_code;
 717         int nheader_words, ncode_words, nwords;
 718         unsigned long displacement;
 719         lispobj fheaderl, *prev_pointer;
 720
 721 #if defined(DEBUG_CODE_GC)
 722         printf("\nTransporting code object located at 0x%08x.\n",
 723                (unsigned long) code);
 724 #endif
 725
 726         /* if object has already been transported, just return pointer */
 727         first = code->header;
 728         if (Pointerp(first) && new_space_p(first)) {
 729 #ifdef DEBUG_CODE_GC
 730             printf("Was already transported\n");
 731 #endif
 732             return (struct code *) PTR(first);
 733         }
 734
 735         gc_assert(TypeOf(first) == type_CodeHeader);
 736
 737         /* prepare to transport the code vector */
 738         l_code = (lispobj) LOW_WORD(code) | type_OtherPointer;
 739
 740         ncode_words = fixnum_value(code->code_size);
 741         nheader_words = HeaderValue(code->header);
 742         nwords = ncode_words + nheader_words;
 743         nwords = CEILING(nwords, 2);
 744
 745         l_new_code = copy_object(l_code, nwords);
 746         new_code = (struct code *) PTR(l_new_code);
 747
 748         displacement = l_new_code - l_code;
 749
 750 #if defined(DEBUG_CODE_GC)
 751         printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
 752                (unsigned long) code, (unsigned long) new_code);
 753         printf("Code object is %d words long.\n", nwords);
 754 #endif
 755
 756         /* set forwarding pointer */
 757         code->header = l_new_code;
 758
 759         /* set forwarding pointers for all the function headers in the */
 760         /* code object.  also fix all self pointers */
 761
 762         fheaderl = code->entry_points;
 763         prev_pointer = &new_code->entry_points;
 764
 765         while (fheaderl != NIL) {
 766                 struct function *fheaderp, *nfheaderp;
 767                 lispobj nfheaderl;
 768
 769                 fheaderp = (struct function *) PTR(fheaderl);
 770                 gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
 771
 772                 /* calcuate the new function pointer and the new */
 773                 /* function header */
 774                 nfheaderl = fheaderl + displacement;
 775                 nfheaderp = (struct function *) PTR(nfheaderl);
 776
 777                 /* set forwarding pointer */
 778 #ifdef DEBUG_CODE_GC
 779                 printf("fheaderp->header (at %x) <- %x\n",
 780                        &(fheaderp->header) , nfheaderl);
 781 #endif
 782                 fheaderp->header = nfheaderl;
 783
 784                 /* fix self pointer */
 785                 nfheaderp->self = nfheaderl;
 786
 787                 *prev_pointer = nfheaderl;
 788
 789                 fheaderl = fheaderp->next;
 790                 prev_pointer = &nfheaderp->next;
 791         }
 792
 793 #ifndef MACH
 794         os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),
 795                         ncode_words * sizeof(int));
 796 #endif
 797         return new_code;
 798 }
 799
 800 static int
 801 scav_code_header(lispobj *where, lispobj object)
 802 {
 803         struct code *code;
 804         int nheader_words, ncode_words, nwords;
 805         lispobj fheaderl;
 806         struct function *fheaderp;
 807
 808         code = (struct code *) where;
 809         ncode_words = fixnum_value(code->code_size);
 810         nheader_words = HeaderValue(object);
 811         nwords = ncode_words + nheader_words;
 812         nwords = CEILING(nwords, 2);
 813
 814 #if defined(DEBUG_CODE_GC)
 815         printf("\nScavening code object at 0x%08x.\n",
 816                (unsigned long) where);
 817         printf("Code object is %d words long.\n", nwords);
 818         printf("Scavenging boxed section of code data block (%d words).\n",
 819                nheader_words - 1);
 820 #endif
 821
 822         /* Scavenge the boxed section of the code data block */
 823         scavenge(where + 1, nheader_words - 1);
 824
 825         /* Scavenge the boxed section of each function object in the */
 826         /* code data block */
 827         fheaderl = code->entry_points;
 828         while (fheaderl != NIL) {
 829                 fheaderp = (struct function *) PTR(fheaderl);
 830                 gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
 831
 832 #if defined(DEBUG_CODE_GC)
 833                 printf("Scavenging boxed section of entry point located at 0x%08x.\n",
 834                        (unsigned long) PTR(fheaderl));
 835 #endif
 836                 scavenge(&fheaderp->name, 1);
 837                 scavenge(&fheaderp->arglist, 1);
 838                 scavenge(&fheaderp->type, 1);
 839
 840                 fheaderl = fheaderp->next;
 841         }
 842
 843         return nwords;
 844 }
 845
 846 static lispobj
 847 trans_code_header(lispobj object)
 848 {
 849         struct code *ncode;
 850
 851         ncode = trans_code((struct code *) PTR(object));
 852         return (lispobj) LOW_WORD(ncode) | type_OtherPointer;
 853 }
 854
 855 static int
 856 size_code_header(lispobj *where)
 857 {
 858         struct code *code;
 859         int nheader_words, ncode_words, nwords;
 860
 861         code = (struct code *) where;
 862
 863         ncode_words = fixnum_value(code->code_size);
 864         nheader_words = HeaderValue(code->header);
 865         nwords = ncode_words + nheader_words;
 866         nwords = CEILING(nwords, 2);
 867
 868         return nwords;
 869 }
 870
 871
 872 static int
 873 scav_return_pc_header(lispobj *where, lispobj object)
 874 {
 875     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
 876     fprintf(stderr, "Return PC Header.\n");
 877     fprintf(stderr, "where = 0x%p, object = 0x%x", where, object);
 878     lose(NULL);
 879     return 0;
 880 }
 881
 882 static lispobj
 883 trans_return_pc_header(lispobj object)
 884 {
 885         struct function *return_pc;
 886         unsigned long offset;
 887         struct code *code, *ncode;
 888         lispobj ret;
 889         return_pc = (struct function *) PTR(object);
 890         offset = HeaderValue(return_pc->header)  * 4 ;
 891
 892         /* Transport the whole code object */
 893         code = (struct code *) ((unsigned long) return_pc - offset);
 894 #ifdef DEBUG_CODE_GC
 895         printf("trans_return_pc_header object=%x, code=%lx\n",object,code);
 896 #endif
 897         ncode = trans_code(code);
 898         if(object==0x304748d7) {
 899             /* ldb_monitor(); */
 900         }
 901         ret= ((lispobj) LOW_WORD(ncode) + offset) | type_OtherPointer;
 902 #ifdef DEBUG_CODE_GC
 903         printf("trans_return_pc_header returning %x\n",ret);
 904 #endif
 905         return ret;
 906 }
 907
 908 /* On the 386, closures hold a pointer to the raw address instead of the
 909    function object, so we can use CALL [$FDEFN+const] to invoke the function
 910    without loading it into a register.  Given that code objects don't move,
 911    we don't need to update anything, but we do have to figure out that the
 912    function is still live. */
 913 #ifdef i386
 914 static
 915 scav_closure_header(where, object)
 916 lispobj *where, object;
 917 {
 918         struct closure *closure;
 919         lispobj fun;
 920
 921         closure = (struct closure *)where;
 922         fun = closure->function - RAW_ADDR_OFFSET;
 923         scavenge(&fun, 1);
 924
 925         return 2;
 926 }
 927 #endif
 928
 929 static int
 930 scav_function_header(lispobj *where, lispobj object)
 931 {
 932     fprintf(stderr, "GC lossage.  Should not be scavenging a ");
 933     fprintf(stderr, "Function Header.\n");
 934     fprintf(stderr, "where = 0x%p, object = 0x%08x",
 935             where, (unsigned int) object);
 936     lose(NULL);
 937     return 0;
 938 }
 939
 940 static lispobj
 941 trans_function_header(lispobj object)
 942 {
 943         struct function *fheader;
 944         unsigned long offset;
 945         struct code *code, *ncode;
 946
 947         fheader = (struct function *) PTR(object);
 948         offset = HeaderValue(fheader->header) * 4;
 949
 950         /* Transport the whole code object */
 951         code = (struct code *) ((unsigned long) fheader - offset);
 952         ncode = trans_code(code);
 953
 954         return ((lispobj) LOW_WORD(ncode) + offset) | type_FunctionPointer;
 955 }
 956
 957
 958 \f
 959 /* Instances */
 960
 961 #if DIRECT_SCAV
 962 static int
 963 scav_instance_pointer(lispobj *where, lispobj object)
 964 {
 965     if (from_space_p(object)) {
 966         lispobj first, *first_pointer;
 967
 968         /* object is a pointer into from space.  check to see */
 969         /* if it has been forwarded */
 970         first_pointer = (lispobj *) PTR(object);
 971         first = *first_pointer;
 972
 973         if (!(Pointerp(first) && new_space_p(first)))
 974             first = *first_pointer = trans_boxed(object);
 975         *where = first;
 976     }
 977     return 1;
 978 }
 979 #else
 980 static int
 981 scav_instance_pointer(lispobj *where, lispobj object)
 982 {
 983   lispobj  *first_pointer;
 984
 985   /* object is a pointer into from space.  Not a FP */
 986   first_pointer = (lispobj *) PTR(object);
 987
 988   *where = *first_pointer = trans_boxed(object);
 989   return 1;
 990 }
 991 #endif
 992
 993 \f
 994 /* Lists and Conses */
 995
 996 static lispobj trans_list(lispobj object);
 997
 998 #if DIRECT_SCAV
 999 static int
1000 scav_list_pointer(lispobj *where, lispobj object)
1001 {
1002         gc_assert(Pointerp(object));
1003
1004         if (from_space_p(object)) {
1005                 lispobj first, *first_pointer;
1006
1007                 /* object is a pointer into from space.  check to see */
1008                 /* if it has been forwarded */
1009                 first_pointer = (lispobj *) PTR(object);
1010                 first = *first_pointer;
1011
1012                 if (!(Pointerp(first) && new_space_p(first)))
1013                         first = *first_pointer = trans_list(object);
1014
1015                 gc_assert(Pointerp(first));
1016                 gc_assert(!from_space_p(first));
1017
1018                 *where = first;
1019         }
1020         return 1;
1021 }
1022 #else
1023 static int
1024 scav_list_pointer(lispobj *where, lispobj object)
1025 {
1026   lispobj first, *first_pointer;
1027
1028   gc_assert(Pointerp(object));
1029
1030   /* object is a pointer into from space.  Not a FP. */
1031   first_pointer = (lispobj *) PTR(object);
1032
1033   first = *first_pointer = trans_list(object);
1034
1035   gc_assert(Pointerp(first));
1036   gc_assert(!from_space_p(first));
1037
1038   *where = first;
1039   return 1;
1040 }
1041 #endif
1042
1043 static lispobj
1044 trans_list(lispobj object)
1045 {
1046         lispobj new_list_pointer;
1047         struct cons *cons, *new_cons;
1048
1049         cons = (struct cons *) PTR(object);
1050
1051         /* ### Don't use copy_object here. */
1052         new_list_pointer = copy_object(object, 2);
1053         new_cons = (struct cons *) PTR(new_list_pointer);
1054
1055         /* Set forwarding pointer. */
1056         cons->car = new_list_pointer;
1057
1058         /* Try to linearize the list in the cdr direction to help reduce */
1059         /* paging. */
1060
1061         while (1) {
1062                 lispobj cdr, new_cdr, first;
1063                 struct cons *cdr_cons, *new_cdr_cons;
1064
1065                 cdr = cons->cdr;
1066
1067                 if (LowtagOf(cdr) != type_ListPointer ||
1068                     !from_space_p(cdr) ||
1069                     (Pointerp(first = *(lispobj *)PTR(cdr)) &&
1070                      new_space_p(first)))
1071                         break;
1072
1073                 cdr_cons = (struct cons *) PTR(cdr);
1074
1075                 /* ### Don't use copy_object here */
1076                 new_cdr = copy_object(cdr, 2);
1077                 new_cdr_cons = (struct cons *) PTR(new_cdr);
1078
1079                 /* Set forwarding pointer */
1080                 cdr_cons->car = new_cdr;
1081
1082                 /* Update the cdr of the last cons copied into new */
1083                 /* space to keep the newspace scavenge from having to */
1084                 /* do it. */
1085                 new_cons->cdr = new_cdr;
1086
1087                 cons = cdr_cons;
1088                 new_cons = new_cdr_cons;
1089         }
1090
1091         return new_list_pointer;
1092 }
1093
1094 \f
1095 /* Scavenging and Transporting Other Pointers */
1096
1097 #if DIRECT_SCAV
1098 static int
1099 scav_other_pointer(lispobj *where, lispobj object)
1100 {
1101         gc_assert(Pointerp(object));
1102
1103         if (from_space_p(object)) {
1104                 lispobj first, *first_pointer;
1105
1106                 /* object is a pointer into from space.  check to see */
1107                 /* if it has been forwarded */
1108                 first_pointer = (lispobj *) PTR(object);
1109                 first = *first_pointer;
1110
1111                 if (!(Pointerp(first) && new_space_p(first)))
1112                         first = *first_pointer =
1113                                 (transother[TypeOf(first)])(object);
1114
1115                 gc_assert(Pointerp(first));
1116                 gc_assert(!from_space_p(first));
1117
1118                 *where = first;
1119         }
1120         return 1;
1121 }
1122 #else
1123 static int
1124 scav_other_pointer(lispobj *where, lispobj object)
1125 {
1126   lispobj first, *first_pointer;
1127
1128   gc_assert(Pointerp(object));
1129
1130   /* Object is a pointer into from space - not a FP */
1131   first_pointer = (lispobj *) PTR(object);
1132   first = *first_pointer = (transother[TypeOf(*first_pointer)])(object);
1133
1134   gc_assert(Pointerp(first));
1135   gc_assert(!from_space_p(first));
1136
1137   *where = first;
1138   return 1;
1139 }
1140 #endif
1141
1142 \f
1143 /* Immediate, Boxed, and Unboxed Objects */
1144
1145 static int
1146 size_pointer(lispobj *where)
1147 {
1148     return 1;
1149 }
1150
1151 static int
1152 scav_immediate(lispobj *where, lispobj object)
1153 {
1154     return 1;
1155 }
1156
1157 static lispobj
1158 trans_immediate(lispobj object)
1159 {
1160     fprintf(stderr, "GC lossage.  Trying to transport an immediate!?\n");
1161     lose(NULL);
1162     return NIL;
1163 }
1164
1165 static int
1166 size_immediate(lispobj *where)
1167 {
1168     return 1;
1169 }
1170
1171
1172 static int
1173 scav_boxed(lispobj *where, lispobj object)
1174 {
1175     return 1;
1176 }
1177
1178 static lispobj
1179 trans_boxed(lispobj object)
1180 {
1181         lispobj header;
1182         unsigned long length;
1183
1184         gc_assert(Pointerp(object));
1185
1186         header = *((lispobj *) PTR(object));
1187         length = HeaderValue(header) + 1;
1188         length = CEILING(length, 2);
1189
1190         return copy_object(object, length);
1191 }
1192
1193 static int
1194 size_boxed(lispobj *where)
1195 {
1196         lispobj header;
1197         unsigned long length;
1198
1199         header = *where;
1200         length = HeaderValue(header) + 1;
1201         length = CEILING(length, 2);
1202
1203         return length;
1204 }
1205
1206 /* Note: on the sparc we don't have to do anything special for fdefns, */
1207 /* cause the raw-addr has a function lowtag. */
1208 #ifndef sparc
1209 static int
1210 scav_fdefn(lispobj *where, lispobj object)
1211 {
1212     struct fdefn *fdefn;
1213
1214     fdefn = (struct fdefn *)where;
1215
1216     if ((char *)(fdefn->function + RAW_ADDR_OFFSET)
1217         == (char *)((unsigned long)(fdefn->raw_addr))) {
1218         scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
1219         fdefn->raw_addr = (u32)  ((char *) LOW_WORD(fdefn->function)) + RAW_ADDR_OFFSET;
1220         return sizeof(struct fdefn) / sizeof(lispobj);
1221     }
1222     else
1223         return 1;
1224 }
1225 #endif
1226
1227 static int
1228 scav_unboxed(lispobj *where, lispobj object)
1229 {
1230         unsigned long length;
1231
1232         length = HeaderValue(object) + 1;
1233         length = CEILING(length, 2);
1234
1235         return length;
1236 }
1237
1238 static lispobj
1239 trans_unboxed(lispobj object)
1240 {
1241         lispobj header;
1242         unsigned long length;
1243
1244
1245         gc_assert(Pointerp(object));
1246
1247         header = *((lispobj *) PTR(object));
1248         length = HeaderValue(header) + 1;
1249         length = CEILING(length, 2);
1250
1251         return copy_object(object, length);
1252 }
1253
1254 static int
1255 size_unboxed(lispobj *where)
1256 {
1257         lispobj header;
1258         unsigned long length;
1259
1260         header = *where;
1261         length = HeaderValue(header) + 1;
1262         length = CEILING(length, 2);
1263
1264         return length;
1265 }
1266
1267 \f
1268 /* Vector-Like Objects */
1269
1270 #define NWORDS(x,y) (CEILING((x),(y)) / (y))
1271
1272 static int
1273 scav_string(lispobj *where, lispobj object)
1274 {
1275         struct vector *vector;
1276         int length, nwords;
1277
1278         /* NOTE: Strings contain one more byte of data than the length */
1279         /* slot indicates. */
1280
1281         vector = (struct vector *) where;
1282         length = fixnum_value(vector->length) + 1;
1283         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1284
1285         return nwords;
1286 }
1287
1288 static lispobj
1289 trans_string(lispobj object)
1290 {
1291         struct vector *vector;
1292         int length, nwords;
1293
1294         gc_assert(Pointerp(object));
1295
1296         /* NOTE: Strings contain one more byte of data than the length */
1297         /* slot indicates. */
1298
1299         vector = (struct vector *) PTR(object);
1300         length = fixnum_value(vector->length) + 1;
1301         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1302
1303         return copy_object(object, nwords);
1304 }
1305
1306 static int
1307 size_string(lispobj *where)
1308 {
1309         struct vector *vector;
1310         int length, nwords;
1311
1312         /* NOTE: Strings contain one more byte of data than the length */
1313         /* slot indicates. */
1314
1315         vector = (struct vector *) where;
1316         length = fixnum_value(vector->length) + 1;
1317         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1318
1319         return nwords;
1320 }
1321
1322 static int
1323 scav_vector(lispobj *where, lispobj object)
1324 {
1325     if (HeaderValue(object) == subtype_VectorValidHashing)
1326         *where = (subtype_VectorMustRehash<<type_Bits) | type_SimpleVector;
1327
1328     return 1;
1329 }
1330
1331
1332 static lispobj
1333 trans_vector(lispobj object)
1334 {
1335         struct vector *vector;
1336         int length, nwords;
1337
1338         gc_assert(Pointerp(object));
1339
1340         vector = (struct vector *) PTR(object);
1341
1342         length = fixnum_value(vector->length);
1343         nwords = CEILING(length + 2, 2);
1344
1345         return copy_object(object, nwords);
1346 }
1347
1348 static int
1349 size_vector(lispobj *where)
1350 {
1351         struct vector *vector;
1352         int length, nwords;
1353
1354         vector = (struct vector *) where;
1355         length = fixnum_value(vector->length);
1356         nwords = CEILING(length + 2, 2);
1357
1358         return nwords;
1359 }
1360
1361
1362 static int
1363 scav_vector_bit(lispobj *where, lispobj object)
1364 {
1365         struct vector *vector;
1366         int length, nwords;
1367
1368         vector = (struct vector *) where;
1369         length = fixnum_value(vector->length);
1370         nwords = CEILING(NWORDS(length, 32) + 2, 2);
1371
1372         return nwords;
1373 }
1374
1375 static lispobj
1376 trans_vector_bit(lispobj object)
1377 {
1378         struct vector *vector;
1379         int length, nwords;
1380
1381         gc_assert(Pointerp(object));
1382
1383         vector = (struct vector *) PTR(object);
1384         length = fixnum_value(vector->length);
1385         nwords = CEILING(NWORDS(length, 32) + 2, 2);
1386
1387         return copy_object(object, nwords);
1388 }
1389
1390 static int
1391 size_vector_bit(lispobj *where)
1392 {
1393         struct vector *vector;
1394         int length, nwords;
1395
1396         vector = (struct vector *) where;
1397         length = fixnum_value(vector->length);
1398         nwords = CEILING(NWORDS(length, 32) + 2, 2);
1399
1400         return nwords;
1401 }
1402
1403
1404 static int
1405 scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
1406 {
1407         struct vector *vector;
1408         int length, nwords;
1409
1410         vector = (struct vector *) where;
1411         length = fixnum_value(vector->length);
1412         nwords = CEILING(NWORDS(length, 16) + 2, 2);
1413
1414         return nwords;
1415 }
1416
1417 static lispobj
1418 trans_vector_unsigned_byte_2(lispobj object)
1419 {
1420         struct vector *vector;
1421         int length, nwords;
1422
1423         gc_assert(Pointerp(object));
1424
1425         vector = (struct vector *) PTR(object);
1426         length = fixnum_value(vector->length);
1427         nwords = CEILING(NWORDS(length, 16) + 2, 2);
1428
1429         return copy_object(object, nwords);
1430 }
1431
1432 static int
1433 size_vector_unsigned_byte_2(lispobj *where)
1434 {
1435         struct vector *vector;
1436         int length, nwords;
1437
1438         vector = (struct vector *) where;
1439         length = fixnum_value(vector->length);
1440         nwords = CEILING(NWORDS(length, 16) + 2, 2);
1441
1442         return nwords;
1443 }
1444
1445
1446 static int
1447 scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
1448 {
1449         struct vector *vector;
1450         int length, nwords;
1451
1452         vector = (struct vector *) where;
1453         length = fixnum_value(vector->length);
1454         nwords = CEILING(NWORDS(length, 8) + 2, 2);
1455
1456         return nwords;
1457 }
1458
1459 static lispobj
1460 trans_vector_unsigned_byte_4(lispobj object)
1461 {
1462         struct vector *vector;
1463         int length, nwords;
1464
1465         gc_assert(Pointerp(object));
1466
1467         vector = (struct vector *) PTR(object);
1468         length = fixnum_value(vector->length);
1469         nwords = CEILING(NWORDS(length, 8) + 2, 2);
1470
1471         return copy_object(object, nwords);
1472 }
1473
1474 static int
1475 size_vector_unsigned_byte_4(lispobj *where)
1476 {
1477         struct vector *vector;
1478         int length, nwords;
1479
1480         vector = (struct vector *) where;
1481         length = fixnum_value(vector->length);
1482         nwords = CEILING(NWORDS(length, 8) + 2, 2);
1483
1484         return nwords;
1485 }
1486
1487
1488 static int
1489 scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
1490 {
1491         struct vector *vector;
1492         int length, nwords;
1493
1494         vector = (struct vector *) where;
1495         length = fixnum_value(vector->length);
1496         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1497
1498         return nwords;
1499 }
1500
1501 static lispobj
1502 trans_vector_unsigned_byte_8(lispobj object)
1503 {
1504         struct vector *vector;
1505         int length, nwords;
1506
1507         gc_assert(Pointerp(object));
1508
1509         vector = (struct vector *) PTR(object);
1510         length = fixnum_value(vector->length);
1511         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1512
1513         return copy_object(object, nwords);
1514 }
1515
1516 static int
1517 size_vector_unsigned_byte_8(lispobj *where)
1518 {
1519         struct vector *vector;
1520         int length, nwords;
1521
1522         vector = (struct vector *) where;
1523         length = fixnum_value(vector->length);
1524         nwords = CEILING(NWORDS(length, 4) + 2, 2);
1525
1526         return nwords;
1527 }
1528
1529
1530 static int
1531 scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
1532 {
1533         struct vector *vector;
1534         int length, nwords;
1535
1536         vector = (struct vector *) where;
1537         length = fixnum_value(vector->length);
1538         nwords = CEILING(NWORDS(length, 2) + 2, 2);
1539
1540         return nwords;
1541 }
1542
1543 static lispobj
1544 trans_vector_unsigned_byte_16(lispobj object)
1545 {
1546         struct vector *vector;
1547         int length, nwords;
1548
1549         gc_assert(Pointerp(object));
1550
1551         vector = (struct vector *) PTR(object);
1552         length = fixnum_value(vector->length);
1553         nwords = CEILING(NWORDS(length, 2) + 2, 2);
1554
1555         return copy_object(object, nwords);
1556 }
1557
1558 static int
1559 size_vector_unsigned_byte_16(lispobj *where)
1560 {
1561         struct vector *vector;
1562         int length, nwords;
1563
1564         vector = (struct vector *) where;
1565         length = fixnum_value(vector->length);
1566         nwords = CEILING(NWORDS(length, 2) + 2, 2);
1567
1568         return nwords;
1569 }
1570
1571
1572 static int
1573 scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
1574 {
1575         struct vector *vector;
1576         int length, nwords;
1577
1578         vector = (struct vector *) where;
1579         length = fixnum_value(vector->length);
1580         nwords = CEILING(length + 2, 2);
1581
1582         return nwords;
1583 }
1584
1585 static lispobj
1586 trans_vector_unsigned_byte_32(lispobj object)
1587 {
1588         struct vector *vector;
1589         int length, nwords;
1590
1591         gc_assert(Pointerp(object));
1592
1593         vector = (struct vector *) PTR(object);
1594         length = fixnum_value(vector->length);
1595         nwords = CEILING(length + 2, 2);
1596
1597         return copy_object(object, nwords);
1598 }
1599
1600 static int
1601 size_vector_unsigned_byte_32(lispobj *where)
1602 {
1603         struct vector *vector;
1604         int length, nwords;
1605
1606         vector = (struct vector *) where;
1607         length = fixnum_value(vector->length);
1608         nwords = CEILING(length + 2, 2);
1609
1610         return nwords;
1611 }
1612
1613
1614 static int
1615 scav_vector_single_float(lispobj *where, lispobj object)
1616 {
1617         struct vector *vector;
1618         int length, nwords;
1619
1620         vector = (struct vector *) where;
1621         length = fixnum_value(vector->length);
1622         nwords = CEILING(length + 2, 2);
1623
1624         return nwords;
1625 }
1626
1627 static lispobj
1628 trans_vector_single_float(lispobj object)
1629 {
1630         struct vector *vector;
1631         int length, nwords;
1632
1633         gc_assert(Pointerp(object));
1634
1635         vector = (struct vector *) PTR(object);
1636         length = fixnum_value(vector->length);
1637         nwords = CEILING(length + 2, 2);
1638
1639         return copy_object(object, nwords);
1640 }
1641
1642 static int
1643 size_vector_single_float(lispobj *where)
1644 {
1645         struct vector *vector;
1646         int length, nwords;
1647
1648         vector = (struct vector *) where;
1649         length = fixnum_value(vector->length);
1650         nwords = CEILING(length + 2, 2);
1651
1652         return nwords;
1653 }
1654
1655
1656 static int
1657 scav_vector_double_float(lispobj *where, lispobj object)
1658 {
1659         struct vector *vector;
1660         int length, nwords;
1661
1662         vector = (struct vector *) where;
1663         length = fixnum_value(vector->length);
1664         nwords = CEILING(length * 2 + 2, 2);
1665
1666         return nwords;
1667 }
1668
1669 static lispobj
1670 trans_vector_double_float(lispobj object)
1671 {
1672         struct vector *vector;
1673         int length, nwords;
1674
1675         gc_assert(Pointerp(object));
1676
1677         vector = (struct vector *) PTR(object);
1678         length = fixnum_value(vector->length);
1679         nwords = CEILING(length * 2 + 2, 2);
1680
1681         return copy_object(object, nwords);
1682 }
1683
1684 static int
1685 size_vector_double_float(lispobj *where)
1686 {
1687         struct vector *vector;
1688         int length, nwords;
1689
1690         vector = (struct vector *) where;
1691         length = fixnum_value(vector->length);
1692         nwords = CEILING(length * 2 + 2, 2);
1693
1694         return nwords;
1695 }
1696
1697
1698 #ifdef type_SimpleArrayLongFloat
1699 static int
1700 scav_vector_long_float(lispobj *where, lispobj object)
1701 {
1702         struct vector *vector;
1703         int length, nwords;
1704
1705         vector = (struct vector *) where;
1706         length = fixnum_value(vector->length);
1707 #ifdef sparc
1708         nwords = CEILING(length * 4 + 2, 2);
1709 #endif
1710
1711         return nwords;
1712 }
1713
1714 static lispobj
1715 trans_vector_long_float(lispobj object)
1716 {
1717         struct vector *vector;
1718         int length, nwords;
1719
1720         gc_assert(Pointerp(object));
1721
1722         vector = (struct vector *) PTR(object);
1723         length = fixnum_value(vector->length);
1724 #ifdef sparc
1725         nwords = CEILING(length * 4 + 2, 2);
1726 #endif
1727
1728         return copy_object(object, nwords);
1729 }
1730
1731 static int
1732 size_vector_long_float(lispobj *where)
1733 {
1734         struct vector *vector;
1735         int length, nwords;
1736
1737         vector = (struct vector *) where;
1738         length = fixnum_value(vector->length);
1739 #ifdef sparc
1740         nwords = CEILING(length * 4 + 2, 2);
1741 #endif
1742
1743         return nwords;
1744 }
1745 #endif
1746
1747
1748 #ifdef type_SimpleArrayComplexSingleFloat
1749 static int
1750 scav_vector_complex_single_float(lispobj *where, lispobj object)
1751 {
1752         struct vector *vector;
1753         int length, nwords;
1754
1755         vector = (struct vector *) where;
1756         length = fixnum_value(vector->length);
1757         nwords = CEILING(length * 2 + 2, 2);
1758
1759         return nwords;
1760 }
1761
1762 static lispobj
1763 trans_vector_complex_single_float(lispobj object)
1764 {
1765         struct vector *vector;
1766         int length, nwords;
1767
1768         gc_assert(Pointerp(object));
1769
1770         vector = (struct vector *) PTR(object);
1771         length = fixnum_value(vector->length);
1772         nwords = CEILING(length * 2 + 2, 2);
1773
1774         return copy_object(object, nwords);
1775 }
1776
1777 static int
1778 size_vector_complex_single_float(lispobj *where)
1779 {
1780         struct vector *vector;
1781         int length, nwords;
1782
1783         vector = (struct vector *) where;
1784         length = fixnum_value(vector->length);
1785         nwords = CEILING(length * 2 + 2, 2);
1786
1787         return nwords;
1788 }
1789 #endif
1790
1791 #ifdef type_SimpleArrayComplexDoubleFloat
1792 static int
1793 scav_vector_complex_double_float(lispobj *where, lispobj object)
1794 {
1795         struct vector *vector;
1796         int length, nwords;
1797
1798         vector = (struct vector *) where;
1799         length = fixnum_value(vector->length);
1800         nwords = CEILING(length * 4 + 2, 2);
1801
1802         return nwords;
1803 }
1804
1805 static lispobj
1806 trans_vector_complex_double_float(lispobj object)
1807 {
1808         struct vector *vector;
1809         int length, nwords;
1810
1811         gc_assert(Pointerp(object));
1812
1813         vector = (struct vector *) PTR(object);
1814         length = fixnum_value(vector->length);
1815         nwords = CEILING(length * 4 + 2, 2);
1816
1817         return copy_object(object, nwords);
1818 }
1819
1820 static int
1821 size_vector_complex_double_float(lispobj *where)
1822 {
1823         struct vector *vector;
1824         int length, nwords;
1825
1826         vector = (struct vector *) where;
1827         length = fixnum_value(vector->length);
1828         nwords = CEILING(length * 4 + 2, 2);
1829
1830         return nwords;
1831 }
1832 #endif
1833
1834 #ifdef type_SimpleArrayComplexLongFloat
1835 static int
1836 scav_vector_complex_long_float(lispobj *where, lispobj object)
1837 {
1838         struct vector *vector;
1839         int length, nwords;
1840
1841         vector = (struct vector *) where;
1842         length = fixnum_value(vector->length);
1843 #ifdef sparc
1844         nwords = CEILING(length * 8 + 2, 2);
1845 #endif
1846
1847         return nwords;
1848 }
1849
1850 static lispobj
1851 trans_vector_complex_long_float(lispobj object)
1852 {
1853         struct vector *vector;
1854         int length, nwords;
1855
1856         gc_assert(Pointerp(object));
1857
1858         vector = (struct vector *) PTR(object);
1859         length = fixnum_value(vector->length);
1860 #ifdef sparc
1861         nwords = CEILING(length * 8 + 2, 2);
1862 #endif
1863
1864         return copy_object(object, nwords);
1865 }
1866
1867 static int
1868 size_vector_complex_long_float(lispobj *where)
1869 {
1870         struct vector *vector;
1871         int length, nwords;
1872
1873         vector = (struct vector *) where;
1874         length = fixnum_value(vector->length);
1875 #ifdef sparc
1876         nwords = CEILING(length * 8 + 2, 2);
1877 #endif
1878
1879         return nwords;
1880 }
1881 #endif
1882
1883 \f
1884 /* Weak Pointers */
1885
1886 #define WEAK_POINTER_NWORDS \
1887         CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
1888
1889 static int
1890 scav_weak_pointer(lispobj *where, lispobj object)
1891 {
1892         /* Do not let GC scavenge the value slot of the weak pointer */
1893         /* (that is why it is a weak pointer).  Note:  we could use */
1894         /* the scav_unboxed method here. */
1895
1896         return WEAK_POINTER_NWORDS;
1897 }
1898
1899 static lispobj
1900 trans_weak_pointer(lispobj object)
1901 {
1902         lispobj copy;
1903         struct weak_pointer *wp;
1904
1905         gc_assert(Pointerp(object));
1906
1907 #if defined(DEBUG_WEAK)
1908         printf("Transporting weak pointer from 0x%08x\n", object);
1909 #endif
1910
1911         /* Need to remember where all the weak pointers are that have */
1912         /* been transported so they can be fixed up in a post-GC pass. */
1913
1914         copy = copy_object(object, WEAK_POINTER_NWORDS);
1915         wp = (struct weak_pointer *) PTR(copy);
1916
1917
1918         /* Push the weak pointer onto the list of weak pointers. */
1919         wp->next = LOW_WORD(weak_pointers);
1920         weak_pointers = wp;
1921
1922         return copy;
1923 }
1924
1925 static int
1926 size_weak_pointer(lispobj *where)
1927 {
1928         return WEAK_POINTER_NWORDS;
1929 }
1930
1931 void scan_weak_pointers(void)
1932 {
1933         struct weak_pointer *wp;
1934
1935         for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
1936              wp = (struct weak_pointer *)((unsigned long)wp->next)) {
1937                 lispobj value;
1938                 lispobj first, *first_pointer;
1939
1940                 value = wp->value;
1941
1942 #if defined(DEBUG_WEAK)
1943                 printf("Weak pointer at 0x%p\n",  wp);
1944                 printf("Value: 0x%08x\n", (unsigned int) value);
1945 #endif
1946
1947                 if (!(Pointerp(value) && from_space_p(value)))
1948                         continue;
1949
1950                 /* Now, we need to check if the object has been */
1951                 /* forwarded.  If it has been, the weak pointer is */
1952                 /* still good and needs to be updated.  Otherwise, the */
1953                 /* weak pointer needs to be nil'ed out. */
1954
1955                 first_pointer = (lispobj *) PTR(value);
1956                 first = *first_pointer;
1957
1958 #if defined(DEBUG_WEAK)
1959                 printf("First: 0x%08x\n", (unsigned long) first);
1960 #endif
1961
1962                 if (Pointerp(first) && new_space_p(first))
1963                         wp->value = first;
1964                 else {
1965                         wp->value = NIL;
1966                         wp->broken = T;
1967                 }
1968         }
1969 }
1970
1971
1972 \f
1973 /* Initialization */
1974
1975 static int
1976 scav_lose(lispobj *where, lispobj object)
1977 {
1978     fprintf(stderr, "GC lossage.  No scavenge function for object 0x%08x (at 0x%016lx)\n",
1979             (unsigned int) object, (unsigned long)where);
1980     lose(NULL);
1981     return 0;
1982 }
1983
1984 static lispobj
1985 trans_lose(lispobj object)
1986 {
1987     fprintf(stderr, "GC lossage.  No transport function for object 0x%08x\n",
1988             (unsigned int)object);
1989     lose(NULL);
1990     return NIL;
1991 }
1992
1993 static int
1994 size_lose(lispobj *where)
1995 {
1996         fprintf(stderr, "Size lossage.  No size function for object at 0x%p\n",
1997                 where);
1998         fprintf(stderr, "First word of object: 0x%08x\n",
1999                 (u32) *where);
2000         return 1;
2001 }
2002
2003 void gc_init(void)
2004 {
2005         int i;
2006
2007         /* Scavenge Table */
2008         for (i = 0; i < 256; i++)
2009             scavtab[i] = scav_lose;
2010         /* scavtab[i] = scav_immediate; */
2011
2012         for (i = 0; i < 32; i++) {
2013                 scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
2014                 scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
2015                 /* OtherImmediate0 */
2016                 scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
2017                 scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
2018                 scavtab[type_InstancePointer|(i<<3)] = scav_instance_pointer;
2019                 /* OtherImmediate1 */
2020                 scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
2021         }
2022
2023         scavtab[type_Bignum] = scav_unboxed;
2024         scavtab[type_Ratio] = scav_boxed;
2025         scavtab[type_SingleFloat] = scav_unboxed;
2026         scavtab[type_DoubleFloat] = scav_unboxed;
2027 #ifdef type_LongFloat
2028         scavtab[type_LongFloat] = scav_unboxed;
2029 #endif
2030         scavtab[type_Complex] = scav_boxed;
2031 #ifdef type_ComplexSingleFloat
2032         scavtab[type_ComplexSingleFloat] = scav_unboxed;
2033 #endif
2034 #ifdef type_ComplexDoubleFloat
2035         scavtab[type_ComplexDoubleFloat] = scav_unboxed;
2036 #endif
2037 #ifdef type_ComplexLongFloat
2038         scavtab[type_ComplexLongFloat] = scav_unboxed;
2039 #endif
2040         scavtab[type_SimpleArray] = scav_boxed;
2041         scavtab[type_SimpleString] = scav_string;
2042         scavtab[type_SimpleBitVector] = scav_vector_bit;
2043         scavtab[type_SimpleVector] = scav_vector;
2044         scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
2045         scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
2046         scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
2047         scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
2048         scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
2049 #ifdef type_SimpleArraySignedByte8
2050         scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
2051 #endif
2052 #ifdef type_SimpleArraySignedByte16
2053         scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
2054 #endif
2055 #ifdef type_SimpleArraySignedByte30
2056         scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
2057 #endif
2058 #ifdef type_SimpleArraySignedByte32
2059         scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
2060 #endif
2061         scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
2062         scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
2063 #ifdef type_SimpleArrayLongFloat
2064         scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
2065 #endif
2066 #ifdef type_SimpleArrayComplexSingleFloat
2067         scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float;
2068 #endif
2069 #ifdef type_SimpleArrayComplexDoubleFloat
2070         scavtab[type_SimpleArrayComplexDoubleFloat] = scav_vector_complex_double_float;
2071 #endif
2072 #ifdef type_SimpleArrayComplexLongFloat
2073         scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
2074 #endif
2075         scavtab[type_ComplexString] = scav_boxed;
2076         scavtab[type_ComplexBitVector] = scav_boxed;
2077         scavtab[type_ComplexVector] = scav_boxed;
2078         scavtab[type_ComplexArray] = scav_boxed;
2079         scavtab[type_CodeHeader] = scav_code_header;
2080         scavtab[type_FunctionHeader] = scav_function_header;
2081         scavtab[type_ClosureFunctionHeader] = scav_function_header;
2082         scavtab[type_ReturnPcHeader] = scav_return_pc_header;
2083 #ifdef i386
2084         scavtab[type_ClosureHeader] = scav_closure_header;
2085         scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
2086         scavtab[type_ByteCodeFunction] = scav_closure_header;
2087         scavtab[type_ByteCodeClosure] = scav_closure_header;
2088         /*      scavtab[type_DylanFunctionHeader] = scav_closure_header; */
2089 #else
2090         scavtab[type_ClosureHeader] = scav_boxed;
2091         scavtab[type_FuncallableInstanceHeader] = scav_boxed;
2092         scavtab[type_ByteCodeFunction] = scav_boxed;
2093         scavtab[type_ByteCodeClosure] = scav_boxed;
2094         /* scavtab[type_DylanFunctionHeader] = scav_boxed; */
2095 #endif
2096         scavtab[type_ValueCellHeader] = scav_boxed;
2097         scavtab[type_SymbolHeader] = scav_boxed;
2098         scavtab[type_BaseChar] = scav_immediate;
2099         scavtab[type_Sap] = scav_unboxed;
2100         scavtab[type_UnboundMarker] = scav_immediate;
2101         scavtab[type_WeakPointer] = scav_weak_pointer;
2102         scavtab[type_InstanceHeader] = scav_boxed;
2103 #ifndef sparc
2104         scavtab[type_Fdefn] = scav_fdefn;
2105 #else
2106         scavtab[type_Fdefn] = scav_boxed;
2107 #endif
2108
2109         /* Transport Other Table */
2110         for (i = 0; i < 256; i++)
2111                 transother[i] = trans_lose;
2112
2113         transother[type_Bignum] = trans_unboxed;
2114         transother[type_Ratio] = trans_boxed;
2115         transother[type_SingleFloat] = trans_unboxed;
2116         transother[type_DoubleFloat] = trans_unboxed;
2117 #ifdef type_LongFloat
2118         transother[type_LongFloat] = trans_unboxed;
2119 #endif
2120         transother[type_Complex] = trans_boxed;
2121 #ifdef type_ComplexSingleFloat
2122         transother[type_ComplexSingleFloat] = trans_unboxed;
2123 #endif
2124 #ifdef type_ComplexDoubleFloat
2125         transother[type_ComplexDoubleFloat] = trans_unboxed;
2126 #endif
2127 #ifdef type_ComplexLongFloat
2128         transother[type_ComplexLongFloat] = trans_unboxed;
2129 #endif
2130         transother[type_SimpleArray] = trans_boxed;
2131         transother[type_SimpleString] = trans_string;
2132         transother[type_SimpleBitVector] = trans_vector_bit;
2133         transother[type_SimpleVector] = trans_vector;
2134         transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
2135         transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
2136         transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
2137         transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
2138         transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
2139 #ifdef type_SimpleArraySignedByte8
2140         transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
2141 #endif
2142 #ifdef type_SimpleArraySignedByte16
2143         transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
2144 #endif
2145 #ifdef type_SimpleArraySignedByte30
2146         transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
2147 #endif
2148 #ifdef type_SimpleArraySignedByte32
2149         transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
2150 #endif
2151         transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
2152         transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
2153 #ifdef type_SimpleArrayLongFloat
2154         transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
2155 #endif
2156 #ifdef type_SimpleArrayComplexSingleFloat
2157         transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float;
2158 #endif
2159 #ifdef type_SimpleArrayComplexDoubleFloat
2160         transother[type_SimpleArrayComplexDoubleFloat] = trans_vector_complex_double_float;
2161 #endif
2162 #ifdef type_SimpleArrayComplexLongFloat
2163         transother[type_SimpleArrayComplexLongFloat] = trans_vector_complex_long_float;
2164 #endif
2165         transother[type_ComplexString] = trans_boxed;
2166         transother[type_ComplexBitVector] = trans_boxed;
2167         transother[type_ComplexVector] = trans_boxed;
2168         transother[type_ComplexArray] = trans_boxed;
2169         transother[type_CodeHeader] = trans_code_header;
2170         transother[type_FunctionHeader] = trans_function_header;
2171         transother[type_ClosureFunctionHeader] = trans_function_header;
2172         transother[type_ReturnPcHeader] = trans_return_pc_header;
2173         transother[type_ClosureHeader] = trans_boxed;
2174         transother[type_FuncallableInstanceHeader] = trans_boxed;
2175         transother[type_ByteCodeFunction] = trans_boxed;
2176         transother[type_ByteCodeClosure] = trans_boxed;
2177         transother[type_ValueCellHeader] = trans_boxed;
2178         transother[type_SymbolHeader] = trans_boxed;
2179         transother[type_BaseChar] = trans_immediate;
2180         transother[type_Sap] = trans_unboxed;
2181         transother[type_UnboundMarker] = trans_immediate;
2182         transother[type_WeakPointer] = trans_weak_pointer;
2183         transother[type_InstanceHeader] = trans_boxed;
2184         transother[type_Fdefn] = trans_boxed;
2185
2186         /* Size table */
2187
2188         for (i = 0; i < 256; i++)
2189                 sizetab[i] = size_lose;
2190
2191         for (i = 0; i < 32; i++) {
2192                 sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
2193                 sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
2194                 /* OtherImmediate0 */
2195                 sizetab[type_ListPointer|(i<<3)] = size_pointer;
2196                 sizetab[type_OddFixnum|(i<<3)] = size_immediate;
2197                 sizetab[type_InstancePointer|(i<<3)] = size_pointer;
2198                 /* OtherImmediate1 */
2199                 sizetab[type_OtherPointer|(i<<3)] = size_pointer;
2200         }
2201
2202         sizetab[type_Bignum] = size_unboxed;
2203         sizetab[type_Ratio] = size_boxed;
2204         sizetab[type_SingleFloat] = size_unboxed;
2205         sizetab[type_DoubleFloat] = size_unboxed;
2206 #ifdef type_LongFloat
2207         sizetab[type_LongFloat] = size_unboxed;
2208 #endif
2209         sizetab[type_Complex] = size_boxed;
2210 #ifdef type_ComplexSingleFloat
2211         sizetab[type_ComplexSingleFloat] = size_unboxed;
2212 #endif
2213 #ifdef type_ComplexDoubleFloat
2214         sizetab[type_ComplexDoubleFloat] = size_unboxed;
2215 #endif
2216 #ifdef type_ComplexLongFloat
2217         sizetab[type_ComplexLongFloat] = size_unboxed;
2218 #endif
2219         sizetab[type_SimpleArray] = size_boxed;
2220         sizetab[type_SimpleString] = size_string;
2221         sizetab[type_SimpleBitVector] = size_vector_bit;
2222         sizetab[type_SimpleVector] = size_vector;
2223         sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
2224         sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
2225         sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
2226         sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
2227         sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
2228 #ifdef type_SimpleArraySignedByte8
2229         sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
2230 #endif
2231 #ifdef type_SimpleArraySignedByte16
2232         sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
2233 #endif
2234 #ifdef type_SimpleArraySignedByte30
2235         sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
2236 #endif
2237 #ifdef type_SimpleArraySignedByte32
2238         sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
2239 #endif
2240         sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
2241         sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
2242 #ifdef type_SimpleArrayLongFloat
2243         sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
2244 #endif
2245 #ifdef type_SimpleArrayComplexSingleFloat
2246         sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float;
2247 #endif
2248 #ifdef type_SimpleArrayComplexDoubleFloat
2249         sizetab[type_SimpleArrayComplexDoubleFloat] = size_vector_complex_double_float;
2250 #endif
2251 #ifdef type_SimpleArrayComplexLongFloat
2252         sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
2253 #endif
2254         sizetab[type_ComplexString] = size_boxed;
2255         sizetab[type_ComplexBitVector] = size_boxed;
2256         sizetab[type_ComplexVector] = size_boxed;
2257         sizetab[type_ComplexArray] = size_boxed;
2258         sizetab[type_CodeHeader] = size_code_header;
2259 #if 0
2260         /* Shouldn't see these so just lose if it happens */
2261         sizetab[type_FunctionHeader] = size_function_header;
2262         sizetab[type_ClosureFunctionHeader] = size_function_header;
2263         sizetab[type_ReturnPcHeader] = size_return_pc_header;
2264 #endif
2265         sizetab[type_ClosureHeader] = size_boxed;
2266         sizetab[type_FuncallableInstanceHeader] = size_boxed;
2267         sizetab[type_ValueCellHeader] = size_boxed;
2268         sizetab[type_SymbolHeader] = size_boxed;
2269         sizetab[type_BaseChar] = size_immediate;
2270         sizetab[type_Sap] = size_unboxed;
2271         sizetab[type_UnboundMarker] = size_immediate;
2272         sizetab[type_WeakPointer] = size_weak_pointer;
2273         sizetab[type_InstanceHeader] = size_boxed;
2274         sizetab[type_Fdefn] = size_boxed;
2275 }
2276
2277
2278 \f
2279 /* Noise to manipulate the gc trigger stuff. */
2280
2281 #ifndef ibmrt
2282
2283 void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
2284 {
2285     os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
2286         dynamic_usage;
2287     long length =
2288         DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2289
2290     if(addr < (os_vm_address_t)dynamic_space_free_pointer) {
2291         fprintf(stderr,
2292            "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
2293                 (unsigned int)dynamic_usage,
2294                 (os_vm_address_t)dynamic_space_free_pointer
2295                 - (os_vm_address_t)current_dynamic_space);
2296         return;
2297     }
2298     else if (length < 0) {
2299         fprintf(stderr,
2300                 "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n",
2301                 dynamic_usage);
2302         return;
2303     }
2304
2305     addr=os_round_up_to_page(addr);
2306     length=os_trunc_size_to_page(length);
2307
2308 #if defined(SUNOS) || defined(SOLARIS)
2309     os_invalidate(addr,length);
2310 #else
2311     os_protect(addr, length, 0);
2312 #endif
2313
2314     current_auto_gc_trigger = (lispobj *)addr;
2315 }
2316
2317 void clear_auto_gc_trigger(void)
2318 {
2319     if(current_auto_gc_trigger!=NULL){
2320 #if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
2321         os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
2322         os_vm_size_t length=
2323             DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
2324
2325         os_validate(addr,length);
2326 #else
2327         os_protect((os_vm_address_t)current_dynamic_space,
2328                    DYNAMIC_SPACE_SIZE,
2329                    OS_VM_PROT_ALL);
2330 #endif
2331
2332         current_auto_gc_trigger = NULL;
2333     }
2334 }
2335
2336 #endif